diff --git a/models/files.model b/models/files.model index eae0276d7..fcf0b3809 100644 --- a/models/files.model +++ b/models/files.model @@ -5,4 +5,9 @@ FileContent SessionFile content FileContentReference Maybe - touched UTCTime \ No newline at end of file + touched UTCTime + +FileLock + content FileContentReference + instance InstanceId + time UTCTime \ No newline at end of file diff --git a/src/Handler/Allocation/Application.hs b/src/Handler/Allocation/Application.hs index c5229cbfb..73d898959 100644 --- a/src/Handler/Allocation/Application.hs +++ b/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 diff --git a/src/Handler/Course/Register.hs b/src/Handler/Course/Register.hs index 5e0165a1c..66b9b3566 100644 --- a/src/Handler/Course/Register.hs +++ b/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 diff --git a/src/Handler/Sheet/Pseudonym.hs b/src/Handler/Sheet/Pseudonym.hs index b9c055fa6..f269ef18c 100644 --- a/src/Handler/Sheet/Pseudonym.hs +++ b/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) diff --git a/src/Handler/Submission/Helper.hs b/src/Handler/Submission/Helper.hs index d808b501d..286481651 100644 --- a/src/Handler/Submission/Helper.hs +++ b/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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 86e56b95a..0345765f8 100644 --- a/src/Handler/Utils/Form.hs +++ b/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) -> - Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old + whenIsJust mIdent $ \ident -> + 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 diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index 7af8f3d57..8d0a895cc 100644 --- a/src/Handler/Utils/Submission.hs +++ b/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 diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index bbb67eb6b..25c1330b5 100644 --- a/src/Import/NoModel.hs +++ b/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 diff --git a/src/Jobs.hs b/src/Jobs.hs index 5faf681e0..b917354f0 100644 --- a/src/Jobs.hs +++ b/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 diff --git a/src/Jobs/Handler/Files.hs b/src/Jobs/Handler/Files.hs index b9817f649..7b144ae05 100644 --- a/src/Jobs/Handler/Files.hs +++ b/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 - isReferenced <- lift . E.selectExists . E.where_ . E.any E.exists . fileReferences $ E.val fRef - if | isReferenced -> do - alreadyInjected <- lift $ exists [ FileContentHash ==. fRef ] - if | alreadyInjected -> return (mempty, mempty, Sum 1) - | otherwise -> do - content <- (hoistMaybe =<<) . runAppMinio . runMaybeT $ do - objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj Minio.defaultGetObjectOptions - lift . runConduit $ Minio.gorObjectStream objRes .| C.fold - lift $ (mempty, Sum 1, mempty) <$ insert (FileContent fRef content) - | otherwise -> return (Sum 1, mempty, mempty) + res <- hoist (runDB . setSerializable) $ do + alreadyInjected <- lift $ exists [ FileContentHash ==. fRef ] + if | alreadyInjected -> return (mempty, Sum 1) + | otherwise -> do + content <- (hoistMaybe =<<) . runAppMinio . runMaybeT $ do + objRes <- catchIfMaybeT minioIsDoesNotExist $ Minio.getObject uploadBucket obj Minio.defaultGetObjectOptions + lift . runConduit $ Minio.gorObjectStream objRes .| C.fold + lift $ (Sum 1, mempty) <$ insertUnique (FileContent fRef content) 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) $ diff --git a/src/Jobs/Queue.hs b/src/Jobs/Queue.hs index 5275304d7..045649ed1 100644 --- a/src/Jobs/Queue.hs +++ b/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(..)) diff --git a/src/Utils/Files.hs b/src/Utils/Files.hs index b9121904e..517c36034 100644 --- a/src/Utils/Files.hs +++ b/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)