MultiFileField Sheet

src/CryptoID.hs

@@ -34,5 +34,6 @@ instance PathPiece UUID where
 decCryptoIDs [ ''SubmissionId
              , ''CourseId
              , ''SheetId
+             , ''FileId
              ]
 {- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}

src/Handler/Sheet.hs

@@ -20,7 +20,7 @@ import Handler.Utils.Zip
 import qualified Data.Text as T
 -- import Data.Function ((&))
 -- 
-import Colonnade hiding (fromMaybe)
+import Colonnade hiding (fromMaybe, singleton)
 import Yesod.Colonnade
 -- 
 import qualified Data.UUID.Cryptographic as UUID
@@ -29,8 +29,12 @@ import qualified Data.Conduit.List as C
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Internal.Sql as E
 
+import Control.Monad.Writer (MonadWriter(..), execWriterT)
+
 import Network.Mime
 
+import qualified Data.Set as Set
+
 
 instance Eq (Unique Sheet) where
   (CourseSheet cid1 name1) == (CourseSheet cid2 name2) =
@@ -51,7 +55,7 @@ data SheetForm = SheetForm
       , sfVisibleFrom  :: Maybe UTCTime
       , sfActiveFrom   :: UTCTime
       , sfActiveTo     :: UTCTime
-      , sfSheetF       :: Maybe (Source Handler File)
+      , sfSheetF       :: Maybe (Source Handler (Either FileId File))
       , sfHintFrom     :: Maybe UTCTime
       , sfHintF        :: Maybe FileInfo
       , sfSolutionFrom :: Maybe UTCTime
@@ -60,10 +64,16 @@ data SheetForm = SheetForm
       }
 
 
