{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_HADDOCK prune not-home #-}

{- |
Module : Data.Attoparsec.Framer
Copyright : (c) 2022 Tim Emiola
Maintainer : Tim Emiola <adetokunbo@emio.la>
SPDX-License-Identifier: BSD3

Provides the 'Framer' data type that combines an @Attoparsec 'A.Parser'@ with a
a few additional combinators that allow the parser to be used to process frames
of the framed byte streams commonly used in network protocol implementations.

A @'Framer'@ specifies how the processing function @'runFramer'@ should
parse a byte stream.

Minimally, a @Framer@ specifies

* a @'A.Parser'@, used to extract frames from the byte stream
* a @'FrameHandler'@ responsible for using the parsed frames
* the byte stream source, represented by a 'ByteSource'

@'runFramer'@ reads chunks from the @ByteSource@, parses these into frames and
invokes the 'FrameHandler'. Each invocation returns a 'Progression', which
indicates if processing should continue. This allows the 'FrameHandler' to
trigger termination of 'runFramer'.
-}
module Data.Attoparsec.Framer (
  -- * Framer
  ByteSource,
  Framer,
  FrameHandler,
  Progression (..),
  mkFramer,
  mkFramer',

  -- * query/update a  @'Framer'@
  setChunkSize,
  setOnBadParse,
  setOnClosed,
  setOnFrame,
  chunkSize,

  -- * Run the @Framer@
  runFramer,
  runOneFrame,

  -- * Exception handling
  -- $exceptions

  -- * exceptions
  BrokenFrame (..),
  NoMoreInput (..),
) where

import Control.Exception (Exception)
import Control.Monad.Catch (MonadThrow (..))
import qualified Data.Attoparsec.ByteString as A
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Word (Word32)


-- | Handles a parsed @frame@, returning a @Progression@ that indicates if further @frames@ should be parsed.
type FrameHandler m frame = frame -> m Progression


-- | A byte stream from which chunks are to be retrieved.
type ByteSource m = Word32 -> m ByteString


-- | Used by 'FrameHandler' to indicate if additional frames should be parsed.
data Progression
  = Stop
  | StopUnlessExtra
  | Continue
  deriving (Progression -> Progression -> Bool
(Progression -> Progression -> Bool)
-> (Progression -> Progression -> Bool) -> Eq Progression
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Progression -> Progression -> Bool
== :: Progression -> Progression -> Bool
$c/= :: Progression -> Progression -> Bool
/= :: Progression -> Progression -> Bool
Eq, Int -> Progression -> ShowS
[Progression] -> ShowS
Progression -> String
(Int -> Progression -> ShowS)
-> (Progression -> String)
-> ([Progression] -> ShowS)
-> Show Progression
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Progression -> ShowS
showsPrec :: Int -> Progression -> ShowS
$cshow :: Progression -> String
show :: Progression -> String
$cshowList :: [Progression] -> ShowS
showList :: [Progression] -> ShowS
Show)


-- | Uses a 'A.Parser' to parse a stream of @frames@ from a byte stream
data Framer m frame = Framer
  { forall (m :: * -> *) frame. Framer m frame -> Word32
framerChunkSize :: !Word32
  , forall (m :: * -> *) frame. Framer m frame -> ByteSource m
frameByteSource :: !(ByteSource m)
  , forall (m :: * -> *) frame. Framer m frame -> FrameHandler m frame
framerOnFrame :: !(FrameHandler m frame)
  , forall (m :: * -> *) frame. Framer m frame -> Parser frame
framerParser :: !(A.Parser frame)
  , forall (m :: * -> *) frame. Framer m frame -> m ()
framerOnClosed :: !(m ())
  , forall (m :: * -> *) frame. Framer m frame -> Text -> m ()
framerOnBadParse :: !(Text -> m ())
  }


{- | Construct a @'Framer'@ that will handle @frames@ repeatedly until the
@FrameHandler@ returns a @'Progression'@ that stops it.
-}
mkFramer' ::
  MonadThrow m =>
  A.Parser frame ->
  FrameHandler m frame ->
  ByteSource m ->
  Framer m frame
mkFramer' :: forall (m :: * -> *) frame.
MonadThrow m =>
Parser frame
-> FrameHandler m frame -> ByteSource m -> Framer m frame
mkFramer' Parser frame
framerParser FrameHandler m frame
framerOnFrame ByteSource m
frameByteSource =
  Framer
    { Parser frame
framerParser :: Parser frame
framerParser :: Parser frame
framerParser
    , FrameHandler m frame
framerOnFrame :: FrameHandler m frame
framerOnFrame :: FrameHandler m frame
framerOnFrame
    , ByteSource m
frameByteSource :: ByteSource m
frameByteSource :: ByteSource m
frameByteSource
    , framerOnBadParse :: Text -> m ()
framerOnBadParse = \Text
_err -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
    , framerOnClosed :: m ()
framerOnClosed = NoMoreInput -> m ()
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM NoMoreInput
NoMoreInput
    , framerChunkSize :: Word32
framerChunkSize = Word32
defaultChunkSize
    }


-- | Construct a @'Framer'@ that loops continuously.
mkFramer ::
  MonadThrow m =>
  -- | parses frames from the byte stream
  A.Parser frame ->
  -- | handles parsed frames
  (frame -> m ()) ->
  -- | obtains the next chunk from the byte stream
  ByteSource m ->
  Framer m frame
mkFramer :: forall (m :: * -> *) frame.
MonadThrow m =>
Parser frame -> (frame -> m ()) -> ByteSource m -> Framer m frame
mkFramer Parser frame
parser frame -> m ()
onFrame ByteSource m
fetchBytes =
  let onFrameContinue :: frame -> m Progression
onFrameContinue frame
x = do
        frame -> m ()
onFrame frame
x
        Progression -> m Progression
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Progression
Continue
   in Parser frame
-> (frame -> m Progression) -> ByteSource m -> Framer m frame
forall (m :: * -> *) frame.
MonadThrow m =>
Parser frame
-> FrameHandler m frame -> ByteSource m -> Framer m frame
mkFramer' Parser frame
parser frame -> m Progression
onFrameContinue ByteSource m
fetchBytes


-- | Repeatedly parse and handle frames until the configured @FrameHandler@ ends handling.
runFramer ::
  MonadThrow m =>
  Framer m frame ->
  m ()
runFramer :: forall (m :: * -> *) frame. MonadThrow m => Framer m frame -> m ()
runFramer Framer m frame
f =
  let Framer
        { framerChunkSize :: forall (m :: * -> *) frame. Framer m frame -> Word32
framerChunkSize = Word32
fetchSize
        , framerOnBadParse :: forall (m :: * -> *) frame. Framer m frame -> Text -> m ()
framerOnBadParse = Text -> m ()
onErr
        , frameByteSource :: forall (m :: * -> *) frame. Framer m frame -> ByteSource m
frameByteSource = ByteSource m
fetchBytes
        , framerOnFrame :: forall (m :: * -> *) frame. Framer m frame -> FrameHandler m frame
framerOnFrame = FrameHandler m frame
onFrame
        , framerParser :: forall (m :: * -> *) frame. Framer m frame -> Parser frame
framerParser = Parser frame
parser
        , framerOnClosed :: forall (m :: * -> *) frame. Framer m frame -> m ()
framerOnClosed = m ()
onClosed
        } = Framer m frame
f
   in Word32
-> Parser frame
-> ByteSource m
-> FrameHandler m frame
-> (Text -> m ())
-> m ()
-> m ()
forall (m :: * -> *) a.
MonadThrow m =>
Word32
-> Parser a
-> (Word32 -> m ByteString)
-> (a -> m Progression)
-> (Text -> m ())
-> m ()
-> m ()
runFramer' Word32
fetchSize Parser frame
parser ByteSource m
fetchBytes FrameHandler m frame
onFrame Text -> m ()
onErr m ()
onClosed


{- | Parse and handle a single frame.

The result is a tuple: (Maybe @unparsed@, @terminated@)

where

@unparsed@ are outstanding bytes fetched from the @ByteSource@ and
@terminated@ is @True@ if the @ByteSource@ has no further input.
-}
runOneFrame ::
  MonadThrow m =>
  -- | the unparsed bytes from an earlier invocation, if any
  Maybe ByteString ->
  -- | the 'Framer' used to parse the @frame@
  Framer m frame ->
  m ((Maybe ByteString), Bool)
runOneFrame :: forall (m :: * -> *) frame.
MonadThrow m =>
Maybe ByteString -> Framer m frame -> m (Maybe ByteString, Bool)
runOneFrame Maybe ByteString
restMb Framer m frame
f =
  let Framer
        { framerChunkSize :: forall (m :: * -> *) frame. Framer m frame -> Word32
framerChunkSize = Word32
fetchSize
        , framerOnBadParse :: forall (m :: * -> *) frame. Framer m frame -> Text -> m ()
framerOnBadParse = Text -> m ()
onErr
        , frameByteSource :: forall (m :: * -> *) frame. Framer m frame -> ByteSource m
frameByteSource = ByteSource m
fetchBytes
        , framerOnFrame :: forall (m :: * -> *) frame. Framer m frame -> FrameHandler m frame
framerOnFrame = FrameHandler m frame
onFrame
        , framerParser :: forall (m :: * -> *) frame. Framer m frame -> Parser frame
framerParser = Parser frame
parser
        , framerOnClosed :: forall (m :: * -> *) frame. Framer m frame -> m ()
framerOnClosed = m ()
onClose
        } = Framer m frame
f
   in Maybe ByteString
-> Word32
-> Parser frame
-> ByteSource m
-> FrameHandler m frame
-> (Text -> m ())
-> m ()
-> m (Maybe ByteString, Bool)
forall (m :: * -> *) a.
MonadThrow m =>
Maybe ByteString
-> Word32
-> Parser a
-> (Word32 -> m ByteString)
-> (a -> m Progression)
-> (Text -> m ())
-> m ()
-> m (Maybe ByteString, Bool)
runOneFrame' Maybe ByteString
restMb Word32
fetchSize Parser frame
parser ByteSource m
fetchBytes FrameHandler m frame
onFrame Text -> m ()
onErr m ()
onClose


-- | The chunk size of a @Framer@.
chunkSize :: Framer m a -> Word32
chunkSize :: forall (m :: * -> *) frame. Framer m frame -> Word32
chunkSize = Framer m a -> Word32
forall (m :: * -> *) frame. Framer m frame -> Word32
framerChunkSize


-- | Update the chunk size of a @Framer@.
setChunkSize :: Word32 -> Framer m a -> Framer m a
setChunkSize :: forall (m :: * -> *) a. Word32 -> Framer m a -> Framer m a
setChunkSize Word32
size Framer m a
f = Framer m a
f {framerChunkSize = size}


-- | Update the parse error handler of a @Framer@.
setOnBadParse :: (Text -> m ()) -> Framer m a -> Framer m a
setOnBadParse :: forall (m :: * -> *) a. (Text -> m ()) -> Framer m a -> Framer m a
setOnBadParse Text -> m ()
onErr Framer m a
f = Framer m a
f {framerOnBadParse = onErr}


-- | Update the @FrameHandler@ of a @Framer@.
setOnFrame :: FrameHandler m frame -> Framer m frame -> Framer m frame
setOnFrame :: forall (m :: * -> *) frame.
FrameHandler m frame -> Framer m frame -> Framer m frame
setOnFrame FrameHandler m frame
onFrame Framer m frame
f = Framer m frame
f {framerOnFrame = onFrame}


-- | Update the end-of-input handler of a @Framer@.
setOnClosed :: (m ()) -> Framer m a -> Framer m a
setOnClosed :: forall (m :: * -> *) a. m () -> Framer m a -> Framer m a
setOnClosed m ()
onClose Framer m a
f = Framer m a
f {framerOnClosed = onClose}


runFramer' ::
  MonadThrow m =>
  Word32 ->
  A.Parser a ->
  (Word32 -> m ByteString) ->
  (a -> m Progression) ->
  (Text -> m ()) ->
  m () ->
  m ()
runFramer' :: forall (m :: * -> *) a.
MonadThrow m =>
Word32
-> Parser a
-> (Word32 -> m ByteString)
-> (a -> m Progression)
-> (Text -> m ())
-> m ()
-> m ()
runFramer' Word32
fetchSize Parser a
parser Word32 -> m ByteString
fetchBytes a -> m Progression
handleFrame Text -> m ()
onErr m ()
onClosed = do
  let loop :: Maybe ByteString -> m ()
loop Maybe ByteString
x = do
        (Maybe ByteString
next, Bool
closed) <- Maybe ByteString
-> Word32
-> Parser a
-> (Word32 -> m ByteString)
-> (a -> m Progression)
-> (Text -> m ())
-> m ()
-> m (Maybe ByteString, Bool)
forall (m :: * -> *) a.
MonadThrow m =>
Maybe ByteString
-> Word32
-> Parser a
-> (Word32 -> m ByteString)
-> (a -> m Progression)
-> (Text -> m ())
-> m ()
-> m (Maybe ByteString, Bool)
runOneFrame' Maybe ByteString
x Word32
fetchSize Parser a
parser Word32 -> m ByteString
fetchBytes a -> m Progression
handleFrame Text -> m ()
onErr m ()
onClosed
        if Bool -> Bool
not Bool
closed then Maybe ByteString -> m ()
loop Maybe ByteString
next else () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Maybe ByteString -> m ()
loop Maybe ByteString
forall a. Maybe a
Nothing


runOneFrame' ::
  MonadThrow m =>
  Maybe ByteString ->
  Word32 ->
  A.Parser a ->
  (Word32 -> m ByteString) ->
  (a -> m Progression) ->
  (Text -> m ()) ->
  m () ->
  m ((Maybe ByteString), Bool)
runOneFrame' :: forall (m :: * -> *) a.
MonadThrow m =>
Maybe ByteString
-> Word32
-> Parser a
-> (Word32 -> m ByteString)
-> (a -> m Progression)
-> (Text -> m ())
-> m ()
-> m (Maybe ByteString, Bool)
runOneFrame' Maybe ByteString
restMb Word32
fetchSize Parser a
parser Word32 -> m ByteString
fetchBytes a -> m Progression
handleFrame Text -> m ()
onErr m ()
onClose = do
  let pullChunk :: m ByteString
pullChunk = Word32 -> m ByteString
fetchBytes Word32
fetchSize
      initial :: ByteString
initial = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
BS.empty Maybe ByteString
restMb
      onParse :: IResult ByteString a -> m (Maybe ByteString, Bool)
onParse (A.Fail ByteString
_ [String]
ctxs String
reason) = do
        let errMessage :: Text
errMessage = [String] -> String -> Text
parsingFailed [String]
ctxs String
reason
        if String
reason String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
closedReason
          then -- WANTED: a typed way of detecting this condition, i.e,
          -- it is possible not to rely on a  specific error message ?
          do
            m ()
onClose
            (Maybe ByteString, Bool) -> m (Maybe ByteString, Bool)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString
forall a. Maybe a
Nothing, Bool
True)
          else do
            Text -> m ()
