fix: better concurrency behaviour

models/files.model

@@ -5,4 +5,9 @@ FileContent
 
 SessionFile
     content         FileContentReference Maybe
-    touched         UTCTime
+    touched         UTCTime
+
+FileLock
+    content         FileContentReference
+    instance        InstanceId
+    time            UTCTime

src/Handler/Allocation/Application.hs

@@ -260,7 +260,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
     if
       | BtnAllocationApply <- afAction
       , allowAction afAction
-        -> runDB $ do
+        -> runDB . setSerializable $ do
           haveOld <- exists [ CourseApplicationCourse     ==. cid
                             , CourseApplicationUser       ==. uid
                             , CourseApplicationAllocation ==. maId
@@ -291,7 +291,7 @@ editApplicationR maId uid cid mAppId afMode allowAction postAction = do
       | is _BtnAllocationApplicationEdit afAction || is _BtnAllocationApplicationRate afAction
       , allowAction afAction
       , Just appId <- mAppId
-        -> runDB $ do
+        -> runDB . setSerializable $ do
           now <- liftIO getCurrentTime
 
           changes <- if

src/Handler/Course/Register.hs

@@ -175,8 +175,9 @@ postCRegisterR tid ssh csh = do
   formResult regResult $ \CourseRegisterForm{..} -> do
     cTime <- liftIO getCurrentTime
     let
+      doApplication = courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles)
       mkApplication
-        | courseApplicationsRequired || is _Just (void crfApplicationText <|> void crfApplicationFiles)
+        | doApplication
         = void <$> do
             appIds <- selectKeysList [ CourseApplicationAllocation ==. Nothing, CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid ] []
             appRes <- case appIds of
@@ -210,12 +211,12 @@ postCRegisterR tid ssh csh = do
           ]
 
     case courseRegisterButton of
-      BtnCourseRegister -> runDB $ do
+      BtnCourseRegister -> runDB . bool id setSerializable doApplication $ do
         regOk <- (\app reg -> (, reg) <$> app) <$> mkApplication <*> mkRegistration
         case regOk of
           Nothing -> transactionUndo
           Just _  -> addMessageIconI Success IconEnrolTrue MsgCourseRegisterOk
-      BtnCourseDeregister -> runDB $ do
+      BtnCourseDeregister -> runDB . setSerializable $ do
         part <- fmap (assertM . has $ _entityVal . _courseParticipantState . _CourseParticipantActive) . getBy $ UniqueParticipant uid cid
         forM_ part $ \(Entity _partId CourseParticipant{..}) -> do
           deregisterParticipant uid cid
@@ -237,7 +238,7 @@ postCRegisterR tid ssh csh = do
             when courseDeregisterNoShow . runConduit $ selectKeys [ ExamCourse ==. cid ] [] .| C.mapM_ recordNoShow
 
         addMessageIconI Info IconEnrolFalse MsgCourseDeregisterOk
-      BtnCourseApply -> runDB $ do
+      BtnCourseApply -> runDB . setSerializable $ do
         regOk <- mkApplication
         case regOk of
           Nothing -> transactionUndo

src/Handler/Sheet/Pseudonym.hs

@@ -7,8 +7,6 @@ import Import
 
 import Handler.Utils
 
-import Utils.Sql
-
 
 data ButtonGeneratePseudonym = BtnGenerate
   deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)

src/Handler/Submission/Helper.hs

@@ -318,7 +318,7 @@ submissionHelper tid ssh csh shn mcid = do
         , formEncoding = formEnctype
         }
 
-  mCID <- fmap join . msgSubmissionErrors . runDBJobs $ do
+  mCID <- fmap join . msgSubmissionErrors . runDBJobs . setSerializable $ do
     (Entity shid Sheet{..}, _, _, _, isLecturer, _, msubmission, _) <- hoist lift getSheetInfo
 
     submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do

src/Handler/Utils/Form.hs

@@ -899,13 +899,14 @@ genericFileField mkOpts = Field{..}
     handleUpload FileField{fieldMaxFileSize} mIdent
       =    C.filter (\File{..} -> maybe (const True) (>) fieldMaxFileSize $ maybe 0 (fromIntegral . olength) fileContent)
         .| sinkFiles
-        .| maybe (C.map id) mkSessionFile mIdent
+        .| C.mapM mkSessionFile
       where
