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:
parent
9b0dde834e
commit
2c8cf06e75
31 changed files with 239 additions and 182 deletions
|
@ -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 */
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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.
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue