{-# 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 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) (fsb "Name") (sfName <$> template) <*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfDescription <$> template) <*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template) <*> sheetGroupAFormReq (fsb "Abgabegruppengröße") (sfGrouping <$> template) <*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template) <*> aopt utcTimeField (fslI MsgSheetVisibleFrom & setTooltip "Ohne Datum ist das Blatt komplett unsichtbar, z.B. weil es noch nicht fertig ist.") ((sfVisibleFrom <$> template) <|> pure (Just ctime)) <*> areq utcTimeField (fslI MsgSheetActiveFrom & setTooltip "Abgabe und Dateien zur Aufgabenstellung sind erst ab diesem Datum zugänglich") (sfActiveFrom <$> template) <*> areq utcTimeField (fslI MsgSheetActiveTo) (sfActiveTo <$> template) <*> aopt (multiFileField $ oldFileIds SheetExercise) (fsb "Aufgabenstellung") (sfSheetF <$> template) <*> aopt utcTimeField (fslpI MsgSheetHintFrom "Datum, sonst nur für Korrektoren" & setTooltip "Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen") (sfHintFrom <$> template) <*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template) <*> aopt utcTimeField (fslpI MsgSheetSolutionFrom "Datum, sonst nur für Korrektoren" & setTooltip "Ohne Datum nie für Teilnehmer sichtbar, Korrektoren können diese Dateien immer herunterladen") (sfSolutionFrom <$> template) <*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template) <*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarking & setTooltip "Hinweise zur Korrektur, sichtbar nur für Korrektoren") (sfMarkingF <$> template) <* submitButton return $ case result of FormSuccess sheetResult | errorMsgs <- validateSheet mr sheetResult , not $ null errorMsgs -> (FormFailure errorMsgs, [whamlet|

Fehler:
    $forall errmsg <- errorMsgs
  • #{errmsg} ^{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 -> CourseShorthand -> Handler Html getSheetListR tid csh = do Entity cid _ <- runDB . getBy404 $ CourseTermShort tid csh let sheetData :: E.SqlExpr (E.Entity Sheet) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime))) sheetData sheet = do 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) sheetCol = widgetColonnade . mconcat $ [ sortable (Just "name") (i18nCell MsgSheet) $ \(Entity _ Sheet{..}, _) -> anchorCell (CSheetR tid 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 ] psValidator = def & defaultSorting [("submission-since", SortAsc)] table <- dbTable psValidator $ DBTable { dbtSQLQuery = sheetData , dbtColonnade = sheetCol , dbtProj = \DBRow{ dbrOutput = dbrOutput@(Entity _ Sheet{..}, _) } -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid csh sheetName SShowR) False) , dbtSorting = Map.fromList [ ( "name" , SortColumn $ \sheet -> sheet E.^. SheetName ) , ( "last-edit" , SortColumn $ \sheet -> E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do return $ sheetEdit E.?. SheetEditTime ) , ( "submission-since" , SortColumn $ \sheet -> sheet E.^. SheetActiveFrom ) , ( "submission-until" , SortColumn $ \sheet -> sheet E.^. SheetActiveTo ) ] , dbtFilter = Map.fromList [] , dbtStyle = def , dbtIdent = "sheets" :: Text } defaultLayout $ do $(widgetFile "sheetList") -- Show single sheet getSShowR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSShowR tid csh shn = do entSheet <- runDB $ fetchSheet tid 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 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 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 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) defaultLayout $ do setTitleI $ MsgSheetTitle tid 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 -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent getSFileR tid 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.^. 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 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 -> CourseShorthand -> Handler Html getSheetNewR tid 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 csh Nothing template action postSheetNewR :: TermId -> CourseShorthand -> Handler Html postSheetNewR = getSheetNewR getSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSEditR tid csh shn = do (sheetEnt, sheetFileIds) <- runDB $ do ent <- fetchSheet tid 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 csh (Just sid) template action postSEditR :: TermId -> CourseShorthand -> SheetName -> Handler Html postSEditR = getSEditR handleSheetEdit :: TermId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html handleSheetEdit tid 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 $ CourseTermShort tid 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 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 csh sfName return True when saveOkay $ redirect $ CSheetR tid csh sfName SShowR -- redirect must happen outside of runDB (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml _ -> return () let pageTitle = maybe (MsgSheetTitleNew tid csh) (MsgSheetTitle tid csh) mbshn -- let formTitle = pageTitle -- no longer used in template let formText = Nothing :: Maybe UniWorXMessage actionUrl <- fromMaybe (CourseR tid csh SheetNewR) <$> getCurrentRoute defaultLayout $ do setTitleI pageTitle $(widgetFile "formPageI18n") getSDelR :: TermId -> CourseShorthand -> SheetName -> Handler Html getSDelR tid csh shn = do ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) case result of (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh shn SShowR (FormSuccess BtnDelete) -> do runDB $ fetchSheetId tid csh shn >>= deleteCascade -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! addMessageI "info" $ MsgSheetDelOk tid csh shn redirect $ CourseR tid csh SheetListR _other -> do submissionno <- runDB $ do sid <- fetchSheetId tid csh shn count [SubmissionSheet ==. sid] let formTitle = MsgSheetDelHead tid csh shn let formText = Just $ MsgSheetDelText submissionno let actionUrl = CSheetR tid csh shn SDelR defaultLayout $ do setTitleI $ MsgSheetTitle tid csh shn $(widgetFile "formPageI18n") postSDelR :: TermId -> 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 Load , cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX } type Loads = Map UserId 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) where toMap :: [(E.Value UserId, E.Value Load)] -> Loads toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid 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 = Map.fromList . map (\(Entity _ SheetCorrector{..}) -> (sheetCorrectorUser, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] [] (defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads loads' <- fmap (Map.fromList [(uid, 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 (, 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