module Network.WebSockets.Handshake.Http
( Headers
, RequestHttpPart (..)
, Request (..)
, Response (..)
, HandshakeError (..)
, getSecWebSocketVersion
, decodeRequest
, encodeResponse
, response101
, response400
) where
import Data.Dynamic (Typeable)
import Data.Monoid (mappend, mconcat)
import Control.Applicative (pure, (<$>), (<*>), (*>), (<*))
import Control.Exception (Exception)
import Control.Monad.Error (Error (..))
import Data.ByteString.Char8 ()
import Data.ByteString.Internal (c2w)
import qualified Data.Attoparsec as A
import qualified Blaze.ByteString.Builder as Builder
import qualified Blaze.ByteString.Builder.Char.Utf8 as Builder
import qualified Data.ByteString as B
import qualified Data.CaseInsensitive as CI
type Headers = [(CI.CI B.ByteString, B.ByteString)]
data RequestHttpPart = RequestHttpPart
{ requestHttpPath :: !B.ByteString
, requestHttpHeaders :: Headers
, requestHttpSecure :: Bool
} deriving (Eq, Show)
data Request = Request
{ requestPath :: !B.ByteString
, requestHeaders :: Headers
, requestResponse :: Response
}
deriving (Show)
data Response = Response
{ responseCode :: !Int
, responseMessage :: !B.ByteString
, responseHeaders :: Headers
, responseBody :: B.ByteString
} deriving (Show)
data HandshakeError
= NotSupported
| MalformedRequest RequestHttpPart String
| RequestRejected Request String
| OtherHandshakeError String
deriving (Show, Typeable)
instance Error HandshakeError where
strMsg = OtherHandshakeError
instance Exception HandshakeError
getSecWebSocketVersion :: RequestHttpPart -> Maybe B.ByteString
getSecWebSocketVersion p = lookup "Sec-WebSocket-Version" (requestHttpHeaders p)
decodeRequest :: Bool -> A.Parser RequestHttpPart
decodeRequest isSecure = RequestHttpPart
<$> requestLine
<*> A.manyTill header 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
header = (,)
<$> (CI.mk <$> A.takeWhile1 (/= c2w ':'))
<* A.string ": "
<*> A.takeWhile1 (/= c2w '\r')
<* newline
encodeResponse :: Response -> Builder.Builder
encodeResponse (Response code msg headers body) =
Builder.copyByteString "HTTP/1.1 " `mappend`
Builder.fromString (show code) `mappend`
Builder.fromChar ' ' `mappend`
Builder.fromByteString msg `mappend`
Builder.fromByteString "\r\n" `mappend`
mconcat (map header headers) `mappend`
Builder.copyByteString "\r\n" `mappend`
Builder.copyByteString body
where
header (k, v) = mconcat $ map Builder.copyByteString
[CI.original k, ": ", v, "\r\n"]
response101 :: Headers -> B.ByteString -> Response
response101 headers body = Response 101 "WebSocket Protocol Handshake"
(("Upgrade", "WebSocket") : ("Connection", "Upgrade") : headers)
body
response400 :: Headers -> Response
response400 headers = Response 400 "Bad Request" headers ""