-makeSheetForm :: Maybe SheetForm -> Form SheetForm
+makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm
-makeSheetForm template = identForm FIDsheet $ \html -> do
+makeSheetForm msId template = identForm FIDsheet $ \html -> do
-    -- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :(
+    let oldFileIds fType
-    -- Erstmal nur mit ZIP arbeiten
+          | Just sId <- msId = fmap setFromList . fmap (map E.unValue) . runDB . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
+              E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
+              E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val sId
+                   E.&&. sheetFile E.^. SheetFileType    E.==. E.val fType
+              return (file E.^. FileId)
+          | otherwise = return Set.empty
+  
     (result, widget) <- flip (renderAForm FormStandard) html $ SheetForm
       <$> areq textField      (fsb "Name")                     (sfName <$> template)
       <*> aopt htmlField      (fsb "Hinweise für Teilnehmer")  (sfDescription <$> template)
@@ -73,7 +83,7 @@ makeSheetForm template = identForm FIDsheet $ \html -> do
       <*> aopt utcTimeField   (fsb "Sichtbar ab") (sfVisibleFrom  <$> template)
       <*> areq utcTimeField   (fsb "Abgabe ab")   (sfActiveFrom   <$> template)
       <*> areq utcTimeField   (fsb "Abgabefrist") (sfActiveTo     <$> template)
-      <*> aopt multiFileField (fsb "Aufgabenstellung") (error "No defaults for file uploads")
+      <*> aopt (multiFileField $ oldFileIds SheetExercise) (fsb "Aufgabenstellung") (sfSheetF <$> template)
       <*> aopt utcTimeField   (fsb "Hinweis ab")  (sfHintFrom     <$> template)
       <*> fileAFormOpt        (fsb "Hinweis")
       <*> aopt utcTimeField   (fsb "Lösung ab")   (sfSolutionFrom <$> template)
@@ -250,7 +260,7 @@ getSheetNewR tid csh = do
   let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
   let action newSheet = -- More specific error message for new sheet could go here, if insertUnique returns Nothing
         insertUnique $ newSheet
-  handleSheetEdit tid csh template action
+  handleSheetEdit tid csh Nothing template action
 
 postSheetNewR :: TermId -> Text -> Handler Html
 postSheetNewR = getSheetNewR
@@ -258,7 +268,14 @@ postSheetNewR = getSheetNewR
 
 getSheetEditR :: TermId -> Text -> Text -> Handler Html
 getSheetEditR tid csh shn = do
-  sheetEnt <- runDB $ fetchSheet tid csh shn
+  (sheetEnt, sheetFileIds) <- runDB $ do
+    ent <- fetchSheet tid csh shn
+    fIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
+      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
+      E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val (entityKey ent)
+           E.&&. sheetFile E.^. SheetFileType    E.==. E.val SheetExercise
+      return (file E.^. FileId)
+    return (ent, fIds)
   let sid = entityKey sheetEnt
   let oldSheet@(Sheet {..}) = entityVal sheetEnt
   let template = Just $ SheetForm
@@ -270,7 +287,7 @@ getSheetEditR tid csh shn = do
         , sfVisibleFrom  = sheetVisibleFrom
         , sfActiveFrom   = sheetActiveFrom
         , sfActiveTo     = sheetActiveTo
-        , sfSheetF       = Nothing -- TODO
+        , sfSheetF       = Just . yieldMany . map Left $ Set.toList sheetFileIds
         , sfHintFrom     = sheetHintFrom
         , sfHintF        = Nothing -- TODO
         , sfSolutionFrom = sheetSolutionFrom
@@ -283,17 +300,17 @@ getSheetEditR tid csh shn = do
         case replaceRes of
           Nothing     -> return $ Just sid
           (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here
-  handleSheetEdit tid csh template action
+  handleSheetEdit tid csh (Just sid) template action
 
 postSheetEditR :: TermId -> Text -> Text -> Handler Html
 postSheetEditR = getSheetEditR
 
-handleSheetEdit :: TermId -> Text -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
+handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html
-handleSheetEdit tid csh template dbAction = do
+handleSheetEdit tid csh msId template dbAction = do
   let tident = unTermKey tid
   let mbshn  = sfName <$> template
   aid  <- requireAuthId
-  ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm template
+  ((res,formWidget), formEnctype) <- runFormPost $ makeSheetForm msId template
   case res of
     (FormSuccess SheetForm{..}) -> do
       saveOkay <- runDB $ do
@@ -374,10 +391,17 @@ insertSheetFile sid ftype finfo = do
       fid <- insert file
       void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
 
-insertSheetFile' :: SheetId -> SheetFileType -> Source Handler File -> YesodDB UniWorX ()
+insertSheetFile' :: SheetId -> SheetFileType -> Source Handler (Either FileId File) -> YesodDB UniWorX ()
 insertSheetFile' sid ftype fs = do
-    runConduit $ transPipe lift fs =$= C.mapM_ finsert
+    oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
+      E.on $ file E.^. FileId E.==. sheetFile E.^. SheetFileFileId
+      E.where_ $ sheetFile E.^. SheetFileSheetId E.==. E.val sid
+           E.&&. sheetFile E.^. SheetFileType    E.==. E.val ftype
+      return (file E.^. FileId)
+    keep <- execWriterT . runConduit $ transPipe (lift . lift) fs =$= C.mapM_ finsert
+    mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
   where
-    finsert file = do
+    finsert (Left fileId) = tell $ singleton fileId
+    finsert (Right file) = lift $ do
       fid <- insert file
       void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step

src/Handler/Utils/Form.hs

@@ -8,9 +8,13 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ViewPatterns #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE LambdaCase #-}
 
 module Handler.Utils.Form where
 
+import Handler.Utils.Form.Types
+
 import Import
 import qualified Data.Char as Char
 import Handler.Utils.DateTime
@@ -31,6 +35,11 @@ import Web.PathPieces (showToPathPiece, readFromPathPiece)
 import Handler.Utils.Zip
 import qualified Data.Conduit.List as C
 
+import qualified Database.Esqueleto as E
+import qualified Database.Esqueleto.Internal.Sql as E
+
+import qualified Data.Set as Set
+
 ------------------------------------------------
 -- Unique Form Identifiers to avoid accidents --
 ------------------------------------------------
@@ -236,17 +245,54 @@ schoolEntField = selectField schools
   where
     schools = optionsPersist [] [Asc SchoolName] schoolName
 
-multiFileField :: Field Handler (Source Handler File)
+multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either FileId File))
-multiFileField = Field{..}
+multiFileField permittedFiles' = Field{..}
   where
     fieldEnctype = Multipart
     fieldParse vals files
