fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

SheetFile Up/Download added

Browse Source
This commit is contained in:
SJost 2018-01-09 15:24:18 +01:00
parent 6070c9231b
commit 499315432a
7 changed files with 135 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
routes
View File

@ -18,15 +18,12 @@
/course/#TermIdentifier/#Text/edit CourseEditExistR GET
/course/#TermIdentifier/#Text/show CourseShowR GET POST
/course/#TermIdentifier/#Text/sheet/ SheetListR GET
/course/#CourseId/sheet/ SheetListCID GET
/course/#TermIdentifier/#Text/sheet/#Text/show SheetShowR GET
/sheet/#SheetId/show SheetIdShowR GET
/sheetuuid/#CryptoUUIDSheet/show SheetUUIDShowR GET
/course/#TermIdentifier/#Text/sheet/new SheetNewR GET
/course/#TermIdentifier/#Text/sheet/ SheetListR GET
/course/#TermIdentifier/#Text/sheet/#Text/show SheetShowR GET
/course/#TermIdentifier/#Text/sheet/#Text/#SheetFileType/#FilePath SheetFileR GET
/course/#TermIdentifier/#Text/sheet/new SheetNewR GET POST
/course/#TermIdentifier/#Text/sheet/#SheetId/edit SheetEditR GET POST
/course/#TermIdentifier/#Text/sheet/#SheetId/delete SheetDelR POST
/course/#TermIdentifier/#Text/sheet/#SheetId/delete SheetDelR GET POST
/submission SubmissionListR GET POST
/submission/#CryptoUUIDSubmission SubmissionR GET POST

6
src/Foundation.hs
View File

@ -186,6 +186,7 @@ isAuthorizedDB TermEditR _ = adminAccess Nothing
isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing
isAuthorizedDB CourseEditR _ = lecturerAccess Nothing
isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort (TermKey t) c)
isAuthorizedDB (SheetNewR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort (TermKey t) c)
isAuthorizedDB (CourseEditExistIDR cID) _ = do
courseId <- decrypt cID
courseLecturerAccess courseId
@ -248,11 +249,6 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (SheetListR tid csh) = return ("Kurs", Just $ CourseShowR tid csh)
breadcrumb (SheetShowR tid csh _shn) = return ("Übungen", Just $ SheetListR tid csh)
breadcrumb (SheetUUIDShowR sUUID) = do
cIDKey <- getsYesod appCryptoIDKey
sheetId <- UUID.decrypt cIDKey sUUID
sheet <- runDB $ get sheetId
return ("Übungen", (SheetListCID . sheetCourseId) <$> sheet )
breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR)

84
src/Handler/Sheet.hs
View File

