module Network.Http.Types (
Request(..),
EntityBody(..),
ExpectMode(..),
Response(..),
StatusCode,
TransferEncoding(..),
ContentEncoding(..),
getStatusCode,
getStatusMessage,
getHeader,
Method(..),
Headers,
emptyHeaders,
updateHeader,
removeHeader,
buildHeaders,
lookupHeader,
HttpParseException(..),
composeRequestBytes,
composeResponseBytes
) where
import Prelude hiding (lookup)
import Blaze.ByteString.Builder (Builder)
import qualified Blaze.ByteString.Builder as Builder (copyByteString,
copyByteString,
fromByteString,
fromByteString,
toByteString)
import qualified Blaze.ByteString.Builder.Char8 as Builder (fromChar,
fromShow,
fromString)
import Control.Exception (Exception)
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as S
import Data.CaseInsensitive (CI, mk, original)
import Data.HashMap.Strict (HashMap, delete, empty, foldrWithKey, insert,
insertWith, lookup)
import Data.List (foldl')
import Data.Monoid (mconcat, mempty)
import Data.Typeable (Typeable)
data Method
= GET
| HEAD
| POST
| PUT
| DELETE
| TRACE
| OPTIONS
| CONNECT
| PATCH
| Method ByteString
deriving (Show, Read, Ord)
instance Eq Method where
GET == GET = True
HEAD == HEAD = True
POST == POST = True
PUT == PUT = True
DELETE == DELETE = True
TRACE == TRACE = True
OPTIONS == OPTIONS = True
CONNECT == CONNECT = True
PATCH == PATCH = True
GET == Method "GET" = True
HEAD == Method "HEAD" = True
POST == Method "POST" = True
PUT == Method "PUT" = True
DELETE == Method "DELETE" = True
TRACE == Method "TRACE" = True
OPTIONS == Method "OPTIONS" = True
CONNECT == Method "CONNECT" = True
PATCH == Method "PATCH" = True
Method a == Method b = a == b
m@(Method _) == other = other == m
_ == _ = False
data Request
= Request {
qMethod :: !Method,
qHost :: Maybe ByteString,
qPath :: !ByteString,
qBody :: !EntityBody,
qExpect :: !ExpectMode,
qHeaders :: !Headers
}
instance Show Request where
show q =
S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ composeRequestBytes q "<default>"
data EntityBody = Empty | Chunking | Static Int
data ExpectMode = Normal | Continue
composeRequestBytes :: Request -> ByteString -> Builder
composeRequestBytes q h' =
mconcat
[requestline,
hostLine,
headerFields,
crlf]
where
requestline = mconcat
[method,
sp,
uri,
sp,
version,
crlf]
method = case qMethod q of
GET -> Builder.fromString "GET"
HEAD -> Builder.fromString "HEAD"
POST -> Builder.fromString "POST"
PUT -> Builder.fromString "PUT"
DELETE -> Builder.fromString "DELETE"
TRACE -> Builder.fromString "TRACE"
OPTIONS -> Builder.fromString "OPTIONS"
CONNECT -> Builder.fromString "CONNECT"
PATCH -> Builder.fromString "PATCH"
(Method x) -> Builder.fromByteString x
uri = Builder.copyByteString $ qPath q
version = Builder.fromString "HTTP/1.1"
hostLine = mconcat
[Builder.fromString"Host: ",
hostname,
crlf]
hostname = case qHost q of
Just x' -> Builder.copyByteString x'
Nothing -> Builder.copyByteString h'
headerFields = joinHeaders $ unWrap $ qHeaders q
crlf = Builder.fromString "\r\n"
sp = Builder.fromChar ' '
type StatusCode = Int
data Response
= Response {
pStatusCode :: !StatusCode,
pStatusMsg :: !ByteString,
pTransferEncoding :: !TransferEncoding,
pContentEncoding :: !ContentEncoding,
pContentLength :: !Int,
pHeaders :: !Headers
}
instance Show Response where
show p =
S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ composeResponseBytes p
data TransferEncoding = None | Chunked
data ContentEncoding = Identity | Gzip | Deflate
deriving (Show)
getStatusCode :: Response -> StatusCode
getStatusCode = pStatusCode
getStatusMessage :: Response -> ByteString
getStatusMessage = pStatusMsg
getHeader :: Response -> ByteString -> Maybe ByteString
getHeader p k =
lookupHeader h k
where
h = pHeaders p
composeResponseBytes :: Response -> Builder
composeResponseBytes p =
mconcat
[statusline,
headerFields,
crlf]
where
statusline = mconcat
[version,
sp,
code,
sp,
message,
crlf]
code = Builder.fromShow $ pStatusCode p
message = Builder.copyByteString $ pStatusMsg p
version = Builder.fromString "HTTP/1.1"
headerFields = joinHeaders $ unWrap $ pHeaders p
newtype Headers = Wrap {
unWrap :: HashMap (CI ByteString) ByteString
}
instance Show Headers where
show x = S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ joinHeaders $ unWrap x
joinHeaders :: HashMap (CI ByteString) ByteString -> Builder
joinHeaders m = foldrWithKey combine mempty m
combine :: CI ByteString -> ByteString -> Builder -> Builder
combine k v acc =
mconcat [acc, key, Builder.fromString ": ", value, crlf]
where
key = Builder.copyByteString $ original k
value = Builder.fromByteString v
emptyHeaders :: Headers
emptyHeaders =
Wrap empty
updateHeader :: Headers -> ByteString -> ByteString -> Headers
updateHeader x k v =
Wrap result
where
!result = insert (mk k) v m
!m = unWrap x
removeHeader :: Headers -> ByteString -> Headers
removeHeader x k =
Wrap result
where
!result = delete (mk k) m
!m = unWrap x
buildHeaders :: [(ByteString,ByteString)] -> Headers
buildHeaders hs =
Wrap result
where
result = foldl' addHeader empty hs
addHeader
:: HashMap (CI ByteString) ByteString
-> (ByteString,ByteString)
-> HashMap (CI ByteString) ByteString
addHeader m (k,v) =
insertWith f (mk k) v m
where
f new old = S.concat [old, ",", new]
lookupHeader :: Headers -> ByteString -> Maybe ByteString
lookupHeader x k =
lookup (mk k) m
where
!m = unWrap x
data HttpParseException = HttpParseException String
deriving (Typeable, Show)
instance Exception HttpParseException