{-# 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
type = [(CI.CI ByteString, ByteString)]
data RequestHead = RequestHead
{ RequestHead -> ByteString
requestPath :: !B.ByteString
, :: 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)
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)
data ResponseHead = ResponseHead
{ ResponseHead -> Int
responseCode :: !Int
, ResponseHead -> ByteString
responseMessage :: !B.ByteString
, :: 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)
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)
data HandshakeException
= NotSupported
| MalformedRequest RequestHead String
| MalformedResponse ResponseHead String
| RequestRejected RequestHead ResponseHead
| ConnectionTimeout
| 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
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
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
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))
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)
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
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
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)
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)
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
' ')
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)
= (,)
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"