{-# OPTIONS_GHC -fno-warn-orphans #-} module Handler.Sheet where import Import import Jobs.Queue -- import Utils.Lens import Utils.Sheet import Handler.Utils -- import Handler.Utils.Zip import Handler.Utils.Table.Cells -- import Handler.Utils.Table.Columns import Handler.Utils.SheetType import Handler.Utils.Delete import Handler.Utils.Form.MassInput 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.Internal.Sql as E import Control.Monad.Writer (MonadWriter(..), execWriterT) -- import Control.Monad.Trans.RWS.Lazy (RWST, local) -- import qualified Text.Email.Validate as Email -- import qualified Data.List as List import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map import Data.Map (Map, (!)) import Data.Monoid (Any(..)) -- import Control.Lens import Utils.Lens --import qualified Data.Aeson as Aeson import Control.Monad.Random.Class (MonadRandom(..)) import Utils.Sql import Data.Aeson hiding (Result(..)) import Text.Hamlet (ihamlet) {- * Implement Handlers * Implement Breadcrumbs in Foundation * Implement Access in Foundation -} data SheetForm = SheetForm { sfName :: SheetName , sfDescription :: Maybe Html , sfType :: SheetType , sfGrouping :: SheetGroup , sfVisibleFrom :: Maybe UTCTime , sfActiveFrom :: UTCTime , sfActiveTo :: UTCTime , sfSubmissionMode :: SubmissionMode , sfSheetF :: Maybe (Source Handler (Either FileId File)) , sfHintFrom :: Maybe UTCTime , sfHintF :: Maybe (Source Handler (Either FileId File)) , sfSolutionFrom :: Maybe UTCTime , sfSolutionF :: Maybe (Source Handler (Either FileId File)) , sfMarkingF :: Maybe (Source Handler (Either FileId File)) , sfMarkingText :: Maybe Html -- Keine SheetId im Formular! } getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileId) getFtIdMap sId = do allfIds <- E.select . E.from $ \(sheetFile `E.InnerJoin` file) -> do E.on $ sheetFile E.^. SheetFileFile E.==. file E.^. FileId E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId return (sheetFile E.^. SheetFileType, file E.^. FileId) return $ partitionFileType [(t,i)|(E.Value t, E.Value i) <- allfIds] makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm makeSheetForm msId template = identifyForm FIDsheet $ \html -> do oldFileIds <- (return.) <$> case msId of Nothing -> return $ partitionFileType mempty (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId mr <- getMsgRenderer ctime <- ceilingQuarterHour <$> liftIO getCurrentTime (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm <$> areq ciField (fslI MsgSheetName) (sfName <$> template) <*> aopt htmlField (fslpI MsgSheetDescription "Html") (sfDescription <$> template) <*> sheetTypeAFormReq (fslI MsgSheetType & setTooltip (uniworxMessages [MsgSheetTypeInfoBonus,MsgSheetTypeInfoNotGraded])) (sfType <$> template) <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template) <*> aopt utcTimeField (fslI MsgSheetVisibleFrom & setTooltip MsgSheetVisibleFromTip) ((sfVisibleFrom <$> template) <|> pure (Just ctime)) <*> areq utcTimeField (fslI MsgSheetActiveFrom & setTooltip MsgSheetActiveFromTip) (sfActiveFrom <$> template) <*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template) <*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ Upload True)) <*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template) <*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren" & setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template) <*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template) <*> aopt utcTimeField (fslpI MsgSheetSolutionFrom "Datum, sonst nur für Korrektoren" & setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template) <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template) <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking & setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template) <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template) return $ case result of FormSuccess sheetResult | errorMsgs <- validateSheet mr sheetResult , not $ null errorMsgs -> (FormFailure errorMsgs, widget) _ -> (result, widget) where validateSheet :: MsgRenderer -> SheetForm -> [Text] validateSheet (MsgRenderer {..}) (SheetForm{..}) = [ msg | (False, msg) <- [ ( sfVisibleFrom <= Just sfActiveFrom , render MsgSheetErrVisibility) , ( sfActiveFrom <= sfActiveTo , render MsgSheetErrDeadlineEarly) , ( NTop sfHintFrom >= NTop (Just sfActiveFrom) , render MsgSheetErrHintEarly) , ( NTop sfSolutionFrom >= NTop (Just sfActiveTo) , render MsgSheetErrSolutionEarly) ] ] getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetCurrentR tid ssh csh = runDB $ do let redi shn = redirectAccess $ CSheetR tid ssh csh shn SShowR shn <- sheetCurrent tid ssh csh maybe notFound redi shn getSheetOldUnassigned :: TermId -> SchoolId -> CourseShorthand -> Handler () getSheetOldUnassigned tid ssh csh = runDB $ do let redi shn = redirectAccess $ CSheetR tid ssh csh shn SSubsR shn <- sheetOldUnassigned tid ssh csh maybe notFound redi shn getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetListR tid ssh csh = do muid <- maybeAuthId now <- liftIO getCurrentTime cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh let lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId return . E.max_ $ sheetEdit E.^. SheetEditTime sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery () sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid E.where_ $ sheet E.^. SheetCourse E.==. E.val cid sheetFilter :: SheetName -> DB Bool sheetFilter sheetName = (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False sheetCol = widgetColonnade . mconcat $ [ dbRow , sortable (Just "name") (i18nCell MsgSheet) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName) , sortable (Just "last-edit") (i18nCell MsgLastEdit) $ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> foldMap dateTimeCell mEditTime , sortable (Just "visible-from") (i18nCell MsgAccessibleSince) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> dateTimeCell sheetActiveFrom , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> dateTimeCell sheetActiveTo , sortable Nothing (i18nCell MsgSheetType) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> i18nCell sheetType , sortable Nothing (i18nCell MsgSubmission) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of Nothing -> mempty (Just (Entity sid Submission{..})) -> let mkCid = encrypt sid -- TODO: executed twice mkRoute = do cid' <- mkCid return $ CSubmissionR tid ssh csh sheetName cid' SubShowR in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|]) , sortable (Just "rating") (i18nCell MsgRating) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> let stats = sheetTypeSum sheetType in -- for statistics over all shown rows case mbSub of Nothing -> cellTell mempty $ stats Nothing (Just (Entity sid sub@Submission{..})) -> let mkCid = encrypt sid mkRoute = do cid' <- mkCid return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating") in cellTell acell $ stats submissionRatingPoints , sortable Nothing -- (Just "percent") (i18nCell MsgRatingPercent) $ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub)} -> case mbSub of (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) -> case preview (_grading . _maxPoints) sType of Just maxPoints | maxPoints /= 0 -> let percent = sPoints / maxPoints in textCell $ textPercent $ realToFrac percent _other -> mempty _other -> mempty ] psValidator = def & defaultSorting [SortDescBy "submission-since"] (raw_statistics,table) <- runDB $ dbTableWidget psValidator DBTable { dbtColonnade = sheetCol , dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> sheetData dt *> return (sheet, lastSheetEdit sheet, submission) , dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId , dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) } -> dbr <$ guardM (lift $ sheetFilter sheetName) , dbtSorting = Map.fromList [ ( "name" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName ) , ( "last-edit" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet ) , ( "visible-from" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetVisibleFrom ) , ( "submission-since" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom ) , ( "submission-until" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo ) , ( "rating" , SortColumn $ \(_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> submission E.?. SubmissionRatingPoints ) -- GitLab Issue $143: HOW TO SORT? -- , ( "percent" -- , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> -- case sheetType of -- no Haskell inside Esqueleto, right? -- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType) -- ) ] , dbtFilter = mempty , dbtFilterUI = mempty , dbtStyle = def , dbtParams = def , dbtIdent = "sheets" :: Text } -- ) ( -- !!!DEPRECTAED!!! Summary only over shown rows !!! -- -- Collect summary over all Sheets, not just the ones shown due to pagination: -- do -- rows <- E.select $ E.from $ \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> -- sheetData dt *> return (sheet E.^. SheetName, sheet E.^. SheetType, submission E.?. SubmissionRatingPoints) -- flip filterM rows (\(E.Value sheetName, _, _) -> sheetFilter sheetName) -- ) let statistics = gradeSummaryWidget MsgSheetGradingSummaryTitle raw_statistics -- only over shown rows -- foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts)) defaultLayout $ do $(widgetFile "sheetList") data ButtonGeneratePseudonym = BtnGenerate deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable) instance Universe ButtonGeneratePseudonym instance Finite ButtonGeneratePseudonym nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1) instance Button UniWorX ButtonGeneratePseudonym where btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|] btnClasses BtnGenerate = [BCIsButton, BCDefault] -- Show single sheet getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSShowR tid ssh csh shn = do Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn -- without Colonnade -- fileNameTypes <- runDB $ E.select $ E.from $ -- \(sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do -- -- Restrict to consistent rows that correspond to each other -- E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) -- E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) -- -- filter to requested file -- E.where_ (sheet E.^. SheetId E.==. E.val sid ) -- -- return desired columns -- return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) -- let fileLinks = map (\(E.Value fName, E.Value modified, E.Value fType) -> (CSheetR tid ssh csh (SheetFileR shn fType fName),modified)) fileNameTypes -- with Colonnade let fileData (sheetFile `E.InnerJoin` file) = do -- Restrict to consistent rows that correspond to each other E.on (sheetFile E.^. SheetFileFile E.==. file E.^. FileId) -- filter to requested file E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories -- return desired columns return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = widgetColonnade $ mconcat [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) , sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell (CSheetR tid ssh csh shn (SFileR fType fName)) (str2widget fName) -- , 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)))) -- , colFileModification (view _2) , sortable (Just "time") (i18nCell MsgFileModified) $ \(_,E.Value modified,_) -> dateTimeCell modified ] let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"] (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery = fileData , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId , dbtColonnade = colonnadeFiles , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } -> guardAuthorizedFor (CSheetR tid ssh csh shn $ SFileR fType fName) dbrOutput , dbtStyle = def , dbtFilter = mempty , dbtFilterUI = mempty , dbtIdent = "files" :: Text , dbtSorting = Map.fromList [ ( "type" , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType ) , ( "path" , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileTitle ) , ( "time" , SortColumn $ \(_sheetFile `E.InnerJoin` file) -> file E.^. FileModified ) ] , dbtParams = def } (hasHints, hasSolution) <- runDB $ do hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ] hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ] return (hasHints, hasSolution) cTime <- Just <$> liftIO getCurrentTime visibleFrom <- traverse (formatTime SelFormatDateTime) $ sheetVisibleFrom sheet when (NTop (sheetVisibleFrom sheet) >= NTop cTime) $ addMessageI Warning $ maybe MsgSheetInvisible MsgSheetInvisibleUntil visibleFrom mPseudonym <- runMaybeT $ do uid <- MaybeT maybeAuthId Entity _ SheetPseudonym{sheetPseudonymPseudonym} <- MaybeT . runDB . getBy $ UniqueSheetPseudonymUser sid uid return $ review _PseudonymText sheetPseudonymPseudonym (generateWidget, generateEnctype) <- generateFormPost $ \csrf -> over _2 ((toWidget csrf <>) . fvInput) <$> mreq (buttonField BtnGenerate) "" Nothing 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 sheetFrom <- formatTime SelFormatDateTime $ sheetActiveFrom sheet sheetTo <- formatTime SelFormatDateTime $ sheetActiveTo sheet hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet) $(widgetFile "sheetShow") getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent getSPseudonymR = postSPseudonymR postSPseudonymR tid ssh csh shn = do uid <- requireAuthId shId <- runDB $ fetchSheetId tid ssh csh shn let genPseudonym = do inserted <- runExceptT . mapExceptT (runDB . setSerializable) $ do candidate <- liftIO getRandom existing <- lift . getBy $ UniqueSheetPseudonymUser shId uid case existing of Just (Entity _ SheetPseudonym{sheetPseudonymPseudonym}) -> throwE sheetPseudonymPseudonym Nothing -> lift $ fmap (const candidate) <$> insertUnique (SheetPseudonym shId candidate uid) case inserted of Right Nothing -> genPseudonym Right (Just ps) -> return ps Left ps -> return ps ps <- genPseudonym selectRep $ do provideRep . return $ review _PseudonymText ps provideJson ps provideRep (redirect $ CSheetR tid ssh csh shn SShowR :#: ("pseudonym" :: Text) :: Handler Html) getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent getSFileR tid ssh csh shn typ title = serveOneFile fileQuery where fileQuery = E.select $ E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do -- Restrict to consistent rows that correspond to each other E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile) E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId) E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId) -- filter to requested file E.where_ ((file E.^. FileTitle E.==. E.val title) E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ ) E.&&. (sheet E.^. SheetName E.==. E.val shn ) E.&&. (course E.^. CourseShorthand E.==. E.val csh ) E.&&. (course E.^. CourseSchool E.==. E.val ssh ) E.&&. (course E.^. CourseTerm E.==. E.val tid ) ) -- return file entity return file getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetNewR tid ssh csh = do parShn <- runInputGetResult $ iopt ciField "shn" let searchShn sheet = case parShn of (FormSuccess (Just shn)) -> E.where_ $ sheet E.^. SheetName E.==. E.val shn -- (FormFailure msgs) -> -- not in MonadHandler anymore -- forM_ msgs (addMessage Error . toHtml) _other -> return () lastSheets <- runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse E.where_ $ course E.^. CourseTerm E.==. E.val tid E.&&. course E.^. CourseSchool E.==. E.val ssh E.&&. course E.^. CourseShorthand E.==. E.val csh searchShn sheet -- let lastSheetEdit = E.sub_select . E.from $ \sheetEdit -> do -- E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId -- return . E.max_ $ sheetEdit E.^. SheetEditTime -- Preferring last edited sheet may lead to suggesting duplicated sheet name numbers -- E.orderBy [E.desc lastSheetEdit, E.desc (sheet E.^. SheetActiveFrom)] E.orderBy [E.desc (sheet E.^. SheetActiveFrom)] E.limit 1 return sheet now <- liftIO getCurrentTime let template = case lastSheets of ((Entity {entityVal=Sheet{..}}):_) -> let addTime = addWeeks $ max 1 $ weeksToAdd sheetActiveTo now in Just $ SheetForm { sfName = stepTextCounterCI sheetName , sfDescription = sheetDescription , sfType = sheetType , sfGrouping = sheetGrouping , sfVisibleFrom = addTime <$> sheetVisibleFrom , sfActiveFrom = addTime sheetActiveFrom , sfActiveTo = addTime sheetActiveTo , sfSubmissionMode = sheetSubmissionMode , sfSheetF = Nothing , sfHintFrom = addTime <$> sheetHintFrom , sfHintF = Nothing , sfSolutionFrom = addTime <$> sheetSolutionFrom , sfSolutionF = Nothing , sfMarkingF = Nothing , sfMarkingText = sheetMarkingText } _other -> Nothing let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing insertUnique $ newSheet handleSheetEdit tid ssh csh Nothing template action postSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html postSheetNewR = getSheetNewR getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSEditR tid ssh csh shn = do (Entity sid Sheet{..}, sheetFileIds) <- runDB $ do ent <- fetchSheet tid ssh csh shn fti <- getFtIdMap $ entityKey ent return (ent, fti) let template = Just $ SheetForm { sfName = sheetName , sfDescription = sheetDescription , sfType = sheetType , sfGrouping = sheetGrouping , sfVisibleFrom = sheetVisibleFrom , sfActiveFrom = sheetActiveFrom , sfActiveTo = sheetActiveTo , sfSubmissionMode = sheetSubmissionMode , sfSheetF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetExercise , sfHintFrom = sheetHintFrom , sfHintF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetHint , sfSolutionFrom = sheetSolutionFrom , sfSolutionF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetSolution , sfMarkingF = Just . yieldMany . map Left . Set.elems $ sheetFileIds SheetMarking , sfMarkingText = sheetMarkingText } let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead handleSheetEdit tid ssh csh (Just sid) template action postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html postSEditR = getSEditR handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html handleSheetEdit tid ssh csh msId template dbAction = do let mbshn = sfName <$> template aid <- requireAuthId ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template case res of (FormSuccess SheetForm{..}) -> do saveOkay <- runDB $ do actTime <- liftIO getCurrentTime cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh oldAutoDistribute <- fmap sheetAutoDistribute . join <$> traverse get msId let newSheet = Sheet { sheetCourse = cid , sheetName = sfName , sheetDescription = sfDescription , sheetType = sfType , sheetGrouping = sfGrouping , sheetMarkingText = sfMarkingText , sheetVisibleFrom = sfVisibleFrom , sheetActiveFrom = sfActiveFrom , sheetActiveTo = sfActiveTo , sheetHintFrom = sfHintFrom , sheetSolutionFrom = sfSolutionFrom , sheetSubmissionMode = sfSubmissionMode , sheetAutoDistribute = fromMaybe False oldAutoDistribute } mbsid <- dbAction newSheet case mbsid of Nothing -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName) (Just sid) -> do -- save files in DB: whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise whenIsJust sfHintF $ insertSheetFile' sid SheetHint whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking insert_ $ SheetEdit aid actTime sid addMessageI Success $ MsgSheetEditOk tid ssh csh sfName -- Sanity checks generating warnings only, but not errors! warnTermDays tid [sfVisibleFrom, Just sfActiveFrom, Just sfActiveTo, sfHintFrom, sfSolutionFrom] return True when saveOkay $ redirect $ case msId of Just _ -> CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB Nothing -> CSheetR tid ssh csh sfName SCorrR (FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml _ -> runDB $ warnTermDays tid $ (join . (flip fmap template)) <$> [sfVisibleFrom, Just . sfActiveFrom, Just . sfActiveTo, sfHintFrom, sfSolutionFrom] let pageTitle = maybe (MsgSheetTitleNew tid ssh csh) (MsgSheetTitle tid ssh csh) mbshn -- let formTitle = pageTitle -- no longer used in template actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute defaultLayout $ do setTitleI pageTitle let sheetEditForm = wrapForm formWidget def { formAction = Just $ SomeRoute actionUrl , formEncoding = formEnctype } $(i18nWidgetFile "sheet-edit") getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSDelR = postSDelR postSDelR tid ssh csh shn = do sid <- runDB $ fetchSheetId tid ssh csh shn deleteR $ (sheetDeleteRoute $ Set.singleton sid) { drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR , drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR } insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX () insertSheetFile sid ftype finfo = do runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert where finsert file = do fid <- insert file void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX () insertSheetFile' sid ftype fs = do oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFile E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype return (file E.^. FileId) keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId) where finsert (Left fileId) = tell $ singleton fileId finsert (Right file) = lift $ do fid <- insert file void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step data CorrectorForm = CorrectorForm { cfUserId :: UserId , cfUserName :: Text , cfResult :: FormResult (CorrectorState, Load) , cfViewByTut, cfViewProp, cfViewDel, cfViewState :: FieldView UniWorX } type Loads = Map (Either UserEmail UserId) (CorrectorState, Load) defaultLoads :: SheetId -> DB Loads -- ^ Generate `Loads` in such a way that minimal editing is required -- -- For every user, that ever was a corrector for this course, return their last `Load`. -- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit). defaultLoads shid = do cId <- sheetCourse <$> getJust shid fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet let creationTime = E.sub_select . E.from $ \sheetEdit -> do E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId return . E.min_ $ sheetEdit E.^. SheetEditTime E.where_ $ sheet E.^. SheetCourse E.==. E.val cId E.orderBy [E.desc creationTime] return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState) where toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads toMap = foldMap $ \(E.Value uid, E.Value load, E.Value state) -> Map.singleton (Right uid) (state, load) correctorForm :: SheetId -> AForm Handler (Set (Either (Invitation' SheetCorrector) SheetCorrector)) correctorForm shid = wFormToAForm $ do Just currentRoute <- liftHandlerT getCurrentRoute userId <- liftHandlerT requireAuthId MsgRenderer mr <- getMsgRenderer let currentLoads :: DB Loads currentLoads = Map.union <$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (sheetCorrectorState, sheetCorrectorLoad)) (selectList [ SheetCorrectorSheet ==. shid ] []) <*> fmap (foldMap $ \(email, InvDBDataSheetCorrector load state) -> Map.singleton (Left email) (state, load)) (sourceInvitationsList shid) (defaultLoads', currentLoads') <- liftHandlerT . runDB $ (,) <$> defaultLoads shid <*> currentLoads isWrite <- liftHandlerT $ isWriteRequest currentRoute let applyDefaultLoads = Map.null currentLoads' && not isWrite loads :: Map (Either UserEmail UserId) (CorrectorState, Load) loads | applyDefaultLoads = defaultLoads' | otherwise = currentLoads' when (not (Map.null loads) && applyDefaultLoads) $ addMessageI Warning MsgCorrectorsDefaulted countTutRes <- wreq checkBoxField (fsm MsgCountTutProp) . 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 return user miAdd :: ListPosition -> Natural -> (Text -> Text) -> FieldView UniWorX -> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId)))) miAdd _ _ nudge submitView = Just $ \csrf -> do (addRes, addView) <- mpreq (multiUserField False $ Just previousCorrectors) (fslpI MsgCorrector (mr MsgEMail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if | existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData , not $ null existing -> FormFailure [mr MsgCorrectorExists] | otherwise -> FormSuccess . Map.fromList . zip [kStart..] $ Set.toList nCorrs return (addRes', $(widgetFile "sheetCorrectors/add")) miCell :: ListPosition -> Either UserEmail UserId -> Maybe (CorrectorState, Load) -> (Text -> Text) -> Form (CorrectorState, Load) miCell _ userIdent initRes nudge csrf = do (stateRes, stateView) <- mreq (selectField optionsFinite) ("" & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal (byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False (propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) ("" & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0 let res :: FormResult (CorrectorState, Load) res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes) tutRes' | FormSuccess True <- byTutRes = Just <$> countTutRes | otherwise = Nothing <$ byTutRes identWidget <- case userIdent of Left email -> return . toWidget $ mailtoHtml email Right uid -> do User{userEmail, userDisplayName, userSurname} <- liftHandlerT . runDB $ getJust uid return $ nameEmailWidget userEmail userDisplayName userSurname return (res, $(widgetFile "sheetCorrectors/cell")) miDelete :: ListLength -> ListPosition -> MaybeT (MForm Handler) (Map ListPosition ListPosition) miDelete = miDeleteList miAllowAdd :: ListPosition -> Natural -> ListLength -> Bool miAllowAdd _ _ _ = True miAddEmpty :: ListPosition -> Natural -> ListLength -> Set ListPosition miAddEmpty _ _ _ = Set.empty miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX) miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag miLayout :: ListLength -> Map ListPosition (Either UserEmail UserId, FormResult (CorrectorState, Load)) -> Map ListPosition Widget -> Map ListPosition (FieldView UniWorX) -> Map (Natural, ListPosition) Widget -> Widget miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout") miIdent :: Text miIdent = "correctors" postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either (Invitation' SheetCorrector) SheetCorrector) postProcess = Set.fromList . map postProcess' . Map.elems where sheetCorrectorSheet = shid postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either (Invitation' SheetCorrector) SheetCorrector postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..} postProcess' (Left email, (state, load)) = Left (email, shid, (InvDBDataSheetCorrector load state, InvTokenDataSheetCorrector)) fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors & setTooltip MsgMassInputTip) True (Just . Map.fromList . zip [0..] $ Map.toList loads) getSCorrR, postSCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html postSCorrR = getSCorrR getSCorrR tid ssh csh shn = do Entity shid Sheet{..} <- runDB $ fetchSheet tid ssh csh shn ((res,formWidget), formEnctype) <- runFormPost . identifyForm FIDcorrectors . renderAForm FormStandard $ (,) <$> areq checkBoxField (fslI MsgAutoAssignCorrs) (Just sheetAutoDistribute) <*> correctorForm shid case res of FormFailure errs -> mapM_ (addMessage Error . toHtml) errs FormSuccess (autoDistribute, sheetCorrectors) -> runDBJobs $ do update shid [ SheetAutoDistribute =. autoDistribute ] let (invites, adds) = partitionEithers $ Set.toList sheetCorrectors deleteWhere [ SheetCorrectorSheet ==. shid ] insertMany_ adds deleteWhere [InvitationFor ==. invRef @SheetCorrector shid, InvitationEmail /<-. toListOf (folded . _1) invites] sinkInvitationsF correctorInvitationConfig invites addMessageI Success MsgCorrectorsUpdated FormMissing -> return () defaultLayout $ do setTitleI $ MsgSheetCorrectorsTitle tid ssh csh shn wrapForm formWidget def { formAction = Just . SomeRoute $ CSheetR tid ssh csh shn SCorrR , formEncoding = formEnctype } instance IsInvitableJunction SheetCorrector where type InvitationFor SheetCorrector = Sheet data InvitableJunction SheetCorrector = JunctionSheetCorrector { jSheetCorrectorLoad :: Load , jSheetCorrectorState :: CorrectorState } deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationDBData SheetCorrector = InvDBDataSheetCorrector { invDBSheetCorrectorLoad :: Load , invDBSheetCorrectorState :: CorrectorState } deriving (Eq, Ord, Read, Show, Generic, Typeable) data InvitationTokenData SheetCorrector = InvTokenDataSheetCorrector deriving (Eq, Ord, Read, Show, Generic, Typeable) _InvitableJunction = iso (\SheetCorrector{..} -> (sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState)) (\(sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState) -> SheetCorrector{..}) instance ToJSON (InvitableJunction SheetCorrector) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } instance FromJSON (InvitableJunction SheetCorrector) where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 } instance ToJSON (InvitationDBData SheetCorrector) where toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } instance FromJSON (InvitationDBData SheetCorrector) where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } instance ToJSON (InvitationTokenData SheetCorrector) where toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 } instance FromJSON (InvitationTokenData SheetCorrector) where parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 } correctorInvitationConfig :: InvitationConfig SheetCorrector correctorInvitationConfig = InvitationConfig{..} where invitationRoute Sheet{..} _ = do Course{..} <- get404 sheetCourse return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR invitationResolveFor = do Just (CSheetR tid csh ssh shn SCorrInviteR) <- getCurrentRoute fetchSheetId tid csh ssh shn invitationSubject Sheet{..} _ = do Course{..} <- get404 sheetCourse return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName invitationHeading Sheet{..} _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName invitationExplanation _ _ = [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|] invitationTokenConfig _ _ = do itAuthority <- liftHandlerT requireAuthId return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing invitationRestriction _ _ = return Authorized invitationForm _ (InvDBDataSheetCorrector load state, _) = pure $ JunctionSheetCorrector load state invitationSuccessMsg Sheet{..} _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName invitationUltDest 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