Загрузить файлы в «/»

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)

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

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"

groups.csv

@@ -0,0 +1 @@
+Иван,Иванович,Иванов,99И999

shell.nix

@@ -0,0 +1,16 @@
+{ pkgs ? import <nixpkgs> {} }:
+
+pkgs.mkShell {
+  buildInputs = [
+    (pkgs.haskellPackages.ghcWithPackages (p: with p; [
+      servant
+      wai
+      warp
+      servant-server
+      lucid
+      servant-lucid
+      haskell-language-server
+    ]))
+  ];
+}
+