@ -11,6 +11,8 @@ module Handler.Sheet where
import Import
import Handler.Utils
import Handler.Utils.Zip
-- import Data.Time
import qualified Data.Text as T
@ -21,7 +23,11 @@ import Colonnade -- hiding (fromMaybe)
import Yesod.Colonnade
--
import qualified Data.UUID.Cryptographic as UUID
import qualified Data.Conduit.List as C
import qualified Database.Esqueleto as E
import Network.Mime
{-
* Implement Handlers
@ -30,8 +36,7 @@ import qualified Data.UUID.Cryptographic as UUID
-}
data SheetForm = SheetForm
{ sfCourseId :: Maybe CourseId
, sfName :: Text
{ sfName :: Text
, sfComment :: Maybe Html
, sfType :: SheetType
, sfMarkingText :: Maybe Html
@ -45,13 +50,15 @@ data SheetForm = SheetForm
}
makeSheetForm :: Maybe CourseId -> Maybe SheetForm -> Form SheetForm
makeSheetForm :: CourseId -> Maybe SheetForm -> Form SheetForm
makeSheetForm cid template = identForm FIDsheet $ \html -> do
-- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :(
-- Erstmal nur mit ZIP arbeiten
(result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ SheetForm
<$> areq hiddenField "KursId" (Just cid)
<*> areq textField (fsb "Name") (sfName <$> template)
<$> areq textField (fsb "Name") (sfName <$> template)
<*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfMarkingText <$> template)
<*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template)
--TODO: SICHTBARKEIT hinzunehmen
<*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
<*> areq utcTimeField (fsb "Abgabe ab") (sfActiveFrom <$> template)
<*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo <$> template)
@ -76,7 +83,7 @@ makeSheetForm cid template = identForm FIDsheet $ \html -> do
)
_ -> (result, widget)
where
validateSheet _ = []
validateSheet _ = [] -- TODO
fetchSheet :: TermIdentifier -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
@ -129,16 +136,18 @@ getSheetShowR :: TermIdentifier -> Text -> Text -> Handler Html
getSheetShowR tid csh shn = getSheetShow =<<
(runDB $ fetchSheet tid csh shn)
{- Nur per UUID
getSheetIdShowR :: SheetId -> Handler Html
getSheetIdShowR sheetId = getSheetShow =<<
(Entity sheetId) <$> (runDB $ get404 sheetId)
(Entity sheetId) <$> (runDB $ get404 sheetId)\
-}{-
getSheetUUIDShowR :: CryptoUUIDSheet -> Handler Html
getSheetUUIDShowR sUUID = do
cIDKey <- getsYesod appCryptoIDKey
sheetId <- UUID.decrypt cIDKey sUUID
sheetEnt <- runDB $ get404 sheetId
getSheetShow $ Entity sheetId sheetEnt
-}
getSheetShow :: (Entity Sheet) -> Handler Html
getSheetShow entSheet = do
@ -148,11 +157,62 @@ getSheetShow entSheet = do
[whamlet| Under Construction !!! |] -- TODO
$(widgetFile "sheetAdmin")
getSheetFileR :: TermIdentifier -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
getSheetFileR tid csh shn typ title = do
content <- 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.^. SheetFileFileId)
E.on (sheetFile E.^. SheetFileSheetId E.==. sheet E.^. SheetId)
E.on (sheet E.^. SheetCourseId 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.^. CourseTermId E.==. E.val (TermKey tid))
)
-- return desired columns
return $ file E.^. FileContent
let mimeType = defaultMimeLookup $ pack title
case content of
[E.Value (Just nochmalContent)] -> do
addHeader "Content-Disposition" "attachment"
respond mimeType nochmalContent
[] -> notFound
_other -> error "Multiple matching files found."
getSheetNewR :: TermIdentifier -> Text -> Handler Html
getSheetNewR tid csh = do
(Entity cid course) <- runDB $ getBy404 $ CourseTermShort (TermKey tid) csh
defaultLayout [whamlet| Under Construction !!! |] -- TODO
let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
((res,wdgt), enc) <- runFormPost $ makeSheetForm cid template
case res of
(FormSuccess SheetForm{..}) -> do
let sid = undefined -- TODO after first insert
let sname = undefined -- TODO after first insert
-- Prüfe, das FileTitle innerhalb des Sheets eindeutig ist für diesen SheetFileTpye
whenIsJust sfSheetF $ \sinfo -> do
let sheetInsert file = do
fid <- insert file
void . insert $ SheetFile sid fid SheetExercise
runDB . runConduit $ (sourceFiles sinfo) =$= C.mapM_ sheetInsert
addMessage "info" "Blatt angelegt"
redirect $ SheetShowR tid csh sname
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
_ -> return ()
defaultLayout $ do
$(widgetFile "newSheet")
postSheetNewR :: TermIdentifier -> Text -> Handler Html
postSheetNewR = getSheetNewR
getSheetEditR :: TermIdentifier -> Text -> SheetId -> Handler Html
getSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
@ -161,8 +221,14 @@ postSheetEditR :: TermIdentifier -> Text -> SheetId -> Handler Html
postSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
getSheetDelR :: TermIdentifier -> Text -> SheetId -> Handler Html
getSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
-- Sicherheitsabfrage
postSheetDelR :: TermIdentifier -> Text -> SheetId -> Handler Html
postSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
-- Tatsächlich löschen
{-
getCourseShowR :: TermIdentifier -> Text -> Handler Html

8
src/Handler/Utils.hs
View File

@ -47,10 +47,16 @@ withFragment :: ( Monad m
) => MForm m (a, WidgetT site IO ()) -> Markup -> MForm m (a, WidgetT site IO ())
withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >> widget)
-----------
-- Maybe --
-----------
whenIsJust :: Monad m => Maybe a -> (a -> m ()) -> m ()
whenIsJust (Just x) f = f x
whenIsJust Nothing _ = return ()
----------
-- Maps --
----------
entities2map :: PersistEntity record => [Entity record] -> Map (Key record) record
entities2map = foldl' (\m entity -> Map.insert (entityKey entity) (entityVal entity) m) Map.empty

17
src/Handler/Utils/Zip.hs
View File

@ -1,5 +1,6 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-} -- This concerns zipEntrySize in produceZip
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -10,6 +11,7 @@ module Handler.Utils.Zip
, produceZip
, consumeZip
, modifyFileTitle
, sourceFiles
) where
import Import
@ -29,6 +31,8 @@ import Data.Time
import Data.List (dropWhileEnd)
import Network.Mime
instance Default ZipInfo where
def = ZipInfo
@ -93,3 +97,16 @@ produceZip info = mapC toZipData =$= void (zipStream zipOptions)
modifyFileTitle :: Monad m => (FilePath -> FilePath) -> Conduit File m File
modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle }
-- Takes FileInfo and if it is a ZIP-Archive, extract files, otherwiese yield fileinfo
sourceFiles :: (MonadResource m, MonadThrow m, MonadIO m) => FileInfo -> Source m File
sourceFiles fInfo
| mimeType == "application/zip" = fileSource fInfo =$= void consumeZip
| otherwise = do
let fileTitle = unpack $ fileName fInfo
fileModified <- liftIO getCurrentTime
yieldM $ do
fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
return File{..}
where
mimeType = defaultMimeLookup (fileName fInfo)

10
src/Model/Types.hs
View File

@ -63,6 +63,16 @@ data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
deriving (Show, Read, Eq, Ord, Enum, Bounded)
derivePersistField "SheetFileType"
instance PathPiece SheetFileType where
toPathPiece SheetExercise = "file"
toPathPiece SheetHint = "hint"
toPathPiece SheetSolution = "solution"
toPathPiece SheetMarking = "marking"
fromPathPiece t =
lookup (CI.mk t) [(CI.mk $ toPathPiece ty,ty) | ty <- [minBound..maxBound]]
data Load = ByTutorial | ByProportion Double
deriving (Show, Read, Eq)
derivePersistField "Load"

20
templates/newSheet.hamlet Normal file
View File

@ -0,0 +1,20 @@
<div .container>
<div .bs-docs-section>
<div .row>
<div .col-lg-12>
<div .page-header>
<h1 #forms>Neuen Blatt anlegen:
<p>
Bitte alles ausfüllen!
<div .row>
<div .col-lg-6>
<div .bs-callout bs-callout-info well>
<form .form-horizontal method=post #forms enctype=#{enc}>
^{wdgt}
<button .btn.btn-primary type="submit">
Blatt anlegen