{-# LANGUAGE LambdaCase #-}
module Data.Acid.Repair
( repairFile
, repairEvents
, repairCheckpoints
) where
import qualified Data.Acid.Archive as Archive
import Data.Acid.Local (mkEventsLogKey, mkCheckpointsLogKey)
import Data.Acid.Log (LogKey)
import qualified Data.Acid.Log as Log
import qualified Data.ByteString.Lazy as Lazy
import Data.List (sort)
import System.Directory
import System.FilePath.Posix
import System.IO (hClose, openTempFile)
repairEntries :: Lazy.ByteString -> Lazy.ByteString
repairEntries :: ByteString -> ByteString
repairEntries =
[ByteString] -> ByteString
Archive.packEntries forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entries -> [ByteString]
Archive.entriesToListNoFail forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Entries
Archive.readEntries
repairFile :: FilePath -> IO ()
repairFile :: FilePath -> IO ()
repairFile FilePath
fp = do
ByteString
broken <- FilePath -> IO ByteString
Lazy.readFile FilePath
fp
let repaired :: ByteString
repaired = ByteString -> ByteString
repairEntries ByteString
broken
(FilePath
tmp, Handle
temph) <- FilePath -> FilePath -> IO (FilePath, Handle)
openTempFile (FilePath -> FilePath
takeDirectory FilePath
fp) (FilePath -> FilePath
takeFileName FilePath
fp)
Handle -> IO ()
hClose Handle
temph
FilePath -> ByteString -> IO ()
Lazy.writeFile FilePath
tmp ByteString
repaired
FilePath -> IO ()
dropFile FilePath
fp
FilePath -> FilePath -> IO ()
renameFile FilePath
tmp FilePath
fp
repairLogs :: LogKey object -> IO ()
repairLogs :: forall object. LogKey object -> IO ()
repairLogs LogKey object
identifier = do
[(Int, FilePath)]
logFiles <- forall object. LogKey object -> IO [(Int, FilePath)]
Log.findLogFiles LogKey object
identifier
let sorted :: [(Int, FilePath)]
sorted = forall a. Ord a => [a] -> [a]
sort [(Int, FilePath)]
logFiles
([Int]
_eventIds, [FilePath]
files) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Int, FilePath)]
sorted
[Bool]
broken_files <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM FilePath -> IO Bool
needsRepair [FilePath]
files
[FilePath] -> IO ()
repair forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhile (\(Bool
b,FilePath
_) -> Bool -> Bool
not Bool
b) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Bool]
broken_files [FilePath]
files
where
repair :: [FilePath] -> IO ()
repair [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
repair (FilePath
file:[FilePath]
rest) = do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
dropFile (forall a. [a] -> [a]
reverse [FilePath]
rest)
FilePath -> IO ()
repairFile FilePath
file
dropFile :: FilePath -> IO ()
dropFile :: FilePath -> IO ()
dropFile FilePath
fp = do
FilePath
bak <- FilePath -> IO FilePath
findNext (FilePath
fp forall a. [a] -> [a] -> [a]
++ FilePath
".bak")
FilePath -> FilePath -> IO ()
renameFile FilePath
fp FilePath
bak
repairEvents
:: FilePath
-> IO ()
repairEvents :: FilePath -> IO ()
repairEvents FilePath
directory =
forall object. LogKey object -> IO ()
repairLogs (forall object.
FilePath -> SerialisationLayer object -> LogKey (Tagged ByteString)
mkEventsLogKey FilePath
directory forall {a}. a
noserialisation)
where
noserialisation :: a
noserialisation =
forall a. HasCallStack => FilePath -> a
error FilePath
"Repair.repairEvents: the serialisation layer shouldn't be forced"
repairCheckpoints
:: FilePath
-> IO ()
repairCheckpoints :: FilePath -> IO ()
repairCheckpoints FilePath
directory = do
let checkpointLogKey :: LogKey (Checkpoint object)
checkpointLogKey = forall object.
FilePath -> SerialisationLayer object -> LogKey (Checkpoint object)
mkCheckpointsLogKey FilePath
directory forall {a}. a
noserialisation
[(Int, FilePath)]
checkpointFiles <- forall object. LogKey object -> IO [(Int, FilePath)]
Log.findLogFiles forall {object}. LogKey (Checkpoint object)
checkpointLogKey
let ([Int]
_eventIds, [FilePath]
files) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Int, FilePath)]
checkpointFiles
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ FilePath -> IO ()
repairFile [FilePath]
files
where
noserialisation :: a
noserialisation =
forall a. HasCallStack => FilePath -> a
error FilePath
"Repair.repairCheckpoints: the serialisation layer shouldn't be forced"
needsRepair :: FilePath -> IO Bool
needsRepair :: FilePath -> IO Bool
needsRepair FilePath
fp = do
ByteString
contents <- FilePath -> IO ByteString
Lazy.readFile FilePath
fp
let entries :: Entries
entries = ByteString -> Entries
Archive.readEntries ByteString
contents
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Entries -> Bool
entriesNeedRepair Entries
entries
where
entriesNeedRepair :: Entries -> Bool
entriesNeedRepair Archive.Fail{} = Bool
True
entriesNeedRepair Entries
Archive.Done = Bool
False
entriesNeedRepair (Archive.Next ByteString
_ Entries
rest) = Entries -> Bool
entriesNeedRepair Entries
rest
findNext :: FilePath -> IO (FilePath)
findNext :: FilePath -> IO FilePath
findNext FilePath
fp = Int -> IO FilePath
go Int
0
where
go :: Int -> IO FilePath
go Int
n =
let next :: FilePath
next = FilePath -> Int -> FilePath
fileWithSuffix FilePath
fp Int
n in
FilePath -> IO Bool
doesFileExist FilePath
next forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
next
Bool
True -> Int -> IO FilePath
go (Int
nforall a. Num a => a -> a -> a
+Int
1)
fileWithSuffix :: FilePath -> Int -> FilePath
fileWithSuffix :: FilePath -> Int -> FilePath
fileWithSuffix FilePath
fp Int
i =
if Int
i forall a. Eq a => a -> a -> Bool
== Int
0 then FilePath
fp
else FilePath
fp forall a. [a] -> [a] -> [a]
++ FilePath
"." forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> FilePath
show Int
i