refactor(file upload): move to genericFileField
This commit is contained in:
Gregor Kleen
parent
bf74eb5122
commit
192b6279d3
@ -89,7 +89,7 @@
|
||||
\:checked + label::before
|
||||
background-color: white
|
||||
|
||||
[disabled] + label
|
||||
[disabled] + label, [readonly] + label
|
||||
pointer-events: none
|
||||
border: none
|
||||
opacity: 0.6
|
||||
|
||||
@ -38,7 +38,7 @@
|
||||
box-shadow: 0 0 0.125em 0 rgba(50, 115, 220, 0.8)
|
||||
outline: 0
|
||||
|
||||
[disabled] + label
|
||||
[disabled] + label, [readonly] + label
|
||||
pointer-events: none
|
||||
border: none
|
||||
opacity: 0.6
|
||||
|
||||
@ -788,6 +788,9 @@ UploadModeExtensionRestriction: Zulässige Dateiendungen
|
||||
UploadModeExtensionRestrictionTip: Komma-separiert. Wenn keine Dateiendungen angegeben werden erfolgt keine Einschränkung.
|
||||
UploadModeExtensionRestrictionEmpty: Liste von zulässigen Dateiendungen darf nicht leer sein
|
||||
|
||||
GenericFileFieldInvalidExtension file@FilePath: „#{file}” hat keine zulässige Dateiendung
|
||||
FileUploadOnlySessionTip: Sie haben diese Datei in der aktuellen Session bereits hochgeladen, sie ist allerdings noch nicht gespeichert. Sie müssen zunächst noch das Formular „Senden“, damit die Datei ordnungsgemäß gespeichert wird.
|
||||
|
||||
UploadSpecificFiles: Vorgegebene Dateinamen
|
||||
NoUploadSpecificFilesConfigured: Wenn der Abgabemodus vorgegebene Dateinamen vorsieht, muss mindestens ein vorgegebener Dateiname konfiguriert werden.
|
||||
UploadSpecificFilesDuplicateNames: Vorgegebene Dateinamen müssen eindeutig sein
|
||||
|
||||
@ -21,7 +21,7 @@ Allocation -- attributes with prefix staff- affect lecturers only, but are invis
|
||||
registerByCourse UTCTime Maybe -- course registration dates are ignored until this day has passed or always prohibited
|
||||
overrideDeregister UTCTime Maybe -- course deregistration enforced to be this date, i.e. students may disenrol from course after or never
|
||||
-- overrideVisible not needed, since courses are always visible
|
||||
matchingSeed ByteString default=''
|
||||
matchingSeed ByteString default='\x'::bytea
|
||||
TermSchoolAllocationShort term school shorthand -- shorthand must be unique within school and semester
|
||||
TermSchoolAllocationName term school name -- name must be unique within school and semester
|
||||
deriving Show Eq Ord Generic
|
||||
|
||||
@ -8,7 +8,5 @@ File
|
||||
deriving Show Eq Generic
|
||||
|
||||
SessionFile
|
||||
user UserId
|
||||
reference SessionFileReference
|
||||
file FileId
|
||||
touched UTCTime
|
||||
@ -57,8 +57,8 @@ postAPriosR tid ssh ash = do
|
||||
|
||||
formResult priosRes $ \(mode, fInfo) -> do
|
||||
let sourcePrios = case mode of
|
||||
AllocationPrioritiesNumeric -> fileSourceCsvPositional Csv.NoHeader fInfo
|
||||
AllocationPrioritiesOrdinal -> fileSourceCsvPositional Csv.NoHeader fInfo .| C.map Csv.fromOnly .| ordinalPriorities
|
||||
AllocationPrioritiesNumeric -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader
|
||||
AllocationPrioritiesOrdinal -> transPipe liftHandler fInfo .| fileSourceCsvPositional Csv.NoHeader .| C.map Csv.fromOnly .| ordinalPriorities
|
||||
|
||||
(matrSunk, matrMissing) <- runDB $ do
|
||||
Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
||||
|
||||
@ -316,7 +316,9 @@ handleMaterialEdit tid ssh csh cid template dbMaterial = do
|
||||
keep <- execWriterT . runConduit $ transPipe (lift . lift) fs .| C.mapM_ finsert
|
||||
mapM_ deleteCascade (oldFileIds \\ keep :: Set FileId)
|
||||
where
|
||||
finsert (Left fileId) = tell $ singleton fileId
|
||||
finsert (Left fid) = do
|
||||
lift . void $ upsertBy (UniqueMaterialFile mid fid) (MaterialFile mid fid) []
|
||||
tell $ singleton fid
|
||||
finsert (Right file) = lift $ do
|
||||
fid <- insert file
|
||||
void . insert $ MaterialFile mid fid -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
|
||||
|
||||
@ -610,10 +610,10 @@ handleSheetEdit tid ssh csh msId template dbAction = do
|
||||
case mbsid of
|
||||
Nothing -> False <$ addMessageI Error (MsgSheetNameDup tid ssh csh sfName)
|
||||
(Just sid) -> do -- save files in DB:
|
||||
whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise
|
||||
whenIsJust sfHintF $ insertSheetFile' sid SheetHint
|
||||
whenIsJust sfSolutionF $ insertSheetFile' sid SheetSolution
|
||||
whenIsJust sfMarkingF $ insertSheetFile' sid SheetMarking
|
||||
insertSheetFile' sid SheetExercise $ fromMaybe (return ()) sfSheetF
|
||||
insertSheetFile' sid SheetHint $ fromMaybe (return ()) sfHintF
|
||||
insertSheetFile' sid SheetSolution $ fromMaybe (return ()) sfSolutionF
|
||||
insertSheetFile' sid SheetMarking $ fromMaybe (return ()) sfMarkingF
|
||||
insert_ $ SheetEdit aid actTime sid
|
||||
addMessageI Success $ MsgSheetEditOk tid ssh csh sfName
|
||||
-- Sanity checks generating warnings only, but not errors!
|
||||
@ -674,14 +674,6 @@ postSDelR tid ssh csh shn = do
|
||||
}
|
||||
|
||||
|
||||
insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
|
||||
insertSheetFile sid ftype finfo = do
|
||||
runConduit $ sourceFiles finfo .| C.mapM_ finsert
|
||||
where
|
||||
finsert file = 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 -> ConduitT () (Either FileId File) Handler () -> YesodJobDB UniWorX ()
|
||||
insertSheetFile' sid ftype fs = do
|
||||
oldFileIds <- fmap setFromList . fmap (map E.unValue) . E.select . E.from $ \(file `E.InnerJoin` sheetFile) -> do
|
||||
@ -692,7 +684,9 @@ insertSheetFile' sid ftype fs = do
|
||||
keep <- execWriterT . runConduit $ transPipe liftHandler fs .| C.mapM_ finsert
|
||||
mapM_ deleteCascade $ (oldFileIds \\ keep :: Set FileId)
|
||||
where
|
||||
finsert (Left fileId) = tell $ singleton fileId
|
||||
finsert (Left fid) = do
|
||||
lift . void $ upsertBy (UniqueSheetFile fid sid ftype) (SheetFile sid fid ftype) []
|
||||
tell $ singleton fid
|
||||
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
|
||||
|
||||
@ -20,6 +20,8 @@ import Import hiding (Header, mapM_)
|
||||
import Data.Csv
|
||||
import Data.Csv.Conduit
|
||||
|
||||
import Handler.Utils.Form (uploadContents)
|
||||
|
||||
import Control.Monad (mapM_)
|
||||
|
||||
-- import qualified Data.Csv.Util as Csv
|
||||
@ -213,9 +215,8 @@ fileSourceCsv :: ( FromNamedRecord csv
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> FileInfo
|
||||
-> ConduitT () csv m ()
|
||||
fileSourceCsv = (.| decodeCsv) . fileSource
|
||||
=> ConduitT (Either FileId File) csv m ()
|
||||
fileSourceCsv = uploadContents .| decodeCsv
|
||||
|
||||
fileSourceCsvPositional :: ( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
@ -223,9 +224,8 @@ fileSourceCsvPositional :: ( MonadHandler m
|
||||
, FromRecord csv
|
||||
)
|
||||
=> HasHeader
|
||||
-> FileInfo
|
||||
-> ConduitT () csv m ()
|
||||
fileSourceCsvPositional hdr = (.| decodeCsvPositional hdr) . fileSource
|
||||
-> ConduitT (Either FileId File) csv m ()
|
||||
fileSourceCsvPositional hdr = uploadContents .| decodeCsvPositional hdr
|
||||
|
||||
|
||||
instance ToWidget UniWorX CsvRendered where
|
||||
|
||||
@ -40,6 +40,8 @@ import qualified Data.Set as Set
|
||||
import Data.Map ((!), (!?))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import qualified Data.HashMap.Lazy as HashMap
|
||||
|
||||
import Control.Monad.Writer.Class
|
||||
import Control.Monad.Error.Class (MonadError(..))
|
||||
|
||||
@ -48,8 +50,6 @@ import Data.Aeson.Text (encodeToLazyText)
|
||||
|
||||
import qualified Text.Email.Validate as Email
|
||||
|
||||
import Yesod.Core.Types (FileInfo(..))
|
||||
|
||||
import Data.Text.Lens (unpacked)
|
||||
|
||||
import Data.Char (isDigit)
|
||||
@ -57,6 +57,12 @@ import Text.Blaze (toMarkup)
|
||||
|
||||
import Handler.Utils.Form.MassInput
|
||||
|
||||
import qualified Data.Binary as Binary
|
||||
import qualified Data.ByteString.Base64.URL as Base64
|
||||
|
||||
import Data.Time.Clock.System (systemEpochDay)
|
||||
|
||||
|
||||
----------------------------
|
||||
-- Buttons (new version ) --
|
||||
----------------------------
|
||||
@ -824,42 +830,253 @@ pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOp
|
||||
|
||||
|
||||
type FileUploads = ConduitT () (Either FileId File) Handler ()
|
||||
|
||||
|
||||
specificFileField :: UploadSpecificFile -> Field Handler FileUploads
|
||||
specificFileField UploadSpecificFile{..} = Field{..}
|
||||
uploadContents :: (MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT (Either FileId File) ByteString m ()
|
||||
uploadContents = C.mapMaybeM $ either dbContents (return . fileContent)
|
||||
where dbContents = fmap (fileContent =<<) . liftHandler . runDB . get
|
||||
|
||||
data FileFieldUserOption a = FileFieldUserOption
|
||||
{ fieldOptionForce :: Bool
|
||||
, fieldOptionDefault :: a
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
data FileField = FileField
|
||||
{ fieldIdent :: Maybe Text
|
||||
, fieldUnpackZips :: FileFieldUserOption Bool
|
||||
, fieldMultiple :: Bool
|
||||
, fieldRestrictExtensions :: Maybe (NonNull (Set Extension))
|
||||
, fieldAdditionalFiles :: Map FileId (FileFieldUserOption Bool)
|
||||
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
genericFileField :: forall m.
|
||||
( MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> Handler FileField -> Field m FileUploads
|
||||
genericFileField mkOpts = Field{..}
|
||||
where
|
||||
permittedExtension :: FileField -> FileName -> Bool
|
||||
permittedExtension FileField{..} fTitle
|
||||
| Just exts <- fieldRestrictExtensions
|
||||
= anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fTitle) exts
|
||||
| otherwise
|
||||
= True
|
||||
|
||||
getIdent :: forall m'. (MonadHandler m', RenderRoute (HandlerSite m')) => FileField -> m' (Maybe Text)
|
||||
getIdent FileField{..} = do
|
||||
ident <- case fieldIdent of
|
||||
Just ident -> return $ Just ident
|
||||
Nothing -> runMaybeT $ do
|
||||
cRoute <- MaybeT getCurrentRoute
|
||||
pos <- newIdent
|
||||
$logDebugS "genericFileField.getIdent" pos
|
||||
return $ hash (cRoute, pos)
|
||||
& toStrict . Binary.encode
|
||||
& decodeUtf8 . Base64.encode
|
||||
& Text.dropWhileEnd (== '=')
|
||||
$logDebugS "genericFileField.getIdent" $ tshow ident
|
||||
return ident
|
||||
|
||||
getPermittedFiles :: Maybe Text -> FileField -> DB (Map FileId (FileFieldUserOption Bool))
|
||||
getPermittedFiles mIdent opts@FileField{..} = do
|
||||
sessionFiles <- fmap fold . for mIdent $ \fieldIdent' ->
|
||||
fold . (HashMap.lookup fieldIdent' . unMergeHashMap =<<) <$> lookupSessionJson @_ @(MergeHashMap Text (Set SessionFileId)) @_ SessionFiles
|
||||
sessionFiles' <- flip foldMapM sessionFiles $ \sfId -> maybeT (return Map.empty) $ do
|
||||
SessionFile{..} <- MaybeT $ get sfId
|
||||
when (is _Just fieldRestrictExtensions) $ do
|
||||
(fTitle, isDirectory) <- MaybeT . fmap (getFirst . foldMap (First . Just . $(E.unValueN 2))) . E.select . E.from $ \file -> do
|
||||
E.where_ $ file E.^. FileId E.==. E.val sessionFileFile
|
||||
return $ (file E.^. FileTitle, E.isNothing $ file E.^. FileContent)
|
||||
guard $ isDirectory || permittedExtension opts (pack fTitle)
|
||||
return . Map.singleton sessionFileFile $ FileFieldUserOption False True
|
||||
$logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles
|
||||
$logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles'
|
||||
return $ fieldAdditionalFiles <> sessionFiles'
|
||||
|
||||
handleUpload :: Maybe Text -> File -> DB (Maybe FileId)
|
||||
handleUpload mIdent file = do
|
||||
for mIdent $ \ident -> do
|
||||
now <- liftIO getCurrentTime
|
||||
fId <- insert file
|
||||
sfId <- insert $ SessionFile fId now
|
||||
tellSessionJson SessionFiles . MergeHashMap . HashMap.singleton ident $ Set.singleton sfId
|
||||
return fId
|
||||
|
||||
fieldEnctype = Multipart
|
||||
fieldParse _ files
|
||||
| [f] <- files
|
||||
= return . Right . Just $ yieldM (acceptFile f) .| modifyFileTitle (const $ unpack specificFileName) .| C.map Right
|
||||
| null files = return $ Right Nothing
|
||||
| otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile
|
||||
fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/specificFileField")
|
||||
fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads))
|
||||
fieldParse vals files = do
|
||||
opts@FileField{..} <- liftHandler mkOpts
|
||||
|
||||
extensions = fileNameExtensions specificFileName
|
||||
acceptRestricted = not $ null extensions
|
||||
accept = Text.intercalate "," . map ("." <>) $ extensions
|
||||
mIdent <- fmap getFirst . flip foldMapM vals $ \v ->
|
||||
fmap First . runMaybeT . exceptTMaybe $ encodedSecretBoxOpen v
|
||||
|
||||
let
|
||||
decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
|
||||
decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt
|
||||
|
||||
let uploadedFilenames = fileName <$> bool (take 1) id fieldMultiple files
|
||||
|
||||
let
|
||||
doUnpack
|
||||
| fieldOptionForce fieldUnpackZips = fieldOptionDefault fieldUnpackZips
|
||||
| otherwise = unpackZips `elem` vals
|
||||
handleFile :: FileInfo -> ConduitT () File Handler ()
|
||||
handleFile
|
||||
| doUnpack = sourceFiles
|
||||
| otherwise = yieldM . acceptFile
|
||||
|
||||
if | invExt : _ <- filter (not . permittedExtension opts) uploadedFilenames
|
||||
-> do
|
||||
liftHandler . runDB . runConduit $
|
||||
mapM_ (transPipe lift . handleFile) files
|
||||
.| C.mapM_ (void . handleUpload mIdent)
|
||||
return . Left . SomeMessage . MsgGenericFileFieldInvalidExtension $ unpack invExt
|
||||
| otherwise
|
||||
-> do
|
||||
let fSrc = do
|
||||
permittedFiles <- liftHandler . runDB $ getPermittedFiles mIdent opts
|
||||
yieldMany [ Left fId
|
||||
| (fId, FileFieldUserOption{..}) <- Map.toList permittedFiles
|
||||
, fieldOptionForce, fieldOptionDefault
|
||||
]
|
||||
yieldMany vals
|
||||
.| C.mapMaybe fromPathPiece
|
||||
.| C.mapMaybeM (\enc -> fmap (, enc) <$> decrypt' enc)
|
||||
.| C.filter (\(fId, _) -> maybe False (not . fieldOptionForce) $ Map.lookup fId permittedFiles)
|
||||
.| C.filter (\(_, enc) -> fieldMultiple
|
||||
|| ( (bool (\n h -> [n] == h) elem fieldMultiple) enc (mapMaybe fromPathPiece vals)
|
||||
&& null files
|
||||
)
|
||||
)
|
||||
.| C.map (\(fId, _) -> Left fId)
|
||||
mapM_ handleFile (bool (take 1) id fieldMultiple files) .| C.map Right
|
||||
(unsealConduitT -> fSrc', length -> nFiles) <- liftHandler $ fSrc $$+ peekN 2
|
||||
$logDebugS "genericFileField.fieldParse" $ tshow nFiles
|
||||
if
|
||||
| nFiles <= 0 -> return $ Right Nothing
|
||||
| nFiles <= 1 -> return . Right $ Just fSrc'
|
||||
| not fieldMultiple -> do
|
||||
liftHandler . runDB . runConduit $
|
||||
mapM_ (transPipe lift . handleFile) files
|
||||
.| C.mapM_ (void . handleUpload mIdent)
|
||||
return . Left $ SomeMessage MsgOnlyUploadOneFile
|
||||
| otherwise -> return . Right $ Just fSrc'
|
||||
|
||||
fieldView :: FieldViewFunc m FileUploads
|
||||
fieldView fieldId fieldName _attrs val req = do
|
||||
opts@FileField{..} <- liftHandler mkOpts
|
||||
mIdent <- getIdent opts
|
||||
identSecret <- for mIdent $ encodedSecretBox SecretBoxShort
|
||||
|
||||
fileInfos <- liftHandler . runDB $ do
|
||||
permittedFiles <- getPermittedFiles mIdent opts
|
||||
|
||||
let
|
||||
handleReference fId
|
||||
| fId `Map.member` permittedFiles = return $ Just fId
|
||||
| otherwise = return Nothing
|
||||
|
||||
sentVals <- for val $ \src ->
|
||||
fmap Set.fromList . sourceToList
|
||||
$ transPipe lift src
|
||||
.| C.mapMaybeM (either handleReference $ handleUpload mIdent)
|
||||
let
|
||||
toFUI (E.Value fuiId', E.Value fuiTitle) = do
|
||||
fuiId <- encrypt fuiId'
|
||||
let fuiHtmlId = [st|#{fieldId}--#{toPathPiece fuiId}|]
|
||||
fuiChecked
|
||||
| Right sentVals' <- sentVals
|
||||
= fuiId' `Set.member` sentVals'
|
||||
| Just FileFieldUserOption{..} <- Map.lookup fuiId' fieldAdditionalFiles
|
||||
= fieldOptionDefault
|
||||
| otherwise = False
|
||||
fuiSession = fuiId' `Map.notMember` fieldAdditionalFiles
|
||||
fuiForced
|
||||
| Just FileFieldUserOption{..} <- Map.lookup fuiId' permittedFiles
|
||||
= fieldOptionForce
|
||||
| otherwise
|
||||
= False
|
||||
return FileUploadInfo{..}
|
||||
fileInfos' <- mapM toFUI <=< E.select . E.from $ \file -> do
|
||||
E.where_ $ file E.^. FileId `E.in_` E.valList (Set.toList $ fold sentVals <> Map.keysSet permittedFiles)
|
||||
E.orderBy [E.asc $ file E.^. FileTitle]
|
||||
return (file E.^. FileId, file E.^. FileTitle)
|
||||
|
||||
return $ sortOn (splitPath . fuiTitle) fileInfos'
|
||||
|
||||
let
|
||||
mayUnpack = not (fieldOptionForce fieldUnpackZips) || fieldOptionDefault fieldUnpackZips
|
||||
|
||||
zipExtensions = mimeExtensions typeZip
|
||||
|
||||
acceptRestricted = isJust fieldRestrictExtensions
|
||||
accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) mayUnpack ++ toListOf (_Just . re _nullable . folded) fieldRestrictExtensions
|
||||
|
||||
uploadOnlySessionMessage <- messageIconI Warning IconFileUploadSession MsgFileUploadOnlySessionTip
|
||||
|
||||
$(widgetFile "widgets/genericFileField")
|
||||
unpackZips :: Text
|
||||
unpackZips = "unpack-zip"
|
||||
|
||||
|
||||
|
||||
fileFieldMultiple :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m FileUploads
|
||||
fileFieldMultiple = genericFileField $ return FileField
|
||||
{ fieldIdent = Nothing
|
||||
, fieldUnpackZips = FileFieldUserOption True False
|
||||
, fieldMultiple = True
|
||||
, fieldRestrictExtensions = Nothing
|
||||
, fieldAdditionalFiles = Map.empty
|
||||
}
|
||||
|
||||
fileField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m FileUploads
|
||||
fileField = genericFileField $ return FileField
|
||||
{ fieldIdent = Nothing
|
||||
, fieldUnpackZips = FileFieldUserOption True False
|
||||
, fieldMultiple = False
|
||||
, fieldRestrictExtensions = Nothing
|
||||
, fieldAdditionalFiles = Map.empty
|
||||
}
|
||||
|
||||
specificFileField :: UploadSpecificFile -> Field Handler FileUploads
|
||||
specificFileField UploadSpecificFile{..} = convertField fixupFileTitles id . genericFileField $ return FileField
|
||||
{ fieldIdent = Nothing
|
||||
, fieldUnpackZips = FileFieldUserOption True False
|
||||
, fieldMultiple = False
|
||||
, fieldRestrictExtensions = fromNullable . maybe Set.empty (Set.singleton . view _2) . Map.lookupMin . Map.fromList . map (length &&& id) $ fileNameExtensions specificFileName
|
||||
, fieldAdditionalFiles = Map.empty
|
||||
}
|
||||
where
|
||||
fixupFileTitles = flip (.|) . C.mapM $ either (fmap Left . updateFileReference) (fmap Right . updateFile)
|
||||
where updateFileReference fId = runDB . maybeT (return fId) $ do
|
||||
oldTitle <- MaybeT . fmap (getFirst . foldMap (First . Just)) . E.select . E.from $ \file -> do
|
||||
E.where_ $ file E.^. FileId E.==. E.val fId
|
||||
return $ file E.^. FileTitle
|
||||
if | oldTitle == E.Value (unpack specificFileName)
|
||||
-> return fId
|
||||
| otherwise -> lift $ do
|
||||
fId' <- insert $ File (unpack specificFileName) Nothing (toMidnight systemEpochDay) {- temporary -}
|
||||
E.update $ \file' -> do
|
||||
let newModified = E.subSelect . E.from $ \file -> do
|
||||
E.where_ $ file E.^. FileId E.==. E.val fId
|
||||
return $ file E.^. FileModified
|
||||
newContent = E.subSelect . E.from $ \file -> do
|
||||
E.where_ $ file E.^. FileId E.==. E.val fId
|
||||
return $ file E.^. FileContent
|
||||
E.set file' [ FileModified E.=. E.maybe (E.val $ toMidnight systemEpochDay) id newModified, FileContent E.=. E.joinV newContent ]
|
||||
return fId'
|
||||
updateFile = return . set _fileTitle (unpack specificFileName)
|
||||
|
||||
zipFileField :: Bool -- ^ Unpack zips?
|
||||
-> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
|
||||
-> Field Handler FileUploads
|
||||
zipFileField doUnpack permittedExtensions = Field{..}
|
||||
where
|
||||
fieldEnctype = Multipart
|
||||
fieldParse _ files
|
||||
| [f@FileInfo{..}] <- files
|
||||
, maybe True (anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fileName)) permittedExtensions || doUnpack
|
||||
= return . Right . Just $ bool (yieldM . fmap Right . acceptFile) ((.| C.map Right) . sourceFiles) doUnpack f
|
||||
| null files = return $ Right Nothing
|
||||
| otherwise = return . Left $ SomeMessage MsgOnlyUploadOneFile
|
||||
fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/zipFileField")
|
||||
|
||||
zipExtensions = mimeExtensions typeZip
|
||||
|
||||
acceptRestricted = isJust permittedExtensions
|
||||
accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) doUnpack ++ toListOf (_Just . re _nullable . folded) permittedExtensions
|
||||
zipFileField doUnpack permittedExtensions = genericFileField $ return FileField
|
||||
{ fieldIdent = Nothing
|
||||
, fieldUnpackZips = FileFieldUserOption True doUnpack
|
||||
, fieldMultiple = doUnpack
|
||||
, fieldRestrictExtensions = permittedExtensions
|
||||
, fieldAdditionalFiles = Map.empty
|
||||
}
|
||||
|
||||
fileUploadForm :: Bool -- ^ Required?
|
||||
-> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny`
|
||||
@ -887,53 +1104,14 @@ multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .|
|
||||
|
||||
multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference
|
||||
-> Field Handler FileUploads
|
||||
multiFileField permittedFiles' = Field{..}
|
||||
where
|
||||
fieldEnctype = Multipart
|
||||
fieldParse vals files = 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 -> ConduitT () File Handler ()
|
||||
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{..}
|
||||
autoUnzipInfo :: Widget
|
||||
autoUnzipInfo = i18n MsgAutoUnzipInfo
|
||||
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)
|
||||
let fileInfos = sortOn fuiTitle fileInfos'
|
||||
$(widgetFile "widgets/multiFileField")
|
||||
unpackZips :: Text
|
||||
unpackZips = "unpack-zip"
|
||||
takeLefts :: Monad m => ConduitT (Either b a) b m ()
|
||||
takeLefts = awaitForever $ \case
|
||||
Right _ -> return ()
|
||||
Left r -> yield r
|
||||
multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted
|
||||
where mkField permitted = FileField
|
||||
{ fieldIdent = Nothing
|
||||
, fieldUnpackZips = FileFieldUserOption False False
|
||||
, fieldMultiple = True
|
||||
, fieldRestrictExtensions = Nothing
|
||||
, fieldAdditionalFiles = Map.fromSet (const $ FileFieldUserOption False True) permitted
|
||||
}
|
||||
|
||||
data SheetGrading' = Points' | PassPoints' | PassBinary'
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
||||
|
||||
@ -6,5 +6,5 @@ data FileUploadInfo = FileUploadInfo
|
||||
{ fuiId :: CryptoUUIDFile
|
||||
, fuiTitle :: FilePath
|
||||
, fuiHtmlId :: Text
|
||||
, fuiChecked :: Bool
|
||||
, fuiChecked, fuiSession, fuiForced :: Bool
|
||||
}
|
||||
|
||||
@ -377,7 +377,7 @@ data DBCsvMode
|
||||
{ dbCsvExportData :: Dynamic
|
||||
}
|
||||
| DBCsvImport
|
||||
{ dbCsvFiles :: [FileInfo]
|
||||
{ dbCsvFiles :: FileUploads
|
||||
}
|
||||
| DBCsvExportExample
|
||||
| DBCsvAbort
|
||||
@ -1109,7 +1109,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
-> return $ DBCsvDiffExisting rowKey' oldRow row
|
||||
| otherwise
|
||||
-> return $ DBCsvDiffNew rowKey row
|
||||
mapM_ fileSourceCsv dbCsvFiles .| C.mapM toDiff
|
||||
transPipe liftHandler dbCsvFiles .| fileSourceCsv .| C.mapM toDiff
|
||||
|
||||
seen <- State.get
|
||||
forM_ (Map.toList existing) $ \(rowKey, oldRow) -> if
|
||||
|
||||
@ -27,12 +27,12 @@ dispatchJobPruneUnreferencedFiles = do
|
||||
where
|
||||
references :: E.SqlExpr (Entity File) -> [E.SqlQuery ()]
|
||||
references ((E.^. FileId) -> fId) =
|
||||
[ E.from $ \matching -> E.where_ $ matching E.^. AllocationMatchingLog E.==. fId
|
||||
, E.from $ \appInstr -> E.where_ $ appInstr E.^. CourseAppInstructionFileFile E.==. fId
|
||||
, E.from $ \appFile -> E.where_ $ appFile E.^. CourseApplicationFileFile E.==. fId
|
||||
[ E.from $ \appFile -> E.where_ $ appFile E.^. CourseApplicationFileFile E.==. fId
|
||||
, E.from $ \matFile -> E.where_ $ matFile E.^. MaterialFileFile E.==. fId
|
||||
, E.from $ \newsFile -> E.where_ $ newsFile E.^. CourseNewsFileFile E.==. fId
|
||||
, E.from $ \sessFile -> E.where_ $ sessFile E.^. SessionFileFile E.==. fId
|
||||
, E.from $ \sheetFile -> E.where_ $ sheetFile E.^. SheetFileFile E.==. fId
|
||||
, E.from $ \appInstr -> E.where_ $ appInstr E.^. CourseAppInstructionFileFile E.==. fId
|
||||
, E.from $ \matching -> E.where_ $ matching E.^. AllocationMatchingLog E.==. fId
|
||||
, E.from $ \subFile -> E.where_ $ subFile E.^. SubmissionFileFile E.==. fId
|
||||
, E.from $ \sessFile -> E.where_ $ sessFile E.^. SessionFileFile E.==. fId
|
||||
]
|
||||
|
||||
@ -38,6 +38,8 @@ deriving newtype instance ToJSONKey UserId
|
||||
deriving newtype instance FromJSONKey UserId
|
||||
deriving newtype instance ToJSONKey ExamOccurrenceId
|
||||
deriving newtype instance FromJSONKey ExamOccurrenceId
|
||||
deriving newtype instance ToJSONKey FileId
|
||||
deriving newtype instance FromJSONKey FileId
|
||||
|
||||
-- ToMarkup and ToMessage instances for displaying selected database primary keys
|
||||
|
||||
|
||||
@ -672,32 +672,6 @@ secretJsonField :: forall m a.
|
||||
=> Field m a
|
||||
secretJsonField = secretJsonField' $ fieldView (hiddenField :: Field m Text)
|
||||
|
||||
fileFieldMultiple :: Monad m => Field m [FileInfo]
|
||||
fileFieldMultiple = Field{..}
|
||||
where
|
||||
fieldEnctype = Multipart
|
||||
fieldParse _ files = return $ case files of
|
||||
[] -> Right Nothing
|
||||
fs -> Right $ Just fs
|
||||
fieldView id' name attrs _ isReq =
|
||||
[whamlet|
|
||||
$newline never
|
||||
<input type="file" uw-file-input ##{id'} name=#{name} *{attrs} multiple :isReq:required>
|
||||
|]
|
||||
|
||||
fileField :: Monad m => Field m FileInfo
|
||||
fileField = Field{..}
|
||||
where
|
||||
fieldEnctype = Multipart
|
||||
fieldParse _ files = return $ case files of
|
||||
[] -> Right Nothing
|
||||
f : _ -> Right $ Just f
|
||||
fieldView id' name attrs _ isReq =
|
||||
[whamlet|
|
||||
$newline never
|
||||
<input type=file uw-file-input ##{id'} name=#{name} *{attrs} :isReq:required>
|
||||
|]
|
||||
|
||||
guardField :: Functor m => (a -> Bool) -> Field m a -> Field m a
|
||||
guardField p field = field { fieldParse = \ts fs -> fieldParse field ts fs <&> \case
|
||||
Right (Just x)
|
||||
|
||||
@ -83,6 +83,7 @@ data Icon
|
||||
| IconPageActionPrimaryExpand | IconPageActionSecondary
|
||||
| IconBreadcrumbSeparator
|
||||
| IconMissingAllocationPriority
|
||||
| IconFileUploadSession
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic, Typeable)
|
||||
|
||||
iconText :: Icon -> Text
|
||||
@ -144,6 +145,7 @@ iconText = \case
|
||||
IconPageActionSecondary -> "ellipsis-h"
|
||||
IconBreadcrumbSeparator -> "angle-right"
|
||||
IconMissingAllocationPriority -> "empty-set"
|
||||
IconFileUploadSession -> "file-upload"
|
||||
|
||||
instance Universe Icon
|
||||
instance Finite Icon
|
||||
|
||||
@ -16,6 +16,7 @@ data SessionKey = SessionActiveAuthTags | SessionInactiveAuthTags
|
||||
| SessionAllocationResults
|
||||
| SessionLang
|
||||
| SessionError
|
||||
| SessionFiles
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
|
||||
41
templates/widgets/genericFileField.hamlet
Normal file
41
templates/widgets/genericFileField.hamlet
Normal file
@ -0,0 +1,41 @@
|
||||
$newline never
|
||||
|
||||
$maybe ident <- identSecret
|
||||
<input type=hidden name=#{fieldName} id=#{fieldId}--ident value=#{ident}>
|
||||
|
||||
$if not (null fileInfos)
|
||||
<div .file-uploads-label>_{MsgPreviouslyUploadedInfo}
|
||||
<ul .list--iconless .file-input__list>
|
||||
$forall FileUploadInfo{..} <- fileInfos
|
||||
<li>
|
||||
<div .file-container>
|
||||
<input type=checkbox id=#{fuiHtmlId} name=#{fieldName} :fuiChecked:checked value=#{toPathPiece fuiId} :fuiForced:readonly>
|
||||
$if fuiSession
|
||||
^{messageTooltip uploadOnlySessionMessage}
|
||||
<label for=#{fuiHtmlId}>
|
||||
#{fuiTitle}
|
||||
|
||||
<div .file-input__info>
|
||||
_{MsgPreviouslyUploadedDeletionInfo}
|
||||
|
||||
<div .file-uploads-label>_{MsgAddMoreFiles}
|
||||
|
||||
$# new files
|
||||
<input type="file" uw-file-input name=#{fieldName} id=#{fieldId} :fieldMultiple:multiple :acceptRestricted:accept=#{accept} :req && null fileInfos:required>
|
||||
|
||||
$if fieldMultiple
|
||||
<div .file-input__info>
|
||||
_{MsgMultiFileUploadInfo}
|
||||
|
||||
$maybe exts <- fmap toNullable fieldRestrictExtensions
|
||||
<div .file-input__info>
|
||||
_{MsgUploadModeExtensionRestriction}: #
|
||||
<ul .list--inline .list--comma-separated .list--iconless>
|
||||
$forall ext <- bool id (mappend zipExtensions) mayUnpack exts
|
||||
<li style="font-family: monospace">#{ext}
|
||||
|
||||
$if not (fieldOptionForce fieldUnpackZips)
|
||||
<div .file-input__unpack>
|
||||
^{iconTooltip (i18n MsgAutoUnzipInfo) Nothing False}
|
||||
<label for=#{fieldId}_zip>_{MsgAutoUnzip}
|
||||
<input type=checkbox id=#{fieldId}--zip name=#{fieldName} value=#{unpackZips} :fieldOptionDefault fieldUnpackZips:checked>
|
||||
Loading…
Reference in New Issue
Block a user