168 lines
9.5 KiB
Haskell
168 lines
9.5 KiB
Haskell
module Handler.Sheet.Show
|
|
( getSShowR
|
|
) where
|
|
|
|
import Import hiding (link)
|
|
|
|
import Handler.Utils
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Data.Map as Map
|
|
|
|
import Handler.Sheet.Pseudonym
|
|
import Utils.Sheet
|
|
|
|
|
|
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
|
|
getSShowR tid ssh csh shn = do
|
|
now <- liftIO getCurrentTime
|
|
muid <- maybeAuthId
|
|
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 `E.FullOuterJoin` psFile) = do
|
|
E.on $ sheetFile E.?. SheetFileTitle E.==. psFile E.?. PersonalisedSheetFileTitle
|
|
E.&&. sheetFile E.?. SheetFileType E.==. psFile E.?. PersonalisedSheetFileType
|
|
E.&&. sheetFile E.?. SheetFileSheet E.==. psFile E.?. PersonalisedSheetFileSheet
|
|
E.&&. psFile E.?. PersonalisedSheetFileUser E.==. E.val muid
|
|
-- filter to requested file
|
|
E.where_ $ (sheetFile E.?. SheetFileSheet E.==. E.justVal sid E.||. psFile E.?. PersonalisedSheetFileSheet E.==. E.justVal sid)
|
|
E.&&. E.maybe (E.isJust . E.joinV $ sheetFile E.?. SheetFileContent) E.isJust (psFile E.?. PersonalisedSheetFileContent) -- don't show directories
|
|
E.&&. E.maybe E.true (\psfUser -> E.just psfUser E.==. E.val muid) (psFile E.?. PersonalisedSheetFileUser)
|
|
-- return desired columns
|
|
return ( E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileTitle, sheetFile E.?. SheetFileTitle]
|
|
, E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileModified, sheetFile E.?. SheetFileModified]
|
|
, E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileType, sheetFile E.?. SheetFileType]
|
|
, E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileContent, sheetFile E.?. SheetFileContent]
|
|
)
|
|
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 MsgTableFileTitle) $ \(E.Value fName, _, E.Value fType, _) -> anchorCell
|
|
(CSheetR tid ssh csh shn $ SFileR fType fName)
|
|
(str2widget fName)
|
|
, sortable (toNothing "visible") (i18nCell MsgSheetVisibleFrom)
|
|
$ \(_, _ , E.Value ftype, _) -> sftVisible ftype
|
|
, sortable (Just "time") (i18nCell MsgTableFileModified)
|
|
$ \(_,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 = \(sheetFile `E.FullOuterJoin` psFile) -> (sheetFile E.?. SheetFileId, psFile E.?. PersonalisedSheetFileId)
|
|
, dbtColonnade = colonnadeFiles
|
|
, dbtProj = (dbrOutput :: _ -> (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType, E.Value (Maybe FileContentReference))) <$> dbtProjFilteredPostId
|
|
, dbtStyle = def
|
|
, dbtFilter = mconcat
|
|
[ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) DBRow{ dbrOutput = (E.Value fName, _ :: E.Value UTCTime, E.Value fType, _ :: E.Value (Maybe FileContentReference)) } ->
|
|
(==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool
|
|
]
|
|
, dbtFilterUI = mempty
|
|
, dbtIdent = "files" :: Text
|
|
, dbtSorting = Map.fromList
|
|
[ ( "type"
|
|
, SortColumn $ \(sheetFile `E.FullOuterJoin` psFile) -> E.orderByEnum $ E.unsafeCoalesce [sheetFile E.?. SheetFileType, psFile E.?. PersonalisedSheetFileType]
|
|
)
|
|
, ( "path"
|
|
, SortColumn $ \(sheetFile `E.FullOuterJoin` psFile) -> E.unsafeCoalesce [sheetFile E.?. SheetFileTitle, psFile E.?. PersonalisedSheetFileTitle]
|
|
)
|
|
-- , ( "visible"
|
|
-- , SortColumn $ \(sheetFile `E.InnerJoin` _file) -> sheetFileTypeDates sheet $ sheetFile E.^. SheetFileType -- not possible without another join for the sheet
|
|
-- )
|
|
, ( "time"
|
|
, SortColumn $ \(sheetFile `E.FullOuterJoin` psFile) -> E.unsafeCoalesce [sheetFile E.?. SheetFileModified, psFile E.?. PersonalisedSheetFileModified]
|
|
)
|
|
]
|
|
, dbtParams = def
|
|
, dbtCsvEncode = noCsvEncode
|
|
, dbtCsvDecode = Nothing
|
|
, dbtExtraReps = []
|
|
}
|
|
(hasHints, hasSolution) <- runDB $ do
|
|
hasHints <- E.selectExists . E.from $ \sheet' ->
|
|
E.where_ $ hasSheetFileQuery sheet' (E.val muid) SheetHint
|
|
E.&&. sheet' E.^. SheetId E.==. E.val sid
|
|
hasSolution <- E.selectExists . E.from $ \sheet' ->
|
|
E.where_ $ hasSheetFileQuery sheet' (E.val muid) SheetSolution
|
|
E.&&. sheet' E.^. SheetId E.==. E.val sid
|
|
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
|
|
}
|
|
checkExamRegistration <- orM
|
|
[ wouldHaveWriteAccessToIff [(AuthExamRegistered, True)] $ CSheetR tid ssh csh shn SubmissionNewR
|
|
, wouldHaveReadAccessToIff [(AuthExamRegistered, True)] $ CSheetR tid ssh csh shn SArchiveR
|
|
]
|
|
mRequiredExam <- fmap join . for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> fmap (fmap $(E.unValueN 4)) . runDB . E.selectMaybe . E.from $ \(exam `E.InnerJoin` course) -> do
|
|
E.on $ exam E.^. ExamCourse E.==. course E.^. CourseId
|
|
E.where_ $ exam E.^. ExamId E.==. E.val eId
|
|
return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, exam E.^. ExamName)
|
|
mRequiredExamLink <- runMaybeT $ do
|
|
(etid, essh, ecsh, examn) <- hoistMaybe mRequiredExam
|
|
let eUrl = CExamR etid essh ecsh examn EShowR
|
|
guardM . lift $ hasReadAccessTo eUrl
|
|
return eUrl
|
|
mMissingExamRegistration <- for (guardOnM checkExamRegistration $ sheetRequireExamRegistration sheet) $ \eId -> maybeT (return True) $ do
|
|
uid <- MaybeT maybeAuthId
|
|
lift . fmap not . runDB $ exists [ ExamRegistrationExam ==. eId, ExamRegistrationUser ==. uid ]
|
|
|
|
checkPersonalisedFiles <- andM
|
|
[ return . not $ sheetAllowNonPersonalisedSubmission sheet
|
|
, return $ NTop (sheetActiveFrom sheet) <= NTop (Just now), return $ NTop (Just now) <= NTop (sheetActiveTo sheet)
|
|
, wouldHaveWriteAccessToIff [(AuthPersonalisedSheetFiles, True)] $ CSheetR tid ssh csh shn SubmissionNewR
|
|
]
|
|
mMissingPersonalisedFiles <- for (guardOnM checkPersonalisedFiles muid) $ \uid -> runDB $
|
|
fmap not . E.selectExists . E.from $ \psFile ->
|
|
E.where_ $ psFile E.^. PersonalisedSheetFileUser E.==. E.val uid
|
|
E.&&. psFile E.^. PersonalisedSheetFileSheet E.==. E.val sid
|
|
|
|
submissionModeNoneWithoutNotGradedWarning <- runMaybeT $ do
|
|
guard $ classifySubmissionMode (sheetSubmissionMode sheet) == SubmissionModeNone
|
|
&& sheetType sheet /= NotGraded
|
|
guardM . lift . hasWriteAccessTo $ CSheetR tid ssh csh shn SEditR
|
|
return $ notification NotificationBroad =<< messageI Warning MsgSheetSubmissionModeNoneWithoutNotGraded
|
|
|
|
sTypeDesc <- runDB $ sheetTypeDescription (sheetCourse sheet) (sheetType sheet)
|
|
|
|
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 ==) (lift $ evalAccessCorrector tid ssh csh) >> hoistMaybe (sheetMarkingText sheet)
|
|
submissionTip <- messageI Info MsgSheetCorrectorSubmissionsTip
|
|
tr <- getTranslate
|
|
$(widgetFile "sheetShow")
|