1{- Sqlite database used for exports to special remotes. 2 - 3 - Copyright 2017-2019 Joey Hess <id@joeyh.name> 4 -: 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE CPP #-} 9{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} 10{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-} 11{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} 12{-# LANGUAGE RankNTypes #-} 13{-# LANGUAGE DataKinds, FlexibleInstances #-} 14{-# LANGUAGE UndecidableInstances #-} 15#if MIN_VERSION_persistent_template(2,8,0) 16{-# LANGUAGE DerivingStrategies #-} 17{-# LANGUAGE StandaloneDeriving #-} 18#endif 19 20module Database.Export ( 21 ExportHandle, 22 openDb, 23 closeDb, 24 writeLockDbWhile, 25 flushDbQueue, 26 addExportedLocation, 27 removeExportedLocation, 28 getExportedLocation, 29 isExportDirectoryEmpty, 30 getExportTreeCurrent, 31 recordExportTreeCurrent, 32 getExportTree, 33 getExportTreeKey, 34 addExportTree, 35 removeExportTree, 36 updateExportTree, 37 updateExportTree', 38 updateExportTreeFromLog, 39 updateExportDb, 40 ExportedId, 41 ExportedDirectoryId, 42 ExportTreeId, 43 ExportTreeCurrentId, 44 ExportUpdateResult(..), 45 ExportDiffUpdater, 46 runExportDiffUpdater, 47) where 48 49import Database.Types 50import qualified Database.Queue as H 51import Database.Init 52import Annex.Locations 53import Annex.Common hiding (delete) 54import Types.Export 55import Annex.Export 56import qualified Logs.Export as Log 57import Annex.LockFile 58import Annex.LockPool 59import Git.Types 60import Git.Sha 61import Git.FilePath 62import qualified Git.DiffTree 63import qualified Utility.RawFilePath as R 64 65import Database.Persist.Sql hiding (Key) 66import Database.Persist.TH 67import qualified System.FilePath.ByteString as P 68 69data ExportHandle = ExportHandle H.DbQueue UUID 70 71share [mkPersist sqlSettings, mkMigrate "migrateExport"] [persistLowerCase| 72-- Files that have been exported to the remote and are present on it. 73Exported 74 key Key 75 file SFilePath 76 ExportedIndex key file 77-- Directories that exist on the remote, and the files that are in them. 78ExportedDirectory 79 subdir SFilePath 80 file SFilePath 81 ExportedDirectoryIndex subdir file 82-- The content of the tree that has been exported to the remote. 83-- Not all of these files are necessarily present on the remote yet. 84ExportTree 85 key Key 86 file SFilePath 87 ExportTreeKeyFileIndex key file 88 ExportTreeFileKeyIndex file key 89-- The tree stored in ExportTree 90ExportTreeCurrent 91 tree SSha 92 UniqueTree tree 93|] 94 95{- Opens the database, creating it if it doesn't exist yet. 96 - 97 - Only a single process should write to the export at a time, so guard 98 - any writes with the gitAnnexExportLock. 99 -} 100openDb :: UUID -> Annex ExportHandle 101openDb u = do 102 dbdir <- fromRepo (gitAnnexExportDbDir u) 103 let db = dbdir P.</> "db" 104 unlessM (liftIO $ R.doesPathExist db) $ do 105 initDb db $ void $ 106 runMigrationSilent migrateExport 107 h <- liftIO $ H.openDbQueue H.SingleWriter db "exported" 108 return $ ExportHandle h u 109 110closeDb :: ExportHandle -> Annex () 111closeDb (ExportHandle h _) = liftIO $ H.closeDbQueue h 112 113queueDb :: ExportHandle -> SqlPersistM () -> IO () 114queueDb (ExportHandle h _) = H.queueDb h checkcommit 115 where 116 -- commit queue after 1000 changes 117 checkcommit sz _lastcommittime 118 | sz > 1000 = return True 119 | otherwise = return False 120 121flushDbQueue :: ExportHandle -> IO () 122flushDbQueue (ExportHandle h _) = H.flushDbQueue h 123 124recordExportTreeCurrent :: ExportHandle -> Sha -> IO () 125recordExportTreeCurrent h s = queueDb h $ do 126 deleteWhere ([] :: [Filter ExportTreeCurrent]) 127 void $ insertUnique $ ExportTreeCurrent $ toSSha s 128 129getExportTreeCurrent :: ExportHandle -> IO (Maybe Sha) 130getExportTreeCurrent (ExportHandle h _) = H.queryDbQueue h $ do 131 l <- selectList ([] :: [Filter ExportTreeCurrent]) [] 132 case l of 133 (s:[]) -> return $ Just $ fromSSha $ 134 exportTreeCurrentTree $ entityVal s 135 _ -> return Nothing 136 137addExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () 138addExportedLocation h k el = queueDb h $ do 139 void $ insertUnique $ Exported k ef 140 let edirs = map 141 (\ed -> ExportedDirectory (SFilePath (fromExportDirectory ed)) ef) 142 (exportDirectories el) 143 putMany edirs 144 where 145 ef = SFilePath (fromExportLocation el) 146 147removeExportedLocation :: ExportHandle -> Key -> ExportLocation -> IO () 148removeExportedLocation h k el = queueDb h $ do 149 deleteWhere [ExportedKey ==. k, ExportedFile ==. ef] 150 let subdirs = map (SFilePath . fromExportDirectory) 151 (exportDirectories el) 152 deleteWhere [ExportedDirectoryFile ==. ef, ExportedDirectorySubdir <-. subdirs] 153 where 154 ef = SFilePath (fromExportLocation el) 155 156{- Note that this does not see recently queued changes. -} 157getExportedLocation :: ExportHandle -> Key -> IO [ExportLocation] 158getExportedLocation (ExportHandle h _) k = H.queryDbQueue h $ do 159 l <- selectList [ExportedKey ==. k] [] 160 return $ map (mkExportLocation . (\(SFilePath f) -> f) . exportedFile . entityVal) l 161 162{- Note that this does not see recently queued changes. -} 163isExportDirectoryEmpty :: ExportHandle -> ExportDirectory -> IO Bool 164isExportDirectoryEmpty (ExportHandle h _) d = H.queryDbQueue h $ do 165 l <- selectList [ExportedDirectorySubdir ==. ed] [] 166 return $ null l 167 where 168 ed = SFilePath $ fromExportDirectory d 169 170{- Get locations in the export that might contain a key. -} 171getExportTree :: ExportHandle -> Key -> IO [ExportLocation] 172getExportTree (ExportHandle h _) k = H.queryDbQueue h $ do 173 l <- selectList [ExportTreeKey ==. k] [] 174 return $ map (mkExportLocation . (\(SFilePath f) -> f) . exportTreeFile . entityVal) l 175 176{- Get keys that might be currently exported to a location. 177 - 178 - Note that this does not see recently queued changes. 179 -} 180getExportTreeKey :: ExportHandle -> ExportLocation -> IO [Key] 181getExportTreeKey (ExportHandle h _) el = H.queryDbQueue h $ do 182 map (exportTreeKey . entityVal) 183 <$> selectList [ExportTreeFile ==. ef] [] 184 where 185 ef = SFilePath (fromExportLocation el) 186 187addExportTree :: ExportHandle -> Key -> ExportLocation -> IO () 188addExportTree h k loc = queueDb h $ 189 void $ insertUnique $ ExportTree k ef 190 where 191 ef = SFilePath (fromExportLocation loc) 192 193removeExportTree :: ExportHandle -> Key -> ExportLocation -> IO () 194removeExportTree h k loc = queueDb h $ 195 deleteWhere [ExportTreeKey ==. k, ExportTreeFile ==. ef] 196 where 197 ef = SFilePath (fromExportLocation loc) 198 199-- An action that is passed the old and new values that were exported, 200-- and updates state. 201type ExportDiffUpdater 202 = ExportHandle 203 -> Maybe Key 204 -- ^ old exported key 205 -> Maybe Key 206 -- ^ new exported key 207 -> Git.DiffTree.DiffTreeItem 208 -> Annex () 209 210mkExportDiffUpdater 211 :: (ExportHandle -> Key -> ExportLocation -> IO ()) 212 -> (ExportHandle -> Key -> ExportLocation -> IO ()) 213 -> ExportDiffUpdater 214mkExportDiffUpdater removeold addnew h srcek dstek i = do 215 case srcek of 216 Nothing -> return () 217 Just k -> liftIO $ removeold h k loc 218 case dstek of 219 Nothing -> return () 220 Just k -> liftIO $ addnew h k loc 221 where 222 loc = mkExportLocation $ getTopFilePath $ Git.DiffTree.file i 223 224runExportDiffUpdater :: ExportDiffUpdater -> ExportHandle -> Sha -> Sha -> Annex () 225runExportDiffUpdater updater h old new = do 226 (diff, cleanup) <- inRepo $ 227 Git.DiffTree.diffTreeRecursive old new 228 forM_ diff $ \i -> do 229 srcek <- getek (Git.DiffTree.srcsha i) 230 dstek <- getek (Git.DiffTree.dstsha i) 231 updater h srcek dstek i 232 void $ liftIO cleanup 233 where 234 getek sha 235 | sha `elem` nullShas = return Nothing 236 | otherwise = Just <$> exportKey sha 237 238{- Diff from the old to the new tree and update the ExportTree table. -} 239updateExportTree :: ExportHandle -> Sha -> Sha -> Annex () 240updateExportTree = runExportDiffUpdater updateExportTree' 241 242updateExportTree' :: ExportDiffUpdater 243updateExportTree' = mkExportDiffUpdater removeExportTree addExportTree 244 245{- Diff from the old to the new tree and update all tables in the export 246 - database. Should only be used when all the files in the new tree have 247 - been verified to already be present in the export remote. -} 248updateExportDb :: ExportHandle -> Sha -> Sha -> Annex () 249updateExportDb = runExportDiffUpdater $ mkExportDiffUpdater removeold addnew 250 where 251 removeold h k loc = liftIO $ do 252 removeExportTree h k loc 253 removeExportedLocation h k loc 254 addnew h k loc = liftIO $ do 255 addExportTree h k loc 256 addExportedLocation h k loc 257 258{- Runs an action with the database locked for write. Waits for any other 259 - writers to finish first. The queue is flushed at the end. 260 - 261 - This first updates the ExportTree table with any new information 262 - from the git-annex branch export log. 263 -} 264writeLockDbWhile :: ExportHandle -> Annex a -> Annex a 265writeLockDbWhile db@(ExportHandle _ u) a = do 266 updatelck <- takeExclusiveLock (gitAnnexExportUpdateLock u) 267 withExclusiveLock (gitAnnexExportLock u) $ do 268 bracket_ (setup updatelck) cleanup a 269 where 270 setup updatelck = do 271 void $ updateExportTreeFromLog' db 272 -- flush the update so it's available immediately to 273 -- anything waiting on the updatelck 274 liftIO $ flushDbQueue db 275 liftIO $ dropLock updatelck 276 cleanup = liftIO $ flushDbQueue db 277 278data ExportUpdateResult = ExportUpdateSuccess | ExportUpdateConflict 279 deriving (Eq) 280 281{- Updates the ExportTree table with information from the 282 - git-annex branch export log. 283 - 284 - This can safely be called whether the database is locked for write or 285 - not. Either way, it will block until the update is complete. 286 -} 287updateExportTreeFromLog :: ExportHandle -> Annex ExportUpdateResult 288updateExportTreeFromLog db@(ExportHandle _ u) = 289 -- If another process or thread is performing the update, 290 -- this will block until it's done. 291 withExclusiveLock (gitAnnexExportUpdateLock u) $ do 292 -- If the database is locked by something else, 293 -- this will not run the update. But, in that case, 294 -- writeLockDbWhile is running, and has already 295 -- completed the update, so we don't need to do anything. 296 mr <- tryExclusiveLock (gitAnnexExportLock u) $ 297 updateExportTreeFromLog' db 298 case mr of 299 Just r -> return r 300 Nothing -> do 301 old <- liftIO $ fromMaybe emptyTree 302 <$> getExportTreeCurrent db 303 l <- Log.getExport u 304 return $ case Log.exportedTreeishes l of 305 [] -> ExportUpdateSuccess 306 (new:[]) 307 | new /= old -> ExportUpdateSuccess 308 | new == old -> ExportUpdateSuccess 309 _ts -> ExportUpdateConflict 310 311{- The database should be locked when calling this. -} 312updateExportTreeFromLog' :: ExportHandle -> Annex ExportUpdateResult 313updateExportTreeFromLog' db@(ExportHandle _ u) = do 314 old <- liftIO $ fromMaybe emptyTree 315 <$> getExportTreeCurrent db 316 l <- Log.getExport u 317 case Log.exportedTreeishes l of 318 [] -> return ExportUpdateSuccess 319 (new:[]) 320 | new /= old -> do 321 updateExportTree db old new 322 liftIO $ recordExportTreeCurrent db new 323 liftIO $ flushDbQueue db 324 return ExportUpdateSuccess 325 | new == old -> return ExportUpdateSuccess 326 _ts -> return ExportUpdateConflict 327