refactor: unify FileUploads type

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
+            sinkFile' (Right file) =
-              fId <- insert 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

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)

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 ()

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

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`
+multiFileField' :: FileUploads -- ^ Permitted files in same format as produced by `multiFileField`
-                -> Field Handler (ConduitT () (Either FileId File) Handler ())
+                -> 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