{-# 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 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 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.Monad.Random.Class (MonadRandom(..)) import Utils.Sql import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) import System.FilePath (addExtension) {- * Implement Handlers * Implement Breadcrumbs in Foundation * Implement Access in Foundation -} data SheetForm = SheetForm { sfName :: SheetName , sfVisibleFrom :: Maybe UTCTime , sfActiveFrom :: UTCTime , sfActiveTo :: UTCTime , sfHintFrom :: Maybe UTCTime , sfSolutionFrom :: Maybe UTCTime , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe (ConduitT () (Either FileId File) Handler ()) , sfType :: SheetType , sfGrouping :: SheetGroup , sfSubmissionMode :: SubmissionMode , sfDescription :: Maybe Html , 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 = identifyForm FIDsheet $ \html -> do oldFileIds <- (return.) <$> case msId of Nothing -> return $ partitionFileType mempty (Just sId) -> liftHandler $ runDB $ getFtIdMap sId mr <- getMsgRenderer ctime <- ceilingQuarterHour <$> liftIO getCurrentTime (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm <$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template) <* aformSection MsgSheetFormTimes <*> 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) <*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren" & setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template) <*> aopt utcTimeField (fslpI MsgSheetSolutionFrom "Datum, sonst nur für Korrektoren" & setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> 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 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)) <*> aopt htmlField (fslpI MsgSheetDescription "Html") (sfDescription <$> template) <*> aopt htmlField (fslpI MsgSheetMarking "Html") (sfMarkingText <$> 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) <- [ ( sfVisibleFrom <= Just sfActiveFrom , render MsgSheetErrVisibility) , ( sfActiveFrom <= sfActiveTo , render MsgSheetErrDeadlineEarly) , ( NTop sfHintFrom >= NTop (Just sfActiveFrom) , render MsgSheetErrHintEarly) , ( NTop sfSolutionFrom >= NTop (Just 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.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 = 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{..}, _, _, _)} -> dateTimeCell sheetActiveFrom , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> 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 mkCid = encrypt sid mkRoute = do cid' <- mkCid 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") in cellTell acell $ stats submissionRatingPoints , 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 -> textCell $ textPercent sPoints maxPoints _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") 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] -- 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 sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet sheetTo <- 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) $(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 <- 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 searchShn sheet -- let lastSheetEdit = E.sub_select . 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 return sheet now <- liftIO getCurrentTime let template = case lastSheets of ((Entity {entityVal=Sheet{..}}):_) -> let addTime = addWeeks $ max 1 $ weeksToAdd sheetActiveTo 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 } _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 , 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 = 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 -> 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 , 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 $ Map.fromList [ (date,name) | (Just date, name) <- [ (sfVisibleFrom, MsgSheetVisibleFrom) , (Just sfActiveFrom, MsgSheetActiveFrom) , (Just sfActiveTo, MsgSheetActiveTo) , (sfHintFrom, MsgSheetSolutionFromTip) , (sfSolutionFrom, MsgSheetSolutionFrom) ] ] 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 $ 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 () -> 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 (Either UserEmail 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 cLoad, E.Value cState) -> Map.singleton (Right uid) (cState, cLoad) correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector)) correctorForm shid = wFormToAForm $ do currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute userId <- liftHandler requireAuthId MsgRenderer mr <- getMsgRenderer let currentLoads :: DB Loads currentLoads = Map.union <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] []) <*> fmap (fmap ((,) <$> invDBSheetCorrectorState <*> invDBSheetCorrectorLoad) . Map.mapKeysMonotonic Left) (sourceInvitationsF shid) (defaultLoads', currentLoads') <- liftHandler . runDB $ (,) <$> defaultLoads shid <*> currentLoads isWrite <- liftHandler $ isWriteRequest currentRoute let applyDefaultLoads = Map.null currentLoads' && not isWrite loads :: Map (Either UserEmail UserId) (CorrectorState, Load) loads | applyDefaultLoads = defaultLoads' | otherwise = currentLoads' countTutRes <- wreq checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads -- when (not (Map.null loads) && applyDefaultLoads) $ -- Alert Message -- addMessageI Warning MsgCorrectorsDefaulted when (not (Map.null loads) && applyDefaultLoads) $ -- Alert Notification wformMessage =<< messageIconI Warning IconNoCorrectors MsgCorrectorsDefaulted 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 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)) -> Set (Either (Invitation' SheetCorrector) SheetCorrector) postProcess = Set.fromList . map postProcess' . Map.elems where sheetCorrectorSheet = shid postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..} postProcess' (Left email, (cState, load)) = Left (email, shid, (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) True filledData 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 . identifyForm FIDcorrectors . renderAForm FormStandard $ (,) <$> areq checkBoxField (fslI MsgAutoAssignCorrs) (Just sheetAutoDistribute) <*> correctorForm shid case res of FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do update shid [ SheetAutoDistribute =. autoDistribute ] let (invites, adds) = partitionEithers $ Set.toList sheetCorrectors deleteWhere [ SheetCorrectorSheet ==. shid ] insertMany_ adds deleteWhere [InvitationFor ==. invRef @SheetCorrector shid, InvitationEmail /<-. toListOf (folded . _1) invites] sinkInvitationsF correctorInvitationConfig invites addMessageI Success MsgCorrectorsUpdated FormMissing -> return () defaultLayout $ do setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn wrapForm formWidget def { formAction = Just . SomeRoute $ CSheetR tid ssh csh shn SCorrR , formEncoding = formEnctype } 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 <- 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 $ [whamlet|You have corrector access to #{shn}.|]