module Network.Http.Types (
Request(..),
EntityBody(..),
ExpectMode(..),
getHostname,
Response(..),
StatusCode,
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.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 :: ByteString,
qPath :: ByteString,
qBody :: EntityBody,
qExpect :: ExpectMode,
qHeaders :: Headers
}
instance Show Request where
show q =
S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ composeRequestBytes q
data EntityBody = Empty | Chunking | Static Int
data ExpectMode = Normal | Continue
composeRequestBytes :: Request -> Builder
composeRequestBytes q =
mconcat
[requestline,
hostLine,
headerFields,
"\r\n"]
where
requestline = mconcat
[method,
" ",
uri,
" ",
version,
"\r\n"]
method = Builder.fromString $ show $ qMethod q
uri = Builder.copyByteString $ qPath q
version = "HTTP/1.1"
hostLine = mconcat ["Host: ", hostname, "\r\n"]
hostname = Builder.copyByteString $ qHost q
headerFields = joinHeaders $ unWrap $ qHeaders q
getHostname :: Request -> ByteString
getHostname q = qHost q
type StatusCode = Int
data Response
= Response {
pStatusCode :: StatusCode,
pStatusMsg :: ByteString,
pHeaders :: Headers
}
instance Show Response where
show p =
S.unpack $ S.filter (/= '\r') $ Builder.toByteString $ composeResponseBytes p
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 = foldr addHeader empty hs
addHeader
:: (ByteString,ByteString)
-> HashMap (CI ByteString) ByteString
-> HashMap (CI ByteString) ByteString
addHeader (k,v) m =
insert (mk k) v m
lookupHeader :: Headers -> ByteString -> Maybe ByteString
lookupHeader x k =
lookup (mk k) m
where
m = unWrap x