--------------------------------------------------------------------------------
-- | Primary types
{-# LANGUAGE DeriveDataTypeable #-}
module Network.WebSockets.Types
    ( Message (..)
    , ControlMessage (..)
    , DataMessage (..)
    , WebSocketsData (..)

    , HandshakeException (..)
    , ConnectionException (..)

    , ConnectionType (..)

    , decodeUtf8Lenient
    , decodeUtf8Strict
    ) where


--------------------------------------------------------------------------------
import           Control.Exception        (Exception (..))
import           Control.Exception        (throw, try)
import qualified Data.ByteString          as B
import qualified Data.ByteString.Lazy     as BL
import qualified Data.Text                as T
import qualified Data.Text.Encoding.Error as TL
import qualified Data.Text.Lazy           as TL
import qualified Data.Text.Lazy.Encoding  as TL
import           Data.Typeable            (Typeable)
import           Data.Word                (Word16)
import           System.IO.Unsafe         (unsafePerformIO)


--------------------------------------------------------------------------------
import           Network.WebSockets.Http


--------------------------------------------------------------------------------
-- | The kind of message a server application typically deals with
data Message
    = ControlMessage ControlMessage
    -- | Reserved bits, actual message
    | DataMessage Bool Bool Bool DataMessage
    deriving (Message -> Message -> Bool
(Message -> Message -> Bool)
-> (Message -> Message -> Bool) -> Eq Message
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Message -> Message -> Bool
$c/= :: Message -> Message -> Bool
== :: Message -> Message -> Bool
$c== :: Message -> Message -> Bool
Eq, Int -> Message -> ShowS
[Message] -> ShowS
Message -> String
(Int -> Message -> ShowS)
-> (Message -> String) -> ([Message] -> ShowS) -> Show Message
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Message] -> ShowS
$cshowList :: [Message] -> ShowS
show :: Message -> String
$cshow :: Message -> String
showsPrec :: Int -> Message -> ShowS
$cshowsPrec :: Int -> Message -> ShowS
Show)


--------------------------------------------------------------------------------
-- | Different control messages
data ControlMessage
    = Close Word16 BL.ByteString
    | Ping BL.ByteString
    | Pong BL.ByteString
    deriving (ControlMessage -> ControlMessage -> Bool
(ControlMessage -> ControlMessage -> Bool)
-> (ControlMessage -> ControlMessage -> Bool) -> Eq ControlMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ControlMessage -> ControlMessage -> Bool
$c/= :: ControlMessage -> ControlMessage -> Bool
== :: ControlMessage -> ControlMessage -> Bool
$c== :: ControlMessage -> ControlMessage -> Bool
Eq, Int -> ControlMessage -> ShowS
[ControlMessage] -> ShowS
ControlMessage -> String
(Int -> ControlMessage -> ShowS)
-> (ControlMessage -> String)
-> ([ControlMessage] -> ShowS)
-> Show ControlMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ControlMessage] -> ShowS
$cshowList :: [ControlMessage] -> ShowS
show :: ControlMessage -> String
$cshow :: ControlMessage -> String
showsPrec :: Int -> ControlMessage -> ShowS
$cshowsPrec :: Int -> ControlMessage -> ShowS
Show)