-      | null files = return $ Right Nothing
+      | null files
-      | [unpackZips] == vals = return . Right . Just $ mapM_ sourceFiles files
+      , null vals = return $ Right Nothing
-      | otherwise = return . Right . Just $ C.sourceList files .| C.mapM acceptFile
+      | otherwise = return . Right . Just $ do
-    fieldView fieldId fieldName attrs prev req = $(widgetFile "multiFileField")
+          pVals <- lift permittedFiles'
+          let
+            decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
+            decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt 
+          yieldMany vals
+            .| C.filter (/= unpackZips)
+            .| C.map fromPathPiece .| C.catMaybes
+            .| C.mapMaybeM decrypt'
+            .| C.filter (`elem` pVals)
+            .| C.map Left
+          let
+            handleFile :: FileInfo -> Source Handler File
+            handleFile
+              | doUnpack  = sourceFiles
+              | otherwise = yieldM . acceptFile
+          mapM_ handleFile files .| C.map Right
+      where
+        doUnpack = unpackZips `elem` vals
+    fieldView fieldId fieldName attrs val req = do
+      pVals <- handlerToWidget permittedFiles'
+      sentVals <- for val $ \src -> handlerToWidget . sourceToList $ src .| takeLefts
+      let
+        toFUI (E.Value fuiId', E.Value fuiTitle) = do
+          fuiId <- encrypt fuiId'
+          fuiHtmlId <- newIdent
+          let fuiChecked
+                | Right sentVals' <- sentVals = fuiId' `elem` sentVals'
+                | otherwise = True
+          return FileUploadInfo{..}     
+      fileInfos <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
+          E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals)
+          E.orderBy [E.asc $ file E.^. FileTitle]
+          return (file E.^. FileId, file E.^. FileTitle)
+      $(widgetFile "multiFileField")
     unpackZips :: Text
     unpackZips = "unpack-zip"
+    takeLefts :: Monad m => ConduitM (Either b a) b m ()
+    takeLefts = awaitForever $ \case
+      Right _ -> return ()
+      Left  r -> yield r
 
 sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
 sheetTypeAFormReq d Nothing =
@@ -338,3 +384,25 @@ setTooltip :: String -> FieldSettings site -> FieldSettings site
 setTooltip tt fs
   | null tt   = fs { fsTooltip = Nothing }
   | otherwise = fs { fsTooltip = Just $ fromString tt }
+
+optionsPersistCryptoId :: forall site backend a msg.
+                          ( YesodPersist site
+                          , PersistQueryRead backend
+                          , HasCryptoUUID (Key a) (HandlerT site IO)
+                          , RenderMessage site msg
+                          , YesodPersistBackend site ~ backend
+                          , PersistRecordBackend a backend
+                          )
+                       => [Filter a]
+                       -> [SelectOpt a]
+                       -> (a -> msg)
+                       -> HandlerT site IO (OptionList (Key a))
+optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
+  mr <- getMessageRender
+  pairs <- runDB $ selectList filts ords
+  cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e
+  return $ map (\(cId, Entity key value) -> Option
+                 { optionDisplay = mr (toDisplay value)
+                 , optionInternalValue = key
+                 , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
+                 }) cPairs

src/Handler/Utils/Form/Types.hs

@@ -0,0 +1,12 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Handler.Utils.Form.Types where
+
+import Import
+
+data FileUploadInfo = FileUploadInfo
+  { fuiId :: CryptoUUIDFile
+  , fuiTitle :: FilePath
+  , fuiHtmlId :: Text
+  , fuiChecked :: Bool
+  }

templates/multiFileField.hamlet

@@ -1,5 +1,17 @@
 $newline never
+
 <input type=checkbox id=#{fieldId}_zip name=#{fieldName} value=#{unpackZips} :req:required>
 <label for=#{fieldId}_zip>
   ZIPs entpacken
-<input type=file id=#{fieldId} name=#{fieldName}>
+
+
+<ul>
+  $forall FileUploadInfo{..} <- fileInfos
+    <li>
+      <input type=checkbox name=#{fieldName} value=#{toPathPiece fuiId} id=#{fuiHtmlId} :fuiChecked:checked>
+      <span style="display:none">
+        #{fuiTitle}
+      <label for=#{fuiHtmlId}>
+        #{fuiTitle}
+  <li>
+    <input type=file id=#{fieldId} name=#{fieldName} multiple>