--------------------------------------------------------------------------------
-- | Module dealing with HTTP: request data types, encoding and decoding...
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings  #-}
module Network.WebSockets.Http
    ( Headers
    , RequestHead (..)
    , Request (..)
    , ResponseHead (..)
    , Response (..)
    , HandshakeException (..)

    , encodeRequestHead
    , encodeRequest
    , decodeRequestHead

    , encodeResponseHead
    , encodeResponse
    , decodeResponseHead
    , decodeResponse

    , response101
    , response400

    , getRequestHeader
    , getResponseHeader
    , getRequestSecWebSocketVersion
    , getRequestSubprotocols
    , getRequestSecWebSocketExtensions
    ) where


--------------------------------------------------------------------------------
import qualified Data.ByteString.Builder                   as Builder
import qualified Data.ByteString.Builder.Extra             as Builder
import           Control.Applicative                       (pure, (*>), (<$>),
                                                            (<*), (<*>))
import           Control.Exception                         (Exception)
import qualified Data.Attoparsec.ByteString                as A
import           Data.ByteString                           (ByteString)
import qualified Data.ByteString                           as B
import           Data.ByteString.Char8                     ()
import qualified Data.ByteString.Char8                     as BC
import           Data.ByteString.Internal                  (c2w)
import qualified Data.CaseInsensitive                      as CI
import           Data.Dynamic                              (Typeable)
import           Data.Monoid                               (mappend, mconcat)
import qualified Network.WebSockets.Extensions.Description as Extensions


--------------------------------------------------------------------------------
-- | Request headers
type Headers = [(CI.CI ByteString, ByteString)]


--------------------------------------------------------------------------------
-- | An HTTP request. The request body is not yet read.
data RequestHead = RequestHead
    { RequestHead -> ByteString
requestPath    :: !B.ByteString
    , RequestHead -> Headers
requestHeaders :: Headers
    , RequestHead -> Bool
requestSecure  :: Bool
    } deriving (Int -> RequestHead -> ShowS
[RequestHead] -> ShowS
RequestHead -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RequestHead] -> ShowS
$cshowList :: [RequestHead] -> ShowS
show :: RequestHead -> [Char]
$cshow :: RequestHead -> [Char]
showsPrec :: Int -> RequestHead -> ShowS
$cshowsPrec :: Int -> RequestHead -> ShowS
Show)


--------------------------------------------------------------------------------
-- | A request with a body
data Request = Request RequestHead B.ByteString
    deriving (Int -> Request -> ShowS
[Request] -> ShowS
Request -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Request] -> ShowS
$cshowList :: [Request] -> ShowS
show :: Request -> [Char]
$cshow :: Request -> [Char]
showsPrec :: Int -> Request -> ShowS
$cshowsPrec :: Int -> Request -> ShowS
Show)


--------------------------------------------------------------------------------
-- | HTTP response, without body.
data ResponseHead = ResponseHead
    { ResponseHead -> Int
responseCode    :: !Int
    , ResponseHead -> ByteString
responseMessage :: !B.ByteString
    , ResponseHead -> Headers
responseHeaders :: Headers
    } deriving (Int -> ResponseHead -> ShowS
[ResponseHead] -> ShowS
ResponseHead -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ResponseHead] -> ShowS
$cshowList :: [ResponseHead] -> ShowS
show :: ResponseHead -> [Char]
$cshow :: ResponseHead -> [Char]
showsPrec :: Int -> ResponseHead -> ShowS
$cshowsPrec :: Int -> ResponseHead -> ShowS
Show)


--------------------------------------------------------------------------------
-- | A response including a body
data Response = Response ResponseHead B.ByteString
    deriving (Int -> Response -> ShowS
[Response] -> ShowS
Response -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Response] -> ShowS
$cshowList :: [Response] -> ShowS
show :: Response -> [Char]
$cshow :: Response -> [Char]
showsPrec :: Int -> Response -> ShowS
$cshowsPrec :: Int -> Response -> ShowS
Show)


