module Network.Greskell.WebSocket.Codec
(
Codec (..)
, encodeBinaryWith
, messageHeader
, decodeBinary
) where
import Control.Monad (when)
import qualified Data.ByteString.Lazy as BSL
import Data.Monoid ((<>))
import Data.Text (Text)
import Data.Text.Encoding (decodeUtf8', encodeUtf8)
import Network.Greskell.WebSocket.Request (RequestMessage)
import Network.Greskell.WebSocket.Response (ResponseMessage)
data Codec s
= Codec
{ forall s. Codec s -> Text
mimeType :: Text
, forall s. Codec s -> RequestMessage -> ByteString
encodeWith :: RequestMessage -> BSL.ByteString
, forall s.
Codec s -> ByteString -> Either String (ResponseMessage s)
decodeWith :: BSL.ByteString -> Either String (ResponseMessage s)
}
instance Functor Codec where
fmap :: forall a b. (a -> b) -> Codec a -> Codec b
fmap a -> b
f Codec a
c = Codec a
c { decodeWith :: ByteString -> Either String (ResponseMessage b)
decodeWith = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f forall a b. (a -> b) -> a -> b
$ forall s.
Codec s -> ByteString -> Either String (ResponseMessage s)
decodeWith Codec a
c }
messageHeader :: Text
-> BSL.ByteString
Text
mime = Word8 -> ByteString
BSL.singleton Word8
size forall a. Semigroup a => a -> a -> a
<> ByteString
mime_bin
where
size :: Word8
size = forall a b. (Integral a, Num b) => a -> b
fromIntegral forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BSL.length ByteString
mime_bin
mime_bin :: ByteString
mime_bin = ByteString -> ByteString
BSL.fromStrict forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
mime
encodeBinaryWith :: Codec s -> RequestMessage -> BSL.ByteString
encodeBinaryWith :: forall s. Codec s -> RequestMessage -> ByteString
encodeBinaryWith Codec s
c RequestMessage
req = Text -> ByteString
messageHeader (forall s. Codec s -> Text
mimeType Codec s
c) forall a. Semigroup a => a -> a -> a
<> forall s. Codec s -> RequestMessage -> ByteString
encodeWith Codec s
c RequestMessage
req
decodeBinary :: BSL.ByteString
-> Either String (Text, BSL.ByteString)
decodeBinary :: ByteString -> Either String (Text, ByteString)
decodeBinary ByteString
raw_msg = do
case ByteString -> Maybe (Word8, ByteString)
BSL.uncons ByteString
raw_msg of
Maybe (Word8, ByteString)
Nothing -> forall a b. a -> Either a b
Left String
"Length of MIME type is missing in the header."
Just (Word8
mime_len, ByteString
rest) -> forall {p}.
Integral p =>
p -> ByteString -> Either String (Text, ByteString)
decodeMimeAndPayload Word8
mime_len ByteString
rest
where
decodeMimeAndPayload :: p -> ByteString -> Either String (Text, ByteString)
decodeMimeAndPayload p
mime_lenw ByteString
msg = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int64
BSL.length ByteString
mime_field forall a. Eq a => a -> a -> Bool
/= Int64
mime_len) forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (String
"Too short MIME field: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show ByteString
mime_field)
Text
mime_text <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
decodeUtf8' forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict forall a b. (a -> b) -> a -> b
$ ByteString
mime_field
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
mime_text, ByteString
payload)
where
(ByteString
mime_field, ByteString
payload) = Int64 -> ByteString -> (ByteString, ByteString)
BSL.splitAt Int64
mime_len ByteString
msg
mime_len :: Int64
mime_len = forall a b. (Integral a, Num b) => a -> b
fromIntegral p
mime_lenw