--------------------------------------------------------------------------------
-- | For an end-user of this library, dealing with 'Frame's would be a bit
-- low-level. This is why define another type on top of it, which represents
-- data for the application layer.
--
-- There are currently two kinds of data messages supported by the WebSockets
-- protocol:
--
-- * Textual UTF-8 encoded data.  This corresponds roughly to sending a String
-- in JavaScript.
--
-- * Binary data.  This corresponds roughly to send an ArrayBuffer in
-- JavaScript.
data DataMessage
    -- | A textual message.  The second field /might/ contain the decoded UTF-8
    -- text for caching reasons.  This field is computed lazily so if it's not
    -- accessed, it should have no performance impact.
    = Text BL.ByteString (Maybe TL.Text)
    -- | A binary message.
    | Binary BL.ByteString
    deriving (DataMessage -> DataMessage -> Bool
(DataMessage -> DataMessage -> Bool)
-> (DataMessage -> DataMessage -> Bool) -> Eq DataMessage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DataMessage -> DataMessage -> Bool
$c/= :: DataMessage -> DataMessage -> Bool
== :: DataMessage -> DataMessage -> Bool
$c== :: DataMessage -> DataMessage -> Bool
Eq, Int -> DataMessage -> ShowS
[DataMessage] -> ShowS
DataMessage -> String
(Int -> DataMessage -> ShowS)
-> (DataMessage -> String)
-> ([DataMessage] -> ShowS)
-> Show DataMessage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DataMessage] -> ShowS
$cshowList :: [DataMessage] -> ShowS
show :: DataMessage -> String
$cshow :: DataMessage -> String
showsPrec :: Int -> DataMessage -> ShowS
$cshowsPrec :: Int -> DataMessage -> ShowS
Show)


--------------------------------------------------------------------------------
-- | In order to have an even more high-level API, we define a typeclass for
-- values the user can receive from and send to the socket. A few warnings
-- apply:
--
-- * Natively, everything is represented as a 'BL.ByteString', so this is the
--   fastest instance
--
-- * You should only use the 'TL.Text' or the 'T.Text' instance when you are
--   sure that the data is UTF-8 encoded (which is the case for 'Text'
--   messages).
--
-- * Messages can be very large. If this is the case, it might be inefficient to
--   use the strict 'B.ByteString' and 'T.Text' instances.
class WebSocketsData a where
    fromDataMessage :: DataMessage -> a

    fromLazyByteString :: BL.ByteString -> a
    toLazyByteString   :: a -> BL.ByteString


--------------------------------------------------------------------------------
instance WebSocketsData BL.ByteString where
    fromDataMessage :: DataMessage -> ByteString
fromDataMessage (Text   ByteString
bl Maybe Text
_) = ByteString
bl
    fromDataMessage (Binary ByteString
bl)   = ByteString
bl

    fromLazyByteString :: ByteString -> ByteString
fromLazyByteString = ByteString -> ByteString
forall a. a -> a
id
    toLazyByteString :: ByteString -> ByteString
toLazyByteString   = ByteString -> ByteString
forall a. a -> a
id


--------------------------------------------------------------------------------
instance WebSocketsData B.ByteString where
    fromDataMessage :: DataMessage -> ByteString
fromDataMessage (Text   ByteString
bl Maybe Text
_) = ByteString -> ByteString
forall a. WebSocketsData a => ByteString -> a
fromLazyByteString ByteString
bl
    fromDataMessage (Binary ByteString
bl)   = ByteString -> ByteString
forall a. WebSocketsData a => ByteString -> a
fromLazyByteString ByteString
bl

    fromLazyByteString :: ByteString -> ByteString
fromLazyByteString = [ByteString] -> ByteString
B.concat ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
BL.toChunks
    toLazyByteString :: ByteString -> ByteString
toLazyByteString   = [ByteString] -> ByteString
BL.fromChunks ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
forall (m :: * -> *) a. Monad m => a -> m a
return


--------------------------------------------------------------------------------
instance WebSocketsData TL.Text where
    fromDataMessage :: DataMessage -> Text
fromDataMessage (Text   ByteString
_  (Just Text
tl)) = Text
tl
    fromDataMessage (Text   ByteString
bl Maybe Text
Nothing)   = ByteString -> Text
forall a. WebSocketsData a => ByteString -> a
fromLazyByteString ByteString
bl
    fromDataMessage (Binary ByteString
bl)           = ByteString -> Text
forall a. WebSocketsData a => ByteString -> a
fromLazyByteString ByteString
bl


    fromLazyByteString :: ByteString -> Text
fromLazyByteString = ByteString -> Text
TL.decodeUtf8
    toLazyByteString :: Text -> ByteString
toLazyByteString   = Text -> ByteString
TL.encodeUtf8