--------------------------------------------------------------------------------
-- | Error in case of failed handshake. Will be thrown as an 'Exception'.
--
-- TODO: This should probably be in the Handshake module, and is solely here to
-- prevent a cyclic dependency.
data HandshakeException
    -- | We don't have a match for the protocol requested by the client.
    -- todo: version parameter
    = NotSupported
    -- | The request was somehow invalid (missing headers or wrong security
    -- token)
    | MalformedRequest RequestHead String
    -- | The servers response was somehow invalid (missing headers or wrong
    -- security token)
    | MalformedResponse ResponseHead String
    -- | The request was well-formed, but the library user rejected it.
    -- (e.g. "unknown path")
    | RequestRejected RequestHead ResponseHead
    -- | The connection timed out
    | ConnectionTimeout
    -- | for example "EOF came too early" (which is actually a parse error)
    -- or for your own errors. (like "unknown path"?)
    | OtherHandshakeException String
    deriving (Int -> HandshakeException -> ShowS
[HandshakeException] -> ShowS
HandshakeException -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [HandshakeException] -> ShowS
$cshowList :: [HandshakeException] -> ShowS
show :: HandshakeException -> [Char]
$cshow :: HandshakeException -> [Char]
showsPrec :: Int -> HandshakeException -> ShowS
$cshowsPrec :: Int -> HandshakeException -> ShowS
Show, Typeable)


--------------------------------------------------------------------------------
instance Exception HandshakeException


--------------------------------------------------------------------------------
encodeRequestHead :: RequestHead -> Builder.Builder
encodeRequestHead :: RequestHead -> Builder
encodeRequestHead (RequestHead ByteString
path Headers
headers Bool
_) =
    ByteString -> Builder
Builder.byteStringCopy ByteString
"GET "      forall a. Monoid a => a -> a -> a
`mappend`
    ByteString -> Builder
Builder.byteStringCopy ByteString
path        forall a. Monoid a => a -> a -> a
`mappend`
    ByteString -> Builder
Builder.byteStringCopy ByteString
" HTTP/1.1" forall a. Monoid a => a -> a -> a
`mappend`
    ByteString -> Builder
Builder.byteString ByteString
"\r\n"          forall a. Monoid a => a -> a -> a
`mappend`
    forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (CI ByteString, ByteString) -> Builder
header Headers
headers)       forall a. Monoid a => a -> a -> a
`mappend`
    ByteString -> Builder
Builder.byteStringCopy ByteString
"\r\n"
  where
    header :: (CI ByteString, ByteString) -> Builder
header (CI ByteString
k, ByteString
v) = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Builder
Builder.byteStringCopy
        [forall s. CI s -> s
CI.original CI ByteString
k, ByteString
": ", ByteString
v, ByteString
"\r\n"]


--------------------------------------------------------------------------------
encodeRequest :: Request -> Builder.Builder
encodeRequest :: Request -> Builder
encodeRequest (Request RequestHead
head' ByteString
body) =
    RequestHead -> Builder
encodeRequestHead RequestHead
head' forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
Builder.byteStringCopy ByteString
body


--------------------------------------------------------------------------------
-- | Parse an initial request
decodeRequestHead :: Bool -> A.Parser RequestHead
decodeRequestHead :: Bool -> Parser RequestHead
decodeRequestHead Bool
isSecure = ByteString -> Headers -> Bool -> RequestHead
RequestHead
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString ByteString
requestLine
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
A.manyTill Parser (CI ByteString, ByteString)
decodeHeaderLine Parser ByteString ByteString
newline
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
isSecure
  where
    space :: Parser Word8
space   = Word8 -> Parser Word8
A.word8 (Char -> Word8
c2w Char
' ')
    newline :: Parser ByteString ByteString
newline = ByteString -> Parser ByteString ByteString
A.string ByteString
"\r\n"

    requestLine :: Parser ByteString ByteString
requestLine = ByteString -> Parser ByteString ByteString
A.string ByteString
"GET" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Word8
space forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char -> Word8
c2w Char
' ')
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Word8
space
        forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ByteString -> Parser ByteString ByteString
A.string ByteString
"HTTP/1.1" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ByteString
newline


--------------------------------------------------------------------------------
-- | Encode an HTTP upgrade response
encodeResponseHead :: ResponseHead -> Builder.Builder
encodeResponseHead :: ResponseHead -> Builder
encodeResponseHead (ResponseHead Int
code ByteString
msg Headers
headers) =
    ByteString -> Builder
Builder.byteStringCopy ByteString
"HTTP/1.1 " forall a. Monoid a => a -> a -> a
`mappend`
    [Char] -> Builder
Builder.stringUtf8 (forall a. Show a => a -> [Char]
show Int
code)     forall a. Monoid a => a -> a -> a
`mappend`
    Char -> Builder
Builder.charUtf8 Char
' '               forall a. Monoid a => a -> a -> a
`mappend`
    ByteString -> Builder
Builder.byteString ByteString
msg             forall a. Monoid a => a -> a -> a
`mappend`
    ByteString -> Builder
