From 86f10ae1bac8d8a45cb1e5fa1062c7cc42024a58 Mon Sep 17 00:00:00 2001 From: Steffen Jost Date: Fri, 10 May 2019 11:25:43 +0200 Subject: [PATCH] Sheet List Convenience like in UniWorX --- messages/uniworx/de.msg | 1 + routes | 1 + src/Foundation.hs | 15 ++++-- src/Handler/Material.hs | 3 +- src/Handler/Sheet.hs | 75 +++++++++++++++------------ src/Handler/Utils.hs | 22 ++++++++ src/Handler/Utils/Table/Pagination.hs | 21 ++++++++ src/Model/Types.hs | 7 +++ src/Utils.hs | 28 ++++++++-- src/Utils/Sheet.hs | 47 +++++++++++++++++ 10 files changed, 176 insertions(+), 44 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index ed32f7571..f6de18a46 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -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 diff --git a/routes b/routes index 0844f047a..42f6c5934 100644 --- a/routes +++ b/routes @@ -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: diff --git a/src/Foundation.hs b/src/Foundation.hs index 8b97c9317..e6202d49a 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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 diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 54a130c79..f97743157 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 97ce8b441..a87a70d70 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index f5a7be596..b98ca50ff 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -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 diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 65716bc11..5fe533e21 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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)
_{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 diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 1086b40ec..aa1c91037 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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" diff --git a/src/Utils.hs b/src/Utils.hs index 619fdaa81..c45171ed5 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -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||] + +iconHint :: Markup +iconHint = [shamlet||] + +iconSolution :: Markup +iconSolution = [shamlet||] + +iconMarking :: Markup +iconMarking = [shamlet||] + +fileDownload :: Markup +fileDownload = [shamlet||] + +zipDownload :: Markup +zipDownload = [shamlet||] + +-- Conditional icons + isVisible :: Bool -> Markup -- ^ Display an icon that denotes that something™ is visible or invisible isVisible True = [shamlet||] @@ -163,11 +186,6 @@ boolSymbol :: Bool -> Markup boolSymbol True = [shamlet||] boolSymbol False = [shamlet||] -fileDownload :: Markup -fileDownload = [shamlet||] - -zipDownload :: Markup -zipDownload = [shamlet||] --------------------- diff --git a/src/Utils/Sheet.hs b/src/Utils/Sheet.hs index 595c0729e..241947549 100644 --- a/src/Utils/Sheet.hs +++ b/src/Utils/Sheet.hs @@ -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 )) \ No newline at end of file