fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

refactor: unify FileUploads type

Browse Source
This commit is contained in:
Gregor Kleen 2019-11-04 15:20:34 +01:00
parent 954bb78aae
commit 766ca63b40
5 changed files with 34 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
src/Handler/Allocation/Application.hs
View File

@ -52,7 +52,7 @@ data ApplicationForm = ApplicationForm
{ afPriority :: Maybe Natural
, afField :: Maybe StudyFeaturesId
, afText :: Maybe Text
, afFiles :: Maybe (ConduitT () File Handler ())
, afFiles :: Maybe FileUploads
, afRatingVeto :: Bool
, afRatingPoints :: Maybe ExamGrade
, afRatingComment :: Maybe Text
@ -291,8 +291,9 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
, courseApplicationRatingTime = guardOn rated now
}
let
sinkFile' file = do
fId <- insert file
sinkFile' (Right file) =
insert file >>= sinkFile' . Left
sinkFile' (Left fId) =
insert_ $ CourseApplicationFile appId fId
forM_ afFiles $ \afFiles' ->
runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
@ -308,7 +309,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
| afmApplicantEdit afMode -> do
oldFiles <- Set.fromList . map (courseApplicationFileFile . entityVal) <$> selectList [CourseApplicationFileApplication ==. appId] []
changes <- flip execStateT oldFiles . forM_ afFiles $ \afFiles' ->
let sinkFile' file = do
let sinkFile' (Right file) = do
oldFiles' <- lift . E.select . E.from $ \(courseApplicationFile `E.InnerJoin` file') -> do
E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file' E.^. FileId
E.where_ $ file' E.^. FileTitle E.==. E.val (fileTitle file)
@ -326,7 +327,12 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
fId <- lift $ insert file
lift . insert_ $ CourseApplicationFile appId fId
modify $ Set.insert fId
in runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
sinkFile' (Left fId)
| fId `Set.member` oldFiles = modify $ Set.delete fId
| otherwise = do
lift . insert_ $ CourseApplicationFile appId fId
modify $ Set.insert fId
in runConduit $ transPipe liftHandler afFiles' .| C.mapM_ sinkFile'
deleteCascadeWhere [ FileId <-. Set.toList (oldFiles `Set.intersection` changes) ]
return changes
| otherwise

6
src/Handler/Corrections.hs
View File

@ -57,6 +57,8 @@ import qualified Control.Monad.State.Class as State
import Data.Foldable (foldrM)
import qualified Data.Conduit.List as C
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
@ -770,7 +772,7 @@ postCorrectionR tid ssh csh shn cid = do
formResult uploadResult $ \fileUploads -> do
uid <- requireAuthId
res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
res <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) fileUploads .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (Right sub) True
case res of
Nothing -> return () -- ErrorMessages are already added by msgSubmissionErrors
(Just _) -> do
@ -818,7 +820,7 @@ postCorrectionsUploadR = do
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs
FormSuccess files -> do
uid <- requireAuthId
mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkMultiSubmission uid True
mbSubs <- msgSubmissionErrors . runDBJobs . runConduit $ transPipe (lift . lift) files .| C.mapM (either get404 return) .| extractRatingsMsg .| sinkMultiSubmission uid True
case mbSubs of
Nothing -> return ()
(Just subs)

4
src/Handler/Course/Register.hs
View File

@ -42,7 +42,7 @@ instance Button UniWorX ButtonCourseRegister where
data CourseRegisterForm = CourseRegisterForm
{ crfStudyFeatures :: Maybe StudyFeaturesId
, crfApplicationText :: Maybe Text
, crfApplicationFiles :: Maybe (ConduitT () File Handler ())
, crfApplicationFiles :: Maybe FileUploads
}
courseRegisterForm :: (MonadHandler m, HandlerSite m ~ UniWorX) => Entity Course -> m (AForm Handler CourseRegisterForm, ButtonCourseRegister)
@ -195,7 +195,7 @@ postCRegisterR tid ssh csh = do
whenIsJust appRes $
audit . TransactionCourseApplicationEdit cid uid
whenIsJust ((,) <$> appRes <*> crfApplicationFiles) $ \(appId, fSource) -> do
runConduit $ transPipe liftHandler fSource .| C.mapM_ (\f -> insert f >>= insert_ . CourseApplicationFile appId)
runConduit $ transPipe liftHandler fSource .| C.mapM_ (insert_ . CourseApplicationFile appId <=< either return insert)
return appRes
| otherwise
= return $ Just ()

4
src/Handler/Submission.hs
View File

