http-types 0.4.1 → 0.5

raw patch · 3 files changed

+264/−65 lines, 3 filesdep +QuickCheckdep +blaze-builderdep +hspecdep ~arraydep ~asciidep ~basenew-component:exe:runtestsPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, blaze-builder, hspec, text

Dependency ranges changed: array, ascii, base, bytestring

API changes (from Hackage documentation)

Files

• Network/HTTP/Types.hs +192/−63
• http-types.cabal +15/−2
• runtests.hs +57/−0

@@ -51,24 +51,37 @@ , SimpleQuery , simpleQueryToQuery , renderQuery+, renderQueryBuilder , renderSimpleQuery , parseQuery , parseSimpleQuery+  -- * Path segments+, encodePathSegments+, decodePathSegments+  -- * Path (segments + query string)+, encodePath+, decodePath   -- * URL encoding / decoding+, urlEncodeBuilder , urlEncode , urlDecode ) where -import           Control.Arrow         (second, (|||))+import           Control.Arrow            (second, (|||)) import           Data.Array+import           Data.Bits                (shiftL, (.|.)) import           Data.Char-import           Data.List import           Data.Maybe-import           Numeric-import qualified Data.ByteString       as B-import qualified Data.ByteString.Char8 as Ascii-import qualified Data.Ascii            as A+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.Ascii               as A+import qualified Data.ByteString          as B+import qualified Data.ByteString.Char8    as Ascii  -- | HTTP method (flat string type). type Method = A.Ascii@@ -253,78 +266,194 @@ simpleQueryToQuery :: SimpleQuery -> Query simpleQueryToQuery = map (\(a, b) -> (a, Just b)) +renderQueryBuilder :: Bool -- ^ prepend a question mark?+                   -> Query+                   -> A.AsciiBuilder+renderQueryBuilder False [] = mempty+renderQueryBuilder True [] = A.unsafeFromBuilder $ Blaze.copyByteString "?"+-- FIXME replace mconcat + map with foldr+renderQueryBuilder qmark' (p:ps) = mconcat+    $ go (if qmark' then qmark else mempty) p+    : map (go amp) ps+  where+    qmark = A.unsafeFromBuilder $ Blaze.copyByteString "?"+    amp = A.unsafeFromBuilder $ Blaze.copyByteString "&"+    equal = A.unsafeFromBuilder $ Blaze.copyByteString "="+    go sep (k, mv) = mconcat [+                      sep+                     , urlEncodeBuilder True k+                     , case mv of+                         Nothing -> mempty+                         Just v -> equal `mappend` urlEncodeBuilder True v+                     ]+ -- | Convert 'Query' to 'ByteString'. renderQuery :: Bool -- ^ prepend question mark?-            -> 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]+            -> Query -> A.Ascii+renderQuery qm = A.fromAsciiBuilder . renderQueryBuilder qm  -- | Convert 'SimpleQuery' to 'ByteString'. renderSimpleQuery :: Bool -- ^ prepend question mark?-                  -> SimpleQuery -> B.ByteString-renderSimpleQuery useQuestionMark = renderQuery useQuestionMark . map (\(k, v) -> (k, Just v))+                  -> SimpleQuery -> A.Ascii+renderSimpleQuery useQuestionMark = renderQuery useQuestionMark . simpleQueryToQuery --- | Parse 'Query' from a 'ByteString'.+-- | Split out the query string into a list of keys and values. A few+-- importants points:+--+-- * The result returned is still bytestrings, since we perform no character+-- decoding here. Most likely, you will want to use UTF-8 decoding, but this is+-- left to the user of the library.+--+-- * Percent decoding errors are ignored. In particular, "%Q" will be output as+-- "%Q". 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'+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 -- ampersand+         in parsePair x : parseQueryString' xs+      where+        parsePair x =+            let (k, v) = B.breakByte 61 x -- equal sign+                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)+ -- | Parse 'SimpleQuery' from a 'ByteString'. 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 ":@&=+$,"+ -- | Percent-encoding for URLs.-urlEncode :: B.ByteString -> B.ByteString-urlEncode = Ascii.concatMap (Ascii.pack . encodeChar)+urlEncodeBuilder' :: [Word8] -> B.ByteString -> A.AsciiBuilder+urlEncodeBuilder' extraUnreserved = A.unsafeFromBuilder . mconcat . map encodeChar . B.unpack     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+      encodeChar ch | unreserved ch = Blaze.fromWord8 ch+                    | otherwise     = h2 ch       -      h2 :: Int -> [Char]-      h2 v = let (a, b) = v `divMod` 16 in ['%', h a, h b]+      unreserved ch | ch >= 65 && ch <= 90  = True -- A-Z+                    | ch >= 97 && ch <= 122 = True -- a-z+                    | ch >= 48 && ch <= 57  = True -- 0-9+      unreserved c = c `elem` extraUnreserved       -      h :: Int -> Char-      h i | i < 10    = chr $ ord '0' + i-          | otherwise = chr $ ord 'A' + i - 10+      h2 v = let (a, b) = v `divMod` 16 in Blaze.fromWord8s [37, h a, h b] -- percent (%)+      h i | i < 10    = 48 + i -- zero (0)+          | otherwise = 65 + i - 10 -- 65: A +urlEncodeBuilder+    :: Bool -- ^ Whether input is in query string. True: Query string, False: Path element+    -> B.ByteString+    -> A.AsciiBuilder+urlEncodeBuilder True  = urlEncodeBuilder' unreservedQS+urlEncodeBuilder False = urlEncodeBuilder' unreservedPI++urlEncode :: Bool -> Ascii.ByteString -> A.Ascii+urlEncode q = A.fromAsciiBuilder . urlEncodeBuilder q+ -- | 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'+urlDecode :: Bool -- ^ Whether to decode '+' to ' '+         -> 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) -- plus to space+            Just (37, ws) -> Just $ fromMaybe (37, ws) $ do -- percent+                (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 -- 0 - 9+        | 65 <= w && w <= 70  = Just $ w - 55 -- A - F+        | 97 <= w && w <= 102 = Just $ w - 87 -- a - f+        | otherwise = Nothing+    combine :: Word8 -> Word8 -> Word8+    combine a b = shiftL a 4 .|. b++-- | Encodes a list of path segments into a valid URL fragment.+--+-- This function takes the following three steps:+--+-- * UTF-8 encodes the characters.+--+-- * Performs percent encoding on all unreserved characters, as well as \:\@\=\+\$,+--+-- * Intercalates with a slash.+--+-- For example:+--+-- > encodePathInfo [\"foo\", \"bar\", \"baz\"]+--+-- \"foo\/bar\/baz\"+--+-- > encodePathInfo [\"foo bar\", \"baz\/bin\"]+--+-- \"foo\%20bar\/baz\%2Fbin\"+--+-- > encodePathInfo [\"שלום\"]+--+-- \"%D7%A9%D7%9C%D7%95%D7%9D\"+--+-- Huge thanks to Jeremy Shaw who created the original implementation of this+-- function in web-routes and did such thorough research to determine all+-- correct escaping procedures.+encodePathSegments :: [Text] -> A.AsciiBuilder+encodePathSegments [] = mempty+encodePathSegments (x:xs) =+    A.unsafeFromBuilder (Blaze.copyByteString "/")+    `mappend` encodePathSegment x+    `mappend` encodePathSegments xs++encodePathSegment :: Text -> A.AsciiBuilder+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' -- 47 == /+            _ -> 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 -> A.AsciiBuilder+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 -- slash+    in (decodePathSegments x, parseQuery y)

