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 Headers = [(CI.CI ByteString, ByteString)]
data RequestHead = RequestHead
{ requestPath :: !B.ByteString
, requestHeaders :: Headers
, requestSecure :: Bool
} deriving (Show)
data Request = Request RequestHead B.ByteString
deriving (Show)
data ResponseHead = ResponseHead
{ responseCode :: !Int
, responseMessage :: !B.ByteString
, responseHeaders :: Headers
} deriving (Show)
data Response = Response ResponseHead B.ByteString
deriving (Show)
data HandshakeException
= NotSupported
| MalformedRequest RequestHead String
| MalformedResponse ResponseHead String
| RequestRejected Request String
| OtherHandshakeException String
deriving (Show, Typeable)
instance Exception HandshakeException
encodeRequestHead :: RequestHead -> Builder.Builder
encodeRequestHead (RequestHead path headers _) =
Builder.byteStringCopy "GET " `mappend`
Builder.byteStringCopy path `mappend`
Builder.byteStringCopy " HTTP/1.1" `mappend`
Builder.byteString "\r\n" `mappend`
mconcat (map header headers) `mappend`
Builder.byteStringCopy "\r\n"
where
header (k, v) = mconcat $ map Builder.byteStringCopy
[CI.original k, ": ", v, "\r\n"]
encodeRequest :: Request -> Builder.Builder
encodeRequest (Request head' body) =
encodeRequestHead head' `mappend` Builder.byteStringCopy body
decodeRequestHead :: Bool -> A.Parser RequestHead
decodeRequestHead isSecure = RequestHead
<$> requestLine
<*> A.manyTill decodeHeaderLine newline
<*> pure isSecure
where
space = A.word8 (c2w ' ')
newline = A.string "\r\n"
requestLine = A.string "GET" *> space *> A.takeWhile1 (/= c2w ' ')
<* space
<* A.string "HTTP/1.1" <* newline
encodeResponseHead :: ResponseHead -> Builder.Builder
encodeResponseHead (ResponseHead code msg headers) =
Builder.byteStringCopy "HTTP/1.1 " `mappend`
Builder.stringUtf8 (show code) `mappend`
Builder.charUtf8 ' ' `mappend`
Builder.byteString msg `mappend`
Builder.byteString "\r\n" `mappend`
mconcat (map header headers) `mappend`
Builder.byteStringCopy "\r\n"
where
header (k, v) = mconcat $ map Builder.byteStringCopy
[CI.original k, ": ", v, "\r\n"]
encodeResponse :: Response -> Builder.Builder
encodeResponse (Response head' body) =
encodeResponseHead head' `mappend` Builder.byteStringCopy body
response101 :: Headers -> B.ByteString -> Response
response101 headers = Response
(ResponseHead 101 "WebSocket Protocol Handshake"
(("Upgrade", "websocket") : ("Connection", "Upgrade") : headers))
response400 :: Headers -> B.ByteString -> Response
response400 headers = Response (ResponseHead 400 "Bad Request" headers)
decodeResponseHead :: A.Parser ResponseHead
decodeResponseHead = ResponseHead
<$> fmap (read . BC.unpack) code
<*> message
<*> A.manyTill decodeHeaderLine newline
where
space = A.word8 (c2w ' ')
newline = A.string "\r\n"
code = A.string "HTTP/1.1" *> space *> A.takeWhile1 (/= c2w ' ') <* space
message = A.takeWhile (/= c2w '\r') <* newline
decodeResponse :: A.Parser Response
decodeResponse = Response <$> decodeResponseHead <*> A.takeByteString
getRequestHeader :: RequestHead
-> CI.CI ByteString
-> Either HandshakeException ByteString
getRequestHeader rq key = case lookup key (requestHeaders rq) of
Just t -> Right t
Nothing -> Left $ MalformedRequest rq $
"Header missing: " ++ BC.unpack (CI.original key)
getResponseHeader :: ResponseHead
-> CI.CI ByteString
-> Either HandshakeException ByteString
getResponseHeader rsp key = case lookup key (responseHeaders rsp) of
Just t -> Right t
Nothing -> Left $ MalformedResponse rsp $
"Header missing: " ++ BC.unpack (CI.original key)
getRequestSecWebSocketVersion :: RequestHead -> Maybe B.ByteString
getRequestSecWebSocketVersion p =
lookup "Sec-WebSocket-Version" (requestHeaders p)
getRequestSubprotocols :: RequestHead -> [B.ByteString]
getRequestSubprotocols rh = maybe [] parse mproto
where
mproto = lookup "Sec-WebSocket-Protocol" $ requestHeaders rh
parse = filter (not . B.null) . BC.splitWith (\o -> o == ',' || o == ' ')
getRequestSecWebSocketExtensions
:: RequestHead -> Either HandshakeException Extensions.ExtensionDescriptions
getRequestSecWebSocketExtensions rq =
case lookup "Sec-WebSocket-Extensions" (requestHeaders rq) of
Nothing -> Right []
Just ext -> case Extensions.parseExtensionDescriptions ext of
Right x -> Right x
Left err -> Left $ MalformedRequest rq $
"Malformed Sec-WebSockets-Extensions: " ++ err
decodeHeaderLine :: A.Parser (CI.CI ByteString, ByteString)
decodeHeaderLine = (,)
<$> (CI.mk <$> A.takeWhile1 (/= c2w ':'))
<* A.word8 (c2w ':')
<* A.option (c2w ' ') (A.word8 (c2w ' '))
<*> A.takeWhile (/= c2w '\r')
<* A.string "\r\n"