diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 746d60dce..ef6ce57ae 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -596,6 +596,7 @@ SheetGroupNoGroups: Keine Gruppenabgabe SheetGroupMaxGroupsize: Maximale Gruppengröße SheetFiles: Übungsblatt-Dateien +SheetFileTypeHeader: Zugehörigkeit NotificationTriggerSubmissionRatedGraded: Meine Abgabe in einem gewerteten Übungsblatt wurde korrigiert NotificationTriggerSubmissionRated: Meine Abgabe wurde korrigiert diff --git a/routes b/routes index a86f39945..135c9baa1 100644 --- a/routes +++ b/routes @@ -109,9 +109,11 @@ /mat MaterialListR GET !materials !registered !corrector /mat/new MaterialNewR GET POST /mat/#MaterialName MaterialR: - /show MShowR GET !timeANDregistered !timeANDmaterials !corrector /edit MEditR GET POST /delete MDelR GET POST + /show MShowR GET !timeANDregistered !timeANDmaterials !corrector + /file/*FilePath MFileR GET !timeANDregistered !timeANDmaterials !corrector + /subs CorrectionsR GET POST !corrector !lecturer /subs/upload CorrectionsUploadR GET POST !corrector !lecturer diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 5dd8ce020..528e06d84 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -4,20 +4,25 @@ import Import import Data.Set (Set) 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 Database.Esqueleto as E +import Database.Esqueleto.Utils.TH import Utils.Lens import Utils.Form import Handler.Utils -- import Handler.Utils.Delete +import Handler.Utils.Table.Columns import Control.Monad.Writer (MonadWriter(..), execWriterT) + data MaterialForm = MaterialForm { mfName :: MaterialName , mfType :: Maybe Text @@ -72,24 +77,62 @@ fetchMaterial tid ssh csh mnm = do return (cid, matEnt) - - getMaterialListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getMaterialListR = error "unimplemented" -- TODO +getMFileR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> FilePath -> Handler TypedContent +getMFileR tid ssh csh mnm title = serveOneFile fileQuery + where + fileQuery = E.select $ E.from $ + \(course `E.InnerJoin` material `E.InnerJoin` matFile `E.InnerJoin` file) -> do + -- Restrict to consistent rows that correspond to each other + E.on (file E.^. FileId E.==. matFile E.^. MaterialFileFile) + E.on (matFile E.^. MaterialFileMaterial E.==. material E.^. MaterialId) + E.on (material E.^. MaterialCourse E.==. course E.^. CourseId) + -- filter to requested file + E.where_ ((file E.^. FileTitle 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 file getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html -getMShowR = do -- tid ssh csh mnm = do - -- <- runDB $ do - -- (cid, matEnt) <- fetchMaterial tid ssh csh mnm - -- dbTable psValidator DBTable - -- { dbtSQLQuery - - - -- } - - +getMShowR tid ssh csh mnm = do + let matLink :: FilePath -> Route UniWorX + matLink = CourseR tid ssh csh . MaterialR mnm . MFileR + _ <- runDB $ do + (cid, matEnt) <- fetchMaterial tid ssh csh mnm + let psValidator = def & defaultSortingByFileTitle + dbTable psValidator DBTable + { dbtSQLQuery = \(matFile `E.InnerJoin` file) -> do + E.on $ matFile E.^. MaterialFileFile E.==. file E.^. FileId + E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) + E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories + return (file E.^. FileTitle, file E.^. FileModified) + , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId + , dbtColonnade = widgetColonnade $ mconcat + [ colFilePathSimple (view _1) matLink + , colFileModification (view _2) + ] + , dbtProj = \row -> + let dbrOutput = row ^. _dbrOutput + fPath = dbrOutput ^. _1 . _Value + in guardAuthorizedFor (matLink fPath) dbrOutput + , dbtStyle = def + , dbtParams = def + , dbtFilter = mempty + , dbtFilterUI = mempty + , dbtIdent = "material-files" :: Text + , dbtSorting = Map.fromList + [ sortFilePath $ $(sqlIJproj 2 2) E.^. FileTitle + , sortFileModification $ $(sqlIJproj 2 2) E.^. FileModified + ] + } + -- DEAD CODE TO DELETE: -- (cid, Entity mid Material{..}, files) <- runDB $ do -- (cid, matEnt) <- fetchMaterial tid ssh csh mnm -- fileIds <- E.select . E.from $ \(matFile `E.InnerJoin` file) -> do diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 461c23d67..0ca8a2698 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -4,12 +4,12 @@ import Import import Jobs.Queue -import System.FilePath (takeFileName) - +-- import Utils.Lens import Utils.Sheet import Handler.Utils -- import Handler.Utils.Zip import Handler.Utils.Table.Cells +-- import Handler.Utils.Table.Columns import Handler.Utils.SheetType import Handler.Utils.Delete import Handler.Utils.Form.MassInput @@ -38,8 +38,6 @@ import Control.Monad.Writer (MonadWriter(..), execWriterT) import Control.Monad.Trans.Except (runExceptT, mapExceptT, throwE) -import Network.Mime - import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map @@ -310,24 +308,25 @@ getSShowR tid ssh csh shn = do E.on (sheetFile E.^. SheetFileFile E.==. file E.^. FileId) -- filter to requested file E.where_ $ sheetFile E.^. SheetFileSheet E.==. E.val sid - E.&&. E.not_ (E.isNothing $ file E.^. FileContent) + E.&&. E.not_ (E.isNothing $ file E.^. FileContent) -- don't show directories -- return desired columns return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType) let colonnadeFiles = widgetColonnade $ mconcat - [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) - , sortable (Just "path") "Dateiname" $ \(E.Value fName,_,E.Value fType) -> anchorCell - (CSheetR tid ssh csh shn (SFileR fType fName)) - (str2widget fName) - , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget + [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) + , sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell + (CSheetR tid ssh csh shn (SFileR fType fName)) + (str2widget fName) + -- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName)))) + -- , colFileModification (view _2) + , sortable (Just "time") (i18nCell MsgFileModified) $ \(_,E.Value modified,_) -> dateTimeCell modified ] - let psValidator = def - & defaultSorting [SortAscBy "type", SortAscBy "path"] + let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"] (Any hasFiles, fileTable) <- runDB $ dbTable psValidator DBTable { dbtSQLQuery = fileData , dbtRowKey = \(_ `E.InnerJoin` file) -> file E.^. FileId , dbtColonnade = colonnadeFiles , dbtProj = \DBRow{ dbrOutput = dbrOutput@(E.Value fName, _, E.Value fType) } - -> dbrOutput <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn $ SFileR fType fName) False) + -> guardAuthorizedFor (CSheetR tid ssh csh shn $ SFileR fType fName) dbrOutput , dbtStyle = def , dbtFilter = mempty , dbtFilterUI = mempty @@ -399,34 +398,24 @@ postSPseudonymR tid ssh csh shn = do getSFileR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> SheetFileType -> FilePath -> Handler TypedContent -getSFileR tid ssh csh shn typ title = do - results <- runDB $ 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 desired columns - return $ (file E.^. FileTitle, file E.^. FileContent) - case results of - [(E.Value fileTitle, E.Value 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 () - [] -> notFound - other -> do - $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other - error "Multiple matching files found." +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 getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getSheetNewR tid ssh csh = do diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index 46c4e8631..dfca11b4c 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -30,7 +30,9 @@ import Handler.Utils.Sheet as Handler.Utils import Handler.Utils.Mail as Handler.Utils import System.Directory (listDirectory) -import System.FilePath.Posix (takeBaseName) +import System.FilePath.Posix (takeBaseName, takeFileName) + +import Network.Mime import qualified Data.List as List import qualified Data.List.NonEmpty as NonEmpty @@ -45,6 +47,22 @@ downloadFiles = do UserDefaultConf{..} <- getsYesod $ view _appUserDefaults return userDefaultDownloadFiles +-- | Serve a single file, identified through a given DB query +serveOneFile :: DB [Entity File] -> Handler TypedContent +serveOneFile query = do + results <- runDB query + case results of + [(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 () + [] -> notFound + other -> do + $logErrorS "SFileR" $ "Multiple matching files: " <> tshow other + error "Multiple matching files found." + tidFromText :: Text -> Maybe TermId tidFromText = fmap TermKey . maybeRight . termFromText @@ -171,3 +189,12 @@ i18nWidgetFile basename = do | l <- unpack <$> NonEmpty.toList availableTranslations' -- One function definition for every available language ] ++ [ clause [wildP] (normalB [e| error "selectLanguage returned an invalid translation" |]) [] ] -- Fallback mostly there so compiler does not complain about non-exhaustive pattern match ] [e|selectLanguage availableTranslations' >>= $(varE ws)|] + + + +-- | return a value only if the current user ist authorized for a given route +guardAuthorizedFor :: ( HandlerSite h ~ UniWorX, MonadHandler h, MonadLogger h + , MonadTrans m, MonadPlus (m (ReaderT SqlBackend h))) + => Route UniWorX -> a -> m (ReaderT SqlBackend h) a +guardAuthorizedFor link val = + val <$ guardM (lift $ (== Authorized) <$> evalAccessDB link False) diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 25279fb96..f3be69490 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -34,6 +34,49 @@ import Handler.Utils.Table.Cells -- * additional helper, such as default sorting + +--------------- +-- Files + +-- | Generic column for links to FilePaths, where the link depends on the entire table row +colFilePath :: (IsDBTable m c) => (t -> E.Value FilePath) -> (t -> Route UniWorX) -> Colonnade Sortable t (DBCell m c) +colFilePath row2path row2link = sortable (Just "path") (i18nCell MsgFileTitle) makeCell + where + makeCell row = + let filePath = E.unValue $ row2path row + link = row2link row + in anchorCell link $ str2widget filePath + +-- | Generic column for links to FilePaths, where the link only depends on the FilePath itself +colFilePathSimple :: (IsDBTable m c) => (t -> E.Value FilePath) -> (FilePath -> Route UniWorX) -> Colonnade Sortable t (DBCell m c) +colFilePathSimple row2path row2link = sortable (Just "path") (i18nCell MsgFileTitle) makeCell + where + makeCell row = + let filePath = E.unValue $ row2path row + link = row2link filePath + in anchorCell link $ str2widget filePath + +-- | Generic column for File Modification +colFileModification :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) +colFileModification row2time = sortable (Just "time") (i18nCell MsgFileModified) (timeCell . E.unValue . row2time) + +-- sortFilePath :: IsString a => (t -> E.SqlExpr (Entity ???)) -> (a, SortColumn t) +sortFilePath :: (PersistField a2, IsString a1) => + (t -> E.SqlExpr (E.Value a2)) -> (a1, SortColumn t) +sortFilePath queryPath = ("path", SortColumn queryPath) + +sortFileModification :: (PersistField a2, IsString a1) => + (t -> E.SqlExpr (E.Value a2)) -> (a1, SortColumn t) +sortFileModification queryModification = ("time", SortColumn queryModification) + +defaultSortingByFileTitle :: PSValidator m x -> PSValidator m x +defaultSortingByFileTitle = defaultSorting [SortAscBy "path"] + +defaultSortingByFileModification :: PSValidator m x -> PSValidator m x +defaultSortingByFileModification = defaultSorting [SortAscBy "time"] + + + --------------- -- User names