{-# LANGUAGE CPP #-}
module Data.Acid.Log
( FileLog(..)
, LogKey(..)
, EntryId
, openFileLog
, closeFileLog
, pushEntry
, pushAction
, ensureLeastEntryId
, readEntriesFrom
, rollbackTo
, rollbackWhile
, newestEntry
, askCurrentEntryId
, cutFileLog
, archiveFileLog
, findLogFiles
) where
import Data.Acid.Archive (Archiver(..), Entries(..), entriesToList)
import Data.Acid.Core
import System.Directory
import System.FilePath
import System.IO
import FileIO
import Foreign.Ptr
import Control.Monad
import Control.Concurrent
import Control.Concurrent.STM
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Unsafe as Strict
import Data.List ( (\\), stripPrefix, sort )
import Data.Maybe
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid ( (<>) )
#endif
import Text.Printf ( printf )
import Paths_acid_state ( version )
import Data.Version ( showVersion )
import Control.Exception ( handle, IOException )
type EntryId = Int
data FileLog object
= FileLog { forall object. FileLog object -> LogKey object
logIdentifier :: LogKey object
, forall object. FileLog object -> MVar FHandle
logCurrent :: MVar FHandle
, forall object. FileLog object -> TVar EntryId
logNextEntryId :: TVar EntryId
, forall object. FileLog object -> TVar ([ByteString], [IO ()])
logQueue :: TVar ([Lazy.ByteString], [IO ()])
, forall object. FileLog object -> [ThreadId]
logThreads :: [ThreadId]
}
data LogKey object
= LogKey
{ forall object. LogKey object -> String
logDirectory :: FilePath
, forall object. LogKey object -> String
logPrefix :: String
, forall object. LogKey object -> Serialiser object
logSerialiser :: Serialiser object
, forall object. LogKey object -> Archiver
logArchiver :: Archiver
}
formatLogFile :: String -> EntryId -> String
formatLogFile :: String -> EntryId -> String
formatLogFile = forall r. PrintfType r => String -> r
printf String
"%s-%010d.log"
findLogFiles :: LogKey object -> IO [(EntryId, FilePath)]
findLogFiles :: forall object. LogKey object -> IO [(EntryId, String)]
findLogFiles LogKey object
identifier = do
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True (forall object. LogKey object -> String
logDirectory LogKey object
identifier)
[String]
files <- String -> IO [String]
getDirectoryContents (forall object. LogKey object -> String
logDirectory LogKey object
identifier)
forall (m :: * -> *) a. Monad m => a -> m a
return [ (EntryId
tid, forall object. LogKey object -> String
logDirectory LogKey object
identifier String -> String -> String
</> String
file)
| String
file <- [String]
files
, String
logFile <- forall a. Maybe a -> [a]
maybeToList (forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix (forall object. LogKey object -> String
logPrefix LogKey object
identifier forall a. [a] -> [a] -> [a]
++ String
"-") String
file)
, (EntryId
tid, String
".log") <- forall a. Read a => ReadS a
reads String
logFile ]
saveVersionFile :: LogKey object -> IO ()
saveVersionFile :: forall object. LogKey object -> IO ()
saveVersionFile LogKey object
key = do
Bool
exist <- String -> IO Bool
doesFileExist String
versionFile
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
exist forall a b. (a -> b) -> a -> b
$ String -> String -> IO ()
writeFile String
versionFile (Version -> String
showVersion Version
version)
where
versionFile :: String
versionFile = forall object. LogKey object -> String
logDirectory LogKey object
key String -> String -> String
</> forall object. LogKey object -> String
logPrefix LogKey object
key String -> String -> String
<.> String
"version"
openFileLog :: LogKey object -> IO (FileLog object)
openFileLog :: forall object. LogKey object -> IO (FileLog object)
openFileLog LogKey object
identifier = do
[(EntryId, String)]
logFiles <- forall object. LogKey object -> IO [(EntryId, String)]
findLogFiles LogKey object
identifier
forall object. LogKey object -> IO ()
saveVersionFile LogKey object
identifier
MVar FHandle
currentState <- forall a. IO (MVar a)
newEmptyMVar
TVar ([ByteString], [IO ()])
queue <- forall a. a -> IO (TVar a)
newTVarIO ([], [])
TVar EntryId
nextEntryRef <- forall a. a -> IO (TVar a)
newTVarIO EntryId
0
ThreadId
tid1 <- IO ThreadId
myThreadId
ThreadId
tid2 <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Archiver
-> MVar FHandle
-> TVar ([ByteString], [IO ()])
-> ThreadId
-> IO ()
fileWriter (forall object. LogKey object -> Archiver
logArchiver LogKey object
identifier) MVar FHandle
currentState TVar ([ByteString], [IO ()])
queue ThreadId
tid1
let fLog :: FileLog object
fLog = FileLog { logIdentifier :: LogKey object
logIdentifier = LogKey object
identifier
, logCurrent :: MVar FHandle
logCurrent = MVar FHandle
currentState
, logNextEntryId :: TVar EntryId
logNextEntryId = TVar EntryId
nextEntryRef
, logQueue :: TVar ([ByteString], [IO ()])
logQueue = TVar ([ByteString], [IO ()])
queue
, logThreads :: [ThreadId]
logThreads = [ThreadId
tid2] }
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(EntryId, String)]
logFiles
then do let currentEntryId :: EntryId
currentEntryId = EntryId
0
FHandle
handle <- String -> IO FHandle
open (forall object. LogKey object -> String
logDirectory LogKey object
identifier String -> String -> String
</> String -> EntryId -> String
formatLogFile (forall object. LogKey object -> String
logPrefix LogKey object
identifier) EntryId
currentEntryId)
forall a. MVar a -> a -> IO ()
putMVar MVar FHandle
currentState FHandle
handle
else do let (EntryId
lastFileEntryId, String
lastFilePath) = forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum [(EntryId, String)]
logFiles
[ByteString]
entries <- Archiver -> String -> IO [ByteString]
readEntities (forall object. LogKey object -> Archiver
logArchiver LogKey object
identifier) String
lastFilePath
let currentEntryId :: EntryId
currentEntryId = EntryId
lastFileEntryId forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> EntryId
length [ByteString]
entries
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar EntryId
nextEntryRef EntryId
currentEntryId
FHandle
handle <- String -> IO FHandle
open (forall object. LogKey object -> String
logDirectory LogKey object
identifier String -> String -> String
</> String -> EntryId -> String
formatLogFile (forall object. LogKey object -> String
logPrefix LogKey object
identifier) EntryId
currentEntryId)
forall a. MVar a -> a -> IO ()
putMVar MVar FHandle
currentState FHandle
handle
forall (m :: * -> *) a. Monad m => a -> m a
return FileLog object
fLog
fileWriter :: Archiver -> MVar FHandle -> TVar ([Lazy.ByteString], [IO ()]) -> ThreadId -> IO ()
fileWriter :: Archiver
-> MVar FHandle
-> TVar ([ByteString], [IO ()])
-> ThreadId
-> IO ()
fileWriter Archiver
archiver MVar FHandle
currentState TVar ([ByteString], [IO ()])
queue ThreadId
parentTid = forall (f :: * -> *) a b. Applicative f => f a -> f b
forever forall a b. (a -> b) -> a -> b
$ do
([ByteString]
entries, [IO ()]
actions) <- forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
([ByteString]
entries, [IO ()]
actions) <- forall a. TVar a -> STM a
readTVar TVar ([ByteString], [IO ()])
queue
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ByteString]
entries Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Bool
null [IO ()]
actions) forall a. STM a
retry
forall a. TVar a -> a -> STM ()
writeTVar TVar ([ByteString], [IO ()])
queue ([], [])
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. [a] -> [a]
reverse [ByteString]
entries, forall a. [a] -> [a]
reverse [IO ()]
actions)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\IOException
e -> forall e. Exception e => ThreadId -> e -> IO ()
throwTo ThreadId
parentTid (IOException
e :: IOException)) forall a b. (a -> b) -> a -> b
$
forall a b. MVar a -> (a -> IO b) -> IO b
withMVar MVar FHandle
currentState forall a b. (a -> b) -> a -> b
$ \FHandle
fd -> do
let arch :: ByteString
arch = Archiver -> [ByteString] -> ByteString
archiveWrite Archiver
archiver [ByteString]
entries
FHandle -> [ByteString] -> IO ()
writeToDisk FHandle
fd (ByteString -> [ByteString]
repack ByteString
arch)
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [IO ()]
actions
IO ()
yield
repack :: Lazy.ByteString -> [Strict.ByteString]
repack :: ByteString -> [ByteString]
repack = ByteString -> [ByteString]
worker
where
worker :: ByteString -> [ByteString]
worker ByteString
bs
| ByteString -> Bool
Lazy.null ByteString
bs = []
| Bool
otherwise = [ByteString] -> ByteString
Strict.concat (ByteString -> [ByteString]
Lazy.toChunks (Int64 -> ByteString -> ByteString
Lazy.take Int64
blockSize ByteString
bs)) forall a. a -> [a] -> [a]
: ByteString -> [ByteString]
worker (Int64 -> ByteString -> ByteString
Lazy.drop Int64
blockSize ByteString
bs)
blockSize :: Int64
blockSize = Int64
4forall a. Num a => a -> a -> a
*Int64
1024
writeToDisk :: FHandle -> [Strict.ByteString] -> IO ()
writeToDisk :: FHandle -> [ByteString] -> IO ()
writeToDisk FHandle
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
writeToDisk FHandle
handle [ByteString]
xs = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ByteString -> IO ()
worker [ByteString]
xs
FHandle -> IO ()
flush FHandle
handle
where
worker :: ByteString -> IO ()
worker ByteString
bs = do
let len :: EntryId
len = ByteString -> EntryId
Strict.length ByteString
bs
Word32
count <- forall a. ByteString -> (CString -> IO a) -> IO a
Strict.unsafeUseAsCString ByteString
bs forall a b. (a -> b) -> a -> b
$ \CString
ptr -> FHandle -> Ptr Word8 -> Word32 -> IO Word32
write FHandle
handle (forall a b. Ptr a -> Ptr b
castPtr CString
ptr) (forall a b. (Integral a, Num b) => a -> b
fromIntegral EntryId
len)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
count forall a. Ord a => a -> a -> Bool
< EntryId
len) forall a b. (a -> b) -> a -> b
$
ByteString -> IO ()
worker (EntryId -> ByteString -> ByteString
Strict.drop (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
count) ByteString
bs)
closeFileLog :: FileLog object -> IO ()
closeFileLog :: forall object. FileLog object -> IO ()
closeFileLog FileLog object
fLog =
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (forall object. FileLog object -> MVar FHandle
logCurrent FileLog object
fLog) forall a b. (a -> b) -> a -> b
$ \FHandle
handle -> do
FHandle -> IO ()
close FHandle
handle
ThreadId
_ <- IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall object. FileLog object -> [ThreadId]
logThreads FileLog object
fLog) ThreadId -> IO ()
killThread
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => String -> a
error String
"Data.Acid.Log: FileLog has been closed"
readEntities :: Archiver -> FilePath -> IO [Lazy.ByteString]
readEntities :: Archiver -> String -> IO [ByteString]
readEntities Archiver
archiver String
path = do
ByteString
archive <- String -> IO ByteString
Lazy.readFile String
path
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Entries -> [ByteString]
entriesToList (Archiver -> ByteString -> Entries
archiveRead Archiver
archiver ByteString
archive)
ensureLeastEntryId :: FileLog object -> EntryId -> IO ()
ensureLeastEntryId :: forall object. FileLog object -> EntryId -> IO ()
ensureLeastEntryId FileLog object
fLog EntryId
youngestEntry = do
forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
EntryId
entryId <- forall a. TVar a -> STM a
readTVar (forall object. FileLog object -> TVar EntryId
logNextEntryId FileLog object
fLog)
forall a. TVar a -> a -> STM ()
writeTVar (forall object. FileLog object -> TVar EntryId
logNextEntryId FileLog object
fLog) (forall a. Ord a => a -> a -> a
max EntryId
entryId EntryId
youngestEntry)
forall object. FileLog object -> IO EntryId
cutFileLog FileLog object
fLog
forall (m :: * -> *) a. Monad m => a -> m a
return ()
readEntriesFrom :: FileLog object -> EntryId -> IO [object]
readEntriesFrom :: forall object. FileLog object -> EntryId -> IO [object]
readEntriesFrom FileLog object
fLog EntryId
youngestEntry = do
EntryId
entryCap <- forall object. FileLog object -> IO EntryId
cutFileLog FileLog object
fLog
[(EntryId, String)]
logFiles <- forall object. LogKey object -> IO [(EntryId, String)]
findLogFiles (forall object. FileLog object -> LogKey object
logIdentifier FileLog object
fLog)
let sorted :: [(EntryId, String)]
sorted = forall a. Ord a => [a] -> [a]
sort [(EntryId, String)]
logFiles
relevant :: [(EntryId, String)]
relevant = Maybe EntryId
-> Maybe EntryId -> [(EntryId, String)] -> [(EntryId, String)]
filterLogFiles (forall a. a -> Maybe a
Just EntryId
youngestEntry) (forall a. a -> Maybe a
Just EntryId
entryCap) [(EntryId, String)]
sorted
firstEntryId :: EntryId
firstEntryId = case [(EntryId, String)]
relevant of
[] -> EntryId
0
( (EntryId, String)
logFile : [(EntryId, String)]
_logFiles) -> forall {a} {b}. (a, b) -> a
rangeStart (EntryId, String)
logFile
ByteString
archive <- forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM [ByteString] -> ByteString
Lazy.fromChunks forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> IO ByteString
Strict.readFile forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(EntryId, String)]
relevant
let entries :: [ByteString]
entries = Entries -> [ByteString]
entriesToList forall a b. (a -> b) -> a -> b
$ Archiver -> ByteString -> Entries
archiveRead (forall object. LogKey object -> Archiver
logArchiver LogKey object
identifier) ByteString
archive
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall object. LogKey object -> ByteString -> object
decode' LogKey object
identifier)
forall a b. (a -> b) -> a -> b
$ forall a. EntryId -> [a] -> [a]
take (EntryId
entryCap forall a. Num a => a -> a -> a
- EntryId
youngestEntry)
forall a b. (a -> b) -> a -> b
$ forall a. EntryId -> [a] -> [a]
drop (EntryId
youngestEntry forall a. Num a => a -> a -> a
- EntryId
firstEntryId) [ByteString]
entries
where
rangeStart :: (a, b) -> a
rangeStart (a
firstEntryId, b
_path) = a
firstEntryId
identifier :: LogKey object
identifier = forall object. FileLog object -> LogKey object
logIdentifier FileLog object
fLog
rollbackTo :: LogKey object -> EntryId -> IO ()
rollbackTo :: forall object. LogKey object -> EntryId -> IO ()
rollbackTo LogKey object
identifier EntryId
youngestEntry = do
[(EntryId, String)]
logFiles <- forall object. LogKey object -> IO [(EntryId, String)]
findLogFiles LogKey object
identifier
let sorted :: [(EntryId, String)]
sorted = forall a. Ord a => [a] -> [a]
sort [(EntryId, String)]
logFiles
loop :: [(EntryId, String)] -> IO ()
loop [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
loop ((EntryId
rangeStart, String
path) : [(EntryId, String)]
xs)
| EntryId
rangeStart forall a. Ord a => a -> a -> Bool
>= EntryId
youngestEntry = String -> IO ()
removeFile String
path forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [(EntryId, String)] -> IO ()
loop [(EntryId, String)]
xs
| Bool
otherwise = do
ByteString
archive <- String -> IO ByteString
Strict.readFile String
path
Handle
pathHandle <- String -> IOMode -> IO Handle
openFile String
path IOMode
WriteMode
let entries :: [ByteString]
entries = Entries -> [ByteString]
entriesToList forall a b. (a -> b) -> a -> b
$ Archiver -> ByteString -> Entries
archiveRead (forall object. LogKey object -> Archiver
logArchiver LogKey object
identifier) ([ByteString] -> ByteString
Lazy.fromChunks [ByteString
archive])
entriesToKeep :: [ByteString]
entriesToKeep = forall a. EntryId -> [a] -> [a]
take (EntryId
youngestEntry forall a. Num a => a -> a -> a
- EntryId
rangeStart forall a. Num a => a -> a -> a
+ EntryId
1) [ByteString]
entries
lengthToKeep :: Int64
lengthToKeep = ByteString -> Int64
Lazy.length (Archiver -> [ByteString] -> ByteString
archiveWrite (forall object. LogKey object -> Archiver
logArchiver LogKey object
identifier) [ByteString]
entriesToKeep)
Handle -> Integer -> IO ()
hSetFileSize Handle
pathHandle (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
lengthToKeep)
Handle -> IO ()
hClose Handle
pathHandle
[(EntryId, String)] -> IO ()
loop (forall a. [a] -> [a]
reverse [(EntryId, String)]
sorted)
rollbackWhile :: LogKey object
-> (object -> Bool)
-> IO ()
rollbackWhile :: forall object. LogKey object -> (object -> Bool) -> IO ()
rollbackWhile LogKey object
identifier object -> Bool
filterFn = do
[(EntryId, String)]
logFiles <- forall object. LogKey object -> IO [(EntryId, String)]
findLogFiles LogKey object
identifier
let sorted :: [(EntryId, String)]
sorted = forall a. Ord a => [a] -> [a]
sort [(EntryId, String)]
logFiles
loop :: [(a, String)] -> IO ()
loop [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
loop ((a
_rangeStart, String
path) : [(a, String)]
xs) = do
ByteString
archive <- String -> IO ByteString
Strict.readFile String
path
let entries :: [ByteString]
entries = Entries -> [ByteString]
entriesToList forall a b. (a -> b) -> a -> b
$ Archiver -> ByteString -> Entries
archiveRead (forall object. LogKey object -> Archiver
logArchiver LogKey object
identifier) ([ByteString] -> ByteString
Lazy.fromChunks [ByteString
archive])
entriesToSkip :: [ByteString]
entriesToSkip = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (object -> Bool
filterFn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall object. LogKey object -> ByteString -> object
decode' LogKey object
identifier) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse [ByteString]
entries
skip_size :: Int64
skip_size = ByteString -> Int64
Lazy.length (Archiver -> [ByteString] -> ByteString
archiveWrite (forall object. LogKey object -> Archiver
logArchiver LogKey object
identifier) [ByteString]
entriesToSkip)
orig_size :: Int64
orig_size = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> EntryId
Strict.length ByteString
archive
new_size :: Int64
new_size = Int64
orig_size forall a. Num a => a -> a -> a
- Int64
skip_size
if Int64
new_size forall a. Eq a => a -> a -> Bool
== Int64
0
then do String -> IO ()
removeFile String
path; [(a, String)] -> IO ()
loop [(a, String)]
xs
else do Handle
pathHandle <- String -> IOMode -> IO Handle
openFile String
path IOMode
WriteMode
Handle -> Integer -> IO ()
hSetFileSize Handle
pathHandle (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
new_size)
Handle -> IO ()
hClose Handle
pathHandle
forall {a}. [(a, String)] -> IO ()
loop (forall a. [a] -> [a]
reverse [(EntryId, String)]
sorted)
filterLogFiles
:: Maybe EntryId
-> Maybe EntryId
-> [(EntryId, FilePath)] -> [(EntryId, FilePath)]
filterLogFiles :: Maybe EntryId
-> Maybe EntryId -> [(EntryId, String)] -> [(EntryId, String)]
filterLogFiles Maybe EntryId
minEntryIdMb Maybe EntryId
maxEntryIdMb [(EntryId, String)]
logFiles = forall {b}. [(EntryId, b)] -> [(EntryId, b)]
worker [(EntryId, String)]
logFiles
where
worker :: [(EntryId, b)] -> [(EntryId, b)]
worker [] = []
worker [ (EntryId, b)
logFile ]
| EntryId -> Bool
ltMaxEntryId (forall {a} {b}. (a, b) -> a
rangeStart (EntryId, b)
logFile)
= [ (EntryId, b)
logFile ]
| Bool
otherwise
= []
worker ( (EntryId, b)
left : (EntryId, b)
right : [(EntryId, b)]
xs)
| EntryId -> Bool
ltMinEntryId (forall {a} {b}. (a, b) -> a
rangeStart (EntryId, b)
right)
= [(EntryId, b)] -> [(EntryId, b)]
worker ((EntryId, b)
right forall a. a -> [a] -> [a]
: [(EntryId, b)]
xs)
| EntryId -> Bool
ltMaxEntryId (forall {a} {b}. (a, b) -> a
rangeStart (EntryId, b)
left)
= (EntryId, b)
left forall a. a -> [a] -> [a]
: [(EntryId, b)] -> [(EntryId, b)]
worker ((EntryId, b)
right forall a. a -> [a] -> [a]
: [(EntryId, b)]
xs)
| Bool
otherwise
= []
ltMinEntryId :: EntryId -> Bool
ltMinEntryId = case Maybe EntryId
minEntryIdMb of Maybe EntryId
Nothing -> forall a b. a -> b -> a
const Bool
False
Just EntryId
minEntryId -> (forall a. Ord a => a -> a -> Bool
<= EntryId
minEntryId)
ltMaxEntryId :: EntryId -> Bool
ltMaxEntryId = case Maybe EntryId
maxEntryIdMb of Maybe EntryId
Nothing -> forall a b. a -> b -> a
const Bool
True
Just EntryId
maxEntryId -> (forall a. Ord a => a -> a -> Bool
< EntryId
maxEntryId)
rangeStart :: (a, b) -> a
rangeStart (a
firstEntryId, b
_path) = a
firstEntryId
archiveFileLog :: FileLog object -> EntryId -> IO ()
archiveFileLog :: forall object. FileLog object -> EntryId -> IO ()
archiveFileLog FileLog object
fLog EntryId
entryId = do
[(EntryId, String)]
logFiles <- forall object. LogKey object -> IO [(EntryId, String)]
findLogFiles (forall object. FileLog object -> LogKey object
logIdentifier FileLog object
fLog)
let sorted :: [(EntryId, String)]
sorted = forall a. Ord a => [a] -> [a]
sort [(EntryId, String)]
logFiles
relevant :: [(EntryId, String)]
relevant = Maybe EntryId
-> Maybe EntryId -> [(EntryId, String)] -> [(EntryId, String)]
filterLogFiles forall a. Maybe a
Nothing (forall a. a -> Maybe a
Just EntryId
entryId) [(EntryId, String)]
sorted
forall a. Eq a => [a] -> [a] -> [a]
\\ Maybe EntryId
-> Maybe EntryId -> [(EntryId, String)] -> [(EntryId, String)]
filterLogFiles (forall a. a -> Maybe a
Just EntryId
entryId) (forall a. a -> Maybe a
Just (EntryId
entryIdforall a. Num a => a -> a -> a
+EntryId
1)) [(EntryId, String)]
sorted
Bool -> String -> IO ()
createDirectoryIfMissing Bool
True String
archiveDir
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(EntryId, String)]
relevant forall a b. (a -> b) -> a -> b
$ \(EntryId
_startEntry, String
logFilePath) ->
String -> String -> IO ()
renameFile String
logFilePath (String
archiveDir String -> String -> String
</> String -> String
takeFileName String
logFilePath)
where
archiveDir :: String
archiveDir = forall object. LogKey object -> String
logDirectory (forall object. FileLog object -> LogKey object
logIdentifier FileLog object
fLog) String -> String -> String
</> String
"Archive"
getNextDurableEntryId :: FileLog object -> IO EntryId
getNextDurableEntryId :: forall object. FileLog object -> IO EntryId
getNextDurableEntryId FileLog object
fLog = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
([ByteString]
entries, [IO ()]
_) <- forall a. TVar a -> STM a
readTVar (forall object. FileLog object -> TVar ([ByteString], [IO ()])
logQueue FileLog object
fLog)
EntryId
next <- forall a. TVar a -> STM a
readTVar (forall object. FileLog object -> TVar EntryId
logNextEntryId FileLog object
fLog)
forall (m :: * -> *) a. Monad m => a -> m a
return (EntryId
next forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> EntryId
length [ByteString]
entries)
cutFileLog :: FileLog object -> IO EntryId
cutFileLog :: forall object. FileLog object -> IO EntryId
cutFileLog FileLog object
fLog = do
MVar EntryId
mvar <- forall a. IO (MVar a)
newEmptyMVar
let action :: IO ()
action = do EntryId
currentEntryId <- forall object. FileLog object -> IO EntryId
getNextDurableEntryId FileLog object
fLog
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ (forall object. FileLog object -> MVar FHandle
logCurrent FileLog object
fLog) forall a b. (a -> b) -> a -> b
$ \FHandle
old ->
do FHandle -> IO ()
close FHandle
old
String -> IO FHandle
open (forall object. LogKey object -> String
logDirectory LogKey object
key String -> String -> String
</> String -> EntryId -> String
formatLogFile (forall object. LogKey object -> String
logPrefix LogKey object
key) EntryId
currentEntryId)
forall a. MVar a -> a -> IO ()
putMVar MVar EntryId
mvar EntryId
currentEntryId
forall object. FileLog object -> IO () -> IO ()
pushAction FileLog object
fLog IO ()
action
forall a. MVar a -> IO a
takeMVar MVar EntryId
mvar
where
key :: LogKey object
key = forall object. FileLog object -> LogKey object
logIdentifier FileLog object
fLog
newestEntry :: LogKey object -> IO (Maybe object)
newestEntry :: forall object. LogKey object -> IO (Maybe object)
newestEntry LogKey object
identifier = do
[(EntryId, String)]
logFiles <- forall object. LogKey object -> IO [(EntryId, String)]
findLogFiles LogKey object
identifier
let sorted :: [(EntryId, String)]
sorted = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort [(EntryId, String)]
logFiles
([EntryId]
_eventIds, [String]
files) = forall a b. [(a, b)] -> ([a], [b])
unzip [(EntryId, String)]
sorted
[String] -> IO (Maybe object)
worker [String]
files
where
worker :: [String] -> IO (Maybe object)
worker [] = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
worker (String
logFile:[String]
logFiles) = do
ByteString
archive <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> ByteString
Lazy.fromStrict forall a b. (a -> b) -> a -> b
$ String -> IO ByteString
Strict.readFile String
logFile
case Archiver -> ByteString -> Entries
archiveRead (forall object. LogKey object -> Archiver
logArchiver LogKey object
identifier) ByteString
archive of
Entries
Done -> [String] -> IO (Maybe object)
worker [String]
logFiles
Next ByteString
entry Entries
next -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (forall object. LogKey object -> ByteString -> object
decode' LogKey object
identifier (ByteString -> Entries -> ByteString
lastEntry ByteString
entry Entries
next))
Fail String
msg -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Data.Acid.Log: " forall a. Semigroup a => a -> a -> a
<> String
msg
lastEntry :: ByteString -> Entries -> ByteString
lastEntry ByteString
entry Entries
Done = ByteString
entry
lastEntry ByteString
entry (Fail String
msg) = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Data.Acid.Log: " forall a. Semigroup a => a -> a -> a
<> String
msg
lastEntry ByteString
_ (Next ByteString
entry Entries
next) = ByteString -> Entries -> ByteString
lastEntry ByteString
entry Entries
next
pushEntry :: FileLog object -> object -> IO () -> IO ()
pushEntry :: forall object. FileLog object -> object -> IO () -> IO ()
pushEntry FileLog object
fLog object
object IO ()
finally = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
EntryId
tid <- forall a. TVar a -> STM a
readTVar (forall object. FileLog object -> TVar EntryId
logNextEntryId FileLog object
fLog)
forall a. TVar a -> a -> STM ()
writeTVar (forall object. FileLog object -> TVar EntryId
logNextEntryId FileLog object
fLog) forall a b. (a -> b) -> a -> b
$! EntryId
tidforall a. Num a => a -> a -> a
+EntryId
1
([ByteString]
entries, [IO ()]
actions) <- forall a. TVar a -> STM a
readTVar (forall object. FileLog object -> TVar ([ByteString], [IO ()])
logQueue FileLog object
fLog)
forall a. TVar a -> a -> STM ()
writeTVar (forall object. FileLog object -> TVar ([ByteString], [IO ()])
logQueue FileLog object
fLog) ( ByteString
encoded forall a. a -> [a] -> [a]
: [ByteString]
entries, IO ()
finally forall a. a -> [a] -> [a]
: [IO ()]
actions )
where
encoded :: ByteString
encoded = [ByteString] -> ByteString
Lazy.fromChunks [ ByteString -> ByteString
Strict.copy forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
Lazy.toStrict forall a b. (a -> b) -> a -> b
$
forall a. Serialiser a -> a -> ByteString
serialiserEncode (forall object. LogKey object -> Serialiser object
logSerialiser (forall object. FileLog object -> LogKey object
logIdentifier FileLog object
fLog)) object
object ]
pushAction :: FileLog object -> IO () -> IO ()
pushAction :: forall object. FileLog object -> IO () -> IO ()
pushAction FileLog object
fLog IO ()
finally = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
([ByteString]
entries, [IO ()]
actions) <- forall a. TVar a -> STM a
readTVar (forall object. FileLog object -> TVar ([ByteString], [IO ()])
logQueue FileLog object
fLog)
forall a. TVar a -> a -> STM ()
writeTVar (forall object. FileLog object -> TVar ([ByteString], [IO ()])
logQueue FileLog object
fLog) ([ByteString]
entries, IO ()
finally forall a. a -> [a] -> [a]
: [IO ()]
actions)
askCurrentEntryId :: FileLog object -> IO EntryId
askCurrentEntryId :: forall object. FileLog object -> IO EntryId
askCurrentEntryId FileLog object
fLog = forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$
forall a. TVar a -> STM a
readTVar (forall object. FileLog object -> TVar EntryId
logNextEntryId FileLog object
fLog)
decode' :: LogKey object -> Lazy.ByteString -> object
decode' :: forall object. LogKey object -> ByteString -> object
decode' LogKey object
s ByteString
inp =
case forall a. Serialiser a -> ByteString -> Either String a
serialiserDecode (forall object. LogKey object -> Serialiser object
logSerialiser LogKey object
s) ByteString
inp of
Left String
msg -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Data.Acid.Log: " forall a. Semigroup a => a -> a -> a
<> String
msg
Right object
val -> object
val