{-# LANGUAGE DoAndIfThenElse #-}
module Data.Acid.Archive
( Entry
, Entries(..)
, putEntries
, packEntries
, readEntries
, entriesToList
, entriesToListNoFail
, Archiver(..)
, defaultArchiver
) where
import Data.Acid.CRC
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import Data.ByteString.Builder
import Data.Monoid
import Data.Serialize.Get hiding (Result (..))
import qualified Data.Serialize.Get as Serialize
type Entry = Lazy.ByteString
data Entries = Done | Next Entry Entries | Fail String
deriving (Int -> Entries -> ShowS
[Entries] -> ShowS
Entries -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Entries] -> ShowS
$cshowList :: [Entries] -> ShowS
show :: Entries -> [Char]
$cshow :: Entries -> [Char]
showsPrec :: Int -> Entries -> ShowS
$cshowsPrec :: Int -> Entries -> ShowS
Show)
entriesToList :: Entries -> [Entry]
entriesToList :: Entries -> [Entry]
entriesToList Entries
Done = []
entriesToList (Next Entry
entry Entries
next) = Entry
entry forall a. a -> [a] -> [a]
: Entries -> [Entry]
entriesToList Entries
next
entriesToList (Fail [Char]
msg) = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Data.Acid.Archive: " forall a. Semigroup a => a -> a -> a
<> [Char]
msg
entriesToListNoFail :: Entries -> [Entry]
entriesToListNoFail :: Entries -> [Entry]
entriesToListNoFail Entries
Done = []
entriesToListNoFail (Next Entry
entry Entries
next) = Entry
entry forall a. a -> [a] -> [a]
: Entries -> [Entry]
entriesToListNoFail Entries
next
entriesToListNoFail Fail{} = []
data Archiver
= Archiver
{ Archiver -> [Entry] -> Entry
archiveWrite :: [Entry] -> Lazy.ByteString
, Archiver -> Entry -> Entries
archiveRead :: Lazy.ByteString -> Entries
}
defaultArchiver :: Archiver
defaultArchiver :: Archiver
defaultArchiver = ([Entry] -> Entry) -> (Entry -> Entries) -> Archiver
Archiver [Entry] -> Entry
packEntries Entry -> Entries
readEntries
putEntry :: Entry -> Builder
putEntry :: Entry -> Builder
putEntry Entry
content
= Word64 -> Builder
word64LE Word64
contentLength forall a. Semigroup a => a -> a -> a
!<>
Word16 -> Builder
word16LE Word16
contentHash forall a. Semigroup a => a -> a -> a
!<>
Entry -> Builder
lazyByteString Entry
content
where contentLength :: Word64
contentLength = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ Entry -> Int64
Lazy.length Entry
content
contentHash :: Word16
contentHash = Entry -> Word16
crc16 Entry
content
b
a !<> :: b -> b -> b
!<> b
b = let c :: b
c = b
a forall a. Semigroup a => a -> a -> a
<> b
b in b
c seq :: forall a b. a -> b -> b
`seq` b
c
putEntries :: [Entry] -> Builder
putEntries :: [Entry] -> Builder
putEntries = forall a. Monoid a => [a] -> a
mconcat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Entry -> Builder
putEntry
packEntries :: [Entry] -> Lazy.ByteString
packEntries :: [Entry] -> Entry
packEntries = Builder -> Entry
toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Entry] -> Builder
putEntries
readEntries :: Lazy.ByteString -> Entries
readEntries :: Entry -> Entries
readEntries Entry
bs
= [ByteString] -> Entries
worker (Entry -> [ByteString]
Lazy.toChunks Entry
bs)
where worker :: [ByteString] -> Entries
worker [] = Entries
Done
worker (ByteString
x:[ByteString]
xs)
= Result Entry -> [ByteString] -> Entries
check (forall a. Get a -> ByteString -> Result a
runGetPartial Get Entry
readEntry ByteString
x) [ByteString]
xs
check :: Result Entry -> [ByteString] -> Entries
check Result Entry
result [ByteString]
more
= case Result Entry
result of
Serialize.Done Entry
entry ByteString
rest
| ByteString -> Bool
Strict.null ByteString
rest -> Entry -> Entries -> Entries
Next Entry
entry ([ByteString] -> Entries
worker [ByteString]
more)
| Bool
otherwise -> Entry -> Entries -> Entries
Next Entry
entry ([ByteString] -> Entries
worker (ByteString
restforall a. a -> [a] -> [a]
:[ByteString]
more))
Serialize.Fail [Char]
msg ByteString
_ -> [Char] -> Entries
Fail [Char]
msg
Serialize.Partial ByteString -> Result Entry
cont -> case [ByteString]
more of
[] -> Result Entry -> [ByteString] -> Entries
check (ByteString -> Result Entry
cont ByteString
Strict.empty) []
(ByteString
x:[ByteString]
xs) -> Result Entry -> [ByteString] -> Entries
check (ByteString -> Result Entry
cont ByteString
x) [ByteString]
xs
readEntry :: Get Entry
readEntry :: Get Entry
readEntry
= do Word64
contentLength <- Get Word64
getWord64le
Word16
contentChecksum <-Get Word16
getWord16le
Entry
content <- Int -> Get Entry
getLazyByteString_fast (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
contentLength)
if Entry -> Word16
crc16 Entry
content forall a. Eq a => a -> a -> Bool
/= Word16
contentChecksum
then forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Invalid hash"
else forall (m :: * -> *) a. Monad m => a -> m a
return Entry
content
getLazyByteString_fast :: Int -> Get Lazy.ByteString
getLazyByteString_fast :: Int -> Get Entry
getLazyByteString_fast = Int -> [ByteString] -> Int -> Get Entry
worker Int
0 []
where
worker :: Int -> [ByteString] -> Int -> Get Entry
worker Int
counter [ByteString]
acc Int
n = do
Int
rem <- Get Int
remaining
if Int
n forall a. Ord a => a -> a -> Bool
> Int
rem then do
ByteString
chunk <- Int -> Get ByteString
getBytes Int
rem
ByteString
_ <- Int -> Get ByteString
ensure Int
1
Int -> [ByteString] -> Int -> Get Entry
worker (Int
counter forall a. Num a => a -> a -> a
+ Int
rem) (ByteString
chunkforall a. a -> [a] -> [a]
:[ByteString]
acc) (Int
nforall a. Num a => a -> a -> a
-Int
rem)
else do
ByteString
chunk <- Int -> Get ByteString
getBytes Int
n
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ByteString] -> Entry
Lazy.fromChunks (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ ByteString
chunkforall a. a -> [a] -> [a]
:[ByteString]
acc)