411 lines
21 KiB
Haskell
411 lines
21 KiB
Haskell
module Handler.Material
|
|
( getMaterialListR
|
|
, getMFileR, getMVideoR
|
|
, getMShowR
|
|
, getMEditR, postMEditR
|
|
, getMaterialNewR, postMaterialNewR
|
|
, getMDelR, postMDelR
|
|
, getMArchiveR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Set as Set
|
|
-- import Data.Map (Map)
|
|
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.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Utils.Form
|
|
import Handler.Utils
|
|
import Handler.Utils.Delete
|
|
|
|
|
|
data MaterialForm = MaterialForm
|
|
{ mfName :: MaterialName
|
|
, mfType :: Maybe (CI Text)
|
|
, mfDescription :: Maybe StoredMarkup
|
|
, mfVisibleFrom :: Maybe UTCTime
|
|
, mfFiles :: Maybe FileUploads
|
|
}
|
|
|
|
makeMaterialForm :: CourseId -> Maybe MaterialForm -> Form MaterialForm
|
|
makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let typeOptions :: HandlerFor UniWorX (OptionList (CI Text))
|
|
typeOptions = do
|
|
let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
|
|
previouslyUsed <- runDB $
|
|
E.select $ E.from $ \material ->
|
|
E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do
|
|
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
|
|
E.&&. E.not_ (E.isNothing $ material E.^. MaterialType)
|
|
return $ material E.^. MaterialType
|
|
return . mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList
|
|
$ defaults <> Set.fromList (mapMaybe E.unValue previouslyUsed)
|
|
|
|
now <- liftIO getCurrentTime
|
|
let ctime = ceilingQuarterHour now
|
|
let visibleToolTip = case mfVisibleFrom <$> template of
|
|
(Just (Just vistime)) | vistime <= now
|
|
-> MsgMaterialVisibleFromEditWarning
|
|
_ -> MsgMaterialVisibleFromTip
|
|
|
|
flip (renderAForm FormStandard) html $ MaterialForm
|
|
<$> areq (textField & cfStrip & cfCI) (fslI MsgMaterialName) (mfName <$> template)
|
|
<*> aopt (textField & cfStrip & guardField (not . null) & cfCI & addDatalist typeOptions)
|
|
(fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder)
|
|
(mfType <$> template)
|
|
<*> aopt htmlField (fslI MsgMaterialDescription)
|
|
(mfDescription <$> template)
|
|
<*> aopt utcTimeField (fslI MsgMaterialVisibleFrom & setTooltip visibleToolTip)
|
|
((mfVisibleFrom <$> template) <|> pure (Just ctime))
|
|
<*> aopt (multiFileField' . maybeVoid $ mfFiles =<< template)
|
|
(fslI MsgMaterialFiles) (mfFiles <$> template)
|
|
|
|
fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material)
|
|
fetchMaterial tid ssh csh mnm =
|
|
maybe notFound return . listToMaybe <=< E.select . E.from $ -- uniqueness guaranteed by DB constraints
|
|
\(course `E.InnerJoin` material) -> do
|
|
E.on $ course E.^. CourseId E.==. material E.^. MaterialCourse
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. material E.^. MaterialName E.==. E.val mnm
|
|
return material
|
|
|
|
|
|
getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getMaterialListR tid ssh csh = do
|
|
let matLink :: MaterialName -> Route UniWorX
|
|
matLink = CourseR tid ssh csh . flip MaterialR MShowR
|
|
|
|
filesLink :: MaterialName -> SomeRoute UniWorX
|
|
filesLink mnm = SomeRoute . CourseR tid ssh csh $ MaterialR mnm MArchiveR
|
|
|
|
materialModDateCell :: IsDBTable m a => Material -> DBCell m a
|
|
materialModDateCell Material{materialVisibleFrom, materialLastEdit}
|
|
| NTop materialVisibleFrom >= NTop (Just materialLastEdit)
|
|
= mempty -- empty cells mean no modification after publication
|
|
| otherwise = dateTimeCell materialLastEdit -- modification after publication is highlighted by being shown
|
|
|
|
now <- liftIO getCurrentTime
|
|
seeAllModificationTimestamps <- hasWriteAccessTo $ CourseR tid ssh csh MaterialNewR -- ordinary users should not see modification dates older than visibility
|
|
MsgRenderer mr <- getMsgRenderer
|
|
table <- runDB $ do
|
|
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
let typeOptions :: HandlerFor UniWorX (OptionList Text)
|
|
typeOptions = do
|
|
previouslyUsed <- runDB $
|
|
E.select $ E.from $ \material ->
|
|
E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do
|
|
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
|
|
E.&&. E.not_ (E.isNothing $ material E.^. MaterialType)
|
|
return $ material E.^. MaterialType
|
|
return . mkOptionList . map (\(CI.original -> t) -> Option t t t) . Set.toAscList . Set.fromList $ mapMaybe E.unValue previouslyUsed
|
|
let row2material = view $ _dbrOutput . _1 . _entityVal
|
|
psValidator = def & defaultSorting [SortDescBy "last-edit"]
|
|
& forceFilter "may-access" (Any True)
|
|
dbTableWidget' psValidator DBTable
|
|
{ dbtIdent = "material-list" :: Text
|
|
, dbtStyle = def { dbsFilterLayout = defaultDBSFilterLayout }
|
|
, dbtParams = def
|
|
, dbtSQLQuery = \material -> do
|
|
E.where_ $ material E.^. MaterialCourse E.==. E.val cid
|
|
let filesNum :: E.SqlExpr (E.Value Int64)
|
|
filesNum = E.subSelectCount . E.from $ \materialFile ->
|
|
E.where_ $ materialFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
|
|
return (material, filesNum)
|
|
, dbtRowKey = (E.^. MaterialId)
|
|
, dbtProj = dbtProjFilteredPostId
|
|
, dbtColonnade = widgetColonnade $ mconcat
|
|
[ -- dbRow,
|
|
sortable (Just "type") (i18nCell MsgMaterialType)
|
|
$ foldMap (textCell . CI.original) . materialType . row2material
|
|
, sortable (Just "name") (i18nCell MsgMaterialName)
|
|
$ liftA2 anchorCell matLink toWgt . materialName . row2material
|
|
, sortable (toNothingS "description") (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgMaterialDescription))
|
|
$ foldMap modalCell . materialDescription . row2material
|
|
, sortable (toNothingS "zip-archive") (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgMaterialFiles))
|
|
$ \DBRow{ dbrOutput = (Entity _ Material{..}, E.Value fileNum) } -> if
|
|
| fileNum == 0 -> mempty
|
|
| otherwise -> anchorCell (filesLink materialName) iconFileDownload
|
|
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
|
|
$ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material
|
|
, sortable (Just "last-edit") (i18nCell MsgTableFileModified)
|
|
$ if seeAllModificationTimestamps
|
|
then dateTimeCell . materialLastEdit . row2material
|
|
else materialModDateCell . row2material
|
|
]
|
|
, dbtSorting = Map.fromList
|
|
[ ( "type" , SortColumn (E.^. MaterialType) )
|
|
, ( "name" , SortColumn (E.^. MaterialName) )
|
|
, ( "visible-from" , SortColumn (E.^. MaterialVisibleFrom) )
|
|
, ( "last-edit" , SortColumn (E.^. MaterialLastEdit) )
|
|
]
|
|
, dbtFilter = mconcat
|
|
[ singletonMap "may-access" . mkFilterProjectedPost $ \(Any b) dbr
|
|
-> (== b) <$> hasReadAccessTo (matLink . materialName $ row2material dbr) :: DB Bool
|
|
, singletonMap "name". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of
|
|
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
Just needle -> E.castString (material E.^. MaterialName) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%)
|
|
, singletonMap "type-and-description". FilterColumn $ \material criterion -> case getLast (criterion :: Last Text) of
|
|
Nothing -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
Just needle -> (E.maybe (E.val mempty) E.castString (material E.^. MaterialType) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
|
E.||. (E.maybe (E.val mempty) (E.castString.esqueletoMarkupOutput) (material E.^. MaterialDescription) `E.ilike` (E.%) E.++. E.val needle E.++. (E.%))
|
|
]
|
|
, dbtFilterUI = \mPrev -> mconcat $ catMaybes
|
|
[ Just $ prismAForm (singletonFilter "name") mPrev $ aopt textField (fslI MsgFilterMaterialNameSearch)
|
|
, Just $ prismAForm (singletonFilter "type-and-description") mPrev $ aopt (textField & addDatalist typeOptions) (fslI MsgFilterMaterialTypeAndDescriptionSearch)]
|
|
, dbtCsvEncode = noCsvEncode
|
|
, dbtCsvDecode = Nothing
|
|
, dbtExtraReps = []
|
|
}
|
|
|
|
let headingLong = prependCourseTitle tid ssh csh MsgMaterialListHeading
|
|
headingShort = prependCourseTitle tid ssh csh MsgMaterialListHeading
|
|
siteLayoutMsg headingLong $ do
|
|
setTitleI headingShort
|
|
$(widgetFile "material-list")
|
|
|
|
|
|
|
|
|
|
getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -> Handler TypedContent
|
|
getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal
|
|
where
|
|
fileQuery = E.selectSource $ E.from $
|
|
\(course `E.InnerJoin` material `E.InnerJoin` matFile) -> do
|
|
-- Restrict to consistent rows that correspond to each other
|
|
E.on (matFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId)
|
|
E.on (material E.^. MaterialCourse E.==. course E.^. CourseId)
|
|
-- filter to requested file
|
|
E.where_ ((matFile E.^. MaterialFileTitle E.==. E.val title)
|
|
E.&&. (material E.^. MaterialName E.==. E.val mnm )
|
|
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 matFile
|
|
|
|
getMVideoR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> CryptoUUIDMaterialFile -> Handler Html
|
|
getMVideoR tid ssh csh mnm cID = do
|
|
mfId <- decrypt cID
|
|
MaterialFile{..} <- runDB $ get404 mfId
|
|
let mimeType = mimeLookup $ pack materialFileTitle
|
|
mfile = CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
|
|
let mfileDownload = mfile & over (urlRouteParams $ Proxy @UniWorX) (\params -> bool ((toPathPiece GetDownload, toPathPiece True) : ) id (anyOf (folded . _1) (== toPathPiece GetDownload) params) params)
|
|
mfileText <- toTextUrl mfile
|
|
mfileDownloadText <- toTextUrl mfileDownload
|
|
unless (mimeType `Set.member` videoTypes) $
|
|
redirectWith movedPermanently301 mfile
|
|
siteLayout' Nothing $ do
|
|
setTitleI . prependCourseTitle tid ssh csh $ MsgMaterialVideo mnm
|
|
[whamlet|
|
|
$newline never
|
|
<section>
|
|
<div .video-container>
|
|
<video controls autoplay preload=auto>
|
|
<source src=#{mfileText} type=#{decodeUtf8 mimeType}>
|
|
_{MsgMaterialVideoUnsupported}
|
|
<section>
|
|
<a .btn href=#{mfileDownloadText}>
|
|
^{iconFileDownload} #
|
|
_{MsgMaterialVideoDownload}
|
|
|]
|
|
|
|
|
|
getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
|
|
getMShowR tid ssh csh mnm = do
|
|
seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility
|
|
|
|
(Entity _mid material@Material{materialType, materialDescription}, (Any hasFiles,fileTable), zipLink) <- runDB $ do
|
|
let zipLink = CMaterialR tid ssh csh mnm MArchiveR
|
|
matEnt <- fetchMaterial tid ssh csh mnm
|
|
let materialModDateCol :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c)
|
|
materialModDateCol = if seeAllModificationTimestamps
|
|
then colFileModification
|
|
else colFileModificationWhen $ \t -> NTop (Just t) > NTop (materialVisibleFrom $ entityVal matEnt)
|
|
let psValidator = def & defaultSortingByFileTitle
|
|
fileTable' <- dbTable psValidator DBTable
|
|
{ dbtSQLQuery = \matFile -> do
|
|
E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
|
|
E.&&. E.not_ (E.isNothing $ matFile E.^. MaterialFileContent) -- don't show directories
|
|
return matFile
|
|
, dbtRowKey = (E.^. MaterialFileId)
|
|
, dbtColonnade = widgetColonnade $ mconcat
|
|
[ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgTableFileTitle) $ \(dbrOutput -> Entity mfId MaterialFile{..})
|
|
-> let matLink
|
|
| isVideo
|
|
= CourseR tid ssh csh . MaterialR mnm . MVideoR <$> encrypt mfId
|
|
| otherwise
|
|
= pure . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
|
|
wgt = [whamlet|
|
|
$newline never
|
|
<span .file-path>
|
|
#{materialFileTitle}
|
|
$if isVideo
|
|
\ ^{iconVideo}
|
|
|]
|
|
isVideo = mimeLookup (pack materialFileTitle) `Set.member` videoTypes
|
|
in anchorCellM matLink wgt
|
|
, materialModDateCol (view $ _dbrOutput . _entityVal . to (E.Value . materialFileModified))
|
|
]
|
|
, dbtProj = dbtProjId
|
|
, dbtStyle = def
|
|
, dbtParams = def
|
|
, dbtFilter = mempty
|
|
, dbtFilterUI = mempty
|
|
, dbtIdent = "material-files" :: Text
|
|
, dbtSorting = Map.fromList
|
|
[ sortFilePath id
|
|
, sortFileModification id
|
|
]
|
|
, dbtCsvEncode = noCsvEncode
|
|
, dbtCsvDecode = Nothing
|
|
, dbtExtraReps = []
|
|
}
|
|
return (matEnt,fileTable',zipLink)
|
|
-- File table has no filtering by access, because we assume that
|
|
-- access rights to material and material-files are identical.
|
|
|
|
let matLastEdit = formatTimeW SelFormatDateTime $ materialLastEdit material
|
|
let matVisibleFromMB = visibleUTCTime SelFormatDateTime <$> materialVisibleFrom material
|
|
|
|
let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialHeading mnm
|
|
headingShort = prependCourseTitle tid ssh csh $ SomeMessage mnm
|
|
siteLayoutMsg headingLong $ do
|
|
setTitleI headingShort
|
|
$(widgetFile "material-show")
|
|
|
|
|
|
getMEditR, postMEditR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
|
|
getMEditR = postMEditR
|
|
postMEditR tid ssh csh mnm = do
|
|
(Entity mid Material{..}, files) <- runDB $ do
|
|
matEnt <- fetchMaterial tid ssh csh mnm
|
|
mFileEnts <- selectList [ MaterialFileMaterial ==. entityKey matEnt ] []
|
|
return (matEnt, mFileEnts)
|
|
-- let cid = materialCourse
|
|
let template = Just MaterialForm
|
|
{ mfName = materialName
|
|
, mfType = materialType
|
|
, mfDescription = materialDescription
|
|
, mfVisibleFrom = materialVisibleFrom
|
|
, mfFiles = Just $ yieldMany [ matFile ^. _FileReference . _1 | Entity _ matFile <- files ]
|
|
}
|
|
editWidget <- handleMaterialEdit tid ssh csh materialCourse template $ uniqueReplace mid
|
|
let headingLong = prependCourseTitle tid ssh csh $ MsgMaterialEditHeading mnm
|
|
headingShort = prependCourseTitle tid ssh csh $ MsgMaterialEditTitle mnm
|
|
siteLayoutMsg headingLong $ do
|
|
setTitleI headingShort
|
|
editWidget
|
|
|
|
|
|
getMaterialNewR, postMaterialNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
|
getMaterialNewR = postMaterialNewR
|
|
postMaterialNewR tid ssh csh = do
|
|
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
|
|
editWidget <- handleMaterialEdit tid ssh csh cid Nothing insertUnique
|
|
let headingLong = prependCourseTitle tid ssh csh MsgMaterialNewHeading
|
|
headingShort = prependCourseTitle tid ssh csh MsgMaterialNewTitle
|
|
siteLayoutMsg headingLong $ do
|
|
setTitleI headingShort
|
|
editWidget
|
|
|
|
handleMaterialEdit :: TermId -> SchoolId -> CourseShorthand -> CourseId -> Maybe MaterialForm -> (Material -> DB (Maybe MaterialId)) -> Handler Widget
|
|
handleMaterialEdit tid ssh csh cid template dbMaterial = do
|
|
((res,formWidget), formEnctype) <- runFormPost $ makeMaterialForm cid template
|
|
formResult res saveMaterial
|
|
-- actionUrl <- fromMaybe (CourseR tid ssh csh MaterialNewR) <$> getCurrentRoute
|
|
return $ wrapForm formWidget def
|
|
{ formAction = Nothing -- Just $ SomeRoute actionUrl
|
|
, formEncoding = formEnctype
|
|
}
|
|
where
|
|
saveMaterial :: MaterialForm -> Handler ()
|
|
saveMaterial MaterialForm{..} = do
|
|
_aid <- requireAuthId
|
|
now <- liftIO getCurrentTime
|
|
let newMaterial = Material
|
|
{ materialCourse = cid
|
|
, materialName = mfName
|
|
, materialType = mfType
|
|
, materialDescription = mfDescription
|
|
, materialVisibleFrom = mfVisibleFrom
|
|
, materialLastEdit = now
|
|
}
|
|
saveOk <- runDB $ do
|
|
mbmid <- dbMaterial newMaterial
|
|
case mbmid of
|
|
Nothing -> False <$ addMessageI Error (MsgMaterialNameDup tid ssh csh mfName)
|
|
(Just mid) -> do -- save files in DB
|
|
insertMaterialFile' mid $ maybeVoid mfFiles
|
|
addMessageI Success $ MsgMaterialSaveOk tid ssh csh mfName
|
|
-- more info/warnings could go here
|
|
return True
|
|
when saveOk $ redirect -- redirect must happen outside of runDB
|
|
$ CourseR tid ssh csh (MaterialR mfName MShowR)
|
|
|
|
insertMaterialFile' :: MaterialId -> FileUploads -> DB ()
|
|
insertMaterialFile' mid = (void . ) . replaceFileReferences mkFilter $ MaterialFileResidual mid
|
|
where mkFilter MaterialFileResidual{..} = [ MaterialFileMaterial ==. materialFileResidualMaterial ]
|
|
|
|
getMDelR, postMDelR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
|
|
getMDelR = postMDelR
|
|
postMDelR tid ssh csh mnm = do
|
|
matEnt <- runDB $ fetchMaterial tid ssh csh mnm
|
|
deleteR DeleteRoute
|
|
{ drRecords = Set.singleton $ entityKey matEnt
|
|
, drGetInfo = \(material `E.InnerJoin` course) -> do
|
|
E.on $ material E.^. MaterialCourse E.==. course E.^. CourseId
|
|
let filecount :: E.SqlExpr (E.Value Int64)
|
|
filecount = E.subSelectCount . E.from $ \matfile ->
|
|
E.where_ $ matfile E.^. MaterialFileMaterial E.==. material E.^. MaterialId
|
|
return (material,course,filecount)
|
|
, drUnjoin = \(material `E.InnerJoin` _course) -> material
|
|
, drRenderRecord = \(Entity _ Material{..}, Entity _ Course{..}, E.Value fileCount) -> do
|
|
now <- liftIO getCurrentTime
|
|
let isPublished = NTop (Just now) >= NTop materialVisibleFrom
|
|
pCT = prependCourseTitle courseTerm courseSchool courseShorthand
|
|
return [whamlet|
|
|
_{SomeMessage $ pCT $ MsgMaterialHeading materialName}
|
|
$if fileCount /= 0
|
|
<i>_{SomeMessage $ MsgMaterialDelHasFiles fileCount}
|
|
$if isPublished
|
|
_{SomeMessage $ MsgMaterialIsVisible}
|
|
|]
|
|
, drRecordConfirmString = \(Entity _ Material{..}, Entity _ Course{..}, E.Value fileCount) ->
|
|
return $ [st|#{termToText (unTermKey courseTerm)}/#{unSchoolKey courseSchool}/#{courseShorthand}/#{materialName}|] <> bool mempty [st| + #{tshow fileCount} Files|] (fileCount /= 0)
|
|
, drCaption = SomeMessage MsgMaterialDeleteCaption
|
|
, drSuccessMessage = SomeMessage $ MsgMaterialDeleted mnm
|
|
, drFormMessage = const $ return Nothing
|
|
, drSuccess = SomeRoute $ CourseR tid ssh csh MaterialListR
|
|
, drAbort = SomeRoute $ CourseR tid ssh csh $ MaterialR mnm MShowR
|
|
, drDelete = const id -- TODO: audit
|
|
}
|
|
|
|
materialArchiveSource :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> ConduitT () MaterialFile (YesodDB UniWorX) ()
|
|
materialArchiveSource tid ssh csh mnm = (.| C.map entityVal) . E.selectSource . E.from $
|
|
\(course `E.InnerJoin` material `E.InnerJoin` materialFile) -> do
|
|
E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial
|
|
E.on $ material E.^. MaterialCourse E.==. course E.^. CourseId
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
E.&&. material E.^. MaterialName E.==. E.val mnm
|
|
return materialFile
|
|
|
|
-- | Serve all material-files
|
|
getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent
|
|
getMArchiveR tid ssh csh mnm = do
|
|
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgMaterialArchiveName tid ssh csh mnm
|
|
|
|
let getMatQuery = materialArchiveSource tid ssh csh mnm
|
|
serveSomeFiles archiveName getMatQuery
|