{-# LANGUAGE OverloadedStrings #-}

module Binrep.Predicates.NullPadTo where

import Binrep.Codec
import Binrep.ByteLen
import Binrep.Util ( tshow )
import Refined
import Refined.WithRefine
import Data.Serialize
import GHC.TypeNats
import Numeric.Natural
import GHC.Natural ( minusNaturalMaybe )
import GHC.Exts ( proxy#, Proxy# )
import Data.Typeable
import Data.ByteString qualified as BS

data NullPadTo (n :: Nat)

instance KnownNat n => ByteLen (WithRefine 'Enforced (NullPadTo n) a) where
    blen :: WithRefine 'Enforced (NullPadTo n) a -> Natural
blen = Natural -> WithRefine 'Enforced (NullPadTo n) a -> Natural
forall a b. a -> b -> a
const Natural
n
      where n :: Natural
n = Proxy# n -> Natural
forall (n :: Natural). KnownNat n => Proxy# n -> Natural
natVal' (Proxy# n
forall {k} (a :: k). Proxy# a
proxy# :: Proxy# n)

instance (ByteLen a, KnownNat n) => Predicate (NullPadTo n) a where
    validate :: Proxy (NullPadTo n) -> a -> Maybe RefineException
validate Proxy (NullPadTo n)
p a
a
      | Natural
len Natural -> Natural -> Bool
forall a. Ord a => a -> a -> Bool
> Natural
n
          = TypeRep -> Text -> Maybe RefineException
throwRefineOtherException (Proxy (NullPadTo n) -> TypeRep
forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy (NullPadTo n)
p) (Text -> Maybe RefineException) -> Text -> Maybe RefineException
forall a b. (a -> b) -> a -> b
$
                   Text
"too long: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Natural -> Text
forall a. Show a => a -> Text
tshow Natural
len Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" > " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Natural -> Text
forall a. Show a => a -> Text
tshow Natural
n
      | Bool
otherwise = Maybe RefineException
success
      where
        n :: Natural
n = Proxy# n -> Natural
forall (n :: Natural). KnownNat n => Proxy# n -> Natural
natVal' (Proxy# n
forall {k} (a :: k). Proxy# a
proxy# :: Proxy# n)
        len :: Natural
len = a -> Natural
forall a. ByteLen a => a -> Natural
blen a
a

-- | predicate is inherently enforced due to checking length to calculate how
--   many succeeding nulls to parse
--
-- Note that the consumer probably doesn't care about the content of the
-- padding, just that the data is chunked correctly. I figure we care about
-- correctness here, so it'd be nice to know about the padding well-formedness
-- (i.e. that it's all nulls).
instance (BinaryCodec a, ByteLen a, KnownNat n)
      => BinaryCodec (WithRefine 'Enforced (NullPadTo n) a) where
    fromBin :: Get (WithRefine 'Enforced (NullPadTo n) a)
fromBin = do
        a
a <- Get a
forall a. BinaryCodec a => Get a
fromBin
        let len :: Natural
len = a -> Natural
forall a. ByteLen a => a -> Natural
blen a
a
        case Natural -> Natural -> Maybe Natural
minusNaturalMaybe Natural
n Natural
len of
          Maybe Natural
Nothing -> String -> Get (WithRefine 'Enforced (NullPadTo n) a)
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get (WithRefine 'Enforced (NullPadTo n) a))
-> String -> Get (WithRefine 'Enforced (NullPadTo n) a)
forall a b. (a -> b) -> a -> b
$ String
"too long: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall a. Show a => a -> String
show Natural
len String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" > " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall a. Show a => a -> String
show Natural
n
          Just Natural
nullstrLen -> do
            Natural -> Get ()
getNNulls Natural
nullstrLen
            WithRefine 'Enforced (NullPadTo n) a
-> Get (WithRefine 'Enforced (NullPadTo n) a)
forall (m :: * -> *) a. Monad m => a -> m a
return (WithRefine 'Enforced (NullPadTo n) a
 -> Get (WithRefine 'Enforced (NullPadTo n) a))
-> WithRefine 'Enforced (NullPadTo n) a
-> Get (WithRefine 'Enforced (NullPadTo n) a)
forall a b. (a -> b) -> a -> b
$ a -> WithRefine 'Enforced (NullPadTo n) a
forall {k} a (p :: k). a -> WithRefine 'Enforced p a
reallyUnsafeEnforce a
a
      where
        n :: Natural
n = Proxy# n -> Natural
forall (n :: Natural). KnownNat n => Proxy# n -> Natural
natVal' (Proxy# n
forall {k} (a :: k). Proxy# a
proxy# :: Proxy# n)
    toBin :: Putter (WithRefine 'Enforced (NullPadTo n) a)
toBin WithRefine 'Enforced (NullPadTo n) a
wrnpa = do
        let npa :: a
npa = WithRefine 'Enforced (NullPadTo n) a -> a
forall {k} (ps :: PredicateStatus) (p :: k) a.
WithRefine ps p a -> a
unWithRefine WithRefine 'Enforced (NullPadTo n) a
wrnpa
        Putter a
forall a. BinaryCodec a => Putter a
toBin a
npa
        let paddingLength :: Natural
paddingLength = Natural
n Natural -> Natural -> Natural
forall a. Num a => a -> a -> a
- a -> Natural
forall a. ByteLen a => a -> Natural
blen a
npa
        Putter ByteString
putByteString Putter ByteString -> Putter ByteString
forall a b. (a -> b) -> a -> b
$ Int -> Word8 -> ByteString
BS.replicate (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
paddingLength) Word8
0x00
      where
        n :: Natural
n = Proxy# n -> Natural
forall (n :: Natural). KnownNat n => Proxy# n -> Natural
natVal' (Proxy# n
forall {k} (a :: k). Proxy# a
proxy# :: Proxy# n)

getNNulls :: Natural -> Get ()
getNNulls :: Natural -> Get ()
getNNulls = \case Natural
0 -> () -> Get ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  Natural
n -> Get Word8
getWord8 Get Word8 -> (Word8 -> Get ()) -> Get ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                         Word8
0x00    -> Natural -> Get ()
getNNulls (Natural -> Get ()) -> Natural -> Get ()
forall a b. (a -> b) -> a -> b
$ Natural
nNatural -> Natural -> Natural
forall a. Num a => a -> a -> a
-Natural
1
                         Word8
nonNull -> do
                           Int
offset <- Get Int
bytesRead
                           String -> Get ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Get ()) -> String -> Get ()
forall a b. (a -> b) -> a -> b
$  String
"expected null, found: "String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Word8 -> String
forall a. Show a => a -> String
show Word8
nonNull
                                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" at offset " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall a. Show a => a -> String
show Int
offset
                                String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
", " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Natural -> String
forall a. Show a => a -> String
show Natural
n String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" more nulls to go"