diff --git a/Network/HTTP/Types.hs b/Network/HTTP/Types.hs --- a/Network/HTTP/Types.hs +++ b/Network/HTTP/Types.hs @@ -1,8 +1,8 @@ module Network.HTTP.Types ( -- * Case insensitive HTTP ByteStrings - HttpCIByteString(..) -, mkHttpCIByteString + CIByteString(..) +, mkCIByteString -- * Methods , Method , methodGet @@ -13,11 +13,9 @@ , methodTrace , methodConnect , methodOptions -, MethodADT(GET, POST, HEAD, PUT, DELETE, TRACE, CONNECT, OPTIONS) -, methodToADT -, methodFromADT -, stringToMethodADT -, methodADTToString +, StdMethod(..) +, parseMethod +, renderMethod -- * Versions , HttpVersion(..) , http09 @@ -37,70 +35,88 @@ , status405, statusNotAllowed , status500, statusServerError -- * Headers +, Header , RequestHeaders , ResponseHeaders +, headerAccept +, headerCacheControl +, headerConnection +, headerContentLength +, headerContentType +, headerContentMD5 +, headerDate -- * Query string +, QueryItem , Query -, QuerySimple +, SimpleQueryItem +, SimpleQuery +, renderQuery +, renderSimpleQuery +, parseQuery +, parseSimpleQuery + -- * URL encoding / decoding +, urlEncode +, urlDecode ) where +import Control.Arrow (second) +import Data.Array import Data.Char +import Data.List import Data.Maybe import Data.String +import Numeric import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as Ascii -localError :: String -> String -> a -localError f s = error $ "Network.HTTP.Types." ++ f ++ ": " ++ s - -- | Case-insensitive HTTP ByteStrings, mostly for use in Header names. -data HttpCIByteString - = HttpCIByteString { +data CIByteString + = CIByteString { ciOriginal :: !B.ByteString , ciLowerCase :: !B.ByteString } -mkHttpCIByteString :: B.ByteString -> HttpCIByteString -mkHttpCIByteString orig = HttpCIByteString { +mkCIByteString :: B.ByteString -> CIByteString +mkCIByteString orig = CIByteString { ciOriginal = orig , ciLowerCase = Ascii.map toLower orig } -instance Eq HttpCIByteString where - HttpCIByteString { ciLowerCase = a } == HttpCIByteString { ciLowerCase = b } +instance Eq CIByteString where + CIByteString { ciLowerCase = a } == CIByteString { ciLowerCase = b } = a == b -instance Ord HttpCIByteString where - compare HttpCIByteString { ciLowerCase = a } HttpCIByteString { ciLowerCase = b } +instance Ord CIByteString where + compare CIByteString { ciLowerCase = a } CIByteString { ciLowerCase = b } = compare a b -instance Show HttpCIByteString where +instance Show CIByteString where show = show . ciOriginal -instance IsString HttpCIByteString where - fromString = mkHttpCIByteString . Ascii.pack +instance IsString CIByteString where + fromString = mkCIByteString . Ascii.pack -- | HTTP method (flat string type). type Method = B.ByteString -- | HTTP Method constants. methodGet, methodPost, methodHead, methodPut, methodDelete, methodTrace, methodConnect, methodOptions :: Method -methodGet = Ascii.pack "GET" -methodPost = Ascii.pack "POST" -methodHead = Ascii.pack "HEAD" -methodPut = Ascii.pack "PUT" -methodDelete = Ascii.pack "DELETE" -methodTrace = Ascii.pack "TRACE" -methodConnect = Ascii.pack "CONNECT" -methodOptions = Ascii.pack "OPTIONS" +methodGet = renderMethod GET +methodPost = renderMethod POST +methodHead = renderMethod HEAD +methodPut = renderMethod PUT +methodDelete = renderMethod DELETE +methodTrace = renderMethod TRACE +methodConnect = renderMethod CONNECT +methodOptions = renderMethod OPTIONS --- | HTTP method (ADT version). +-- | HTTP standard method (as defined by RFC 2616). -- -- Note that the Show instance is only for debugging and should NOT be used to generate HTTP method strings; use 'methodToByteString' instead. -- -- The constructor 'OtherMethod' is not exported for forwards compatibility reasons. -data MethodADT +data StdMethod = GET | POST | HEAD @@ -109,46 +125,24 @@ | TRACE | CONNECT | OPTIONS - | OtherMethod B.ByteString - deriving (Show, Eq, Ord) - + deriving (Read, Show, Eq, Ord, Enum, Bounded, Ix) -- These are ordered by suspected frequency. More popular methods should go first. --- The reason is that methodListA and methodListB are used with lookup. +-- The reason is that methodList is used with lookup. -- lookup is probably faster for these few cases than setting up an elaborate data structure. -methodListA :: [(Method, MethodADT)] -methodListA - = [ (methodGet, GET) - , (methodPost, POST) - , (methodHead, HEAD) - , (methodPut, PUT) - , (methodDelete, DELETE) - , (methodTrace, TRACE) - , (methodConnect, CONNECT) - , (methodOptions, OPTIONS) - ] -methodListB :: [(MethodADT, Method)] -methodListB = map (\(a, b) -> (b, a)) methodListA - --- | Convert a method 'ByteString' to a 'MethodADT'. -methodToADT :: Method -> MethodADT -methodToADT bs = fromMaybe (OtherMethod bs) $ lookup bs methodListA +methodArray :: Array StdMethod Method +methodArray = listArray (minBound, maxBound) $ map (Ascii.pack . show) [minBound :: StdMethod .. maxBound] --- | Convert a 'MethodADT' to a 'ByteString'. -methodFromADT :: MethodADT -> Method -methodFromADT m - = case m of - OtherMethod bs -> bs - _ -> fromMaybe (localError "methodToByteString" "This should not happen (methodListB is incomplete)") $ - lookup m methodListB +methodList :: [(Method, StdMethod)] +methodList = map (\(a, b) -> (b, a)) (assocs methodArray) --- | Convert a method 'String' to a 'MethodADT'. -stringToMethodADT :: String -> MethodADT -stringToMethodADT = methodToADT . Ascii.pack +-- | Convert a method 'ByteString' to a 'StdMethod' if possible. +parseMethod :: Method -> Either B.ByteString StdMethod +parseMethod bs = maybe (Left bs) Right $ lookup bs methodList --- | Convert a 'MethodADT' to a 'String'. -methodADTToString :: MethodADT -> String -methodADTToString = Ascii.unpack . methodFromADT +-- | Convert a 'StdMethod' to a 'ByteString'. +renderMethod :: StdMethod -> Method +renderMethod m = methodArray ! m -- | HTTP Version. -- @@ -248,17 +242,114 @@ status500 = Status 500 $ Ascii.pack "Internal Server Error" statusServerError = status500 --- | Request Header -type RequestHeaders = [(HttpCIByteString, B.ByteString)] +-- | Header +type Header = (CIByteString, B.ByteString) +-- | Request Headers +type RequestHeaders = [Header] + -- | Response Headers -type ResponseHeaders = [(HttpCIByteString, B.ByteString)] +type ResponseHeaders = [Header] +makeHeader :: String -> B.ByteString -> Header +makeHeader a = \b -> (a', b) + where a' = mkCIByteString $ Ascii.pack a + +-- | HTTP Headers +headerAccept, headerCacheControl, headerConnection, headerContentLength, headerContentType, headerContentMD5, headerDate :: B.ByteString -> Header +headerAccept = makeHeader "Accept" +headerCacheControl = makeHeader "Cache-Control" +headerConnection = makeHeader "Connection" +headerContentLength = makeHeader "Content-Length" +headerContentType = makeHeader "Content-Type" +headerContentMD5 = makeHeader "Content-MD5" +headerDate = makeHeader "Date" + +-- | Query item +type QueryItem = (B.ByteString, Maybe B.ByteString) + -- | Query. -- -- General form: a=b&c=d, but if the value is Nothing, it becomes -- a&c=d. -type Query = [(B.ByteString, Maybe B.ByteString)] +type Query = [QueryItem] +-- | Simplified Query item type without support for parameter-less items. +type SimpleQueryItem = (B.ByteString, B.ByteString) + -- | Simplified Query type without support for parameter-less items. -type QuerySimple = [(B.ByteString, B.ByteString)] +type SimpleQuery = [SimpleQueryItem] + +-- | Convert 'Query' to 'ByteString'. +renderQuery :: Bool -> Query -> B.ByteString +renderQuery useQuestionMark = B.concat + . addQuestionMark + . intercalate [Ascii.pack "&"] + . map showQueryItem + where + addQuestionMark :: [B.ByteString] -> [B.ByteString] + addQuestionMark [] = [] + addQuestionMark xs | useQuestionMark = Ascii.pack "?" : xs + | otherwise = xs + + showQueryItem :: (B.ByteString, Maybe B.ByteString) -> [B.ByteString] + showQueryItem (n, Nothing) = [urlEncode n] + showQueryItem (n, Just v) = [urlEncode n, Ascii.pack "=", urlEncode v] + +-- | Convert 'SimpleQuery' to 'ByteString'. +renderSimpleQuery :: Bool -> SimpleQuery -> B.ByteString +renderSimpleQuery useQuestionMark = renderQuery useQuestionMark . map (\(k, v) -> (k, Just v)) + +-- | Parse 'Query' from a 'ByteString'. +parseQuery :: B.ByteString -> Query +parseQuery bs = case Ascii.uncons bs of + Nothing -> [] + Just ('?', bs') -> parseQuery' bs' + _ -> parseQuery' bs + where + parseQuery' = map parseQueryItem . Ascii.split '&' + parseQueryItem q = (k, v) + where (k', v') = Ascii.break (== '=') q + k = urlDecode k' + v = if B.null v' + then Nothing + else Just $ urlDecode $ B.tail v' + +-- | Parse 'SimpleQuery' from a 'ByteString'. +parseSimpleQuery :: B.ByteString -> SimpleQuery +parseSimpleQuery = map (second $ fromMaybe B.empty) . parseQuery + +-- | Percent-encoding for URLs. +urlEncode :: B.ByteString -> B.ByteString +urlEncode = Ascii.concatMap (Ascii.pack . encodeChar) + where + encodeChar :: Char -> [Char] + encodeChar ch | unreserved ch = [ch] + | otherwise = h2 $ ord ch + + unreserved :: Char -> Bool + unreserved ch | ch >= 'A' && ch <= 'Z' = True + | ch >= 'a' && ch <= 'z' = True + | ch >= '0' && ch <= '9' = True + unreserved '-' = True + unreserved '_' = True + unreserved '.' = True + unreserved '~' = True + unreserved _ = False + + h2 :: Int -> [Char] + h2 v = let (a, b) = v `divMod` 16 in ['%', h a, h b] + + h :: Int -> Char + h i | i < 10 = chr $ ord '0' + i + | otherwise = chr $ ord 'A' + i - 10 + +-- | Percent-decoding. +urlDecode :: B.ByteString -> B.ByteString +urlDecode bs = case Ascii.uncons bs of + Nothing -> B.empty + Just ('%', x) -> case readHex $ Ascii.unpack pc of + [(v, "")] -> chr v `Ascii.cons` urlDecode bs' + _ -> Ascii.cons '%' $ urlDecode x + where (pc, bs') = Ascii.splitAt 2 x + Just (c, bs') -> Ascii.cons c $ urlDecode bs' diff --git a/http-types.cabal b/http-types.cabal --- a/http-types.cabal +++ b/http-types.cabal @@ -7,7 +7,7 @@ -- The package version. See the Haskell package versioning policy -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for -- standards guiding when and how versions should be incremented. -Version: 0.1.1 +Version: 0.2.0 -- A short (one-line) description of the package. Synopsis: Generic HTTP types for Haskell (for both client and server code). @@ -54,7 +54,9 @@ GHC-Options: -Wall -- Packages needed in order to build this package. - Build-depends: base >= 4 && < 5, bytestring >=0.9.1.5 && <0.10 + Build-depends: base >= 4 && < 5, + bytestring >=0.9.1.5 && <0.10, + array >=0.3 && <0.4 -- Modules not exported by this package. -- Other-modules: