module ProjectM36.TransactionGraph.Persist where
import ProjectM36.Error
import ProjectM36.Transaction
import ProjectM36.Transaction.Persist
import ProjectM36.RelationalExpression
import ProjectM36.Base
import ProjectM36.ScriptSession
import ProjectM36.Persist (writeFileSync, renameSync, DiskSync)
import ProjectM36.FileLock
import System.Directory
import System.FilePath
import System.IO.Temp
import Data.Time.Clock.POSIX
import qualified Data.UUID as U
import qualified Data.Set as S
import qualified Data.Map as M
import qualified Data.Text as T
import Data.Text.Encoding
import Control.Monad (foldM)
import Data.Either (isRight)
import Data.Maybe (fromMaybe)
import qualified Data.List as L
import Control.Exception.Base
import qualified Data.ByteString as BS
import qualified Data.Text.Encoding as TE
import Data.ByteString (ByteString)
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid
#endif
import qualified Crypto.Hash.SHA256 as SHA256
import Control.Arrow
import Data.Time.Clock
import Data.Text.Read
import System.FilePath.Glob
type LockFileHash = ByteString
expectedVersion :: Int
expectedVersion :: Int
expectedVersion = Int
6
transactionLogFileName :: FilePath
transactionLogFileName :: FilePath
transactionLogFileName = FilePath
"m36v" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
expectedVersion
transactionLogPath :: FilePath -> FilePath
transactionLogPath :: FilePath -> FilePath
transactionLogPath FilePath
dbdir = FilePath
dbdir FilePath -> FilePath -> FilePath
</> FilePath
transactionLogFileName
headsPath :: FilePath -> FilePath
headsPath :: FilePath -> FilePath
headsPath FilePath
dbdir = FilePath
dbdir FilePath -> FilePath -> FilePath
</> FilePath
"heads"
lockFilePath :: FilePath -> FilePath
lockFilePath :: FilePath -> FilePath
lockFilePath FilePath
dbdir = FilePath
dbdir FilePath -> FilePath -> FilePath
</> FilePath
"lockFile"
checkForOtherVersions :: FilePath -> IO (Either PersistenceError ())
checkForOtherVersions :: FilePath -> IO (Either PersistenceError ())
checkForOtherVersions FilePath
dbdir = do
[FilePath]
versionMatches <- Pattern -> FilePath -> IO [FilePath]
globDir1 (FilePath -> Pattern
compile FilePath
"m36v*") FilePath
dbdir
let otherVersions :: [FilePath]
otherVersions = FilePath -> [FilePath] -> [FilePath]
forall a. Eq a => a -> [a] -> [a]
L.delete FilePath
transactionLogFileName ((FilePath -> FilePath) -> [FilePath] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> FilePath
takeFileName [FilePath]
versionMatches)
if Bool -> Bool
not ([FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
otherVersions) then
Either PersistenceError () -> IO (Either PersistenceError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PersistenceError -> Either PersistenceError ()
forall a b. a -> Either a b
Left (FilePath -> FilePath -> PersistenceError
WrongDatabaseFormatVersionError FilePath
transactionLogFileName ([FilePath] -> FilePath
forall a. [a] -> a
head [FilePath]
otherVersions)))
else
Either PersistenceError () -> IO (Either PersistenceError ())
forall (f :: * -> *) a. Applicative f => a -> f a
pure (() -> Either PersistenceError ()
forall a b. b -> Either a b
Right ())
setupDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (Either PersistenceError (LockFile, LockFileHash))
setupDatabaseDir :: DiskSync
-> FilePath
-> TransactionGraph
-> IO (Either PersistenceError (LockFile, LockFileHash))
setupDatabaseDir DiskSync
sync FilePath
dbdir TransactionGraph
bootstrapGraph = do
Bool
dbdirExists <- FilePath -> IO Bool
doesDirectoryExist FilePath
dbdir
Either PersistenceError ()
eWrongVersion <- FilePath -> IO (Either PersistenceError ())
checkForOtherVersions FilePath
dbdir
case Either PersistenceError ()
eWrongVersion of
Left PersistenceError
err -> Either PersistenceError (LockFile, LockFileHash)
-> IO (Either PersistenceError (LockFile, LockFileHash))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PersistenceError
-> Either PersistenceError (LockFile, LockFileHash)
forall a b. a -> Either a b
Left PersistenceError
err)
Right () -> do
Bool
m36exists <- FilePath -> IO Bool
doesFileExist (FilePath -> FilePath
transactionLogPath FilePath
dbdir)
if Bool
dbdirExists Bool -> Bool -> Bool
&& Bool
m36exists then do
LockFile
locker <- FilePath -> IO LockFile
openLockFile (FilePath -> FilePath
lockFilePath FilePath
dbdir)
LockFileHash
gDigest <- IO () -> IO () -> IO LockFileHash -> IO LockFileHash
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (LockFile -> LockType -> IO ()
lockFile LockFile
locker LockType
WriteLock) (LockFile -> IO ()
unlockFile LockFile
locker) (FilePath -> IO LockFileHash
readGraphTransactionIdFileDigest FilePath
dbdir)
Either PersistenceError (LockFile, LockFileHash)
-> IO (Either PersistenceError (LockFile, LockFileHash))
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((LockFile, LockFileHash)
-> Either PersistenceError (LockFile, LockFileHash)
forall a b. b -> Either a b
Right (LockFile
locker, LockFileHash
gDigest))
else if Bool -> Bool
not Bool
m36exists then
(LockFile, LockFileHash)
-> Either PersistenceError (LockFile, LockFileHash)
forall a b. b -> Either a b
Right ((LockFile, LockFileHash)
-> Either PersistenceError (LockFile, LockFileHash))
-> IO (LockFile, LockFileHash)
-> IO (Either PersistenceError (LockFile, LockFileHash))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DiskSync
-> FilePath -> TransactionGraph -> IO (LockFile, LockFileHash)
bootstrapDatabaseDir DiskSync
sync FilePath
dbdir TransactionGraph
bootstrapGraph
else
Either PersistenceError (LockFile, LockFileHash)
-> IO (Either PersistenceError (LockFile, LockFileHash))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (PersistenceError
-> Either PersistenceError (LockFile, LockFileHash)
forall a b. a -> Either a b
Left (FilePath -> PersistenceError
InvalidDirectoryError FilePath
dbdir))
bootstrapDatabaseDir :: DiskSync -> FilePath -> TransactionGraph -> IO (LockFile, LockFileHash)
bootstrapDatabaseDir :: DiskSync
-> FilePath -> TransactionGraph -> IO (LockFile, LockFileHash)
bootstrapDatabaseDir DiskSync
sync FilePath
dbdir TransactionGraph
bootstrapGraph = do
FilePath -> IO ()
createDirectory FilePath
dbdir
LockFile
locker <- FilePath -> IO LockFile
openLockFile (FilePath -> FilePath
lockFilePath FilePath
dbdir)
let allTransIds :: [TransactionId]
allTransIds = (Transaction -> TransactionId) -> [Transaction] -> [TransactionId]
forall a b. (a -> b) -> [a] -> [b]
map Transaction -> TransactionId
transactionId (Set Transaction -> [Transaction]
forall a. Set a -> [a]
S.toList (TransactionGraph -> Set Transaction
transactionsForGraph TransactionGraph
bootstrapGraph))
Bool -> FilePath -> IO ()
createDirectoryIfMissing Bool
False (FilePath -> FilePath
ProjectM36.TransactionGraph.Persist.objectFilesPath FilePath
dbdir)
LockFileHash
digest <- IO () -> IO () -> IO LockFileHash -> IO LockFileHash
forall a b c. IO a -> IO b -> IO c -> IO c
bracket_ (LockFile -> LockType -> IO ()
lockFile LockFile
locker LockType
WriteLock) (LockFile -> IO ()
unlockFile LockFile
locker) (DiskSync
-> FilePath
-> [TransactionId]
-> TransactionGraph
-> IO LockFileHash
transactionGraphPersist DiskSync
sync FilePath
dbdir [TransactionId]
allTransIds TransactionGraph
bootstrapGraph)
(LockFile, LockFileHash) -> IO (LockFile, LockFileHash)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LockFile
locker, LockFileHash
digest)
objectFilesPath :: FilePath -> FilePath
objectFilesPath :: FilePath -> FilePath
objectFilesPath FilePath
dbdir = FilePath
dbdir FilePath -> FilePath -> FilePath
</> FilePath
"compiled_modules"
transactionGraphPersist :: DiskSync -> FilePath -> [TransactionId] -> TransactionGraph -> IO LockFileHash
transactionGraphPersist :: DiskSync
-> FilePath
-> [TransactionId]
-> TransactionGraph
-> IO LockFileHash
transactionGraphPersist DiskSync
sync FilePath
destDirectory [TransactionId]
transIds TransactionGraph
graph = do
DiskSync
-> [TransactionId] -> FilePath -> TransactionGraph -> IO ()
transactionsPersist DiskSync
sync [TransactionId]
transIds FilePath
destDirectory TransactionGraph
graph
LockFileHash
newDigest <- DiskSync -> FilePath -> TransactionGraph -> IO LockFileHash
writeGraphTransactionIdFile DiskSync
sync FilePath
destDirectory TransactionGraph
graph
DiskSync -> FilePath -> TransactionGraph -> IO ()
transactionGraphHeadsPersist DiskSync
sync FilePath
destDirectory TransactionGraph
graph
LockFileHash -> IO LockFileHash
forall (f :: * -> *) a. Applicative f => a -> f a
pure LockFileHash
newDigest
transactionsPersist :: DiskSync -> [TransactionId] -> FilePath -> TransactionGraph -> IO ()
transactionsPersist :: DiskSync
-> [TransactionId] -> FilePath -> TransactionGraph -> IO ()
transactionsPersist DiskSync
sync [TransactionId]
transIds FilePath
destDirectory TransactionGraph
graphIn = (TransactionId -> IO ()) -> [TransactionId] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TransactionId -> IO ()
writeTrans [TransactionId]
transIds
where writeTrans :: TransactionId -> IO ()
writeTrans TransactionId
tid =
case TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
tid TransactionGraph
graphIn of
Left RelationalError
err -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error (FilePath
"writeTransaction: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ RelationalError -> FilePath
forall a. Show a => a -> FilePath
show RelationalError
err)
Right Transaction
trans -> DiskSync -> FilePath -> Transaction -> IO ()
writeTransaction DiskSync
sync FilePath
destDirectory Transaction
trans
transactionGraphHeadsPersist :: DiskSync -> FilePath -> TransactionGraph -> IO ()
transactionGraphHeadsPersist :: DiskSync -> FilePath -> TransactionGraph -> IO ()
transactionGraphHeadsPersist DiskSync
sync FilePath
dbdir TransactionGraph
graph = do
let headFileStr :: (HeadName, Transaction) -> T.Text
headFileStr :: (HeadName, Transaction) -> HeadName
headFileStr (HeadName
headName, Transaction
trans) = HeadName
headName HeadName -> HeadName -> HeadName
forall a. Semigroup a => a -> a -> a
<> HeadName
" " HeadName -> HeadName -> HeadName
forall a. Semigroup a => a -> a -> a
<> TransactionId -> HeadName
U.toText (Transaction -> TransactionId
transactionId Transaction
trans)
FilePath -> FilePath -> (FilePath -> IO ()) -> IO ()
forall (m :: * -> *) a.
(MonadMask m, MonadIO m) =>
FilePath -> FilePath -> (FilePath -> m a) -> m a
withTempDirectory FilePath
dbdir FilePath
".heads.tmp" ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \FilePath
tempHeadsDir -> do
let tempHeadsPath :: FilePath
tempHeadsPath = FilePath
tempHeadsDir FilePath -> FilePath -> FilePath
</> FilePath
"heads"
headsStrLines :: [HeadName]
headsStrLines = ((HeadName, Transaction) -> HeadName)
-> [(HeadName, Transaction)] -> [HeadName]
forall a b. (a -> b) -> [a] -> [b]
map (HeadName, Transaction) -> HeadName
headFileStr ([(HeadName, Transaction)] -> [HeadName])
-> [(HeadName, Transaction)] -> [HeadName]
forall a b. (a -> b) -> a -> b
$ Map HeadName Transaction -> [(HeadName, Transaction)]
forall k a. Map k a -> [(k, a)]
M.toList (TransactionGraph -> Map HeadName Transaction
transactionHeadsForGraph TransactionGraph
graph)
DiskSync -> FilePath -> HeadName -> IO ()
writeFileSync DiskSync
sync FilePath
tempHeadsPath (HeadName -> IO ()) -> HeadName -> IO ()
forall a b. (a -> b) -> a -> b
$ HeadName -> [HeadName] -> HeadName
T.intercalate HeadName
"\n" [HeadName]
headsStrLines
DiskSync -> FilePath -> FilePath -> IO ()
renameSync DiskSync
sync FilePath
tempHeadsPath (FilePath -> FilePath
headsPath FilePath
dbdir)
transactionGraphHeadsLoad :: FilePath -> IO [(HeadName,TransactionId)]
transactionGraphHeadsLoad :: FilePath -> IO [(HeadName, TransactionId)]
transactionGraphHeadsLoad FilePath
dbdir = do
FilePath
headsData <- FilePath -> IO FilePath
readFile (FilePath -> FilePath
headsPath FilePath
dbdir)
let headsAssocs :: [(FilePath, FilePath)]
headsAssocs = (FilePath -> (FilePath, FilePath))
-> [FilePath] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map (\FilePath
l -> let [FilePath
headName, FilePath
uuidStr] = FilePath -> [FilePath]
words FilePath
l in
(FilePath
headName,FilePath
uuidStr)
) (FilePath -> [FilePath]
lines FilePath
headsData)
[(HeadName, TransactionId)] -> IO [(HeadName, TransactionId)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(FilePath -> HeadName
T.pack FilePath
headName, TransactionId
uuid) | (FilePath
headName, Just TransactionId
uuid) <- ((FilePath, FilePath) -> (FilePath, Maybe TransactionId))
-> [(FilePath, FilePath)] -> [(FilePath, Maybe TransactionId)]
forall a b. (a -> b) -> [a] -> [b]
map ((FilePath -> Maybe TransactionId)
-> (FilePath, FilePath) -> (FilePath, Maybe TransactionId)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second FilePath -> Maybe TransactionId
U.fromString) [(FilePath, FilePath)]
headsAssocs]
transactionGraphLoad :: FilePath -> TransactionGraph -> Maybe ScriptSession -> IO (Either PersistenceError TransactionGraph)
transactionGraphLoad :: FilePath
-> TransactionGraph
-> Maybe ScriptSession
-> IO (Either PersistenceError TransactionGraph)
transactionGraphLoad FilePath
dbdir TransactionGraph
graphIn Maybe ScriptSession
mScriptSession = do
Either PersistenceError [(TransactionId, UTCTime, [TransactionId])]
uuidInfo <- FilePath
-> IO
(Either
PersistenceError [(TransactionId, UTCTime, [TransactionId])])
readGraphTransactionIdFile FilePath
dbdir
[(HeadName, TransactionId)]
freshHeadsAssoc <- FilePath -> IO [(HeadName, TransactionId)]
transactionGraphHeadsLoad FilePath
dbdir
case Either PersistenceError [(TransactionId, UTCTime, [TransactionId])]
uuidInfo of
Left PersistenceError
err -> Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph))
-> Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
forall a b. (a -> b) -> a -> b
$ PersistenceError -> Either PersistenceError TransactionGraph
forall a b. a -> Either a b
Left PersistenceError
err
Right [(TransactionId, UTCTime, [TransactionId])]
info -> do
let folder :: Either PersistenceError TransactionGraph
-> TransactionId -> IO (Either PersistenceError TransactionGraph)
folder Either PersistenceError TransactionGraph
eitherGraph TransactionId
transId = case Either PersistenceError TransactionGraph
eitherGraph of
Left PersistenceError
err -> Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph))
-> Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
forall a b. (a -> b) -> a -> b
$ PersistenceError -> Either PersistenceError TransactionGraph
forall a b. a -> Either a b
Left PersistenceError
err
Right TransactionGraph
graph -> FilePath
-> TransactionId
-> Maybe ScriptSession
-> TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
readTransactionIfNecessary FilePath
dbdir TransactionId
transId Maybe ScriptSession
mScriptSession TransactionGraph
graph
Either PersistenceError TransactionGraph
loadedGraph <- (Either PersistenceError TransactionGraph
-> TransactionId -> IO (Either PersistenceError TransactionGraph))
-> Either PersistenceError TransactionGraph
-> [TransactionId]
-> IO (Either PersistenceError TransactionGraph)
forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM Either PersistenceError TransactionGraph
-> TransactionId -> IO (Either PersistenceError TransactionGraph)
folder (TransactionGraph -> Either PersistenceError TransactionGraph
forall a b. b -> Either a b
Right TransactionGraph
graphIn) (((TransactionId, UTCTime, [TransactionId]) -> TransactionId)
-> [(TransactionId, UTCTime, [TransactionId])] -> [TransactionId]
forall a b. (a -> b) -> [a] -> [b]
map (\(TransactionId
tid,UTCTime
_,[TransactionId]
_) -> TransactionId
tid) [(TransactionId, UTCTime, [TransactionId])]
info)
case Either PersistenceError TransactionGraph
loadedGraph of
Left PersistenceError
err -> Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph))
-> Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
forall a b. (a -> b) -> a -> b
$ PersistenceError -> Either PersistenceError TransactionGraph
forall a b. a -> Either a b
Left PersistenceError
err
Right TransactionGraph
freshGraph -> do
let maybeTransHeads :: [(HeadName, Either RelationalError Transaction)]
maybeTransHeads = [(HeadName
headName, TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
uuid TransactionGraph
freshGraph) | (HeadName
headName, TransactionId
uuid) <- [(HeadName, TransactionId)]
freshHeadsAssoc]
freshHeads :: Map HeadName Transaction
freshHeads = [(HeadName, Transaction)] -> Map HeadName Transaction
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(HeadName
headName,Transaction
trans) | (HeadName
headName, Right Transaction
trans) <- [(HeadName, Either RelationalError Transaction)]
maybeTransHeads]
Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph))
-> Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
forall a b. (a -> b) -> a -> b
$ TransactionGraph -> Either PersistenceError TransactionGraph
forall a b. b -> Either a b
Right (TransactionGraph -> Either PersistenceError TransactionGraph)
-> TransactionGraph -> Either PersistenceError TransactionGraph
forall a b. (a -> b) -> a -> b
$ Map HeadName Transaction -> Set Transaction -> TransactionGraph
TransactionGraph Map HeadName Transaction
freshHeads (TransactionGraph -> Set Transaction
transactionsForGraph TransactionGraph
freshGraph)
readTransactionIfNecessary :: FilePath -> TransactionId -> Maybe ScriptSession -> TransactionGraph -> IO (Either PersistenceError TransactionGraph)
readTransactionIfNecessary :: FilePath
-> TransactionId
-> Maybe ScriptSession
-> TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
readTransactionIfNecessary FilePath
dbdir TransactionId
transId Maybe ScriptSession
mScriptSession TransactionGraph
graphIn =
if Either RelationalError Transaction -> Bool
forall a b. Either a b -> Bool
isRight (Either RelationalError Transaction -> Bool)
-> Either RelationalError Transaction -> Bool
forall a b. (a -> b) -> a -> b
$ TransactionId
-> TransactionGraph -> Either RelationalError Transaction
transactionForId TransactionId
transId TransactionGraph
graphIn then
Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph))
-> Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
forall a b. (a -> b) -> a -> b
$ TransactionGraph -> Either PersistenceError TransactionGraph
forall a b. b -> Either a b
Right TransactionGraph
graphIn
else do
Either PersistenceError Transaction
trans <- FilePath
-> TransactionId
-> Maybe ScriptSession
-> IO (Either PersistenceError Transaction)
readTransaction FilePath
dbdir TransactionId
transId Maybe ScriptSession
mScriptSession
case Either PersistenceError Transaction
trans of
Left PersistenceError
err -> Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph))
-> Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
forall a b. (a -> b) -> a -> b
$ PersistenceError -> Either PersistenceError TransactionGraph
forall a b. a -> Either a b
Left PersistenceError
err
Right Transaction
trans' -> Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph))
-> Either PersistenceError TransactionGraph
-> IO (Either PersistenceError TransactionGraph)
forall a b. (a -> b) -> a -> b
$ TransactionGraph -> Either PersistenceError TransactionGraph
forall a b. b -> Either a b
Right (TransactionGraph -> Either PersistenceError TransactionGraph)
-> TransactionGraph -> Either PersistenceError TransactionGraph
forall a b. (a -> b) -> a -> b
$ Map HeadName Transaction -> Set Transaction -> TransactionGraph
TransactionGraph (TransactionGraph -> Map HeadName Transaction
transactionHeadsForGraph TransactionGraph
graphIn) (Transaction -> Set Transaction -> Set Transaction
forall a. Ord a => a -> Set a -> Set a
S.insert Transaction
trans' (TransactionGraph -> Set Transaction
transactionsForGraph TransactionGraph
graphIn))
writeGraphTransactionIdFile :: DiskSync -> FilePath -> TransactionGraph -> IO LockFileHash
writeGraphTransactionIdFile :: DiskSync -> FilePath -> TransactionGraph -> IO LockFileHash
writeGraphTransactionIdFile DiskSync
sync FilePath
destDirectory (TransactionGraph Map HeadName Transaction
_ Set Transaction
transSet) = DiskSync -> FilePath -> HeadName -> IO ()
writeFileSync DiskSync
sync FilePath
graphFile HeadName
uuidInfo IO () -> IO LockFileHash -> IO LockFileHash
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> LockFileHash -> IO LockFileHash
forall (f :: * -> *) a. Applicative f => a -> f a
pure LockFileHash
digest
where
graphFile :: FilePath
graphFile = FilePath -> FilePath
transactionLogPath FilePath
destDirectory
uuidInfo :: HeadName
uuidInfo = HeadName -> [HeadName] -> HeadName
T.intercalate HeadName
"\n" [HeadName]
graphLines
digest :: LockFileHash
digest = LockFileHash -> LockFileHash
SHA256.hash (HeadName -> LockFileHash
encodeUtf8 HeadName
uuidInfo)
graphLines :: [HeadName]
graphLines = Set HeadName -> [HeadName]
forall a. Set a -> [a]
S.toList (Set HeadName -> [HeadName]) -> Set HeadName -> [HeadName]
forall a b. (a -> b) -> a -> b
$ (Transaction -> HeadName) -> Set Transaction -> Set HeadName
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map Transaction -> HeadName
graphLine Set Transaction
transSet
epochTime :: Transaction -> Double
epochTime = POSIXTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac (POSIXTime -> Double)
-> (Transaction -> POSIXTime) -> Transaction -> Double
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UTCTime -> POSIXTime
utcTimeToPOSIXSeconds (UTCTime -> POSIXTime)
-> (Transaction -> UTCTime) -> Transaction -> POSIXTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Transaction -> UTCTime
timestamp :: Transaction -> Double
graphLine :: Transaction -> HeadName
graphLine Transaction
trans = TransactionId -> HeadName
U.toText (Transaction -> TransactionId
transactionId Transaction
trans)
HeadName -> HeadName -> HeadName
forall a. Semigroup a => a -> a -> a
<> HeadName
" "
HeadName -> HeadName -> HeadName
forall a. Semigroup a => a -> a -> a
<> FilePath -> HeadName
T.pack (Double -> FilePath
forall a. Show a => a -> FilePath
show (Transaction -> Double
epochTime Transaction
trans))
HeadName -> HeadName -> HeadName
forall a. Semigroup a => a -> a -> a
<> HeadName
" "
HeadName -> HeadName -> HeadName
forall a. Semigroup a => a -> a -> a
<> HeadName -> [HeadName] -> HeadName
T.intercalate HeadName
" " (Set HeadName -> [HeadName]
forall a. Set a -> [a]
S.toList ((TransactionId -> HeadName) -> Set TransactionId -> Set HeadName
forall b a. Ord b => (a -> b) -> Set a -> Set b
S.map TransactionId -> HeadName
U.toText (Set TransactionId -> Set HeadName)
-> Set TransactionId -> Set HeadName
forall a b. (a -> b) -> a -> b
$ Transaction -> Set TransactionId
parentIds Transaction
trans))
readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash
readGraphTransactionIdFileDigest :: FilePath -> IO LockFileHash
readGraphTransactionIdFileDigest FilePath
dbdir = do
let graphTransactionIdData :: IO HeadName
graphTransactionIdData = FilePath -> IO HeadName
readUTF8FileOrError (FilePath -> FilePath
transactionLogPath FilePath
dbdir)
LockFileHash -> LockFileHash
SHA256.hash (LockFileHash -> LockFileHash)
-> (HeadName -> LockFileHash) -> HeadName -> LockFileHash
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeadName -> LockFileHash
encodeUtf8 (HeadName -> LockFileHash) -> IO HeadName -> IO LockFileHash
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO HeadName
graphTransactionIdData
readGraphTransactionIdFile :: FilePath -> IO (Either PersistenceError [(TransactionId, UTCTime, [TransactionId])])
readGraphTransactionIdFile :: FilePath
-> IO
(Either
PersistenceError [(TransactionId, UTCTime, [TransactionId])])
readGraphTransactionIdFile FilePath
dbdir = do
let grapher :: HeadName -> (TransactionId, UTCTime, [TransactionId])
grapher HeadName
line = let HeadName
tid:HeadName
epochText:[HeadName]
parentIds' = HeadName -> [HeadName]
T.words HeadName
line in
(HeadName -> TransactionId
readUUID HeadName
tid, HeadName -> UTCTime
readEpoch HeadName
epochText, (HeadName -> TransactionId) -> [HeadName] -> [TransactionId]
forall a b. (a -> b) -> [a] -> [b]
map HeadName -> TransactionId
readUUID [HeadName]
parentIds')
readUUID :: HeadName -> TransactionId
readUUID HeadName
uuidText = TransactionId -> Maybe TransactionId -> TransactionId
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> TransactionId
forall a. HasCallStack => FilePath -> a
error FilePath
"failed to read uuid") (HeadName -> Maybe TransactionId
U.fromText HeadName
uuidText)
readEpoch :: HeadName -> UTCTime
readEpoch HeadName
t = POSIXTime -> UTCTime
posixSecondsToUTCTime (Double -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac ((FilePath -> Double)
-> ((Double, HeadName) -> Double)
-> Either FilePath (Double, HeadName)
-> Double
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (FilePath -> FilePath -> Double
forall a. HasCallStack => FilePath -> a
error FilePath
"failed to read epoch") (Double, HeadName) -> Double
forall a b. (a, b) -> a
fst (Reader Double
double HeadName
t)))
[(TransactionId, UTCTime, [TransactionId])]
-> Either
PersistenceError [(TransactionId, UTCTime, [TransactionId])]
forall a b. b -> Either a b
Right ([(TransactionId, UTCTime, [TransactionId])]
-> Either
PersistenceError [(TransactionId, UTCTime, [TransactionId])])
-> (HeadName -> [(TransactionId, UTCTime, [TransactionId])])
-> HeadName
-> Either
PersistenceError [(TransactionId, UTCTime, [TransactionId])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HeadName -> (TransactionId, UTCTime, [TransactionId]))
-> [HeadName] -> [(TransactionId, UTCTime, [TransactionId])]
forall a b. (a -> b) -> [a] -> [b]
map HeadName -> (TransactionId, UTCTime, [TransactionId])
grapher ([HeadName] -> [(TransactionId, UTCTime, [TransactionId])])
-> (HeadName -> [HeadName])
-> HeadName
-> [(TransactionId, UTCTime, [TransactionId])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeadName -> [HeadName]
T.lines (HeadName
-> Either
PersistenceError [(TransactionId, UTCTime, [TransactionId])])
-> IO HeadName
-> IO
(Either
PersistenceError [(TransactionId, UTCTime, [TransactionId])])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO HeadName
readUTF8FileOrError (FilePath -> FilePath
transactionLogPath FilePath
dbdir)
readUTF8FileOrError :: FilePath -> IO T.Text
readUTF8FileOrError :: FilePath -> IO HeadName
readUTF8FileOrError FilePath
pathIn = do
Either IOError LockFileHash
eFileBytes <- IO LockFileHash -> IO (Either IOError LockFileHash)
forall e a. Exception e => IO a -> IO (Either e a)
try (FilePath -> IO LockFileHash
BS.readFile FilePath
pathIn) :: IO (Either IOError BS.ByteString)
case Either IOError LockFileHash
eFileBytes of
Left IOError
err -> FilePath -> IO HeadName
forall a. HasCallStack => FilePath -> a
error (IOError -> FilePath
forall a. Show a => a -> FilePath
show IOError
err)
Right LockFileHash
fileBytes ->
case LockFileHash -> Either UnicodeException HeadName
TE.decodeUtf8' LockFileHash
fileBytes of
Left UnicodeException
err -> FilePath -> IO HeadName
forall a. HasCallStack => FilePath -> a
error (UnicodeException -> FilePath
forall a. Show a => a -> FilePath
show UnicodeException
err)
Right HeadName
utf8Bytes -> HeadName -> IO HeadName
forall (f :: * -> *) a. Applicative f => a -> f a
pure HeadName
utf8Bytes