166 lines
4.9 KiB
Haskell
166 lines
4.9 KiB
Haskell
{-# 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)
|