{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE MultiWayIf, LambdaCase #-} {-# LANGUAGE TupleSections #-} module Handler.Sheet where import Import import System.FilePath (takeFileName) import Handler.Utils -- import Handler.Utils.Zip -- import Data.Time -- import qualified Data.Text as T -- import Data.Function ((&)) -- -- import Colonnade hiding (fromMaybe, singleton, bool) import qualified Yesod.Colonnade as Yesod import Text.Blaze (text) -- -- 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 Network.Mime import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map import Data.Map (Map, (!), (!?)) import qualified Data.Map as Map import Data.Monoid (Sum(..)) import Control.Lens -- import Utils.Lens instance Eq (Unique Sheet) where (CourseSheet cid1 name1) == (CourseSheet cid2 name2) = cid1 == cid2 && name1 == name2 {- * Implement Handlers * Implement Breadcrumbs in Foundation * Implement Access in Foundation -} data SheetForm = SheetForm { sfName :: SheetName , sfDescription :: Maybe Html , sfType :: SheetType , sfGrouping :: SheetGroup , sfMarkingText :: Maybe Html , sfVisibleFrom :: Maybe UTCTime , sfActiveFrom :: UTCTime , sfActiveTo :: UTCTime , 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)) -- 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 = identForm FIDsheet $ \html -> do oldFileIds <- (return.) <$> case msId of Nothing -> return $ partitionFileType mempty (Just sId) -> liftHandlerT $ runDB $ getFtIdMap sId mr <- getMsgRenderer ctime <- liftIO $ getCurrentTime (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm <$> areq (ciField textField) (fslI MsgSheetName) (sfName <$> template) <*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template) <*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template) <*> sheetGroupAFormReq (fslI MsgSheetGroup) (sfGrouping <$> template) <*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> 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) <*> 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) <* submitButton 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) ] ] getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetListR tid ssh csh = do muid <- maybeAuthId Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh let sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)),E.SqlExpr (Maybe (Entity Submission))) 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 let sheetEdit = E.sub_select . E.from $ \sheetEdit' -> do E.where_ $ sheetEdit' E.^. SheetEditSheet E.==. sheet E.^. SheetId return . E.max_ $ sheetEdit' E.^. SheetEditTime E.where_ $ sheet E.^. SheetCourse E.==. E.val cid return (sheet, sheetEdit, submission) sheetCol = widgetColonnade . mconcat $ [ sortable (Just "name") (i18nCell MsgSheet) $ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName) , sortable (Just "last-edit") (i18nCell MsgLastEdit) $ \(_, E.Value mEditTime, _) -> case mEditTime of Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget Nothing -> mempty , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom) $ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveFrom >>= toWidget , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) $ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveTo >>= toWidget , sortable Nothing (i18nCell MsgSheetType) $ \(Entity _ Sheet{..}, _, _) -> textCell $ display sheetType , sortable Nothing (i18nCell MsgSubmission) $ \(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) $ \(Entity _ Sheet{..}, _, mbSub) -> case mbSub of Nothing -> mempty (Just (Entity sid Submission{..})) -> let mkCid = encrypt sid mkRoute = do cid <- mkCid return $ CSubmissionR tid ssh csh sheetName cid CorrectionR protoCell = anchorCellM mkRoute $(widgetFile "widgets/rating") in protoCell & cellContents %~ (<* tell (sheetTypeSum (sheetType, submissionRatingPoints))) , sortable Nothing -- (Just "percent") (i18nCell MsgRatingPercent) $ \(Entity _ Sheet{sheetType=sType}, _, mbSub) -> case mbSub of (Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) -> case sType of NotGraded -> mempty _ | maxPoints sType > 0 -> let percent = sPoints / maxPoints sType in textCell $ textPercent $ realToFrac percent _other -> mempty _other -> mempty ] psValidator = def & defaultSorting [("submission-since", SortAsc)] (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable { dbtSQLQuery = sheetData , dbtColonnade = sheetCol , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _, _) } -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False) , dbtSorting = Map.fromList [ ( "name" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName ) , ( "last-edit" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do return $ sheetEdit E.?. SheetEditTime ) , ( "submission-since" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom ) , ( "submission-until" , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo ) , ( "rating" , SortColumn $ \(_ `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 = Map.fromList [] , dbtStyle = def , dbtIdent = "sheets" :: Text } defaultLayout $ do $(widgetFile "sheetList") $(widgetFile "widgets/sheetTypeSummary") -- Show single sheet getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSShowR tid ssh csh shn = do entSheet <- runDB $ fetchSheet tid ssh csh shn let sheet = entityVal entSheet sid = entityKey entSheet -- 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) -> stringCell ftype , sortable (Just "path") "Dateiname" $ anchorCell' (\(E.Value fName,_,E.Value fType) -> CSheetR tid ssh csh shn (SFileR fType fName)) (\(E.Value fName,_,_) -> str2widget fName) , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget ] let psValidator = def & defaultSorting [("type", SortAsc), ("path", SortAsc)] ((), fileTable) <- dbTable psValidator $ DBTable { dbtSQLQuery = fileData , 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 = Map.empty , dbtIdent = "files" :: Text , dbtSorting = [ ( "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 ) ] } (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 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 $(widgetFile "sheetShow") 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) let mimeType = defaultMimeLookup $ pack title 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 let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days 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 (sheetEnt, sheetFileIds) <- runDB $ do ent <- fetchSheet tid ssh csh shn fti <- getFtIdMap $ entityKey ent return (ent, fti) let sid = entityKey sheetEnt let oldSheet@(Sheet {..}) = entityVal sheetEnt let template = Just $ SheetForm { sfName = sheetName , sfDescription = sheetDescription , sfType = sheetType , sfGrouping = sheetGrouping , sfMarkingText = sheetMarkingText , sfVisibleFrom = sheetVisibleFrom , sfActiveFrom = sheetActiveFrom , sfActiveTo = sheetActiveTo , 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 } 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 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 } mbsid <- dbAction newSheet case mbsid of Nothing -> False <$ addMessageI "danger" (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 "info" $ MsgSheetEditOk tid ssh csh sfName return True when saveOkay $ redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml _ -> return () let pageTitle = maybe (MsgSheetTitleNew tid ssh csh) (MsgSheetTitle tid ssh csh) mbshn -- let formTitle = pageTitle -- no longer used in template let formText = Nothing :: Maybe UniWorXMessage actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute defaultLayout $ do setTitleI pageTitle $(widgetFile "formPageI18n") getSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html getSDelR tid ssh csh shn = do ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) case result of (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid ssh csh shn SShowR (FormSuccess BtnDelete) -> do runDB $ fetchSheetId tid ssh csh shn >>= deleteCascade -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! addMessageI "info" $ MsgSheetDelOk tid ssh csh shn redirect $ CourseR tid ssh csh SheetListR _other -> do submissionno <- runDB $ do sid <- fetchSheetId tid ssh csh shn count [SubmissionSheet ==. sid] let formTitle = MsgSheetDelHead tid ssh csh shn let formText = Just $ MsgSheetDelText submissionno let actionUrl = CSheetR tid ssh csh shn SDelR defaultLayout $ do setTitleI $ MsgSheetTitle tid ssh csh shn $(widgetFile "formPageI18n") postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html postSDelR = getSDelR 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 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 uid (state, load) correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX]) correctorForm shid = do cListIdent <- newFormIdent let guardNonDeleted :: UserId -> Handler (Maybe UserId) guardNonDeleted uid = do cID@CryptoID{..} <- encrypt uid :: Handler CryptoUUIDUser deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del" return $ bool Just (const Nothing) (isJust deleted) uid formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser]) let currentLoads :: DB Loads currentLoads = foldMap (\(Entity _ SheetCorrector{..}) -> Map.singleton sheetCorrectorUser (sheetCorrectorState, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] [] (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads loads' <- fmap (Map.fromList [(uid, (CorrectorNormal, mempty)) | uid <- formCIDs] `Map.union`) $ if | Map.null currentLoads' , null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warning" MsgCorrectorsDefaulted) | otherwise -> return $ Map.fromList (map (, (CorrectorNormal, mempty)) formCIDs) `Map.union` currentLoads' deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads') let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions) didDelete = any (flip Set.member deletions) formCIDs (countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads' let tutorField :: Field Handler [UserEmail] tutorField = convertField (map CI.mk) (map CI.original) $ multiEmailField { fieldView = \theId name attrs val isReq -> asWidgetT $ do listIdent <- newIdent userId <- handlerToWidget requireAuthId previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ 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 E.^. UserEmail [whamlet| $newline never $forall E.Value prev <- previousCorrectors