Material dbTable almost done, sorting type error

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

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

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
+getMShowR tid ssh csh mnm = do
-  -- <- runDB $ do
+  let matLink :: FilePath -> Route UniWorX
-  --   (cid, matEnt) <- fetchMaterial tid ssh csh mnm
+      matLink = CourseR tid ssh csh . MaterialR mnm . MFileR
-  --   dbTable psValidator DBTable
+  _ <- runDB $ do
-  --     { dbtSQLQuery
+    (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

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 "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
-        , sortable (Just "path") "Dateiname" $ \(E.Value fName,_,E.Value fType) -> anchorCell
+        , sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell
-            (CSheetR tid ssh csh shn (SFileR fType fName))
+             (CSheetR tid ssh csh shn (SFileR fType fName))
-            (str2widget fName)
+             (str2widget fName)
-        , sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> cell $ formatTime SelFormatDateTime (modified :: UTCTime) >>= toWidget
+        -- , 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
+  let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
-        & 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
+getSFileR tid ssh csh shn typ title = serveOneFile fileQuery
-  results <- runDB $ E.select $ E.from $
+  where
-    \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
+    fileQuery = E.select $ E.from $
-      -- Restrict to consistent rows that correspond to each other
+       \(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
-      E.on (file      E.^. FileId         E.==. sheetFile E.^. SheetFileFile)
+        -- Restrict to consistent rows that correspond to each other
-      E.on (sheetFile E.^. SheetFileSheet E.==. sheet     E.^. SheetId)
+        E.on (file      E.^. FileId         E.==. sheetFile E.^. SheetFileFile)
-      E.on (sheet     E.^. SheetCourse    E.==. course    E.^. CourseId)
+        E.on (sheetFile E.^. SheetFileSheet E.==. sheet     E.^. SheetId)
-      -- filter to requested file
+        E.on (sheet     E.^. SheetCourse    E.==. course    E.^. CourseId)
-      E.where_ ((file      E.^. FileTitle       E.==. E.val title)
+        -- filter to requested file
-        E.&&.   (sheetFile E.^. SheetFileType   E.==. E.val typ  )
+        E.where_ ((file      E.^. FileTitle       E.==. E.val title)
-        E.&&.   (sheet     E.^. SheetName       E.==. E.val shn  )
+          E.&&.   (sheetFile E.^. SheetFileType   E.==. E.val typ  )
-        E.&&.   (course    E.^. CourseShorthand E.==. E.val csh  )
+          E.&&.   (sheet     E.^. SheetName       E.==. E.val shn  )
-        E.&&.   (course    E.^. CourseSchool    E.==. E.val ssh  )
+          E.&&.   (course    E.^. CourseShorthand E.==. E.val csh  )
-        E.&&.   (course    E.^. CourseTerm      E.==. E.val tid  )
+          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)
+        -- return file entity
-  case results of
+        return file
-    [(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."
 
 getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getSheetNewR tid ssh csh = do

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)

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