content: {-# LANGUAGE TypeFamilies #-}
  
  -- | BiP datatype and related instance for time-warp abstracted
  -- serialization.
  
  module Pos.Infra.Communication.BiP
         ( BiP(..)
         , bipPacking
         ) where
  
  import           Universum
  
  import           Control.Monad.ST
  import qualified Data.ByteString.Builder.Extra as Builder
  import qualified Data.ByteString.Lazy as LBS
  
  import           Node.Message.Class (Packing (..), PackingType (..),
                       Serializable (..))
  import qualified Node.Message.Decoder as TW
  
  import           Pos.Binary.Class (Bi (..))
  import qualified Pos.Binary.Class as Bi
  
  data BiP = BiP
  
  instance PackingType BiP where
      type PackM BiP   = Identity
      type UnpackM BiP = ST RealWorld
  
  bipPacking :: MonadIO m => Packing BiP m
  bipPacking = Packing
      { packingType = Proxy @BiP
      , packM = pure . runIdentity
      , unpackM = liftIO . Control.Monad.ST.stToIO
      }
  
  biPackMsg :: Bi.Encoding -> LBS.ByteString
  biPackMsg = Builder.toLazyByteStringWith strategy mempty . Bi.toBuilder
    where
      strategy = Builder.untrimmedStrategy 1024 4096
  
  biUnpackMsg :: Bi t => Bi.Decoder RealWorld t -> TW.Decoder (UnpackM BiP) t
  biUnpackMsg decoder = TW.Decoder (fromBiDecoder Proxy (Bi.deserialiseIncremental decoder))
  
  instance  Bi t => Serializable BiP t where
      packMsg _   = pure . biPackMsg . Bi.encode
      unpackMsg _ = biUnpackMsg Bi.decode
  
  type M = ST RealWorld
  
  fromBiDecoder :: Bi t => Proxy t -> M (Bi.IDecode RealWorld t) -> M (TW.DecoderStep M t)
  fromBiDecoder p x = do
      nextStep <- x
      case nextStep of
        (Bi.Partial cont)    -> return $ TW.Partial $ \bs -> TW.Decoder $ fromBiDecoder p (cont bs)
        (Bi.Done bs off t)   -> return (TW.Done bs off t)
        (Bi.Fail bs off exn) -> do
            let msg = "fromBiDecoder failure for " <> label p <> ": " <> show exn <> ", leftover: " <> show bs
            return (TW.Fail bs off msg)
  