fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Sheet List Convenience like in UniWorX

Browse Source
This commit is contained in:
Steffen Jost 2019-05-10 11:25:43 +02:00
parent df2df21bf4
commit 86f10ae1ba
10 changed files with 176 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
messages/uniworx/de.msg
View File

@ -410,6 +410,7 @@ RatingPointsDone: Abgabe zählt als korrigiert, gdw. Punktezahl gesetzt ist
ColumnRatingPoints: Punktzahl
Pseudonyms: Pseudonyme
Files: Dateien
FileTitle: Dateiname
FileModified: Letzte Änderung
VisibleFrom: Veröffentlicht

1
routes
View File

@ -114,6 +114,7 @@
/pseudonym SPseudonymR GET POST !course-registeredANDcorrector-submissions
/corrector-invite/ SCorrInviteR GET POST
!/#SheetFileType/*FilePath SFileR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
!/#{ZIPArchiveName SheetFileType} SZipR GET !timeANDcourse-registered !timeANDmaterials !corrector !timeANDtutor
/file MaterialListR GET !course-registered !materials !corrector !tutor
/file/new MaterialNewR GET POST
/file/#MaterialName MaterialR:

15
src/Foundation.hs
View File

@ -671,10 +671,17 @@ tagAccessPredicate AuthTime = APDB $ \mAuthId route _ -> case route of
guard visible
case subRoute of
SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime
SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
SFileR _ _ -> mzero
-- Single Files
SFileR SheetExercise _ -> guard $ sheetActiveFrom <= cTime
SFileR SheetHint _ -> guard $ maybe False (<= cTime) sheetHintFrom
SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
SFileR _ _ -> mzero
-- Archives of SheetFileType
SZipR (ZIPArchiveName SheetExercise) -> guard $ sheetActiveFrom <= cTime
SZipR (ZIPArchiveName SheetHint ) -> guard $ maybe False (<= cTime) sheetHintFrom
SZipR (ZIPArchiveName SheetSolution) -> guard $ maybe False (<= cTime) sheetSolutionFrom
SZipR _ -> mzero
-- Submissions
SubmissionNewR -> guard active
SubmissionR _ SAssignR -> guard marking -- Correctors can only be assigned when the Sheet is inactive, since submissions are subject to change
SubmissionR _ _ -> guard active

3
src/Handler/Material.hs
View File

@ -362,6 +362,5 @@ getMArchiveR tid ssh csh mnm = do
E.on $ materialFile E.^. MaterialFileFile E.==. file E.^. FileId
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. E.val mid
return file
fileSource' = fileSelect .| C.map entityVal
zipComment = Text.encodeUtf8 $ termToText (unTermKey tid) <> "-" <> toPathPiece (unSchoolKey ssh <> "-" <> csh <> ":" <> mnm)
fileSource' .| produceZip ZipInfo{..} .| C.map toFlushBuilder
fileSelect .| C.map entityVal .| produceZip ZipInfo{..} .| C.map toFlushBuilder

75
src/Handler/Sheet.hs
View File

