{-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NamedFieldPuns #-} module Network.TypedProtocol.PingPong.Codec where import Network.TypedProtocol.Codec import Network.TypedProtocol.PingPong.Type codecPingPong :: forall m. Monad m => Codec PingPong CodecFailure m String codecPingPong :: Codec PingPong CodecFailure m String codecPingPong = 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 (pr :: PeerRole) (st :: PingPong) (st' :: PingPong). PeerHasAgency pr st -> Message PingPong st st' -> String encode :: forall (pr :: PeerRole) (st :: PingPong) (st' :: PingPong). PeerHasAgency pr st -> Message PingPong st st' -> String encode :: forall (pr :: PeerRole) (st :: PingPong) (st' :: PingPong). PeerHasAgency pr st -> Message PingPong st st' -> String encode, forall (pr :: PeerRole) (st :: PingPong). PeerHasAgency pr st -> m (DecodeStep String CodecFailure m (SomeMessage st)) decode :: forall (pr :: PeerRole) (st :: PingPong). PeerHasAgency pr st -> m (DecodeStep String CodecFailure m (SomeMessage st)) decode :: forall (pr :: PeerRole) (st :: PingPong). PeerHasAgency pr st -> m (DecodeStep String CodecFailure m (SomeMessage st)) decode} where encode :: forall pr (st :: PingPong) (st' :: PingPong) . PeerHasAgency pr st -> Message PingPong st st' -> String encode :: PeerHasAgency pr st -> Message PingPong st st' -> String encode (ClientAgency ClientHasAgency st TokIdle) Message PingPong st st' MsgPing = String "ping\n" encode (ClientAgency ClientHasAgency st TokIdle) Message PingPong st st' MsgDone = String "done\n" encode (ServerAgency ServerHasAgency st TokBusy) Message PingPong st st' MsgPong = String "pong\n" decode :: forall pr (st :: PingPong) . 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, String str) of (ServerAgency ServerHasAgency st TokBusy, String "pong") -> 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 PingPong 'StBusy 'StIdle -> SomeMessage 'StBusy forall ps (st :: ps) (st' :: ps). Message ps st st' -> SomeMessage st SomeMessage Message PingPong 'StBusy 'StIdle MsgPong) Maybe String trailing (ClientAgency ClientHasAgency st TokIdle, String "ping") -> 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 PingPong 'StIdle 'StBusy -> SomeMessage 'StIdle forall ps (st :: ps) (st' :: ps). Message ps st st' -> SomeMessage st SomeMessage Message PingPong 'StIdle 'StBusy MsgPing) Maybe String trailing (ClientAgency ClientHasAgency st TokIdle, String "done") -> 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 PingPong 'StIdle 'StDone -> SomeMessage 'StIdle forall ps (st :: ps) (st' :: ps). Message ps st st' -> SomeMessage st SomeMessage Message PingPong 'StIdle 'StDone MsgDone) Maybe String trailing (ServerAgency ServerHasAgency st _ , 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 _ ) -> 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) decodeTerminatedFrame :: forall m a. Monad m => Char -> (String -> Maybe String -> DecodeStep String CodecFailure m a) -> m (DecodeStep String CodecFailure m a) decodeTerminatedFrame :: Char -> (String -> Maybe String -> DecodeStep String CodecFailure m a) -> m (DecodeStep String CodecFailure m a) decodeTerminatedFrame Char terminator String -> Maybe String -> DecodeStep String CodecFailure m a k = [String] -> m (DecodeStep String CodecFailure m a) go [] where go :: [String] -> m (DecodeStep String CodecFailure m a) go :: [String] -> m (DecodeStep String CodecFailure m a) go [String] chunks = DecodeStep String CodecFailure m a -> m (DecodeStep String CodecFailure m a) forall (m :: * -> *) a. Monad m => a -> m a return (DecodeStep String CodecFailure m a -> m (DecodeStep String CodecFailure m a)) -> DecodeStep String CodecFailure m a -> m (DecodeStep String CodecFailure m a) forall a b. (a -> b) -> a -> b $ (Maybe String -> m (DecodeStep String CodecFailure m a)) -> DecodeStep String CodecFailure m a forall bytes failure (m :: * -> *) a. (Maybe bytes -> m (DecodeStep bytes failure m a)) -> DecodeStep bytes failure m a DecodePartial ((Maybe String -> m (DecodeStep String CodecFailure m a)) -> DecodeStep String CodecFailure m a) -> (Maybe String -> m (DecodeStep String CodecFailure m a)) -> DecodeStep String CodecFailure m a forall a b. (a -> b) -> a -> b $ \Maybe String mchunk -> case Maybe String mchunk of Maybe String Nothing -> DecodeStep String CodecFailure m a -> m (DecodeStep String CodecFailure m a) forall (m :: * -> *) a. Monad m => a -> m a return (DecodeStep String CodecFailure m a -> m (DecodeStep String CodecFailure m a)) -> DecodeStep String CodecFailure m a -> m (DecodeStep String CodecFailure m a) forall a b. (a -> b) -> a -> b $ CodecFailure -> DecodeStep String CodecFailure m a forall bytes failure (m :: * -> *) a. failure -> DecodeStep bytes failure m a DecodeFail CodecFailure CodecFailureOutOfInput Just String chunk -> case (Char -> Bool) -> String -> (String, String) forall a. (a -> Bool) -> [a] -> ([a], [a]) break (Char -> Char -> Bool forall a. Eq a => a -> a -> Bool ==Char terminator) String chunk of (String c, Char _:String c') -> DecodeStep String CodecFailure m a -> m (DecodeStep String CodecFailure m a) forall (m :: * -> *) a. Monad m => a -> m a return (DecodeStep String CodecFailure m a -> m (DecodeStep String CodecFailure m a)) -> DecodeStep String CodecFailure m a -> m (DecodeStep String CodecFailure m a) forall a b. (a -> b) -> a -> b $ String -> Maybe String -> DecodeStep String CodecFailure m a k ([String] -> String forall (t :: * -> *) a. Foldable t => t [a] -> [a] concat ([String] -> [String] forall a. [a] -> [a] reverse (String cString -> [String] -> [String] forall a. a -> [a] -> [a] :[String] chunks))) (if String -> Bool forall (t :: * -> *) a. Foldable t => t a -> Bool null String c' then Maybe String forall a. Maybe a Nothing else String -> Maybe String forall a. a -> Maybe a Just String c) (String, String) _ -> [String] -> m (DecodeStep String CodecFailure m a) go (String chunk String -> [String] -> [String] forall a. a -> [a] -> [a] : [String] chunks)