MateHistory.hs

module Main where

import Codec.Text.IConv
import Control.Monad
import Data.Bits
import Data.ByteString.Lazy.Char8 (ByteString)
import qualified Data.ByteString.Lazy.Char8 as B
import Data.Time
import Network.Curl
import System.Console.GetOpt
import System.Directory
import System.Environment
import System.Exit
import System.IO
import System.Locale
import System.Process
import Text.Regex.PCRE

-- Supported VCS
data Repository = Git FilePath
    deriving (Read, Show)

-- Configuration
data Config = Config {
        repository :: Repository
    ,   username :: String
    ,   password :: String
    ,   semester :: String
    } deriving (Read, Show)

type Resp = CurlResponse_ [(String, String)] ByteString

defaultConfig = Config {
        repository = Git "972"
    ,   username = "s941522"
    ,   password = ""
    ,   semester = "972"
    }

-- YZU Portal links
url path = "https://portal.yzu.edu.tw" ++ path
logincheck_new = "/logincheck_new.asp"
login_student_in = "/VC/login_student_in.asp"
classlistsall = "/VC/classlistsall.asp"
myclassmate cid = "/VC/contact/myclassmate.asp?CCN=x&PClass=" ++ cid

mkRegex src = makeRegexOpts compOpt execOpt pat :: Regex
    where compOpt = defaultCompOpt .|.
                    compUTF8 .|. compDotAll .|. compUngreedy
          execOpt = defaultExecOpt
          pat = B.pack src

conv = convertFuzzy Transliterate "big5" "utf8"

login h uid pwd = do
    let info = [CurlPostFields ["uid="++uid, "pwd="++pwd], CurlPost True]
    do_curl_ h (url logincheck_new) info :: IO Resp
    resp <- do_curl_ h (url login_student_in) method_GET :: IO Resp
    return $ match (mkRegex "Login_student\\.asp") $ conv $ respBody resp

listCourses h smtr = do
    let opts =
            [ CurlPostFields
                [ "otherSmtr="++smtr
                , "selDepartmentNo=*"
                , "selYear=*"
                ]
            , CurlPost True
            ]
    resp <- do_curl_ h (url classlistsall) opts :: IO Resp
    return $ parseCourseList $ conv $ respBody resp

parseCourseList page = map (map B.unpack . tail) info
    where info = match (mkRegex pat) page
          pat = "PClass=(\\d+_(\\w{2})(\\d{3}_\\w+))&"

getClassmates h cid = do
        resp <- do_curl_ h (url $ myclassmate cid) method_GET :: IO Resp
        return $ format $ parseMates $ conv $ respBody resp

parseMates page = map (dropHead . parseRow) rows
    where dropHead row = if B.null $ head row
                            then drop 8 row
                            else tail row
          parseRow = map last . match (mkRegex pat)
            where pat = "<(?:TD|td)>\\s*(\\S*)\\s*</(?:TD|td)>"
          rows :: [ByteString]
          rows = map last $ match (mkRegex "<tr.*>(.+)</TR>") page

format = B.unlines . map (B.intercalate $ B.pack "\t\t")

-- Options
data Opt = Help
         | ConfigFile FilePath

flags =
    [ Option ['h'] ["help"] (NoArg Help)
        "Print this help message"
    , Option ['f'] ["cinfig-file"] (ReqArg ConfigFile "FILE")
        "Specify configuration file"
    ]

getConfigFromOpts = getArgs >>= parseArgs >>=
                    foldM handleFlag defaultConfig

usageHeader progname = "Usage:  " ++ progname ++ " [opts...]"

parseArgs argv = do
    progname <- getProgName
    case getOpt Permute flags argv of
        (opts, _, []) -> return opts
        (_, _, errs) -> do
            let usage = usageInfo (usageHeader progname) flags
            hPutStrLn stderr $ concat errs ++ usage
            exitWith $ ExitFailure 1

handleFlag conf opt = do
    progname <- getProgName
    case opt of
        Help -> do
            hPutStrLn stderr $ usageInfo (usageHeader progname) flags
            exitWith ExitSuccess
        ConfigFile f -> liftM read $ readFile f

-- VCS commands
runGitCommand = rawSystem "git"
getTimeStamp = getCurrentTime >>=
               return . utcToLocalTime (hoursToTimeZone 8) >>=
               return . formatTime defaultTimeLocale "%F %T"

commit (Git _) = do
    existed <- doesDirectoryExist ".git"
    if existed
        then return ExitSuccess
        else do
            runGitCommand ["init"]
            runGitCommand ["add", "."]
    time <- getTimeStamp
    runGitCommand ["commit", "-a", "-m", time]
    return ()

main = do
    conf <- getConfigFromOpts
    case repository conf of
        Git path -> setCurrentDirectory path

    h <- initialize
    setopts h [CurlCookieJar "/tmp/cookies"]

    success <- login h (username conf) (password conf)
    if success
        then return ()
        else do
            hPutStrLn stderr "login failed"
            exitWith $ ExitFailure 1
    courses <- listCourses h $ semester conf

    forM_ courses $ \cos -> do
        let [cid, dept, id] = cos
        putStrLn cid
        info <- getClassmates h cid

        createDirectoryIfMissing False dept
        setCurrentDirectory dept
        B.writeFile (id++".txt") info
        setCurrentDirectory ".."

    commit $ repository conf