module Handler.Sheet where import Import import Jobs.Queue import System.FilePath (takeFileName) import Utils.Sheet import Handler.Utils -- import Handler.Utils.Zip import Handler.Utils.Table.Cells import Handler.Utils.SheetType import Handler.Utils.Delete import Handler.Utils.Form.MassInput -- 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 Network.Mime 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 {- * 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 Entity cid _ <- runDB . getBy404 $ 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, _)} -> maybe mempty dateTimeCell mEditTime , sortable (Just "visible-from") (i18nCell MsgSheetVisibleFrom) $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> maybe mempty dateTimeCell 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 (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 E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- return desired columns return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = widgetColonnade $ mconcat [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) , sortable (Just "path") "Dateiname" $ \(E.Value fName,_,E.Value fType) -> anchorCell (CSheetR tid ssh csh shn (SFileR fType fName)) (str2widget fName) , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget ] let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"] (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery = fileData , dbtRowKey = \(_ `E.InnerJoin` _ `E.InnerJoin` file) -> file E.^. FileId , dbtColonnade = colonnadeFiles , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False) , dbtStyle = def , dbtFilter = mempty , dbtFilterUI = mempty , dbtIdent = "files" :: Text , dbtSorting = Map.fromList [ ( "type" , SortColumn $ \(_sheet `E.InnerJoin` sheetFile `E.InnerJoin` _file) -> sheetFile E.^. SheetFileType ) , ( "path" , SortColumn $ \(_sheet `E.InnerJoin` _sheetFile `E.InnerJoin` file) -> file E.^. FileTitle ) , ( "time" , SortColumn $ \(_sheet `E.InnerJoin` _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 $ MsgSheetTitle tid ssh csh 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 = do results <- runDB $ 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 desired columns return $ (file E.^. FileTitle, file E.^. FileContent) case results of [(E.Value fileTitle, E.Value fileContent)] | Just fileContent' <- fileContent -> do whenM downloadFiles $ addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|] return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent') | otherwise -> sendResponseStatus noContent204 () [] -> notFound other -> do $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other error "Multiple matching files found." 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 newSheet = do replaceRes <- myReplaceUnique sid $ newSheet case replaceRes of Nothing -> return $ Just sid (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here 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 wrapForm formWidget def { formAction = Just $ SomeRoute actionUrl , formEncoding = formEnctype } 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 SheetCorrectorInvitation 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 $ \(Entity _ SheetCorrectorInvitation{..}) -> Map.singleton (Left sheetCorrectorInvitationEmail) (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) (selectList [ SheetCorrectorInvitationSheet ==. 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") postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Set (Either SheetCorrectorInvitation SheetCorrector) postProcess = Set.fromList . map postProcess' . Map.elems where sheetCorrectorSheet = shid sheetCorrectorInvitationSheet = shid postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> Either SheetCorrectorInvitation SheetCorrector postProcess' (Right sheetCorrectorUser, (sheetCorrectorState, sheetCorrectorLoad)) = Right SheetCorrector{..} postProcess' (Left sheetCorrectorInvitationEmail, (sheetCorrectorInvitationState, sheetCorrectorInvitationLoad)) = Left SheetCorrectorInvitation{..} fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors) 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 uid <- requireAuthId 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 ] deleteWhere [ SheetCorrectorSheet ==. shid ] deleteWhere [ SheetCorrectorInvitationSheet ==. shid, SheetCorrectorInvitationEmail /<-. toListOf (folded . _Left . _sheetCorrectorInvitationEmail) sheetCorrectors ] forM_ sheetCorrectors $ \case Right shCor -> insert_ shCor Left shCorInv -> do insertRes <- insertBy shCorInv case insertRes of Right _ -> void . queueDBJob $ JobCorrectorInvitation uid shCorInv Left (Entity old _) -> replace old shCorInv 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 } data ButtonCorrInvite = BtnCorrInvAccept | BtnCorrInvDecline deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) instance Universe ButtonCorrInvite instance Finite ButtonCorrInvite nullaryPathPiece ''ButtonCorrInvite $ camelToPathPiece' 3 embedRenderMessage ''UniWorX ''ButtonCorrInvite id instance Button UniWorX ButtonCorrInvite where btnClasses BtnCorrInvAccept = [BCIsButton, BCPrimary] btnClasses BtnCorrInvDecline = [BCIsButton, BCDanger] getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> UserEmail -> Handler Html getSCorrInviteR = postSCorrInviteR postSCorrInviteR tid ssh csh shn email = do uid <- requireAuthId (Entity _ Course{..}, Entity shid Sheet{..}, Entity ciId SheetCorrectorInvitation{..}) <- runDB $ do (sRes@(Entity shid _), cRes) <- fetchSheetCourse tid ssh csh shn iRes <- getBy404 $ UniqueSheetCorrectorInvitation email shid return (cRes, sRes, iRes) ((btnResult, btnInnerWidget), btnEncoding) <- runFormPost $ formEmbedJwtPost buttonForm let btnWidget = wrapForm btnInnerWidget def { formEncoding = btnEncoding , formAction = Just . SomeRoute . CSheetR tid ssh csh shn $ SCorrInviteR email , formSubmit = FormNoSubmit } formResult btnResult $ \case BtnCorrInvAccept -> do runDB $ do delete ciId insert_ $ SheetCorrector uid shid sheetCorrectorInvitationLoad sheetCorrectorInvitationState addMessageI Success $ MsgCorrectorInvitationAccepted shn redirect $ CSheetR tid ssh csh shn SShowR BtnCorrInvDecline -> do runDB $ delete ciId addMessageI Info $ MsgCorrectorInvitationDeclined shn redirect HomeR siteLayoutMsg (MsgSheetCorrInviteHeading shn) $ do setTitleI $ MsgSheetCorrInviteHeading shn $(widgetFile "sheetCorrInvite")