@ -125,7 +125,7 @@ submissionUserInvitationConfig = InvitationConfig{..}
return . SomeRoute $ CSubmissionR courseTerm courseSchool courseShorthand sheetName cID SubShowR
makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe (ConduitT () File Handler ()), Set (Either UserEmail UserId))
makeSubmissionForm :: CourseId -> Maybe SubmissionId -> UploadMode -> SheetGroup -> Bool -> Set (Either UserEmail UserId) -> Form (Maybe FileUploads, Set (Either UserEmail UserId))
makeSubmissionForm cid msmid uploadMode grouping isLecturer prefillUsers = identifyForm FIDsubmission . renderAForm FormStandard $ (,)
<$> fileUploadForm (not isLecturer && is _Nothing msmid) (fslI . bool MsgSubmissionFile MsgSubmissionArchive) uploadMode
<*> wFormToAForm submittorsForm
@ -428,7 +428,7 @@ submissionHelper tid ssh csh shn mcid = do
(Nothing, Just smid) -- no new files, existing submission partners updated
-> return smid
(Just files, _) -> -- new files
runConduit $ transPipe (lift . lift) files .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
runConduit $ transPipe (lift . lift) files .| Conduit.mapM (either get404 return) .| extractRatingsMsg .| sinkSubmission uid (maybe (Left shid) Right msmid) False
(Nothing, Nothing) -- new submission, no file upload requested
-> do
sid <- insert Submission

26
src/Handler/Utils/Form.hs
View File

@ -643,13 +643,17 @@ pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOp
| otherwise
= return . Left $ MsgUnknownPseudonymWord (CI.original w)
specificFileField :: UploadSpecificFile -> Field Handler (ConduitT () File Handler ())
type FileUploads = ConduitT () (Either FileId File) Handler ()
specificFileField :: UploadSpecificFile -> Field Handler FileUploads
specificFileField UploadSpecificFile{..} = Field{..}
where
fieldEnctype = Multipart
fieldParse _ files
| [f] <- files
= return . Right . Just $ yieldM (acceptFile f) .| modifyFileTitle (const $ unpack specificFileName)
= 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")
@ -661,14 +665,14 @@ specificFileField UploadSpecificFile{..} = Field{..}
zipFileField :: Bool -- ^ Unpack zips?
-> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
-> Field Handler (ConduitT () File Handler ())
-> 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 . acceptFile) sourceFiles doUnpack f
= 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")
@ -680,7 +684,7 @@ zipFileField doUnpack permittedExtensions = Field{..}
fileUploadForm :: Bool -- ^ Required?
-> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny`
-> UploadMode -> AForm Handler (Maybe (ConduitT () File Handler ()))
-> UploadMode -> AForm Handler (Maybe FileUploads)
fileUploadForm isReq mkFs = \case
NoUpload
-> pure Nothing
@ -689,21 +693,21 @@ fileUploadForm isReq mkFs = \case
UploadSpecific{..}
-> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
where
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe (ConduitT () File Handler ()))
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe FileUploads)
specificFileForm spec@UploadSpecificFile{..}
= bool (\f fs d -> aopt f fs $ fmap Just d) (\f fs d -> Just <$> areq f fs d) specificFileRequired (specificFileField spec) (fsl specificFileLabel) Nothing
mergeFileSources :: [Maybe (ConduitT () File Handler ())] -> Maybe (ConduitT () File Handler ())
mergeFileSources :: [Maybe FileUploads] -> Maybe FileUploads
mergeFileSources (catMaybes -> sources) = case sources of
[] -> Nothing
fs -> Just $ sequence_ fs
multiFileField' :: ConduitT () (Either FileId File) Handler () -- ^ Permitted files in same format as produced by `multiFileField`
-> Field Handler (ConduitT () (Either FileId File) Handler ())
multiFileField' :: FileUploads -- ^ Permitted files in same format as produced by `multiFileField`
-> Field Handler FileUploads
multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.mapMaybe (preview _Left) .| C.foldMap Set.singleton
multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference
-> Field Handler (ConduitT () (Either FileId File) Handler ())
-> Field Handler FileUploads
multiFileField permittedFiles' = Field{..}
where
fieldEnctype = Multipart
@ -746,7 +750,7 @@ multiFileField permittedFiles' = Field{..}
$(widgetFile "widgets/multiFileField")
unpackZips :: Text
unpackZips = "unpack-zip"
takeLefts :: Monad m => ConduitM (Either b a) b m ()
takeLefts :: Monad m => ConduitT (Either b a) b m ()
takeLefts = awaitForever $ \case
Right _ -> return ()
Left r -> yield r