not_a_moodle/App.hs

{-# 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)