diff options
| -rw-r--r-- | Command/Benchmark.hs | 10 | ||||
| -rw-r--r-- | Database/Keys.hs | 16 | ||||
| -rw-r--r-- | Database/Keys/SQL.hs | 44 | ||||
| -rw-r--r-- | Database/Types.hs | 18 |
4 files changed, 53 insertions, 35 deletions
diff --git a/Command/Benchmark.hs b/Command/Benchmark.hs index b1cc9a830..bcfecc2dc 100644 --- a/Command/Benchmark.hs +++ b/Command/Benchmark.hs @@ -87,13 +87,13 @@ populateAssociatedFiles h num = do SQL.addAssociatedFile (keyN n) (fileN n) (SQL.WriteHandle h) H.flushDbQueue h -keyN :: Int -> SKey -keyN n = SKey ("key" ++ show n) +keyN :: Int -> IKey +keyN n = IKey ("key" ++ show n) fileN :: Int -> TopFilePath fileN n = asTopFilePath ("file" ++ show n) -keyMiss :: SKey +keyMiss :: IKey keyMiss = keyN 0 -- 0 is never stored fileMiss :: TopFilePath @@ -114,8 +114,8 @@ benchDb tmpdir num = do instance NFData TopFilePath where rnf = rnf . getTopFilePath -instance NFData SKey where - rnf (SKey s) = rnf s +instance NFData IKey where + rnf (IKey s) = rnf s -- can't use Criterion's defaultMain here because it looks at -- command-line parameters diff --git a/Database/Keys.hs b/Database/Keys.hs index 89410e741..fdba05312 100644 --- a/Database/Keys.hs +++ b/Database/Keys.hs @@ -133,20 +133,20 @@ openDb createdb _ = withExclusiveLock gitAnnexKeysDbLock $ do open db = liftIO $ DbOpen <$> H.openDbQueue db SQL.containedTable addAssociatedFile :: Key -> TopFilePath -> Annex () -addAssociatedFile k f = runWriterIO $ SQL.addAssociatedFile (toSKey k) f +addAssociatedFile k f = runWriterIO $ SQL.addAssociatedFile (toIKey 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 = runReaderIO . SQL.getAssociatedFiles . toSKey +getAssociatedFiles = runReaderIO . SQL.getAssociatedFiles . toIKey {- 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 = map fromSKey <$$> runReaderIO . SQL.getAssociatedKey +getAssociatedKey = map fromIKey <$$> runReaderIO . SQL.getAssociatedKey removeAssociatedFile :: Key -> TopFilePath -> Annex () -removeAssociatedFile k = runWriterIO . SQL.removeAssociatedFile (toSKey k) +removeAssociatedFile k = runWriterIO . SQL.removeAssociatedFile (toIKey k) {- Find all unlocked associated files. This is expensive, and so normally - the associated files are updated incrementally when changes are noticed. -} @@ -168,7 +168,7 @@ scanAssociatedFiles = whenM (isJust <$> inRepo Git.Branch.current) $ isregfile i = Git.Types.toBlobType (Git.LsTree.mode i) == Just Git.Types.FileBlob add h i k = liftIO $ flip SQL.queueDb h $ void $ insertUnique $ SQL.Associated - (toSKey k) + (toIKey k) (getTopFilePath $ Git.LsTree.file i) {- Stats the files, and stores their InodeCaches. -} @@ -177,12 +177,12 @@ storeInodeCaches k fs = withTSDelta $ \d -> addInodeCaches k . catMaybes =<< liftIO (mapM (`genInodeCache` d) fs) addInodeCaches :: Key -> [InodeCache] -> Annex () -addInodeCaches k is = runWriterIO $ SQL.addInodeCaches (toSKey k) is +addInodeCaches k is = runWriterIO $ SQL.addInodeCaches (toIKey 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 = runReaderIO . SQL.getInodeCaches . toSKey +getInodeCaches = runReaderIO . SQL.getInodeCaches . toIKey removeInodeCaches :: Key -> Annex () -removeInodeCaches = runWriterIO . SQL.removeInodeCaches . toSKey +removeInodeCaches = runWriterIO . SQL.removeInodeCaches . toIKey diff --git a/Database/Keys/SQL.hs b/Database/Keys/SQL.hs index 79230b60d..456b48e46 100644 --- a/Database/Keys/SQL.hs +++ b/Database/Keys/SQL.hs @@ -25,12 +25,12 @@ import Control.Monad share [mkPersist sqlSettings, mkMigrate "migrateKeysDb"] [persistLowerCase| Associated - key SKey + key IKey file FilePath KeyFileIndex key file FileKeyIndex file key Content - key SKey + key IKey cache SInodeCache KeyCacheIndex key cache |] @@ -58,51 +58,51 @@ queueDb a (WriteHandle h) = H.queueDb h checkcommit a now <- getCurrentTime return $ diffUTCTime lastcommittime now > 300 -addAssociatedFile :: SKey -> TopFilePath -> WriteHandle -> IO () -addAssociatedFile sk f = queueDb $ do +addAssociatedFile :: IKey -> TopFilePath -> WriteHandle -> IO () +addAssociatedFile ik 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_ (r ^. AssociatedFile ==. val (getTopFilePath f) &&. not_ (r ^. AssociatedKey ==. val ik)) + void $ insertUnique $ Associated ik (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 +getAssociatedFiles :: IKey -> ReadHandle -> IO [TopFilePath] +getAssociatedFiles ik = readDb $ do l <- select $ from $ \r -> do - where_ (r ^. AssociatedKey ==. val sk) + where_ (r ^. AssociatedKey ==. val ik) 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 :: TopFilePath -> ReadHandle -> IO [IKey] 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 $ +removeAssociatedFile :: IKey -> TopFilePath -> WriteHandle -> IO () +removeAssociatedFile ik f = queueDb $ delete $ from $ \r -> do - where_ (r ^. AssociatedKey ==. val sk &&. r ^. AssociatedFile ==. val (getTopFilePath f)) + where_ (r ^. AssociatedKey ==. val ik &&. r ^. AssociatedFile ==. val (getTopFilePath f)) -addInodeCaches :: SKey -> [InodeCache] -> WriteHandle -> IO () -addInodeCaches sk is = queueDb $ - forM_ is $ \i -> insertUnique $ Content sk (toSInodeCache i) +addInodeCaches :: IKey -> [InodeCache] -> WriteHandle -> IO () +addInodeCaches ik is = queueDb $ + forM_ is $ \i -> insertUnique $ Content ik (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 +getInodeCaches :: IKey -> ReadHandle -> IO [InodeCache] +getInodeCaches ik = readDb $ do l <- select $ from $ \r -> do - where_ (r ^. ContentKey ==. val sk) + where_ (r ^. ContentKey ==. val ik) return (r ^. ContentCache) return $ map (fromSInodeCache . unValue) l -removeInodeCaches :: SKey -> WriteHandle -> IO () -removeInodeCaches sk = queueDb $ +removeInodeCaches :: IKey -> WriteHandle -> IO () +removeInodeCaches ik = queueDb $ delete $ from $ \r -> do - where_ (r ^. ContentKey ==. val sk) + where_ (r ^. ContentKey ==. val ik) diff --git a/Database/Types.hs b/Database/Types.hs index 1476a693a..6667bc343 100644 --- a/Database/Types.hs +++ b/Database/Types.hs @@ -27,6 +27,24 @@ fromSKey (SKey s) = fromMaybe (error $ "bad serialied Key " ++ s) (file2key s) derivePersistField "SKey" +-- A Key index. More efficient than SKey, but its Read instance does not +-- work when it's used in any kind of complex data structure. +newtype IKey = IKey String + +instance Read IKey where + readsPrec _ s = [(IKey s, "")] + +instance Show IKey where + show (IKey s) = s + +toIKey :: Key -> IKey +toIKey = IKey . key2file + +fromIKey :: IKey -> Key +fromIKey (IKey s) = fromMaybe (error $ "bad serialied Key " ++ s) (file2key s) + +derivePersistField "IKey" + -- A serialized InodeCache newtype SInodeCache = I String deriving (Show, Read) |