diff --git a/src/CryptoID.hs b/src/CryptoID.hs index 25d19fdca..ed2864eab 100644 --- a/src/CryptoID.hs +++ b/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? -} diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index f009c3969..b3fabdceb 100644 --- a/src/Handler/Sheet.hs +++ b/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 template = identForm FIDsheet $ \html -> do - -- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :( - -- Erstmal nur mit ZIP arbeiten +makeSheetForm :: Maybe SheetId -> Maybe SheetForm -> Form SheetForm +makeSheetForm msId template = identForm FIDsheet $ \html -> do + let oldFileIds fType + | 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 tid csh template dbAction = do +handleSheetEdit :: TermId -> Text -> Maybe SheetId -> Maybe SheetForm -> (Sheet -> YesodDB UniWorX (Maybe SheetId)) -> Handler Html +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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index b534f1198..f28154e55 100644 --- a/src/Handler/Utils/Form.hs +++ b/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 = Field{..} +multiFileField :: Handler (Set FileId) -> Field Handler (Source Handler (Either FileId File)) +multiFileField permittedFiles' = Field{..} where fieldEnctype = Multipart fieldParse vals files - | null files = return $ Right Nothing - | [unpackZips] == vals = return . Right . Just $ mapM_ sourceFiles files - | otherwise = return . Right . Just $ C.sourceList files .| C.mapM acceptFile - fieldView fieldId fieldName attrs prev req = $(widgetFile "multiFileField") + | null files + , null vals = return $ Right Nothing + | otherwise = return . Right . Just $ do + 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 diff --git a/src/Handler/Utils/Form/Types.hs b/src/Handler/Utils/Form/Types.hs new file mode 100644 index 000000000..386f029a0 --- /dev/null +++ b/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 + } diff --git a/templates/multiFileField.hamlet b/templates/multiFileField.hamlet index fb315ade7..9a9822c84 100644 --- a/templates/multiFileField.hamlet +++ b/templates/multiFileField.hamlet @@ -1,5 +1,17 @@ $newline never +