MultiFileField Sheet
This commit is contained in:
Gregor Kleen
parent
7ee2aac209
commit
1b86abb46d
@ -34,5 +34,6 @@ instance PathPiece UUID where
|
||||
decCryptoIDs [ ''SubmissionId
|
||||
, ''CourseId
|
||||
, ''SheetId
|
||||
, ''FileId
|
||||
]
|
||||
{- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
12
src/Handler/Utils/Form/Types.hs
Normal file
12
src/Handler/Utils/Form/Types.hs
Normal file
@ -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
|
||||
}
|
||||
@ -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>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user