onErr Text
errMessage
            BrokenFrame -> m (Maybe ByteString, Bool)
forall e a. (HasCallStack, Exception e) => e -> m a
forall (m :: * -> *) e a.
(MonadThrow m, HasCallStack, Exception e) =>
e -> m a
throwM (BrokenFrame -> m (Maybe ByteString, Bool))
-> BrokenFrame -> m (Maybe ByteString, Bool)
forall a b. (a -> b) -> a -> b
$ String -> BrokenFrame
BrokenFrame String
reason
      onParse (A.Done ByteString
i a
r) = do
        let extraMb :: Maybe ByteString
extraMb = if ByteString -> Bool
BS.null ByteString
i then Maybe ByteString
forall a. Maybe a
Nothing else ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
i
        Progression
doMore <- a -> m Progression
handleFrame a
r
        case (Progression
doMore, Maybe ByteString
extraMb) of
          (Progression
Stop, Maybe ByteString
_) -> (Maybe ByteString, Bool) -> m (Maybe ByteString, Bool)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString
extraMb, Bool
True)
          (Progression
StopUnlessExtra, Maybe ByteString
Nothing) -> (Maybe ByteString, Bool) -> m (Maybe ByteString, Bool)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString
extraMb, Bool
True)
          (Progression
_, Maybe ByteString
_) -> (Maybe ByteString, Bool) -> m (Maybe ByteString, Bool)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe ByteString
extraMb, Bool
False)
      onParse (A.Partial ByteString -> IResult ByteString a
continue) = m ByteString
pullChunk m ByteString
-> (ByteString -> m (Maybe ByteString, Bool))
-> m (Maybe ByteString, Bool)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IResult ByteString a -> m (Maybe ByteString, Bool)
onParse (IResult ByteString a -> m (Maybe ByteString, Bool))
-> (ByteString -> IResult ByteString a)
-> ByteString
-> m (Maybe ByteString, Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IResult ByteString a
continue
  m ByteString -> Parser a -> ByteString -> m (IResult ByteString a)
forall (m :: * -> *) a.
Monad m =>
m ByteString -> Parser a -> ByteString -> m (Result a)
A.parseWith m ByteString
pullChunk Parser a
parser ByteString
initial m (IResult ByteString a)
-> (IResult ByteString a -> m (Maybe ByteString, Bool))
-> m (Maybe ByteString, Bool)
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IResult ByteString a -> m (Maybe ByteString, Bool)
onParse


parsingFailed :: [String] -> String -> Text
parsingFailed :: [String] -> String -> Text
parsingFailed [String]
context String
reason =
  let contexts :: Text
contexts = Text -> [Text] -> Text
Text.intercalate Text
"-" (String -> Text
Text.pack (String -> Text) -> [String] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
context)
      cause :: Text
cause = if String -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
reason then Text
Text.empty else Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
Text.pack String
reason
   in Text
"bad parse:" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
contexts Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
cause


{- $exceptions

On failures, @'runFramer'@ throws @'Exception's@ using @'MonadThrow'@ rather
than using an @Either@ or @MonadError@

This is because its intended use is for parsing framed protocol byte streams;
where parsing or connection errors are typically not recoverable. In
haskell non-recoverable failures are better modelled using @Exceptions@.

Although it throws 'NoMoreInput' or 'BrokenFrame' when appropriate, it provides
hooks to override these when constructing a 'Framer'.

By use of 'setOnClosed' and 'setOnBadParse', the caller of @runFramer@ can
completely override the exception type that is raised when @runFramer@ encounters
any failure.
-}


{- | Thrown by 'runFramer' or 'runOneFrame' if parsing fails and there is no
 handler installed using 'setOnBadParse', or it does not throw an exception.
-}
newtype BrokenFrame = BrokenFrame String
  deriving (BrokenFrame -> BrokenFrame -> Bool
(BrokenFrame -> BrokenFrame -> Bool)
-> (BrokenFrame -> BrokenFrame -> Bool) -> Eq BrokenFrame
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: BrokenFrame -> BrokenFrame -> Bool
== :: BrokenFrame -> BrokenFrame -> Bool
$c/= :: BrokenFrame -> BrokenFrame -> Bool
/= :: BrokenFrame -> BrokenFrame -> Bool
Eq, Int -> BrokenFrame -> ShowS
[BrokenFrame] -> ShowS
BrokenFrame -> String
(Int -> BrokenFrame -> ShowS)
-> (BrokenFrame -> String)
-> ([BrokenFrame] -> ShowS)
-> Show BrokenFrame
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BrokenFrame -> ShowS
showsPrec :: Int -> BrokenFrame -> ShowS
$cshow :: BrokenFrame -> String
show :: BrokenFrame -> String
$cshowList :: [BrokenFrame] -> ShowS
showList :: [BrokenFrame] -> ShowS
Show)


instance Exception BrokenFrame


{- | Thrown by 'runFramer' or 'runOneFrame' when no further input is available and
 no end of input handler is set using 'setOnClosed'.
-}
data NoMoreInput = NoMoreInput
  deriving (NoMoreInput -> NoMoreInput -> Bool
(NoMoreInput -> NoMoreInput -> Bool)
-> (NoMoreInput -> NoMoreInput -> Bool) -> Eq NoMoreInput
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: NoMoreInput -> NoMoreInput -> Bool
== :: NoMoreInput -> NoMoreInput -> Bool
$c/= :: NoMoreInput -> NoMoreInput -> Bool
/= :: NoMoreInput -> NoMoreInput -> Bool
Eq, Int -> NoMoreInput -> ShowS
[NoMoreInput] -> ShowS
NoMoreInput -> String
(Int -> NoMoreInput -> ShowS)
-> (NoMoreInput -> String)
-> ([NoMoreInput] -> ShowS)
-> Show NoMoreInput
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> NoMoreInput -> ShowS
showsPrec :: Int -> NoMoreInput -> ShowS
$cshow :: NoMoreInput -> String
show :: NoMoreInput -> String
$cshowList :: [NoMoreInput] -> ShowS
showList :: [NoMoreInput] -> ShowS
Show)


instance Exception NoMoreInput


closedReason :: String
closedReason :: String
closedReason = String
"not enough input"


defaultChunkSize :: Word32
defaultChunkSize :: Word32
defaultChunkSize = Word32
2048