diff --git a/App.hs b/App.hs new file mode 100644 index 0000000..7713af0 --- /dev/null +++ b/App.hs @@ -0,0 +1,166 @@ +{-# 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) diff --git a/Common.hs b/Common.hs new file mode 100644 index 0000000..f0e01e9 --- /dev/null +++ b/Common.hs @@ -0,0 +1,26 @@ +{-# LANGUAGE OverloadedStrings #-} +module Common where +import Lucid.Base +import Lucid.Html5 +import qualified Data.Text as T +type Name = T.Text +type Key = T.Text +type Students = [(Key, Name)] + +layout :: Html() -> Html () +layout bodyContent = + doctypehtml_ $ do + head_ $ do + link_ [ rel_ "stylesheet", href_ "https://unpkg.com/milligram/dist/milligram.min.css" ] + style_ $ T.unlines + [ "form { text-align:center; width: 70%; margin: 0 auto; }" + , "h1 { text-align: center; }" + , "h2 { text-align: center; }" + , "h3 { text-align: center; }" + , "p { text-align: center; }" + , "label { display: inline-flex; align-items: center; gap: 6px;}" + ] + title_ "Каждому по заслугам" + meta_ [charset_ "utf-8"] + meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1"] + body_ bodyContent diff --git a/IndexHtml.hs b/IndexHtml.hs new file mode 100644 index 0000000..c2d920f --- /dev/null +++ b/IndexHtml.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +module IndexHtml where +import Lucid.Base +import Lucid.Html5 +import qualified Data.Text as T +import Common (Students, layout) + +index :: Students -> (Html()) +index students = layout $ do + h1_ "Каждому по заслугам" + h2_ "Сервис записи работ студентов" + h3_ "Выберите студента" + form_ [method_ "GET", action_ "./student" ]$ do + input_ [type_ "search", name_ "student_id", list_ listId] + datalist_ [id_ listId] $ do + mapM_ (\x -> option_ [value_ $ fst x] (toHtml $ snd x)) students + input_ [type_ "submit"] + where listId = "students" diff --git a/groups.csv b/groups.csv new file mode 100644 index 0000000..17f9068 --- /dev/null +++ b/groups.csv @@ -0,0 +1 @@ +Иван,Иванович,Иванов,99И999 diff --git a/shell.nix b/shell.nix new file mode 100644 index 0000000..7347632 --- /dev/null +++ b/shell.nix @@ -0,0 +1,16 @@ +{ pkgs ? import {} }: + +pkgs.mkShell { + buildInputs = [ + (pkgs.haskellPackages.ghcWithPackages (p: with p; [ + servant + wai + warp + servant-server + lucid + servant-lucid + haskell-language-server + ])) + ]; +} +