{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE NamedFieldPuns      #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.TypedProtocol.ReqResp.Codec where

import           Network.TypedProtocol.Codec
import           Network.TypedProtocol.Core
import           Network.TypedProtocol.PingPong.Codec (decodeTerminatedFrame)
import           Network.TypedProtocol.ReqResp.Type
import           Text.Read (readMaybe)


codecReqResp ::
    forall req resp m
  . (Monad m, Show req, Show resp, Read req, Read resp)
  => Codec (ReqResp req resp) CodecFailure m String
codecReqResp :: forall req resp (m :: * -> *).
(Monad m, Show req, Show resp, Read req, Read resp) =>
Codec (ReqResp req resp) CodecFailure m String
codecReqResp =
    Codec{Message (ReqResp req resp) st st' -> String
forall {k} {k1} (req' :: k) (resp' :: k1)
       (st :: ReqResp req' resp') (st' :: ReqResp req' resp').
Show (Message (ReqResp req' resp') st st') =>
Message (ReqResp req' resp') st st' -> String
forall (st :: ReqResp req resp) (st' :: ReqResp req resp).
(StateTokenI st, ActiveState st) =>
Message (ReqResp req resp) st st' -> String
encode :: forall {k} {k1} (req' :: k) (resp' :: k1)
       (st :: ReqResp req' resp') (st' :: ReqResp req' resp').
Show (Message (ReqResp req' resp') st st') =>
Message (ReqResp req' resp') st st' -> String
encode :: forall (st :: ReqResp req resp) (st' :: ReqResp req resp).
(StateTokenI st, ActiveState st) =>
Message (ReqResp req resp) st st' -> String
encode, StateToken st
-> m (DecodeStep String CodecFailure m (SomeMessage st))
forall req' resp' (m' :: * -> *) (st :: ReqResp req' resp').
(Monad m', Read req', Read resp', ActiveState st) =>
StateToken st
-> m' (DecodeStep String CodecFailure m' (SomeMessage st))
forall (st :: ReqResp req resp).
ActiveState st =>
StateToken st
-> m (DecodeStep String CodecFailure m (SomeMessage st))
decode :: forall req' resp' (m' :: * -> *) (st :: ReqResp req' resp').
(Monad m', Read req', Read resp', ActiveState st) =>
StateToken st
-> m' (DecodeStep String CodecFailure m' (SomeMessage st))
decode :: forall (st :: ReqResp req resp).
ActiveState st =>
StateToken st
-> m (DecodeStep String CodecFailure m (SomeMessage st))
decode}
  where
    encode :: forall req' resp'
                     (st  :: ReqResp req' resp')
                     (st' :: ReqResp req' resp')
           .  ( Show (Message (ReqResp req' resp') st st') )
           => Message (ReqResp req' resp') st st'
           -> String
    encode :: forall {k} {k1} (req' :: k) (resp' :: k1)
       (st :: ReqResp req' resp') (st' :: ReqResp req' resp').
Show (Message (ReqResp req' resp') st st') =>
Message (ReqResp req' resp') st st' -> String
encode Message (ReqResp req' resp') st st'
msg = Message (ReqResp req' resp') st st' -> String
forall a. Show a => a -> String
show Message (ReqResp req' resp') st st'
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n"

    decode :: forall req' resp' m'
                     (st :: ReqResp req' resp')
           .  (Monad m', Read req', Read resp', ActiveState st)
           => StateToken st
           -> m' (DecodeStep String CodecFailure m' (SomeMessage st))
    decode :: forall req' resp' (m' :: * -> *) (st :: ReqResp req' resp').
(Monad m', Read req', Read resp', ActiveState st) =>
StateToken st
-> m' (DecodeStep String CodecFailure m' (SomeMessage st))
decode StateToken st
stok =
      Char
-> (String
    -> Maybe String
    -> DecodeStep String CodecFailure m' (SomeMessage st))
-> m' (DecodeStep String CodecFailure m' (SomeMessage st))
forall (m :: * -> *) a.
Monad m =>
Char
-> (String -> Maybe String -> DecodeStep String CodecFailure m a)
-> m (DecodeStep String CodecFailure m a)
decodeTerminatedFrame Char
'\n' ((String
  -> Maybe String
  -> DecodeStep String CodecFailure m' (SomeMessage st))
 -> m' (DecodeStep String CodecFailure m' (SomeMessage st)))
-> (String
    -> Maybe String
    -> DecodeStep String CodecFailure m' (SomeMessage st))
-> m' (DecodeStep String CodecFailure m' (SomeMessage st))
forall a b. (a -> b) -> a -> b
$ \String
str Maybe String
trailing ->
        case (StateToken st
SReqResp st
stok, (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
' ') String
str) of
          (SReqResp st
SingIdle, (String
"MsgReq", String
str'))
             | Just req'
req <- String -> Maybe req'
forall a. Read a => String -> Maybe a
readMaybe String
str'
            -> SomeMessage st
-> Maybe String
-> DecodeStep String CodecFailure m' (SomeMessage st)
forall bytes failure (m :: * -> *) a.
a -> Maybe bytes -> DecodeStep bytes failure m a
DecodeDone (Message (ReqResp req' resp') st 'StBusy -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage (req' -> Message (ReqResp req' resp') 'StIdle 'StBusy
forall {k1} req1 (resp :: k1).
req1 -> Message (ReqResp req1 resp) 'StIdle 'StBusy
MsgReq req'
req)) Maybe String
trailing
          (SReqResp st
SingIdle, (String
"MsgDone", String
""))
            -> SomeMessage st
-> Maybe String
-> DecodeStep String CodecFailure m' (SomeMessage st)
forall bytes failure (m :: * -> *) a.
a -> Maybe bytes -> DecodeStep bytes failure m a
DecodeDone (Message (ReqResp req' resp') st 'StDone -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage Message (ReqResp req' resp') st 'StDone
Message (ReqResp req' resp') 'StIdle 'StDone
forall {k} {k1} (req :: k) (resp :: k1).
Message (ReqResp req resp) 'StIdle 'StDone
MsgDone) Maybe String
trailing
          (SReqResp st
SingBusy, (String
"MsgResp", String
str'))
            | Just resp'
resp <- String -> Maybe resp'
forall a. Read a => String -> Maybe a
readMaybe String
str'
            -> SomeMessage st
-> Maybe String
-> DecodeStep String CodecFailure m' (SomeMessage st)
forall bytes failure (m :: * -> *) a.
a -> Maybe bytes -> DecodeStep bytes failure m a
DecodeDone (Message (ReqResp req' resp') st 'StIdle -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage (resp' -> Message (ReqResp req' resp') 'StBusy 'StIdle
forall {k} resp1 (req :: k).
resp1 -> Message (ReqResp req resp1) 'StBusy 'StIdle
MsgResp resp'
resp)) Maybe String
trailing

          (SReqResp st
_       , (String, String)
_     ) -> CodecFailure -> DecodeStep String CodecFailure m' (SomeMessage st)
forall bytes failure (m :: * -> *) a.
failure -> DecodeStep bytes failure m a
DecodeFail CodecFailure
failure
            where failure :: CodecFailure
failure = String -> CodecFailure
CodecFailure (String
"unexpected server message: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
str)


codecReqRespId ::
    forall req resp m
  . (Monad m, Show req, Show resp)
  => Codec (ReqResp req resp) CodecFailure m (AnyMessage (ReqResp req resp))
codecReqRespId :: forall req resp (m :: * -> *).
(Monad m, Show req, Show resp) =>
Codec
  (ReqResp req resp) CodecFailure m (AnyMessage (ReqResp req resp))
codecReqRespId =
    Codec{Message (ReqResp req resp) st st' -> AnyMessage (ReqResp req resp)
forall (st :: ReqResp req resp) (st' :: ReqResp req resp).
(StateTokenI st, ActiveState st) =>
Message (ReqResp req resp) st st' -> AnyMessage (ReqResp req resp)
encode :: forall (st :: ReqResp req resp) (st' :: ReqResp req resp).
(StateTokenI st, ActiveState st) =>
Message (ReqResp req resp) st st' -> AnyMessage (ReqResp req resp)
encode :: forall (st :: ReqResp req resp) (st' :: ReqResp req resp).
(StateTokenI st, ActiveState st) =>
Message (ReqResp req resp) st st' -> AnyMessage (ReqResp req resp)
encode, StateToken st
-> m (DecodeStep
        (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st))
forall (st :: ReqResp req resp).
ActiveState st =>
StateToken st
-> m (DecodeStep
        (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st))
decode :: forall (st :: ReqResp req resp).
ActiveState st =>
StateToken st
-> m (DecodeStep
        (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st))
decode :: forall (st :: ReqResp req resp).
ActiveState st =>
StateToken st
-> m (DecodeStep
        (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st))
decode}
  where
    encode :: forall (st  :: ReqResp req resp)
                     (st' :: ReqResp req resp)
           .  StateTokenI st
           => ActiveState st
           => Message (ReqResp req resp) st st'
           -> AnyMessage (ReqResp req resp)
    encode :: forall (st :: ReqResp req resp) (st' :: ReqResp req resp).
(StateTokenI st, ActiveState st) =>
Message (ReqResp req resp) st st' -> AnyMessage (ReqResp req resp)
encode Message (ReqResp req resp) st st'
msg = Message (ReqResp req resp) st st' -> AnyMessage (ReqResp req resp)
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, ActiveState st) =>
Message ps st st' -> AnyMessage ps
AnyMessage Message (ReqResp req resp) st st'
msg

    decode :: forall (st :: ReqResp req resp)
           .  ActiveState st
           => StateToken st
           -> m (DecodeStep (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st))
    decode :: forall (st :: ReqResp req resp).
ActiveState st =>
StateToken st
-> m (DecodeStep
        (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st))
decode StateToken st
stok =
      DecodeStep
  (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
-> m (DecodeStep
        (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st))
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (DecodeStep
   (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
 -> m (DecodeStep
         (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)))
-> DecodeStep
     (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
-> m (DecodeStep
        (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st))
forall a b. (a -> b) -> a -> b
$ (Maybe (AnyMessage (ReqResp req resp))
 -> m (DecodeStep
         (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)))
-> DecodeStep
     (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
forall bytes failure (m :: * -> *) a.
(Maybe bytes -> m (DecodeStep bytes failure m a))
-> DecodeStep bytes failure m a
DecodePartial ((Maybe (AnyMessage (ReqResp req resp))
  -> m (DecodeStep
          (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)))
 -> DecodeStep
      (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st))
-> (Maybe (AnyMessage (ReqResp req resp))
    -> m (DecodeStep
            (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)))
-> DecodeStep
     (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
forall a b. (a -> b) -> a -> b
$ \Maybe (AnyMessage (ReqResp req resp))
mb ->
        case Maybe (AnyMessage (ReqResp req resp))
mb of
          Maybe (AnyMessage (ReqResp req resp))
Nothing -> DecodeStep
  (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
-> m (DecodeStep
        (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DecodeStep
   (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
 -> m (DecodeStep
         (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)))
-> DecodeStep
     (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
-> m (DecodeStep
        (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st))
forall a b. (a -> b) -> a -> b
$ CodecFailure
-> DecodeStep
     (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
forall bytes failure (m :: * -> *) a.
failure -> DecodeStep bytes failure m a
DecodeFail (String -> CodecFailure
CodecFailure String
"expected more data")
          Just (AnyMessage Message (ReqResp req resp) st st'
msg) -> DecodeStep
  (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
-> m (DecodeStep
        (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DecodeStep
   (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
 -> m (DecodeStep
         (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)))
-> DecodeStep
     (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
-> m (DecodeStep
        (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st))
forall a b. (a -> b) -> a -> b
$
            case (StateToken st
SReqResp st
stok, Message (ReqResp req resp) st st'
msg) of
              (SReqResp st
SingIdle, MsgReq{})
                -> SomeMessage st
-> Maybe (AnyMessage (ReqResp req resp))
-> DecodeStep
     (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
forall bytes failure (m :: * -> *) a.
a -> Maybe bytes -> DecodeStep bytes failure m a
DecodeDone (Message (ReqResp req resp) st st' -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage Message (ReqResp req resp) st st'
Message (ReqResp req resp) st st'
msg) Maybe (AnyMessage (ReqResp req resp))
forall a. Maybe a
Nothing
              (SReqResp st
SingIdle, Message (ReqResp req resp) st st'
R:MessageReqRespfromto (*) (*) req resp st st'
MsgDone)
                -> SomeMessage st
-> Maybe (AnyMessage (ReqResp req resp))
-> DecodeStep
     (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
forall bytes failure (m :: * -> *) a.
a -> Maybe bytes -> DecodeStep bytes failure m a
DecodeDone (Message (ReqResp req resp) st st' -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage Message (ReqResp req resp) st st'
Message (ReqResp req resp) st st'
msg) Maybe (AnyMessage (ReqResp req resp))
forall a. Maybe a
Nothing
              (SReqResp st
SingBusy, MsgResp{})
                -> SomeMessage st
-> Maybe (AnyMessage (ReqResp req resp))
-> DecodeStep
     (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
forall bytes failure (m :: * -> *) a.
a -> Maybe bytes -> DecodeStep bytes failure m a
DecodeDone (Message (ReqResp req resp) st st' -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage Message (ReqResp req resp) st st'
Message (ReqResp req resp) st st'
msg) Maybe (AnyMessage (ReqResp req resp))
forall a. Maybe a
Nothing

              (SReqResp st
SingIdle, Message (ReqResp req resp) st st'
_) ->
                CodecFailure
-> DecodeStep
     (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
forall bytes failure (m :: * -> *) a.
failure -> DecodeStep bytes failure m a
DecodeFail CodecFailure
failure
                  where failure :: CodecFailure
failure = String -> CodecFailure
CodecFailure (String
"unexpected client message: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Message (ReqResp req resp) st st' -> String
forall a. Show a => a -> String
show Message (ReqResp req resp) st st'
msg)
              (SReqResp st
SingBusy, Message (ReqResp req resp) st st'
_) ->
                CodecFailure
-> DecodeStep
     (AnyMessage (ReqResp req resp)) CodecFailure m (SomeMessage st)
forall bytes failure (m :: * -> *) a.
failure -> DecodeStep bytes failure m a
DecodeFail CodecFailure
failure
                  where failure :: CodecFailure
failure = String -> CodecFailure
CodecFailure (String
"unexpected server message: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Message (ReqResp req resp) st st' -> String
forall a. Show a => a -> String
show Message (ReqResp req resp) st st'
msg)

              (a :: SReqResp st
a@SReqResp st
SingDone, Message (ReqResp req resp) st st'
_) -> StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken 'StDone
SReqResp st
a