{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeOperators #-} module Main where import Servant ( PlainText , JSON , QueryParam' , QueryFlag , Required , Headers , StdMethod(GET) , Verb , Header , NoContent(..) , err302 , err303 , errHeaders , serveDirectoryWebApp , Get , Post , ReqBody , Proxy(..) , Raw , Accept(..) , addHeader , throwError , type (:>) , type (:<|>) , err404 , (:<|>)(..) ) import qualified Data.Text.IO as TIO import qualified Data.Map.Strict as M import qualified Data.Text as T import Servant.Server (Handler, Server, Application, serve) import Network.Wai.Handler.Warp (run) import Servant.HTML.Lucid (HTML(..)) import qualified Data.Text as T import Lucid.Base import Lucid.Html5 import Data.Maybe (mapMaybe) import Data.Time (getCurrentTime) import Control.Monad.IO.Class (liftIO) import qualified Data.ByteString.Char8 as BS import IndexHtml (index) import StudentHtml (studentPage) import Common (Students, Key) import Control.Exception (catch) type Redirect = Headers '[Header "Location" T.Text] NoContent type Redirect302 = Headers '[Header "Location" T.Text] NoContent type API = Verb 'GET 302 '[PlainText] Redirect :<|> "student" :> QueryParam' '[Required] "student_id" T.Text :> Get '[HTML] (Html ()) :<|> "ban" :> QueryParam' '[Required] "student_id" T.Text :> Get '[HTML] NoContent :<|> "accept" :> QueryParam' '[Required] "student_id" T.Text :> QueryParam' '[Required] "homework" T.Text :> QueryFlag "task_1" :> QueryFlag "task_2" :> QueryFlag "task_3" :> QueryFlag "task_4" :> QueryFlag "task_5" :> QueryFlag "task_6" :> Get '[HTML] NoContent :<|> "index.html" :> Get '[HTML] (Html ()) :<|> "static" :> Raw appendCsvLine :: FilePath -> [T.Text] -> IO () appendCsvLine fp cols = TIO.appendFile fp (T.intercalate "," (map csvEscape cols) <> "\n") where csvEscape t | T.any (`elem` [',','"','\n','\r']) t = "\"" <> T.replace "\"" "\"\"" t <> "\"" | otherwise = t pairs :: [String] -> Students pairs = mapMaybe $ \s -> case split s of (w1:w2:idTok:_) -> Just (idTok, (w1 <> " " <> w2)) _ -> Nothing where split = T.splitOn "," . T.pack api = (Proxy :: Proxy API) redirectTo :: T.Text -> Handler a redirectTo url = throwError $ err303 { errHeaders = [("Location", BS.pack (T.unpack url))] } rootRedirect :: Handler NoContent rootRedirect = redirectTo "/index.html" handlerBan :: Students -> Key -> Handler NoContent handlerBan them sid = do case lookup sid them of Nothing -> throwError err404 Just _ -> pure () now <- liftIO getCurrentTime liftIO $ appendCsvLine "ban.csv" [T.pack (show now), sid] rootRedirect handlerAccept :: Students -> Key -> T.Text -> Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> Handler NoContent handlerAccept them sid homework t1 t2 t3 t4 t5 t6 = do case lookup sid them of Nothing -> throwError err404 Just _ -> pure () let tasks = mapMaybe (\(n, ok) -> if ok then Just n else Nothing) [("1", t1),("2", t2),("3", t3),("4", t4),("5", t5),("6", t6)] now <- liftIO getCurrentTime liftIO $ appendCsvLine "accept.csv" [ T.pack (show now), sid, homework, T.intercalate ";" tasks ] rootRedirect server :: Students -> Server API server students = rootRedirect :<|> handlerStudent :<|> handlerBan students :<|> handlerAccept students :<|> handlerIndex :<|> serveDirectoryWebApp "static" where rootRedirect :: Handler Redirect rootRedirect = return $ addHeader "/index.html" NoContent handlerIndex = return $ index students handlerStudent sid = do bans <- liftIO $ loadBanCounts "ban.csv" let banCount = M.findWithDefault 0 sid bans case lookup sid students of Nothing -> throwError err404 Just _ -> return $ studentPage students sid banCount type BanCounts = M.Map Key Int loadBanCounts :: FilePath -> IO BanCounts loadBanCounts fp = do txt <- TIO.readFile fp `catch` \(_ :: IOError) -> pure "" let sids = mapMaybe sidFromLine (T.lines txt) pure $ M.fromListWith (+) [(sid, 1) | sid <- sids] where sidFromLine :: T.Text -> Maybe Key sidFromLine line = case T.splitOn "," line of (_ts : sid : _) -> Just sid _ -> Nothing main :: IO () main = do students <- pairs . lines <$> readFile "groups.csv" run 4000 $ serve (Proxy :: Proxy API) (server students)