--------------------------------------------------------------------------------
instance WebSocketsData T.Text where
    fromDataMessage :: DataMessage -> Text
fromDataMessage (Text   ByteString
_ (Just Text
tl)) = [Text] -> Text
T.concat (Text -> [Text]
TL.toChunks Text
tl)
    fromDataMessage (Text   ByteString
bl Maybe Text
Nothing)  = ByteString -> Text
forall a. WebSocketsData a => ByteString -> a
fromLazyByteString ByteString
bl
    fromDataMessage (Binary ByteString
bl)          = ByteString -> Text
forall a. WebSocketsData a => ByteString -> a
fromLazyByteString ByteString
bl

    fromLazyByteString :: ByteString -> Text
fromLazyByteString = [Text] -> Text
T.concat ([Text] -> Text) -> (ByteString -> [Text]) -> ByteString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
TL.toChunks (Text -> [Text]) -> (ByteString -> Text) -> ByteString -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
forall a. WebSocketsData a => ByteString -> a
fromLazyByteString
    toLazyByteString :: Text -> ByteString
toLazyByteString   = Text -> ByteString
forall a. WebSocketsData a => a -> ByteString
toLazyByteString (Text -> ByteString) -> (Text -> Text) -> Text -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
TL.fromChunks ([Text] -> Text) -> (Text -> [Text]) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Text]
forall (m :: * -> *) a. Monad m => a -> m a
return


--------------------------------------------------------------------------------
-- | Various exceptions that can occur while receiving or transmitting messages
data ConnectionException
    -- | The peer has requested that the connection be closed, and included
    -- a close code and a reason for closing.  When receiving this exception,
    -- no more messages can be sent.  Also, the server is responsible for
    -- closing the TCP connection once this exception is received.
    --
    -- See <http://tools.ietf.org/html/rfc6455#section-7.4> for a list of close
    -- codes.
    = CloseRequest Word16 BL.ByteString

    -- | The peer unexpectedly closed the connection while we were trying to
    -- receive some data.  This is a violation of the websocket RFC since the
    -- TCP connection should only be closed after sending and receiving close
    -- control messages.
    | ConnectionClosed

    -- | The client sent garbage, i.e. we could not parse the WebSockets stream.
    | ParseException String

    -- | The client sent invalid UTF-8.  Note that this exception will only be
    -- thrown if strict decoding is set in the connection options.
    | UnicodeException String
    deriving (ConnectionException -> ConnectionException -> Bool
(ConnectionException -> ConnectionException -> Bool)
-> (ConnectionException -> ConnectionException -> Bool)
-> Eq ConnectionException
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConnectionException -> ConnectionException -> Bool
$c/= :: ConnectionException -> ConnectionException -> Bool
== :: ConnectionException -> ConnectionException -> Bool
$c== :: ConnectionException -> ConnectionException -> Bool
Eq, Int -> ConnectionException -> ShowS
[ConnectionException] -> ShowS
ConnectionException -> String
(Int -> ConnectionException -> ShowS)
-> (ConnectionException -> String)
-> ([ConnectionException] -> ShowS)
-> Show ConnectionException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConnectionException] -> ShowS
$cshowList :: [ConnectionException] -> ShowS
show :: ConnectionException -> String
$cshow :: ConnectionException -> String
showsPrec :: Int -> ConnectionException -> ShowS
$cshowsPrec :: Int -> ConnectionException -> ShowS
Show, Typeable)


--------------------------------------------------------------------------------
instance Exception ConnectionException


