mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

refactor

Browse source
This commit is contained in:
Joey Hess 2017-09-20 16:22:32 -04:00
parent ad36479b3e
commit 129418615b
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
2 changed files with 27 additions and 22 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

34
Database/Export.hs
View file

@ -26,6 +26,7 @@ module Database.Export (
removeExportTree, removeExportTree,
updateExportTree, updateExportTree,
updateExportTree', updateExportTree',
updateExportTreeFromLog,
ExportedId, ExportedId,
ExportedDirectoryId, ExportedDirectoryId,
ExportTreeId, ExportTreeId,
@ -39,6 +40,8 @@ import Annex.Locations
import Annex.Common hiding (delete) import Annex.Common hiding (delete)
import Types.Export import Types.Export
import Annex.Export import Annex.Export
import qualified Logs.Export as Log
import Annex.LockFile
import Git.Types import Git.Types
import Git.Sha import Git.Sha
import Git.FilePath import Git.FilePath
@ -47,7 +50,7 @@ import qualified Git.DiffTree
import Database.Persist.TH import Database.Persist.TH
import Database.Esqueleto hiding (Key) import Database.Esqueleto hiding (Key)
newtype ExportHandle = ExportHandle H.DbQueue data ExportHandle = ExportHandle H.DbQueue UUID
share [mkPersist sqlSettings, mkMigrate "migrateExport"] [persistLowerCase| share [mkPersist sqlSettings, mkMigrate "migrateExport"] [persistLowerCase|
-- Files that have been exported to the remote and are present on it. -- Files that have been exported to the remote and are present on it.
@ -85,13 +88,13 @@ openDb u = do
initDb db $ void $ initDb db $ void $
runMigrationSilent migrateExport runMigrationSilent migrateExport
h <- liftIO $ H.openDbQueue H.SingleWriter db "exported" h <- liftIO $ H.openDbQueue H.SingleWriter db "exported"
return $ ExportHandle h return $ ExportHandle h u
closeDb :: ExportHandle -> Annex () closeDb :: ExportHandle -> Annex ()
closeDb (ExportHandle h) = liftIO $ H.closeDbQueue h closeDb (ExportHandle h _) = liftIO $ H.closeDbQueue h
queueDb :: ExportHandle -> SqlPersistM () -> IO () queueDb :: ExportHandle -> SqlPersistM () -> IO ()
queueDb (ExportHandle h) = H.queueDb h checkcommit queueDb (ExportHandle h _) = H.queueDb h checkcommit
where where
-- commit queue after 1000 changes -- commit queue after 1000 changes
checkcommit sz _lastcommittime checkcommit sz _lastcommittime
@ -99,7 +102,7 @@ queueDb (ExportHandle h) = H.queueDb h checkcommit
| otherwise = return False | otherwise = return False
flushDbQueue :: ExportHandle -> IO () flushDbQueue :: ExportHandle -> IO ()
flushDbQueue (ExportHandle h) = H.flushDbQueue h flushDbQueue (ExportHandle h _) = H.flushDbQueue h
recordExportTreeCurrent :: ExportHandle -> Sha -> IO () recordExportTreeCurrent :: ExportHandle -> Sha -> IO ()
recordExportTreeCurrent h s = queueDb h $ do recordExportTreeCurrent h s = queueDb h $ do
@ -108,7 +111,7 @@ recordExportTreeCurrent h s = queueDb h $ do
void $ insertUnique $ ExportTreeCurrent $ toSRef s void $ insertUnique $ ExportTreeCurrent $ toSRef s
getExportTreeCurrent :: ExportHandle -> IO (Maybe Sha) getExportTreeCurrent :: ExportHandle -> IO (Maybe Sha)
getExportTreeCurrent (ExportHandle h) = H.queryDbQueue h $ do getExportTreeCurrent (ExportHandle h _) = H.queryDbQueue h $ do
l <- select $ from $ \r -> do l <- select $ from $ \r -> do
where_ (r ^. ExportTreeCurrentTree ==. r ^. ExportTreeCurrentTree) where_ (r ^. ExportTreeCurrentTree ==. r ^. ExportTreeCurrentTree)
return (r ^. ExportTreeCurrentTree) return (r ^. ExportTreeCurrentTree)
@ -141,7 +144,7 @@ removeExportedLocation h k el = queueDb h $ do
{- Note that this does not see recently queued changes. -} {- Note that this does not see recently queued changes. -}
getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation] getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation]
getExportedLocation (ExportHandle h) k = H.queryDbQueue h $ do getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do
l <- select $ from $ \r -> do l <- select $ from $ \r -> do
where_ (r ^. ExportedKey ==. val ik) where_ (r ^. ExportedKey ==. val ik)
return (r ^. ExportedFile) return (r ^. ExportedFile)
@ -151,7 +154,7 @@ getExportedLocation (ExportHandle h) k = H.queryDbQueue h $ do
{- Note that this does not see recently queued changes. -} {- Note that this does not see recently queued changes. -}
isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool
isExportDirectoryEmpty (ExportHandle h) d = H.queryDbQueue h $ do isExportDirectoryEmpty (ExportHandle h _) d = H.queryDbQueue h $ do
l <- select $ from $ \r -> do l <- select $ from $ \r -> do
where_ (r ^. ExportedDirectorySubdir ==. val ed) where_ (r ^. ExportedDirectorySubdir ==. val ed)
return (r ^. ExportedDirectoryFile) return (r ^. ExportedDirectoryFile)
@ -161,7 +164,7 @@ isExportDirectoryEmpty (ExportHandle h) d = H.queryDbQueue h $ do
{- Get locations in the export that might contain a key. -} {- Get locations in the export that might contain a key. -}
getExportTree :: ExportHandle -> Key -> IO [ExportLocation] getExportTree :: ExportHandle -> Key -> IO [ExportLocation]
getExportTree (ExportHandle h) k = H.queryDbQueue h $ do getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do
l <- select $ from $ \r -> do l <- select $ from $ \r -> do
where_ (r ^. ExportTreeKey ==. val ik) where_ (r ^. ExportTreeKey ==. val ik)
return (r ^. ExportTreeFile) return (r ^. ExportTreeFile)
@ -209,3 +212,16 @@ updateExportTree' h srcek dstek i = do
Just k -> liftIO $ addExportTree h (asKey k) loc Just k -> liftIO $ addExportTree h (asKey k) loc
where where
loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i
updateExportTreeFromLog :: ExportHandle -> Annex ()
updateExportTreeFromLog db@(ExportHandle _ u) =
withExclusiveLock (gitAnnexExportLock u) $ do
old <- liftIO $ fromMaybe emptyTree
<$> getExportTreeCurrent db
l <- Log.getExport u
case map Log.exportedTreeish l of
(new:[]) | new /= old -> do
updateExportTree db old new
liftIO $ recordExportTreeCurrent db new
liftIO $ flushDbQueue db
_ -> return ()

15
Remote/Helper/Export.hs
View file

@ -16,10 +16,7 @@ import Types.Key
import Backend import Backend
import Remote.Helper.Encryptable (isEncrypted) import Remote.Helper.Encryptable (isEncrypted)
import Database.Export import Database.Export
import Logs.Export
import Annex.Export import Annex.Export
import Annex.LockFile
import Git.Sha
import qualified Data.Map as M import qualified Data.Map as M
import Control.Concurrent.STM import Control.Concurrent.STM
@ -103,16 +100,8 @@ adjustExportable r = case M.lookup "exporttree" (config r) of
-- updates the database, to notice when an export has been -- updates the database, to notice when an export has been
-- updated from another repository. -- updated from another repository.
let getexportlocs = \k -> do let getexportlocs = \k -> do
whenM updateonce $ withExclusiveLock (gitAnnexExportLock (uuid r)) $ do whenM updateonce $
old <- liftIO $ fromMaybe emptyTree updateExportTreeFromLog db
<$> getExportTreeCurrent db
l <- getExport (uuid r)
case map exportedTreeish l of
(new:[]) | new /= old -> do
updateExportTree db old new
liftIO $ recordExportTreeCurrent db new
liftIO $ flushDbQueue db
_ -> return ()
liftIO $ getExportTree db k liftIO $ getExportTree db k
return $ r return $ r