@ -163,6 +163,14 @@ getSheetListR tid ssh csh = do
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 <- [minBound..maxBound]
, sft /= SheetExercise || hasExercise
, sft /= SheetHint || hasHint
, sft /= SheetSolution || hasSolution
, sft /= SheetMarking || hasMarking
]
lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
return . E.max_ $ sheetEdit E.^. SheetEditTime
@ -178,21 +186,27 @@ getSheetListR tid ssh csh = do
sheetFilter sheetName = (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh sheetName SShowR) False
sheetCol = widgetColonnade . mconcat $
[ dbRow
, sortable (Just "name") (i18nCell MsgSheet)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
[ -- dbRow ,
sortable (Just "name") (i18nCell MsgSheet)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
, sortable (Just "last-edit") (i18nCell MsgLastEdit)
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _)} -> foldMap dateTimeCell mEditTime
$ \DBRow{dbrOutput=(_, E.Value mEditTime, _, _)} -> foldMap dateTimeCell mEditTime
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> foldMap (dateTimeCellVisible now) sheetVisibleFrom
, sortable (toNothing "downloads") (i18nCell MsgFiles)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, existFiles)} -> mconcat
[ linkEmptyCell link icn | sft <- hasSFT existFiles
, let link = CSheetR tid ssh csh sheetName $ SZipR $ ZIPArchiveName sft
, let icn = toWidget $ sheetFile2markup sft
]
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> dateTimeCell sheetActiveFrom
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> dateTimeCell sheetActiveFrom
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> dateTimeCell sheetActiveTo
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> dateTimeCell sheetActiveTo
, sortable Nothing (i18nCell MsgSheetType)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> i18nCell sheetType
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _, _)} -> i18nCell sheetType
, sortable Nothing (i18nCell MsgSubmission)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} -> case mbSub of
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub, _)} -> case mbSub of
Nothing -> mempty
(Just (Entity sid Submission{..})) ->
let mkCid = encrypt sid -- TODO: executed twice
@ -201,7 +215,7 @@ getSheetListR tid ssh csh = do
return $ CSubmissionR tid ssh csh sheetName cid' SubShowR
in anchorCellM mkRoute (mkCid >>= \cid2 -> [whamlet|#{display cid2}|])
, sortable (Just "rating") (i18nCell MsgRating)
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub)} ->
$ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, mbSub,_)} ->
let stats = sheetTypeSum sheetType in -- for statistics over all shown rows
case mbSub of
Nothing -> cellTell mempty $ stats Nothing
@ -216,7 +230,7 @@ getSheetListR tid ssh csh = do
, sortable Nothing -- (Just "percent")
(i18nCell MsgRatingPercent)
$ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub)} -> case mbSub of
$ \DBRow{dbrOutput=(Entity _ Sheet{sheetType=sType}, _, mbSub,_)} -> case mbSub of
(Just (Entity _ Submission{submissionRatingPoints=Just sPoints})) ->
case preview (_grading . _maxPoints) sType of
Just maxPoints
@ -228,14 +242,21 @@ getSheetListR tid ssh csh = do
]
psValidator = def
& defaultSorting [SortDescBy "submission-since"]
& defaultSorting [SortDescBy "submission-until", SortDescBy "submission-since"]
(raw_statistics,table) <- runDB $ dbTableWidget psValidator DBTable
{ dbtColonnade = sheetCol
, dbtSQLQuery = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser))
-> sheetData dt *> return (sheet, lastSheetEdit sheet, submission)
, 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 = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _) }
, dbtProj = \dbr@DBRow{ dbrOutput=(Entity _ Sheet{..}, _, _, _) }
-> dbr <$ guardM (lift $ sheetFilter sheetName)
, dbtSorting = Map.fromList
[ ( "name"
@ -412,24 +433,12 @@ postSPseudonymR tid ssh csh shn = do
getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent
getSFileR tid ssh csh shn typ title = serveOneFile fileQuery
where
fileQuery = E.select $ E.from $
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFile)
E.on (sheetFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
-- filter to requested file
E.where_ ((file E.^. FileTitle E.==. E.val title)
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
E.&&. (sheet E.^. SheetName E.==. E.val shn )
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
E.&&. (course E.^. CourseSchool E.==. E.val ssh )
E.&&. (course E.^. CourseTerm E.==. E.val tid )
)
-- return file entity
return file
getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file
getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> ZIPArchiveName SheetFileType -> Handler TypedContent
getSZipR tid ssh csh shn filename@(ZIPArchiveName sft)
= serveSomeFiles (toPathPiece filename) $ sheetFilesAllQuery tid ssh csh shn sft
getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetNewR tid ssh csh = do

22
src/Handler/Utils.hs
View File

@ -7,10 +7,12 @@ import Import
import Utils.Lens
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
-- import qualified Data.Set (Set)
import qualified Data.Set as Set
import Data.CaseInsensitive (original)
-- import qualified Data.CaseInsensitive as CI
import qualified Data.Conduit.List as Conduit
import Language.Haskell.TH
import Language.Haskell.TH.Syntax (qRunIO)
@ -63,6 +65,26 @@ serveOneFile query = do
$logErrorS "SFileR" $ "Multiple matching files: " <> tshow other
error "Multiple matching files found."
-- | Serve one file directly or a zip-archive of files, identified through a given DB query
-- Like `serveOneFile`, but sends a zip-archive if multiple results are returned
serveSomeFiles :: Text -> DB [Entity File] -> Handler TypedContent
serveSomeFiles archiveName query = do
results <- runDB query
case results of
[] -> notFound
[Entity _fileId File{fileTitle, fileContent}]
| Just fileContent' <- fileContent -> do
whenM downloadFiles $
addHeader "Content-Disposition" [st|attachment; filename="#{takeFileName fileTitle}"|]
return $ TypedContent (defaultMimeLookup (pack fileTitle) <> "; charset=utf-8") (toContent fileContent')
| otherwise -> sendResponseStatus noContent204 ()
files -> do
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece archiveName}"|]
respondSourceDB "application/zip" $ do
let zipComment = T.encodeUtf8 archiveName
yieldMany files .| Conduit.map entityVal .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
tidFromText :: Text -> Maybe TermId
tidFromText = fmap TermKey . maybeRight . termFromText

21
src/Handler/Utils/Table/Pagination.hs
View File

@ -23,6 +23,7 @@ module Handler.Utils.Table.Pagination
, widgetColonnade, formColonnade, dbColonnade
, cell, textCell, stringCell, i18nCell
, anchorCell, anchorCell', anchorCellM, anchorCellM'
, linkEmptyCell, linkEmptyCellM, linkEmptyCellM'
, cellTooltip
, listCell
, formCell, DBFormResult, getDBFormResult
@ -863,6 +864,8 @@ cellTooltip msg = cellContents.mapped %~ (<> tipWdgt)
<div .tooltip__content>_{msg}
|]
-- | Always display widget; maybe a link if user is Authorized.
-- Also see variant `linkEmptyCell`
anchorCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
anchorCell = anchorCellM . return
@ -886,6 +889,24 @@ anchorCellM' xM x2route x2widget = cell $ do
Authorized -> $(widgetFile "table/cell/link") -- show allowed link
_otherwise -> widget -- don't show prohibited link
-- | Variant of `anchorCell` that returns `mempty` for unauthorized links
linkEmptyCell :: IsDBTable m a => Route UniWorX -> Widget -> DBCell m a
linkEmptyCell = linkEmptyCellM . return
linkEmptyCellM :: IsDBTable m a => WidgetT UniWorX IO (Route UniWorX) -> Widget -> DBCell m a
linkEmptyCellM routeM widget = linkEmptyCellM' routeM id (const widget)
linkEmptyCellM' :: IsDBTable m a => WidgetT UniWorX IO x -> (x -> Route UniWorX) -> (x -> Widget) -> DBCell m a
linkEmptyCellM' xM x2route x2widget = cell $ do
x <- xM
let route = x2route x
widget = x2widget x
authResult <- liftHandlerT $ isAuthorized route False
case authResult of
Authorized -> $(widgetFile "table/cell/link") -- show allowed link
_otherwise -> mempty -- don't show anything for prohibited links
listCell :: (IsDBTable m a, Traversable f) => f r' -> (r' -> DBCell m a) -> DBCell m a
listCell xs mkCell = review dbCell . ([], ) $ do