--------------------------------------------------------------------------------
data ConnectionType = ServerConnection | ClientConnection
    deriving (ConnectionType -> ConnectionType -> Bool
(ConnectionType -> ConnectionType -> Bool)
-> (ConnectionType -> ConnectionType -> Bool) -> Eq ConnectionType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ConnectionType -> ConnectionType -> Bool
$c/= :: ConnectionType -> ConnectionType -> Bool
== :: ConnectionType -> ConnectionType -> Bool
$c== :: ConnectionType -> ConnectionType -> Bool
Eq, Eq ConnectionType
Eq ConnectionType
-> (ConnectionType -> ConnectionType -> Ordering)
-> (ConnectionType -> ConnectionType -> Bool)
-> (ConnectionType -> ConnectionType -> Bool)
-> (ConnectionType -> ConnectionType -> Bool)
-> (ConnectionType -> ConnectionType -> Bool)
-> (ConnectionType -> ConnectionType -> ConnectionType)
-> (ConnectionType -> ConnectionType -> ConnectionType)
-> Ord ConnectionType
ConnectionType -> ConnectionType -> Bool
ConnectionType -> ConnectionType -> Ordering
ConnectionType -> ConnectionType -> ConnectionType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ConnectionType -> ConnectionType -> ConnectionType
$cmin :: ConnectionType -> ConnectionType -> ConnectionType
max :: ConnectionType -> ConnectionType -> ConnectionType
$cmax :: ConnectionType -> ConnectionType -> ConnectionType
>= :: ConnectionType -> ConnectionType -> Bool
$c>= :: ConnectionType -> ConnectionType -> Bool
> :: ConnectionType -> ConnectionType -> Bool
$c> :: ConnectionType -> ConnectionType -> Bool
<= :: ConnectionType -> ConnectionType -> Bool
$c<= :: ConnectionType -> ConnectionType -> Bool
< :: ConnectionType -> ConnectionType -> Bool
$c< :: ConnectionType -> ConnectionType -> Bool
compare :: ConnectionType -> ConnectionType -> Ordering
$ccompare :: ConnectionType -> ConnectionType -> Ordering
$cp1Ord :: Eq ConnectionType
Ord, Int -> ConnectionType -> ShowS
[ConnectionType] -> ShowS
ConnectionType -> String
(Int -> ConnectionType -> ShowS)
-> (ConnectionType -> String)
-> ([ConnectionType] -> ShowS)
-> Show ConnectionType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ConnectionType] -> ShowS
$cshowList :: [ConnectionType] -> ShowS
show :: ConnectionType -> String
$cshow :: ConnectionType -> String
showsPrec :: Int -> ConnectionType -> ShowS
$cshowsPrec :: Int -> ConnectionType -> ShowS
Show)


--------------------------------------------------------------------------------
-- | Replace an invalid input byte with the Unicode replacement character
-- U+FFFD.
decodeUtf8Lenient :: BL.ByteString -> TL.Text
decodeUtf8Lenient :: ByteString -> Text
decodeUtf8Lenient = OnDecodeError -> ByteString -> Text
TL.decodeUtf8With OnDecodeError
TL.lenientDecode


--------------------------------------------------------------------------------
-- | Throw an error if there is an invalid input byte.
decodeUtf8Strict :: BL.ByteString -> Either ConnectionException TL.Text
decodeUtf8Strict :: ByteString -> Either ConnectionException Text
decodeUtf8Strict ByteString
bl = IO (Either ConnectionException Text)
-> Either ConnectionException Text
forall a. IO a -> a
unsafePerformIO (IO (Either ConnectionException Text)
 -> Either ConnectionException Text)
-> IO (Either ConnectionException Text)
-> Either ConnectionException Text
forall a b. (a -> b) -> a -> b
$ IO Text -> IO (Either ConnectionException Text)
forall e a. Exception e => IO a -> IO (Either e a)
try (IO Text -> IO (Either ConnectionException Text))
-> IO Text -> IO (Either ConnectionException Text)
forall a b. (a -> b) -> a -> b
$
    let txt :: Text
txt = OnDecodeError -> ByteString -> Text
TL.decodeUtf8With (\String
err Maybe Word8
_ -> ConnectionException -> Maybe Char
forall a e. Exception e => e -> a
throw (String -> ConnectionException
UnicodeException String
err)) ByteString
bl in
    Text -> Int64
TL.length Text
txt Int64 -> IO Text -> IO Text
`seq` Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
txt