{-# 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.HashSet as HashSet 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) import qualified Control.Monad.State.Class as State {- * 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 , sfSubmissionMode :: SubmissionMode , sfGrouping :: SheetGroup , sfType :: SheetType , sfAutoDistribute :: Bool , sfMarkingText :: Maybe Html , sfAnonymousCorrection :: Bool , 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 . validateForm validateSheet $ \html -> do oldFileIds <- (return.) <$> case msId of Nothing -> return $ partitionFileType mempty (Just sId) -> liftHandler $ runDB $ getFtIdMap sId MsgRenderer mr <- getMsgRenderer ctime <- ceilingQuarterHour <$> liftIO getCurrentTime 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 <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction)) <*> sheetGroupAFormReq (fslI MsgSheetGroup) ((sfGrouping <$> template) <|> pure NoGroups) <*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template) <*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template) <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) <*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template) <*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template) where validateSheet :: FormValidator SheetForm Handler () validateSheet = do SheetForm{..} <- State.get guardValidation MsgSheetErrVisibility $ NTop sfVisibleFrom <= NTop sfActiveFrom guardValidation MsgSheetErrDeadlineEarly $ NTop sfActiveFrom <= NTop sfActiveTo guardValidation MsgSheetErrHintEarly $ NTop sfHintFrom >= NTop sfActiveFrom guardValidation MsgSheetErrSolutionEarly $ NTop sfSolutionFrom >= NTop sfActiveTo guardValidation MsgSheetErrVisibleWithoutActive $ is _Just sfActiveFrom || is _Nothing sfVisibleFrom warnValidation MsgSheetWarnNoActiveTo $ is _Just sfActiveTo || is _Nothing sfActiveFrom 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"] & forceFilter "may-access" (Any True) (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 = return , 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 = mconcat [ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} -> let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool)) in (==b) <$> sheetFilter sheetName :: DB Bool ] , 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"] & forceFilter "may-access" (Any True) (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery = fileData , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId , dbtColonnade = colonnadeFiles , dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType) , dbtStyle = def , dbtFilter = mconcat [ singletonMap "may-access" . FilterProjected $ \(Any b) r -> let (E.Value fName, _, E.Value fType) = r :: (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType) in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool ] , 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 , sfAnonymousCorrection = sheetAnonymousCorrection } _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 , sfAnonymousCorrection = sheetAnonymousCorrection , 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 , sheetAnonymousCorrection = sfAnonymousCorrection } mbsid <- dbAction newSheet case mbsid of Nothing -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName) (Just sid) -> do -- save files in DB: insertSheetFile' sid SheetExercise $ fromMaybe (return ()) sfSheetF insertSheetFile' sid SheetHint $ fromMaybe (return ()) sfHintF insertSheetFile' sid SheetSolution $ fromMaybe (return ()) sfSolutionF insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF 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 -> 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 fid) = do lift . void $ upsertBy (UniqueSheetFile fid sid ftype) (SheetFile sid fid ftype) [] tell $ singleton fid 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 (multiUserInvitationField . MUILookupAnyUser $ Just previousCorrectors) (fslpI MsgCorrector (mr MsgLdapIdentificationOrEmail) & 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 <- messageIconI Info IconEmail 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) 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 <- HashSet.singleton . 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