more RawFilePath conversion

Converted file mode setting to it, and follow-on changes.

Compiles up through 369/646.

This commit was sponsored by Ethan Aubin.
This commit is contained in:
Joey Hess 2020-11-05 18:45:37 -04:00
parent 9b0dde834e
commit 2c8cf06e75
No known key found for this signature in database
GPG key ID: DB12DB0FF05F8F38
31 changed files with 239 additions and 182 deletions

View file

@ -25,12 +25,13 @@ import Criterion.Main
import qualified Data.ByteString.Char8 as B8
import System.Random
import Control.Concurrent
import qualified System.FilePath.ByteString as P
#endif
benchmarkDbs :: CriterionMode -> Integer -> Annex ()
#ifdef WITH_BENCHMARK
benchmarkDbs mode n = withTmpDirIn "." "benchmark" $ \tmpdir -> do
db <- benchDb tmpdir n
db <- benchDb (toRawFilePath tmpdir) n
liftIO $ runMode mode
[ bgroup "keys database"
[ getAssociatedFilesHitBench db
@ -101,18 +102,18 @@ fileMiss = fileN 0 -- 0 is never stored
data BenchDb = BenchDb H.DbQueue Integer (MVar Integer)
benchDb :: FilePath -> Integer -> Annex BenchDb
benchDb :: RawFilePath -> Integer -> Annex BenchDb
benchDb tmpdir num = do
liftIO $ putStrLn $ "setting up database with " ++ show num ++ " items"
initDb db SQL.createTables
h <- liftIO $ H.openDbQueue H.MultiWriter db SQL.containedTable
liftIO $ populateAssociatedFiles h num
sz <- liftIO $ getFileSize (toRawFilePath db)
sz <- liftIO $ getFileSize db
liftIO $ putStrLn $ "size of database on disk: " ++
roughSize storageUnits False sz
mv <- liftIO $ newMVar 1
return (BenchDb h num mv)
where
db = tmpdir </> show num </> "db"
db = tmpdir P.</> toRawFilePath (show num </> "db")
#endif /* WITH_BENCHMARK */

View file

@ -47,9 +47,11 @@ import qualified Git.Ref
import qualified Git.DiffTree as DiffTree
import Logs
import qualified Logs.ContentIdentifier as Log
import qualified Utility.RawFilePath as R
import Database.Persist.Sql hiding (Key)
import Database.Persist.TH
import qualified System.FilePath.ByteString as P
data ContentIdentifierHandle = ContentIdentifierHandle H.DbQueue
@ -75,8 +77,8 @@ AnnexBranch
openDb :: Annex ContentIdentifierHandle
openDb = do
dbdir <- fromRawFilePath <$> fromRepo gitAnnexContentIdentifierDbDir
let db = dbdir </> "db"
unlessM (liftIO $ doesFileExist db) $ do
let db = dbdir P.</> "db"
unlessM (liftIO $ R.doesPathExist db) $ do
initDb db $ void $
runMigrationSilent migrateContentIdentifier
h <- liftIO $ H.openDbQueue H.SingleWriter db "content_identifiers"

View file

@ -59,9 +59,11 @@ import Git.Types
import Git.Sha
import Git.FilePath
import qualified Git.DiffTree
import qualified Utility.RawFilePath as R
import Database.Persist.Sql hiding (Key)
import Database.Persist.TH
import qualified System.FilePath.ByteString as P
data ExportHandle = ExportHandle H.DbQueue UUID
@ -96,9 +98,9 @@ ExportTreeCurrent
-}
openDb :: UUID -> Annex ExportHandle
openDb u = do
dbdir <- fromRawFilePath <$> fromRepo (gitAnnexExportDbDir u)
let db = dbdir </> "db"
unlessM (liftIO $ doesFileExist db) $ do
dbdir <- fromRepo (gitAnnexExportDbDir u)
let db = dbdir P.</> "db"
unlessM (liftIO $ R.doesPathExist db) $ do
initDb db $ void $
runMigrationSilent migrateExport
h <- liftIO $ H.openDbQueue H.SingleWriter db "exported"

View file

@ -33,10 +33,12 @@ import Annex.Locations
import Utility.Exception
import Annex.Common
import Annex.LockFile
import qualified Utility.RawFilePath as R
import Database.Persist.Sql hiding (Key)
import Database.Persist.TH
import Data.Time.Clock
import qualified System.FilePath.ByteString as P
data FsckHandle = FsckHandle H.DbQueue UUID
@ -68,8 +70,8 @@ newPass u = isJust <$> tryExclusiveLock (gitAnnexFsckDbLock u) go
openDb :: UUID -> Annex FsckHandle
openDb u = do
dbdir <- fromRepo (gitAnnexFsckDbDir u)
let db = fromRawFilePath dbdir </> "db"
unlessM (liftIO $ doesFileExist db) $ do
let db = dbdir P.</> "db"
unlessM (liftIO $ R.doesPathExist db) $ do
initDb db $ void $
runMigrationSilent migrateFsck
lockFileCached =<< fromRepo (gitAnnexFsckDbLock u)

View file

@ -63,10 +63,10 @@ data DbConcurrency = SingleWriter | MultiWriter
{- Opens the database, but does not perform any migrations. Only use
- once the database is known to exist and have the right tables. -}
openDb :: DbConcurrency -> FilePath -> TableName -> IO DbHandle
openDb :: DbConcurrency -> RawFilePath -> TableName -> IO DbHandle
openDb dbconcurrency db tablename = do
jobs <- newEmptyMVar
worker <- async (workerThread (T.pack db) tablename jobs)
worker <- async (workerThread (T.pack (fromRawFilePath db)) tablename jobs)
-- work around https://github.com/yesodweb/persistent/issues/474
liftIO $ fileEncoding stderr

View file

@ -5,16 +5,20 @@
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE OverloadedStrings #-}
module Database.Init where
import Annex.Common
import Annex.Perms
import Utility.FileMode
import Utility.Directory.Create
import qualified Utility.RawFilePath as R
import Database.Persist.Sqlite
import qualified Data.Text as T
import Lens.Micro
import qualified Data.Text as T
import qualified System.FilePath.ByteString as P
{- Ensures that the database is freshly initialized. Deletes any
- existing database. Pass the migration action for the database.
@ -24,24 +28,24 @@ import Lens.Micro
- file causes Sqlite to always use the same permissions for additional
- files it writes later on
-}
initDb :: FilePath -> SqlPersistM () -> Annex ()
initDb :: P.RawFilePath -> SqlPersistM () -> Annex ()
initDb db migration = do
let dbdir = takeDirectory db
let tmpdbdir = dbdir ++ ".tmp"
let tmpdb = tmpdbdir </> "db"
let tdb = T.pack tmpdb
let dbdir = P.takeDirectory db
let tmpdbdir = dbdir <> ".tmp"
let tmpdb = tmpdbdir P.</> "db"
let tdb = T.pack (fromRawFilePath tmpdb)
top <- parentDir <$> fromRepo gitAnnexDir
liftIO $ do
createDirectoryUnder top (toRawFilePath tmpdbdir)
createDirectoryUnder top tmpdbdir
runSqliteInfo (enableWAL tdb) migration
setAnnexDirPerm tmpdbdir
-- Work around sqlite bug that prevents it from honoring
-- less restrictive umasks.
liftIO $ setFileMode tmpdb =<< defaultFileMode
liftIO $ R.setFileMode tmpdb =<< defaultFileMode
setAnnexFilePerm tmpdb
liftIO $ do
void $ tryIO $ removeDirectoryRecursive dbdir
rename tmpdbdir dbdir
void $ tryIO $ removeDirectoryRecursive (fromRawFilePath dbdir)
rename (fromRawFilePath tmpdbdir) (fromRawFilePath dbdir)
{- Make sure that the database uses WAL mode, to prevent readers
- from blocking writers, and prevent a writer from blocking readers.

View file

@ -43,6 +43,7 @@ import Git.FilePath
import Git.Command
import Git.Types
import Git.Index
import qualified Utility.RawFilePath as R
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
@ -114,8 +115,8 @@ openDb _ st@(DbOpen _) = return st
openDb False DbUnavailable = return DbUnavailable
openDb createdb _ = catchPermissionDenied permerr $ withExclusiveLock gitAnnexKeysDbLock $ do
dbdir <- fromRepo gitAnnexKeysDb
let db = fromRawFilePath dbdir </> "db"
dbexists <- liftIO $ doesFileExist db
let db = dbdir P.</> "db"
dbexists <- liftIO $ R.doesPathExist db
case (dbexists, createdb) of
(True, _) -> open db
(False, True) -> do
@ -215,7 +216,7 @@ reconcileStaged :: H.DbQueue -> Annex ()
reconcileStaged qh = do
gitindex <- inRepo currentIndexFile
indexcache <- fromRawFilePath <$> fromRepo gitAnnexKeysDbIndexCache
withTSDelta (liftIO . genInodeCache (toRawFilePath gitindex)) >>= \case
withTSDelta (liftIO . genInodeCache gitindex) >>= \case
Just cur ->
liftIO (maybe Nothing readInodeCache <$> catchMaybeIO (readFile indexcache)) >>= \case
Nothing -> go cur indexcache

View file

@ -19,6 +19,7 @@ module Database.Queue (
) where
import Utility.Monad
import Utility.RawFilePath
import Database.Handle
import Database.Persist.Sqlite
@ -36,7 +37,7 @@ data DbQueue = DQ DbHandle (MVar Queue)
{- Opens the database queue, but does not perform any migrations. Only use
- if the database is known to exist and have the right tables; ie after
- running initDb. -}
openDbQueue :: DbConcurrency -> FilePath -> TableName -> IO DbQueue
openDbQueue :: DbConcurrency -> RawFilePath -> TableName -> IO DbQueue
openDbQueue dbconcurrency db tablename = DQ
<$> openDb dbconcurrency db tablename
<*> (newMVar =<< emptyQueue)