diff --git a/frontend/src/utils/inputs/checkbox.sass b/frontend/src/utils/inputs/checkbox.sass index ab7f0cd11..3842e1bb9 100644 --- a/frontend/src/utils/inputs/checkbox.sass +++ b/frontend/src/utils/inputs/checkbox.sass @@ -89,7 +89,7 @@ \:checked + label::before background-color: white - [disabled] + label + [disabled] + label, [readonly] + label pointer-events: none border: none opacity: 0.6 diff --git a/frontend/src/utils/inputs/radio.sass b/frontend/src/utils/inputs/radio.sass index 0603875aa..f68943142 100644 --- a/frontend/src/utils/inputs/radio.sass +++ b/frontend/src/utils/inputs/radio.sass @@ -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 diff --git a/messages/uniworx/de-de-formal.msg b/messages/uniworx/de-de-formal.msg index efd71068d..2003dd3fc 100644 --- a/messages/uniworx/de-de-formal.msg +++ b/messages/uniworx/de-de-formal.msg @@ -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 diff --git a/models/allocations.model b/models/allocations.model index db56d37cd..a1d254dda 100644 --- a/models/allocations.model +++ b/models/allocations.model @@ -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 diff --git a/models/files.model b/models/files.model index 2ea0569ef..6b2324e55 100644 --- a/models/files.model +++ b/models/files.model @@ -8,7 +8,5 @@ File deriving Show Eq Generic SessionFile - user UserId - reference SessionFileReference file FileId touched UTCTime \ No newline at end of file diff --git a/src/Handler/Allocation/Prios.hs b/src/Handler/Allocation/Prios.hs index ca4b4c499..20b3f5127 100644 --- a/src/Handler/Allocation/Prios.hs +++ b/src/Handler/Allocation/Prios.hs @@ -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 diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 10ab3536b..968e9f06b 100644 --- a/src/Handler/Material.hs +++ b/src/Handler/Material.hs @@ -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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index 07369029f..833811653 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -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 diff --git a/src/Handler/Utils/Csv.hs b/src/Handler/Utils/Csv.hs index 57465d311..4b2d9dcf4 100644 --- a/src/Handler/Utils/Csv.hs +++ b/src/Handler/Utils/Csv.hs @@ -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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 3d7ac307f..ec3735954 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -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) diff --git a/src/Handler/Utils/Form/Types.hs b/src/Handler/Utils/Form/Types.hs index 16c8f0af6..9adb7e83c 100644 --- a/src/Handler/Utils/Form/Types.hs +++ b/src/Handler/Utils/Form/Types.hs @@ -6,5 +6,5 @@ data FileUploadInfo = FileUploadInfo { fuiId :: CryptoUUIDFile , fuiTitle :: FilePath , fuiHtmlId :: Text - , fuiChecked :: Bool + , fuiChecked, fuiSession, fuiForced :: Bool } diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 12e9304b0..6ffbf56fe 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -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 diff --git a/src/Jobs/Handler/PruneFiles.hs b/src/Jobs/Handler/PruneFiles.hs index 43289dab6..be2870fef 100644 --- a/src/Jobs/Handler/PruneFiles.hs +++ b/src/Jobs/Handler/PruneFiles.hs @@ -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 ] diff --git a/src/Model.hs b/src/Model.hs index d5a130d34..56132c831 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -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 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 93799679d..78a88e909 100644 --- a/src/Utils/Form.hs +++ b/src/Utils/Form.hs @@ -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 - - |] - -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 - - |] - 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) diff --git a/src/Utils/Icon.hs b/src/Utils/Icon.hs index 1853c9a88..b9cb8334b 100644 --- a/src/Utils/Icon.hs +++ b/src/Utils/Icon.hs @@ -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 diff --git a/src/Utils/Session.hs b/src/Utils/Session.hs index 51f66105c..14c03770f 100644 --- a/src/Utils/Session.hs +++ b/src/Utils/Session.hs @@ -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) diff --git a/templates/widgets/genericFileField.hamlet b/templates/widgets/genericFileField.hamlet new file mode 100644 index 000000000..2c780cc7f --- /dev/null +++ b/templates/widgets/genericFileField.hamlet @@ -0,0 +1,41 @@ +$newline never + +$maybe ident <- identSecret + + +$if not (null fileInfos) +
_{MsgPreviouslyUploadedInfo} +