From a5e968bb8d4c608c33463160ea2b583a3e34b8fc Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 18 Sep 2017 13:57:25 -0400 Subject: add ExportTree table to export db New table needed to look up what filenames are used in the currently exported tree, for reasons explained in export.mdwn. Also, added smart constructors for ExportLocation and ExportDirectory to make sure they contain filepaths with the right direction slashes. And some code refactoring. This commit was sponsored by Francois Marier on Patreon. --- Database/Export.hs | 127 ++++++++++++++++++++++++++++++++++++++++++++--------- Database/Types.hs | 21 ++++++++- 2 files changed, 126 insertions(+), 22 deletions(-) (limited to 'Database') diff --git a/Database/Export.hs b/Database/Export.hs index df3d92300..7dae408fa 100644 --- a/Database/Export.hs +++ b/Database/Export.hs @@ -14,13 +14,19 @@ module Database.Export ( ExportHandle, openDb, closeDb, - addExportLocation, - removeExportLocation, flushDbQueue, - getExportLocation, + recordDataSource, + getDataSource, + addExportedLocation, + removeExportedLocation, + getExportedLocation, isExportDirectoryEmpty, + getExportTree, + updateExportTree, ExportedId, + ExportTreeId, ExportedDirectoryId, + DataSourceId, ) where import Database.Types @@ -29,6 +35,11 @@ import Database.Init import Annex.Locations import Annex.Common hiding (delete) import Types.Export +import Annex.Export +import Git.Types +import Git.Sha +import Git.FilePath +import qualified Git.DiffTree import Database.Persist.TH import Database.Esqueleto hiding (Key) @@ -36,14 +47,26 @@ import Database.Esqueleto hiding (Key) newtype ExportHandle = ExportHandle H.DbQueue share [mkPersist sqlSettings, mkMigrate "migrateExport"] [persistLowerCase| +-- Files that have been exported to the remote. Exported key IKey file SFilePath - KeyFileIndex key file + ExportedIndex key file +-- The tree that has been exported to the remote. +-- Not all of these files are necessarily present on the remote yet. +ExportTree + key IKey + file SFilePath + ExportTreeIndex key file +-- Directories that exist on the remote, and the files that are in them. ExportedDirectory subdir SFilePath file SFilePath - SubdirFileIndex subdir file + ExportedDirectoryIndex subdir file +-- Record of what tree the current database content comes from. +DataSource + tree SRef + UniqueTree tree |] {- Opens the database, creating it if it doesn't exist yet. -} @@ -68,48 +91,110 @@ queueDb (ExportHandle h) = H.queueDb h checkcommit | sz > 1000 = return True | otherwise = return False -addExportLocation :: ExportHandle -> Key -> ExportLocation -> IO () -addExportLocation h k el@(ExportLocation f) = queueDb h $ do +flushDbQueue :: ExportHandle -> IO () +flushDbQueue (ExportHandle h) = H.flushDbQueue h + +recordDataSource :: ExportHandle -> Sha -> IO () +recordDataSource h s = queueDb h $ do + delete $ from $ \r -> do + where_ (r ^. DataSourceTree ==. r ^. DataSourceTree) + void $ insertUnique $ DataSource (toSRef s) + +getDataSource :: ExportHandle -> IO (Maybe Sha) +getDataSource (ExportHandle h) = H.queryDbQueue h $ do + l <- select $ from $ \r -> do + where_ (r ^. DataSourceTree ==. r ^. DataSourceTree) + return (r ^. DataSourceTree) + case l of + (s:[]) -> return (Just (fromSRef (unValue s))) + _ -> return Nothing + +addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () +addExportedLocation h k el = queueDb h $ do void $ insertUnique $ Exported ik ef insertMany_ $ map - (\(ExportDirectory d) -> ExportedDirectory (toSFilePath d) ef) + (\ed -> ExportedDirectory (toSFilePath (fromExportDirectory ed)) ef) (exportDirectories el) where ik = toIKey k - ef = toSFilePath f + ef = toSFilePath (fromExportLocation el) -removeExportLocation :: ExportHandle -> Key -> ExportLocation -> IO () -removeExportLocation h k el@(ExportLocation f) = queueDb h $ do +removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () +removeExportedLocation h k el = queueDb h $ do delete $ from $ \r -> do where_ (r ^. ExportedKey ==. val ik &&. r ^. ExportedFile ==. val ef) - let subdirs = map (\(ExportDirectory d) -> toSFilePath d) + let subdirs = map (toSFilePath . fromExportDirectory) (exportDirectories el) delete $ from $ \r -> do where_ (r ^. ExportedDirectoryFile ==. val ef &&. r ^. ExportedDirectorySubdir `in_` valList subdirs) where ik = toIKey k - ef = toSFilePath f - -flushDbQueue :: ExportHandle -> IO () -flushDbQueue (ExportHandle h) = H.flushDbQueue h + ef = toSFilePath (fromExportLocation el) {- Note that this does not see recently queued changes. -} -getExportLocation :: ExportHandle -> Key -> IO [ExportLocation] -getExportLocation (ExportHandle h) k = H.queryDbQueue h $ do +getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation] +getExportedLocation (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 + return $ map (mkExportLocation . fromSFilePath . unValue) l where ik = toIKey k {- Note that this does not see recently queued changes. -} isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool -isExportDirectoryEmpty (ExportHandle h) (ExportDirectory d) = H.queryDbQueue h $ do +isExportDirectoryEmpty (ExportHandle h) d = H.queryDbQueue h $ do l <- select $ from $ \r -> do where_ (r ^. ExportedDirectorySubdir ==. val ed) return (r ^. ExportedDirectoryFile) return $ null l where - ed = toSFilePath d + ed = toSFilePath $ 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 <- select $ from $ \r -> do + where_ (r ^. ExportTreeKey ==. val ik) + return (r ^. ExportTreeFile) + return $ map (mkExportLocation . fromSFilePath . unValue) l + where + ik = toIKey k + +addExportTree :: ExportHandle -> Key -> ExportLocation -> IO () +addExportTree h k loc = queueDb h $ + void $ insertUnique $ Exported ik ef + where + ik = toIKey k + ef = toSFilePath (fromExportLocation loc) + +removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO () +removeExportTree h k loc = queueDb h $ + delete $ from $ \r -> + where_ (r ^. ExportTreeKey ==. val ik &&. r ^. ExportTreeFile ==. val ef) + where + ik = toIKey k + ef = toSFilePath (fromExportLocation loc) + +{- Diff from the old to the new tree and update the ExportTree table. -} +updateExportTree :: ExportHandle -> Sha -> Sha -> Annex () +updateExportTree h old new = do + (diff, cleanup) <- inRepo $ + Git.DiffTree.diffTreeRecursive old new + forM_ diff $ \i -> do + let loc = mkExportLocation $ getTopFilePath $ + Git.DiffTree.file i + srcek <- getek (Git.DiffTree.srcsha i) + case srcek of + Nothing -> return () + Just k -> liftIO $ removeExportTree h (asKey k) loc + dstek <- getek (Git.DiffTree.dstsha i) + case dstek of + Nothing -> return () + Just k -> liftIO $ addExportTree h (asKey k) loc + void $ liftIO cleanup + where + getek sha + | sha == nullSha = return Nothing + | otherwise = Just <$> exportKey sha diff --git a/Database/Types.hs b/Database/Types.hs index a4b5fbcb1..49a63f067 100644 --- a/Database/Types.hs +++ b/Database/Types.hs @@ -1,6 +1,6 @@ {- types for SQL databases - - - Copyright 2015-2016 Joey Hess + - Copyright 2015-2017 Joey Hess - - Licensed under the GNU GPL version 3 or higher. -} @@ -16,6 +16,7 @@ import Data.Char import Utility.PartialPrelude import Key import Utility.InodeCache +import Git.Types (Ref(..)) -- A serialized Key newtype SKey = SKey String @@ -93,3 +94,21 @@ fromSFilePath (SFilePath s) = s derivePersistField "SFilePath" +-- A serialized Ref +newtype SRef = SRef Ref + +-- Note that Read instance does not work when used in any kind of complex +-- data structure. +instance Read SRef where + readsPrec _ s = [(SRef (Ref s), "")] + +instance Show SRef where + show (SRef (Ref s)) = s + +derivePersistField "SRef" + +toSRef :: Ref -> SRef +toSRef = SRef + +fromSRef :: SRef -> Ref +fromSRef (SRef r) = r -- cgit v1.2.3