621 lines
27 KiB
Haskell
621 lines
27 KiB
Haskell
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# LANGUAGE QuasiQuotes #-}
|
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
{-# LANGUAGE FlexibleContexts #-}
|
|
{-# LANGUAGE FlexibleInstances #-}
|
|
{-# LANGUAGE ViewPatterns #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE TypeOperators #-}
|
|
{-# LANGUAGE PartialTypeSignatures #-}
|
|
{-# LANGUAGE MultiWayIf, LambdaCase #-}
|
|
{-# LANGUAGE TupleSections #-}
|
|
|
|
module Handler.Sheet where
|
|
|
|
import Import
|
|
import System.FilePath (takeFileName)
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Zip
|
|
|
|
-- import Data.Time
|
|
import qualified Data.Text as T
|
|
-- import Data.Function ((&))
|
|
--
|
|
import Colonnade hiding (fromMaybe, singleton, bool)
|
|
import qualified Yesod.Colonnade as Yesod
|
|
import Text.Blaze (text)
|
|
--
|
|
import qualified Data.UUID.Cryptographic as UUID
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Internal.Sql as E
|
|
|
|
import Control.Monad.Writer (MonadWriter(..), execWriterT)
|
|
import Control.Monad.Trans.RWS.Lazy (RWST, local)
|
|
|
|
import qualified Text.Email.Validate as Email
|
|
|
|
import qualified Data.List as List
|
|
|
|
import Network.Mime
|
|
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import Data.Map (Map, (!), (!?))
|
|
import qualified Data.Map as Map
|
|
|
|
import Control.Lens
|
|
import Utils.Lens
|
|
|
|
|
|
instance Eq (Unique Sheet) where
|
|
(CourseSheet cid1 name1) == (CourseSheet cid2 name2) =
|
|
cid1 == cid2 && name1 == name2
|
|
|
|
{-
|
|
* Implement Handlers
|
|
* Implement Breadcrumbs in Foundation
|
|
* Implement Access in Foundation
|
|
-}
|
|
|
|
data SheetForm = SheetForm
|
|
{ sfName :: Text
|
|
, sfDescription :: Maybe Html
|
|
, sfType :: SheetType
|
|
, sfGrouping :: SheetGroup
|
|
, sfMarkingText :: Maybe Html
|
|
, sfVisibleFrom :: Maybe UTCTime
|
|
, sfActiveFrom :: UTCTime
|
|
, sfActiveTo :: UTCTime
|
|
, sfSheetF :: Maybe (Source Handler (Either FileId File))
|
|
, sfHintFrom :: Maybe UTCTime
|
|
, sfHintF :: Maybe FileInfo
|
|
, sfSolutionFrom :: Maybe UTCTime
|
|
, sfSolutionF :: Maybe FileInfo
|
|
-- Keine SheetId im Formular!
|
|
}
|
|
|
|
|
|
makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
|
|
makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
|
let oldFileIds fType
|
|
| Just sId <- msId = fmap setFromList . fmap (map E.unValue) . runDB . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
|
|
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
|
|
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
|
|
E.&&. sheetFile E.^. SheetFileType E.==. E.val fType
|
|
return (file E.^. FileId)
|
|
| otherwise = return Set.empty
|
|
|
|
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
|
|
<$> areq textField (fsb "Name") (sfName <$> template)
|
|
<*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfDescription <$> template)
|
|
<*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template)
|
|
<*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGrouping <$> template)
|
|
<*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
|
|
<*> aopt utcTimeField (fsb "Sichtbar ab") (sfVisibleFrom <$> template)
|
|
<*> areq utcTimeField (fsb "Abgabe ab") (sfActiveFrom <$> template)
|
|
<*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo <$> template)
|
|
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fsb "Aufgabenstellung") (sfSheetF <$> template)
|
|
<*> aopt utcTimeField (fsb "Hinweis ab") (sfHintFrom <$> template)
|
|
<*> fileAFormOpt (fsb "Hinweis")
|
|
<*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template)
|
|
<*> fileAFormOpt (fsb "Lösung")
|
|
<* submitButton
|
|
return $ case result of
|
|
FormSuccess sheetResult
|
|
| errorMsgs <- validateSheet sheetResult
|
|
, not $ null errorMsgs ->
|
|
(FormFailure errorMsgs,
|
|
[whamlet|
|
|
<div class="alert alert-danger">
|
|
<div class="alert__content">
|
|
<h4> Fehler:
|
|
<ul>
|
|
$forall errmsg <- errorMsgs
|
|
<li> #{errmsg}
|
|
^{widget}
|
|
|]
|
|
)
|
|
_ -> (result, widget)
|
|
where
|
|
validateSheet :: SheetForm -> [Text]
|
|
validateSheet (SheetForm{..}) =
|
|
[ msg | (False, msg) <-
|
|
[ ( maybe True (sfActiveFrom >=) sfVisibleFrom
|
|
, "Sichtbarkeit muss vor Beginn der Abgabefrist liegen."
|
|
)
|
|
, ( sfActiveTo >= sfActiveFrom
|
|
, "Ende der Abgabefrist muss nach deren Beginn liegen."
|
|
)
|
|
-- TODO: continue validation here!!!
|
|
] ]
|
|
|
|
-- List Sheets
|
|
getSheetListCID :: CourseId -> Handler Html
|
|
getSheetListCID cid = getSheetList =<<
|
|
(Entity cid) <$> (runDB $ get404 cid)
|
|
|
|
getSheetListR :: TermId -> Text -> Handler Html
|
|
getSheetListR tid csh = getSheetList =<<
|
|
(runDB $ getBy404 $ CourseTermShort tid csh)
|
|
|
|
getSheetList :: Entity Course -> Handler Html
|
|
getSheetList courseEnt = do
|
|
-- mbAid <- maybeAuthId
|
|
let cid = entityKey courseEnt
|
|
let course = entityVal courseEnt
|
|
let csh = courseShorthand course
|
|
let tid = courseTerm course
|
|
sheets <- runDB $ do
|
|
rawSheets <- selectList [SheetCourse ==. cid] [Desc SheetActiveFrom]
|
|
forM rawSheets $ \(Entity sid sheet) -> do
|
|
let sheetsub = [SubmissionSheet ==. sid]
|
|
submissions <- count sheetsub
|
|
rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
|
|
return (sid, sheet, (submissions, rated))
|
|
let colBase = mconcat
|
|
[ headed "Blatt" $ \(sid,sheet,_) -> simpleLink (toWgt $ sheetName sheet) $ CSheetR tid csh (sheetName sheet) SShowR
|
|
, headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
|
|
, headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3
|
|
, headed "Bewertung" $ toWgt . display . sheetType . snd3
|
|
]
|
|
let colAdmin = mconcat -- only show edit button for allowed course assistants
|
|
[ headed "Korrigiert" $ toWgt . snd . trd3
|
|
, headed "Eingereicht" $ toWgt . fst . trd3
|
|
, headed "" $ \s -> simpleLink "Edit" $ CSheetR tid csh (sheetName $ snd3 s) SEditR
|
|
, headed "" $ \s -> simpleLink "Delete" $ CSheetR tid csh (sheetName $ snd3 s) SDelR
|
|
]
|
|
showAdmin <- case sheets of
|
|
((_,firstSheet,_):_) -> do
|
|
setUltDestCurrent
|
|
(Authorized ==) <$> isAuthorized (CSheetR tid csh (sheetName firstSheet) SEditR) False
|
|
_otherwise -> return False
|
|
let colSheets = if showAdmin
|
|
then colBase `mappend` colAdmin
|
|
else colBase
|
|
defaultLayout $ do
|
|
setTitle $ toHtml $ csh <> " Übungsblätter"
|
|
if null sheets
|
|
then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
|
|
else Yesod.encodeWidgetTable tableDefault colSheets sheets
|
|
|
|
|
|
-- Show single sheet
|
|
getSShowR :: TermId -> Text -> Text -> Handler Html
|
|
getSShowR tid csh shn = do
|
|
entSheet <- runDB $ fetchSheet tid csh shn
|
|
let sheet = entityVal entSheet
|
|
sid = entityKey entSheet
|
|
-- without Colonnade
|
|
-- fileNameTypes <- runDB $ E.select $ E.from $
|
|
-- \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
|
-- -- Restrict to consistent rows that correspond to each other
|
|
-- E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
|
|
-- E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
|
|
-- -- filter to requested file
|
|
-- E.where_ (sheet E.^. SheetId E.==. E.val sid )
|
|
-- -- return desired columns
|
|
-- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
|
|
-- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid csh (SheetFileR shn fType fName),modified)) fileNameTypes
|
|
-- with Colonnade
|
|
|
|
let fileData (sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) = do
|
|
-- Restrict to consistent rows that correspond to each other
|
|
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
|
|
E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
|
|
-- filter to requested file
|
|
E.where_ $ sheet E.^. SheetId E.==. E.val sid
|
|
E.&&. E.not_ (E.isNothing $ file E.^. FileContent)
|
|
-- return desired columns
|
|
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
|
|
let colonnadeFiles = widgetColonnade $ mconcat
|
|
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> stringCell ftype
|
|
, sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName))
|
|
(\(E.Value fName,_,_) -> str2widget fName)
|
|
, sortable Nothing "Freigabe" $ \(_,_, E.Value ftype) ->
|
|
case ftype of
|
|
SheetExercise -> textCell $ display $ sheetActiveFrom sheet
|
|
SheetHint -> textCell $ display $ sheetHintFrom sheet
|
|
SheetSolution -> textCell $ display $ sheetSolutionFrom sheet
|
|
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime)
|
|
]
|
|
fileTable <- dbTable def $ DBTable
|
|
{ dbtSQLQuery = fileData
|
|
, dbtColonnade = colonnadeFiles
|
|
, dbtAttrs = tableDefault
|
|
, dbtFilter = Map.empty
|
|
, dbtIdent = "files" :: Text
|
|
-- TODO: Add column for and visibility date
|
|
, dbtSorting = [ ( "type"
|
|
, SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> sheetFile E.^. SheetFileType
|
|
)
|
|
, ( "path"
|
|
, SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileTitle
|
|
)
|
|
, ( "time"
|
|
, SortColumn $ \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> file E.^. FileModified
|
|
)
|
|
]
|
|
}
|
|
defaultLayout $ do
|
|
setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
|
|
$(widgetFile "sheetShow")
|
|
[whamlet| Under Construction !!! |] -- TODO
|
|
|
|
getSFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
|
|
getSFileR tid csh shn typ title = do
|
|
content <- runDB $ E.select $ E.from $
|
|
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
|
-- Restrict to consistent rows that correspond to each other
|
|
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
|
|
E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
|
|
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
|
|
-- filter to requested file
|
|
E.where_ ((file E.^. FileTitle E.==. E.val title)
|
|
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
|
|
E.&&. (sheet E.^. SheetName E.==. E.val shn )
|
|
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
|
|
E.&&. (course E.^. CourseTerm E.==. E.val tid )
|
|
)
|
|
-- return desired columns
|
|
return $ file E.^. FileContent
|
|
let mimeType = defaultMimeLookup $ pack title
|
|
case content of
|
|
[E.Value (Just nochmalContent)] -> do
|
|
addHeader "Content-Disposition" "attachment"
|
|
respond mimeType nochmalContent
|
|
[] -> notFound
|
|
_other -> error "Multiple matching files found."
|
|
|
|
|
|
getSheetNewR :: TermId -> Text -> Handler Html
|
|
getSheetNewR tid csh = do
|
|
let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
|
|
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
|
|
insertUnique $ newSheet
|
|
handleSheetEdit tid csh Nothing template action
|
|
|
|
postSheetNewR :: TermId -> Text -> Handler Html
|
|
postSheetNewR = getSheetNewR
|
|
|
|
|
|
getSEditR :: TermId -> Text -> Text -> Handler Html
|
|
getSEditR tid csh shn = do
|
|
(sheetEnt, sheetFileIds) <- runDB $ do
|
|
ent <- fetchSheet tid csh shn
|
|
fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
|
|
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
|
|
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val (entityKey ent)
|
|
E.&&. sheetFile E.^. SheetFileType E.==. E.val SheetExercise
|
|
return (file E.^. FileId)
|
|
return (ent, fIds)
|
|
let sid = entityKey sheetEnt
|
|
let oldSheet@(Sheet {..}) = entityVal sheetEnt
|
|
let template = Just $ SheetForm
|
|
{ sfName = sheetName
|
|
, sfDescription = sheetDescription
|
|
, sfType = sheetType
|
|
, sfGrouping = sheetGrouping
|
|
, sfMarkingText = sheetMarkingText
|
|
, sfVisibleFrom = sheetVisibleFrom
|
|
, sfActiveFrom = sheetActiveFrom
|
|
, sfActiveTo = sheetActiveTo
|
|
, sfSheetF = Just . yieldMany . map Left $ Set.toList sheetFileIds
|
|
, sfHintFrom = sheetHintFrom
|
|
, sfHintF = Nothing -- TODO
|
|
, sfSolutionFrom = sheetSolutionFrom
|
|
, sfSolutionF = Nothing -- TODO
|
|
}
|
|
let action newSheet = do
|
|
replaceRes <- myReplaceUnique sid $ newSheet
|
|
case replaceRes of
|
|
Nothing -> return $ Just sid
|
|
(Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
|
|
handleSheetEdit tid csh (Just sid) template action
|
|
|
|
postSEditR :: TermId -> Text -> Text -> Handler Html
|
|
postSEditR = getSEditR
|
|
|
|
handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
|
|
handleSheetEdit tid csh msId template dbAction = do
|
|
let mbshn = sfName <$> template
|
|
aid <- requireAuthId
|
|
((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template
|
|
case res of
|
|
(FormSuccess SheetForm{..}) -> do
|
|
saveOkay <- runDB $ do
|
|
actTime <- liftIO getCurrentTime
|
|
cid <- getKeyBy404 $ CourseTermShort tid csh
|
|
let newSheet = Sheet
|
|
{ sheetCourse = cid
|
|
, sheetName = sfName
|
|
, sheetDescription = sfDescription
|
|
, sheetType = sfType
|
|
, sheetGrouping = sfGrouping
|
|
, sheetMarkingText = sfMarkingText
|
|
, sheetVisibleFrom = sfVisibleFrom
|
|
, sheetActiveFrom = sfActiveFrom
|
|
, sheetActiveTo = sfActiveTo
|
|
, sheetHintFrom = sfHintFrom
|
|
, sheetSolutionFrom = sfSolutionFrom
|
|
}
|
|
mbsid <- dbAction newSheet
|
|
case mbsid of
|
|
Nothing -> False <$ addMessageI "danger" (MsgSheetNameDup tid csh sfName)
|
|
(Just sid) -> do -- save files in DB:
|
|
whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise
|
|
whenIsJust sfHintF $ insertSheetFile sid SheetHint
|
|
whenIsJust sfSolutionF $ insertSheetFile sid SheetSolution
|
|
insert_ $ SheetEdit aid actTime sid
|
|
addMessageI "info" $ MsgSheetEditOk tid csh sfName
|
|
return True
|
|
when saveOkay $ redirect $ CSheetR tid csh sfName SShowR -- redirect must happen outside of runDB
|
|
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
|
|
_ -> return ()
|
|
let pageTitle = maybe (MsgSheetTitleNew tid csh)
|
|
(MsgSheetTitle tid csh) mbshn
|
|
-- let formTitle = pageTitle -- no longer used in template
|
|
let formText = Nothing :: Maybe UniWorXMessage
|
|
actionUrl <- fromMaybe (CourseR tid csh SheetNewR) <$> getCurrentRoute
|
|
defaultLayout $ do
|
|
setTitleI pageTitle
|
|
$(widgetFile "formPageI18n")
|
|
|
|
|
|
|
|
getSDelR :: TermId -> Text -> Text -> Handler Html
|
|
getSDelR tid csh shn = do
|
|
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
|
|
case result of
|
|
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh shn SShowR
|
|
(FormSuccess BtnDelete) -> do
|
|
runDB $ fetchSheetId tid csh shn >>= deleteCascade
|
|
-- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
|
|
addMessageI "info" $ MsgSheetDelOk tid csh shn
|
|
redirect $ CourseR tid csh SheetListR
|
|
_other -> do
|
|
submissionno <- runDB $ do
|
|
sid <- fetchSheetId tid csh shn
|
|
count [SubmissionSheet ==. sid]
|
|
let formTitle = MsgSheetDelHead tid csh shn
|
|
let formText = Just $ MsgSheetDelText submissionno
|
|
let actionUrl = CSheetR tid csh shn SDelR
|
|
defaultLayout $ do
|
|
setTitleI $ MsgSheetTitle tid csh shn
|
|
$(widgetFile "formPageI18n")
|
|
|
|
postSDelR :: TermId -> Text -> Text -> Handler Html
|
|
postSDelR = getSDelR
|
|
|
|
|
|
|
|
insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
|
|
insertSheetFile sid ftype finfo = do
|
|
runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert
|
|
where
|
|
finsert file = do
|
|
fid <- insert file
|
|
void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
|
|
|
|
insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX ()
|
|
insertSheetFile' sid ftype fs = do
|
|
oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
|
|
E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile
|
|
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
|
|
E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype
|
|
return (file E.^. FileId)
|
|
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
|
|
mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
|
|
where
|
|
finsert (Left fileId) = tell $ singleton fileId
|
|
finsert (Right file) = lift $ do
|
|
fid <- insert file
|
|
void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
|
|
|
|
|
|
data CorrectorForm = CorrectorForm
|
|
{ cfUserId :: UserId
|
|
, cfUserName :: Text
|
|
, cfResult :: FormResult Load
|
|
, cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX
|
|
}
|
|
|
|
type Loads = Map UserId Load
|
|
|
|
defaultLoads :: SheetId -> DB Loads
|
|
-- ^ Generate `Loads` in such a way that minimal editing is required
|
|
--
|
|
-- For every user, that ever was a corrector for this course, return their last `Load`.
|
|
-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit).
|
|
defaultLoads shid = do
|
|
cId <- sheetCourse <$> getJust shid
|
|
fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
|
|
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
|
|
|
let creationTime = E.sub_select . E.from $ \sheetEdit -> do
|
|
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
|
return . E.min_ $ sheetEdit E.^. SheetEditTime
|
|
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cId
|
|
|
|
E.orderBy [E.desc creationTime]
|
|
|
|
return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad)
|
|
where
|
|
toMap :: [(E.Value UserId, E.Value Load)] -> Loads
|
|
toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load
|
|
|
|
|
|
correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
|
|
correctorForm shid = do
|
|
cListIdent <- newFormIdent
|
|
let
|
|
guardNonDeleted :: UserId -> Handler (Maybe UserId)
|
|
guardNonDeleted uid = do
|
|
cID@CryptoID{..} <- encrypt uid :: Handler CryptoUUIDUser
|
|
deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
|
|
return $ bool Just (const Nothing) (isJust deleted) uid
|
|
formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
|
|
let
|
|
currentLoads :: DB Loads
|
|
currentLoads = Map.fromList . map (\(Entity _ SheetCorrector{..}) -> (sheetCorrectorUser, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
|
|
(defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
|
|
loads' <- fmap (Map.fromList [(uid, mempty) | uid <- formCIDs] `Map.union`) $ if
|
|
| Map.null currentLoads'
|
|
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warn" MsgCorrectorsDefaulted)
|
|
| otherwise -> return $ Map.fromList (map (, mempty) formCIDs) `Map.union` currentLoads'
|
|
|
|
deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')
|
|
|
|
let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions)
|
|
didDelete = any (flip Set.member deletions) formCIDs
|
|
|
|
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads'
|
|
let
|
|
tutorField :: Field Handler [Text]
|
|
tutorField = multiEmailField
|
|
{ fieldView = \theId name attrs val isReq -> asWidgetT $ do
|
|
listIdent <- newIdent
|
|
userId <- handlerToWidget requireAuthId
|
|
previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do
|
|
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
|
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
|
E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
|
|
return $ user E.^. UserEmail
|
|
[whamlet|
|
|
$newline never
|
|
<input id=#{theId} name=#{name} list=#{listIdent} *{attrs} type=email multiple :isReq:required value="" placeholder=_{MsgCorrectorsPlaceholder}>
|
|
<datalist id=#{listIdent}>
|
|
$forall E.Value prev <- previousCorrectors
|
|
<option value=#{prev}>
|
|
|]
|
|
}
|
|
(addTutRes, addTutView) <- mopt tutorField (fsm MsgAddCorrector) (Just Nothing)
|
|
|
|
loads <- case addTutRes of
|
|
FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
|
|
mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
|
|
case mUid of
|
|
Nothing -> loads'' <$ addMessageI "error" (MsgEMailUnknown email)
|
|
Just uid
|
|
| not (Map.member uid loads') -> return $ Map.insert uid mempty loads''
|
|
| otherwise -> loads'' <$ addMessageI "warning" (MsgCorrectorExists email)
|
|
FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs
|
|
_ -> return loads''
|
|
|
|
let deletions' = deletions `Set.difference` Map.keysSet loads
|
|
|
|
names <- fmap (Map.fromList . map (\(E.Value a, E.Value b) -> (a, b))) . lift . runDB . E.select . E.from $ \user -> do
|
|
E.where_ $ user E.^. UserId `E.in_` E.valList (Map.keys loads)
|
|
return $ (user E.^. UserId, user E.^. UserDisplayName)
|
|
|
|
let
|
|
constructFields :: (UserId, Text, Load) -> MForm Handler CorrectorForm
|
|
constructFields (uid, uname, Load{..}) = do
|
|
cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser
|
|
let
|
|
fs name = ""
|
|
{ fsName = Just $ tshow ciphertext <> "-" <> name
|
|
}
|
|
rationalField = convertField toRational fromRational doubleField
|
|
|
|
(byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
|
|
(propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
|
|
(_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
|
|
let
|
|
cfResult :: FormResult Load
|
|
cfResult = Load <$> tutRes' <*> propRes
|
|
tutRes'
|
|
| FormSuccess True <- byTutRes = Just <$> countTutRes
|
|
| otherwise = Nothing <$ byTutRes
|
|
cfUserId = uid
|
|
cfUserName = uname
|
|
return CorrectorForm{..}
|
|
|
|
corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid
|
|
|
|
mr <- getMessageRender
|
|
|
|
$logDebugS "SCorrR" $ tshow (didDelete, addTutRes)
|
|
|
|
let
|
|
corrColonnade = mconcat
|
|
[ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName
|
|
, headed (Yesod.textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut
|
|
, headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp
|
|
, headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel
|
|
]
|
|
corrResults
|
|
| FormSuccess (Just es) <- addTutRes
|
|
, not $ null es = FormMissing
|
|
| didDelete = FormMissing
|
|
| otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> cfResult
|
|
| CorrectorForm{..} <- corrData
|
|
]
|
|
idField CorrectorForm{..} = do
|
|
cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
|
|
toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
|
|
|
|
delField uid = do
|
|
cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
|
|
toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
|
|
|
|
return (corrResults, [ countTutView
|
|
, FieldView
|
|
{ fvLabel = text $ mr MsgCorrectors
|
|
, fvTooltip = Nothing
|
|
, fvId = ""
|
|
, fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions
|
|
, fvErrors = Nothing
|
|
, fvRequired = True
|
|
}
|
|
, addTutView
|
|
{ fvInput = [whamlet|
|
|
<div>
|
|
^{fvInput addTutView}
|
|
<button type=submit formnovalidate data-formnorequired>Hinzufügen
|
|
|]
|
|
}
|
|
])
|
|
|
|
-- Eingabebox für Korrektor hinzufügen
|
|
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
|
|
|
|
getSCorrR, postSCorrR :: TermId
|
|
-> Text -- ^ Course shorthand
|
|
-> Text -- ^ Sheet name
|
|
-> Handler Html
|
|
postSCorrR = getSCorrR
|
|
getSCorrR tid csh shn = do
|
|
Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn
|
|
|
|
((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
|
|
|
|
case res of
|
|
FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
|
|
FormSuccess res -> runDB $ do
|
|
deleteWhere [SheetCorrectorSheet ==. shid]
|
|
insertMany_ $ Set.toList res
|
|
addMessageI "success" MsgCorrectorsUpdated
|
|
FormMissing -> return ()
|
|
|
|
let
|
|
-- formTitle = MsgSheetCorrectorsTitle tid csh shn
|
|
formText = Nothing :: Maybe (SomeMessage UniWorX)
|
|
actionUrl = CSheetR tid csh shn SCorrR
|
|
-- actionUrl = CSheetR tid csh shn SShowR
|
|
defaultLayout $ do
|
|
setTitleI $ MsgSheetCorrectorsTitle tid csh shn
|
|
$(widgetFile "formPageI18n")
|