Download Link für Material-Archive

routes

@@ -121,6 +121,8 @@
     /delete                     MDelR          GET POST
     /show                       MShowR         GET             !timeANDcourse-registered !timeANDmaterials !corrector !tutor
     /load/*FilePath             MFileR         GET             !timeANDcourse-registered !timeANDmaterials !corrector !tutor
+    -- Besser wäre #{ZIPArchiveName MaterialName} auf höherer Ebene
+    /zip                        MArchiveR      GET             !timeANDcourse-registered !timeANDmaterials !corrector !tutor
   /tuts                         CTutorialListR GET             !tutor
   /tuts/new                     CTutorialNewR  GET POST
   /tuts/#TutorialName TutorialR:

src/Handler/Material.hs

@@ -9,6 +9,7 @@ import qualified Data.Set as Set
 import qualified Data.Map as Map
 import qualified Data.Conduit.List as C
 -- import qualified Data.CaseInsensitive as CI
+import qualified Data.Text.Encoding as Text
 
 import qualified Database.Esqueleto as E
 import Database.Esqueleto.Utils.TH
@@ -23,8 +24,6 @@ import Handler.Utils.Table.Columns
 import Control.Monad.Writer (MonadWriter(..), execWriterT)
 
 
-
-
 data MaterialForm = MaterialForm
       { mfName         :: MaterialName
       , mfType         :: Maybe Text
@@ -72,6 +71,11 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
       <*> aopt (multiFileField oldFileIds)
                               (fslI MsgMaterialFiles)        (mfFiles <$> template)
 
+getMaterialKeyBy404 :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Key Material)
+getMaterialKeyBy404 tid ssh csh mnm = do
+  cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
+  getKeyBy404 $  UniqueMaterial cid mnm
+
 fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material)
 fetchMaterial tid ssh csh mnm = do
   [matEnt] <- E.select . E.from  $ -- uniqueness guaranteed by DB constraints
@@ -90,6 +94,9 @@ getMaterialListR tid ssh csh = do
   let matLink :: MaterialName -> Route UniWorX
       matLink = CourseR tid ssh csh . flip MaterialR MShowR
 
+      zipLink :: MaterialName -> Route UniWorX
+      zipLink = CourseR tid ssh csh . flip MaterialR MArchiveR
+
       materialModDateCell :: IsDBTable m a => Material -> DBCell m a
       materialModDateCell Material{materialVisibleFrom, materialLastEdit}
         | NTop materialVisibleFrom >= NTop (Just materialLastEdit)
@@ -113,13 +120,15 @@ getMaterialListR tid ssh csh = do
       -- , dbtProj      = \dbr -> guardAuthorizedFor (matLink . materialName $ dbr ^. _dbrOutput . _entityVal) dbr
       , dbtProj      = guardAuthorizedFor =<< matLink . materialName . row2material -- Moand: (a ->)
       , dbtColonnade = widgetColonnade $ mconcat
-            [ dbRow
+            [ -- dbRow,
-            , sortable (Just "type") (i18nCell MsgMaterialType)
+              sortable (Just "type") (i18nCell MsgMaterialType)
                 $ foldMap textCell . materialType . row2material
             , sortable (Just "name") (i18nCell MsgMaterialName)
                 $ liftA2 anchorCell matLink toWgt . materialName . row2material
             , sortable (toNothingS "description") mempty
                 $ foldMap modalCell . materialDescription . row2material
+            , sortable (toNothingS "zip-archive") mempty
+                $ zipCell . zipLink . materialName . row2material
             , sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
                 $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material
             , sortable (Just "last-edit") (i18nCell MsgFileModified)
@@ -337,3 +346,19 @@ postMDelR tid ssh csh mnm = do
     , drSuccess = SomeRoute $ CourseR tid ssh csh   MaterialListR
     , drAbort   = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR
     }
+
+getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent
+getMArchiveR tid ssh csh mnm = do
+  let filename = ZIPArchiveName mnm
+  addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece filename}"|]
+  respondSourceDB "application/zip" $ do
+    mid <- lift $ getMaterialKeyBy404 tid ssh csh mnm
+    -- Entity{entityKey=mid, entityVal=material} <- lift $ fetchMaterial tid ssh csh mnm
+    let
+      fileSelect = E.selectSource . E.from $ \(materialFile `E.InnerJoin` file) -> 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

src/Handler/Utils/Table/Cells.hs

@@ -87,12 +87,21 @@ commentCell Nothing     = mempty
 commentCell (Just link) = anchorCell link icon
   where icon = toWidget $ hasComment True
 
+-- | whether something is visible or hidden
 isVisibleCell :: (IsDBTable m a) => Bool -> DBCell m a
 isVisibleCell True  =  cell . toWidget $ isVisible True
 isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass
   where
     addUrgencyClass = over cellAttrs $ insertClass $ statusToUrgencyClass Warning
 
+-- | for simple file downloads
+fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a
+fileCell route = anchorCell route $ toWidget fileDownload
+
+-- | for zip-archive downloads
+zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a
+zipCell route = anchorCell route $ toWidget zipDownload
+
 -- | Display an icon that opens a modal upon clicking
 modalCell :: (IsDBTable m a, ToWidget UniWorX w) => w -> DBCell m a
 modalCell content = cell $ modal (toWidget $ hasComment True) (Right $ toWidget content)

src/Utils.hs

@@ -163,6 +163,12 @@ 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>|]
+
 
 ---------------------
 -- Text and String --