-        mkSessionFile ident = C.mapM $ \fRef@FileReference{..} -> fRef <$ do
+        mkSessionFile fRef@FileReference{..} = fRef <$ do
           now <- liftIO getCurrentTime
           sfId <- insert $ SessionFile fileReferenceContent now
-          modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) ->
+          whenIsJust mIdent $ \ident ->
-            Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old
+            modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) ->
+              Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old
 
   
     _FileTitle :: Prism' Text FilePath

src/Handler/Utils/Submission.hs

@@ -900,7 +900,7 @@ submissionDeleteRoute drRecords = DeleteRoute
           subUsers <- selectList [SubmissionUserSubmission ==. subId] []
           if
             | length subUsers >= 1
-            , maybe False (flip any subUsers . (. submissionUserUser . entityVal) . (==)) uid
+            , maybe True (flip any subUsers . (. submissionUserUser . entityVal) . (/=)) uid
               -> Just <$> messageI Warning (MsgSubmissionDeleteCosubmittorsWarning $ length infos)
             | otherwise
               -> return Nothing

src/Import/NoModel.hs

@@ -38,6 +38,7 @@ import Yesod.Core.Types.Instances as Import
 import Utils                  as Import
 import Utils.Frontend.I18n    as Import
 import Utils.DB               as Import
+import Utils.Sql              as Import
 
 import Data.Fixed             as Import
 

src/Jobs.hs

@@ -18,8 +18,6 @@ import Data.Aeson (fromJSON)
 import qualified Data.Aeson as Aeson
 import qualified Data.Aeson.Types as Aeson
 
-import Utils.Sql
-
 import Control.Monad.Random (evalRand, mkStdGen, uniformMay)
 
 import Cron

src/Jobs/Handler/Files.hs

@@ -37,9 +37,10 @@ fileReferences (E.just -> fHash)
     , E.from $ \newsFile  -> E.where_ $ newsFile  E.^. CourseNewsFileContent           E.==. fHash
     , E.from $ \sheetFile -> E.where_ $ sheetFile E.^. SheetFileContent                E.==. fHash
     , E.from $ \appInstr  -> E.where_ $ appInstr  E.^. CourseAppInstructionFileContent E.==. fHash
-    , E.from $ \matching  -> E.where_ $ E.just (matching  E.^. AllocationMatchingLog)  E.==. fHash
+    , E.from $ \matching  -> E.where_ $ E.just (matching E.^. AllocationMatchingLog)   E.==. fHash
     , E.from $ \subFile   -> E.where_ $ subFile   E.^. SubmissionFileContent           E.==. fHash
     , E.from $ \sessFile  -> E.where_ $ sessFile  E.^. SessionFileContent              E.==. fHash
+    , E.from $ \lock      -> E.where_ $ E.just (lock E.^. FileLockContent)             E.==. fHash
     ]
 
 
@@ -75,33 +76,28 @@ dispatchJobInjectFiles = JobHandlerException . maybeT (return ()) $ do
     extractReference _ = Nothing
     
     injectOrDelete :: (Minio.Object, FileContentReference)
-                   -> Handler (Sum Int64, Sum Int64, Sum Int64) -- ^ Deleted, Injected, Existed
+                   -> Handler (Sum Int64, Sum Int64) -- ^ Injected, Already existed
     injectOrDelete (obj, fRef) = maybeT (return mempty) $ do
-      res <- hoist runDB $ do
+      res <- hoist (runDB . setSerializable) $ do
-        isReferenced <- lift . E.selectExists . E.where_ . E.any E.exists . fileReferences $ E.val fRef
+        alreadyInjected <- lift $ exists [ FileContentHash ==. fRef ]
-        if | isReferenced -> do
+        if | alreadyInjected -> return (mempty, Sum 1)
-               alreadyInjected <- lift $ exists [ FileContentHash ==. fRef ]
+           | otherwise -> do
-               if | alreadyInjected -> return (mempty, mempty, Sum 1)
+               content <- (hoistMaybe =<<) . runAppMinio  . runMaybeT $ do
-                  | otherwise -> do
+                 objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj Minio.defaultGetObjectOptions
-                      content <- (hoistMaybe =<<) . runAppMinio  . runMaybeT $ do
+                 lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
-                        objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj Minio.defaultGetObjectOptions
+               lift $ (Sum 1, mempty) <$ insertUnique (FileContent fRef content)
-                        lift . runConduit $ Minio.gorObjectStream objRes .| C.fold
-                      lift $ (mempty, Sum 1, mempty) <$ insert (FileContent fRef content)
-           | otherwise -> return (Sum 1, mempty, mempty)
       runAppMinio . maybeT (return ()) . catchIfMaybeT minioIsDoesNotExist $ Minio.removeObject uploadBucket obj 
       return res
 
