Download of multiple Submissions & Additional colonnade wrapper

package.yaml

@@ -69,6 +69,7 @@ dependencies:
 - esqueleto
 - mime-types
 - generic-deriving
+- blaze-html
 
 # The library contains all of our application code. The executable
 # defined below is just a thin wrapper.

routes

@@ -20,6 +20,7 @@
 
 /submission                 SubmissionListR GET
 /submission/#CryptoUUIDSubmission SubmissionR GET POST
+/submissions.zip SubmissionDownloadMultiArchiveR POST
 !/submission/archive/#FilePath SubmissionDownloadArchiveR GET
 !/submission/#CryptoUUIDSubmission/#FilePath SubmissionDownloadSingleR GET
 

src/Foundation.hs

@@ -177,6 +177,7 @@ instance Yesod UniWorX where
     isAuthorized (SubmissionR _)      _ = return Authorized
     isAuthorized (SubmissionDownloadSingleR _ _) _ = return Authorized
     isAuthorized (SubmissionDownloadArchiveR _) _ = return Authorized
+    isAuthorized SubmissionDownloadMultiArchiveR _ = return Authorized
     -- TODO: change to Assistants    
     isAuthorized TermEditR              _ = return Authorized
     isAuthorized (TermEditExistR _)     _ = return Authorized    

src/Handler/Submission.hs

@@ -33,15 +33,43 @@ import qualified Data.Conduit.List as Conduit
 
 import System.FilePath
 
+import Colonnade
+import Yesod.Colonnade
+import qualified Text.Blaze.Html5.Attributes as HA
+
+submissionTable :: MForm Handler (FormResult [SubmissionId], Widget)
+submissionTable = do
+  subs <- lift . runDB $ E.select . E.from $ \(sub `E.InnerJoin` sheet `E.InnerJoin` course) -> do
+    E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
+    E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheetId
+
+    return (sub, sheet, course)
+
+  cIDKey <- getsYesod appCryptoIDKey
+  cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) ->
+    (,,) <$> Base32.encrypt cIDKey submissionId <*> UUID.encrypt cIDKey submissionId <*> pure s
+
+  let
+    anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR (unTermKey courseTermId) courseShorthand
+    courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
+    anchorSubmission (_, cUUID, _) = SubmissionR cUUID
+    submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
+    colonnade = mconcat
+      [ headed "Abgabe-ID" $ anchorCell anchorSubmission submissionText
+      , headed "Kurs" $ anchorCell anchorCourse courseText
+      , headed "Blatt" $ \(_, _, (_, Entity _ Sheet{..}, _)) -> textCell $ sheetName
+      ]
+    toExternal :: (CryptoFileNameSubmission, CryptoUUIDSubmission, a) -> Handler CryptoUUIDSubmission
+    toExternal (_, cID, _) = return cID
+    fromExternal :: CryptoUUIDSubmission -> Handler SubmissionId
+    fromExternal = UUID.decrypt cIDKey
+  headedRowSelector toExternal fromExternal (HA.class_ "table table-striped table-hover") colonnade cryptedSubs
+
 
 getSubmissionListR :: Handler Html
 getSubmissionListR = do
-  entityList <- runDB $ selectList [] []
+  (submissionTable, selectEncoding) <- generateFormPost . withFragment $ submissionTable
-  cIDKey <- getsYesod appCryptoIDKey
+  
-  let
-    cryptEntity :: Entity Submission -> Handler (CryptoUUIDSubmission, Submission)
-    cryptEntity (Entity key val) = (, val) <$> UUID.encrypt cIDKey key
-  submissionList <- mapM cryptEntity entityList
   defaultLayout $(widgetFile "submission-list")
 
 getSubmissionDownloadSingleR :: CryptoUUIDSubmission -> FilePath -> Handler TypedContent
@@ -71,6 +99,56 @@ getSubmissionDownloadSingleR cID path = do
           [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c)
           _ -> notFound
 
+submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
+submissionFileSource submissionID = E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
+  E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
+  E.where_ $ sf E.^. SubmissionFileSubmissionId E.==. E.val submissionID
+  E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion
+  E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
+  return f
+
+postSubmissionDownloadMultiArchiveR :: Handler TypedContent
+postSubmissionDownloadMultiArchiveR = do
+  ((selectResult, _), _) <- runFormPost . withFragment $ submissionTable
+
+  case selectResult of
+    FormMissing -> invalidArgs ["Missing submission numbers"]
+    FormFailure errs -> invalidArgs errs
+    FormSuccess ids -> do
+      (dbrunner, cleanup) <- getDBRunner
+
+      ratedSubmissions <- runDBRunner dbrunner $ do
+        submissions <- selectList [ SubmissionId <-. ids ] []
+        forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
+  
+      (<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
+        let
+          fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
+          fileEntitySource' (rating, Entity submissionID Submission{..}) = do
+            cID <- lift $ do
+              cIDKey <- getsYesod appCryptoIDKey
+              Base32.encrypt cIDKey submissionID
+
+            let
+              directoryName = Text.unpack . CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
+              
+              fileEntitySource = do
+                submissionFileSource submissionID =$= Conduit.map entityVal
+                yieldM (ratingFile cID rating)
+
+              withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
+
+            yield $ File
+              { fileModified = submissionChanged
+              , fileTitle = directoryName
+              , fileContent = Nothing
+              }
+
+            fileEntitySource =$= mapC withinDirectory
+          
+        mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
+
+
 getSubmissionDownloadArchiveR :: FilePath -> Handler TypedContent
 getSubmissionDownloadArchiveR path = do
   let (baseName, ext) = splitExtension path
@@ -85,13 +163,8 @@ getSubmissionDownloadArchiveR path = do
     case rating of
       Nothing -> lift notFound
       Just rating' -> do
-        let fileEntitySource = E.selectSource . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
+        let fileEntitySource' :: Source (YesodDB UniWorX) File
-              E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFileId)
+            fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating')
-              E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion
-              E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
-              return f
-            fileEntitySource' :: Source (YesodDB UniWorX) File
-            fileEntitySource' = fileEntitySource =$= Conduit.map entityVal >> yieldM (ratingFile cID rating')
             info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) }
         fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder
 

