aa4f353e5d
The repo path is typically relative, not absolute, so providing it to absPathFrom doesn't yield an absolute path. This is not a bug, just unclear documentation. Indeed, there seem to be no reason to simplifyPath here, which absPathFrom does, so instead just combine the repo path and the TopFilePath. Also, removed an export of the TopFilePath constructor; asTopFilePath is provided to construct one as-is.
266 lines
8.1 KiB
Haskell
266 lines
8.1 KiB
Haskell
{- 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 (
|
||
DbHandle,
|
||
addAssociatedFile,
|
||
getAssociatedFiles,
|
||
getAssociatedKey,
|
||
removeAssociatedFile,
|
||
scanAssociatedFiles,
|
||
storeInodeCaches,
|
||
addInodeCaches,
|
||
getInodeCaches,
|
||
removeInodeCaches,
|
||
AssociatedId,
|
||
ContentId,
|
||
) where
|
||
|
||
import Database.Types
|
||
import Database.Keys.Handle
|
||
import qualified Database.Queue as H
|
||
import Locations
|
||
import Common.Annex hiding (delete)
|
||
import qualified Annex
|
||
import Annex.Perms
|
||
import Annex.LockFile
|
||
import Utility.InodeCache
|
||
import Annex.InodeSentinal
|
||
import qualified Git.Types
|
||
import qualified Git.LsTree
|
||
import qualified Git.Branch
|
||
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.
|
||
-
|
||
- If the database doesn't already exist, it's not created; mempty is
|
||
- returned instead. This way, when the keys database is not in use,
|
||
- there's minimal overhead in checking it.
|
||
-
|
||
- If the database is already open, any writes are flushed to it, to ensure
|
||
- consistency.
|
||
-
|
||
- Any queued writes will be flushed before the read.
|
||
-}
|
||
runReader :: Monoid v => Reader v -> Annex v
|
||
runReader a = do
|
||
h <- getDbHandle
|
||
withDbState h go
|
||
where
|
||
go DbEmpty = return (mempty, DbEmpty)
|
||
go st@(DbOpen qh) = do
|
||
liftIO $ H.flushDbQueue qh
|
||
v <- a (ReadHandle qh)
|
||
return (v, st)
|
||
go DbClosed = do
|
||
st' <- openDb False DbClosed
|
||
v <- case st' of
|
||
(DbOpen qh) -> a (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 ()
|
||
|
||
{- 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 a = do
|
||
h <- getDbHandle
|
||
withDbState h go
|
||
where
|
||
go st@(DbOpen qh) = do
|
||
v <- a (WriteHandle qh)
|
||
return (v, st)
|
||
go st = do
|
||
st' <- openDb True st
|
||
v <- case st' of
|
||
DbOpen qh -> a (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
|
||
|
||
{- Gets the handle cached in Annex state; creates a new one if it's not yet
|
||
- available, but doesn't open the database. -}
|
||
getDbHandle :: Annex DbHandle
|
||
getDbHandle = go =<< Annex.getState Annex.keysdbhandle
|
||
where
|
||
go (Just h) = pure h
|
||
go Nothing = do
|
||
h <- liftIO newDbHandle
|
||
Annex.changeState $ \s -> s { Annex.keysdbhandle = Just h }
|
||
return h
|
||
|
||
{- Opens the database, perhaps creating it if it doesn't exist yet.
|
||
-
|
||
- Multiple readers and writers can have the database open at the same
|
||
- time. Database.Handle deals with the concurrency issues.
|
||
- The lock is held while opening the database, so that when
|
||
- the database doesn't exist yet, one caller wins the lock and
|
||
- can create it undisturbed.
|
||
-}
|
||
openDb :: Bool -> DbState -> Annex DbState
|
||
openDb _ st@(DbOpen _) = return st
|
||
openDb False DbEmpty = return DbEmpty
|
||
openDb createdb _ = withExclusiveLock gitAnnexKeysDbLock $ do
|
||
dbdir <- fromRepo gitAnnexKeysDb
|
||
let db = dbdir </> "db"
|
||
dbexists <- liftIO $ doesFileExist db
|
||
case (dbexists, createdb) of
|
||
(True, _) -> open db
|
||
(False, True) -> do
|
||
liftIO $ do
|
||
createDirectoryIfMissing True dbdir
|
||
H.initDb db $ void $
|
||
runMigrationSilent migrateKeysDb
|
||
setAnnexDirPerm dbdir
|
||
setAnnexFilePerm db
|
||
open db
|
||
(False, False) -> return DbEmpty
|
||
where
|
||
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) &&. r ^. AssociatedKey ==. val sk)
|
||
void $ insertUnique $ Associated sk (getTopFilePath f)
|
||
where
|
||
sk = toSKey k
|
||
|
||
{- 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
|
||
|
||
{- 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
|
||
|
||
removeAssociatedFile :: Key -> TopFilePath -> Annex ()
|
||
removeAssociatedFile k = runWriter . 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 ()
|
||
scanAssociatedFiles = whenM (isJust <$> inRepo Git.Branch.current) $
|
||
runWriter $ \h -> do
|
||
showSideAction "scanning for unlocked files"
|
||
dropallassociated h
|
||
(l, cleanup) <- inRepo $ Git.LsTree.lsTree headRef
|
||
forM_ l $ \i ->
|
||
when (isregfile i) $
|
||
maybe noop (add h i)
|
||
=<< catKey (Git.LsTree.sha i)
|
||
liftIO $ void cleanup
|
||
where
|
||
dropallassociated = queueDb $
|
||
delete $ from $ \(_r :: SqlExpr (Entity 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
|
||
(toSKey k)
|
||
(getTopFilePath $ Git.LsTree.file i)
|
||
|
||
{- Stats the files, and stores their InodeCaches. -}
|
||
storeInodeCaches :: Key -> [FilePath] -> Annex ()
|
||
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)
|
||
|
||
{- 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
|
||
|
||
removeInodeCaches :: Key -> Annex ()
|
||
removeInodeCaches = runWriter . removeInodeCaches' . toSKey
|
||
|
||
removeInodeCaches' :: SKey -> Writer
|
||
removeInodeCaches' sk = queueDb $
|
||
delete $ from $ \r -> do
|
||
where_ (r ^. ContentKey ==. val sk)
|