@@ -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.4.1+Version:             0.5  -- A short (one-line) description of the package. Synopsis:            Generic HTTP types for Haskell (for both client and server code).@@ -45,6 +45,9 @@ -- Constraint on the version of Cabal needed to build this package. Cabal-version:       >=1.8 +flag test+  description: Build the executable to run unit tests+  default: False  Library   -- Modules exported by the library.@@ -57,7 +60,9 @@   Build-depends:       base >= 4 && < 5,                        bytestring >=0.9.1.5 && <0.10,                        array >=0.3 && <0.4,-                       ascii >= 0.0 && < 0.1+                       ascii >= 0.0.1.1 && < 0.1,+                       blaze-builder >= 0.2.1.4 && < 0.3,+                       text >= 0.11.0.2 && < 0.12      -- Modules not exported by this package.   -- Other-modules:       @@ -65,3 +70,11 @@   -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.   -- Build-tools:            ++executable             runtests+    main-is:           runtests.hs+    if flag(test)+        Buildable: True+        build-depends: text, bytestring, base, blaze-builder, ascii, array, QuickCheck, hspec >= 0.3 && < 0.4+    else+        Buildable: False

@@ -0,0 +1,57 @@+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE OverloadedStrings #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+import Debug.Trace+import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck (Arbitrary (..))+import qualified Data.Ascii               as A+import Network.HTTP.Types+import           Data.Text                   (Text)+import qualified Data.ByteString as S+import qualified Data.Text as T++main :: IO ()+main = hspec $ descriptions+    [ describe "encode/decode path"+        [ it "is identity to encode and then decode"+            $ property propEncodeDecodePath+        ]+    , describe "encode/decode query"+        [ it "is identity to encode and then decode"+            $ property propEncodeDecodeQuery+        ]+    , describe "encode/decode path segments"+        [ it "is identity to encode and then decode"+            $ property propEncodeDecodePathSegments+        ]+    ]++propEncodeDecodePath :: ([Text], Query) -> Bool+propEncodeDecodePath (p', q') =+    let x = A.toByteString $ A.fromAsciiBuilder $ encodePath a b+        y = decodePath x+        z = y == (a, b)+     in if z then z else traceShow (a, b, x, y) z+  where+    a = if p' == [""] then [] else p'+    b = filter (\(x, _) -> not (S.null x)) q'++propEncodeDecodeQuery :: Query -> Bool+propEncodeDecodeQuery q' =+    q == parseQuery (A.toByteString $ renderQuery True q)+  where+    q = filter (\(x, _) -> not (S.null x)) q'++propEncodeDecodePathSegments :: [Text] -> Bool+propEncodeDecodePathSegments p' =+    p == decodePathSegments (A.toByteString $ A.fromAsciiBuilder $ encodePathSegments p)+  where+    p = if p' == [""] then [] else p'++instance Arbitrary Text where+    arbitrary = fmap T.pack arbitrary++instance Arbitrary S.ByteString where+    arbitrary = fmap S.pack arbitrary