767 lines
37 KiB
Haskell
767 lines
37 KiB
Haskell
module Handler.Sheet where
|
|
|
|
import Import
|
|
import System.FilePath (takeFileName)
|
|
|
|
import Handler.Utils
|
|
-- import Handler.Utils.Zip
|
|
import Handler.Utils.Table.Cells
|
|
import Handler.Utils.SheetType
|
|
import Handler.Utils.Delete
|
|
|
|
-- 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 Data.CaseInsensitive (CI)
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
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 Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE)
|
|
|
|
import Network.Mime
|
|
|
|
import Data.Set (Set)
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Map as Map
|
|
|
|
import Data.Map (Map, (!?))
|
|
|
|
import Data.Monoid (Any(..))
|
|
|
|
-- import Control.Lens
|
|
import Utils.Lens
|
|
|
|
--import qualified Data.Aeson as Aeson
|
|
|
|
import Control.Monad.Random.Class (MonadRandom(..))
|
|
import Utils.Sql
|
|
|
|
|
|
{-
|
|
* Implement Handlers
|
|
* Implement Breadcrumbs in Foundation
|
|
* Implement Access in Foundation
|
|
-}
|
|
|
|
data SheetForm = SheetForm
|
|
{ sfName :: SheetName
|
|
, sfDescription :: Maybe Html
|
|
, sfType :: SheetType
|
|
, sfGrouping :: SheetGroup
|
|
, sfVisibleFrom :: Maybe UTCTime
|
|
, sfActiveFrom :: UTCTime
|
|
, sfActiveTo :: UTCTime
|
|
, sfSubmissionMode :: SheetSubmissionMode
|
|
, sfUploadMode :: UploadMode
|
|
, sfSheetF :: Maybe (Source Handler (Either FileId File))
|
|
, sfHintFrom :: Maybe UTCTime
|
|
, sfHintF :: Maybe (Source Handler (Either FileId File))
|
|
, sfSolutionFrom :: Maybe UTCTime
|
|
, sfSolutionF :: Maybe (Source Handler (Either FileId File))
|
|
, sfMarkingF :: Maybe (Source Handler (Either FileId File))
|
|
, sfMarkingText :: Maybe Html
|
|
-- Keine SheetId im Formular!
|
|
}
|
|
|
|
getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileId)
|
|
getFtIdMap sId = do
|
|
allfIds <- E.select . E.from $ \(sheetFile `E.InnerJoin` file) -> do
|
|
E.on $ sheetFile E.^. SheetFileFile E.==. file E.^. FileId
|
|
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
|
|
return (sheetFile E.^. SheetFileType, file E.^. FileId)
|
|
return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds]
|
|
|
|
makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
|
|
makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
|
oldFileIds <- (return.) <$> case msId of
|
|
Nothing -> return $ partitionFileType mempty
|
|
(Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId
|
|
mr <- getMsgRenderer
|
|
ctime <- liftIO $ getCurrentTime
|
|
(result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
|
|
<$> areq ciField (fslI MsgSheetName) (sfName <$> template)
|
|
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
|
|
<*> sheetTypeAFormReq (fslI MsgSheetType
|
|
& setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded]))
|
|
(sfType <$> template)
|
|
<*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template)
|
|
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
|
|
& setTooltip MsgSheetVisibleFromTip)
|
|
((sfVisibleFrom <$> template) <|> pure (Just ctime))
|
|
<*> areq utcTimeField (fslI MsgSheetActiveFrom
|
|
& setTooltip MsgSheetActiveFromTip)
|
|
(sfActiveFrom <$> template)
|
|
<*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template)
|
|
<*> areq submissionModeField (fslI MsgSheetSubmissionMode) ((sfSubmissionMode <$> template) <|> pure UserSubmissions)
|
|
<*> areq uploadModeField (fslI MsgSheetUploadMode) ((sfUploadMode <$> template) <|> pure (Upload True))
|
|
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren"
|
|
& setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
|
|
<*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
|
|
<*> aopt utcTimeField (fslpI MsgSheetSolutionFrom "Datum, sonst nur für Korrektoren"
|
|
& setTooltip MsgSheetSolutionFromTip)
|
|
(sfSolutionFrom <$> template)
|
|
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
|
|
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking
|
|
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
|
|
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
|
<* submitButton
|
|
return $ case result of
|
|
FormSuccess sheetResult
|
|
| errorMsgs <- validateSheet mr sheetResult
|
|
, not $ null errorMsgs ->
|
|
(FormFailure errorMsgs, widget)
|
|
_ -> (result, widget)
|
|
where
|
|
validateSheet :: MsgRenderer -> SheetForm -> [Text]
|
|
validateSheet (MsgRenderer {..}) (SheetForm{..}) =
|
|
[ msg | (False, msg) <-
|
|
[ ( sfVisibleFrom <= Just sfActiveFrom , render MsgSheetErrVisibility)
|
|
, ( sfActiveFrom <= sfActiveTo , render MsgSheetErrDeadlineEarly)
|
|
, ( NTop sfHintFrom >= NTop (Just sfActiveFrom) , render MsgSheetErrHintEarly)
|
|
, ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly)
|
|
] ]
|
|
|
|
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getSheetListR tid ssh csh = do
|
|
muid <- maybeAuthId
|
|
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
let
|
|
lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
|
|
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
|
return . E.max_ $ sheetEdit E.^. SheetEditTime
|
|
|
|
sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery ()
|
|
sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
|
|
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
|
|
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
|
|
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
|
|
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
|
|
|
sheetFilter :: SheetName -> DB Bool
|
|
sheetFilter sheetName = (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False
|
|
|
|
sheetCol = widgetColonnade . mconcat $
|
|
[ dbRow
|
|
, sortable (Just "name") (i18nCell MsgSheet)
|
|
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
|
|
, sortable (Just "last-edit") (i18nCell MsgLastEdit)
|
|
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> maybe mempty timeCell mEditTime
|
|
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
|
|
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveFrom
|
|
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
|
|
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> timeCell sheetActiveTo
|
|
, sortable Nothing (i18nCell MsgSheetType)
|
|
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> i18nCell sheetType
|
|
, sortable Nothing (i18nCell MsgSubmission)
|
|
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of
|
|
Nothing -> mempty
|
|
(Just (Entity sid Submission{..})) ->
|
|
let mkCid = encrypt sid -- TODO: executed twice
|
|
mkRoute = do
|
|
cid' <- mkCid
|
|
return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
|
|
in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
|
|
, sortable (Just "rating") (i18nCell MsgRating)
|
|
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of
|
|
Nothing -> mempty
|
|
(Just (Entity sid Submission{..})) ->
|
|
let mkCid = encrypt sid
|
|
mkRoute = do
|
|
cid' <- mkCid
|
|
return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
|
|
in anchorCellM mkRoute $(widgetFile "widgets/rating")
|
|
, sortable Nothing -- (Just "percent")
|
|
(i18nCell MsgRatingPercent)
|
|
$ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub)} -> case mbSub of
|
|
(Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
|
|
case preview (_grading . _maxPoints) sType of
|
|
Just maxPoints
|
|
| maxPoints /= 0 ->
|
|
let percent = sPoints / maxPoints
|
|
in textCell $ textPercent $ realToFrac percent
|
|
_other -> mempty
|
|
_other -> mempty
|
|
]
|
|
|
|
psValidator = def
|
|
& defaultSorting [SortDescBy "submission-since"]
|
|
|
|
(table,raw_statistics) <- runDB $ liftA2 (,)
|
|
(dbTableWidget' psValidator DBTable
|
|
{ dbtColonnade = sheetCol
|
|
, dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser))
|
|
-> sheetData dt *> return (sheet, lastSheetEdit sheet, submission)
|
|
, dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
|
, dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) }
|
|
-> dbr <$ guardM (lift $ sheetFilter sheetName)
|
|
, dbtSorting = Map.fromList
|
|
[ ( "name"
|
|
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
|
)
|
|
, ( "last-edit"
|
|
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
|
|
)
|
|
, ( "submission-since"
|
|
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
|
|
)
|
|
, ( "submission-until"
|
|
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
|
|
)
|
|
, ( "rating"
|
|
, SortColumn $ \(_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> submission E.?. SubmissionRatingPoints
|
|
)
|
|
-- GitLab Issue $143: HOW TO SORT?
|
|
-- , ( "percent"
|
|
-- , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
|
|
-- case sheetType of -- no Haskell inside Esqueleto, right?
|
|
-- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
|
|
-- )
|
|
]
|
|
, dbtFilter = mempty
|
|
, dbtFilterUI = mempty
|
|
, dbtStyle = def
|
|
, dbtParams = def
|
|
, dbtIdent = "sheets" :: Text
|
|
}
|
|
) (
|
|
-- Collect summary over all Sheets, not just the ones shown due to pagination:
|
|
do
|
|
rows <- E.select $ E.from $ \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
|
|
sheetData dt *> return (sheet E.^. SheetName, sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
|
|
flip filterM rows (\(E.Value sheetName, _, _) -> sheetFilter sheetName)
|
|
)
|
|
|
|
let statistics =
|
|
gradeSummaryWidget MsgSheetGradingSummaryTitle $
|
|
foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts))
|
|
raw_statistics
|
|
defaultLayout $ do
|
|
$(widgetFile "sheetList")
|
|
|
|
data ButtonGeneratePseudonym = BtnGenerate
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
|
instance Universe ButtonGeneratePseudonym
|
|
instance Finite ButtonGeneratePseudonym
|
|
|
|
nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)
|
|
|
|
instance Button UniWorX ButtonGeneratePseudonym where
|
|
label BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
|
|
cssClass BtnGenerate = BCDefault
|
|
|
|
-- Show single sheet
|
|
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
|
getSShowR tid ssh csh shn = do
|
|
Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn
|
|
-- 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 ssh 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) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
|
|
, sortable (Just "path") "Dateiname" $ \(E.Value fName,_,E.Value fType) -> anchorCell
|
|
(CSheetR tid ssh csh shn (SFileR fType fName))
|
|
(str2widget fName)
|
|
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
|
|
]
|
|
let psValidator = def
|
|
& defaultSorting [SortAscBy "type", SortAscBy "path"]
|
|
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
|
|
{ dbtSQLQuery = fileData
|
|
, dbtRowKey = \(_ `E.InnerJoin` _ `E.InnerJoin` file) -> file E.^. FileId
|
|
, dbtColonnade = colonnadeFiles
|
|
, dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) }
|
|
-> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False)
|
|
, dbtStyle = def
|
|
, dbtFilter = mempty
|
|
, dbtFilterUI = mempty
|
|
, dbtIdent = "files" :: Text
|
|
, dbtSorting = Map.fromList
|
|
[ ( "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
|
|
)
|
|
]
|
|
, dbtParams = def
|
|
}
|
|
(hasHints, hasSolution) <- runDB $ do
|
|
hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
|
|
hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ]
|
|
return (hasHints, hasSolution)
|
|
cTime <- Just <$> liftIO getCurrentTime
|
|
visibleFrom <- traverse (formatTime SelFormatDateTime) $ sheetVisibleFrom sheet
|
|
when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI Warning $
|
|
maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom
|
|
mPseudonym <- runMaybeT $ do
|
|
uid <- MaybeT maybeAuthId
|
|
Entity _ SheetPseudonym{sheetPseudonymPseudonym} <- MaybeT . runDB . getBy $ UniqueSheetPseudonymUser sid uid
|
|
return $ review _PseudonymText sheetPseudonymPseudonym
|
|
(generateWidget, generateEnctype) <- generateFormPost $ \csrf ->
|
|
over _2 ((toWidget csrf <>) . fvInput) <$> mreq (buttonField BtnGenerate) "" Nothing
|
|
defaultLayout $ do
|
|
setTitleI $ MsgSheetTitle tid ssh csh shn
|
|
sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet
|
|
sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet
|
|
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
|
|
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
|
|
$(widgetFile "sheetShow")
|
|
|
|
getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
|
getSPseudonymR = postSPseudonymR
|
|
postSPseudonymR tid ssh csh shn = do
|
|
uid <- requireAuthId
|
|
shId <- runDB $ fetchSheetId tid ssh csh shn
|
|
let
|
|
genPseudonym = do
|
|
inserted <- runExceptT . mapExceptT (runDB . setSerializable) $ do
|
|
candidate <- liftIO getRandom
|
|
existing <- lift . getBy $ UniqueSheetPseudonymUser shId uid
|
|
case existing of
|
|
Just (Entity _ SheetPseudonym{sheetPseudonymPseudonym}) -> throwE sheetPseudonymPseudonym
|
|
Nothing
|
|
-> lift $ fmap (const candidate) <$> insertUnique (SheetPseudonym shId candidate uid)
|
|
case inserted of
|
|
Right Nothing -> genPseudonym
|
|
Right (Just ps) -> return ps
|
|
Left ps -> return ps
|
|
ps <- genPseudonym
|
|
selectRep $ do
|
|
provideRep . return $ review _PseudonymText ps
|
|
provideJson ps
|
|
provideRep (redirect $ CSheetR tid ssh csh shn SShowR :#: ("pseudonym" :: Text) :: Handler Html)
|
|
|
|
|
|
getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
|
|
getSFileR tid ssh csh shn typ title = do
|
|
results <- 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.^. CourseSchool E.==. E.val ssh )
|
|
E.&&. (course E.^. CourseTerm E.==. E.val tid )
|
|
)
|
|
-- return desired columns
|
|
return $ (file E.^. FileTitle, file E.^. FileContent)
|
|
case results of
|
|
[(E.Value fileTitle, E.Value fileContent)]
|
|
| Just fileContent' <- fileContent -> do
|
|
whenM downloadFiles $
|
|
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
|
|
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
|
|
| otherwise -> sendResponseStatus noContent204 ()
|
|
[] -> notFound
|
|
other -> do
|
|
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
|
|
error "Multiple matching files found."
|
|
|
|
getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getSheetNewR tid ssh csh = do
|
|
lastSheets <- runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
|
|
E.limit 1
|
|
return sheet
|
|
let template = case lastSheets of
|
|
((Entity {entityVal=Sheet{..}}):_) -> Just $ SheetForm
|
|
{ sfName = stepTextCounterCI sheetName
|
|
, sfDescription = sheetDescription
|
|
, sfType = sheetType
|
|
, sfGrouping = sheetGrouping
|
|
, sfVisibleFrom = addOneWeek <$> sheetVisibleFrom
|
|
, sfActiveFrom = addOneWeek sheetActiveFrom
|
|
, sfActiveTo = addOneWeek sheetActiveTo
|
|
, sfSubmissionMode = sheetSubmissionMode
|
|
, sfUploadMode = sheetUploadMode
|
|
, sfSheetF = Nothing
|
|
, sfHintFrom = addOneWeek <$> sheetHintFrom
|
|
, sfHintF = Nothing
|
|
, sfSolutionFrom = addOneWeek <$> sheetSolutionFrom
|
|
, sfSolutionF = Nothing
|
|
, sfMarkingF = Nothing
|
|
, sfMarkingText = sheetMarkingText
|
|
}
|
|
_other -> Nothing
|
|
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
|
|
insertUnique $ newSheet
|
|
handleSheetEdit tid ssh csh Nothing template action
|
|
|
|
postSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
postSheetNewR = getSheetNewR
|
|
|
|
|
|
getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
|
getSEditR tid ssh csh shn = do
|
|
(Entity sid Sheet{..}, sheetFileIds) <- runDB $ do
|
|
ent <- fetchSheet tid ssh csh shn
|
|
fti <- getFtIdMap $ entityKey ent
|
|
return (ent, fti)
|
|
let template = Just $ SheetForm
|
|
{ sfName = sheetName
|
|
, sfDescription = sheetDescription
|
|
, sfType = sheetType
|
|
, sfGrouping = sheetGrouping
|
|
, sfVisibleFrom = sheetVisibleFrom
|
|
, sfActiveFrom = sheetActiveFrom
|
|
, sfActiveTo = sheetActiveTo
|
|
, sfSubmissionMode = sheetSubmissionMode
|
|
, sfUploadMode = sheetUploadMode
|
|
, sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise
|
|
, sfHintFrom = sheetHintFrom
|
|
, sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint
|
|
, sfSolutionFrom = sheetSolutionFrom
|
|
, sfSolutionF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution
|
|
, sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking
|
|
, sfMarkingText = sheetMarkingText
|
|
}
|
|
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 ssh csh (Just sid) template action
|
|
|
|
postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
|
postSEditR = getSEditR
|
|
|
|
handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
|
|
handleSheetEdit tid ssh 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 $ TermSchoolCourseShort tid ssh csh
|
|
oldAutoDistribute <- fmap sheetAutoDistribute . join <$> traverse get msId
|
|
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
|
|
, sheetUploadMode = sfUploadMode
|
|
, sheetSubmissionMode = sfSubmissionMode
|
|
, sheetAutoDistribute = fromMaybe False oldAutoDistribute
|
|
}
|
|
mbsid <- dbAction newSheet
|
|
case mbsid of
|
|
Nothing -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName)
|
|
(Just sid) -> do -- save files in DB:
|
|
whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise
|
|
whenIsJust sfHintF $ insertSheetFile' sid SheetHint
|
|
whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution
|
|
whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking
|
|
insert_ $ SheetEdit aid actTime sid
|
|
addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
|
|
-- Sanity checks generating warnings only, but not errors!
|
|
warnTermDays tid [sfVisibleFrom, Just sfActiveFrom, Just sfActiveTo, sfHintFrom, sfSolutionFrom]
|
|
return True
|
|
when saveOkay $ redirect $ case msId of
|
|
Just _ -> CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
|
|
Nothing -> CSheetR tid ssh csh sfName SCorrR
|
|
(FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
|
|
_ -> runDB $ warnTermDays tid $ (join . (flip fmap template))
|
|
<$> [sfVisibleFrom, Just . sfActiveFrom, Just . sfActiveTo, sfHintFrom, sfSolutionFrom]
|
|
|
|
let pageTitle = maybe (MsgSheetTitleNew tid ssh csh)
|
|
(MsgSheetTitle tid ssh csh) mbshn
|
|
-- let formTitle = pageTitle -- no longer used in template
|
|
let formText = Nothing :: Maybe UniWorXMessage
|
|
actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute
|
|
defaultLayout $ do
|
|
setTitleI pageTitle
|
|
$(widgetFile "formPageI18n")
|
|
|
|
|
|
getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
|
getSDelR = postSDelR
|
|
postSDelR tid ssh csh shn = do
|
|
sid <- runDB $ fetchSheetId tid ssh csh shn
|
|
deleteR $ (sheetDeleteRoute $ Set.singleton sid)
|
|
{ drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR
|
|
, drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR
|
|
}
|
|
|
|
|
|
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 (CorrectorState, Load)
|
|
, cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX
|
|
}
|
|
|
|
type Loads = Map UserId (CorrectorState, 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, sheetCorrector E.^. SheetCorrectorState)
|
|
where
|
|
toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
|
|
toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton uid (state, load)
|
|
|
|
|
|
correctorForm :: SheetId -> MForm Handler (FormResult (Bool {- ^ autoDistribute -} , Set SheetCorrector), [FieldView UniWorX])
|
|
correctorForm shid = do
|
|
cListIdent <- newFormIdent
|
|
let
|
|
guardNonDeleted :: UserId -> Handler (Maybe UserId)
|
|
guardNonDeleted uid = do
|
|
CryptoID{ciphertext} <- 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 = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
|
|
(autoDistribute, defaultLoads', currentLoads') <- lift . runDB $ (,,) <$> (sheetAutoDistribute <$> getJust shid) <*> defaultLoads shid <*> currentLoads
|
|
loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if
|
|
| Map.null currentLoads'
|
|
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI Warning MsgCorrectorsDefaulted)
|
|
| otherwise -> return $ Map.fromList (map (, (CorrectorNormal, 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'
|
|
(autoDistributeRes, autoDistributeView) <- mreq checkBoxField (fsm MsgAutoAssignCorrs) (Just autoDistribute)
|
|
let
|
|
tutorField :: Field Handler [UserEmail]
|
|
tutorField = convertField (map CI.mk) (map CI.original) $ 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 (CorrectorNormal, 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, (CorrectorState, Load)) -> MForm Handler CorrectorForm
|
|
constructFields (uid, uname, (state, Load{..})) = do
|
|
CryptoID{ciphertext} <- encrypt uid :: MForm Handler CryptoUUIDUser
|
|
let
|
|
fs name = ""
|
|
{ fsName = Just $ tshow ciphertext <> "-" <> name
|
|
}
|
|
rationalField = convertField toRational fromRational doubleField
|
|
|
|
(stateRes, cfViewState) <- mreq (selectField optionsFinite) (fs "state") (Just state)
|
|
(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 (CorrectorState, Load)
|
|
cfResult = (,) <$> stateRes <*> (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 MsgCorState) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewState
|
|
, 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 <*> (snd <$> cfResult) <*> (fst <$> 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 ( (,) <$> autoDistributeRes <*> corrResults
|
|
, [ autoDistributeView
|
|
, countTutView
|
|
, FieldView
|
|
{ fvLabel = text $ mr MsgCorrectors
|
|
, fvTooltip = Just $ toHtml $ mr MsgCorrectorStateTip
|
|
, 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 -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
|
postSCorrR = getSCorrR
|
|
getSCorrR tid ssh csh shn = do
|
|
Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh 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 (autoDistribute, res') -> runDB $ do
|
|
update shid [ SheetAutoDistribute =. autoDistribute ]
|
|
deleteWhere [SheetCorrectorSheet ==. shid]
|
|
insertMany_ $ Set.toList res'
|
|
addMessageI Success MsgCorrectorsUpdated
|
|
FormMissing -> return ()
|
|
|
|
let
|
|
-- formTitle = MsgSheetCorrectorsTitle tid ssh csh shn
|
|
formText = Nothing :: Maybe (SomeMessage UniWorX)
|
|
actionUrl = CSheetR tid ssh csh shn SCorrR
|
|
-- actionUrl = CSheetR tid ssh csh shn SShowR
|
|
defaultLayout $ do
|
|
setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn
|
|
$(widgetFile "formPageI18n")
|