Sheet List Convenience like in UniWorX

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

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:

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
+      -- Single Files
-      SFileR SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
+      SFileR                SheetExercise _ -> guard $ sheetActiveFrom <= cTime
-      SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
+      SFileR                SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
-      SFileR _             _ -> mzero
+      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

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

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
+      [ -- dbRow ,
-      , sortable (Just "name") (i18nCell MsgSheet)
+        sortable (Just "name") (i18nCell MsgSheet)
-          $ \DBRow{dbrOutput=(Entity _ Sheet{..}, _, _)} -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
+          $ \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))
+      , dbtSQLQuery  = \dt@(sheet `E.LeftOuterJoin` (submission `E.InnerJoin` _submissionUser)) -> do
-                          -> sheetData dt *> return (sheet, lastSheetEdit sheet, submission)
+                          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
+getSFileR tid ssh csh shn sft file = serveOneFile $ sheetFileQuery tid ssh csh shn sft file
-  where
+
-    fileQuery = E.select $ E.from $
+getSZipR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> ZIPArchiveName SheetFileType -> Handler TypedContent
-       \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
+getSZipR tid ssh csh shn filename@(ZIPArchiveName sft)
-        -- Restrict to consistent rows that correspond to each other
+  = serveSomeFiles (toPathPiece filename) $ sheetFilesAllQuery tid ssh csh shn sft
-        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
 
 getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getSheetNewR tid ssh csh = do

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
 

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)
           <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

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"

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|<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>|]
 
 
 ---------------------

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  ))