f5b642318d
After commit f4bdecc4ec, there is no
longer any distinction between SingleWriter and MultiWriter's handling
of read after write.
Databases that were SingleWriter still have lock files that are used to
prevent multiple writers.
This does make writing to such databases a bit more expensive,
because the MultiWriter code path that is now used opens a second db
connection in order to write to them.
326 lines
10 KiB
Haskell
326 lines
10 KiB
Haskell
{- Sqlite database used for exports to special remotes.
|
|
-
|
|
- Copyright 2017-2019 Joey Hess <id@joeyh.name>
|
|
-:
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
|
|
{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-}
|
|
{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-}
|
|
{-# LANGUAGE RankNTypes #-}
|
|
{-# LANGUAGE DataKinds, FlexibleInstances #-}
|
|
{-# LANGUAGE UndecidableInstances #-}
|
|
#if MIN_VERSION_persistent_template(2,8,0)
|
|
{-# LANGUAGE DerivingStrategies #-}
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
|
#endif
|
|
|
|
module Database.Export (
|
|
ExportHandle,
|
|
openDb,
|
|
closeDb,
|
|
writeLockDbWhile,
|
|
flushDbQueue,
|
|
addExportedLocation,
|
|
removeExportedLocation,
|
|
getExportedLocation,
|
|
isExportDirectoryEmpty,
|
|
getExportTreeCurrent,
|
|
recordExportTreeCurrent,
|
|
getExportTree,
|
|
getExportTreeKey,
|
|
addExportTree,
|
|
removeExportTree,
|
|
updateExportTree,
|
|
updateExportTree',
|
|
updateExportTreeFromLog,
|
|
updateExportDb,
|
|
ExportedId,
|
|
ExportedDirectoryId,
|
|
ExportTreeId,
|
|
ExportTreeCurrentId,
|
|
ExportUpdateResult(..),
|
|
ExportDiffUpdater,
|
|
runExportDiffUpdater,
|
|
) where
|
|
|
|
import Database.Types
|
|
import qualified Database.Queue as H
|
|
import Database.Init
|
|
import Annex.Locations
|
|
import Annex.Common hiding (delete)
|
|
import Types.Export
|
|
import Annex.Export
|
|
import qualified Logs.Export as Log
|
|
import Annex.LockFile
|
|
import Annex.LockPool
|
|
import Git.Types
|
|
import Git.Sha
|
|
import Git.FilePath
|
|
import qualified Git.DiffTree
|
|
import qualified Utility.RawFilePath as R
|
|
|
|
import Database.Persist.Sql hiding (Key)
|
|
import Database.Persist.TH
|
|
import qualified System.FilePath.ByteString as P
|
|
|
|
data ExportHandle = ExportHandle H.DbQueue UUID
|
|
|
|
share [mkPersist sqlSettings, mkMigrate "migrateExport"] [persistLowerCase|
|
|
-- Files that have been exported to the remote and are present on it.
|
|
Exported
|
|
key Key
|
|
file SFilePath
|
|
ExportedIndex key file
|
|
-- Directories that exist on the remote, and the files that are in them.
|
|
ExportedDirectory
|
|
subdir SFilePath
|
|
file SFilePath
|
|
ExportedDirectoryIndex subdir file
|
|
-- The content of the tree that has been exported to the remote.
|
|
-- Not all of these files are necessarily present on the remote yet.
|
|
ExportTree
|
|
key Key
|
|
file SFilePath
|
|
ExportTreeKeyFileIndex key file
|
|
ExportTreeFileKeyIndex file key
|
|
-- The tree stored in ExportTree
|
|
ExportTreeCurrent
|
|
tree SSha
|
|
UniqueTree tree
|
|
|]
|
|
|
|
{- Opens the database, creating it if it doesn't exist yet.
|
|
-
|
|
- Only a single process should write to the export at a time, so guard
|
|
- any writes with the gitAnnexExportLock.
|
|
-}
|
|
openDb :: UUID -> Annex ExportHandle
|
|
openDb u = do
|
|
dbdir <- fromRepo (gitAnnexExportDbDir u)
|
|
let db = dbdir P.</> "db"
|
|
unlessM (liftIO $ R.doesPathExist db) $ do
|
|
initDb db $ void $
|
|
runMigrationSilent migrateExport
|
|
h <- liftIO $ H.openDbQueue db "exported"
|
|
return $ ExportHandle h u
|
|
|
|
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
|
|
|
|
flushDbQueue :: ExportHandle -> IO ()
|
|
flushDbQueue (ExportHandle h _) = H.flushDbQueue h
|
|
|
|
recordExportTreeCurrent :: ExportHandle -> Sha -> IO ()
|
|
recordExportTreeCurrent h s = queueDb h $ do
|
|
deleteWhere ([] :: [Filter ExportTreeCurrent])
|
|
void $ insertUnique $ ExportTreeCurrent $ toSSha s
|
|
|
|
getExportTreeCurrent :: ExportHandle -> IO (Maybe Sha)
|
|
getExportTreeCurrent (ExportHandle h _) = H.queryDbQueue h $ do
|
|
l <- selectList ([] :: [Filter ExportTreeCurrent]) []
|
|
case l of
|
|
(s:[]) -> return $ Just $ fromSSha $
|
|
exportTreeCurrentTree $ entityVal s
|
|
_ -> return Nothing
|
|
|
|
addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
|
|
addExportedLocation h k el = queueDb h $ do
|
|
void $ insertUnique $ Exported k ef
|
|
let edirs = map
|
|
(\ed -> ExportedDirectory (SFilePath (fromExportDirectory ed)) ef)
|
|
(exportDirectories el)
|
|
putMany edirs
|
|
where
|
|
ef = SFilePath (fromExportLocation el)
|
|
|
|
removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO ()
|
|
removeExportedLocation h k el = queueDb h $ do
|
|
deleteWhere [ExportedKey ==. k, ExportedFile ==. ef]
|
|
let subdirs = map (SFilePath . fromExportDirectory)
|
|
(exportDirectories el)
|
|
deleteWhere [ExportedDirectoryFile ==. ef, ExportedDirectorySubdir <-. subdirs]
|
|
where
|
|
ef = SFilePath (fromExportLocation el)
|
|
|
|
{- Note that this does not see recently queued changes. -}
|
|
getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation]
|
|
getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do
|
|
l <- selectList [ExportedKey ==. k] []
|
|
return $ map (mkExportLocation . (\(SFilePath f) -> f) . exportedFile . entityVal) l
|
|
|
|
{- Note that this does not see recently queued changes. -}
|
|
isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool
|
|
isExportDirectoryEmpty (ExportHandle h _) d = H.queryDbQueue h $ do
|
|
l <- selectList [ExportedDirectorySubdir ==. ed] []
|
|
return $ null l
|
|
where
|
|
ed = SFilePath $ fromExportDirectory d
|
|
|
|
{- Get locations in the export that might contain a key. -}
|
|
getExportTree :: ExportHandle -> Key -> IO [ExportLocation]
|
|
getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do
|
|
l <- selectList [ExportTreeKey ==. k] []
|
|
return $ map (mkExportLocation . (\(SFilePath f) -> f) . exportTreeFile . entityVal) l
|
|
|
|
{- Get keys that might be currently exported to a location.
|
|
-
|
|
- Note that this does not see recently queued changes.
|
|
-}
|
|
getExportTreeKey :: ExportHandle -> ExportLocation -> IO [Key]
|
|
getExportTreeKey (ExportHandle h _) el = H.queryDbQueue h $ do
|
|
map (exportTreeKey . entityVal)
|
|
<$> selectList [ExportTreeFile ==. ef] []
|
|
where
|
|
ef = SFilePath (fromExportLocation el)
|
|
|
|
addExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
|
|
addExportTree h k loc = queueDb h $
|
|
void $ insertUnique $ ExportTree k ef
|
|
where
|
|
ef = SFilePath (fromExportLocation loc)
|
|
|
|
removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO ()
|
|
removeExportTree h k loc = queueDb h $
|
|
deleteWhere [ExportTreeKey ==. k, ExportTreeFile ==. ef]
|
|
where
|
|
ef = SFilePath (fromExportLocation loc)
|
|
|
|
-- An action that is passed the old and new values that were exported,
|
|
-- and updates state.
|
|
type ExportDiffUpdater
|
|
= ExportHandle
|
|
-> Maybe Key
|
|
-- ^ old exported key
|
|
-> Maybe Key
|
|
-- ^ new exported key
|
|
-> Git.DiffTree.DiffTreeItem
|
|
-> Annex ()
|
|
|
|
mkExportDiffUpdater
|
|
:: (ExportHandle -> Key -> ExportLocation -> IO ())
|
|
-> (ExportHandle -> Key -> ExportLocation -> IO ())
|
|
-> ExportDiffUpdater
|
|
mkExportDiffUpdater removeold addnew h srcek dstek i = do
|
|
case srcek of
|
|
Nothing -> return ()
|
|
Just k -> liftIO $ removeold h k loc
|
|
case dstek of
|
|
Nothing -> return ()
|
|
Just k -> liftIO $ addnew h k loc
|
|
where
|
|
loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i
|
|
|
|
runExportDiffUpdater :: ExportDiffUpdater -> ExportHandle -> Sha -> Sha -> Annex ()
|
|
runExportDiffUpdater updater h old new = do
|
|
(diff, cleanup) <- inRepo $
|
|
Git.DiffTree.diffTreeRecursive old new
|
|
forM_ diff $ \i -> do
|
|
srcek <- getek (Git.DiffTree.srcsha i)
|
|
dstek <- getek (Git.DiffTree.dstsha i)
|
|
updater h srcek dstek i
|
|
void $ liftIO cleanup
|
|
where
|
|
getek sha
|
|
| sha `elem` nullShas = return Nothing
|
|
| otherwise = Just <$> exportKey sha
|
|
|
|
{- Diff from the old to the new tree and update the ExportTree table. -}
|
|
updateExportTree :: ExportHandle -> Sha -> Sha -> Annex ()
|
|
updateExportTree = runExportDiffUpdater updateExportTree'
|
|
|
|
updateExportTree' :: ExportDiffUpdater
|
|
updateExportTree' = mkExportDiffUpdater removeExportTree addExportTree
|
|
|
|
{- Diff from the old to the new tree and update all tables in the export
|
|
- database. Should only be used when all the files in the new tree have
|
|
- been verified to already be present in the export remote. -}
|
|
updateExportDb :: ExportHandle -> Sha -> Sha -> Annex ()
|
|
updateExportDb = runExportDiffUpdater $ mkExportDiffUpdater removeold addnew
|
|
where
|
|
removeold h k loc = liftIO $ do
|
|
removeExportTree h k loc
|
|
removeExportedLocation h k loc
|
|
addnew h k loc = liftIO $ do
|
|
addExportTree h k loc
|
|
addExportedLocation h k loc
|
|
|
|
{- Runs an action with the database locked for write. Waits for any other
|
|
- writers to finish first. The queue is flushed at the end.
|
|
-
|
|
- This first updates the ExportTree table with any new information
|
|
- from the git-annex branch export log.
|
|
-}
|
|
writeLockDbWhile :: ExportHandle -> Annex a -> Annex a
|
|
writeLockDbWhile db@(ExportHandle _ u) a = do
|
|
updatelck <- takeExclusiveLock (gitAnnexExportUpdateLock u)
|
|
withExclusiveLock (gitAnnexExportLock u) $ do
|
|
bracket_ (setup updatelck) cleanup a
|
|
where
|
|
setup updatelck = do
|
|
void $ updateExportTreeFromLog' db
|
|
-- flush the update so it's available immediately to
|
|
-- anything waiting on the updatelck
|
|
liftIO $ flushDbQueue db
|
|
liftIO $ dropLock updatelck
|
|
cleanup = liftIO $ flushDbQueue db
|
|
|
|
data ExportUpdateResult = ExportUpdateSuccess | ExportUpdateConflict
|
|
deriving (Eq)
|
|
|
|
{- Updates the ExportTree table with information from the
|
|
- git-annex branch export log.
|
|
-
|
|
- This can safely be called whether the database is locked for write or
|
|
- not. Either way, it will block until the update is complete.
|
|
-}
|
|
updateExportTreeFromLog :: ExportHandle -> Annex ExportUpdateResult
|
|
updateExportTreeFromLog db@(ExportHandle _ u) =
|
|
-- If another process or thread is performing the update,
|
|
-- this will block until it's done.
|
|
withExclusiveLock (gitAnnexExportUpdateLock u) $ do
|
|
-- If the database is locked by something else,
|
|
-- this will not run the update. But, in that case,
|
|
-- writeLockDbWhile is running, and has already
|
|
-- completed the update, so we don't need to do anything.
|
|
mr <- tryExclusiveLock (gitAnnexExportLock u) $
|
|
updateExportTreeFromLog' db
|
|
case mr of
|
|
Just r -> return r
|
|
Nothing -> do
|
|
old <- liftIO $ fromMaybe emptyTree
|
|
<$> getExportTreeCurrent db
|
|
l <- Log.getExport u
|
|
return $ case Log.exportedTreeishes l of
|
|
[] -> ExportUpdateSuccess
|
|
(new:[])
|
|
| new /= old -> ExportUpdateSuccess
|
|
| new == old -> ExportUpdateSuccess
|
|
_ts -> ExportUpdateConflict
|
|
|
|
{- The database should be locked when calling this. -}
|
|
updateExportTreeFromLog' :: ExportHandle -> Annex ExportUpdateResult
|
|
updateExportTreeFromLog' db@(ExportHandle _ u) = do
|
|
old <- liftIO $ fromMaybe emptyTree
|
|
<$> getExportTreeCurrent db
|
|
l <- Log.getExport u
|
|
case Log.exportedTreeishes l of
|
|
[] -> return ExportUpdateSuccess
|
|
(new:[])
|
|
| new /= old -> do
|
|
updateExportTree db old new
|
|
liftIO $ recordExportTreeCurrent db new
|
|
liftIO $ flushDbQueue db
|
|
return ExportUpdateSuccess
|
|
| new == old -> return ExportUpdateSuccess
|
|
_ts -> return ExportUpdateConflict
|