-  (Sum del, Sum inj, Sum exc) <-
+  (Sum inj, Sum exc) <-
     runConduit $ transPipe runAppMinio (Minio.listObjects uploadBucket Nothing True)
               .| C.mapMaybe extractReference
               .| maybe (C.map id) (takeWhileTime . (/ 2)) interval
-              .| transPipe (lift . runDB) (persistentTokenBucketTakeC' TokenBucketInjectFiles $ views _1 Minio.oiSize)
+              .| transPipe (lift . runDB . setSerializable) (persistentTokenBucketTakeC' TokenBucketInjectFiles $ views _1 Minio.oiSize)
               .| C.map (over _1 Minio.oiObject)
               .| transPipe lift (C.mapM injectOrDelete)
               .| C.fold
 
-  when (del > 0) $
-    $logInfoS "InjectFiles" [st|Deleted #{del} unreferenced files from upload cache|]
   when (exc > 0) $
     $logInfoS "InjectFiles" [st|Deleted #{exc} files from upload cache because they were already referenced|]
   when (inj > 0) $

src/Jobs/Queue.hs

@@ -11,7 +11,6 @@ module Jobs.Queue
 
 import Import hiding ((<>))
 
-import Utils.Sql
 import Jobs.Types
 
 import Control.Monad.Writer.Class (MonadWriter(..))

src/Utils/Files.hs

@@ -24,17 +24,27 @@ import Control.Monad.State.Class (modify)
 
 import Database.Persist.Sql (deleteWhereCount)
 
+import Control.Monad.Trans.Resource (allocate)
 
-sinkFiles :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT File FileReference (SqlPersistT m) ()
+
+sinkFiles :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => ConduitT File FileReference (SqlPersistT m) ()
 sinkFiles = C.mapM sinkFile
   
-sinkFile :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX) => File -> SqlPersistT m FileReference
+sinkFile :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX) => File -> SqlPersistT m FileReference
 sinkFile File{ fileContent = Nothing, .. } = return FileReference
   { fileReferenceContent  = Nothing
   , fileReferenceTitle    = fileTitle
   , fileReferenceModified = fileModified
   }
 sinkFile File{ fileContent = Just fileContentContent, .. } = do
+  void . withUnliftIO $ \UnliftIO{..} ->
+    let takeLock = do
+          fileLockTime <- liftIO getCurrentTime
+          fileLockInstance <- getsYesod appInstanceID
+          insert FileLock{ fileLockContent = fileContentHash, .. }
+        releaseLock lId = liftHandler . runDB $ (withReaderT projectBackend $ setSerializable (delete lId :: SqlPersistT (HandlerFor UniWorX) ()) :: YesodDB UniWorX ())
+     in unliftIO $ allocate (unliftIO takeLock) (unliftIO . releaseLock)
+  
   inDB <- exists [ FileContentHash ==. fileContentHash ]
   
   let sinkFileDB = unless inDB $ repsert (FileContentKey fileContentHash) FileContent{..}
@@ -60,10 +70,10 @@ sinkFile File{ fileContent = Just fileContentContent, .. } = do
     fileContentHash = Crypto.hash fileContentContent
         
 
-sinkFiles' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, HasFileReference record) => ConduitT (File, FileReferenceResidual record) record (SqlPersistT m) ()
+sinkFiles' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX, HasFileReference record) => ConduitT (File, FileReferenceResidual record) record (SqlPersistT m) ()
 sinkFiles' = C.mapM $ uncurry sinkFile'
 
-sinkFile' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, HasFileReference record) => File -> FileReferenceResidual record -> SqlPersistT m record
+sinkFile' :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, MonadUnliftIO m, BackendCompatible SqlBackend (YesodPersistBackend UniWorX), YesodPersist UniWorX, HasFileReference record) => File -> FileReferenceResidual record -> SqlPersistT m record
 sinkFile' file residual = do
   reference <- sinkFile file
   return $ _FileReference # (reference, residual)