module Network.HTTP.Types
(
Ascii
, Method
, methodGet
, methodPost
, methodHead
, methodPut
, methodDelete
, methodTrace
, methodConnect
, methodOptions
, StdMethod(..)
, parseMethod
, renderMethod
, renderStdMethod
, HttpVersion(..)
, http09
, http10
, http11
, Status(..)
, status200, statusOK
, status201, statusCreated
, status206, statusPartialContent
, status301, statusMovedPermanently
, status302, statusFound
, status303, statusSeeOther
, status400, statusBadRequest
, status401, statusUnauthorized
, status403, statusForbidden
, status404, statusNotFound
, status405, statusNotAllowed
, status500, statusServerError
, Header
, RequestHeaders
, ResponseHeaders
, headerAccept
, headerCacheControl
, headerConnection
, headerContentLength
, headerContentType
, headerContentMD5
, headerDate
, QueryItem
, Query
, SimpleQueryItem
, SimpleQuery
, simpleQueryToQuery
, renderQuery
, renderQueryBuilder
, renderSimpleQuery
, parseQuery
, parseSimpleQuery
, QueryText
, queryTextToQuery
, queryToQueryText
, renderQueryText
, parseQueryText
, encodePathSegments
, decodePathSegments
, encodePath
, decodePath
, urlEncodeBuilder
, urlEncode
, urlDecode
)
where
import Control.Arrow (second, (|||), (***))
import Data.Array
import Data.Bits (shiftL, (.|.))
import Data.Char
import Data.Maybe
import Data.Monoid (mempty, mappend, mconcat)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8, decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Word (Word8)
import qualified Blaze.ByteString.Builder as Blaze
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as B8
import qualified Data.CaseInsensitive as CI
type Ascii = B.ByteString
type Method = Ascii
methodGet, methodPost, methodHead, methodPut, methodDelete, methodTrace, methodConnect, methodOptions :: Method
methodGet = renderStdMethod GET
methodPost = renderStdMethod POST
methodHead = renderStdMethod HEAD
methodPut = renderStdMethod PUT
methodDelete = renderStdMethod DELETE
methodTrace = renderStdMethod TRACE
methodConnect = renderStdMethod CONNECT
methodOptions = renderStdMethod OPTIONS
data StdMethod
= GET
| POST
| HEAD
| PUT
| DELETE
| TRACE
| CONNECT
| OPTIONS
deriving (Read, Show, Eq, Ord, Enum, Bounded, Ix)
methodArray :: Array StdMethod Method
methodArray = listArray (minBound, maxBound) $ map (B8.pack . show) [minBound :: StdMethod .. maxBound]
methodList :: [(Method, StdMethod)]
methodList = map (\(a, b) -> (b, a)) (assocs methodArray)
parseMethod :: Method -> Either Ascii StdMethod
parseMethod bs = maybe (Left bs) Right $ lookup bs methodList
renderMethod :: Either Ascii StdMethod -> Method
renderMethod = id ||| renderStdMethod
renderStdMethod :: StdMethod -> Method
renderStdMethod m = methodArray ! m
data HttpVersion
= HttpVersion {
httpMajor :: !Int
, httpMinor :: !Int
}
deriving (Eq, Ord)
instance Show HttpVersion where
show (HttpVersion major minor) = "HTTP/" ++ show major ++ "." ++ show minor
http09 :: HttpVersion
http09 = HttpVersion 0 9
http10 :: HttpVersion
http10 = HttpVersion 1 0
http11 :: HttpVersion
http11 = HttpVersion 1 1
data Status
= Status {
statusCode :: Int
, statusMessage :: Ascii
}
deriving (Show)
instance Eq Status where
Status { statusCode = a } == Status { statusCode = b } = a == b
instance Ord Status where
compare Status { statusCode = a } Status { statusCode = b } = a `compare` b
status200, statusOK :: Status
status200 = Status 200 "OK"
statusOK = status200
status201, statusCreated :: Status
status201 = Status 201 "Created"
statusCreated = status201
status206, statusPartialContent :: Status
status206 = Status 206 "PartialContent"
statusPartialContent = status206
status301, statusMovedPermanently :: Status
status301 = Status 301 "Moved Permanently"
statusMovedPermanently = status301
status302, statusFound :: Status
status302 = Status 302 "Found"
statusFound = status302
status303, statusSeeOther :: Status
status303 = Status 303 "See Other"
statusSeeOther = status303
status400, statusBadRequest :: Status
status400 = Status 400 "Bad Request"
statusBadRequest = status400
status401, statusUnauthorized :: Status
status401 = Status 401 "Unauthorized"
statusUnauthorized = status401
status403, statusForbidden :: Status
status403 = Status 403 "Forbidden"
statusForbidden = status403
status404, statusNotFound :: Status
status404 = Status 404 "Not Found"
statusNotFound = status404
status405, statusNotAllowed :: Status
status405 = Status 405 "Method Not Allowed"
statusNotAllowed = status405
status500, statusServerError :: Status
status500 = Status 500 "Internal Server Error"
statusServerError = status500
type Header = (CI.CI Ascii, Ascii)
type RequestHeaders = [Header]
type ResponseHeaders = [Header]
headerAccept, headerCacheControl, headerConnection, headerContentLength, headerContentType, headerContentMD5, headerDate :: Ascii -> Header
headerAccept = (,) "Accept"
headerCacheControl = (,) "Cache-Control"
headerConnection = (,) "Connection"
headerContentLength = (,) "Content-Length"
headerContentType = (,) "Content-Type"
headerContentMD5 = (,) "Content-MD5"
headerDate = (,) "Date"
type QueryItem = (B.ByteString, Maybe B.ByteString)
type Query = [QueryItem]
type QueryText = [(Text, Maybe Text)]
queryTextToQuery :: QueryText -> Query
queryTextToQuery = map $ encodeUtf8 *** fmap encodeUtf8
renderQueryText :: Bool
-> QueryText
-> Blaze.Builder
renderQueryText b = renderQueryBuilder b . queryTextToQuery
queryToQueryText :: Query -> QueryText
queryToQueryText =
map $ go *** fmap go
where
go = decodeUtf8With lenientDecode
parseQueryText :: B.ByteString -> QueryText
parseQueryText = queryToQueryText . parseQuery
type SimpleQueryItem = (B.ByteString, B.ByteString)
type SimpleQuery = [SimpleQueryItem]
simpleQueryToQuery :: SimpleQuery -> Query
simpleQueryToQuery = map (\(a, b) -> (a, Just b))
renderQueryBuilder :: Bool
-> Query
-> Blaze.Builder
renderQueryBuilder _ [] = mempty
renderQueryBuilder qmark' (p:ps) = mconcat
$ go (if qmark' then qmark else mempty) p
: map (go amp) ps
where
qmark = Blaze.copyByteString "?"
amp = Blaze.copyByteString "&"
equal = Blaze.copyByteString "="
go sep (k, mv) = mconcat [
sep
, urlEncodeBuilder True k
, case mv of
Nothing -> mempty
Just v -> equal `mappend` urlEncodeBuilder True v
]
renderQuery :: Bool
-> Query -> Ascii
renderQuery qm = Blaze.toByteString . renderQueryBuilder qm
renderSimpleQuery :: Bool
-> SimpleQuery -> Ascii
renderSimpleQuery useQuestionMark = renderQuery useQuestionMark . simpleQueryToQuery
parseQuery :: B.ByteString -> Query
parseQuery = parseQueryString' . dropQuestion
where
dropQuestion q =
case B.uncons q of
Just (63, q') -> q'
_ -> q
parseQueryString' q | B.null q = []
parseQueryString' q =
let (x, xs) = breakDiscard 38 q
in parsePair x : parseQueryString' xs
where
parsePair x =
let (k, v) = B.breakByte 61 x
v'' =
case B.uncons v of
Just (_, v') -> Just $ urlDecode True v'
_ -> Nothing
in (urlDecode True k, v'')
breakDiscard :: Word8 -> B.ByteString -> (B.ByteString, B.ByteString)
breakDiscard w s =
let (x, y) = B.breakByte w s
in (x, B.drop 1 y)
parseSimpleQuery :: B.ByteString -> SimpleQuery
parseSimpleQuery = map (second $ fromMaybe B.empty) . parseQuery
ord8 :: Char -> Word8
ord8 = fromIntegral . ord
unreservedQS, unreservedPI :: [Word8]
unreservedQS = map ord8 "-_.~"
unreservedPI = map ord8 ":@&=+$,"
urlEncodeBuilder' :: [Word8] -> B.ByteString -> Blaze.Builder
urlEncodeBuilder' extraUnreserved = mconcat . map encodeChar . B.unpack
where
encodeChar ch | unreserved ch = Blaze.fromWord8 ch
| otherwise = h2 ch
unreserved ch | ch >= 65 && ch <= 90 = True
| ch >= 97 && ch <= 122 = True
| ch >= 48 && ch <= 57 = True
unreserved c = c `elem` extraUnreserved
h2 v = let (a, b) = v `divMod` 16 in Blaze.fromWord8s [37, h a, h b]
h i | i < 10 = 48 + i
| otherwise = 65 + i 10
urlEncodeBuilder
:: Bool
-> B.ByteString
-> Blaze.Builder
urlEncodeBuilder True = urlEncodeBuilder' unreservedQS
urlEncodeBuilder False = urlEncodeBuilder' unreservedPI
urlEncode :: Bool -> B.ByteString -> Ascii
urlEncode q = Blaze.toByteString . urlEncodeBuilder q
urlDecode :: Bool
-> B.ByteString -> B.ByteString
urlDecode replacePlus z = fst $ B.unfoldrN (B.length z) go z
where
go bs =
case B.uncons bs of
Nothing -> Nothing
Just (43, ws) | replacePlus -> Just (32, ws)
Just (37, ws) -> Just $ fromMaybe (37, ws) $ do
(x, xs) <- B.uncons ws
x' <- hexVal x
(y, ys) <- B.uncons xs
y' <- hexVal y
Just $ (combine x' y', ys)
Just (w, ws) -> Just (w, ws)
hexVal w
| 48 <= w && w <= 57 = Just $ w 48
| 65 <= w && w <= 70 = Just $ w 55
| 97 <= w && w <= 102 = Just $ w 87
| otherwise = Nothing
combine :: Word8 -> Word8 -> Word8
combine a b = shiftL a 4 .|. b
encodePathSegments :: [Text] -> Blaze.Builder
encodePathSegments [] = mempty
encodePathSegments (x:xs) =
Blaze.copyByteString "/"
`mappend` encodePathSegment x
`mappend` encodePathSegments xs
encodePathSegment :: Text -> Blaze.Builder
encodePathSegment = urlEncodeBuilder False . encodeUtf8
decodePathSegments :: B.ByteString -> [Text]
decodePathSegments "" = []
decodePathSegments "/" = []
decodePathSegments a =
go $ drop1Slash a
where
drop1Slash bs =
case B.uncons bs of
Just (47, bs') -> bs'
_ -> bs
go bs =
let (x, y) = B.breakByte 47 bs
in decodePathSegment x :
if B.null y
then []
else go $ B.drop 1 y
decodePathSegment :: B.ByteString -> Text
decodePathSegment = decodeUtf8With lenientDecode . urlDecode False
encodePath :: [Text] -> Query -> Blaze.Builder
encodePath x [] = encodePathSegments x
encodePath x y = encodePathSegments x `mappend` renderQueryBuilder True y
decodePath :: B.ByteString -> ([Text], Query)
decodePath b =
let (x, y) = B.breakByte 63 b
in (decodePathSegments x, parseQuery y)