module Rattletrap.Type.Section where

import qualified Control.Monad as Monad
import qualified Data.ByteString as ByteString
import qualified Data.Text as Text
import qualified Rattletrap.ByteGet as ByteGet
import qualified Rattletrap.BytePut as BytePut
import qualified Rattletrap.Exception.CrcMismatch as CrcMismatch
import qualified Rattletrap.Schema as Schema
import qualified Rattletrap.Type.U32 as U32
import qualified Rattletrap.Utility.Crc as Crc
import qualified Rattletrap.Utility.Json as Json

-- | A section is a large piece of a 'Rattletrap.Replay.Replay'. It has a
-- 32-bit size (in bytes), a 32-bit CRC (see "Rattletrap.Utility.Crc"), and then a
-- bunch of data (the body). This interface is provided so that you don't have
-- to think about the size and CRC.
data Section a = Section
  { -- | read only
    forall a. Section a -> U32
size :: U32.U32,
    -- | read only
    forall a. Section a -> U32
crc :: U32.U32,
    -- | The actual content in the section.
    forall a. Section a -> a
body :: a
  }
  deriving (Section a -> Section a -> Bool
forall a. Eq a => Section a -> Section a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Section a -> Section a -> Bool
$c/= :: forall a. Eq a => Section a -> Section a -> Bool
== :: Section a -> Section a -> Bool
$c== :: forall a. Eq a => Section a -> Section a -> Bool
Eq, Int -> Section a -> ShowS
forall a. Show a => Int -> Section a -> ShowS
forall a. Show a => [Section a] -> ShowS
forall a. Show a => Section a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Section a] -> ShowS
$cshowList :: forall a. Show a => [Section a] -> ShowS
show :: Section a -> String
$cshow :: forall a. Show a => Section a -> String
showsPrec :: Int -> Section a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> Section a -> ShowS
Show)

instance (Json.FromJSON a) => Json.FromJSON (Section a) where
  parseJSON :: Value -> Parser (Section a)
parseJSON = forall a. String -> (Object -> Parser a) -> Value -> Parser a
Json.withObject String
"Section" forall a b. (a -> b) -> a -> b
$ \Object
object -> do
    U32
size <- forall value. FromJSON value => Object -> String -> Parser value
Json.required Object
object String
"size"
    U32
crc <- forall value. FromJSON value => Object -> String -> Parser value
Json.required Object
object String
"crc"
    a
body <- forall value. FromJSON value => Object -> String -> Parser value
Json.required Object
object String
"body"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure Section {U32
size :: U32
size :: U32
size, U32
crc :: U32
crc :: U32
crc, a
body :: a
body :: a
body}

instance (Json.ToJSON a) => Json.ToJSON (Section a) where
  toJSON :: Section a -> Value
toJSON Section a
x =
    [(Key, Value)] -> Value
Json.object
      [ forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"size" forall a b. (a -> b) -> a -> b
$ forall a. Section a -> U32
size Section a
x,
        forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"crc" forall a b. (a -> b) -> a -> b
$ forall a. Section a -> U32
crc Section a
x,
        forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"body" forall a b. (a -> b) -> a -> b
$ forall a. Section a -> a
body Section a
x
      ]

schema :: Schema.Schema -> Schema.Schema
schema :: Schema -> Schema
schema Schema
s =
  String -> Value -> Schema
Schema.named (String
"section-" forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack (Schema -> Text
Schema.name Schema
s)) forall a b. (a -> b) -> a -> b
$
    [((Key, Value), Bool)] -> Value
Schema.object
      [ (forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"size" forall a b. (a -> b) -> a -> b
$ Schema -> Value
Schema.ref Schema
U32.schema, Bool
True),
        (forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"crc" forall a b. (a -> b) -> a -> b
$ Schema -> Value
Schema.ref Schema
U32.schema, Bool
True),
        (forall value pair.
(ToJSON value, KeyValue pair) =>
String -> value -> pair
Json.pair String
"body" forall a b. (a -> b) -> a -> b
$ Schema -> Value
Schema.ref Schema
s, Bool
True)
      ]

