module Network.Http.Types (
Request(..),
EntityBody(..),
ExpectMode(..),
Response(..),
StatusCode,
TransferEncoding(..),
ContentEncoding(..),
getStatusCode,
getStatusMessage,
getHeader,
Method(..),
Headers,
emptyHeaders,
updateHeader,
removeHeader,
buildHeaders,
lookupHeader,
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
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,
lookup)
import Data.List (foldl')
import Data.Monoid (mconcat, mempty)
import Data.String (IsString, fromString)
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,
"\r\n"]
where
requestline = mconcat
[method,
" ",
uri,
" ",
version,
"\r\n"]
method = case qMethod q of
GET -> "GET"
HEAD -> "HEAD"
POST -> "POST"
PUT -> "PUT"
DELETE -> "DELETE"
TRACE -> "TRACE"
OPTIONS -> "OPTIONS"
CONNECT -> "CONNECT"
PATCH -> "PATCH"
(Method x) -> Builder.fromByteString x
uri = Builder.copyByteString $ qPath q
version = "HTTP/1.1"
hostLine = mconcat ["Host: ", hostname, "\r\n"]
hostname = case qHost q of
Just x' -> Builder.copyByteString x'
Nothing -> Builder.copyByteString h'
headerFields = joinHeaders $ unWrap $ qHeaders q
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,
"\r\n"]
where
statusline = mconcat
[version,
" ",
code,
" ",
message,
"\r\n"]
code = Builder.fromShow $ pStatusCode p
message = Builder.copyByteString $ pStatusMsg p
version = "HTTP/1.1"
headerFields = joinHeaders $ unWrap $ pHeaders p
instance IsString Builder where
fromString x = Builder.fromString x
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, ": ", value, "\r\n"]
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) =
insert (mk k) v m
lookupHeader :: Headers -> ByteString -> Maybe ByteString
lookupHeader x k =
lookup (mk k) m
where
!m = unWrap x