diff options
Diffstat (limited to 'Database')
| -rw-r--r-- | Database/Keys.hs | 120 | ||||
| -rw-r--r-- | Database/Keys/SQL.hs | 100 |
2 files changed, 123 insertions, 97 deletions
diff --git a/Database/Keys.hs b/Database/Keys.hs index 4c4c65850..a711ba7ca 100644 --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -21,10 +21,9 @@ module Database.Keys ( addInodeCaches, getInodeCaches, removeInodeCaches, - AssociatedId, - ContentId, ) where +import qualified Database.Keys.SQL as SQL import Database.Types import Database.Keys.Handle import qualified Database.Queue as H @@ -42,24 +41,7 @@ import Git.Ref import Git.FilePath import Annex.CatFile -import Database.Persist.TH import Database.Esqueleto hiding (Key) -import Data.Time.Clock - -share [mkPersist sqlSettings, mkMigrate "migrateKeysDb"] [persistLowerCase| -Associated - key SKey - file FilePath - KeyFileIndex key file -Content - key SKey - cache SInodeCache - KeyCacheIndex key cache -|] - -newtype ReadHandle = ReadHandle H.DbQueue - -type Reader v = ReadHandle -> Annex v {- Runs an action that reads from the database. - @@ -72,7 +54,7 @@ type Reader v = ReadHandle -> Annex v - - Any queued writes will be flushed before the read. -} -runReader :: Monoid v => Reader v -> Annex v +runReader :: Monoid v => (SQL.ReadHandle -> Annex v) -> Annex v runReader a = do h <- getDbHandle withDbState h go @@ -80,50 +62,39 @@ runReader a = do go DbEmpty = return (mempty, DbEmpty) go st@(DbOpen qh) = do liftIO $ H.flushDbQueue qh - v <- a (ReadHandle qh) + v <- a (SQL.ReadHandle qh) return (v, st) go DbClosed = do st' <- openDb False DbClosed v <- case st' of - (DbOpen qh) -> a (ReadHandle qh) + (DbOpen qh) -> a (SQL.ReadHandle qh) _ -> return mempty return (v, st') -readDb :: SqlPersistM a -> ReadHandle -> Annex a -readDb a (ReadHandle h) = liftIO $ H.queryDbQueue h a - -newtype WriteHandle = WriteHandle H.DbQueue - -type Writer = WriteHandle -> Annex () +runReaderIO :: Monoid v => (SQL.ReadHandle -> IO v) -> Annex v +runReaderIO a = runReader (liftIO . a) {- Runs an action that writes to the database. Typically this is used to - queue changes, which will be flushed at a later point. - - The database is created if it doesn't exist yet. -} -runWriter :: Writer -> Annex () +runWriter :: (SQL.WriteHandle -> Annex ()) -> Annex () runWriter a = do h <- getDbHandle withDbState h go where go st@(DbOpen qh) = do - v <- a (WriteHandle qh) + v <- a (SQL.WriteHandle qh) return (v, st) go st = do st' <- openDb True st v <- case st' of - DbOpen qh -> a (WriteHandle qh) + DbOpen qh -> a (SQL.WriteHandle qh) _ -> error "internal" return (v, st') -queueDb :: SqlPersistM () -> WriteHandle -> Annex () -queueDb a (WriteHandle h) = liftIO $ H.queueDb h checkcommit a - where - -- commit queue after 1000 changes or 5 minutes, whichever comes first - checkcommit sz lastcommittime - | sz > 1000 = return True - | otherwise = do - now <- getCurrentTime - return $ diffUTCTime lastcommittime now > 300 +runWriterIO :: (SQL.WriteHandle -> IO ()) -> Annex () +runWriterIO a = runWriter (liftIO . a) {- Gets the handle cached in Annex state; creates a new one if it's not yet - available, but doesn't open the database. -} @@ -157,7 +128,7 @@ openDb createdb _ = withExclusiveLock gitAnnexKeysDbLock $ do liftIO $ do createDirectoryIfMissing True dbdir H.initDb db $ void $ - runMigrationSilent migrateKeysDb + runMigrationSilent SQL.migrateKeysDb setAnnexDirPerm dbdir setAnnexFilePerm db open db @@ -166,50 +137,21 @@ openDb createdb _ = withExclusiveLock gitAnnexKeysDbLock $ do open db = liftIO $ DbOpen <$> H.openDbQueue db "content" addAssociatedFile :: Key -> TopFilePath -> Annex () -addAssociatedFile k f = runWriter $ addAssociatedFile' k f - -addAssociatedFile' :: Key -> TopFilePath -> Writer -addAssociatedFile' k f = queueDb $ do - -- If the same file was associated with a different key before, - -- remove that. - delete $ from $ \r -> do - where_ (r ^. AssociatedFile ==. val (getTopFilePath f) &&. not_ (r ^. AssociatedKey ==. val sk)) - void $ insertUnique $ Associated sk (getTopFilePath f) - where - sk = toSKey k +addAssociatedFile k f = runWriterIO $ SQL.addAssociatedFile (toSKey k) f {- Note that the files returned were once associated with the key, but - some of them may not be any longer. -} getAssociatedFiles :: Key -> Annex [TopFilePath] -getAssociatedFiles = runReader . getAssociatedFiles' . toSKey - -getAssociatedFiles' :: SKey -> Reader [TopFilePath] -getAssociatedFiles' sk = readDb $ do - l <- select $ from $ \r -> do - where_ (r ^. AssociatedKey ==. val sk) - return (r ^. AssociatedFile) - return $ map (asTopFilePath . unValue) l +getAssociatedFiles = runReaderIO . SQL.getAssociatedFiles . toSKey {- Gets any keys that are on record as having a particular associated file. - (Should be one or none but the database doesn't enforce that.) -} getAssociatedKey :: TopFilePath -> Annex [Key] -getAssociatedKey = runReader . getAssociatedKey' - -getAssociatedKey' :: TopFilePath -> Reader [Key] -getAssociatedKey' f = readDb $ do - l <- select $ from $ \r -> do - where_ (r ^. AssociatedFile ==. val (getTopFilePath f)) - return (r ^. AssociatedKey) - return $ map (fromSKey . unValue) l +getAssociatedKey = map fromSKey <$$> runReaderIO . SQL.getAssociatedKey removeAssociatedFile :: Key -> TopFilePath -> Annex () -removeAssociatedFile k = runWriter . removeAssociatedFile' (toSKey k) +removeAssociatedFile k = runWriterIO . SQL.removeAssociatedFile (toSKey k) -removeAssociatedFile' :: SKey -> TopFilePath -> Writer -removeAssociatedFile' sk f = queueDb $ - delete $ from $ \r -> do - where_ (r ^. AssociatedKey ==. val sk &&. r ^. AssociatedFile ==. val (getTopFilePath f)) - {- Find all unlocked associated files. This is expensive, and so normally - the associated files are updated incrementally when changes are noticed. -} scanAssociatedFiles :: Annex () @@ -224,12 +166,12 @@ scanAssociatedFiles = whenM (isJust <$> inRepo Git.Branch.current) $ =<< catKey (Git.LsTree.sha i) liftIO $ void cleanup where - dropallassociated = queueDb $ - delete $ from $ \(_r :: SqlExpr (Entity Associated)) -> + dropallassociated h = liftIO $ flip SQL.queueDb h $ + delete $ from $ \(_r :: SqlExpr (Entity SQL.Associated)) -> return () isregfile i = Git.Types.toBlobType (Git.LsTree.mode i) == Just Git.Types.FileBlob - add h i k = flip queueDb h $ - void $ insertUnique $ Associated + add h i k = liftIO $ flip SQL.queueDb h $ + void $ insertUnique $ SQL.Associated (toSKey k) (getTopFilePath $ Git.LsTree.file i) @@ -239,28 +181,12 @@ storeInodeCaches k fs = withTSDelta $ \d -> addInodeCaches k . catMaybes =<< liftIO (mapM (`genInodeCache` d) fs) addInodeCaches :: Key -> [InodeCache] -> Annex () -addInodeCaches k is = runWriter $ addInodeCaches' (toSKey k) is - -addInodeCaches' :: SKey -> [InodeCache] -> Writer -addInodeCaches' sk is = queueDb $ - forM_ is $ \i -> insertUnique $ Content sk (toSInodeCache i) +addInodeCaches k is = runWriterIO $ SQL.addInodeCaches (toSKey k) is {- A key may have multiple InodeCaches; one for the annex object, and one - for each pointer file that is a copy of it. -} getInodeCaches :: Key -> Annex [InodeCache] -getInodeCaches = runReader . getInodeCaches' . toSKey - -getInodeCaches' :: SKey -> Reader [InodeCache] -getInodeCaches' sk = readDb $ do - l <- select $ from $ \r -> do - where_ (r ^. ContentKey ==. val sk) - return (r ^. ContentCache) - return $ map (fromSInodeCache . unValue) l +getInodeCaches = runReaderIO . SQL.getInodeCaches . toSKey removeInodeCaches :: Key -> Annex () -removeInodeCaches = runWriter . removeInodeCaches' . toSKey - -removeInodeCaches' :: SKey -> Writer -removeInodeCaches' sk = queueDb $ - delete $ from $ \r -> do - where_ (r ^. ContentKey ==. val sk) +removeInodeCaches = runWriterIO . SQL.removeInodeCaches . toSKey diff --git a/Database/Keys/SQL.hs b/Database/Keys/SQL.hs new file mode 100644 index 000000000..22bcb86a1 --- /dev/null +++ b/Database/Keys/SQL.hs @@ -0,0 +1,100 @@ +{- Sqlite database of information about Keys + - + - Copyright 2015-2016 Joey Hess <id@joeyh.name> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings, GADTs, FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes, ScopedTypeVariables #-} + +module Database.Keys.SQL where + +import Database.Types +import qualified Database.Queue as H +import Utility.InodeCache +import Git.FilePath + +import Database.Persist.TH +import Database.Esqueleto hiding (Key) +import Data.Time.Clock +import Control.Monad + +share [mkPersist sqlSettings, mkMigrate "migrateKeysDb"] [persistLowerCase| +Associated + key SKey + file FilePath + KeyFileIndex key file +Content + key SKey + cache SInodeCache + KeyCacheIndex key cache +|] + +newtype ReadHandle = ReadHandle H.DbQueue + +readDb :: SqlPersistM a -> ReadHandle -> IO a +readDb a (ReadHandle h) = H.queryDbQueue h a + +newtype WriteHandle = WriteHandle H.DbQueue + +queueDb :: SqlPersistM () -> WriteHandle -> IO () +queueDb a (WriteHandle h) = H.queueDb h checkcommit a + where + -- commit queue after 1000 changes or 5 minutes, whichever comes first + checkcommit sz lastcommittime + | sz > 1000 = return True + | otherwise = do + now <- getCurrentTime + return $ diffUTCTime lastcommittime now > 300 + +addAssociatedFile :: SKey -> TopFilePath -> WriteHandle -> IO () +addAssociatedFile sk f = queueDb $ do + -- If the same file was associated with a different key before, + -- remove that. + delete $ from $ \r -> do + where_ (r ^. AssociatedFile ==. val (getTopFilePath f) &&. not_ (r ^. AssociatedKey ==. val sk)) + void $ insertUnique $ Associated sk (getTopFilePath f) + +{- Note that the files returned were once associated with the key, but + - some of them may not be any longer. -} +getAssociatedFiles :: SKey -> ReadHandle -> IO [TopFilePath] +getAssociatedFiles sk = readDb $ do + l <- select $ from $ \r -> do + where_ (r ^. AssociatedKey ==. val sk) + return (r ^. AssociatedFile) + return $ map (asTopFilePath . unValue) l + +{- Gets any keys that are on record as having a particular associated file. + - (Should be one or none but the database doesn't enforce that.) -} +getAssociatedKey :: TopFilePath -> ReadHandle -> IO [SKey] +getAssociatedKey f = readDb $ do + l <- select $ from $ \r -> do + where_ (r ^. AssociatedFile ==. val (getTopFilePath f)) + return (r ^. AssociatedKey) + return $ map unValue l + +removeAssociatedFile :: SKey -> TopFilePath -> WriteHandle -> IO () +removeAssociatedFile sk f = queueDb $ + delete $ from $ \r -> do + where_ (r ^. AssociatedKey ==. val sk &&. r ^. AssociatedFile ==. val (getTopFilePath f)) + +addInodeCaches :: SKey -> [InodeCache] -> WriteHandle -> IO () +addInodeCaches sk is = queueDb $ + forM_ is $ \i -> insertUnique $ Content sk (toSInodeCache i) + +{- A key may have multiple InodeCaches; one for the annex object, and one + - for each pointer file that is a copy of it. -} +getInodeCaches :: SKey -> ReadHandle -> IO [InodeCache] +getInodeCaches sk = readDb $ do + l <- select $ from $ \r -> do + where_ (r ^. ContentKey ==. val sk) + return (r ^. ContentCache) + return $ map (fromSInodeCache . unValue) l + +removeInodeCaches :: SKey -> WriteHandle -> IO () +removeInodeCaches sk = queueDb $ + delete $ from $ \r -> do + where_ (r ^. ContentKey ==. val sk) |