Builder.byteString ByteString
"\r\n"          forall a. Monoid a => a -> a -> a
`mappend`
    forall a. Monoid a => [a] -> a
mconcat (forall a b. (a -> b) -> [a] -> [b]
map (CI ByteString, ByteString) -> Builder
header Headers
headers)       forall a. Monoid a => a -> a -> a
`mappend`
    ByteString -> Builder
Builder.byteStringCopy ByteString
"\r\n"
  where
    header :: (CI ByteString, ByteString) -> Builder
header (CI ByteString
k, ByteString
v) = forall a. Monoid a => [a] -> a
mconcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map ByteString -> Builder
Builder.byteStringCopy
        [forall s. CI s -> s
CI.original CI ByteString
k, ByteString
": ", ByteString
v, ByteString
"\r\n"]


--------------------------------------------------------------------------------
encodeResponse :: Response -> Builder.Builder
encodeResponse :: Response -> Builder
encodeResponse (Response ResponseHead
head' ByteString
body) =
    ResponseHead -> Builder
encodeResponseHead ResponseHead
head' forall a. Monoid a => a -> a -> a
`mappend` ByteString -> Builder
Builder.byteStringCopy ByteString
body


--------------------------------------------------------------------------------
-- | An upgrade response
response101 :: Headers -> B.ByteString -> Response
response101 :: Headers -> ByteString -> Response
response101 Headers
headers = ResponseHead -> ByteString -> Response
Response
    (Int -> ByteString -> Headers -> ResponseHead
ResponseHead Int
101 ByteString
"WebSocket Protocol Handshake"
        ((CI ByteString
"Upgrade", ByteString
"websocket") forall a. a -> [a] -> [a]
: (CI ByteString
"Connection", ByteString
"Upgrade") forall a. a -> [a] -> [a]
: Headers
headers))


--------------------------------------------------------------------------------
-- | Bad request
response400 :: Headers -> B.ByteString -> Response
response400 :: Headers -> ByteString -> Response
response400 Headers
headers = ResponseHead -> ByteString -> Response
Response (Int -> ByteString -> Headers -> ResponseHead
ResponseHead Int
400 ByteString
"Bad Request" Headers
headers)


--------------------------------------------------------------------------------
-- | HTTP response parser
decodeResponseHead :: A.Parser ResponseHead
decodeResponseHead :: Parser ResponseHead
decodeResponseHead = Int -> ByteString -> Headers -> ResponseHead
ResponseHead
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Read a => [Char] -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [Char]
BC.unpack) Parser ByteString ByteString
code
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString ByteString
message
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
A.manyTill Parser (CI ByteString, ByteString)
decodeHeaderLine Parser ByteString ByteString
newline
  where
    space :: Parser Word8
space = Word8 -> Parser Word8
A.word8 (Char -> Word8
c2w Char
' ')
    newline :: Parser ByteString ByteString
newline = ByteString -> Parser ByteString ByteString
A.string ByteString
"\r\n"

    code :: Parser ByteString ByteString
code    = ByteString -> Parser ByteString ByteString
A.string ByteString
"HTTP/1.1" forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser Word8
space forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile1 Word8 -> Bool
digit forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser Word8
space
    digit :: Word8 -> Bool
digit   = \Word8
x -> Word8
x forall a. Ord a => a -> a -> Bool
>= Char -> Word8
c2w Char
'0' Bool -> Bool -> Bool
&& Word8
x forall a. Ord a => a -> a -> Bool
<= Char -> Word8
c2w Char
'9'
    message :: Parser ByteString ByteString
message = (Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char -> Word8
c2w Char
'\r') forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ByteString ByteString
newline


--------------------------------------------------------------------------------
decodeResponse :: A.Parser Response
decodeResponse :: Parser Response
decodeResponse = ResponseHead -> ByteString -> Response
Response forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ResponseHead
decodeResponseHead forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString ByteString
A.takeByteString


--------------------------------------------------------------------------------
getRequestHeader :: RequestHead
                 -> CI.CI ByteString
                 -> Either HandshakeException ByteString
getRequestHeader :: RequestHead
-> CI ByteString -> Either HandshakeException ByteString
getRequestHeader RequestHead
rq CI ByteString
key = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
key (RequestHead -> Headers
requestHeaders RequestHead
rq) of
    Just ByteString
t  -> forall a b. b -> Either a b
Right ByteString
t
    Maybe ByteString
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ RequestHead -> [Char] -> HandshakeException
MalformedRequest RequestHead
rq forall a b. (a -> b) -> a -> b
$
        [Char]
