From 766ca63b409a7380b4d554b5b10a3f5b3096e838 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 4 Nov 2019 15:20:34 +0100 Subject: [PATCH] refactor: unify FileUploads type --- src/Handler/Allocation/Application.hs | 16 +++++++++++----- src/Handler/Corrections.hs | 6 ++++-- src/Handler/Course/Register.hs | 4 ++-- src/Handler/Submission.hs | 4 ++-- src/Handler/Utils/Form.hs | 26 +++++++++++++++----------- 5 files changed, 34 insertions(+), 22 deletions(-) diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index 912fd8450..9c1cba0e1 100644 --- a/src/Handler/Allocation/Application.hs +++ b/src/Handler/Allocation/Application.hs @@ -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 diff --git a/src/Handler/Corrections.hs b/src/Handler/Corrections.hs index b9e16b4bb..da2e47096 100644 --- a/src/Handler/Corrections.hs +++ b/src/Handler/Corrections.hs @@ -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) diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 5da5f6735..fc687713a 100644 --- a/src/Handler/Course/Register.hs +++ b/src/Handler/Course/Register.hs @@ -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 () diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 8e5ca85c1..f254f9104 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index b9f0138dd..3ab191e0a 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -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