539 lines
23 KiB
Haskell
539 lines
23 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 #-}
|
|
|
|
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)
|
|
import Yesod.Colonnade
|
|
--
|
|
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)
|
|
|
|
import qualified Data.List as List
|
|
|
|
import Network.Mime
|
|
|
|
import qualified Data.Set as Set
|
|
|
|
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">
|
|
<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,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CourseR tid csh $ SheetR $ SheetShowR $ sheetName sheet
|
|
, headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
|
|
, headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3
|
|
, headed "Bewertung" $ toWgt . show . 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 -> linkButton "Edit" BCLink $ CourseR tid csh $ SheetR $ SheetEditR $ sheetName $ snd3 s
|
|
, headed "" $ \s -> linkButton "Delete" BCLink $ CourseR tid csh $ SheetR $ SheetDelR $ sheetName $ snd3 s
|
|
]
|
|
showAdmin <- case sheets of
|
|
((_,firstSheet,_):_) -> do
|
|
setUltDestCurrent
|
|
(Authorized ==) <$> isAuthorized (CourseR tid csh $ SheetR $ SheetEditR $ sheetName firstSheet) False
|
|
_otherwise -> return False
|
|
let colSheets = if showAdmin
|
|
then colBase `mappend` colAdmin
|
|
else colBase
|
|
defaultLayout $ do
|
|
setTitle $ toHtml $ T.append "Übungsblätter " csh
|
|
if null sheets
|
|
then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
|
|
else encodeWidgetTable tableDefault colSheets sheets
|
|
|
|
|
|
-- Show single sheet
|
|
getSheetShowR :: TermId -> Text -> Text -> Handler Html
|
|
getSheetShowR 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 = mconcat
|
|
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
|
|
, sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh (SheetFileR shn fType fName))
|
|
(\(E.Value fName,_,_) -> str2widget fName)
|
|
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT modified
|
|
]
|
|
fileTable <- dbTable def $ DBTable
|
|
{ dbtSQLQuery = fileData
|
|
, dbtColonnade = colonnadeFiles
|
|
, dbtAttrs = tableDefault
|
|
, dbtIdent = "files" :: Text
|
|
, 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
|
|
|
|
getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
|
|
getSheetFileR 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
|
|
|
|
|
|
getSheetEditR :: TermId -> Text -> Text -> Handler Html
|
|
getSheetEditR 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
|
|
|
|
postSheetEditR :: TermId -> Text -> Text -> Handler Html
|
|
postSheetEditR = getSheetEditR
|
|
|
|
handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
|
|
handleSheetEdit tid csh msId template dbAction = do
|
|
let tident = unTermKey tid
|
|
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 tident 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 tident csh sfName
|
|
return True
|
|
when saveOkay $ redirect $ CSheetR tid csh $ SheetShowR sfName -- redirect must happen outside of runDB
|
|
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
|
|
_ -> return ()
|
|
let pageTitle = maybe (MsgSheetTitleNew tident csh)
|
|
(MsgSheetTitle tident csh) mbshn
|
|
let formTitle = pageTitle
|
|
let formText = Nothing :: Maybe UniWorXMessage
|
|
actionUrl <- fromMaybe (CSheetR tid csh SheetNewR) <$> getCurrentRoute
|
|
defaultLayout $ do
|
|
setTitleI pageTitle
|
|
$(widgetFile "formPageI18n")
|
|
|
|
|
|
|
|
getSheetDelR :: TermId -> Text -> Text -> Handler Html
|
|
getSheetDelR tid csh shn = do
|
|
let tident = unTermKey tid
|
|
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
|
|
case result of
|
|
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh $ SheetShowR shn
|
|
(FormSuccess BtnDelete) -> do
|
|
runDB $ fetchSheetId tid csh shn >>= deleteCascade
|
|
-- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
|
|
addMessageI "info" $ MsgSheetDelOk tident csh shn
|
|
redirect $ CSheetR tid csh SheetListR
|
|
_other -> do
|
|
submissionno <- runDB $ do
|
|
sid <- fetchSheetId tid csh shn
|
|
count [SubmissionSheet ==. sid]
|
|
let formTitle = MsgSheetDelTitle tident csh shn
|
|
let formText = Just $ MsgSheetDelText submissionno
|
|
let actionUrl = CSheetR tid csh $ SheetDelR shn
|
|
defaultLayout $ do
|
|
setTitleI $ MsgSheetTitle tident csh shn
|
|
$(widgetFile "formPageI18n")
|
|
|
|
postSheetDelR :: TermId -> Text -> Text -> Handler Html
|
|
postSheetDelR = getSheetDelR
|
|
|
|
|
|
|
|
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, cfViewCountTut, cfViewProp :: 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 = 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.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 Loads, [FieldView UniWorX])
|
|
correctorForm shid = do
|
|
cListIdent <- newFormIdent
|
|
formCIDs <- lift $ mapM decrypt =<< (catMaybes . map fromPathPiece <$> lookupPostParams cListIdent :: Handler [CryptoUUIDUser])
|
|
loads'' <- lift . runDB $ defaultLoads shid
|
|
let loads' = loads'' `Map.union` Map.fromList [(uid, mempty) | uid <- formCIDs]
|
|
|
|
(addTutRes, addTutView) <- mopt emailField (fsm MsgAddCorrector) (Just Nothing)
|
|
|
|
loads <- case addTutRes of
|
|
FormSuccess (Just 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'
|
|
|
|
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)
|
|
(countTutRes, cfViewCountTut) <- mreq checkBoxField (fs "counttut") byTutorial
|
|
(propRes, cfViewProp) <- mreq rationalField (fs "prop") (Just byProportion)
|
|
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
|
|
|
|
let
|
|
corrColonnade = mconcat
|
|
[ headed "Korrektor" $ \CorrectorForm{..} -> textCell cfUserName
|
|
, headed "Nach Tutorium" $ \CorrectorForm{..} -> cell $ fvInput cfViewByTut
|
|
, headed "Tutorium zählt gegen Proportion" $ \CorrectorForm{..} -> cell $ fvInput cfViewCountTut -- TODO: set this once for entire sheet?
|
|
, headed "Proportion" $ \CorrectorForm{..} -> cell $ fvInput cfViewProp
|
|
]
|
|
corrResults
|
|
| FormSuccess _ <- addTutRes = FormMissing
|
|
| otherwise = fmap Map.fromList $ sequenceA [ (,) <$> pure cfUserId <*> cfResult
|
|
| CorrectorForm{..} <- corrData
|
|
]
|
|
idField CorrectorForm{..} = do
|
|
cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
|
|
toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
|
|
|
|
return (corrResults, [ FieldView
|
|
{ fvLabel = mempty
|
|
, fvTooltip = Nothing
|
|
, fvId = ""
|
|
, fvInput = encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData
|
|
, fvErrors = Nothing
|
|
, fvRequired = True
|
|
}
|
|
, addTutView
|
|
{ fvInput = fvInput addTutView >> toWidget [hamlet|<button type=submit formnovalidate>Hinzufügen|]
|
|
}
|
|
])
|
|
|
|
-- Eingabebox für Korrektor hinzufügen
|
|
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
|
|
|
|
getSheetCorrectorsR, postSheetCorrectorsR :: TermId
|
|
-> Text -- ^ Course shorthand
|
|
-> Text -- ^ Sheet name
|
|
-> Handler Html
|
|
postSheetCorrectorsR = getSheetCorrectorsR
|
|
getSheetCorrectorsR tid@(unTermKey -> tident) csh shn = do
|
|
Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn
|
|
|
|
((res,formWidget), formEnctype) <- runFormPost . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
|
|
|
|
let
|
|
formTitle = MsgSheetCorrectorsTitle tident csh shn
|
|
formText = Nothing :: Maybe (SomeMessage UniWorX)
|
|
actionUrl = CSheetR tid csh $ SheetCorrectorsR shn
|
|
defaultLayout $ do
|
|
setTitleI $ MsgSheetCorrectorsTitle tident csh shn
|
|
$(widgetFile "formPageI18n")
|