"Header missing: " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BC.unpack (forall s. CI s -> s
CI.original CI ByteString
key)


--------------------------------------------------------------------------------
getResponseHeader :: ResponseHead
                  -> CI.CI ByteString
                  -> Either HandshakeException ByteString
getResponseHeader :: ResponseHead
-> CI ByteString -> Either HandshakeException ByteString
getResponseHeader ResponseHead
rsp CI ByteString
key = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
key (ResponseHead -> Headers
responseHeaders ResponseHead
rsp) of
    Just ByteString
t  -> forall a b. b -> Either a b
Right ByteString
t
    Maybe ByteString
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ ResponseHead -> [Char] -> HandshakeException
MalformedResponse ResponseHead
rsp forall a b. (a -> b) -> a -> b
$
        [Char]
"Header missing: " forall a. [a] -> [a] -> [a]
++ ByteString -> [Char]
BC.unpack (forall s. CI s -> s
CI.original CI ByteString
key)


--------------------------------------------------------------------------------
-- | Get the @Sec-WebSocket-Version@ header
getRequestSecWebSocketVersion :: RequestHead -> Maybe B.ByteString
getRequestSecWebSocketVersion :: RequestHead -> Maybe ByteString
getRequestSecWebSocketVersion RequestHead
p =
    forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"Sec-WebSocket-Version" (RequestHead -> Headers
requestHeaders RequestHead
p)


--------------------------------------------------------------------------------
-- | List of subprotocols specified by the client, in order of preference.
-- If the client did not specify a list of subprotocols, this will be the
-- empty list.
getRequestSubprotocols :: RequestHead -> [B.ByteString]
getRequestSubprotocols :: RequestHead -> [ByteString]
getRequestSubprotocols RequestHead
rh = forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ByteString -> [ByteString]
parse Maybe ByteString
mproto
    where
        mproto :: Maybe ByteString
mproto = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"Sec-WebSocket-Protocol" forall a b. (a -> b) -> a -> b
$ RequestHead -> Headers
requestHeaders RequestHead
rh
        parse :: ByteString -> [ByteString]
parse = forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Bool
B.null) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> ByteString -> [ByteString]
BC.splitWith (\Char
o -> Char
o forall a. Eq a => a -> a -> Bool
== Char
',' Bool -> Bool -> Bool
|| Char
o forall a. Eq a => a -> a -> Bool
== Char
' ')


--------------------------------------------------------------------------------
-- | Get the @Sec-WebSocket-Extensions@ header
getRequestSecWebSocketExtensions
    :: RequestHead -> Either HandshakeException Extensions.ExtensionDescriptions
getRequestSecWebSocketExtensions :: RequestHead -> Either HandshakeException ExtensionDescriptions
getRequestSecWebSocketExtensions RequestHead
rq =
    case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup CI ByteString
"Sec-WebSocket-Extensions" (RequestHead -> Headers
requestHeaders RequestHead
rq) of
        Maybe ByteString
Nothing -> forall a b. b -> Either a b
Right []
        Just ByteString
ext -> case ByteString -> Either [Char] ExtensionDescriptions
Extensions.parseExtensionDescriptions ByteString
ext of
            Right ExtensionDescriptions
x  -> forall a b. b -> Either a b
Right ExtensionDescriptions
x
            Left [Char]
err -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ RequestHead -> [Char] -> HandshakeException
MalformedRequest RequestHead
rq forall a b. (a -> b) -> a -> b
$
                [Char]
"Malformed Sec-WebSockets-Extensions: " forall a. [a] -> [a] -> [a]
++ [Char]
err


--------------------------------------------------------------------------------
decodeHeaderLine :: A.Parser (CI.CI ByteString, ByteString)
decodeHeaderLine :: Parser (CI ByteString, ByteString)
decodeHeaderLine = (,)
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall s. FoldCase s => s -> CI s
CI.mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile1 (forall a. Eq a => a -> a -> Bool
/= Char -> Word8
c2w Char
':'))
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  Word8 -> Parser Word8
A.word8 (Char -> Word8
c2w Char
':')
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  forall (f :: * -> *) a. Alternative f => a -> f a -> f a
A.option (Char -> Word8
c2w Char
' ') (Word8 -> Parser Word8
A.word8 (Char -> Word8
c2w Char
' '))
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Word8 -> Bool) -> Parser ByteString ByteString
A.takeWhile (forall a. Eq a => a -> a -> Bool
/= Char -> Word8
c2w Char
'\r')
    forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<*  ByteString -> Parser ByteString ByteString
A.string ByteString
"\r\n"