create :: (a -> BytePut.BytePut) -> a -> Section a
create :: forall a. (a -> BytePut) -> a -> Section a
create a -> BytePut
encode a
body_ =
  let bytes :: ByteString
bytes = BytePut -> ByteString
BytePut.toByteString forall a b. (a -> b) -> a -> b
$ a -> BytePut
encode a
body_
   in Section
        { size :: U32
size = Word32 -> U32
U32.fromWord32 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int
ByteString.length ByteString
bytes,
          crc :: U32
crc = Word32 -> U32
U32.fromWord32 forall a b. (a -> b) -> a -> b
$ ByteString -> Word32
Crc.compute ByteString
bytes,
          body :: a
body = a
body_
        }

-- | Given a way to put the 'body', puts a section. This will also put
-- the size and CRC.
bytePut :: (a -> BytePut.BytePut) -> Section a -> BytePut.BytePut
bytePut :: forall a. (a -> BytePut) -> Section a -> BytePut
bytePut a -> BytePut
putBody Section a
section =
  let rawBody :: ByteString
rawBody = BytePut -> ByteString
BytePut.toByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> BytePut
putBody forall a b. (a -> b) -> a -> b
$ forall a. Section a -> a
body Section a
section
      size_ :: Int
size_ = ByteString -> Int
ByteString.length ByteString
rawBody
      crc_ :: Word32
crc_ = ByteString -> Word32
Crc.compute ByteString
rawBody
   in U32 -> BytePut
U32.bytePut (Word32 -> U32
U32.fromWord32 (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size_))
        forall a. Semigroup a => a -> a -> a
<> U32 -> BytePut
U32.bytePut (Word32 -> U32
U32.fromWord32 Word32
crc_)
        forall a. Semigroup a => a -> a -> a
<> ByteString -> BytePut
BytePut.byteString ByteString
rawBody

byteGet ::
  Bool -> (U32.U32 -> ByteGet.ByteGet a) -> ByteGet.ByteGet (Section a)
byteGet :: forall a. Bool -> (U32 -> ByteGet a) -> ByteGet (Section a)
byteGet Bool
skip U32 -> ByteGet a
getBody = forall a. String -> ByteGet a -> ByteGet a
ByteGet.label String
"Section" forall a b. (a -> b) -> a -> b
$ do
  U32
size <- forall a. String -> ByteGet a -> ByteGet a
ByteGet.label String
"size" ByteGet U32
U32.byteGet
  U32
crc <- forall a. String -> ByteGet a -> ByteGet a
ByteGet.label String
"crc" ByteGet U32
U32.byteGet
  a
body <- forall a. String -> ByteGet a -> ByteGet a
ByteGet.label String
"body" forall a b. (a -> b) -> a -> b
$ do
    ByteString
rawBody <- Int -> Get ByteString Identity ByteString
ByteGet.byteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ U32 -> Word32
U32.toWord32 U32
size
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.unless Bool
skip forall a b. (a -> b) -> a -> b
$ do
      let expected :: Word32
expected = U32 -> Word32
U32.toWord32 U32
crc
          actual :: Word32
actual = ByteString -> Word32
Crc.compute ByteString
rawBody
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
Monad.when (Word32
actual forall a. Eq a => a -> a -> Bool
/= Word32
expected) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> ByteGet a
ByteGet.throw forall a b. (a -> b) -> a -> b
$
        Word32 -> Word32 -> CrcMismatch
CrcMismatch.CrcMismatch
          Word32
expected
          Word32
actual
    forall a. ByteGet a -> ByteString -> ByteGet a
ByteGet.embed (U32 -> ByteGet a
getBody U32
size) ByteString
rawBody
  forall (f :: * -> *) a. Applicative f => a -> f a
pure Section {U32
size :: U32
size :: U32
size, U32
crc :: U32
crc :: U32
crc, a
body :: a
body :: a
body}

crcMessage :: U32.U32 -> U32.U32 -> String
crcMessage :: U32 -> U32 -> String
crcMessage U32
actual U32
expected =
  [String] -> String
unwords
    [ String
"[RT10] actual CRC",
      forall a. Show a => a -> String
show U32
actual,
      String
"does not match expected CRC",
      forall a. Show a => a -> String
show U32
expected
    ]