diff --git a/routes b/routes index 89b7fc369..0844f047a 100644 --- a/routes +++ b/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: diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index b12b3b9af..c9199136f 100644 --- a/src/Handler/Material.hs +++ b/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 - , sortable (Just "type") (i18nCell MsgMaterialType) + [ -- dbRow, + 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 diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index c135e851b..e2294e46c 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/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) diff --git a/src/Utils.hs b/src/Utils.hs index 9b764fc12..619fdaa81 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -163,6 +163,12 @@ boolSymbol :: Bool -> Markup boolSymbol True = [shamlet||] boolSymbol False = [shamlet||] +fileDownload :: Markup +fileDownload = [shamlet||] + +zipDownload :: Markup +zipDownload = [shamlet||] + --------------------- -- Text and String --