7
src/Model/Types.hs
View File

@ -42,6 +42,7 @@ import Database.Persist.Sql
import Web.HttpApiData
import Web.PathPieces
import Text.Blaze (Markup)
import Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Lens as Text
@ -250,6 +251,12 @@ instance PathPiece SheetFileType where
toPathPiece SheetMarking = "marking"
fromPathPiece = finiteFromPathPiece
sheetFile2markup :: SheetFileType -> Markup
sheetFile2markup SheetExercise = iconQuestion
sheetFile2markup SheetHint = iconHint
sheetFile2markup SheetSolution = iconSolution
sheetFile2markup SheetMarking = iconMarking
-- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
display SheetExercise = "Aufgabenstellung"

28
src/Utils.hs
View File

@ -123,6 +123,29 @@ type WidgetSiteless = forall site. forall m. (MonadIO m, MonadThrow m, MonadBase
-- Icons --
-----------
-- We collect all used icons here for an overview.
-- For consistency, some conditional icons are also provided, e.g. `isIvisble`
iconQuestion :: Markup
iconQuestion = [shamlet|<i .fas .fa-question-circle>|]
iconHint :: Markup
iconHint = [shamlet|<i .fas .fa-life-ring>|]
iconSolution :: Markup
iconSolution = [shamlet|<i .fas .fa-exclamation-circle>|]
iconMarking :: Markup
iconMarking = [shamlet|<i .fas .fa-check-circle>|]
fileDownload :: Markup
fileDownload = [shamlet|<i .fas .fa-file-download>|]
zipDownload :: Markup
zipDownload = [shamlet|<i .fas .fa-file-archive>|]
-- Conditional icons
isVisible :: Bool -> Markup
-- ^ Display an icon that denotes that something™ is visible or invisible
isVisible True = [shamlet|<i .fas .fa-eye>|]
@ -163,11 +186,6 @@ boolSymbol :: Bool -> Markup
boolSymbol True = [shamlet|<i .fas .fa-check>|]
boolSymbol False = [shamlet|<i .fas .fa-times>|]
fileDownload :: Markup
fileDownload = [shamlet|<i .fas .fa-file-download>|]
zipDownload :: Markup
zipDownload = [shamlet|<i .fas .fa-file-archive>|]
---------------------

47
src/Utils/Sheet.hs
View File

@ -3,6 +3,7 @@ module Utils.Sheet where
import Import.NoFoundation
import qualified Database.Esqueleto as E
import Database.Esqueleto.Internal.Language (From) -- How to avoid this import?
-- DB Queries for Sheets that are used in several places
@ -44,3 +45,49 @@ sheetOldUnassigned tid ssh csh = do
[] -> Nothing
[E.Value shn] -> Just shn
_ -> error "SQL Query with limit 1 returned more than one result"
-- | Return a specfic file from a `Sheet`
sheetFileQuery :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> SqlReadT m [Entity File]
sheetFileQuery tid ssh csh shn sft title = E.select $ E.from $
\(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile)
E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
-- filter to requested file
E.where_ ((file E.^. FileTitle E.==. E.val title)
E.&&. (sFile E.^. SheetFileType E.==. E.val sft )
E.&&. (sheet E.^. SheetName E.==. E.val shn )
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
E.&&. (course E.^. CourseSchool E.==. E.val ssh )
E.&&. (course E.^. CourseTerm E.==. E.val tid )
)
-- return file entity
return file
-- | Return all files of a certain `SheetFileType` for a `Sheet`
sheetFilesAllQuery :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> SqlReadT m [Entity File]
sheetFilesAllQuery tid ssh csh shn sft = E.select $ E.from $
\(course `E.InnerJoin` sheet `E.InnerJoin` sFile `E.InnerJoin` file) -> do
-- Restrict to consistent rows that correspond to each other
E.on (file E.^. FileId E.==. sFile E.^. SheetFileFile)
E.on (sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
E.on (sheet E.^. SheetCourse E.==. course E.^. CourseId)
-- filter to requested file
E.where_ ((sFile E.^. SheetFileType E.==. E.val sft )
E.&&. (sheet E.^. SheetName E.==. E.val shn )
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
E.&&. (course E.^. CourseSchool E.==. E.val ssh )
E.&&. (course E.^. CourseTerm E.==. E.val tid )
)
-- return file entity
return file
-- | Check whether a sheet has any files for a given file type
hasSheetFileQuery :: Database.Esqueleto.Internal.Language.From query expr backend (expr (Entity SheetFile))
-- hasSheetFileQuery :: (E.Esqueleto query expr backend)
=> expr (Entity Sheet) -> SheetFileType -> expr (E.Value Bool)
hasSheetFileQuery sheet sft =
E.exists $ E.from $ \sFile ->
E.where_ ((sFile E.^. SheetFileSheet E.==. sheet E.^. SheetId)
E.&&. (sFile E.^. SheetFileType E.==. E.val sft ))