simplexmq/src/Simplex/Messaging/Encoding.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

module Simplex.Messaging.Encoding
  ( Encoding (..),
    Tail (..),
    Large (..),
    EncList (..),
    _smpP,
    smpEncodeList,
    smpListP,
    lenEncode,
  )
where

import Data.Attoparsec.ByteString.Char8 (Parser)
import qualified Data.Attoparsec.ByteString.Char8 as A
import Data.Bits (shiftL, shiftR, (.|.))
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
import Data.ByteString.Internal (c2w, w2c)
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
import Data.Int (Int64)
import qualified Data.List.NonEmpty as L
import Data.Time.Clock.System (SystemTime (..))
import Data.Word (Word16, Word32)
import Network.Transport.Internal (decodeWord16, decodeWord32, encodeWord16, encodeWord32)
import Simplex.Messaging.Parsers (parseAll)
import Simplex.Messaging.Util ((<$?>))

-- | SMP protocol encoding
class Encoding a where
  {-# MINIMAL smpEncode, (smpDecode | smpP) #-}

  -- | protocol encoding of type (default implementation uses protocol ByteString encoding)
  smpEncode :: a -> ByteString

  -- | decoding of type (default implementation uses parser)
  smpDecode :: ByteString -> Either String a
  smpDecode = parseAll smpP
  {-# INLINE smpDecode #-}

  -- | protocol parser of type (default implementation parses protocol ByteString encoding)
  smpP :: Parser a
  smpP = smpDecode <$?> smpP
  {-# INLINE smpP #-}

instance Encoding Char where
  smpEncode = B.singleton
  {-# INLINE smpEncode #-}
  smpP = A.anyChar
  {-# INLINE smpP #-}

instance Encoding Bool where
  smpEncode = \case
    True -> "T"
    False -> "F"
  {-# INLINE smpEncode #-}
  smpP =
    smpP >>= \case
      'T' -> pure True
      'F' -> pure False
      _ -> fail "invalid Bool"
  {-# INLINE smpP #-}

instance Encoding Word16 where
  smpEncode = encodeWord16
  {-# INLINE smpEncode #-}
  smpP = decodeWord16 <$> A.take 2
  {-# INLINE smpP #-}

instance Encoding Word32 where
  smpEncode = encodeWord32
  {-# INLINE smpEncode #-}
  smpP = decodeWord32 <$> A.take 4
  {-# INLINE smpP #-}

instance Encoding Int64 where
  smpEncode i = w32 (i `shiftR` 32) <> w32 i
  {-# INLINE smpEncode #-}
  smpP = do
    l <- w32P
    r <- w32P
    pure $ (l `shiftL` 32) .|. r
  {-# INLINE smpP #-}

w32 :: Int64 -> ByteString
w32 = smpEncode @Word32 . fromIntegral
{-# INLINE w32 #-}

w32P :: Parser Int64
w32P = fromIntegral <$> smpP @Word32
{-# INLINE w32P #-}

-- ByteStrings are assumed no longer than 255 bytes
instance Encoding ByteString where
  smpEncode s = B.cons (lenEncode $ B.length s) s
  {-# INLINE smpEncode #-}
  smpP = A.take =<< lenP
  {-# INLINE smpP #-}

lenEncode :: Int -> Char
lenEncode = w2c . fromIntegral
{-# INLINE lenEncode #-}

lenP :: Parser Int
lenP = fromIntegral . c2w <$> A.anyChar
{-# INLINE lenP #-}

instance Encoding a => Encoding (Maybe a) where
  smpEncode = maybe "0" (('1' `B.cons`) . smpEncode)
  {-# INLINE smpEncode #-}
  smpP =
    smpP >>= \case
      '0' -> pure Nothing
      '1' -> Just <$> smpP
      _ -> fail "invalid Maybe tag"
  {-# INLINE smpP #-}

newtype Tail = Tail {unTail :: ByteString}

instance Encoding Tail where
  smpEncode = unTail
  {-# INLINE smpEncode #-}
  smpP = Tail <$> A.takeByteString
  {-# INLINE smpP #-}

-- newtype for encoding/decoding ByteStrings over 255 bytes with 2-bytes length prefix
newtype Large = Large {unLarge :: ByteString}

instance Encoding Large where
  smpEncode (Large s) = smpEncode @Word16 (fromIntegral $ B.length s) <> s
  {-# INLINE smpEncode #-}
  smpP = do
    len <- fromIntegral <$> smpP @Word16
    Large <$> A.take len
  {-# INLINE smpP #-}

instance Encoding SystemTime where
  smpEncode = smpEncode . systemSeconds
  {-# INLINE smpEncode #-}
  smpP = (`MkSystemTime` 0) <$> smpP
  {-# INLINE smpP #-}

_smpP :: Encoding a => Parser a
_smpP = A.space *> smpP

-- lists encode/parse as a sequence of items prefixed with list length (as 1 byte)
smpEncodeList :: Encoding a => [a] -> ByteString
smpEncodeList xs = B.cons (lenEncode $ length xs) . B.concat $ map smpEncode xs

smpListP :: Encoding a => Parser [a]
smpListP = (`A.count` smpP) =<< lenP

instance Encoding Text where
  smpEncode = smpEncode . encodeUtf8
  {-# INLINE smpEncode #-}
  smpP = either (fail . show) pure . decodeUtf8' =<< smpP
  {-# INLINE smpP #-}

instance Encoding String where
  smpEncode = smpEncode . B.pack
  {-# INLINE smpEncode #-}
  smpP = B.unpack <$> smpP
  {-# INLINE smpP #-}

instance Encoding a => Encoding (L.NonEmpty a) where
  smpEncode = smpEncodeList . L.toList
  smpP =
    lenP >>= \case
      0 -> fail "empty list"
      n -> L.fromList <$> A.count n smpP

newtype EncList a = EncList [a]

instance Encoding a => Encoding (EncList a) where
  smpEncode (EncList xs) = smpEncodeList xs
  smpP = EncList <$> smpListP

instance (Encoding a, Encoding b) => Encoding (a, b) where
  smpEncode (a, b) = smpEncode a <> smpEncode b
  {-# INLINE smpEncode #-}
  smpP = (,) <$> smpP <*> smpP
  {-# INLINE smpP #-}

instance (Encoding a, Encoding b, Encoding c) => Encoding (a, b, c) where
  smpEncode (a, b, c) = B.concat [smpEncode a, smpEncode b, smpEncode c]
  {-# INLINE smpEncode #-}
  smpP = (,,) <$> smpP <*> smpP <*> smpP
  {-# INLINE smpP #-}

instance (Encoding a, Encoding b, Encoding c, Encoding d) => Encoding (a, b, c, d) where
  smpEncode (a, b, c, d) = B.concat [smpEncode a, smpEncode b, smpEncode c, smpEncode d]
  {-# INLINE smpEncode #-}
  smpP = (,,,) <$> smpP <*> smpP <*> smpP <*> smpP
  {-# INLINE smpP #-}

instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e) => Encoding (a, b, c, d, e) where
  smpEncode (a, b, c, d, e) = B.concat [smpEncode a, smpEncode b, smpEncode c, smpEncode d, smpEncode e]
  {-# INLINE smpEncode #-}
  smpP = (,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP
  {-# INLINE smpP #-}

instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f) => Encoding (a, b, c, d, e, f) where
  smpEncode (a, b, c, d, e, f) = B.concat [smpEncode a, smpEncode b, smpEncode c, smpEncode d, smpEncode e, smpEncode f]
  {-# INLINE smpEncode #-}
  smpP = (,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
  {-# INLINE smpP #-}

instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f, Encoding g) => Encoding (a, b, c, d, e, f, g) where
  smpEncode (a, b, c, d, e, f, g) = B.concat [smpEncode a, smpEncode b, smpEncode c, smpEncode d, smpEncode e, smpEncode f, smpEncode g]
  {-# INLINE smpEncode #-}
  smpP = (,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
  {-# INLINE smpP #-}

instance (Encoding a, Encoding b, Encoding c, Encoding d, Encoding e, Encoding f, Encoding g, Encoding h) => Encoding (a, b, c, d, e, f, g, h) where
  smpEncode (a, b, c, d, e, f, g, h) = B.concat [smpEncode a, smpEncode b, smpEncode c, smpEncode d, smpEncode e, smpEncode f, smpEncode g, smpEncode h]
  {-# INLINE smpEncode #-}
  smpP = (,,,,,,,) <$> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP <*> smpP
  {-# INLINE smpP #-}