urlencoded 0.0 → 0.1
raw patch · 4 files changed
+281/−24 lines, 4 filesdep +QuickCheckdep ~basebuild-type:Customsetup-changednew-component:exe:test
Dependencies added: QuickCheck
Dependency ranges changed: base
Files
- Setup.lhs +19/−1
- src/Data/URLEncoded.hs +114/−17
- test/TestDriver.hs +128/−0
- urlencoded.cabal +20/−6
Setup.lhs view
@@ -1,3 +1,21 @@ #!/usr/bin/env runhaskell > import Distribution.Simple-> main = defaultMain+> import Distribution.PackageDescription+> import Distribution.Simple.Setup ( defaultBuildFlags )+> import Distribution.Simple.LocalBuildInfo ( buildDir )+> import Distribution.Simple.Utils ( rawSystemExit )+> import Distribution.Verbosity ( normal )+> import System.FilePath ( (</>) )++> main = defaultMainWithHooks hooks++> hooks = simpleUserHooks { instHook = inst+> , runTests = test+> }++> inst pkg = instHook simpleUserHooks $ pkg { executables = [] }++> test args _unknown pkg lbi = do+> buildHook hooks pkg lbi hooks defaultBuildFlags+> let testPath = buildDir lbi </> "test" </> "test"+> rawSystemExit normal testPath args
src/Data/URLEncoded.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-} -- |Implements a data type for constructing and destructing -- x-www-urlencoded strings. See -- <http://www.w3.org/TR/html401/interact/forms.html#h-17.13.4.1>@@ -6,6 +6,9 @@ module Data.URLEncoded ( -- * Representation of a URL-encoded string URLEncoded+ , filter+ , URLShow(..)+ , URLEncode(..) -- * Generate , empty@@ -13,13 +16,18 @@ , importList , (%=) , (%=?)+ , (%&)+ , AddURLEncoded(..) -- * Query , null , keys , lookup+ , lookupAll , lookup1+ , lookupDefault , pairs+ , (%!) -- * Export , addToURI@@ -28,19 +36,43 @@ where import qualified Prelude-import Prelude hiding ( null, lookup )-import Data.List.Split ( splitOn )+import Prelude hiding ( null, lookup, filter )+import Data.List.Split ( unintercalate ) import Control.Monad ( liftM ) import Control.Arrow ( (>>>) ) import Control.Monad.Error ( MonadError ) import Network.URI ( unEscapeString, escapeURIString, isUnreserved, URI(uriQuery) )-import Data.Monoid ( Monoid )+import Data.Monoid ( Monoid, mappend ) import Data.List ( intercalate )+import Data.Maybe ( fromMaybe ) -- | A container for URLEncoded data newtype URLEncoded = URLEncoded { pairs :: [(String, String)] } deriving (Monoid, Eq) +class AddURLEncoded a where+ (%?) :: a -> URLEncoded -> a+infixr 6 %?++instance AddURLEncoded [Char] where+ str %? q = let (u, frag) = break (== '#') str+ joiner = if last u == '?'+ then ""+ else if '?' `elem` u+ then "&"+ else "?"+ in concat [u, joiner, export q, frag]++instance AddURLEncoded URI where+ (%?) = flip addToURI++instance AddURLEncoded URLEncoded where+ (%?) = mappend++(%&) :: URLEncoded -> URLEncoded -> URLEncoded+(%&) = mappend+infixr 7 %&+ -- | Is this URLEncoded data empty? null :: URLEncoded -> Bool null = Prelude.null . pairs@@ -58,21 +90,67 @@ keys = map fst . pairs -- |Create singleton URLEncoded data containing the supplied key and value-(%=) :: String -> String -> URLEncoded-k %= v = URLEncoded [(k, v)]+(%=) :: (URLShow a, URLShow b) => a -> b -> URLEncoded+k %= v = URLEncoded [(urlShow k, urlShow v)]+infixl 8 %= +-- |Encode a value as x-www-urlencoded+class URLEncode a where+ urlEncode :: a -> URLEncoded++instance (URLShow a, URLShow b) => URLEncode (a, b) where+ urlEncode (x, y) = importList [(urlShow x, urlShow y)]++instance URLEncode a => URLEncode (Maybe a) where+ urlEncode = maybe empty urlEncode++instance URLEncode URLEncoded where+ urlEncode = id++-- |Serialize a value into a String for encoding as part of an+-- x-www-urlencoded value+class URLShow a where+ urlShow :: a -> String++instance URLShow Char where+ urlShow = return++instance URLShow URI where+ urlShow = show++instance URLShow URLEncoded where+ urlShow = export++instance URLShow [Char] where+ urlShow = id++instance URLShow Int where+ urlShow = show++instance URLShow Integer where+ urlShow = show++instance URLShow Bool where+ urlShow True = "true"+ urlShow False = "false"+ -- |If the second value is Nothing, return empty URLEncoded -- data. Otherwise return singleton URLEncoded data that contains the -- given key and value.-(%=?) :: String {-^key-} -> Maybe String {-^value-} -> URLEncoded+(%=?) :: (URLShow a, URLShow b) =>+ a {-^key-} -> Maybe b {-^value-} -> URLEncoded k %=? v = maybe empty (k %=) v+infixl 8 %=? -- |Add this URL-encoded data to the query part of a URI, after any -- existing query arguments. addToURI :: URLEncoded -> URI -> URI addToURI q u =- let initialChar = if Prelude.null (uriQuery u) then '?' else '&'- in u { uriQuery = uriQuery u ++ (initialChar:export q) }+ let uq = uriQuery u+ initial = if uq == "?"+ then ""+ else if Prelude.null (uriQuery u) then "?" else "&"+ in u { uriQuery = uriQuery u ++ initial ++ export q } -- |Convert this URLEncoded object into an x-www-urlencoded String -- (The resulting string is 7-bit clean ASCII, containing only@@ -88,23 +166,42 @@ -- |Parse this string as x-www-urlencoded importString :: MonadError e m => String -> m URLEncoded-importString = splitOn "&" >>> mapM parsePair >>> liftM URLEncoded+importString "" = return empty+importString s = liftM importList $ mapM parsePair $ unintercalate "&" s where parsePair p = case break (== '=') p of (_, []) -> fail $ "Missing value in query string: " ++ show p- (k, '=':v) -> return ( unEscapeString k- , unEscapeString v+ (k, '=':v) -> return ( unesc k+ , unesc v ) unknown -> error $ "impossible: " ++ show unknown+ unesc = unEscapeString . intercalate "%20" . unintercalate "+" -- |Return the /first/ value for the given key, or throw an error if the -- key is not present in the URLEncoded data.-lookup1 :: MonadError e m => String -> URLEncoded -> m String-lookup1 k = pairs >>> Prelude.lookup k >>> maybe missing return- where missing = fail $ "Key not found: " ++ show k+lookup1 :: (URLShow a, MonadError e m) => a -> URLEncoded -> m String+lookup1 k = lookup k >>> maybe missing return+ where missing = fail $ "Key not found: " ++ urlShow k +lookup :: URLShow a => a -> URLEncoded -> Maybe String+lookup k = pairs >>> Prelude.lookup (urlShow k)++lookupDefault :: URLShow a => String -> a -> URLEncoded -> String+lookupDefault dflt k q = fromMaybe dflt $ q %! k+ -- |Return all values whose keys match the supplied key, in the order -- they appear in the query. Will return an empty list if no keys -- match.-lookup :: String -> URLEncoded -> [String]-lookup k urlenc = [ v | (k', v) <- pairs urlenc, k' == k ]+lookupAll :: URLShow a => a -> URLEncoded -> [String]+lookupAll k urlenc = [ v | (k', v) <- pairs urlenc, k' == urlShow k ]++-- |Create a URLEncoded object that represents all pairs from the+-- input that match the supplied predicate+filter :: ((String, String) -> Bool) -> URLEncoded -> URLEncoded+filter p = pairs >>> Prelude.filter p >>> URLEncoded++-- |Look up a key in a URLEncoded value and return the first matching+-- value, or Nothing if there is no value that matches+(%!) :: URLShow a => URLEncoded -> a -> Maybe String+(%!) = flip lookup+infixr 1 %!
+ test/TestDriver.hs view
@@ -0,0 +1,128 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Main where++import Control.Monad ( liftM, replicateM, liftM2 )++import Data.Monoid ( mconcat )+import Data.Maybe ( isJust )+import Data.URLEncoded as U+import Data.List ( intercalate, intersperse )++import Network.URI+ ( isAllowedInURI, URI(..), URIAuth(..), escapeURIString, isUnreserved )++import Control.Applicative ( (<$>), Applicative(..) )++import Test.QuickCheck++instance Arbitrary URLEncoded where+ arbitrary = do+ numPairs <- sized $ \n -> choose (0, n)+ importList `liftM` replicateM numPairs (two arbitraryQueryArg)+ coarbitrary = undefined++instance Applicative Gen where+ (<*>) = liftM2 ($)+ pure = return++arbitraryQueryArg :: Gen String+arbitraryQueryArg = do+ qLen <- sized $ \n -> choose (0, n)+ replicateM qLen $ elements ['\x00'..'\xff']++httpUri :: Gen URI+httpUri = URI <$> proto <*> auth <*> path <*> query <*> frag+ where proto = (++ ":") <$> elements ["http", "https"]+ auth = sized $ \n -> if n == 0+ then return Nothing+ else Just <$> (URIAuth "" <$> host <*> port)+ lstart = elements ['a'..'z']+ lmid = elements $ ['a'..'z'] ++ ['0'..'9'] ++ "-"+ lend = elements $ ['a'..'z'] ++ ['0'..'9']+ hlabel = (:)+ <$> lstart+ <*> sized (\n -> do+ m <- choose (0, n)+ if m == 0+ then return []+ else (++) <$> (replicateM (m - 1) lmid)+ <*> (return <$> lend))+ host = intercalate "." <$> (flip replicateM hlabel =<< choose (1, 6))+ port = maybeEmpty (((':':) . show) <$> choose (1, 65535::Int))+ frag = maybeEmpty (('#':) <$> urlSafe)+ urlSafe = escapeURIString isUnreserved <$> arbitraryQueryArg+ query = maybeEmpty+ ((('?':) . export) <$> (arbitrary :: Gen URLEncoded))+ path = sized $ \n -> do+ m <- choose (0, n)+ if m == 0+ then return "/"+ else concat <$> (replicateM m (('/':) <$> urlSafe))+ maybeEmpty g = sized $ \n -> do m <- choose (0, n)+ if m == 0 then return "" else g++pairLists :: Gen [(String, String)]+pairLists = sized $ \n -> do+ m <- choose (0, n)+ replicateM m $ two arbitraryQueryArg++multiLists :: String -> Gen (Int, URLEncoded)+multiLists k = sized $ \n -> do+ m <- choose (2, 2 + n)+ let getP = (k %=) <$> arbitraryQueryArg+ us <- sequence $ intersperse getP $ replicate m arbitrary+ return (m, mconcat us)++badKey :: URLEncoded -> String+badKey u = 'x':concat (keys u)++main :: IO ()+main = mapM_ quickCheck+ [ property $ \u ->+ importString (export u) == (Right u :: Either String URLEncoded)++ , property $ \u ->+ let s = export u+ expected = Right s :: Either String String+ in (export `liftM` importString s) == expected++ , property $ \u1 u2 ->+ not (U.null u1 || U.null u2) ==>+ (export u1 ++ "&" ++ export u2) == export (u1 %& u2)++ , property $ all isAllowedInURI . export++ , property $ \u1 u2 -> (u1 %? u2) == (u1 %& u2)++ , property $ \u ->+ forAll httpUri $ \uri -> (show (uri %? u)) == (show uri %? u)++ , forAll (two arbitraryQueryArg) $ \(a, b) -> pairs (a %= b) == [(a, b)]++ , forAll pairLists $ \l -> map fst l == keys (importList l)++ , property $ \u -> urlEncode u == u++ , property $ \m ->+ urlEncode (m :: Maybe URLEncoded) == maybe empty urlEncode m++ , property $ \m ->+ "x" %=? m == maybe empty ("x" %=) (m :: Maybe Int)++ , property $ \u -> show u == export u++ , property $ \u -> all (\k -> isJust (u %! k)) $ keys u++ , property $ \u -> (u %! badKey u) == Nothing++ , property $ \u -> lookupDefault "missing" (badKey u) u == "missing"++ , forAll (multiLists "repeated") $ \(_, u) -> isJust (u %! "repeated")++ , forAll (multiLists "repeated") $ \(_, u) ->+ length (lookupAll "repeated" u) > 0++ , property $ \u -> case lookup1 (badKey u) u :: Either String String of+ Left _ -> True+ Right _ -> False+ ]
urlencoded.cabal view
@@ -1,6 +1,6 @@ name: urlencoded Cabal-Version: >= 1.6-version: 0.0+version: 0.1 synopsis: Generate or process x-www-urlencoded data description: Generate or process x-www-urlencoded data as it@@ -14,8 +14,22 @@ license-file: LICENSE author: Josh Hoyt maintainer: joshhoyt@gmail.com-build-depends: base == 4.*, network == 2.2.*, mtl, split == 0.1.*-build-type: Simple-ghc-options: -Wall-hs-source-dirs: src-exposed-modules: Data.URLEncoded+build-type: Custom+Library+ build-depends: base == 4.*, network == 2.2.*, mtl, split == 0.1.*+ ghc-options: -Wall+ hs-source-dirs: src+ exposed-modules: Data.URLEncoded++-- This executable is not installed by the (custom) Setup program. It is+-- used by the test hook (cabal test)+Executable test+ build-depends:+ base == 4.*,+ network == 2.2.*,+ mtl,+ QuickCheck >= 1.2 && < 1.3,+ split == 0.1.*+ GHC-Options: -Wall+ Main-is: TestDriver.hs+ HS-Source-Dirs: src, test