src/Handler/Utils.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts #-}
 
 module Handler.Utils
   ( module Handler.Utils
@@ -16,6 +17,12 @@ import Handler.Utils.Zip as Handler.Utils
 import Handler.Utils.Rating as Handler.Utils
 import Handler.Utils.Submission as Handler.Utils
 
+import Text.Blaze (Markup)
+
 
 tickmark :: IsString a => a
 tickmark = fromString "✔"
+
+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)

src/Handler/Utils/Table.hs

@@ -1,5 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TypeFamilies #-}
 
 module Handler.Utils.Table where
 -- General Utilities for Tables
@@ -8,11 +10,16 @@ import Import hiding  ((<>))
 -- import Data.Monoid ((<>))
 import Data.Profunctor
 
+import Control.Monad.Except
+
 import Text.Blaze as B
 
 import Colonnade
 import Yesod.Colonnade
 
+import Data.List ((!!))
+import Data.Either
+
 
 -- Table design
 tableDefault :: Attribute
@@ -34,4 +41,50 @@ encodeHeadedWidgetTableNumbered attrs colo tdata =
     numberCol :: Colonnade Headed (Int,a) (WidgetT site IO ())
     numberCol = headed "Nr" (fromString.show.fst)    
   
+headedRowSelector :: ( PathPiece b
+                     , Eq b
+                     )
+                  => (a -> Handler b)
+                  -> (b -> Handler c)
+                  -> Attribute
+                  -> Colonnade Headed a (Cell UniWorX)
+                  -> [a]
+                  -> MForm Handler (FormResult [c], Widget)
+headedRowSelector toExternal fromExternal attrs colonnade tdata = do
+  externalIds <- mapM (lift . toExternal) tdata
+
+  let
+    checkbox externalId = Field parse view UrlEncoded
+      where
+        parse [] _ = return $ Right Nothing
+        parse optlist _ = runExceptT $ do
+          externalIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist
+          case () of
+            _ | externalId `elem` externalIds
+                -> Just <$> (lift $ fromExternal externalId)
+              | otherwise
+                -> return Nothing
+
+        view _ name attrs val _ = do
+          [whamlet|
+            <label style="display: block">
+              <input type=checkbox name=#{name} value=#{toPathPiece externalId} *{attrs} :isRight val:checked>
+          |]
+
+  selectionIdent <- newFormIdent
+
+  (selectionResults, selectionBoxes) <- fmap unzip . forM externalIds $ \id -> mopt (checkbox id) ("" { fsName = Just selectionIdent }) Nothing
   
+  let
+    selColonnade :: Colonnade Headed Int (Cell UniWorX)
+    selColonnade = headed "Markiert" $ cell . fvInput . (selectionBoxes !!)
+
+    collectResult :: [FormResult a] -> FormResult [a]
+    collectResult [] = FormSuccess []
+    collectResult (FormFailure errs : _) = FormFailure errs
+    collectResult (FormMissing:rs) = collectResult rs
+    collectResult (FormSuccess x:rs) = (x :) <$> collectResult rs
+
+  return ( catMaybes <$> collectResult selectionResults
+         , encodeHeadedCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata)
+         )

src/Handler/Utils/Zip.hs

@@ -9,12 +9,11 @@ module Handler.Utils.Zip
   , ZipInfo(..)
   , produceZip
   , consumeZip
+  , modifyFileTitle
   ) where
 
 import Import
 
-import qualified Data.Conduit.List as Conduit (map)
-
 import Codec.Archive.Zip.Conduit.Types
 import Codec.Archive.Zip.Conduit.UnZip
 import Codec.Archive.Zip.Conduit.Zip
@@ -77,7 +76,7 @@ produceZip :: ( MonadBase b m
               , MonadThrow m
               ) => ZipInfo
               -> Conduit File m ByteString
-produceZip info = Conduit.map toZipData =$= void (zipStream zipOptions)
+produceZip info = mapC toZipData =$= void (zipStream zipOptions)
   where
     zipOptions = ZipOptions
       { zipOpt64 = True
@@ -95,3 +94,6 @@ produceZip info = Conduit.map toZipData =$= void (zipStream zipOptions)
       }
       where
         isDir = isNothing fileContent
+
+modifyFileTitle :: Monad m => (FilePath -> FilePath) -> Conduit File m File
+modifyFileTitle f = mapC $ \x@File{..} -> x{ fileTitle = f fileTitle }

templates/submission-list.hamlet

@@ -1,4 +1,3 @@
-<ul>
+<form method=POST enctype=#{selectEncoding} target=_blank action=@{SubmissionDownloadMultiArchiveR}>
-  $forall (cID, _) <- submissionList
+  ^{submissionTable}
-    <li>
+  <button type=submit >Markierte herunterladen
-      <a href=@{SubmissionR cID}>#{tshow $ ciphertext cID}