119 lines
5.7 KiB
Haskell
119 lines
5.7 KiB
Haskell
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")
|