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 (encodeUtf8, decodeUtf8')
import Network.Greskell.WebSocket.Request (RequestMessage)
import Network.Greskell.WebSocket.Response (ResponseMessage)
data Codec s =
Codec
{ Codec s -> Text
mimeType :: Text,
Codec s -> RequestMessage -> ByteString
encodeWith :: RequestMessage -> BSL.ByteString,
Codec s -> ByteString -> Either String (ResponseMessage s)
decodeWith :: BSL.ByteString -> Either String (ResponseMessage s)
}
instance Functor Codec where
fmap :: (a -> b) -> Codec a -> Codec b
fmap a -> b
f Codec a
c = Codec a
c { decodeWith :: ByteString -> Either String (ResponseMessage b)
decodeWith = ((Either String (ResponseMessage a)
-> Either String (ResponseMessage b))
-> (ByteString -> Either String (ResponseMessage a))
-> ByteString
-> Either String (ResponseMessage b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either String (ResponseMessage a)
-> Either String (ResponseMessage b))
-> (ByteString -> Either String (ResponseMessage a))
-> ByteString
-> Either String (ResponseMessage b))
-> ((a -> b)
-> Either String (ResponseMessage a)
-> Either String (ResponseMessage b))
-> (a -> b)
-> (ByteString -> Either String (ResponseMessage a))
-> ByteString
-> Either String (ResponseMessage b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ResponseMessage a -> ResponseMessage b)
-> Either String (ResponseMessage a)
-> Either String (ResponseMessage b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ResponseMessage a -> ResponseMessage b)
-> Either String (ResponseMessage a)
-> Either String (ResponseMessage b))
-> ((a -> b) -> ResponseMessage a -> ResponseMessage b)
-> (a -> b)
-> Either String (ResponseMessage a)
-> Either String (ResponseMessage b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> b) -> ResponseMessage a -> ResponseMessage b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) a -> b
f ((ByteString -> Either String (ResponseMessage a))
-> ByteString -> Either String (ResponseMessage b))
-> (ByteString -> Either String (ResponseMessage a))
-> ByteString
-> Either String (ResponseMessage b)
forall a b. (a -> b) -> a -> b
$ Codec a -> ByteString -> Either String (ResponseMessage a)
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 ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
mime_bin
where
size :: Word8
size = Int64 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int64 -> Word8) -> Int64 -> Word8
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
BSL.length ByteString
mime_bin
mime_bin :: ByteString
mime_bin = ByteString -> ByteString
BSL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
encodeUtf8 Text
mime
encodeBinaryWith :: Codec s -> RequestMessage -> BSL.ByteString
encodeBinaryWith :: Codec s -> RequestMessage -> ByteString
encodeBinaryWith Codec s
c RequestMessage
req = Text -> ByteString
messageHeader (Codec s -> Text
forall s. Codec s -> Text
mimeType Codec s
c) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> Codec s -> RequestMessage -> ByteString
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 -> String -> Either String (Text, ByteString)
forall a b. a -> Either a b
Left String
"Length of MIME type is missing in the header."
Just (Word8
mime_len, ByteString
rest) -> Word8 -> ByteString -> Either String (Text, ByteString)
forall a.
Integral a =>
a -> ByteString -> Either String (Text, ByteString)
decodeMimeAndPayload Word8
mime_len ByteString
rest
where
decodeMimeAndPayload :: a -> ByteString -> Either String (Text, ByteString)
decodeMimeAndPayload a
mime_lenw ByteString
msg = do
Bool -> Either String () -> Either String ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int64
BSL.length ByteString
mime_field Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
/= Int64
mime_len) (Either String () -> Either String ())
-> Either String () -> Either String ()
forall a b. (a -> b) -> a -> b
$ String -> Either String ()
forall a b. a -> Either a b
Left (String
"Too short MIME field: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> ByteString -> String
forall a. Show a => a -> String
show ByteString
mime_field)
Text
mime_text <- (UnicodeException -> Either String Text)
-> (Text -> Either String Text)
-> Either UnicodeException Text
-> Either String Text
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (String -> Either String Text
forall a b. a -> Either a b
Left (String -> Either String Text)
-> (UnicodeException -> String)
-> UnicodeException
-> Either String Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnicodeException -> String
forall a. Show a => a -> String
show) Text -> Either String Text
forall a b. b -> Either a b
Right (Either UnicodeException Text -> Either String Text)
-> Either UnicodeException Text -> Either String Text
forall a b. (a -> b) -> a -> b
$ ByteString -> Either UnicodeException Text
decodeUtf8' (ByteString -> Either UnicodeException Text)
-> ByteString -> Either UnicodeException Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
BSL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString
mime_field
(Text, ByteString) -> Either String (Text, ByteString)
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 = a -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
mime_lenw