module Network.WebSockets.Handshake.Http
( Headers
, RequestHttpPart (..)
, Request (..)
, Response (..)
, HandshakeError (..)
, decodeRequest
, encodeResponse
, response101
, response400
) where
import Data.Dynamic (Typeable)
import Data.Monoid (mappend, mconcat)
import Control.Applicative ((<$>), (<*>), (*>), (<*))
import Control.Exception (Exception)
import Control.Monad.Error (Error (..))
import Data.Attoparsec (string, takeWhile1, word8)
import Data.Attoparsec.Combinator (manyTill)
import Data.ByteString.Char8 ()
import Data.ByteString.Internal (c2w)
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
import Network.WebSockets.Types
type Headers = [(CI.CI B.ByteString, B.ByteString)]
data RequestHttpPart = RequestHttpPart
{ requestHttpPath :: !B.ByteString
, requestHttpHeaders :: Headers
} 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
decodeRequest :: Decoder p RequestHttpPart
decodeRequest = RequestHttpPart
<$> requestLine
<*> manyTill header newline
where
space = word8 (c2w ' ')
newline = string "\r\n"
requestLine = string "GET" *> space *> takeWhile1 (/= c2w ' ')
<* space
<* string "HTTP/1.1" <* newline
header = (,)
<$> (CI.mk <$> takeWhile1 (/= c2w ':'))
<* string ": "
<*> takeWhile1 (/= c2w '\r')
<* newline
encodeResponse :: Encoder p Response
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 ""