diff options
Diffstat (limited to 'Database/Export.hs')
-rw-r--r-- | Database/Export.hs | 127 |
1 files changed, 106 insertions, 21 deletions
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 |