{-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Sheet where import Import hiding (link) import Jobs.Queue -- import Utils.Lens import Utils.Sheet import Handler.Utils -- import Handler.Utils.Zip import Handler.Utils.SheetType import Handler.Utils.Delete import Handler.Utils.Invitations -- import Data.Time -- import qualified Data.Text as T -- import Data.Function ((&)) -- -- import Colonnade hiding (fromMaybe, singleton, bool) -- -- 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.Utils as E -- import qualified Database.Esqueleto.Internal.Sql as E import qualified Data.Set as Set import qualified Data.Map as Map import Data.Map ((!)) import Utils.Sql import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) import Data.Time.Clock.System (systemEpochDay) {- * Implement Handlers * Implement Breadcrumbs in Foundation * Implement Access in Foundation -} type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector) data SheetForm = SheetForm { sfName :: SheetName , sfDescription :: Maybe Html , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ()) , sfVisibleFrom :: Maybe UTCTime , sfActiveFrom :: Maybe UTCTime , sfActiveTo :: Maybe UTCTime , sfHintFrom :: Maybe UTCTime , sfSolutionFrom :: Maybe UTCTime , sfType :: SheetType , sfGrouping :: SheetGroup , sfSubmissionMode :: SubmissionMode , sfAutoDistribute :: Bool , sfMarkingText :: Maybe Html , sfCorrectors :: Loads -- Keine SheetId im Formular! } data ButtonGeneratePseudonym = BtnGenerate deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonGeneratePseudonym instance Finite ButtonGeneratePseudonym nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1) instance Button UniWorX ButtonGeneratePseudonym where btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|] btnClasses BtnGenerate = [BCIsButton, BCDefault] 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 = identifyForm FIDsheet $ \html -> do oldFileIds <- (return.) <$> case msId of Nothing -> return $ partitionFileType mempty (Just sId) -> liftHandler $ runDB $ getFtIdMap sId mr'@(MsgRenderer mr) <- getMsgRenderer ctime <- ceilingQuarterHour <$> liftIO getCurrentTime (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm <$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template) <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template) <* aformSection MsgSheetFormFiles <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template) <*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template) <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template) <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template) <* aformSection MsgSheetFormTimes <*> aopt utcTimeField (fslI MsgSheetVisibleFrom & setTooltip MsgSheetVisibleFromTip) ((sfVisibleFrom <$> template) <|> pure (Just ctime)) <*> aopt utcTimeField (fslI MsgSheetActiveFrom & setTooltip MsgSheetActiveFromTip) (sfActiveFrom <$> template) <*> aopt utcTimeField (fslI MsgSheetActiveTo & setTooltip MsgSheetActiveToTip) (sfActiveTo <$> template) <*> aopt utcTimeField (fslpI MsgSheetHintFrom (mr MsgSheetHintFromPlaceholder) & setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template) <*> aopt utcTimeField (fslpI MsgSheetSolutionFrom (mr MsgSheetSolutionFromPlaceholder) & setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template) <* aformSection MsgSheetFormType <*> sheetTypeAFormReq (fslI MsgSheetType & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus, MsgSheetTypeInfoInformational, MsgSheetTypeInfoNotGraded])) (sfType <$> template) <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template) <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction)) <*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template) <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) <*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template) 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) <- [ ( NTop sfVisibleFrom <= NTop sfActiveFrom , render MsgSheetErrVisibility) , ( NTop sfActiveFrom <= NTop sfActiveTo , render MsgSheetErrDeadlineEarly) , ( NTop sfHintFrom >= NTop sfActiveFrom , render MsgSheetErrHintEarly) , ( NTop sfSolutionFrom >= NTop sfActiveTo , render MsgSheetErrSolutionEarly) ] ] getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetCurrentR tid ssh csh = do mbShn <- runDB $ sheetCurrent tid ssh csh case mbShn of Just shn -> redirectAccess $ CSheetR tid ssh csh shn SShowR Nothing -> do -- no current sheet exists -- users should never see a link to this URL in this situation, -- but we had confused users that used a bookmark instead. let headingShort = [whamlet|_{MsgMenuSheetCurrent}|] headingLong = prependCourseTitle tid ssh csh MsgMenuSheetCurrent siteLayout headingShort $ do setTitleI headingLong [whamlet|_{MsgSheetNoCurrent}|] getSheetOldUnassignedR:: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetOldUnassignedR tid ssh csh = do mbShn <- runDB $ sheetOldUnassigned tid ssh csh case mbShn of Just shn -> redirectAccess $ CSheetR tid ssh csh shn SSubsR Nothing -> do -- no unassigned submissions in any inactive sheet -- users should never see a link to this URL in this situation, -- but we had confused users that used a bookmark instead. let headingShort = [whamlet|_{MsgMenuSheetOldUnassigned}|] headingLong = prependCourseTitle tid ssh csh MsgMenuSheetOldUnassigned siteLayout headingShort $ do setTitleI headingLong [whamlet|_{MsgSheetNoOldUnassigned}|] getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetListR tid ssh csh = do muid <- maybeAuthId now <- liftIO getCurrentTime cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh let hasSFT :: (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool) -> [SheetFileType] hasSFT (E.Value hasExercise, E.Value hasHint, E.Value hasSolution, E.Value hasMarking) = [ sft | sft <- universeF , sft /= SheetExercise || hasExercise , sft /= SheetHint || hasHint , sft /= SheetSolution || hasSolution , sft /= SheetMarking || hasMarking ] lastSheetEdit sheet = E.subSelectMaybe . 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 = hasReadAccessTo $ CSheetR tid ssh csh sheetName SShowR sheetCol = widgetColonnade . mconcat $ [ -- dbRow , sortable (Just "name") (i18nCell MsgSheet) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) sheetName , sortable (Just "last-edit") (i18nCell MsgLastEdit) $ \DBRow{dbrOutput=(_, E.Value mEditTime, _, _)} -> foldMap dateTimeCell mEditTime , sortable (Just "visible-from") (i18nCell MsgAccessibleSince) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom , sortable (toNothing "downloads") (i18nCell MsgFiles) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, existFiles)} -> listCell [ icnCell & addIconFixedWidth | let existingSFTs = hasSFT existFiles , sft <- [minBound..maxBound] , let link = CSheetR tid ssh csh sheetName $ SZipR sft , let icn = toWgt $ sheetFile2markup sft , let icnCell = if sft `elem` existingSFTs then linkEitherCell link (icn, [whamlet| |]) else spacerCell ] id & cellAttrs <>~ [("class","list--inline list--space-separated")] , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell sheetActiveFrom , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell 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|#{cid2}|]) , sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} -> let stats = sheetTypeSum sheetType in -- for statistics over all shown rows case mbSub of Nothing -> cellTell mempty $ stats Nothing (Just (Entity sid sub@Submission{..})) -> let mkRoute :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (Route UniWorX) mkRoute = liftHandler $ do cid' <- encrypt sid return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating") tellStats = do r <- mkRoute showRating <- hasReadAccessTo r tell . stats $ bool Nothing submissionRatingPoints showRating in acell & cellContents %~ (<* tellStats) , sortable Nothing -- (Just "percent") (i18nCell MsgRatingPercent) $ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType, sheetName}, _, mbSub,_)} -> case mbSub of (Just (Entity sid Submission{submissionRatingPoints=Just sPoints})) -> case preview (_grading . _maxPoints) sType of Just maxPoints | maxPoints /= 0 -> cell $ do cID <- encrypt sid showRating <- hasReadAccessTo $ CSubmissionR tid ssh csh sheetName cID CorrectionR bool (return ()) (toWidget . toMessage $ textPercent sPoints maxPoints) showRating _other -> mempty _other -> mempty ] psValidator = def & defaultSorting [SortDescBy "submission-until", SortDescBy "submission-since"] (raw_statistics,table) <- runDB $ dbTableWidget psValidator DBTable { dbtColonnade = sheetCol , dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> do sheetData dt let existFiles = -- check whether files exist for given type ( hasSheetFileQuery sheet SheetExercise , hasSheetFileQuery sheet SheetHint , hasSheetFileQuery sheet SheetSolution , hasSheetFileQuery sheet SheetMarking ) return (sheet, lastSheetEdit sheet, submission, existFiles) , 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 ) , ( "visible-from" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetVisibleFrom ) , ( "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 , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing } -- ) ( -- !!!DEPRECTAED!!! Summary only over shown rows !!! -- -- 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 raw_statistics -- only over shown rows -- foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) defaultLayout $ do $(widgetFile "sheetList") -- Show single sheet getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSShowR tid ssh csh shn = do now <- liftIO getCurrentTime Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn seeAllModificationTimestamps <- hasReadAccessTo $ CSheetR tid ssh csh shn SIsCorrR -- ordinary users should not see modification dates older than visibility let sftVisible :: IsDBTable m a => SheetFileType -> DBCell m a sftVisible sft | Just dts <- sheetFileTypeDates sheet sft = dateTimeCellVisible now dts | otherwise = isVisibleCell False sftModification :: IsDBTable m a => SheetFileType -> UTCTime -> DBCell m a sftModification sft mtime | seeAllModificationTimestamps = dateTimeCell mtime | NTop (Just mtime) > NTop (sheetFileTypeDates sheet sft) = dateTimeCell mtime | otherwise = mempty let fileData (sheetFile `E.InnerJoin` file) = do -- Restrict to consistent rows that correspond to each other E.on (sheetFile E.^. SheetFileFile E.==. file E.^. FileId) -- filter to requested file E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories -- return desired columns return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = widgetColonnade $ mconcat [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> let link = CSheetR tid ssh csh shn $ SZipR ftype in tellCell (Any True) $ anchorCell link [whamlet|#{sheetFile2markup ftype} _{ftype}|] -- i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) -- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName)))) , sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell (CSheetR tid ssh csh shn (SFileR fType fName)) (str2widget fName) , sortable (toNothing "visible") (i18nCell MsgVisibleFrom) $ \(_, _ , E.Value ftype) -> sftVisible ftype , sortable (Just "time") (i18nCell MsgFileModified) $ \(_,E.Value modified, E.Value ftype) -> sftModification ftype modified -- , colFileModification (view _2) ] let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"] (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery = fileData , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId , dbtColonnade = colonnadeFiles , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } -> guardAuthorizedFor (CSheetR tid ssh csh shn $ SFileR fType fName) dbrOutput , dbtStyle = def , dbtFilter = mempty , dbtFilterUI = mempty , dbtIdent = "files" :: Text , dbtSorting = Map.fromList [ ( "type" , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> E.orderByEnum $ sheetFile E.^. SheetFileType ) , ( "path" , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileTitle ) -- , ( "visible" -- , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet -- ) , ( "time" , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileModified ) ] , dbtParams = def , dbtCsvEncode = noCsvEncode , dbtCsvDecode = Nothing } (hasHints, hasSolution) <- runDB $ do hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ] hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ] return (hasHints, hasSolution) 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 let generateForm = wrapForm generateWidget def { formAction = Just . SomeRoute $ CSheetR tid ssh csh shn SPseudonymR , formEncoding = generateEnctype , formSubmit = FormNoSubmit } defaultLayout $ do setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn let zipLink = CSheetR tid ssh csh shn SArchiveR visibleFrom = visibleUTCTime SelFormatDateTime <$> sheetVisibleFrom sheet hasSubmission = classifySubmissionMode (sheetSubmissionMode sheet) /= SubmissionModeNone sheetFrom <- traverse (formatTime SelFormatDateTime) $ sheetActiveFrom sheet sheetTo <- traverse (formatTime SelFormatDateTime) $ sheetActiveTo sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet) submissionTip <- messageI Info MsgSheetCorrectorSubmissionsTip $(widgetFile "sheetShow") getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSArchiveR tid ssh csh shn = do archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgSheetArchiveName tid ssh csh shn let sftArchive = CSheetR tid ssh csh shn . SZipR -- used to check access to SheetFileTypes allowedSFTs <- filterM (hasReadAccessTo . sftArchive) [minBound..maxBound] serveZipArchive archiveName $ sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal 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 sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file .| C.map entityVal getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent getSZipR tid ssh csh shn sft = do sft' <- ap getMessageRender $ pure sft archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgSheetTypeArchiveName tid ssh csh shn sft' serveSomeFiles archiveName $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetNewR tid ssh csh = do parShn <- runInputGetResult $ iopt ciField "shn" let searchShn sheet = case parShn of (FormSuccess (Just shn)) -> E.where_ $ sheet E.^. SheetName E.==. E.val shn -- (FormFailure msgs) -> -- not in MonadHandler anymore -- forM_ msgs (addMessage Error . toHtml) _other -> return () (lastSheets, loads) <- runDB $ do lSheets <- 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 searchShn sheet -- let lastSheetEdit = E.subSelectMaybe . E.from $ \sheetEdit -> do -- E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId -- return . E.max_ $ sheetEdit E.^. SheetEditTime -- Preferring last edited sheet may lead to suggesting duplicated sheet name numbers -- E.orderBy [E.desc lastSheetEdit, E.desc (sheet E.^. SheetActiveFrom)] E.orderBy [E.desc (sheet E.^. SheetActiveFrom)] E.limit 1 let firstEdit = E.subSelectMaybe . E.from $ \sheetEdit -> do E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId return . E.min_ $ sheetEdit E.^. SheetEditTime return (sheet, firstEdit) cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh loads <- defaultLoads cid return (lSheets, loads) now <- liftIO getCurrentTime let template = case lastSheets of ((Entity {entityVal=Sheet{..}}, E.Value fEdit):_) -> let addTime = addWeeks $ max 1 $ weeksToAdd (fromMaybe (UTCTime systemEpochDay 0) $ sheetActiveTo <|> fEdit) now in Just $ SheetForm { sfName = stepTextCounterCI sheetName , sfDescription = sheetDescription , sfType = sheetType , sfGrouping = sheetGrouping , sfVisibleFrom = addTime <$> sheetVisibleFrom , sfActiveFrom = addTime <$> sheetActiveFrom , sfActiveTo = addTime <$> sheetActiveTo , sfSubmissionMode = sheetSubmissionMode , sfSheetF = Nothing , sfHintFrom = addTime <$> sheetHintFrom , sfHintF = Nothing , sfSolutionFrom = addTime <$> sheetSolutionFrom , sfSolutionF = Nothing , sfMarkingF = Nothing , sfMarkingText = sheetMarkingText , sfAutoDistribute = sheetAutoDistribute , sfCorrectors = loads } _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, currentLoads) <- runDB $ do ent@(Entity sid _) <- fetchSheet tid ssh csh shn fti <- getFtIdMap $ entityKey ent cLoads <- Map.union <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (InvDBDataSheetCorrector sheetCorrectorLoad sheetCorrectorState, InvTokenDataSheetCorrector)) (selectList [ SheetCorrectorSheet ==. sid ] []) <*> fmap (fmap (, InvTokenDataSheetCorrector) . Map.mapKeysMonotonic Left) (sourceInvitationsF sid) return (ent, fti, cLoads) let template = Just $ SheetForm { sfName = sheetName , sfDescription = sheetDescription , sfType = sheetType , sfGrouping = sheetGrouping , sfVisibleFrom = sheetVisibleFrom , sfActiveFrom = sheetActiveFrom , sfActiveTo = sheetActiveTo , sfSubmissionMode = sheetSubmissionMode , 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 , sfAutoDistribute = sheetAutoDistribute , sfCorrectors = currentLoads } let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead 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 -> YesodJobDB UniWorX (Maybe SheetId)) -> Handler Html handleSheetEdit tid ssh csh msId template dbAction = do let mbshn = sfName <$> template aid <- requireAuthId cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template case res of (FormSuccess SheetForm{..}) -> do saveOkay <- runDBJobs $ do actTime <- liftIO getCurrentTime 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 , sheetSubmissionMode = sfSubmissionMode , sheetAutoDistribute = sfAutoDistribute } 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! hoist lift . warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <- [ (sfVisibleFrom, MsgSheetVisibleFrom) , (sfActiveFrom, MsgSheetActiveFrom) , (sfActiveTo, MsgSheetActiveTo) , (sfHintFrom, MsgSheetSolutionFromTip) , (sfSolutionFrom, MsgSheetSolutionFrom) ] ] let sheetCorrectors :: Set (Either (Invitation' SheetCorrector) SheetCorrector) sheetCorrectors = Set.fromList . map f $ Map.toList sfCorrectors where f (Left email, invData) = Left (email, sid, invData) f (Right uid, (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)) = Right $ SheetCorrector uid sid load cState (invites, adds) = partitionEithers $ Set.toList sheetCorrectors deleteWhere [ SheetCorrectorSheet ==. sid ] insertMany_ adds deleteWhere [InvitationFor ==. invRef @SheetCorrector sid, InvitationEmail /<-. toListOf (folded . _1) invites] sinkInvitationsF correctorInvitationConfig invites return True when saveOkay $ redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB (FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml _ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <- [(sfVisibleFrom =<< template, MsgSheetVisibleFrom) ,(sfActiveFrom =<< template, MsgSheetActiveFrom) ,(sfActiveTo =<< template, MsgSheetActiveTo) ,(sfHintFrom =<< template, MsgSheetSolutionFromTip) ,(sfSolutionFrom =<< template, MsgSheetSolutionFrom) ] ] let pageTitle = maybe (MsgSheetTitleNew tid ssh csh) (MsgSheetTitle tid ssh csh) mbshn -- let formTitle = pageTitle -- no longer used in template actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute defaultLayout $ do setTitleI pageTitle let sheetEditForm = wrapForm formWidget def { formAction = Just $ SomeRoute actionUrl , formEncoding = formEnctype } $(i18nWidgetFile "sheet-edit") 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 -> ConduitT () (Either FileId File) Handler () -> YesodJobDB 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 liftHandler 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 defaultLoads :: CourseId -> 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 cId = do 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.subSelectMaybe . 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 cLoad, E.Value cState) -> Map.singleton (Right uid) (InvDBDataSheetCorrector cLoad cState, InvTokenDataSheetCorrector) correctorForm :: Loads -> AForm Handler Loads correctorForm loads' = wFormToAForm $ do currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute userId <- liftHandler requireAuthId MsgRenderer mr <- getMsgRenderer let loads :: Map (Either UserEmail UserId) (CorrectorState, Load) loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load) countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads let previousCorrectors :: E.SqlQuery (E.SqlExpr (Entity User)) previousCorrectors = E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> 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 E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName] return user miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) miAdd _ _ nudge submitView = Just $ \csrf -> do (addRes, addView) <- mpreq (multiUserField False $ Just previousCorrectors) (fslpI MsgCorrector (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if | existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData , not $ null existing -> FormFailure [mr MsgCorrectorExists] | otherwise -> FormSuccess . Map.fromList . zip [kStart..] $ Set.toList nCorrs return (addRes', $(widgetFile "sheetCorrectors/add")) miCell :: ListPosition -> Either UserEmail UserId -> Maybe (CorrectorState, Load) -> (Text -> Text) -> Form (CorrectorState, Load) miCell _ userIdent initRes nudge csrf = do (stateRes, stateView) <- mreq (selectField optionsFinite) ("" & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal (byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False (propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) ("" & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0 let res :: FormResult (CorrectorState, Load) res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes) tutRes' | FormSuccess True <- byTutRes = Just <$> countTutRes | otherwise = Nothing <$ byTutRes identWidget <- case userIdent of Left email -> return . toWidget $ mailtoHtml email Right uid -> do User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ getJust uid return $ nameEmailWidget userEmail userDisplayName userSurname invWarnMsg <- messageI Warning MsgEmailInvitationWarning return (res, $(widgetFile "sheetCorrectors/cell")) miDelete :: Map ListPosition (Either UserEmail UserId) -> ListPosition -> MaybeT (MForm Handler) (Map ListPosition ListPosition) miDelete = miDeleteList miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool miAllowAdd _ _ _ = True miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition miAddEmpty _ _ _ = Set.empty miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag miLayout :: ListLength -> Map ListPosition (Either UserEmail UserId, FormResult (CorrectorState, Load)) -> Map ListPosition Widget -> Map ListPosition (FieldView UniWorX) -> Map (Natural, ListPosition) Widget -> Widget miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout") miIdent :: Text miIdent = "correctors" postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Loads postProcess = Map.fromList . map postProcess' . Map.elems where postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> (Either UserEmail UserId, (InvitationDBData SheetCorrector, InvitationTokenData SheetCorrector)) postProcess' = over _2 $ \(cState, load) -> (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load))) filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?! fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) False filledData instance IsInvitableJunction SheetCorrector where type InvitationFor SheetCorrector = Sheet data InvitableJunction SheetCorrector = JunctionSheetCorrector { jSheetCorrectorLoad :: Load , jSheetCorrectorState :: CorrectorState } deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationDBData SheetCorrector = InvDBDataSheetCorrector { invDBSheetCorrectorLoad :: Load , invDBSheetCorrectorState :: CorrectorState } deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationTokenData SheetCorrector = InvTokenDataSheetCorrector deriving (Eq, Ord, Read, Show, Generic, Typeable) _InvitableJunction = iso (\SheetCorrector{..} -> (sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState)) (\(sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState) -> SheetCorrector{..}) instance ToJSON (InvitableJunction SheetCorrector) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } instance FromJSON (InvitableJunction SheetCorrector) where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } instance ToJSON (InvitationDBData SheetCorrector) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } instance FromJSON (InvitationDBData SheetCorrector) where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } instance ToJSON (InvitationTokenData SheetCorrector) where toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 } instance FromJSON (InvitationTokenData SheetCorrector) where parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } correctorInvitationConfig :: InvitationConfig SheetCorrector correctorInvitationConfig = InvitationConfig{..} where invitationRoute (Entity _ Sheet{..}) _ = do Course{..} <- get404 sheetCourse return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR invitationResolveFor _ = do cRoute <- getCurrentRoute case cRoute of Just (CSheetR tid csh ssh shn SCorrInviteR) -> fetchSheetId tid csh ssh shn _other -> error "correctorInvitationConfig called from unsupported route" invitationSubject (Entity _ Sheet{..}) _ = do Course{..} <- get404 sheetCourse return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|] invitationTokenConfig _ _ = do itAuthority <- Right <$> liftHandler requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ()) invitationInsertHook _ _ _ _ _ = id invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName invitationUltDest (Entity _ Sheet{..}) _ = do Course{..} <- get404 sheetCourse return . SomeRoute $ CSheetR courseTerm courseSchool courseShorthand sheetName SShowR getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSCorrInviteR = postSCorrInviteR postSCorrInviteR = invitationR correctorInvitationConfig getSIsCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html -- NOTE: The route SIsCorrR is only used to verfify corrector access rights to given sheet! getSIsCorrR _ _ _ shn = do defaultLayout . i18n $ MsgHaveCorrectorAccess shn