diff --git a/routes b/routes index 6f85b0dfe..0d1caa0c8 100644 --- a/routes +++ b/routes @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 60ca35d2a..3af180e40 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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) diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 19e42a872..7f3e3e4dd 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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 diff --git a/src/Handler/Utils.hs b/src/Handler/Utils.hs index fa6b148de..8f43426b3 100644 --- a/src/Handler/Utils.hs +++ b/src/Handler/Utils.hs @@ -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 - diff --git a/src/Handler/Utils/Zip.hs b/src/Handler/Utils/Zip.hs index ba23903b9..06405b8d6 100644 --- a/src/Handler/Utils/Zip.hs +++ b/src/Handler/Utils/Zip.hs @@ -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) diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 46a5131a6..1a389cd44 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -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" diff --git a/templates/newSheet.hamlet b/templates/newSheet.hamlet new file mode 100644 index 000000000..83a5a3606 --- /dev/null +++ b/templates/newSheet.hamlet @@ -0,0 +1,20 @@ +
+
+
+
+
+

Neuen Blatt anlegen: + +

+ Bitte alles ausfüllen! + +

+
+
+
+ ^{wdgt} + +