SheetFile Up/Download added

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/#TermIdentifier/#Text/sheet/                SheetListR   GET
-/course/#CourseId/sheet/                            SheetListCID GET
+/course/#TermIdentifier/#Text/sheet/#Text/show      SheetShowR   GET
-/course/#TermIdentifier/#Text/sheet/#Text/show      SheetShowR  GET
+/course/#TermIdentifier/#Text/sheet/#Text/#SheetFileType/#FilePath SheetFileR  GET
-/sheet/#SheetId/show                                SheetIdShowR GET
+/course/#TermIdentifier/#Text/sheet/new             SheetNewR   GET POST
-/sheetuuid/#CryptoUUIDSheet/show                    SheetUUIDShowR GET
-/course/#TermIdentifier/#Text/sheet/new             SheetNewR   GET
 /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

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)

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

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
 
-

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)

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"

templates/newSheet.hamlet

@@ -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
+
+