6ab14710fc
The export database has writes made to it and then expects to read back the same data immediately. But, the way that Database.Handle does writes, in order to support multiple writers, makes that not work, due to caching issues. This resulted in export re-uploading files it had already successfully renamed into place. Fixed by allowing databases to be opened in MultiWriter or SingleWriter mode. The export database only needs to support a single writer; it does not make sense for multiple exports to run at the same time to the same special remote. All other databases still use MultiWriter mode. And by inspection, nothing else in git-annex seems to be relying on being able to immediately query for changes that were just written to the database. This commit was supported by the NSF-funded DataLad project.
88 lines
2.5 KiB
Haskell
88 lines
2.5 KiB
Haskell
{- Sqlite database used for exports to special remotes.
|
|
-
|
|
- Copyright 2017 Joey Hess <id@joeyh.name>
|
|
-:
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
|
|
{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}
|
|
{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
|
|
module Database.Export (
|
|
ExportHandle,
|
|
openDb,
|
|
closeDb,
|
|
addExportLocation,
|
|
removeExportLocation,
|
|
flushDbQueue,
|
|
getExportLocation,
|
|
ExportedId,
|
|
) where
|
|
|
|
import Database.Types
|
|
import qualified Database.Queue as H
|
|
import Database.Init
|
|
import Annex.Locations
|
|
import Annex.Common hiding (delete)
|
|
import Types.Remote (ExportLocation(..))
|
|
|
|
import Database.Persist.TH
|
|
import Database.Esqueleto hiding (Key)
|
|
|
|
newtype ExportHandle = ExportHandle H.DbQueue
|
|
|
|
share [mkPersist sqlSettings, mkMigrate "migrateExport"] [persistLowerCase|
|
|
Exported
|
|
key IKey
|
|
file SFilePath
|
|
KeyFileIndex key file
|
|
|]
|
|
|
|
{- Opens the database, creating it if it doesn't exist yet. -}
|
|
openDb :: UUID -> Annex ExportHandle
|
|
openDb u = do
|
|
dbdir <- fromRepo (gitAnnexExportDbDir u)
|
|
let db = dbdir </> "db"
|
|
unlessM (liftIO $ doesFileExist db) $ do
|
|
initDb db $ void $
|
|
runMigrationSilent migrateExport
|
|
h <- liftIO $ H.openDbQueue H.SingleWriter db "exported"
|
|
return $ ExportHandle h
|
|
|
|
closeDb :: ExportHandle -> Annex ()
|
|
closeDb (ExportHandle h) = liftIO $ H.closeDbQueue h
|
|
|
|
queueDb :: ExportHandle -> SqlPersistM () -> IO ()
|
|
queueDb (ExportHandle h) = H.queueDb h checkcommit
|
|
where
|
|
-- commit queue after 1000 changes
|
|
checkcommit sz _lastcommittime
|
|
| sz > 1000 = return True
|
|
| otherwise = return False
|
|
|
|
addExportLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
|
|
addExportLocation h k (ExportLocation f) = queueDb h $
|
|
void $ insertUnique $ Exported (toIKey k) (toSFilePath f)
|
|
|
|
removeExportLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
|
|
removeExportLocation h k (ExportLocation f) = queueDb h $
|
|
delete $ from $ \r -> do
|
|
where_ (r ^. ExportedKey ==. val ik &&. r ^. ExportedFile ==. val ef)
|
|
where
|
|
ik = toIKey k
|
|
ef = toSFilePath f
|
|
|
|
flushDbQueue :: ExportHandle -> IO ()
|
|
flushDbQueue (ExportHandle h) = H.flushDbQueue h
|
|
|
|
{- Note that this does not see recently queued changes. -}
|
|
getExportLocation :: ExportHandle -> Key -> IO [ExportLocation]
|
|
getExportLocation (ExportHandle h) k = H.queryDbQueue h $ do
|
|
l <- select $ from $ \r -> do
|
|
where_ (r ^. ExportedKey ==. val ik)
|
|
return (r ^. ExportedFile)
|
|
return $ map (ExportLocation . fromSFilePath . unValue) l
|
|
where
|
|
ik = toIKey k
|