--------------------------------------------------------------------------------
module Network.WebSockets.Extensions.StrictUnicode
    ( strictUnicode
    ) where


--------------------------------------------------------------------------------
import           Control.Exception             (throwIO)
import qualified Data.ByteString.Lazy          as BL
import           Network.WebSockets.Extensions
import           Network.WebSockets.Types


--------------------------------------------------------------------------------
strictUnicode :: Extension
strictUnicode :: Extension
strictUnicode = Extension :: Headers
-> (IO (Maybe Message) -> IO (IO (Maybe Message)))
-> (([Message] -> IO ()) -> IO ([Message] -> IO ()))
-> Extension
Extension
    { extHeaders :: Headers
extHeaders = []
    , extParse :: IO (Maybe Message) -> IO (IO (Maybe Message))
extParse   = \IO (Maybe Message)
parseRaw -> IO (Maybe Message) -> IO (IO (Maybe Message))
forall (m :: * -> *) a. Monad m => a -> m a
return (IO (Maybe Message)
parseRaw IO (Maybe Message)
-> (Maybe Message -> IO (Maybe Message)) -> IO (Maybe Message)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Maybe Message -> IO (Maybe Message)
strictParse)
    , extWrite :: ([Message] -> IO ()) -> IO ([Message] -> IO ())
extWrite   = ([Message] -> IO ()) -> IO ([Message] -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return
    }


--------------------------------------------------------------------------------
strictParse :: Maybe Message -> IO (Maybe Message)
strictParse :: Maybe Message -> IO (Maybe Message)
strictParse Maybe Message
Nothing = Maybe Message -> IO (Maybe Message)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Message
forall a. Maybe a
Nothing
strictParse (Just (DataMessage Bool
rsv1 Bool
rsv2 Bool
rsv3 (Text ByteString
bl Maybe Text
_))) =
    case ByteString -> Either ConnectionException Text
decodeUtf8Strict ByteString
bl of
        Left ConnectionException
err   -> ConnectionException -> IO (Maybe Message)
forall e a. Exception e => e -> IO a
throwIO ConnectionException
err
        Right Text
txt ->
            Maybe Message -> IO (Maybe Message)
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Maybe Message
forall a. a -> Maybe a
Just (Bool -> Bool -> Bool -> DataMessage -> Message
DataMessage Bool
rsv1 Bool
rsv2 Bool
rsv3 (ByteString -> Maybe Text -> DataMessage
Text ByteString
bl (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
txt))))
strictParse (Just msg :: Message
msg@(ControlMessage (Close Word16
_ ByteString
bl))) =
    -- If there is a body, the first two bytes of the body MUST be a 2-byte
    -- unsigned integer (in network byte order) representing a status code with
    -- value /code/ defined in Section 7.4.  Following the 2-byte integer, the
    -- body MAY contain UTF-8-encoded data with value /reason/, the
    -- interpretation of which is not defined by this specification.
    case ByteString -> Either ConnectionException Text
decodeUtf8Strict (Int64 -> ByteString -> ByteString
BL.drop Int64
2 ByteString
bl) of
        Left ConnectionException
err -> ConnectionException -> IO (Maybe Message)
forall e a. Exception e => e -> IO a
throwIO ConnectionException
err
        Right Text
_  -> Maybe Message -> IO (Maybe Message)
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Maybe Message
forall a. a -> Maybe a
Just Message
msg)
strictParse (Just Message
msg) = Maybe Message -> IO (Maybe Message)
forall (m :: * -> *) a. Monad m => a -> m a
return (Message -> Maybe Message
forall a. a -> Maybe a
Just Message
msg)