diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 2a193a7dd..d174152f5 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -1,931 +1,26 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -module Handler.Sheet where +module Handler.Sheet + ( module Handler.Sheet + ) where -import Import hiding (link) +import Import -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 --} +import Handler.Sheet.CorrectorInvite as Handler.Sheet (getSCorrInviteR, postSCorrInviteR) +import Handler.Sheet.Delete as Handler.Sheet +import Handler.Sheet.Edit as Handler.Sheet (getSEditR, postSEditR) +import Handler.Sheet.List as Handler.Sheet +import Handler.Sheet.Pseudonym as Handler.Sheet (getSPseudonymR, postSPseudonymR) +import Handler.Sheet.Current as Handler.Sheet +import Handler.Sheet.Download as Handler.Sheet +import Handler.Sheet.New as Handler.Sheet +import Handler.Sheet.Show as Handler.Sheet -type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector) - -data SheetForm = SheetForm - { sfName :: SheetName - , sfDescription :: Maybe Html - , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe FileUploads - , 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 FileReference) -getFtIdMap sId = do - allSheetFiles <- E.select . E.from $ \sheetFile -> do - E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId - return sheetFile - return $ partitionFileType [ (sheetFileType, sf ^. _FileReference . _1) | Entity _ sf@SheetFile{..} <- allSheetFiles ] - -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 = do - -- filter to requested file - E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid - E.&&. E.not_ (E.isNothing $ sheetFile E.^. SheetFileContent) -- don't show directories - -- return desired columns - return $ (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileModified, 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.^. SheetFileId) - , 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.orderByEnum $ sheetFile E.^. SheetFileType - ) - , ( "path" - , SortColumn $ \sheetFile -> sheetFile E.^. SheetFileTitle - ) - -- , ( "visible" - -- , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet - -- ) - , ( "time" - , SortColumn $ \sheetFile -> sheetFile E.^. SheetFileModified - ) - ] - , 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 <>) . fvWidget) <$> 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 - shId <- runDB $ fetchSheetId tid ssh csh shn - - MsgRenderer mr <- getMsgRenderer - let archiveName = flip addExtension (unpack extensionZip) . unpack . mr $ MsgSheetArchiveName tid ssh csh shn - let sftArchive = CSheetR tid ssh csh shn . SZipR -- used to check access to SheetFileTypes - allowedSFTs <- filterM (hasReadAccessTo . sftArchive) universeF - multipleSFTs <- if - | length allowedSFTs < 2 -> return False - | otherwise -> runDB . E.selectExists . E.from $ \(sheet `E.InnerJoin` (sFile1 `E.InnerJoin` sFile2)) -> do - E.on $ sFile1 E.^. SheetFileType E.!=. sFile2 E.^. SheetFileType - E.&&. sFile1 E.^. SheetFileTitle E.==. sFile2 E.^. SheetFileTitle - E.on $ sheet E.^. SheetId E.==. sFile1 E.^. SheetFileSheet - E.&&. sheet E.^. SheetId E.==. sFile2 E.^. SheetFileSheet - E.where_ $ sheet E.^. SheetId E.==. E.val shId - E.&&. sFile1 E.^. SheetFileType `E.in_` E.valList allowedSFTs - E.&&. sFile2 E.^. SheetFileType `E.in_` E.valList allowedSFTs - let modifyTitles SheetFile{..} - | not multipleSFTs = SheetFile{..} - | otherwise = SheetFile - { sheetFileTitle = unpack (mr $ SheetArchiveFileTypeDirectory sheetFileType) sheetFileTitle - , .. - } - sftDirectories <- if - | not multipleSFTs -> return mempty - | otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectMaybe . E.from $ \sFile -> do - E.where_ $ sFile E.^. SheetFileSheet E.==. E.val shId - E.&&. sFile E.^. SheetFileType E.==. E.val sft - return . E.max_ $ sFile E.^. SheetFileModified - serveZipArchive archiveName $ do - forM_ sftDirectories $ \(sft, mTime) -> yield $ SheetFile - { sheetFileType = sft - , sheetFileTitle = unpack . mr $ SheetArchiveFileTypeDirectory sft - , sheetFileModified = mTime - , sheetFileContent = Nothing - , sheetFileSheet = shId - } - sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal .| C.map modifyTitles - - -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 . Set.elems $ sheetFileIds SheetExercise - , sfHintFrom = sheetHintFrom - , sfHintF = Just . yieldMany . Set.elems $ sheetFileIds SheetHint - , sfSolutionFrom = sheetSolutionFrom - , sfSolutionF = Just . yieldMany . Set.elems $ sheetFileIds SheetSolution - , sfMarkingF = Just . yieldMany . 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 -> FileUploads -> YesodJobDB UniWorX () -insertSheetFile' sid ftype fs = do - oldFiles <- fmap (Map.fromList . map $(E.unValueN 2)) . E.select . E.from $ \sheetFile -> do - E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid - E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype - return (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileId) - keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ (finsert oldFiles) - deleteWhere [ SheetFileSheet ==. sid, SheetFileType ==. ftype, SheetFileId <-. Set.toList (setOf folded oldFiles \\ keep) ] - where - finsert oldFiles fRef - | Just sfId <- fileReferenceTitle fRef `Map.lookup` oldFiles - = tell $ Set.singleton sfId - | otherwise - = do - sfId <- lift . insert $ _FileReference # (fRef, SheetFileResidual sid ftype) - tell $ Set.singleton sfId - - -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) (fslI MsgSheetCorrectorState & 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) (fslI MsgSheetCorrectorProportion & 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 +getSIsCorrR _ _ _ shn = defaultLayout . i18n $ MsgHaveCorrectorAccess shn - diff --git a/src/Handler/Sheet/CorrectorInvite.hs b/src/Handler/Sheet/CorrectorInvite.hs new file mode 100644 index 000000000..084ca1b75 --- /dev/null +++ b/src/Handler/Sheet/CorrectorInvite.hs @@ -0,0 +1,86 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Handler.Sheet.CorrectorInvite + ( getSCorrInviteR, postSCorrInviteR + , InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..) + , correctorInvitationConfig + ) where + +import Import + +import Handler.Utils +import Handler.Utils.Invitations + +import qualified Data.HashSet as HashSet + +import Data.Aeson hiding (Result(..)) +import Text.Hamlet (ihamlet) + + +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 diff --git a/src/Handler/Sheet/Current.hs b/src/Handler/Sheet/Current.hs new file mode 100644 index 000000000..996199913 --- /dev/null +++ b/src/Handler/Sheet/Current.hs @@ -0,0 +1,27 @@ +module Handler.Sheet.Current + ( getSheetCurrentR + , getSheetOldUnassignedR + ) where + +import Import + +import Utils.Sheet + + +getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Void +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 + addMessageI Error MsgSheetNoCurrent + redirect $ CourseR tid ssh csh SheetListR + +getSheetOldUnassignedR :: TermId -> SchoolId -> CourseShorthand -> Handler Void +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 + addMessageI Error MsgSheetNoOldUnassigned + redirect $ CourseR tid ssh csh SheetListR diff --git a/src/Handler/Sheet/Delete.hs b/src/Handler/Sheet/Delete.hs new file mode 100644 index 000000000..1658e6c81 --- /dev/null +++ b/src/Handler/Sheet/Delete.hs @@ -0,0 +1,50 @@ +module Handler.Sheet.Delete + ( getSDelR, postSDelR + ) where + +import Import + +import Handler.Utils.Delete +import Handler.Utils.Sheet + +import qualified Database.Esqueleto as E + +import qualified Data.Set as Set + + +sheetDeleteRoute :: Set SheetId -> DeleteRoute Sheet +sheetDeleteRoute drRecords = DeleteRoute + { drRecords + , drGetInfo = \(sheet `E.InnerJoin` course `E.InnerJoin` school) -> do + E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool + E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse + let submissions = E.subSelectCount . E.from $ \submission -> + E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId + E.orderBy [E.asc $ sheet E.^. SheetName] + return (submissions, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm) + , drUnjoin = \(sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet + , drRenderRecord = \(E.Value submissions, E.Value shn', _, E.Value cName, _, E.Value sName, E.Value tid') -> + return [whamlet| + $newline never + #{shn'} (_{SomeMessage $ ShortTermIdentifier (unTermKey tid')}, #{sName}, #{cName}) + $if submissions /= 0 +  _{SomeMessage $ MsgSheetDelHasSubmissions submissions} + |] + , drRecordConfirmString = \(E.Value submissions, E.Value shn', E.Value csh', _, E.Value ssh', _, E.Value tid') -> + return $ [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}|] <> bool mempty [st| + #{tshow submissions} Subs|] (submissions /= 0) + , drCaption = SomeMessage MsgSheetDeleteQuestion + , drSuccessMessage = SomeMessage MsgSheetDeleted + , drFormMessage = const $ return Nothing + , drAbort = error "drAbort undefined" + , drSuccess = error "drSuccess undefined" + , drDelete = const id -- TODO: audit + } + +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 + } diff --git a/src/Handler/Sheet/Download.hs b/src/Handler/Sheet/Download.hs new file mode 100644 index 000000000..0f5bfb70d --- /dev/null +++ b/src/Handler/Sheet/Download.hs @@ -0,0 +1,64 @@ +module Handler.Sheet.Download + ( getSArchiveR, getSFileR, getSZipR + ) where + +import Import + +import Utils.Sheet +import Handler.Utils + +import qualified Data.Conduit.Combinators as C + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + + +getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent +getSArchiveR tid ssh csh shn = do + shId <- runDB $ fetchSheetId tid ssh csh shn + + MsgRenderer mr <- getMsgRenderer + let archiveName = flip addExtension (unpack extensionZip) . unpack . mr $ MsgSheetArchiveName tid ssh csh shn + let sftArchive = CSheetR tid ssh csh shn . SZipR -- used to check access to SheetFileTypes + allowedSFTs <- filterM (hasReadAccessTo . sftArchive) universeF + multipleSFTs <- if + | length allowedSFTs < 2 -> return False + | otherwise -> runDB . E.selectExists . E.from $ \(sheet `E.InnerJoin` (sFile1 `E.InnerJoin` sFile2)) -> do + E.on $ sFile1 E.^. SheetFileType E.!=. sFile2 E.^. SheetFileType + E.&&. sFile1 E.^. SheetFileTitle E.==. sFile2 E.^. SheetFileTitle + E.on $ sheet E.^. SheetId E.==. sFile1 E.^. SheetFileSheet + E.&&. sheet E.^. SheetId E.==. sFile2 E.^. SheetFileSheet + E.where_ $ sheet E.^. SheetId E.==. E.val shId + E.&&. sFile1 E.^. SheetFileType `E.in_` E.valList allowedSFTs + E.&&. sFile2 E.^. SheetFileType `E.in_` E.valList allowedSFTs + let modifyTitles SheetFile{..} + | not multipleSFTs = SheetFile{..} + | otherwise = SheetFile + { sheetFileTitle = unpack (mr $ SheetArchiveFileTypeDirectory sheetFileType) sheetFileTitle + , .. + } + sftDirectories <- if + | not multipleSFTs -> return mempty + | otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectMaybe . E.from $ \sFile -> do + E.where_ $ sFile E.^. SheetFileSheet E.==. E.val shId + E.&&. sFile E.^. SheetFileType E.==. E.val sft + return . E.max_ $ sFile E.^. SheetFileModified + + serveZipArchive archiveName $ do + forM_ sftDirectories $ \(sft, mTime) -> yield $ SheetFile + { sheetFileType = sft + , sheetFileTitle = unpack . mr $ SheetArchiveFileTypeDirectory sft + , sheetFileModified = mTime + , sheetFileContent = Nothing + , sheetFileSheet = shId + } + sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal .| C.map modifyTitles + +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 diff --git a/src/Handler/Sheet/Edit.hs b/src/Handler/Sheet/Edit.hs new file mode 100644 index 000000000..66d1782d3 --- /dev/null +++ b/src/Handler/Sheet/Edit.hs @@ -0,0 +1,158 @@ +module Handler.Sheet.Edit + ( getSEditR, postSEditR + , handleSheetEdit + ) where + +import Import + +import Jobs.Queue + +import Handler.Utils +import Handler.Utils.Invitations + +import qualified Data.Conduit.List as C + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import qualified Data.Set as Set +import qualified Data.Map as Map + + +import Handler.Sheet.Form +import Handler.Sheet.CorrectorInvite + + +getSEditR, postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html +getSEditR = postSEditR +postSEditR 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 . Set.elems $ sheetFileIds SheetExercise + , sfHintFrom = sheetHintFrom + , sfHintF = Just . yieldMany . Set.elems $ sheetFileIds SheetHint + , sfSolutionFrom = sheetSolutionFrom + , sfSolutionF = Just . yieldMany . Set.elems $ sheetFileIds SheetSolution + , sfMarkingF = Just . yieldMany . 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 + +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") + +insertSheetFile' :: SheetId -> SheetFileType -> FileUploads -> YesodJobDB UniWorX () +insertSheetFile' sid ftype fs = do + oldFiles <- fmap (Map.fromList . map $(E.unValueN 2)) . E.select . E.from $ \sheetFile -> do + E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid + E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype + return (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileId) + keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ (finsert oldFiles) + deleteWhere [ SheetFileSheet ==. sid, SheetFileType ==. ftype, SheetFileId <-. Set.toList (setOf folded oldFiles \\ keep) ] + where + finsert oldFiles fRef + | Just sfId <- fileReferenceTitle fRef `Map.lookup` oldFiles + = tell $ Set.singleton sfId + | otherwise + = do + sfId <- lift . insert $ _FileReference # (fRef, SheetFileResidual sid ftype) + tell $ Set.singleton sfId diff --git a/src/Handler/Sheet/Form.hs b/src/Handler/Sheet/Form.hs new file mode 100644 index 000000000..8492aa4e0 --- /dev/null +++ b/src/Handler/Sheet/Form.hs @@ -0,0 +1,210 @@ +module Handler.Sheet.Form + ( SheetForm(..), Loads + , makeSheetForm + , getFtIdMap + ) where + +import Import + +import Handler.Utils +import Handler.Utils.Invitations + +import qualified Database.Esqueleto as E + +import qualified Data.Set as Set +import qualified Data.Map as Map + +import Data.Map ((!)) + +import qualified Control.Monad.State.Class as State + + +import Handler.Sheet.CorrectorInvite + + +type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector) + +data SheetForm = SheetForm + { sfName :: SheetName + , sfDescription :: Maybe Html + , sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe FileUploads + , 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! + } + + +getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileReference) +getFtIdMap sId = do + allSheetFiles <- E.select . E.from $ \sheetFile -> do + E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId + return sheetFile + return $ partitionFileType [ (sheetFileType, sf ^. _FileReference . _1) | Entity _ sf@SheetFile{..} <- allSheetFiles ] + +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 + +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) (fslI MsgSheetCorrectorState & 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) (fslI MsgSheetCorrectorProportion & 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 diff --git a/src/Handler/Sheet/List.hs b/src/Handler/Sheet/List.hs new file mode 100644 index 000000000..16a3b532b --- /dev/null +++ b/src/Handler/Sheet/List.hs @@ -0,0 +1,177 @@ +module Handler.Sheet.List + ( getSheetListR + ) where + +import Import hiding (link) + +import Utils.Sheet +import Handler.Utils +import Handler.Utils.SheetType + +import qualified Database.Esqueleto as E + +import qualified Data.Map as Map + + +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") diff --git a/src/Handler/Sheet/New.hs b/src/Handler/Sheet/New.hs new file mode 100644 index 000000000..64fa4624a --- /dev/null +++ b/src/Handler/Sheet/New.hs @@ -0,0 +1,93 @@ +module Handler.Sheet.New + ( getSheetNewR, postSheetNewR + ) where + +import Import + +import Handler.Utils + +import qualified Database.Esqueleto as E + +import qualified Data.Map as Map + +import Data.Time.Clock.System (systemEpochDay) + + +import Handler.Sheet.CorrectorInvite +import Handler.Sheet.Form +import Handler.Sheet.Edit + + +getSheetNewR, postSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html +getSheetNewR = postSheetNewR +postSheetNewR 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 + _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 + 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 + +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) diff --git a/src/Handler/Sheet/Pseudonym.hs b/src/Handler/Sheet/Pseudonym.hs new file mode 100644 index 000000000..b9c055fa6 --- /dev/null +++ b/src/Handler/Sheet/Pseudonym.hs @@ -0,0 +1,47 @@ +module Handler.Sheet.Pseudonym + ( getSPseudonymR, postSPseudonymR + , ButtonGeneratePseudonym(..) + ) where + +import Import + +import Handler.Utils + +import Utils.Sql + + +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] + + +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) diff --git a/src/Handler/Sheet/Show.hs b/src/Handler/Sheet/Show.hs new file mode 100644 index 000000000..1431df5da --- /dev/null +++ b/src/Handler/Sheet/Show.hs @@ -0,0 +1,118 @@ +module Handler.Sheet.Show + ( getSShowR + ) where + +import Import hiding (link) + +import Handler.Utils + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + +import qualified Data.Map as Map + + +import Handler.Sheet.Pseudonym + + +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 = do + -- filter to requested file + E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid + E.&&. E.not_ (E.isNothing $ sheetFile E.^. SheetFileContent) -- don't show directories + -- return desired columns + return $ (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileModified, 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.^. SheetFileId) + , 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.orderByEnum $ sheetFile E.^. SheetFileType + ) + , ( "path" + , SortColumn $ \sheetFile -> sheetFile E.^. SheetFileTitle + ) + -- , ( "visible" + -- , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet + -- ) + , ( "time" + , SortColumn $ \sheetFile -> sheetFile E.^. SheetFileModified + ) + ] + , 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 <>) . fvWidget) <$> 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") diff --git a/src/Handler/Utils/Sheet.hs b/src/Handler/Utils/Sheet.hs index 3dff08571..70399eb81 100644 --- a/src/Handler/Utils/Sheet.hs +++ b/src/Handler/Utils/Sheet.hs @@ -1,7 +1,6 @@ module Handler.Utils.Sheet where import Import -import Handler.Utils.Delete import qualified Database.Esqueleto as E import qualified Database.Esqueleto.Internal.Sql as E @@ -52,30 +51,3 @@ fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Ye fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux (\sheet course -> (sheet E.^. SheetId, course E.^. CourseId)) tid ssh cid shn -sheetDeleteRoute :: Set SheetId -> DeleteRoute Sheet -sheetDeleteRoute drRecords = DeleteRoute - { drRecords - , drGetInfo = \(sheet `E.InnerJoin` course `E.InnerJoin` school) -> do - E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool - E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse - let submissions = E.subSelectCount . E.from $ \submission -> - E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId - E.orderBy [E.asc $ sheet E.^. SheetName] - return (submissions, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm) - , drUnjoin = \(sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet - , drRenderRecord = \(E.Value submissions, E.Value shn', _, E.Value cName, _, E.Value sName, E.Value tid') -> - return [whamlet| - $newline never - #{shn'} (_{SomeMessage $ ShortTermIdentifier (unTermKey tid')}, #{sName}, #{cName}) - $if submissions /= 0 -  _{SomeMessage $ MsgSheetDelHasSubmissions submissions} - |] - , drRecordConfirmString = \(E.Value submissions, E.Value shn', E.Value csh', _, E.Value ssh', _, E.Value tid') -> - return $ [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}|] <> bool mempty [st| + #{tshow submissions} Subs|] (submissions /= 0) - , drCaption = SomeMessage MsgSheetDeleteQuestion - , drSuccessMessage = SomeMessage MsgSheetDeleted - , drFormMessage = const $ return Nothing - , drAbort = error "drAbort undefined" - , drSuccess = error "drSuccess undefined" - , drDelete = const id -- TODO: audit - }