Material dbTable almost done, sorting type error
This commit is contained in:
Steffen Jost
parent
09467c21f3
commit
88fc32e13f
@ -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
|
||||
|
||||
4
routes
4
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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -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
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user