refactor: split up sheet handlers
This commit is contained in:
Gregor Kleen
parent
e62d7a34e6
commit
febf316c6c
@ -1,931 +1,26 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Sheet where
|
||||
module Handler.Sheet
|
||||
( module Handler.Sheet
|
||||
) where
|
||||
|
||||
import Import hiding (link)
|
||||
import Import
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
-- import Utils.Lens
|
||||
import Utils.Sheet
|
||||
import Handler.Utils
|
||||
-- import Handler.Utils.Zip
|
||||
import Handler.Utils.SheetType
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
-- import Data.Time
|
||||
-- import qualified Data.Text as T
|
||||
-- import Data.Function ((&))
|
||||
--
|
||||
-- import Colonnade hiding (fromMaybe, singleton, bool)
|
||||
--
|
||||
-- import qualified Data.UUID.Cryptographic as UUID
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
-- import Data.CaseInsensitive (CI)
|
||||
-- import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
-- import qualified Database.Esqueleto.Internal.Sql as E
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.Map ((!))
|
||||
|
||||
import Utils.Sql
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
import Data.Time.Clock.System (systemEpochDay)
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
|
||||
{-
|
||||
* Implement Handlers
|
||||
* Implement Breadcrumbs in Foundation
|
||||
* Implement Access in Foundation
|
||||
-}
|
||||
import Handler.Sheet.CorrectorInvite as Handler.Sheet (getSCorrInviteR, postSCorrInviteR)
|
||||
import Handler.Sheet.Delete as Handler.Sheet
|
||||
import Handler.Sheet.Edit as Handler.Sheet (getSEditR, postSEditR)
|
||||
import Handler.Sheet.List as Handler.Sheet
|
||||
import Handler.Sheet.Pseudonym as Handler.Sheet (getSPseudonymR, postSPseudonymR)
|
||||
import Handler.Sheet.Current as Handler.Sheet
|
||||
import Handler.Sheet.Download as Handler.Sheet
|
||||
import Handler.Sheet.New as Handler.Sheet
|
||||
import Handler.Sheet.Show as Handler.Sheet
|
||||
|
||||
type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector)
|
||||
|
||||
data SheetForm = SheetForm
|
||||
{ sfName :: SheetName
|
||||
, sfDescription :: Maybe Html
|
||||
, sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe FileUploads
|
||||
, sfVisibleFrom :: Maybe UTCTime
|
||||
, sfActiveFrom :: Maybe UTCTime
|
||||
, sfActiveTo :: Maybe UTCTime
|
||||
, sfHintFrom :: Maybe UTCTime
|
||||
, sfSolutionFrom :: Maybe UTCTime
|
||||
, sfSubmissionMode :: SubmissionMode
|
||||
, sfGrouping :: SheetGroup
|
||||
, sfType :: SheetType
|
||||
, sfAutoDistribute :: Bool
|
||||
, sfMarkingText :: Maybe Html
|
||||
, sfAnonymousCorrection :: Bool
|
||||
, sfCorrectors :: Loads
|
||||
-- Keine SheetId im Formular!
|
||||
}
|
||||
|
||||
data ButtonGeneratePseudonym = BtnGenerate
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonGeneratePseudonym
|
||||
instance Finite ButtonGeneratePseudonym
|
||||
|
||||
nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)
|
||||
|
||||
instance Button UniWorX ButtonGeneratePseudonym where
|
||||
btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
|
||||
btnClasses BtnGenerate = [BCIsButton, BCDefault]
|
||||
|
||||
|
||||
getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileReference)
|
||||
getFtIdMap sId = do
|
||||
allSheetFiles <- E.select . E.from $ \sheetFile -> do
|
||||
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
|
||||
return sheetFile
|
||||
return $ partitionFileType [ (sheetFileType, sf ^. _FileReference . _1) | Entity _ sf@SheetFile{..} <- allSheetFiles ]
|
||||
|
||||
makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
|
||||
makeSheetForm msId template = identifyForm FIDsheet . validateForm validateSheet $ \html -> do
|
||||
oldFileIds <- (return.) <$> case msId of
|
||||
Nothing -> return $ partitionFileType mempty
|
||||
(Just sId) -> liftHandler $ runDB $ getFtIdMap sId
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
|
||||
flip (renderAForm FormStandard) html $ SheetForm
|
||||
<$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
|
||||
<* aformSection MsgSheetFormFiles
|
||||
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles
|
||||
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
|
||||
<* aformSection MsgSheetFormTimes
|
||||
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
|
||||
& setTooltip MsgSheetVisibleFromTip)
|
||||
((sfVisibleFrom <$> template) <|> pure (Just ctime))
|
||||
<*> aopt utcTimeField (fslI MsgSheetActiveFrom
|
||||
& setTooltip MsgSheetActiveFromTip)
|
||||
(sfActiveFrom <$> template)
|
||||
<*> aopt utcTimeField (fslI MsgSheetActiveTo & setTooltip MsgSheetActiveToTip) (sfActiveTo <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgSheetHintFrom (mr MsgSheetHintFromPlaceholder)
|
||||
& setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgSheetSolutionFrom (mr MsgSheetSolutionFromPlaceholder)
|
||||
& setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template)
|
||||
<* aformSection MsgSheetFormType
|
||||
<*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
|
||||
<*> sheetGroupAFormReq (fslI MsgSheetGroup) ((sfGrouping <$> template) <|> pure NoGroups)
|
||||
<*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)
|
||||
<*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template)
|
||||
where
|
||||
validateSheet :: FormValidator SheetForm Handler ()
|
||||
validateSheet = do
|
||||
SheetForm{..} <- State.get
|
||||
|
||||
guardValidation MsgSheetErrVisibility $ NTop sfVisibleFrom <= NTop sfActiveFrom
|
||||
guardValidation MsgSheetErrDeadlineEarly $ NTop sfActiveFrom <= NTop sfActiveTo
|
||||
guardValidation MsgSheetErrHintEarly $ NTop sfHintFrom >= NTop sfActiveFrom
|
||||
guardValidation MsgSheetErrSolutionEarly $ NTop sfSolutionFrom >= NTop sfActiveTo
|
||||
|
||||
guardValidation MsgSheetErrVisibleWithoutActive $ is _Just sfActiveFrom || is _Nothing sfVisibleFrom
|
||||
|
||||
warnValidation MsgSheetWarnNoActiveTo $ is _Just sfActiveTo || is _Nothing sfActiveFrom
|
||||
|
||||
getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetCurrentR tid ssh csh = do
|
||||
mbShn <- runDB $ sheetCurrent tid ssh csh
|
||||
case mbShn of
|
||||
Just shn -> redirectAccess $ CSheetR tid ssh csh shn SShowR
|
||||
Nothing -> do -- no current sheet exists
|
||||
-- users should never see a link to this URL in this situation,
|
||||
-- but we had confused users that used a bookmark instead.
|
||||
let headingShort = [whamlet|_{MsgMenuSheetCurrent}|]
|
||||
headingLong = prependCourseTitle tid ssh csh MsgMenuSheetCurrent
|
||||
siteLayout headingShort $ do
|
||||
setTitleI headingLong
|
||||
[whamlet|_{MsgSheetNoCurrent}|]
|
||||
|
||||
|
||||
getSheetOldUnassignedR:: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetOldUnassignedR tid ssh csh = do
|
||||
mbShn <- runDB $ sheetOldUnassigned tid ssh csh
|
||||
case mbShn of
|
||||
Just shn -> redirectAccess $ CSheetR tid ssh csh shn SSubsR
|
||||
Nothing -> do -- no unassigned submissions in any inactive sheet
|
||||
-- users should never see a link to this URL in this situation,
|
||||
-- but we had confused users that used a bookmark instead.
|
||||
let headingShort = [whamlet|_{MsgMenuSheetOldUnassigned}|]
|
||||
headingLong = prependCourseTitle tid ssh csh MsgMenuSheetOldUnassigned
|
||||
siteLayout headingShort $ do
|
||||
setTitleI headingLong
|
||||
[whamlet|_{MsgSheetNoOldUnassigned}|]
|
||||
|
||||
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetListR tid ssh csh = do
|
||||
muid <- maybeAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let
|
||||
hasSFT :: (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool) -> [SheetFileType]
|
||||
hasSFT (E.Value hasExercise, E.Value hasHint, E.Value hasSolution, E.Value hasMarking)
|
||||
= [ sft | sft <- universeF
|
||||
, sft /= SheetExercise || hasExercise
|
||||
, sft /= SheetHint || hasHint
|
||||
, sft /= SheetSolution || hasSolution
|
||||
, sft /= SheetMarking || hasMarking
|
||||
]
|
||||
lastSheetEdit sheet = E.subSelectMaybe . E.from $ \sheetEdit -> do
|
||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||
return . E.max_ $ sheetEdit E.^. SheetEditTime
|
||||
|
||||
sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery ()
|
||||
sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
|
||||
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
|
||||
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
|
||||
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
|
||||
sheetFilter :: SheetName -> DB Bool
|
||||
sheetFilter sheetName = hasReadAccessTo $ CSheetR tid ssh csh sheetName SShowR
|
||||
|
||||
sheetCol = widgetColonnade . mconcat $
|
||||
[ -- dbRow ,
|
||||
sortable (Just "name") (i18nCell MsgSheet)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) sheetName
|
||||
, sortable (Just "last-edit") (i18nCell MsgLastEdit)
|
||||
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _, _)} -> foldMap dateTimeCell mEditTime
|
||||
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom
|
||||
, sortable (toNothing "downloads") (i18nCell MsgFiles)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, existFiles)} -> listCell
|
||||
[ icnCell & addIconFixedWidth
|
||||
| let existingSFTs = hasSFT existFiles
|
||||
, sft <- [minBound..maxBound]
|
||||
, let link = CSheetR tid ssh csh sheetName $ SZipR sft
|
||||
, let icn = toWgt $ sheetFile2markup sft
|
||||
, let icnCell = if sft `elem` existingSFTs
|
||||
then linkEitherCell link (icn, [whamlet| |])
|
||||
else spacerCell
|
||||
] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
|
||||
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell sheetActiveFrom
|
||||
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell sheetActiveTo
|
||||
, sortable Nothing (i18nCell MsgSheetType)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> i18nCell sheetType
|
||||
, sortable Nothing (i18nCell MsgSubmission)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub, _)} -> case mbSub of
|
||||
Nothing -> mempty
|
||||
(Just (Entity sid Submission{..})) ->
|
||||
let mkCid = encrypt sid -- TODO: executed twice
|
||||
mkRoute = do
|
||||
cid' <- mkCid
|
||||
return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
|
||||
in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{cid2}|])
|
||||
, sortable (Just "rating") (i18nCell MsgRating)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} ->
|
||||
let stats = sheetTypeSum sheetType in -- for statistics over all shown rows
|
||||
case mbSub of
|
||||
Nothing -> cellTell mempty $ stats Nothing
|
||||
(Just (Entity sid sub@Submission{..})) ->
|
||||
let
|
||||
mkRoute :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (Route UniWorX)
|
||||
mkRoute = liftHandler $ do
|
||||
cid' <- encrypt sid
|
||||
return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
|
||||
mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
|
||||
acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
|
||||
tellStats = do
|
||||
r <- mkRoute
|
||||
showRating <- hasReadAccessTo r
|
||||
tell . stats $ bool Nothing submissionRatingPoints showRating
|
||||
in acell & cellContents %~ (<* tellStats)
|
||||
|
||||
, sortable Nothing -- (Just "percent")
|
||||
(i18nCell MsgRatingPercent)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType, sheetName}, _, mbSub,_)} -> case mbSub of
|
||||
(Just (Entity sid Submission{submissionRatingPoints=Just sPoints})) ->
|
||||
case preview (_grading . _maxPoints) sType of
|
||||
Just maxPoints
|
||||
| maxPoints /= 0 -> cell $ do
|
||||
cID <- encrypt sid
|
||||
showRating <- hasReadAccessTo $ CSubmissionR tid ssh csh sheetName cID CorrectionR
|
||||
bool (return ()) (toWidget . toMessage $ textPercent sPoints maxPoints) showRating
|
||||
_other -> mempty
|
||||
_other -> mempty
|
||||
]
|
||||
|
||||
psValidator = def
|
||||
& defaultSorting [SortDescBy "submission-until", SortDescBy "submission-since"]
|
||||
& forceFilter "may-access" (Any True)
|
||||
|
||||
(raw_statistics,table) <- runDB $ dbTableWidget psValidator DBTable
|
||||
{ dbtColonnade = sheetCol
|
||||
, dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> do
|
||||
sheetData dt
|
||||
let existFiles = -- check whether files exist for given type
|
||||
( hasSheetFileQuery sheet SheetExercise
|
||||
, hasSheetFileQuery sheet SheetHint
|
||||
, hasSheetFileQuery sheet SheetSolution
|
||||
, hasSheetFileQuery sheet SheetMarking
|
||||
)
|
||||
return (sheet, lastSheetEdit sheet, submission, existFiles)
|
||||
, dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
||||
, dbtProj = return
|
||||
, dbtSorting = Map.fromList
|
||||
[ ( "name"
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
||||
)
|
||||
, ( "last-edit"
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
|
||||
)
|
||||
, ( "visible-from"
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetVisibleFrom
|
||||
)
|
||||
, ( "submission-since"
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
|
||||
)
|
||||
, ( "submission-until"
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
|
||||
)
|
||||
, ( "rating"
|
||||
, SortColumn $ \(_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> submission E.?. SubmissionRatingPoints
|
||||
)
|
||||
-- GitLab Issue $143: HOW TO SORT?
|
||||
-- , ( "percent"
|
||||
-- , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
|
||||
-- case sheetType of -- no Haskell inside Esqueleto, right?
|
||||
-- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
|
||||
-- )
|
||||
]
|
||||
, dbtFilter = mconcat
|
||||
[ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
|
||||
let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool))
|
||||
in (==b) <$> sheetFilter sheetName :: DB Bool
|
||||
]
|
||||
, dbtFilterUI = mempty
|
||||
, dbtStyle = def
|
||||
, dbtParams = def
|
||||
, dbtIdent = "sheets" :: Text
|
||||
, dbtCsvEncode = noCsvEncode
|
||||
, dbtCsvDecode = Nothing
|
||||
}
|
||||
-- ) ( -- !!!DEPRECTAED!!! Summary only over shown rows !!!
|
||||
-- -- Collect summary over all Sheets, not just the ones shown due to pagination:
|
||||
-- do
|
||||
-- rows <- E.select $ E.from $ \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
|
||||
-- sheetData dt *> return (sheet E.^. SheetName, sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
|
||||
-- flip filterM rows (\(E.Value sheetName, _, _) -> sheetFilter sheetName)
|
||||
-- )
|
||||
|
||||
let statistics = gradeSummaryWidget MsgSheetGradingSummaryTitle raw_statistics -- only over shown rows
|
||||
-- foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts))
|
||||
defaultLayout $ do
|
||||
$(widgetFile "sheetList")
|
||||
|
||||
-- Show single sheet
|
||||
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSShowR tid ssh csh shn = do
|
||||
now <- liftIO getCurrentTime
|
||||
Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn
|
||||
seeAllModificationTimestamps <- hasReadAccessTo $ CSheetR tid ssh csh shn SIsCorrR -- ordinary users should not see modification dates older than visibility
|
||||
|
||||
let sftVisible :: IsDBTable m a => SheetFileType -> DBCell m a
|
||||
sftVisible sft | Just dts <- sheetFileTypeDates sheet sft
|
||||
= dateTimeCellVisible now dts
|
||||
| otherwise = isVisibleCell False
|
||||
|
||||
sftModification :: IsDBTable m a => SheetFileType -> UTCTime -> DBCell m a
|
||||
sftModification sft mtime
|
||||
| seeAllModificationTimestamps = dateTimeCell mtime
|
||||
| NTop (Just mtime) > NTop (sheetFileTypeDates sheet sft) = dateTimeCell mtime
|
||||
| otherwise = mempty
|
||||
|
||||
let fileData sheetFile = do
|
||||
-- filter to requested file
|
||||
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
|
||||
E.&&. E.not_ (E.isNothing $ sheetFile E.^. SheetFileContent) -- don't show directories
|
||||
-- return desired columns
|
||||
return $ (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileModified, sheetFile E.^. SheetFileType)
|
||||
let colonnadeFiles = widgetColonnade $ mconcat
|
||||
[ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) ->
|
||||
let link = CSheetR tid ssh csh shn $ SZipR ftype in
|
||||
tellCell (Any True) $
|
||||
anchorCell link [whamlet|#{sheetFile2markup ftype} _{ftype}|]
|
||||
-- i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
|
||||
|
||||
-- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName))))
|
||||
, sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell
|
||||
(CSheetR tid ssh csh shn (SFileR fType fName))
|
||||
(str2widget fName)
|
||||
, sortable (toNothing "visible") (i18nCell MsgVisibleFrom)
|
||||
$ \(_, _ , E.Value ftype) -> sftVisible ftype
|
||||
, sortable (Just "time") (i18nCell MsgFileModified)
|
||||
$ \(_,E.Value modified, E.Value ftype) -> sftModification ftype modified
|
||||
-- , colFileModification (view _2)
|
||||
]
|
||||
let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
|
||||
& forceFilter "may-access" (Any True)
|
||||
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
|
||||
{ dbtSQLQuery = fileData
|
||||
, dbtRowKey = (E.^. SheetFileId)
|
||||
, dbtColonnade = colonnadeFiles
|
||||
, dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType)
|
||||
, dbtStyle = def
|
||||
, dbtFilter = mconcat
|
||||
[ singletonMap "may-access" . FilterProjected $ \(Any b) r ->
|
||||
let (E.Value fName, _, E.Value fType) = r :: (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType)
|
||||
in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool
|
||||
]
|
||||
, dbtFilterUI = mempty
|
||||
, dbtIdent = "files" :: Text
|
||||
, dbtSorting = Map.fromList
|
||||
[ ( "type"
|
||||
, SortColumn $ \sheetFile -> E.orderByEnum $ sheetFile E.^. SheetFileType
|
||||
)
|
||||
, ( "path"
|
||||
, SortColumn $ \sheetFile -> sheetFile E.^. SheetFileTitle
|
||||
)
|
||||
-- , ( "visible"
|
||||
-- , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet
|
||||
-- )
|
||||
, ( "time"
|
||||
, SortColumn $ \sheetFile -> sheetFile E.^. SheetFileModified
|
||||
)
|
||||
]
|
||||
, dbtParams = def
|
||||
, dbtCsvEncode = noCsvEncode
|
||||
, dbtCsvDecode = Nothing
|
||||
}
|
||||
(hasHints, hasSolution) <- runDB $ do
|
||||
hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
|
||||
hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ]
|
||||
return (hasHints, hasSolution)
|
||||
mPseudonym <- runMaybeT $ do
|
||||
uid <- MaybeT maybeAuthId
|
||||
Entity _ SheetPseudonym{sheetPseudonymPseudonym} <- MaybeT . runDB . getBy $ UniqueSheetPseudonymUser sid uid
|
||||
return $ review _PseudonymText sheetPseudonymPseudonym
|
||||
(generateWidget, generateEnctype) <- generateFormPost $ \csrf ->
|
||||
over _2 ((toWidget csrf <>) . fvWidget) <$> mreq (buttonField BtnGenerate) "" Nothing
|
||||
let generateForm = wrapForm generateWidget def
|
||||
{ formAction = Just . SomeRoute $ CSheetR tid ssh csh shn SPseudonymR
|
||||
, formEncoding = generateEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
|
||||
defaultLayout $ do
|
||||
setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
|
||||
let zipLink = CSheetR tid ssh csh shn SArchiveR
|
||||
visibleFrom = visibleUTCTime SelFormatDateTime <$> sheetVisibleFrom sheet
|
||||
hasSubmission = classifySubmissionMode (sheetSubmissionMode sheet) /= SubmissionModeNone
|
||||
sheetFrom <- traverse (formatTime SelFormatDateTime) $ sheetActiveFrom sheet
|
||||
sheetTo <- traverse (formatTime SelFormatDateTime) $ sheetActiveTo sheet
|
||||
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
|
||||
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
|
||||
markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet)
|
||||
submissionTip <- messageI Info MsgSheetCorrectorSubmissionsTip
|
||||
$(widgetFile "sheetShow")
|
||||
|
||||
getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||
getSArchiveR tid ssh csh shn = do
|
||||
shId <- runDB $ fetchSheetId tid ssh csh shn
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let archiveName = flip addExtension (unpack extensionZip) . unpack . mr $ MsgSheetArchiveName tid ssh csh shn
|
||||
let sftArchive = CSheetR tid ssh csh shn . SZipR -- used to check access to SheetFileTypes
|
||||
allowedSFTs <- filterM (hasReadAccessTo . sftArchive) universeF
|
||||
multipleSFTs <- if
|
||||
| length allowedSFTs < 2 -> return False
|
||||
| otherwise -> runDB . E.selectExists . E.from $ \(sheet `E.InnerJoin` (sFile1 `E.InnerJoin` sFile2)) -> do
|
||||
E.on $ sFile1 E.^. SheetFileType E.!=. sFile2 E.^. SheetFileType
|
||||
E.&&. sFile1 E.^. SheetFileTitle E.==. sFile2 E.^. SheetFileTitle
|
||||
E.on $ sheet E.^. SheetId E.==. sFile1 E.^. SheetFileSheet
|
||||
E.&&. sheet E.^. SheetId E.==. sFile2 E.^. SheetFileSheet
|
||||
E.where_ $ sheet E.^. SheetId E.==. E.val shId
|
||||
E.&&. sFile1 E.^. SheetFileType `E.in_` E.valList allowedSFTs
|
||||
E.&&. sFile2 E.^. SheetFileType `E.in_` E.valList allowedSFTs
|
||||
let modifyTitles SheetFile{..}
|
||||
| not multipleSFTs = SheetFile{..}
|
||||
| otherwise = SheetFile
|
||||
{ sheetFileTitle = unpack (mr $ SheetArchiveFileTypeDirectory sheetFileType) </> sheetFileTitle
|
||||
, ..
|
||||
}
|
||||
sftDirectories <- if
|
||||
| not multipleSFTs -> return mempty
|
||||
| otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectMaybe . E.from $ \sFile -> do
|
||||
E.where_ $ sFile E.^. SheetFileSheet E.==. E.val shId
|
||||
E.&&. sFile E.^. SheetFileType E.==. E.val sft
|
||||
return . E.max_ $ sFile E.^. SheetFileModified
|
||||
|
||||
serveZipArchive archiveName $ do
|
||||
forM_ sftDirectories $ \(sft, mTime) -> yield $ SheetFile
|
||||
{ sheetFileType = sft
|
||||
, sheetFileTitle = unpack . mr $ SheetArchiveFileTypeDirectory sft
|
||||
, sheetFileModified = mTime
|
||||
, sheetFileContent = Nothing
|
||||
, sheetFileSheet = shId
|
||||
}
|
||||
sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal .| C.map modifyTitles
|
||||
|
||||
|
||||
getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||
getSPseudonymR = postSPseudonymR
|
||||
postSPseudonymR tid ssh csh shn = do
|
||||
uid <- requireAuthId
|
||||
shId <- runDB $ fetchSheetId tid ssh csh shn
|
||||
let
|
||||
genPseudonym = do
|
||||
inserted <- runExceptT . mapExceptT (runDB . setSerializable) $ do
|
||||
candidate <- liftIO getRandom
|
||||
existing <- lift . getBy $ UniqueSheetPseudonymUser shId uid
|
||||
case existing of
|
||||
Just (Entity _ SheetPseudonym{sheetPseudonymPseudonym}) -> throwE sheetPseudonymPseudonym
|
||||
Nothing
|
||||
-> lift $ fmap (const candidate) <$> insertUnique (SheetPseudonym shId candidate uid)
|
||||
case inserted of
|
||||
Right Nothing -> genPseudonym
|
||||
Right (Just ps) -> return ps
|
||||
Left ps -> return ps
|
||||
ps <- genPseudonym
|
||||
selectRep $ do
|
||||
provideRep . return $ review _PseudonymText ps
|
||||
provideJson ps
|
||||
provideRep (redirect $ CSheetR tid ssh csh shn SShowR :#: ("pseudonym" :: Text) :: Handler Html)
|
||||
|
||||
|
||||
getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
|
||||
getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file .| C.map entityVal
|
||||
|
||||
getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent
|
||||
getSZipR tid ssh csh shn sft = do
|
||||
sft' <- ap getMessageRender $ pure sft
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgSheetTypeArchiveName tid ssh csh shn sft'
|
||||
serveSomeFiles archiveName $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal
|
||||
|
||||
|
||||
getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetNewR tid ssh csh = do
|
||||
parShn <- runInputGetResult $ iopt ciField "shn"
|
||||
let searchShn sheet = case parShn of
|
||||
(FormSuccess (Just shn)) -> E.where_ $ sheet E.^. SheetName E.==. E.val shn
|
||||
-- (FormFailure msgs) -> -- not in MonadHandler anymore -- forM_ msgs (addMessage Error . toHtml)
|
||||
_other -> return ()
|
||||
(lastSheets, loads) <- runDB $ do
|
||||
lSheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
searchShn sheet
|
||||
-- let lastSheetEdit = E.subSelectMaybe . E.from $ \sheetEdit -> do
|
||||
-- E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||
-- return . E.max_ $ sheetEdit E.^. SheetEditTime
|
||||
-- Preferring last edited sheet may lead to suggesting duplicated sheet name numbers
|
||||
-- E.orderBy [E.desc lastSheetEdit, E.desc (sheet E.^. SheetActiveFrom)]
|
||||
E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
|
||||
E.limit 1
|
||||
let firstEdit = E.subSelectMaybe . E.from $ \sheetEdit -> do
|
||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||
return . E.min_ $ sheetEdit E.^. SheetEditTime
|
||||
return (sheet, firstEdit)
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
loads <- defaultLoads cid
|
||||
return (lSheets, loads)
|
||||
now <- liftIO getCurrentTime
|
||||
let template = case lastSheets of
|
||||
((Entity {entityVal=Sheet{..}}, E.Value fEdit):_) ->
|
||||
let addTime = addWeeks $ max 1 $ weeksToAdd (fromMaybe (UTCTime systemEpochDay 0) $ sheetActiveTo <|> fEdit) now
|
||||
in Just $ SheetForm
|
||||
{ sfName = stepTextCounterCI sheetName
|
||||
, sfDescription = sheetDescription
|
||||
, sfType = sheetType
|
||||
, sfGrouping = sheetGrouping
|
||||
, sfVisibleFrom = addTime <$> sheetVisibleFrom
|
||||
, sfActiveFrom = addTime <$> sheetActiveFrom
|
||||
, sfActiveTo = addTime <$> sheetActiveTo
|
||||
, sfSubmissionMode = sheetSubmissionMode
|
||||
, sfSheetF = Nothing
|
||||
, sfHintFrom = addTime <$> sheetHintFrom
|
||||
, sfHintF = Nothing
|
||||
, sfSolutionFrom = addTime <$> sheetSolutionFrom
|
||||
, sfSolutionF = Nothing
|
||||
, sfMarkingF = Nothing
|
||||
, sfMarkingText = sheetMarkingText
|
||||
, sfAutoDistribute = sheetAutoDistribute
|
||||
, sfCorrectors = loads
|
||||
, sfAnonymousCorrection = sheetAnonymousCorrection
|
||||
}
|
||||
_other -> Nothing
|
||||
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
|
||||
insertUnique $ newSheet
|
||||
handleSheetEdit tid ssh csh Nothing template action
|
||||
|
||||
postSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
postSheetNewR = getSheetNewR
|
||||
|
||||
|
||||
getSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSEditR tid ssh csh shn = do
|
||||
(Entity sid Sheet{..}, sheetFileIds, currentLoads) <- runDB $ do
|
||||
ent@(Entity sid _) <- fetchSheet tid ssh csh shn
|
||||
fti <- getFtIdMap $ entityKey ent
|
||||
cLoads <- Map.union
|
||||
<$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (InvDBDataSheetCorrector sheetCorrectorLoad sheetCorrectorState, InvTokenDataSheetCorrector)) (selectList [ SheetCorrectorSheet ==. sid ] [])
|
||||
<*> fmap (fmap (, InvTokenDataSheetCorrector) . Map.mapKeysMonotonic Left) (sourceInvitationsF sid)
|
||||
return (ent, fti, cLoads)
|
||||
let template = Just $ SheetForm
|
||||
{ sfName = sheetName
|
||||
, sfDescription = sheetDescription
|
||||
, sfType = sheetType
|
||||
, sfGrouping = sheetGrouping
|
||||
, sfVisibleFrom = sheetVisibleFrom
|
||||
, sfActiveFrom = sheetActiveFrom
|
||||
, sfActiveTo = sheetActiveTo
|
||||
, sfSubmissionMode = sheetSubmissionMode
|
||||
, sfSheetF = Just . yieldMany . Set.elems $ sheetFileIds SheetExercise
|
||||
, sfHintFrom = sheetHintFrom
|
||||
, sfHintF = Just . yieldMany . Set.elems $ sheetFileIds SheetHint
|
||||
, sfSolutionFrom = sheetSolutionFrom
|
||||
, sfSolutionF = Just . yieldMany . Set.elems $ sheetFileIds SheetSolution
|
||||
, sfMarkingF = Just . yieldMany . Set.elems $ sheetFileIds SheetMarking
|
||||
, sfMarkingText = sheetMarkingText
|
||||
, sfAutoDistribute = sheetAutoDistribute
|
||||
, sfAnonymousCorrection = sheetAnonymousCorrection
|
||||
, sfCorrectors = currentLoads
|
||||
}
|
||||
|
||||
let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead
|
||||
handleSheetEdit tid ssh csh (Just sid) template action
|
||||
|
||||
postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
postSEditR = getSEditR
|
||||
|
||||
handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodJobDB UniWorX (Maybe SheetId)) -> Handler Html
|
||||
handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
let mbshn = sfName <$> template
|
||||
aid <- requireAuthId
|
||||
cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template
|
||||
case res of
|
||||
(FormSuccess SheetForm{..}) -> do
|
||||
saveOkay <- runDBJobs $ do
|
||||
actTime <- liftIO getCurrentTime
|
||||
let newSheet = Sheet
|
||||
{ sheetCourse = cid
|
||||
, sheetName = sfName
|
||||
, sheetDescription = sfDescription
|
||||
, sheetType = sfType
|
||||
, sheetGrouping = sfGrouping
|
||||
, sheetMarkingText = sfMarkingText
|
||||
, sheetVisibleFrom = sfVisibleFrom
|
||||
, sheetActiveFrom = sfActiveFrom
|
||||
, sheetActiveTo = sfActiveTo
|
||||
, sheetHintFrom = sfHintFrom
|
||||
, sheetSolutionFrom = sfSolutionFrom
|
||||
, sheetSubmissionMode = sfSubmissionMode
|
||||
, sheetAutoDistribute = sfAutoDistribute
|
||||
, sheetAnonymousCorrection = sfAnonymousCorrection
|
||||
}
|
||||
mbsid <- dbAction newSheet
|
||||
case mbsid of
|
||||
Nothing -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName)
|
||||
(Just sid) -> do -- save files in DB:
|
||||
insertSheetFile' sid SheetExercise $ fromMaybe (return ()) sfSheetF
|
||||
insertSheetFile' sid SheetHint $ fromMaybe (return ()) sfHintF
|
||||
insertSheetFile' sid SheetSolution $ fromMaybe (return ()) sfSolutionF
|
||||
insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF
|
||||
insert_ $ SheetEdit aid actTime sid
|
||||
addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
|
||||
-- Sanity checks generating warnings only, but not errors!
|
||||
hoist lift . warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
|
||||
[ (sfVisibleFrom, MsgSheetVisibleFrom)
|
||||
, (sfActiveFrom, MsgSheetActiveFrom)
|
||||
, (sfActiveTo, MsgSheetActiveTo)
|
||||
, (sfHintFrom, MsgSheetSolutionFromTip)
|
||||
, (sfSolutionFrom, MsgSheetSolutionFrom)
|
||||
] ]
|
||||
|
||||
let
|
||||
sheetCorrectors :: Set (Either (Invitation' SheetCorrector) SheetCorrector)
|
||||
sheetCorrectors = Set.fromList . map f $ Map.toList sfCorrectors
|
||||
where
|
||||
f (Left email, invData) = Left (email, sid, invData)
|
||||
f (Right uid, (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)) = Right $ SheetCorrector uid sid load cState
|
||||
(invites, adds) = partitionEithers $ Set.toList sheetCorrectors
|
||||
|
||||
deleteWhere [ SheetCorrectorSheet ==. sid ]
|
||||
insertMany_ adds
|
||||
|
||||
deleteWhere [InvitationFor ==. invRef @SheetCorrector sid, InvitationEmail /<-. toListOf (folded . _1) invites]
|
||||
sinkInvitationsF correctorInvitationConfig invites
|
||||
|
||||
return True
|
||||
when saveOkay $
|
||||
redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
|
||||
_ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
|
||||
[(sfVisibleFrom =<< template, MsgSheetVisibleFrom)
|
||||
,(sfActiveFrom =<< template, MsgSheetActiveFrom)
|
||||
,(sfActiveTo =<< template, MsgSheetActiveTo)
|
||||
,(sfHintFrom =<< template, MsgSheetSolutionFromTip)
|
||||
,(sfSolutionFrom =<< template, MsgSheetSolutionFrom)
|
||||
] ]
|
||||
|
||||
let pageTitle = maybe (MsgSheetTitleNew tid ssh csh)
|
||||
(MsgSheetTitle tid ssh csh) mbshn
|
||||
-- let formTitle = pageTitle -- no longer used in template
|
||||
actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute
|
||||
defaultLayout $ do
|
||||
setTitleI pageTitle
|
||||
let sheetEditForm = wrapForm formWidget def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = formEnctype
|
||||
}
|
||||
$(i18nWidgetFile "sheet-edit")
|
||||
|
||||
|
||||
getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSDelR = postSDelR
|
||||
postSDelR tid ssh csh shn = do
|
||||
sid <- runDB $ fetchSheetId tid ssh csh shn
|
||||
deleteR $ (sheetDeleteRoute $ Set.singleton sid)
|
||||
{ drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR
|
||||
, drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR
|
||||
}
|
||||
|
||||
|
||||
insertSheetFile' :: SheetId -> SheetFileType -> FileUploads -> YesodJobDB UniWorX ()
|
||||
insertSheetFile' sid ftype fs = do
|
||||
oldFiles <- fmap (Map.fromList . map $(E.unValueN 2)) . E.select . E.from $ \sheetFile -> do
|
||||
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
|
||||
E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype
|
||||
return (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileId)
|
||||
keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ (finsert oldFiles)
|
||||
deleteWhere [ SheetFileSheet ==. sid, SheetFileType ==. ftype, SheetFileId <-. Set.toList (setOf folded oldFiles \\ keep) ]
|
||||
where
|
||||
finsert oldFiles fRef
|
||||
| Just sfId <- fileReferenceTitle fRef `Map.lookup` oldFiles
|
||||
= tell $ Set.singleton sfId
|
||||
| otherwise
|
||||
= do
|
||||
sfId <- lift . insert $ _FileReference # (fRef, SheetFileResidual sid ftype)
|
||||
tell $ Set.singleton sfId
|
||||
|
||||
|
||||
defaultLoads :: CourseId -> DB Loads
|
||||
-- ^ Generate `Loads` in such a way that minimal editing is required
|
||||
--
|
||||
-- For every user, that ever was a corrector for this course, return their last `Load`.
|
||||
-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit).
|
||||
defaultLoads cId = do
|
||||
fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
|
||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
|
||||
let creationTime = E.subSelectMaybe . E.from $ \sheetEdit -> do
|
||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||
return . E.min_ $ sheetEdit E.^. SheetEditTime
|
||||
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cId
|
||||
|
||||
E.orderBy [E.desc creationTime]
|
||||
|
||||
return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
|
||||
where
|
||||
toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
|
||||
toMap = foldMap $ \(E.Value uid, E.Value cLoad, E.Value cState) -> Map.singleton (Right uid) (InvDBDataSheetCorrector cLoad cState, InvTokenDataSheetCorrector)
|
||||
|
||||
|
||||
correctorForm :: Loads -> AForm Handler Loads
|
||||
correctorForm loads' = wFormToAForm $ do
|
||||
currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute
|
||||
userId <- liftHandler requireAuthId
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
let
|
||||
loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
|
||||
loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load)
|
||||
|
||||
countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
|
||||
|
||||
|
||||
let
|
||||
previousCorrectors :: E.SqlQuery (E.SqlExpr (Entity User))
|
||||
previousCorrectors = E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
|
||||
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
|
||||
E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||
return user
|
||||
|
||||
miAdd :: ListPosition
|
||||
-> Natural
|
||||
-> (Text -> Text)
|
||||
-> FieldView UniWorX
|
||||
-> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
|
||||
miAdd _ _ nudge submitView = Just $ \csrf -> do
|
||||
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just previousCorrectors) (fslpI MsgCorrector (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing
|
||||
let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
|
||||
| existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData
|
||||
, not $ null existing
|
||||
-> FormFailure [mr MsgCorrectorExists]
|
||||
| otherwise
|
||||
-> FormSuccess . Map.fromList . zip [kStart..] $ Set.toList nCorrs
|
||||
return (addRes', $(widgetFile "sheetCorrectors/add"))
|
||||
|
||||
miCell :: ListPosition
|
||||
-> Either UserEmail UserId
|
||||
-> Maybe (CorrectorState, Load)
|
||||
-> (Text -> Text)
|
||||
-> Form (CorrectorState, Load)
|
||||
miCell _ userIdent initRes nudge csrf = do
|
||||
(stateRes, stateView) <- mreq (selectField optionsFinite) (fslI MsgSheetCorrectorState & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
|
||||
(byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
|
||||
(propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
|
||||
let
|
||||
res :: FormResult (CorrectorState, Load)
|
||||
res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
|
||||
tutRes'
|
||||
| FormSuccess True <- byTutRes = Just <$> countTutRes
|
||||
| otherwise = Nothing <$ byTutRes
|
||||
identWidget <- case userIdent of
|
||||
Left email -> return . toWidget $ mailtoHtml email
|
||||
Right uid -> do
|
||||
User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ getJust uid
|
||||
return $ nameEmailWidget userEmail userDisplayName userSurname
|
||||
invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
|
||||
return (res, $(widgetFile "sheetCorrectors/cell"))
|
||||
|
||||
|
||||
miDelete :: Map ListPosition (Either UserEmail UserId)
|
||||
-> ListPosition
|
||||
-> MaybeT (MForm Handler) (Map ListPosition ListPosition)
|
||||
miDelete = miDeleteList
|
||||
|
||||
miAllowAdd :: ListPosition
|
||||
-> Natural
|
||||
-> ListLength
|
||||
-> Bool
|
||||
miAllowAdd _ _ _ = True
|
||||
|
||||
miAddEmpty :: ListPosition
|
||||
-> Natural
|
||||
-> ListLength
|
||||
-> Set ListPosition
|
||||
miAddEmpty _ _ _ = Set.empty
|
||||
|
||||
miButtonAction :: forall p.
|
||||
PathPiece p
|
||||
=> p
|
||||
-> Maybe (SomeRoute UniWorX)
|
||||
miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
|
||||
|
||||
miLayout :: ListLength
|
||||
-> Map ListPosition (Either UserEmail UserId, FormResult (CorrectorState, Load))
|
||||
-> Map ListPosition Widget
|
||||
-> Map ListPosition (FieldView UniWorX)
|
||||
-> Map (Natural, ListPosition) Widget
|
||||
-> Widget
|
||||
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout")
|
||||
|
||||
miIdent :: Text
|
||||
miIdent = "correctors"
|
||||
|
||||
postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Loads
|
||||
postProcess = Map.fromList . map postProcess' . Map.elems
|
||||
where
|
||||
postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> (Either UserEmail UserId, (InvitationDBData SheetCorrector, InvitationTokenData SheetCorrector))
|
||||
postProcess' = over _2 $ \(cState, load) -> (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)
|
||||
|
||||
filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)))
|
||||
filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?!
|
||||
|
||||
fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors) False filledData
|
||||
|
||||
|
||||
instance IsInvitableJunction SheetCorrector where
|
||||
type InvitationFor SheetCorrector = Sheet
|
||||
data InvitableJunction SheetCorrector = JunctionSheetCorrector
|
||||
{ jSheetCorrectorLoad :: Load
|
||||
, jSheetCorrectorState :: CorrectorState
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData SheetCorrector = InvDBDataSheetCorrector
|
||||
{ invDBSheetCorrectorLoad :: Load
|
||||
, invDBSheetCorrectorState :: CorrectorState
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationTokenData SheetCorrector = InvTokenDataSheetCorrector
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
_InvitableJunction = iso
|
||||
(\SheetCorrector{..} -> (sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState))
|
||||
(\(sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState) -> SheetCorrector{..})
|
||||
|
||||
instance ToJSON (InvitableJunction SheetCorrector) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
instance FromJSON (InvitableJunction SheetCorrector) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
|
||||
instance ToJSON (InvitationDBData SheetCorrector) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationDBData SheetCorrector) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
|
||||
instance ToJSON (InvitationTokenData SheetCorrector) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationTokenData SheetCorrector) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
|
||||
correctorInvitationConfig :: InvitationConfig SheetCorrector
|
||||
correctorInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute (Entity _ Sheet{..}) _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
|
||||
invitationResolveFor _ = do
|
||||
cRoute <- getCurrentRoute
|
||||
case cRoute of
|
||||
Just (CSheetR tid csh ssh shn SCorrInviteR) ->
|
||||
fetchSheetId tid csh ssh shn
|
||||
_other ->
|
||||
error "correctorInvitationConfig called from unsupported route"
|
||||
invitationSubject (Entity _ Sheet{..}) _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
|
||||
invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
|
||||
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ())
|
||||
invitationInsertHook _ _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
|
||||
invitationUltDest (Entity _ Sheet{..}) _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
return . SomeRoute $ CSheetR courseTerm courseSchool courseShorthand sheetName SShowR
|
||||
|
||||
getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSCorrInviteR = postSCorrInviteR
|
||||
postSCorrInviteR = invitationR correctorInvitationConfig
|
||||
|
||||
|
||||
getSIsCorrR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
-- NOTE: The route SIsCorrR is only used to verfify corrector access rights to given sheet!
|
||||
getSIsCorrR _ _ _ shn = do
|
||||
getSIsCorrR _ _ _ shn =
|
||||
defaultLayout . i18n $ MsgHaveCorrectorAccess shn
|
||||
|
||||
|
||||
86
src/Handler/Sheet/CorrectorInvite.hs
Normal file
86
src/Handler/Sheet/CorrectorInvite.hs
Normal file
@ -0,0 +1,86 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Handler.Sheet.CorrectorInvite
|
||||
( getSCorrInviteR, postSCorrInviteR
|
||||
, InvitableJunction(..), InvitationDBData(..), InvitationTokenData(..)
|
||||
, correctorInvitationConfig
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
|
||||
instance IsInvitableJunction SheetCorrector where
|
||||
type InvitationFor SheetCorrector = Sheet
|
||||
data InvitableJunction SheetCorrector = JunctionSheetCorrector
|
||||
{ jSheetCorrectorLoad :: Load
|
||||
, jSheetCorrectorState :: CorrectorState
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationDBData SheetCorrector = InvDBDataSheetCorrector
|
||||
{ invDBSheetCorrectorLoad :: Load
|
||||
, invDBSheetCorrectorState :: CorrectorState
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
data InvitationTokenData SheetCorrector = InvTokenDataSheetCorrector
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
_InvitableJunction = iso
|
||||
(\SheetCorrector{..} -> (sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState))
|
||||
(\(sheetCorrectorUser, sheetCorrectorSheet, JunctionSheetCorrector sheetCorrectorLoad sheetCorrectorState) -> SheetCorrector{..})
|
||||
|
||||
instance ToJSON (InvitableJunction SheetCorrector) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
instance FromJSON (InvitableJunction SheetCorrector) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 1 }
|
||||
|
||||
instance ToJSON (InvitationDBData SheetCorrector) where
|
||||
toJSON = genericToJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationDBData SheetCorrector) where
|
||||
parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelToPathPiece' 4 }
|
||||
|
||||
instance ToJSON (InvitationTokenData SheetCorrector) where
|
||||
toJSON = genericToJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
toEncoding = genericToEncoding defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
instance FromJSON (InvitationTokenData SheetCorrector) where
|
||||
parseJSON = genericParseJSON defaultOptions { constructorTagModifier = camelToPathPiece' 4 }
|
||||
|
||||
correctorInvitationConfig :: InvitationConfig SheetCorrector
|
||||
correctorInvitationConfig = InvitationConfig{..}
|
||||
where
|
||||
invitationRoute (Entity _ Sheet{..}) _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
return $ CSheetR courseTerm courseSchool courseShorthand sheetName SCorrInviteR
|
||||
invitationResolveFor _ = do
|
||||
cRoute <- getCurrentRoute
|
||||
case cRoute of
|
||||
Just (CSheetR tid csh ssh shn SCorrInviteR) ->
|
||||
fetchSheetId tid csh ssh shn
|
||||
_other ->
|
||||
error "correctorInvitationConfig called from unsupported route"
|
||||
invitationSubject (Entity _ Sheet{..}) _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
return . SomeMessage $ MsgMailSubjectCorrectorInvitation courseTerm courseSchool courseShorthand sheetName
|
||||
invitationHeading (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgSheetCorrInviteHeading sheetName
|
||||
invitationExplanation _ _ = return [ihamlet|_{SomeMessage MsgSheetCorrInviteExplanation}|]
|
||||
invitationTokenConfig _ _ = do
|
||||
itAuthority <- HashSet.singleton . Right <$> liftHandler requireAuthId
|
||||
return $ InvitationTokenConfig itAuthority Nothing Nothing Nothing
|
||||
invitationRestriction _ _ = return Authorized
|
||||
invitationForm _ (InvDBDataSheetCorrector cLoad cState, _) _ = pure $ (JunctionSheetCorrector cLoad cState, ())
|
||||
invitationInsertHook _ _ _ _ _ = id
|
||||
invitationSuccessMsg (Entity _ Sheet{..}) _ = return . SomeMessage $ MsgCorrectorInvitationAccepted sheetName
|
||||
invitationUltDest (Entity _ Sheet{..}) _ = do
|
||||
Course{..} <- get404 sheetCourse
|
||||
return . SomeRoute $ CSheetR courseTerm courseSchool courseShorthand sheetName SShowR
|
||||
|
||||
getSCorrInviteR, postSCorrInviteR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSCorrInviteR = postSCorrInviteR
|
||||
postSCorrInviteR = invitationR correctorInvitationConfig
|
||||
27
src/Handler/Sheet/Current.hs
Normal file
27
src/Handler/Sheet/Current.hs
Normal file
@ -0,0 +1,27 @@
|
||||
module Handler.Sheet.Current
|
||||
( getSheetCurrentR
|
||||
, getSheetOldUnassignedR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Sheet
|
||||
|
||||
|
||||
getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Void
|
||||
getSheetCurrentR tid ssh csh = do
|
||||
mbShn <- runDB $ sheetCurrent tid ssh csh
|
||||
case mbShn of
|
||||
Just shn -> redirectAccess $ CSheetR tid ssh csh shn SShowR
|
||||
Nothing -> do -- no current sheet exists
|
||||
addMessageI Error MsgSheetNoCurrent
|
||||
redirect $ CourseR tid ssh csh SheetListR
|
||||
|
||||
getSheetOldUnassignedR :: TermId -> SchoolId -> CourseShorthand -> Handler Void
|
||||
getSheetOldUnassignedR tid ssh csh = do
|
||||
mbShn <- runDB $ sheetOldUnassigned tid ssh csh
|
||||
case mbShn of
|
||||
Just shn -> redirectAccess $ CSheetR tid ssh csh shn SSubsR
|
||||
Nothing -> do -- no unassigned submissions in any inactive sheet
|
||||
addMessageI Error MsgSheetNoOldUnassigned
|
||||
redirect $ CourseR tid ssh csh SheetListR
|
||||
50
src/Handler/Sheet/Delete.hs
Normal file
50
src/Handler/Sheet/Delete.hs
Normal file
@ -0,0 +1,50 @@
|
||||
module Handler.Sheet.Delete
|
||||
( getSDelR, postSDelR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils.Delete
|
||||
import Handler.Utils.Sheet
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
sheetDeleteRoute :: Set SheetId -> DeleteRoute Sheet
|
||||
sheetDeleteRoute drRecords = DeleteRoute
|
||||
{ drRecords
|
||||
, drGetInfo = \(sheet `E.InnerJoin` course `E.InnerJoin` school) -> do
|
||||
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
let submissions = E.subSelectCount . E.from $ \submission ->
|
||||
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
E.orderBy [E.asc $ sheet E.^. SheetName]
|
||||
return (submissions, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
|
||||
, drUnjoin = \(sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet
|
||||
, drRenderRecord = \(E.Value submissions, E.Value shn', _, E.Value cName, _, E.Value sName, E.Value tid') ->
|
||||
return [whamlet|
|
||||
$newline never
|
||||
#{shn'} (_{SomeMessage $ ShortTermIdentifier (unTermKey tid')}, #{sName}, #{cName})
|
||||
$if submissions /= 0
|
||||
<i>_{SomeMessage $ MsgSheetDelHasSubmissions submissions}
|
||||
|]
|
||||
, drRecordConfirmString = \(E.Value submissions, E.Value shn', E.Value csh', _, E.Value ssh', _, E.Value tid') ->
|
||||
return $ [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}|] <> bool mempty [st| + #{tshow submissions} Subs|] (submissions /= 0)
|
||||
, drCaption = SomeMessage MsgSheetDeleteQuestion
|
||||
, drSuccessMessage = SomeMessage MsgSheetDeleted
|
||||
, drFormMessage = const $ return Nothing
|
||||
, drAbort = error "drAbort undefined"
|
||||
, drSuccess = error "drSuccess undefined"
|
||||
, drDelete = const id -- TODO: audit
|
||||
}
|
||||
|
||||
getSDelR, postSDelR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSDelR = postSDelR
|
||||
postSDelR tid ssh csh shn = do
|
||||
sid <- runDB $ fetchSheetId tid ssh csh shn
|
||||
deleteR $ (sheetDeleteRoute $ Set.singleton sid)
|
||||
{ drAbort = SomeRoute $ CSheetR tid ssh csh shn SShowR
|
||||
, drSuccess = SomeRoute $ CourseR tid ssh csh SheetListR
|
||||
}
|
||||
64
src/Handler/Sheet/Download.hs
Normal file
64
src/Handler/Sheet/Download.hs
Normal file
@ -0,0 +1,64 @@
|
||||
module Handler.Sheet.Download
|
||||
( getSArchiveR, getSFileR, getSZipR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Sheet
|
||||
import Handler.Utils
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
|
||||
getSArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||
getSArchiveR tid ssh csh shn = do
|
||||
shId <- runDB $ fetchSheetId tid ssh csh shn
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
let archiveName = flip addExtension (unpack extensionZip) . unpack . mr $ MsgSheetArchiveName tid ssh csh shn
|
||||
let sftArchive = CSheetR tid ssh csh shn . SZipR -- used to check access to SheetFileTypes
|
||||
allowedSFTs <- filterM (hasReadAccessTo . sftArchive) universeF
|
||||
multipleSFTs <- if
|
||||
| length allowedSFTs < 2 -> return False
|
||||
| otherwise -> runDB . E.selectExists . E.from $ \(sheet `E.InnerJoin` (sFile1 `E.InnerJoin` sFile2)) -> do
|
||||
E.on $ sFile1 E.^. SheetFileType E.!=. sFile2 E.^. SheetFileType
|
||||
E.&&. sFile1 E.^. SheetFileTitle E.==. sFile2 E.^. SheetFileTitle
|
||||
E.on $ sheet E.^. SheetId E.==. sFile1 E.^. SheetFileSheet
|
||||
E.&&. sheet E.^. SheetId E.==. sFile2 E.^. SheetFileSheet
|
||||
E.where_ $ sheet E.^. SheetId E.==. E.val shId
|
||||
E.&&. sFile1 E.^. SheetFileType `E.in_` E.valList allowedSFTs
|
||||
E.&&. sFile2 E.^. SheetFileType `E.in_` E.valList allowedSFTs
|
||||
let modifyTitles SheetFile{..}
|
||||
| not multipleSFTs = SheetFile{..}
|
||||
| otherwise = SheetFile
|
||||
{ sheetFileTitle = unpack (mr $ SheetArchiveFileTypeDirectory sheetFileType) </> sheetFileTitle
|
||||
, ..
|
||||
}
|
||||
sftDirectories <- if
|
||||
| not multipleSFTs -> return mempty
|
||||
| otherwise -> runDB . fmap (mapMaybe $ \(sft, mTime) -> (sft, ) <$> mTime) . forM allowedSFTs $ \sft -> fmap ((sft, ) . (=<<) E.unValue) . E.selectMaybe . E.from $ \sFile -> do
|
||||
E.where_ $ sFile E.^. SheetFileSheet E.==. E.val shId
|
||||
E.&&. sFile E.^. SheetFileType E.==. E.val sft
|
||||
return . E.max_ $ sFile E.^. SheetFileModified
|
||||
|
||||
serveZipArchive archiveName $ do
|
||||
forM_ sftDirectories $ \(sft, mTime) -> yield $ SheetFile
|
||||
{ sheetFileType = sft
|
||||
, sheetFileTitle = unpack . mr $ SheetArchiveFileTypeDirectory sft
|
||||
, sheetFileModified = mTime
|
||||
, sheetFileContent = Nothing
|
||||
, sheetFileSheet = shId
|
||||
}
|
||||
sheetFilesSFTsQuery tid ssh csh shn allowedSFTs .| C.map entityVal .| C.map modifyTitles
|
||||
|
||||
getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
|
||||
getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file .| C.map entityVal
|
||||
|
||||
getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> Handler TypedContent
|
||||
getSZipR tid ssh csh shn sft = do
|
||||
sft' <- ap getMessageRender $ pure sft
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgSheetTypeArchiveName tid ssh csh shn sft'
|
||||
serveSomeFiles archiveName $ sheetFilesAllQuery tid ssh csh shn sft .| C.map entityVal
|
||||
158
src/Handler/Sheet/Edit.hs
Normal file
158
src/Handler/Sheet/Edit.hs
Normal file
@ -0,0 +1,158 @@
|
||||
module Handler.Sheet.Edit
|
||||
( getSEditR, postSEditR
|
||||
, handleSheetEdit
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Jobs.Queue
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
import Handler.Sheet.Form
|
||||
import Handler.Sheet.CorrectorInvite
|
||||
|
||||
|
||||
getSEditR, postSEditR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSEditR = postSEditR
|
||||
postSEditR tid ssh csh shn = do
|
||||
(Entity sid Sheet{..}, sheetFileIds, currentLoads) <- runDB $ do
|
||||
ent@(Entity sid _) <- fetchSheet tid ssh csh shn
|
||||
fti <- getFtIdMap $ entityKey ent
|
||||
cLoads <- Map.union
|
||||
<$> fmap (foldMap $ \(Entity _ SheetCorrector{..}) -> Map.singleton (Right sheetCorrectorUser) (InvDBDataSheetCorrector sheetCorrectorLoad sheetCorrectorState, InvTokenDataSheetCorrector)) (selectList [ SheetCorrectorSheet ==. sid ] [])
|
||||
<*> fmap (fmap (, InvTokenDataSheetCorrector) . Map.mapKeysMonotonic Left) (sourceInvitationsF sid)
|
||||
return (ent, fti, cLoads)
|
||||
let template = Just $ SheetForm
|
||||
{ sfName = sheetName
|
||||
, sfDescription = sheetDescription
|
||||
, sfType = sheetType
|
||||
, sfGrouping = sheetGrouping
|
||||
, sfVisibleFrom = sheetVisibleFrom
|
||||
, sfActiveFrom = sheetActiveFrom
|
||||
, sfActiveTo = sheetActiveTo
|
||||
, sfSubmissionMode = sheetSubmissionMode
|
||||
, sfSheetF = Just . yieldMany . Set.elems $ sheetFileIds SheetExercise
|
||||
, sfHintFrom = sheetHintFrom
|
||||
, sfHintF = Just . yieldMany . Set.elems $ sheetFileIds SheetHint
|
||||
, sfSolutionFrom = sheetSolutionFrom
|
||||
, sfSolutionF = Just . yieldMany . Set.elems $ sheetFileIds SheetSolution
|
||||
, sfMarkingF = Just . yieldMany . Set.elems $ sheetFileIds SheetMarking
|
||||
, sfMarkingText = sheetMarkingText
|
||||
, sfAutoDistribute = sheetAutoDistribute
|
||||
, sfAnonymousCorrection = sheetAnonymousCorrection
|
||||
, sfCorrectors = currentLoads
|
||||
}
|
||||
|
||||
let action = uniqueReplace sid -- More specific error message for edit old sheet could go here by using myReplaceUnique instead
|
||||
handleSheetEdit tid ssh csh (Just sid) template action
|
||||
|
||||
handleSheetEdit :: TermId -> SchoolId -> CourseShorthand -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodJobDB UniWorX (Maybe SheetId)) -> Handler Html
|
||||
handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
let mbshn = sfName <$> template
|
||||
aid <- requireAuthId
|
||||
cid <- runDB $ getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template
|
||||
case res of
|
||||
(FormSuccess SheetForm{..}) -> do
|
||||
saveOkay <- runDBJobs $ do
|
||||
actTime <- liftIO getCurrentTime
|
||||
let newSheet = Sheet
|
||||
{ sheetCourse = cid
|
||||
, sheetName = sfName
|
||||
, sheetDescription = sfDescription
|
||||
, sheetType = sfType
|
||||
, sheetGrouping = sfGrouping
|
||||
, sheetMarkingText = sfMarkingText
|
||||
, sheetVisibleFrom = sfVisibleFrom
|
||||
, sheetActiveFrom = sfActiveFrom
|
||||
, sheetActiveTo = sfActiveTo
|
||||
, sheetHintFrom = sfHintFrom
|
||||
, sheetSolutionFrom = sfSolutionFrom
|
||||
, sheetSubmissionMode = sfSubmissionMode
|
||||
, sheetAutoDistribute = sfAutoDistribute
|
||||
, sheetAnonymousCorrection = sfAnonymousCorrection
|
||||
}
|
||||
mbsid <- dbAction newSheet
|
||||
case mbsid of
|
||||
Nothing -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName)
|
||||
(Just sid) -> do -- save files in DB:
|
||||
insertSheetFile' sid SheetExercise $ fromMaybe (return ()) sfSheetF
|
||||
insertSheetFile' sid SheetHint $ fromMaybe (return ()) sfHintF
|
||||
insertSheetFile' sid SheetSolution $ fromMaybe (return ()) sfSolutionF
|
||||
insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF
|
||||
insert_ $ SheetEdit aid actTime sid
|
||||
addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
|
||||
-- Sanity checks generating warnings only, but not errors!
|
||||
hoist lift . warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
|
||||
[ (sfVisibleFrom, MsgSheetVisibleFrom)
|
||||
, (sfActiveFrom, MsgSheetActiveFrom)
|
||||
, (sfActiveTo, MsgSheetActiveTo)
|
||||
, (sfHintFrom, MsgSheetSolutionFromTip)
|
||||
, (sfSolutionFrom, MsgSheetSolutionFrom)
|
||||
] ]
|
||||
|
||||
let
|
||||
sheetCorrectors :: Set (Either (Invitation' SheetCorrector) SheetCorrector)
|
||||
sheetCorrectors = Set.fromList . map f $ Map.toList sfCorrectors
|
||||
where
|
||||
f (Left email, invData) = Left (email, sid, invData)
|
||||
f (Right uid, (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)) = Right $ SheetCorrector uid sid load cState
|
||||
(invites, adds) = partitionEithers $ Set.toList sheetCorrectors
|
||||
|
||||
deleteWhere [ SheetCorrectorSheet ==. sid ]
|
||||
insertMany_ adds
|
||||
|
||||
deleteWhere [InvitationFor ==. invRef @SheetCorrector sid, InvitationEmail /<-. toListOf (folded . _1) invites]
|
||||
sinkInvitationsF correctorInvitationConfig invites
|
||||
|
||||
return True
|
||||
when saveOkay $
|
||||
redirect $ CSheetR tid ssh csh sfName SShowR -- redirect must happen outside of runDB
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage Error) . toHtml
|
||||
_ -> runDB $ warnTermDays tid $ Map.fromList [ (date,name) | (Just date, name) <-
|
||||
[(sfVisibleFrom =<< template, MsgSheetVisibleFrom)
|
||||
,(sfActiveFrom =<< template, MsgSheetActiveFrom)
|
||||
,(sfActiveTo =<< template, MsgSheetActiveTo)
|
||||
,(sfHintFrom =<< template, MsgSheetSolutionFromTip)
|
||||
,(sfSolutionFrom =<< template, MsgSheetSolutionFrom)
|
||||
] ]
|
||||
|
||||
let pageTitle = maybe (MsgSheetTitleNew tid ssh csh)
|
||||
(MsgSheetTitle tid ssh csh) mbshn
|
||||
-- let formTitle = pageTitle -- no longer used in template
|
||||
actionUrl <- fromMaybe (CourseR tid ssh csh SheetNewR) <$> getCurrentRoute
|
||||
defaultLayout $ do
|
||||
setTitleI pageTitle
|
||||
let sheetEditForm = wrapForm formWidget def
|
||||
{ formAction = Just $ SomeRoute actionUrl
|
||||
, formEncoding = formEnctype
|
||||
}
|
||||
$(i18nWidgetFile "sheet-edit")
|
||||
|
||||
insertSheetFile' :: SheetId -> SheetFileType -> FileUploads -> YesodJobDB UniWorX ()
|
||||
insertSheetFile' sid ftype fs = do
|
||||
oldFiles <- fmap (Map.fromList . map $(E.unValueN 2)) . E.select . E.from $ \sheetFile -> do
|
||||
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
|
||||
E.&&. sheetFile E.^. SheetFileType E.==. E.val ftype
|
||||
return (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileId)
|
||||
keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ (finsert oldFiles)
|
||||
deleteWhere [ SheetFileSheet ==. sid, SheetFileType ==. ftype, SheetFileId <-. Set.toList (setOf folded oldFiles \\ keep) ]
|
||||
where
|
||||
finsert oldFiles fRef
|
||||
| Just sfId <- fileReferenceTitle fRef `Map.lookup` oldFiles
|
||||
= tell $ Set.singleton sfId
|
||||
| otherwise
|
||||
= do
|
||||
sfId <- lift . insert $ _FileReference # (fRef, SheetFileResidual sid ftype)
|
||||
tell $ Set.singleton sfId
|
||||
210
src/Handler/Sheet/Form.hs
Normal file
210
src/Handler/Sheet/Form.hs
Normal file
@ -0,0 +1,210 @@
|
||||
module Handler.Sheet.Form
|
||||
( SheetForm(..), Loads
|
||||
, makeSheetForm
|
||||
, getFtIdMap
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.Map ((!))
|
||||
|
||||
import qualified Control.Monad.State.Class as State
|
||||
|
||||
|
||||
import Handler.Sheet.CorrectorInvite
|
||||
|
||||
|
||||
type Loads = Map (Either UserEmail UserId) (InvitationData SheetCorrector)
|
||||
|
||||
data SheetForm = SheetForm
|
||||
{ sfName :: SheetName
|
||||
, sfDescription :: Maybe Html
|
||||
, sfSheetF, sfHintF, sfSolutionF, sfMarkingF :: Maybe FileUploads
|
||||
, sfVisibleFrom :: Maybe UTCTime
|
||||
, sfActiveFrom :: Maybe UTCTime
|
||||
, sfActiveTo :: Maybe UTCTime
|
||||
, sfHintFrom :: Maybe UTCTime
|
||||
, sfSolutionFrom :: Maybe UTCTime
|
||||
, sfSubmissionMode :: SubmissionMode
|
||||
, sfGrouping :: SheetGroup
|
||||
, sfType :: SheetType
|
||||
, sfAutoDistribute :: Bool
|
||||
, sfMarkingText :: Maybe Html
|
||||
, sfAnonymousCorrection :: Bool
|
||||
, sfCorrectors :: Loads
|
||||
-- Keine SheetId im Formular!
|
||||
}
|
||||
|
||||
|
||||
getFtIdMap :: Key Sheet -> DB (SheetFileType -> Set FileReference)
|
||||
getFtIdMap sId = do
|
||||
allSheetFiles <- E.select . E.from $ \sheetFile -> do
|
||||
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sId
|
||||
return sheetFile
|
||||
return $ partitionFileType [ (sheetFileType, sf ^. _FileReference . _1) | Entity _ sf@SheetFile{..} <- allSheetFiles ]
|
||||
|
||||
makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
|
||||
makeSheetForm msId template = identifyForm FIDsheet . validateForm validateSheet $ \html -> do
|
||||
oldFileIds <- (return.) <$> case msId of
|
||||
Nothing -> return $ partitionFileType mempty
|
||||
(Just sId) -> liftHandler $ runDB $ getFtIdMap sId
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
ctime <- ceilingQuarterHour <$> liftIO getCurrentTime
|
||||
flip (renderAForm FormStandard) html $ SheetForm
|
||||
<$> areq (textField & cfStrip & cfCI) (fslI MsgSheetName) (sfName <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetDescription) (sfDescription <$> template)
|
||||
<* aformSection MsgSheetFormFiles
|
||||
<*> aopt (multiFileField $ oldFileIds SheetExercise) (fslI MsgSheetExercise) (sfSheetF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetHint) (fslI MsgSheetHint) (sfHintF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetSolution) (fslI MsgSheetSolution) (sfSolutionF <$> template)
|
||||
<*> aopt (multiFileField $ oldFileIds SheetMarking) (fslI MsgSheetMarkingFiles
|
||||
& setTooltip MsgSheetMarkingTip) (sfMarkingF <$> template)
|
||||
<* aformSection MsgSheetFormTimes
|
||||
<*> aopt utcTimeField (fslI MsgSheetVisibleFrom
|
||||
& setTooltip MsgSheetVisibleFromTip)
|
||||
((sfVisibleFrom <$> template) <|> pure (Just ctime))
|
||||
<*> aopt utcTimeField (fslI MsgSheetActiveFrom
|
||||
& setTooltip MsgSheetActiveFromTip)
|
||||
(sfActiveFrom <$> template)
|
||||
<*> aopt utcTimeField (fslI MsgSheetActiveTo & setTooltip MsgSheetActiveToTip) (sfActiveTo <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgSheetHintFrom (mr MsgSheetHintFromPlaceholder)
|
||||
& setTooltip MsgSheetHintFromTip) (sfHintFrom <$> template)
|
||||
<*> aopt utcTimeField (fslpI MsgSheetSolutionFrom (mr MsgSheetSolutionFromPlaceholder)
|
||||
& setTooltip MsgSheetSolutionFromTip) (sfSolutionFrom <$> template)
|
||||
<* aformSection MsgSheetFormType
|
||||
<*> submissionModeForm ((sfSubmissionMode <$> template) <|> pure (SubmissionMode False . Just $ UploadAny True defaultExtensionRestriction))
|
||||
<*> sheetGroupAFormReq (fslI MsgSheetGroup) ((sfGrouping <$> template) <|> pure NoGroups)
|
||||
<*> sheetTypeAFormReq (fslI MsgSheetType) (sfType <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgAutoAssignCorrs) (sfAutoDistribute <$> template)
|
||||
<*> aopt htmlField (fslI MsgSheetMarking) (sfMarkingText <$> template)
|
||||
<*> apopt checkBoxField (fslI MsgSheetAnonymousCorrection & setTooltip MsgSheetAnonymousCorrectionTip) (sfAnonymousCorrection <$> template)
|
||||
<*> correctorForm (fromMaybe mempty $ sfCorrectors <$> template)
|
||||
where
|
||||
validateSheet :: FormValidator SheetForm Handler ()
|
||||
validateSheet = do
|
||||
SheetForm{..} <- State.get
|
||||
|
||||
guardValidation MsgSheetErrVisibility $ NTop sfVisibleFrom <= NTop sfActiveFrom
|
||||
guardValidation MsgSheetErrDeadlineEarly $ NTop sfActiveFrom <= NTop sfActiveTo
|
||||
guardValidation MsgSheetErrHintEarly $ NTop sfHintFrom >= NTop sfActiveFrom
|
||||
guardValidation MsgSheetErrSolutionEarly $ NTop sfSolutionFrom >= NTop sfActiveTo
|
||||
|
||||
guardValidation MsgSheetErrVisibleWithoutActive $ is _Just sfActiveFrom || is _Nothing sfVisibleFrom
|
||||
|
||||
warnValidation MsgSheetWarnNoActiveTo $ is _Just sfActiveTo || is _Nothing sfActiveFrom
|
||||
|
||||
correctorForm :: Loads -> AForm Handler Loads
|
||||
correctorForm loads' = wFormToAForm $ do
|
||||
currentRoute <- fromMaybe (error "correctorForm called from 404-handler") <$> liftHandler getCurrentRoute
|
||||
userId <- liftHandler requireAuthId
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
|
||||
let
|
||||
loads :: Map (Either UserEmail UserId) (CorrectorState, Load)
|
||||
loads = loads' <&> \(InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector) -> (cState, load)
|
||||
|
||||
countTutRes <- wpopt checkBoxField (fslI MsgCountTutProp & setTooltip MsgCountTutPropTip) . Just . any (\(_, Load{..}) -> fromMaybe False byTutorial) $ Map.elems loads
|
||||
|
||||
|
||||
let
|
||||
previousCorrectors :: E.SqlQuery (E.SqlExpr (Entity User))
|
||||
previousCorrectors = E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> do
|
||||
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
|
||||
E.orderBy $ [E.asc $ user E.^. UserSurname, E.asc $ user E.^. UserDisplayName]
|
||||
return user
|
||||
|
||||
miAdd :: ListPosition
|
||||
-> Natural
|
||||
-> (Text -> Text)
|
||||
-> FieldView UniWorX
|
||||
-> Maybe (Form (Map ListPosition (Either UserEmail UserId) -> FormResult (Map ListPosition (Either UserEmail UserId))))
|
||||
miAdd _ _ nudge submitView = Just $ \csrf -> do
|
||||
(addRes, addView) <- mpreq (multiUserInvitationField . MUILookupAnyUser $ Just previousCorrectors) (fslpI MsgCorrector (mr MsgLdapIdentificationOrEmail) & setTooltip MsgMultiEmailFieldTip & addName (nudge "corrector")) Nothing
|
||||
let addRes' = addRes <&> \nCorrs oldData@(maybe 0 (succ . fst) . Map.lookupMax -> kStart) -> if
|
||||
| existing <- Set.intersection nCorrs . Set.fromList $ Map.elems oldData
|
||||
, not $ null existing
|
||||
-> FormFailure [mr MsgCorrectorExists]
|
||||
| otherwise
|
||||
-> FormSuccess . Map.fromList . zip [kStart..] $ Set.toList nCorrs
|
||||
return (addRes', $(widgetFile "sheetCorrectors/add"))
|
||||
|
||||
miCell :: ListPosition
|
||||
-> Either UserEmail UserId
|
||||
-> Maybe (CorrectorState, Load)
|
||||
-> (Text -> Text)
|
||||
-> Form (CorrectorState, Load)
|
||||
miCell _ userIdent initRes nudge csrf = do
|
||||
(stateRes, stateView) <- mreq (selectField optionsFinite) (fslI MsgSheetCorrectorState & addName (nudge "state")) $ (fst <$> initRes) <|> Just CorrectorNormal
|
||||
(byTutRes, byTutView) <- mreq checkBoxField ("" & addName (nudge "bytut")) $ (isJust . byTutorial . snd <$> initRes) <|> Just False
|
||||
(propRes, propView) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fslI MsgSheetCorrectorProportion & addName (nudge "prop")) $ (byProportion . snd <$> initRes) <|> Just 0
|
||||
let
|
||||
res :: FormResult (CorrectorState, Load)
|
||||
res = (,) <$> stateRes <*> (Load <$> tutRes' <*> propRes)
|
||||
tutRes'
|
||||
| FormSuccess True <- byTutRes = Just <$> countTutRes
|
||||
| otherwise = Nothing <$ byTutRes
|
||||
identWidget <- case userIdent of
|
||||
Left email -> return . toWidget $ mailtoHtml email
|
||||
Right uid -> do
|
||||
User{userEmail, userDisplayName, userSurname} <- liftHandler . runDB $ getJust uid
|
||||
return $ nameEmailWidget userEmail userDisplayName userSurname
|
||||
invWarnMsg <- messageIconI Info IconEmail MsgEmailInvitationWarning
|
||||
return (res, $(widgetFile "sheetCorrectors/cell"))
|
||||
|
||||
|
||||
miDelete :: Map ListPosition (Either UserEmail UserId)
|
||||
-> ListPosition
|
||||
-> MaybeT (MForm Handler) (Map ListPosition ListPosition)
|
||||
miDelete = miDeleteList
|
||||
|
||||
miAllowAdd :: ListPosition
|
||||
-> Natural
|
||||
-> ListLength
|
||||
-> Bool
|
||||
miAllowAdd _ _ _ = True
|
||||
|
||||
miAddEmpty :: ListPosition
|
||||
-> Natural
|
||||
-> ListLength
|
||||
-> Set ListPosition
|
||||
miAddEmpty _ _ _ = Set.empty
|
||||
|
||||
miButtonAction :: forall p.
|
||||
PathPiece p
|
||||
=> p
|
||||
-> Maybe (SomeRoute UniWorX)
|
||||
miButtonAction frag = Just . SomeRoute $ currentRoute :#: frag
|
||||
|
||||
miLayout :: ListLength
|
||||
-> Map ListPosition (Either UserEmail UserId, FormResult (CorrectorState, Load))
|
||||
-> Map ListPosition Widget
|
||||
-> Map ListPosition (FieldView UniWorX)
|
||||
-> Map (Natural, ListPosition) Widget
|
||||
-> Widget
|
||||
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "sheetCorrectors/layout")
|
||||
|
||||
miIdent :: Text
|
||||
miIdent = "correctors"
|
||||
|
||||
postProcess :: Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)) -> Loads
|
||||
postProcess = Map.fromList . map postProcess' . Map.elems
|
||||
where
|
||||
postProcess' :: (Either UserEmail UserId, (CorrectorState, Load)) -> (Either UserEmail UserId, (InvitationDBData SheetCorrector, InvitationTokenData SheetCorrector))
|
||||
postProcess' = over _2 $ \(cState, load) -> (InvDBDataSheetCorrector load cState, InvTokenDataSheetCorrector)
|
||||
|
||||
filledData :: Maybe (Map ListPosition (Either UserEmail UserId, (CorrectorState, Load)))
|
||||
filledData = Just . Map.fromList . zip [0..] $ Map.toList loads -- TODO orderBy Name?!
|
||||
|
||||
fmap postProcess <$> massInputW MassInput{..} (fslI MsgCorrectors) False filledData
|
||||
177
src/Handler/Sheet/List.hs
Normal file
177
src/Handler/Sheet/List.hs
Normal file
@ -0,0 +1,177 @@
|
||||
module Handler.Sheet.List
|
||||
( getSheetListR
|
||||
) where
|
||||
|
||||
import Import hiding (link)
|
||||
|
||||
import Utils.Sheet
|
||||
import Handler.Utils
|
||||
import Handler.Utils.SheetType
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetListR tid ssh csh = do
|
||||
muid <- maybeAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
let
|
||||
hasSFT :: (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool) -> [SheetFileType]
|
||||
hasSFT (E.Value hasExercise, E.Value hasHint, E.Value hasSolution, E.Value hasMarking)
|
||||
= [ sft | sft <- universeF
|
||||
, sft /= SheetExercise || hasExercise
|
||||
, sft /= SheetHint || hasHint
|
||||
, sft /= SheetSolution || hasSolution
|
||||
, sft /= SheetMarking || hasMarking
|
||||
]
|
||||
lastSheetEdit sheet = E.subSelectMaybe . E.from $ \sheetEdit -> do
|
||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||
return . E.max_ $ sheetEdit E.^. SheetEditTime
|
||||
|
||||
sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery ()
|
||||
sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
|
||||
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
|
||||
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
|
||||
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
|
||||
|
||||
sheetFilter :: SheetName -> DB Bool
|
||||
sheetFilter sheetName = hasReadAccessTo $ CSheetR tid ssh csh sheetName SShowR
|
||||
|
||||
sheetCol = widgetColonnade . mconcat $
|
||||
[ -- dbRow ,
|
||||
sortable (Just "name") (i18nCell MsgSheet)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) sheetName
|
||||
, sortable (Just "last-edit") (i18nCell MsgLastEdit)
|
||||
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _, _)} -> foldMap dateTimeCell mEditTime
|
||||
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom
|
||||
, sortable (toNothing "downloads") (i18nCell MsgFiles)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, existFiles)} -> listCell
|
||||
[ icnCell & addIconFixedWidth
|
||||
| let existingSFTs = hasSFT existFiles
|
||||
, sft <- [minBound..maxBound]
|
||||
, let link = CSheetR tid ssh csh sheetName $ SZipR sft
|
||||
, let icn = toWgt $ sheetFile2markup sft
|
||||
, let icnCell = if sft `elem` existingSFTs
|
||||
then linkEitherCell link (icn, [whamlet| |])
|
||||
else spacerCell
|
||||
] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
|
||||
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell sheetActiveFrom
|
||||
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> maybe mempty dateTimeCell sheetActiveTo
|
||||
, sortable Nothing (i18nCell MsgSheetType)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> i18nCell sheetType
|
||||
, sortable Nothing (i18nCell MsgSubmission)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub, _)} -> case mbSub of
|
||||
Nothing -> mempty
|
||||
(Just (Entity sid Submission{..})) ->
|
||||
let mkCid = encrypt sid -- TODO: executed twice
|
||||
mkRoute = do
|
||||
cid' <- mkCid
|
||||
return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
|
||||
in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{cid2}|])
|
||||
, sortable (Just "rating") (i18nCell MsgRating)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} ->
|
||||
let stats = sheetTypeSum sheetType in -- for statistics over all shown rows
|
||||
case mbSub of
|
||||
Nothing -> cellTell mempty $ stats Nothing
|
||||
(Just (Entity sid sub@Submission{..})) ->
|
||||
let
|
||||
mkRoute :: (MonadHandler m, HandlerSite m ~ UniWorX) => m (Route UniWorX)
|
||||
mkRoute = liftHandler $ do
|
||||
cid' <- encrypt sid
|
||||
return $ CSubmissionR tid ssh csh sheetName cid' CorrectionR
|
||||
mTuple mA mB = (,) <$> mA <*> mB -- Hamlet does not support enough haskell-syntax for this
|
||||
acell = anchorCellM mkRoute $(widgetFile "widgets/rating/rating")
|
||||
tellStats = do
|
||||
r <- mkRoute
|
||||
showRating <- hasReadAccessTo r
|
||||
tell . stats $ bool Nothing submissionRatingPoints showRating
|
||||
in acell & cellContents %~ (<* tellStats)
|
||||
|
||||
, sortable Nothing -- (Just "percent")
|
||||
(i18nCell MsgRatingPercent)
|
||||
$ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType, sheetName}, _, mbSub,_)} -> case mbSub of
|
||||
(Just (Entity sid Submission{submissionRatingPoints=Just sPoints})) ->
|
||||
case preview (_grading . _maxPoints) sType of
|
||||
Just maxPoints
|
||||
| maxPoints /= 0 -> cell $ do
|
||||
cID <- encrypt sid
|
||||
showRating <- hasReadAccessTo $ CSubmissionR tid ssh csh sheetName cID CorrectionR
|
||||
bool (return ()) (toWidget . toMessage $ textPercent sPoints maxPoints) showRating
|
||||
_other -> mempty
|
||||
_other -> mempty
|
||||
]
|
||||
|
||||
psValidator = def
|
||||
& defaultSorting [SortDescBy "submission-until", SortDescBy "submission-since"]
|
||||
& forceFilter "may-access" (Any True)
|
||||
|
||||
(raw_statistics,table) <- runDB $ dbTableWidget psValidator DBTable
|
||||
{ dbtColonnade = sheetCol
|
||||
, dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> do
|
||||
sheetData dt
|
||||
let existFiles = -- check whether files exist for given type
|
||||
( hasSheetFileQuery sheet SheetExercise
|
||||
, hasSheetFileQuery sheet SheetHint
|
||||
, hasSheetFileQuery sheet SheetSolution
|
||||
, hasSheetFileQuery sheet SheetMarking
|
||||
)
|
||||
return (sheet, lastSheetEdit sheet, submission, existFiles)
|
||||
, dbtRowKey = \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
||||
, dbtProj = return
|
||||
, dbtSorting = Map.fromList
|
||||
[ ( "name"
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
||||
)
|
||||
, ( "last-edit"
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
|
||||
)
|
||||
, ( "visible-from"
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetVisibleFrom
|
||||
)
|
||||
, ( "submission-since"
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom
|
||||
)
|
||||
, ( "submission-until"
|
||||
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
|
||||
)
|
||||
, ( "rating"
|
||||
, SortColumn $ \(_sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> submission E.?. SubmissionRatingPoints
|
||||
)
|
||||
-- GitLab Issue $143: HOW TO SORT?
|
||||
-- , ( "percent"
|
||||
-- , SortColumn $ \(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
|
||||
-- case sheetType of -- no Haskell inside Esqueleto, right?
|
||||
-- (submission E.?. SubmissionRatingPoints) E./. (sheet E.^. SheetType)
|
||||
-- )
|
||||
]
|
||||
, dbtFilter = mconcat
|
||||
[ singletonMap "may-access" . FilterProjected $ \(Any b) DBRow{..} ->
|
||||
let (Entity _ Sheet{..}, _, _, _) = dbrOutput :: (Entity Sheet, E.Value (Maybe UTCTime), Maybe (Entity Submission), (E.Value Bool, E.Value Bool, E.Value Bool, E.Value Bool))
|
||||
in (==b) <$> sheetFilter sheetName :: DB Bool
|
||||
]
|
||||
, dbtFilterUI = mempty
|
||||
, dbtStyle = def
|
||||
, dbtParams = def
|
||||
, dbtIdent = "sheets" :: Text
|
||||
, dbtCsvEncode = noCsvEncode
|
||||
, dbtCsvDecode = Nothing
|
||||
}
|
||||
-- ) ( -- !!!DEPRECTAED!!! Summary only over shown rows !!!
|
||||
-- -- Collect summary over all Sheets, not just the ones shown due to pagination:
|
||||
-- do
|
||||
-- rows <- E.select $ E.from $ \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) ->
|
||||
-- sheetData dt *> return (sheet E.^. SheetName, sheet E.^. SheetType, submission E.?. SubmissionRatingPoints)
|
||||
-- flip filterM rows (\(E.Value sheetName, _, _) -> sheetFilter sheetName)
|
||||
-- )
|
||||
|
||||
let statistics = gradeSummaryWidget MsgSheetGradingSummaryTitle raw_statistics -- only over shown rows
|
||||
-- foldMap (\(_, E.Value sheetType, E.Value mbPts) -> sheetTypeSum sheetType (join mbPts))
|
||||
defaultLayout $ do
|
||||
$(widgetFile "sheetList")
|
||||
93
src/Handler/Sheet/New.hs
Normal file
93
src/Handler/Sheet/New.hs
Normal file
@ -0,0 +1,93 @@
|
||||
module Handler.Sheet.New
|
||||
( getSheetNewR, postSheetNewR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.Time.Clock.System (systemEpochDay)
|
||||
|
||||
|
||||
import Handler.Sheet.CorrectorInvite
|
||||
import Handler.Sheet.Form
|
||||
import Handler.Sheet.Edit
|
||||
|
||||
|
||||
getSheetNewR, postSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getSheetNewR = postSheetNewR
|
||||
postSheetNewR tid ssh csh = do
|
||||
parShn <- runInputGetResult $ iopt ciField "shn"
|
||||
let searchShn sheet = case parShn of
|
||||
(FormSuccess (Just shn)) -> E.where_ $ sheet E.^. SheetName E.==. E.val shn
|
||||
_other -> return ()
|
||||
(lastSheets, loads) <- runDB $ do
|
||||
lSheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
searchShn sheet
|
||||
E.orderBy [E.desc (sheet E.^. SheetActiveFrom)]
|
||||
E.limit 1
|
||||
let firstEdit = E.subSelectMaybe . E.from $ \sheetEdit -> do
|
||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||
return . E.min_ $ sheetEdit E.^. SheetEditTime
|
||||
return (sheet, firstEdit)
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
loads <- defaultLoads cid
|
||||
return (lSheets, loads)
|
||||
now <- liftIO getCurrentTime
|
||||
let template = case lastSheets of
|
||||
((Entity {entityVal=Sheet{..}}, E.Value fEdit):_) ->
|
||||
let addTime = addWeeks $ max 1 $ weeksToAdd (fromMaybe (UTCTime systemEpochDay 0) $ sheetActiveTo <|> fEdit) now
|
||||
in Just $ SheetForm
|
||||
{ sfName = stepTextCounterCI sheetName
|
||||
, sfDescription = sheetDescription
|
||||
, sfType = sheetType
|
||||
, sfGrouping = sheetGrouping
|
||||
, sfVisibleFrom = addTime <$> sheetVisibleFrom
|
||||
, sfActiveFrom = addTime <$> sheetActiveFrom
|
||||
, sfActiveTo = addTime <$> sheetActiveTo
|
||||
, sfSubmissionMode = sheetSubmissionMode
|
||||
, sfSheetF = Nothing
|
||||
, sfHintFrom = addTime <$> sheetHintFrom
|
||||
, sfHintF = Nothing
|
||||
, sfSolutionFrom = addTime <$> sheetSolutionFrom
|
||||
, sfSolutionF = Nothing
|
||||
, sfMarkingF = Nothing
|
||||
, sfMarkingText = sheetMarkingText
|
||||
, sfAutoDistribute = sheetAutoDistribute
|
||||
, sfCorrectors = loads
|
||||
, sfAnonymousCorrection = sheetAnonymousCorrection
|
||||
}
|
||||
_other -> Nothing
|
||||
let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
|
||||
insertUnique $ newSheet
|
||||
handleSheetEdit tid ssh csh Nothing template action
|
||||
|
||||
defaultLoads :: CourseId -> DB Loads
|
||||
-- ^ Generate `Loads` in such a way that minimal editing is required
|
||||
--
|
||||
-- For every user, that ever was a corrector for this course, return their last `Load`.
|
||||
-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit).
|
||||
defaultLoads cId = do
|
||||
fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
|
||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
|
||||
let creationTime = E.subSelectMaybe . E.from $ \sheetEdit -> do
|
||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||
return . E.min_ $ sheetEdit E.^. SheetEditTime
|
||||
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cId
|
||||
|
||||
E.orderBy [E.desc creationTime]
|
||||
|
||||
return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad, sheetCorrector E.^. SheetCorrectorState)
|
||||
where
|
||||
toMap :: [(E.Value UserId, E.Value Load, E.Value CorrectorState)] -> Loads
|
||||
toMap = foldMap $ \(E.Value uid, E.Value cLoad, E.Value cState) -> Map.singleton (Right uid) (InvDBDataSheetCorrector cLoad cState, InvTokenDataSheetCorrector)
|
||||
47
src/Handler/Sheet/Pseudonym.hs
Normal file
47
src/Handler/Sheet/Pseudonym.hs
Normal file
@ -0,0 +1,47 @@
|
||||
module Handler.Sheet.Pseudonym
|
||||
( getSPseudonymR, postSPseudonymR
|
||||
, ButtonGeneratePseudonym(..)
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
import Utils.Sql
|
||||
|
||||
|
||||
data ButtonGeneratePseudonym = BtnGenerate
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
||||
instance Universe ButtonGeneratePseudonym
|
||||
instance Finite ButtonGeneratePseudonym
|
||||
|
||||
nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)
|
||||
|
||||
instance Button UniWorX ButtonGeneratePseudonym where
|
||||
btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
|
||||
btnClasses BtnGenerate = [BCIsButton, BCDefault]
|
||||
|
||||
|
||||
getSPseudonymR, postSPseudonymR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
||||
getSPseudonymR = postSPseudonymR
|
||||
postSPseudonymR tid ssh csh shn = do
|
||||
uid <- requireAuthId
|
||||
shId <- runDB $ fetchSheetId tid ssh csh shn
|
||||
let
|
||||
genPseudonym = do
|
||||
inserted <- runExceptT . mapExceptT (runDB . setSerializable) $ do
|
||||
candidate <- liftIO getRandom
|
||||
existing <- lift . getBy $ UniqueSheetPseudonymUser shId uid
|
||||
case existing of
|
||||
Just (Entity _ SheetPseudonym{sheetPseudonymPseudonym}) -> throwE sheetPseudonymPseudonym
|
||||
Nothing
|
||||
-> lift $ fmap (const candidate) <$> insertUnique (SheetPseudonym shId candidate uid)
|
||||
case inserted of
|
||||
Right Nothing -> genPseudonym
|
||||
Right (Just ps) -> return ps
|
||||
Left ps -> return ps
|
||||
ps <- genPseudonym
|
||||
selectRep $ do
|
||||
provideRep . return $ review _PseudonymText ps
|
||||
provideJson ps
|
||||
provideRep (redirect $ CSheetR tid ssh csh shn SShowR :#: ("pseudonym" :: Text) :: Handler Html)
|
||||
118
src/Handler/Sheet/Show.hs
Normal file
118
src/Handler/Sheet/Show.hs
Normal file
@ -0,0 +1,118 @@
|
||||
module Handler.Sheet.Show
|
||||
( getSShowR
|
||||
) where
|
||||
|
||||
import Import hiding (link)
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
import Handler.Sheet.Pseudonym
|
||||
|
||||
|
||||
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
||||
getSShowR tid ssh csh shn = do
|
||||
now <- liftIO getCurrentTime
|
||||
Entity sid sheet <- runDB $ fetchSheet tid ssh csh shn
|
||||
seeAllModificationTimestamps <- hasReadAccessTo $ CSheetR tid ssh csh shn SIsCorrR -- ordinary users should not see modification dates older than visibility
|
||||
|
||||
let sftVisible :: IsDBTable m a => SheetFileType -> DBCell m a
|
||||
sftVisible sft | Just dts <- sheetFileTypeDates sheet sft
|
||||
= dateTimeCellVisible now dts
|
||||
| otherwise = isVisibleCell False
|
||||
|
||||
sftModification :: IsDBTable m a => SheetFileType -> UTCTime -> DBCell m a
|
||||
sftModification sft mtime
|
||||
| seeAllModificationTimestamps = dateTimeCell mtime
|
||||
| NTop (Just mtime) > NTop (sheetFileTypeDates sheet sft) = dateTimeCell mtime
|
||||
| otherwise = mempty
|
||||
|
||||
let fileData sheetFile = do
|
||||
-- filter to requested file
|
||||
E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid
|
||||
E.&&. E.not_ (E.isNothing $ sheetFile E.^. SheetFileContent) -- don't show directories
|
||||
-- return desired columns
|
||||
return $ (sheetFile E.^. SheetFileTitle, sheetFile E.^. SheetFileModified, sheetFile E.^. SheetFileType)
|
||||
let colonnadeFiles = widgetColonnade $ mconcat
|
||||
[ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) ->
|
||||
let link = CSheetR tid ssh csh shn $ SZipR ftype in
|
||||
tellCell (Any True) $
|
||||
anchorCell link [whamlet|#{sheetFile2markup ftype} _{ftype}|]
|
||||
-- i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
|
||||
|
||||
-- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName))))
|
||||
, sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell
|
||||
(CSheetR tid ssh csh shn (SFileR fType fName))
|
||||
(str2widget fName)
|
||||
, sortable (toNothing "visible") (i18nCell MsgVisibleFrom)
|
||||
$ \(_, _ , E.Value ftype) -> sftVisible ftype
|
||||
, sortable (Just "time") (i18nCell MsgFileModified)
|
||||
$ \(_,E.Value modified, E.Value ftype) -> sftModification ftype modified
|
||||
-- , colFileModification (view _2)
|
||||
]
|
||||
let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
|
||||
& forceFilter "may-access" (Any True)
|
||||
(Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable
|
||||
{ dbtSQLQuery = fileData
|
||||
, dbtRowKey = (E.^. SheetFileId)
|
||||
, dbtColonnade = colonnadeFiles
|
||||
, dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType)
|
||||
, dbtStyle = def
|
||||
, dbtFilter = mconcat
|
||||
[ singletonMap "may-access" . FilterProjected $ \(Any b) r ->
|
||||
let (E.Value fName, _, E.Value fType) = r :: (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType)
|
||||
in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool
|
||||
]
|
||||
, dbtFilterUI = mempty
|
||||
, dbtIdent = "files" :: Text
|
||||
, dbtSorting = Map.fromList
|
||||
[ ( "type"
|
||||
, SortColumn $ \sheetFile -> E.orderByEnum $ sheetFile E.^. SheetFileType
|
||||
)
|
||||
, ( "path"
|
||||
, SortColumn $ \sheetFile -> sheetFile E.^. SheetFileTitle
|
||||
)
|
||||
-- , ( "visible"
|
||||
-- , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet
|
||||
-- )
|
||||
, ( "time"
|
||||
, SortColumn $ \sheetFile -> sheetFile E.^. SheetFileModified
|
||||
)
|
||||
]
|
||||
, dbtParams = def
|
||||
, dbtCsvEncode = noCsvEncode
|
||||
, dbtCsvDecode = Nothing
|
||||
}
|
||||
(hasHints, hasSolution) <- runDB $ do
|
||||
hasHints <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetHint ]
|
||||
hasSolution <- (/= 0) <$> count [ SheetFileSheet ==. sid, SheetFileType ==. SheetSolution ]
|
||||
return (hasHints, hasSolution)
|
||||
mPseudonym <- runMaybeT $ do
|
||||
uid <- MaybeT maybeAuthId
|
||||
Entity _ SheetPseudonym{sheetPseudonymPseudonym} <- MaybeT . runDB . getBy $ UniqueSheetPseudonymUser sid uid
|
||||
return $ review _PseudonymText sheetPseudonymPseudonym
|
||||
(generateWidget, generateEnctype) <- generateFormPost $ \csrf ->
|
||||
over _2 ((toWidget csrf <>) . fvWidget) <$> mreq (buttonField BtnGenerate) "" Nothing
|
||||
let generateForm = wrapForm generateWidget def
|
||||
{ formAction = Just . SomeRoute $ CSheetR tid ssh csh shn SPseudonymR
|
||||
, formEncoding = generateEnctype
|
||||
, formSubmit = FormNoSubmit
|
||||
}
|
||||
|
||||
defaultLayout $ do
|
||||
setTitleI $ prependCourseTitle tid ssh csh $ SomeMessage shn
|
||||
let zipLink = CSheetR tid ssh csh shn SArchiveR
|
||||
visibleFrom = visibleUTCTime SelFormatDateTime <$> sheetVisibleFrom sheet
|
||||
hasSubmission = classifySubmissionMode (sheetSubmissionMode sheet) /= SubmissionModeNone
|
||||
sheetFrom <- traverse (formatTime SelFormatDateTime) $ sheetActiveFrom sheet
|
||||
sheetTo <- traverse (formatTime SelFormatDateTime) $ sheetActiveTo sheet
|
||||
hintsFrom <- traverse (formatTime SelFormatDateTime) $ sheetHintFrom sheet
|
||||
solutionFrom <- traverse (formatTime SelFormatDateTime) $ sheetSolutionFrom sheet
|
||||
markingText <- runMaybeT $ assertM_ (Authorized ==) (evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet)
|
||||
submissionTip <- messageI Info MsgSheetCorrectorSubmissionsTip
|
||||
$(widgetFile "sheetShow")
|
||||
@ -1,7 +1,6 @@
|
||||
module Handler.Utils.Sheet where
|
||||
|
||||
import Import
|
||||
import Handler.Utils.Delete
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E
|
||||
@ -52,30 +51,3 @@ fetchSheetIdCourseId :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Ye
|
||||
fetchSheetIdCourseId tid ssh cid shn = bimap E.unValue E.unValue <$> fetchSheetAux (\sheet course -> (sheet E.^. SheetId, course E.^. CourseId)) tid ssh cid shn
|
||||
|
||||
|
||||
sheetDeleteRoute :: Set SheetId -> DeleteRoute Sheet
|
||||
sheetDeleteRoute drRecords = DeleteRoute
|
||||
{ drRecords
|
||||
, drGetInfo = \(sheet `E.InnerJoin` course `E.InnerJoin` school) -> do
|
||||
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
let submissions = E.subSelectCount . E.from $ \submission ->
|
||||
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
E.orderBy [E.asc $ sheet E.^. SheetName]
|
||||
return (submissions, sheet E.^. SheetName, course E.^. CourseShorthand, course E.^. CourseName, school E.^. SchoolShorthand, school E.^. SchoolName, course E.^. CourseTerm)
|
||||
, drUnjoin = \(sheet `E.InnerJoin` _ `E.InnerJoin` _) -> sheet
|
||||
, drRenderRecord = \(E.Value submissions, E.Value shn', _, E.Value cName, _, E.Value sName, E.Value tid') ->
|
||||
return [whamlet|
|
||||
$newline never
|
||||
#{shn'} (_{SomeMessage $ ShortTermIdentifier (unTermKey tid')}, #{sName}, #{cName})
|
||||
$if submissions /= 0
|
||||
<i>_{SomeMessage $ MsgSheetDelHasSubmissions submissions}
|
||||
|]
|
||||
, drRecordConfirmString = \(E.Value submissions, E.Value shn', E.Value csh', _, E.Value ssh', _, E.Value tid') ->
|
||||
return $ [st|#{termToText (unTermKey tid')}/#{ssh'}/#{csh'}/#{shn'}|] <> bool mempty [st| + #{tshow submissions} Subs|] (submissions /= 0)
|
||||
, drCaption = SomeMessage MsgSheetDeleteQuestion
|
||||
, drSuccessMessage = SomeMessage MsgSheetDeleted
|
||||
, drFormMessage = const $ return Nothing
|
||||
, drAbort = error "drAbort undefined"
|
||||
, drSuccess = error "drSuccess undefined"
|
||||
, drDelete = const id -- TODO: audit
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user