    {-# 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 -> [Char]
    (Int -> Entries -> ShowS)
    -> (Entries -> [Char]) -> ([Entries] -> ShowS) -> Show Entries
    forall a.
    (Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> Entries -> ShowS
    showsPrec :: Int -> Entries -> ShowS
    $cshow :: Entries -> [Char]
    show :: Entries -> [Char]
    $cshowList :: [Entries] -> ShowS
    showList :: [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 [Char]
    msg)        = [Char] -> [Entry]
    forall a. HasCallStack => [Char] -> a
    error ([Char] -> [Entry]) -> [Char] -> [Entry]
    forall a b. (a -> b) -> a -> b
    $ [Char]
    "Data.Acid.Archive: " [Char] -> ShowS
    forall a. Semigroup a => a -> a -> a
    <> [Char]
    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
    forall a b. a -> 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 [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 (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 [Char] -> Get Entry
    forall a. [Char] -> Get a
    forall (m :: * -> *) a. MonadFail m => [Char] -> m a
    fail [Char]
    "Invalid hash"
               else Entry -> Get Entry
    forall a. a -> Get a
    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 a. a -> Get a
    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)