{-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE TypeInType #-} module Network.TypedProtocol.ReqResp.Codec where import Network.TypedProtocol.Codec import Network.TypedProtocol.ReqResp.Type import Network.TypedProtocol.PingPong.Codec (decodeTerminatedFrame) 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 :: Codec (ReqResp req resp) CodecFailure m String codecReqResp = Codec :: forall ps failure (m :: * -> *) bytes. (forall (pr :: PeerRole) (st :: ps) (st' :: ps). PeerHasAgency pr st -> Message ps st st' -> bytes) -> (forall (pr :: PeerRole) (st :: ps). PeerHasAgency pr st -> m (DecodeStep bytes failure m (SomeMessage st))) -> Codec ps failure m bytes Codec{forall k k (req' :: k) (resp' :: k) (pr :: PeerRole) (st :: ReqResp req' resp') (st' :: ReqResp req' resp'). Show (Message (ReqResp req' resp') st st') => PeerHasAgency pr st -> Message (ReqResp req' resp') st st' -> String forall (pr :: PeerRole) (st :: ReqResp req resp) (st' :: ReqResp req resp). PeerHasAgency pr st -> Message (ReqResp req resp) st st' -> String encode :: forall (pr :: PeerRole) (st :: ReqResp req resp) (st' :: ReqResp req resp). PeerHasAgency pr st -> Message (ReqResp req resp) st st' -> String encode :: forall k k (req' :: k) (resp' :: k) (pr :: PeerRole) (st :: ReqResp req' resp') (st' :: ReqResp req' resp'). Show (Message (ReqResp req' resp') st st') => PeerHasAgency pr st -> Message (ReqResp req' resp') st st' -> String encode, forall req' resp' (m' :: * -> *) (pr :: PeerRole) (st :: ReqResp req' resp'). (Monad m', Read req', Read resp') => PeerHasAgency pr st -> m' (DecodeStep String CodecFailure m' (SomeMessage st)) forall (pr :: PeerRole) (st :: ReqResp req resp). PeerHasAgency pr st -> m (DecodeStep String CodecFailure m (SomeMessage st)) decode :: forall (pr :: PeerRole) (st :: ReqResp req resp). PeerHasAgency pr st -> m (DecodeStep String CodecFailure m (SomeMessage st)) decode :: forall req' resp' (m' :: * -> *) (pr :: PeerRole) (st :: ReqResp req' resp'). (Monad m', Read req', Read resp') => PeerHasAgency pr st -> m' (DecodeStep String CodecFailure m' (SomeMessage st)) decode} where encode :: forall req' resp' (pr :: PeerRole) (st :: ReqResp req' resp') (st' :: ReqResp req' resp') . (Show (Message (ReqResp req' resp') st st')) => PeerHasAgency pr st -> Message (ReqResp req' resp') st st' -> String encode :: PeerHasAgency pr st -> Message (ReqResp req' resp') st st' -> String encode (ClientAgency ClientHasAgency st TokIdle) 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" encode (ServerAgency ServerHasAgency st TokBusy) 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' (pr :: PeerRole) (st :: ReqResp req' resp') . (Monad m', Read req', Read resp') => PeerHasAgency pr st -> m' (DecodeStep String CodecFailure m' (SomeMessage st)) decode :: PeerHasAgency pr st -> m' (DecodeStep String CodecFailure m' (SomeMessage st)) decode PeerHasAgency pr 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 (PeerHasAgency pr 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 (ClientAgency ClientHasAgency st TokIdle, (String "MsgReq", String str')) | Just req' resp <- String -> Maybe req' forall a. Read a => String -> Maybe a readMaybe String str' -> SomeMessage 'StIdle -> Maybe String -> DecodeStep String CodecFailure m' (SomeMessage 'StIdle) forall bytes failure (m :: * -> *) a. a -> Maybe bytes -> DecodeStep bytes failure m a DecodeDone (Message (ReqResp req' resp') 'StIdle 'StBusy -> SomeMessage 'StIdle forall ps (st :: ps) (st' :: ps). Message ps st st' -> SomeMessage st SomeMessage (req' -> Message (ReqResp req' resp') 'StIdle 'StBusy forall k req (resp :: k). req -> Message (ReqResp req resp) 'StIdle 'StBusy MsgReq req' resp)) Maybe String trailing (ClientAgency ClientHasAgency st TokIdle, (String "MsgDone", String "")) -> SomeMessage 'StIdle -> Maybe String -> DecodeStep String CodecFailure m' (SomeMessage 'StIdle) forall bytes failure (m :: * -> *) a. a -> Maybe bytes -> DecodeStep bytes failure m a DecodeDone (Message (ReqResp req' resp') 'StIdle 'StDone -> SomeMessage 'StIdle forall ps (st :: ps) (st' :: ps). Message ps st st' -> SomeMessage st SomeMessage Message (ReqResp req' resp') 'StIdle 'StDone forall k k (req :: k) (resp :: k). Message (ReqResp req resp) 'StIdle 'StDone MsgDone) Maybe String trailing (ServerAgency ServerHasAgency st TokBusy, (String "MsgResp", String str')) | Just resp' resp <- String -> Maybe resp' forall a. Read a => String -> Maybe a readMaybe String str' -> SomeMessage 'StBusy -> Maybe String -> DecodeStep String CodecFailure m' (SomeMessage 'StBusy) forall bytes failure (m :: * -> *) a. a -> Maybe bytes -> DecodeStep bytes failure m a DecodeDone (Message (ReqResp req' resp') 'StBusy 'StIdle -> SomeMessage 'StBusy forall ps (st :: ps) (st' :: ps). Message ps st st' -> SomeMessage st SomeMessage (resp' -> Message (ReqResp req' resp') 'StBusy 'StIdle forall k resp (req :: k). resp -> Message (ReqResp req resp) 'StBusy 'StIdle MsgResp resp' resp)) Maybe String trailing (ServerAgency ServerHasAgency 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) (ClientAgency ClientHasAgency 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 client message: " String -> String -> String forall a. [a] -> [a] -> [a] ++ String str)