{-# LANGUAGE DoAndIfThenElse #-}
{-
Format:
 |content length| crc16   | content |
 |8 bytes       | 2 bytes | n bytes |
-}
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

-- | A bytestring that represents an entry in an archive.
type Entry = Lazy.ByteString

-- | Result of unpacking an archive.  This is essentially a list of
-- 'Entry', but may terminate in 'Fail' if the archive format is
-- incorrect.
data Entries = Done | Next Entry Entries | Fail String
    deriving (Int -> Entries -> ShowS
[Entries] -> ShowS
Entries -> String
(Int -> Entries -> ShowS)
-> (Entries -> String) -> ([Entries] -> ShowS) -> Show Entries
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Entries] -> ShowS
$cshowList :: [Entries] -> ShowS
show :: Entries -> String
$cshow :: Entries -> String
showsPrec :: Int -> Entries -> ShowS
$cshowsPrec :: Int -> Entries -> ShowS
Show)

-- | Convert 'Entries' to a normal list, calling 'error' if there was
-- a failure in unpacking the archive.
entriesToList :: Entries -> [Entry]
entriesToList :: Entries -> [Entry]
entriesToList Entries
Done              = []
entriesToList (Next Entry
entry Entries
next) = Entry
entry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entries -> [Entry]
entriesToList Entries
next
entriesToList (Fail String
msg)        = String -> [Entry]
forall a. HasCallStack => String -> a
error (String -> [Entry]) -> String -> [Entry]
forall a b. (a -> b) -> a -> b
$ String
"Data.Acid.Archive: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
msg

-- | Convert 'Entries' to a normal list, silently ignoring a failure
-- to unpack the archive and instead returning a truncated list.
entriesToListNoFail :: Entries -> [Entry]
entriesToListNoFail :: Entries -> [Entry]
entriesToListNoFail Entries
Done              = []
entriesToListNoFail (Next Entry
entry Entries
next) = Entry
entry Entry -> [Entry] -> [Entry]
forall a. a -> [a] -> [a]
: Entries -> [Entry]
entriesToListNoFail Entries
next
entriesToListNoFail Fail{}            = []


-- | Interface for the lowest level of the serialisation layer, which
-- handles packing lists of 'Entry' elements (essentially just
-- bytestrings) into a single bytestring, perhaps with error-checking.
--
-- Any @'Archiver'{'archiveWrite', 'archiveRead'}@ must satisfy the
-- round-trip property:
--
-- > forall xs . entriesToList (archiveRead (archiveWrite xs)) == xs
--
-- Moreover, 'archiveWrite' must be a monoid homomorphism, so that
-- concatenating archives is equivalent to concatenating the lists of
-- entries that they represent:
--
-- > archiveWrite [] == empty
-- > forall xs ys . archiveWrite xs <> archiveWrite ys == archiveWrite (xs ++ ys)
data Archiver
    = Archiver
      { Archiver -> [Entry] -> Entry
archiveWrite :: [Entry] -> Lazy.ByteString
        -- ^ Pack a list of entries into a bytestring.

      , Archiver -> Entry -> Entries
archiveRead  :: Lazy.ByteString -> Entries
        -- ^ Unpack a bytestring as a list of 'Entries', including the
        -- possibility of failure if the format is invalid.
      }

-- | Standard (and historically the only) implementation of the
-- 'Archiver' interface.  This represents each entry in the following
-- format:
--
-- > | entry length | crc16   | entry   |
-- > | 8 bytes      | 2 bytes | n bytes |
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 Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
!<>
      Word16 -> Builder
word16LE Word16
contentHash Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
!<>
      Entry -> Builder
lazyByteString Entry
content
    where contentLength :: Word64
contentLength = Int64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word64) -> Int64 -> Word64
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 b -> b -> b
forall a. Semigroup a => a -> a -> a
<> b
b in b
c b -> b -> b
`seq` b
c

putEntries :: [Entry] -> Builder
putEntries :: [Entry] -> Builder
putEntries = [Builder] -> Builder
forall a. Monoid a => [a] -> a
mconcat ([Builder] -> Builder)
-> ([Entry] -> [Builder]) -> [Entry] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Entry -> Builder) -> [Entry] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map Entry -> Builder
putEntry

packEntries :: [Entry] -> Lazy.ByteString
packEntries :: [Entry] -> Entry
packEntries = Builder -> Entry
toLazyByteString (Builder -> Entry) -> ([Entry] -> Builder) -> [Entry] -> Entry
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 (Get Entry -> ByteString -> Result Entry
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
restByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
more))
                  Serialize.Fail String
msg ByteString
_      -> String -> Entries
Fail String
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 (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
contentLength)
         if Entry -> Word16
crc16 Entry
content Word16 -> Word16 -> Bool
forall a. Eq a => a -> a -> Bool
/= Word16
contentChecksum
           then String -> Get Entry
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Invalid hash"
           else Entry -> Get Entry
forall (m :: * -> *) a. Monad m => a -> m a
return Entry
content

-- | Read a lazy bytestring WITHOUT any copying or concatenation.
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 Int -> Int -> Bool
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
rem) (ByteString
chunkByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
acc) (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
rem)
      else do
         ByteString
chunk <- Int -> Get ByteString
getBytes Int
n
         Entry -> Get Entry
forall (m :: * -> *) a. Monad m => a -> m a
return (Entry -> Get Entry) -> Entry -> Get Entry
forall a b. (a -> b) -> a -> b
$ [ByteString] -> Entry
Lazy.fromChunks ([ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ ByteString
chunkByteString -> [ByteString] -> [ByteString]
forall a. a -> [a] -> [a]
:[ByteString]
acc)