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

fix: better concurrency behaviour

Browse Source
This commit is contained in:
Gregor Kleen 2020-07-31 18:00:30 +02:00
parent d47d6aa6cc
commit a0392dd329
12 changed files with 48 additions and 39 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
models/files.model
View File

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

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

@ -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

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

@ -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

2
src/Handler/Sheet/Pseudonym.hs
View File

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

2
src/Handler/Submission/Helper.hs
View File

@ -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

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

@ -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

2
src/Handler/Utils/Submission.hs
View File

@ -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

1
src/Import/NoModel.hs
View File

@ -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

2
src/Jobs.hs
View File

@ -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

30
src/Jobs/Handler/Files.hs
View File

@ -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) $

1
src/Jobs/Queue.hs
View File

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

18
src/Utils/Files.hs
View File

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