http-api-data 0.2.4 → 0.3

raw patch · 14 files changed

+1631/−710 lines, 14 filesdep +containersdep +hashabledep +unordered-containersdep ~basedep ~bytestringdep ~text

Dependencies added: containers, hashable, unordered-containers, uri-bytestring

Dependency ranges changed: base, bytestring, text, time

Files

• CHANGELOG.md +8/−0
• README.md +3/−1
• http-api-data.cabal +21/−5
• include/overlapping-compat.h +8/−0
• src/Web/FormUrlEncoded.hs +41/−0
• src/Web/HttpApiData.hs +2/−2
• src/Web/HttpApiData/Internal.hs +0/−570
• src/Web/Internal/FormUrlEncoded.hs +714/−0
• src/Web/Internal/HttpApiData.hs +579/−0
• test/DocTest.hs +1/−0
• test/Spec.hs +1/−132
• test/Web/Internal/FormUrlEncodedSpec.hs +69/−0
• test/Web/Internal/HttpApiDataSpec.hs +82/−0
• test/Web/Internal/TestInstances.hs +102/−0

@@ -1,3 +1,11 @@+0.3+---+* Major changes:+    * Add `Web.FormUrlEncoded` to work with form data (see [#32](https://github.com/fizruk/http-api-data/pull/32)).++* Minor changes:+    * Add instances for `Numeric.Natural` (see [`d944721`](https://github.com/fizruk/http-api-data/commit/d944721ac94929a7ed9e66f25e23221799c08d83)).+ 0.2.4 --- * Make `parseHeader` total (instead of throwing exceptions on invalid Unicode, see [#30](https://github.com/fizruk/http-api-data/pull/30)).

@@ -1,7 +1,9 @@ # http-api-data -[![Hackage package](http://img.shields.io/hackage/v/http-api-data.svg)](http://hackage.haskell.org/package/http-api-data) [![Build Status](https://secure.travis-ci.org/fizruk/http-api-data.png?branch=master)](http://travis-ci.org/fizruk/http-api-data)+[![Hackage package](http://img.shields.io/hackage/v/http-api-data.svg)](http://hackage.haskell.org/package/http-api-data)+[![Stackage LTS](http://stackage.org/package/http-api-data/badge/lts)](http://stackage.org/lts/package/http-api-data)+[![Stackage Nightly](http://stackage.org/package/http-api-data/badge/nightly)](http://stackage.org/nightly/package/http-api-data)  This package defines typeclasses used for converting Haskell data types to and from HTTP API data. 

@@ -1,5 +1,5 @@ name:            http-api-data-version:         0.2.4+version:         0.3 license:         BSD3 license-file:    LICENSE author:          Nickolay Kudasov <nickolay.kudasov@gmail.com>@@ -9,9 +9,10 @@ homepage:        http://github.com/fizruk/http-api-data category:        Web stability:       unstable-cabal-version:   >= 1.8+cabal-version:   >= 1.10 build-type:      Custom extra-source-files:+  include/overlapping-compat.h   test/*.hs   CHANGELOG.md   README.md@@ -22,28 +23,43 @@  library     hs-source-dirs: src/+    include-dirs:   include/     build-depends:   base               >= 4.6    && < 4.10-                   , text               >= 0.5                    , bytestring+                   , containers+                   , hashable+                   , text               >= 0.5                    , time                    , time-locale-compat >=0.1.1.0 && <0.2+                   , unordered-containers+                   , uri-bytestring     if flag(use-text-show)       cpp-options: -DUSE_TEXT_SHOW       build-depends: text-show        >= 2     exposed-modules:       Web.HttpApiData-      Web.HttpApiData.Internal+      Web.FormUrlEncoded+      Web.Internal.FormUrlEncoded+      Web.Internal.HttpApiData     ghc-options:     -Wall+    default-language: Haskell2010  test-suite spec     type:          exitcode-stdio-1.0     main-is:       Spec.hs-    hs-source-dirs: test/+    other-modules:+      Web.Internal.FormUrlEncodedSpec+      Web.Internal.HttpApiDataSpec+      Web.Internal.TestInstances+    hs-source-dirs: test     ghc-options:   -Wall+    default-language: Haskell2010     build-depends:   HUnit                    , hspec >= 1.3                    , base >= 4 && < 5+                   , bytestring                    , QuickCheck+                   , unordered-containers                    , http-api-data                    , text                    , time

@@ -0,0 +1,8 @@+#if __GLASGOW_HASKELL__ >= 710+#define OVERLAPPABLE_ {-# OVERLAPPABLE #-}+#define OVERLAPPING_  {-# OVERLAPPING #-}+#else+{-# LANGUAGE OverlappingInstances #-}+#define OVERLAPPABLE_+#define OVERLAPPING_+#endif

@@ -0,0 +1,41 @@+-- |+-- Convert Haskell values to and from @application/xxx-form-urlencoded@ format.+module Web.FormUrlEncoded (+  -- * Classes+  ToForm (..),+  FromForm (..),++  -- ** Keys for 'Form' entries+  ToFormKey(..),+  FromFormKey(..),++  -- * Encoding and decoding @'Form'@s+  urlEncodeAsForm,+  urlDecodeAsForm,++  urlEncodeForm,+  urlDecodeForm,++  -- * 'Generic's+  genericToForm,+  genericFromForm,++  -- ** Encoding options+  FormOptions(..),+  defaultFormOptions,++  -- * Helpers+  toEntriesByKey,+  fromEntriesByKey,++  lookupAll,+  lookupMaybe,+  lookupUnique,++  parseAll,+  parseMaybe,+  parseUnique,+) where++import Web.Internal.FormUrlEncoded+

@@ -40,7 +40,7 @@   readTextData, ) where -import Web.HttpApiData.Internal+import Web.Internal.HttpApiData  -- $setup --@@ -69,7 +69,7 @@ -- "45.2" -- >>> parseQueryParam "452" :: Either Text Int -- Right 452--- >>> toQueryParams [1..5]+-- >>> toQueryParams [1..5] :: [Text] -- ["1","2","3","4","5"] -- >>> parseQueryParams ["127", "255"] :: Either Text [Int8] -- Left "out of bounds: `255' (should be between -128 and 127)"

@@ -1,570 +0,0 @@-{-# LANGUAGE CPP #-}-{-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeSynonymInstances #-}--- |--- Convert Haskell values to and from HTTP API data--- such as URL pieces, headers and query parameters.-module Web.HttpApiData.Internal where--#if __GLASGOW_HASKELL__ < 710-import Control.Applicative-import Data.Traversable (Traversable(traverse))-#endif-import Control.Arrow ((&&&), left)-import Control.Monad ((<=<))--import Data.Monoid-import Data.ByteString (ByteString)-import qualified Data.ByteString as BS--import Data.Int-import Data.Word--import Data.Text (Text)-import Data.Text.Encoding (encodeUtf8, decodeUtf8')-import Data.Text.Read (signed, decimal, rational, Reader)-import qualified Data.Text as T-import qualified Data.Text.Lazy as L--import Data.Time.Locale.Compat-import Data.Time-import Data.Version--#if MIN_VERSION_base(4,8,0)-import Data.Void-#endif--import Text.Read (readMaybe)-import Text.ParserCombinators.ReadP (readP_to_S)--#if USE_TEXT_SHOW-import TextShow (TextShow, showt)-#endif---- | Convert value to HTTP API data.------ __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated--- instance will loop indefinitely.-class ToHttpApiData a where-  {-# MINIMAL toUrlPiece | toQueryParam #-}-  -- | Convert to URL path piece.-  toUrlPiece :: a -> Text-  toUrlPiece = toQueryParam--  -- | Convert to HTTP header value.-  toHeader :: a -> ByteString-  toHeader = encodeUtf8 . toUrlPiece--  -- | Convert to query param value.-  toQueryParam :: a -> Text-  toQueryParam = toUrlPiece---- | Parse value from HTTP API data.------ __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated--- instance will loop indefinitely.-class FromHttpApiData a where-  {-# MINIMAL parseUrlPiece | parseQueryParam #-}-  -- | Parse URL path piece.-  parseUrlPiece :: Text -> Either Text a-  parseUrlPiece = parseQueryParam--  -- | Parse HTTP header value.-  parseHeader :: ByteString -> Either Text a-  parseHeader = parseUrlPiece <=< (left (T.pack . show) . decodeUtf8')--  -- | Parse query param value.-  parseQueryParam :: Text -> Either Text a-  parseQueryParam = parseUrlPiece---- | Convert multiple values to a list of URL pieces.------ >>> toUrlPieces [1, 2, 3]--- ["1","2","3"]-toUrlPieces :: (Functor t, ToHttpApiData a) => t a -> t Text-toUrlPieces = fmap toUrlPiece---- | Parse multiple URL pieces.------ >>> parseUrlPieces ["true", "false"] :: Either Text [Bool]--- Right [True,False]--- >>> parseUrlPieces ["123", "hello", "world"] :: Either Text [Int]--- Left "could not parse: `hello' (input does not start with a digit)"-parseUrlPieces :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)-parseUrlPieces = traverse parseUrlPiece---- | Convert multiple values to a list of query parameter values.------ >>> toQueryParams [fromGregorian 2015 10 03, fromGregorian 2015 12 01]--- ["2015-10-03","2015-12-01"]-toQueryParams :: (Functor t, ToHttpApiData a) => t a -> t Text-toQueryParams = fmap toQueryParam---- | Parse multiple query parameters.------ >>> parseQueryParams ["1", "2", "3"] :: Either Text [Int]--- Right [1,2,3]--- >>> parseQueryParams ["64", "128", "256"] :: Either Text [Word8]--- Left "out of bounds: `256' (should be between 0 and 255)"-parseQueryParams :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)-parseQueryParams = traverse parseQueryParam---- | Parse URL path piece in a @'Maybe'@.------ >>> parseUrlPieceMaybe "12" :: Maybe Int--- Just 12-parseUrlPieceMaybe :: FromHttpApiData a => Text -> Maybe a-parseUrlPieceMaybe = either (const Nothing) Just . parseUrlPiece---- | Parse HTTP header value in a @'Maybe'@.------ >>> parseHeaderMaybe "hello" :: Maybe Text--- Just "hello"-parseHeaderMaybe :: FromHttpApiData a => ByteString -> Maybe a-parseHeaderMaybe = either (const Nothing) Just . parseHeader---- | Parse query param value in a @'Maybe'@.------ >>> parseQueryParamMaybe "true" :: Maybe Bool--- Just True-parseQueryParamMaybe :: FromHttpApiData a => Text -> Maybe a-parseQueryParamMaybe = either (const Nothing) Just . parseQueryParam---- | Default parsing error.-defaultParseError :: Text -> Either Text a-defaultParseError input = Left ("could not parse: `" <> input <> "'")---- | Convert @'Maybe'@ parser into @'Either' 'Text'@ parser with default error message.-parseMaybeTextData :: (Text -> Maybe a) -> (Text -> Either Text a)-parseMaybeTextData parse input =-  case parse input of-    Nothing  -> defaultParseError input-    Just val -> Right val--#if USE_TEXT_SHOW--- | /Lower case/.------ Convert to URL piece using @'TextShow'@ instance.--- The result is always lower cased.------ >>> showTextData True--- "true"------ This can be used as a default implementation for enumeration types:------ @--- data MyData = Foo | Bar | Baz deriving (Generic)--- --- instance TextShow MyData where---   showt = genericShowt------ instance ToHttpApiData MyData where---   toUrlPiece = showTextData--- @-showTextData :: TextShow a => a -> Text-showTextData = T.toLower . showt-#else--- | /Lower case/.------ Convert to URL piece using @'Show'@ instance.--- The result is always lower cased.------ >>> showTextData True--- "true"------ This can be used as a default implementation for enumeration types:------ >>> data MyData = Foo | Bar | Baz deriving (Show)--- >>> instance ToHttpApiData MyData where toUrlPiece = showTextData--- >>> toUrlPiece Foo--- "foo"-showTextData :: Show a => a -> Text-showTextData = T.toLower . showt---- | Like @'show'@, but returns @'Text'@.-showt :: Show a => a -> Text-showt = T.pack . show-#endif---- | /Case insensitive/.------ Parse given text case insensitive and then parse the rest of the input--- using @'parseUrlPiece'@.------ >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int--- Right 10--- >>> parseUrlPieceWithPrefix "Left " "left" :: Either Text Bool--- Left "could not parse: `left'"------ This can be used to implement @'FromHttpApiData'@ for single field constructors:------ >>> data Foo = Foo Int deriving (Show)--- >>> instance FromHttpApiData Foo where parseUrlPiece s = Foo <$> parseUrlPieceWithPrefix "Foo " s--- >>> parseUrlPiece "foo 1" :: Either Text Foo--- Right (Foo 1)-parseUrlPieceWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a-parseUrlPieceWithPrefix pattern input-  | T.toLower pattern == T.toLower prefix = parseUrlPiece rest-  | otherwise                             = defaultParseError input-  where-    (prefix, rest) = T.splitAt (T.length pattern) input---- $setup--- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)--- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p---- | Parse given bytestring then parse the rest of the input using @'parseHeader'@.------ @--- data BasicAuthToken = BasicAuthToken Text deriving (Show)------ instance FromHttpApiData BasicAuthToken where---   parseHeader h     = BasicAuthToken \<$\> parseHeaderWithPrefix "Basic " h---   parseQueryParam p = BasicAuthToken \<$\> parseQueryParam p--- @------ >>> parseHeader "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" :: Either Text BasicAuthToken--- Right (BasicAuthToken "QWxhZGRpbjpvcGVuIHNlc2FtZQ==")-parseHeaderWithPrefix :: FromHttpApiData a => ByteString -> ByteString -> Either Text a-parseHeaderWithPrefix pattern input-  | pattern `BS.isPrefixOf` input = parseHeader (BS.drop (BS.length pattern) input)-  | otherwise                     = defaultParseError (showt input)---- | /Case insensitive/.------ Parse given text case insensitive and then parse the rest of the input--- using @'parseQueryParam'@.------ >>> parseQueryParamWithPrefix "z" "z10" :: Either Text Int--- Right 10-parseQueryParamWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a-parseQueryParamWithPrefix pattern input-  | T.toLower pattern == T.toLower prefix = parseQueryParam rest-  | otherwise                             = defaultParseError input-  where-    (prefix, rest) = T.splitAt (T.length pattern) input--#if USE_TEXT_SHOW--- | /Case insensitive/.------ Parse values case insensitively based on @'TextShow'@ instance.------ >>> parseBoundedTextData "true" :: Either Text Bool--- Right True--- >>> parseBoundedTextData "FALSE" :: Either Text Bool--- Right False------ This can be used as a default implementation for enumeration types:------ @--- data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum, Generic)------ instance TextShow MyData where---   showt = genericShowt------ instance FromHttpApiData MyData where---   parseUrlPiece = parseBoundedTextData--- @-parseBoundedTextData :: (TextShow a, Bounded a, Enum a) => Text -> Either Text a-#else--- | /Case insensitive/.------ Parse values case insensitively based on @'Show'@ instance.------ >>> parseBoundedTextData "true" :: Either Text Bool--- Right True--- >>> parseBoundedTextData "FALSE" :: Either Text Bool--- Right False------ This can be used as a default implementation for enumeration types:------ >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum)--- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedTextData--- >>> parseUrlPiece "foo" :: Either Text MyData--- Right Foo-parseBoundedTextData :: (Show a, Bounded a, Enum a) => Text -> Either Text a-#endif-parseBoundedTextData = parseBoundedEnumOfI showTextData---- | Lookup values based on a precalculated mapping of their representations.-lookupBoundedEnumOf :: (Bounded a, Enum a, Eq b) => (a -> b) -> b -> Maybe a-lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])---- | Parse values based on a precalculated mapping of their @'Text'@ representation.------ >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool--- Right True------ For case sensitive parser see 'parseBoundedEnumOfI'.-parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a-parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf---- | /Case insensitive/.------ Parse values case insensitively based on a precalculated mapping--- of their @'Text'@ representations.------ >>> parseBoundedEnumOfI toUrlPiece "FALSE" :: Either Text Bool--- Right False------ For case sensitive parser see 'parseBoundedEnumOf'.-parseBoundedEnumOfI :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a-parseBoundedEnumOfI f = parseBoundedEnumOf (T.toLower . f) . T.toLower---- | /Case insensitive/.------ Parse values case insensitively based on @'ToHttpApiData'@ instance.--- Uses @'toUrlPiece'@ to get possible values.-parseBoundedUrlPiece :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a-parseBoundedUrlPiece = parseBoundedEnumOfI toUrlPiece---- | /Case insensitive/.------ Parse values case insensitively based on @'ToHttpApiData'@ instance.--- Uses @'toQueryParam'@ to get possible values.-parseBoundedQueryParam :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a-parseBoundedQueryParam = parseBoundedEnumOfI toQueryParam---- | Parse values based on @'ToHttpApiData'@ instance.--- Uses @'toHeader'@ to get possible values.-parseBoundedHeader :: (ToHttpApiData a, Bounded a, Enum a) => ByteString -> Either Text a-parseBoundedHeader bs = case lookupBoundedEnumOf toHeader bs of-  Nothing -> defaultParseError $ T.pack $ show bs-  Just x  -> return x---- | Parse URL piece using @'Read'@ instance.------ Use for types which do not involve letters:------ >>> readTextData "1991-06-02" :: Either Text Day--- Right 1991-06-02------ This parser is case sensitive and will not match @'showTextData'@--- in presense of letters:------ >>> readTextData (showTextData True) :: Either Text Bool--- Left "could not parse: `true'"------ See @'parseBoundedTextData'@.-readTextData :: Read a => Text -> Either Text a-readTextData = parseMaybeTextData (readMaybe . T.unpack)---- | Run @'Reader'@ as HTTP API data parser.-runReader :: Reader a -> Text -> Either Text a-runReader reader input =-  case reader input of-    Left err          -> Left ("could not parse: `" <> input <> "' (" <> T.pack err <> ")")-    Right (x, rest)-      | T.null rest -> Right x-      | otherwise   -> defaultParseError input---- | Run @'Reader'@ to parse bounded integral value with bounds checking.------ >>> parseBounded decimal "256" :: Either Text Word8--- Left "out of bounds: `256' (should be between 0 and 255)"-parseBounded :: forall a. (Bounded a, Integral a) => Reader Integer -> Text -> Either Text a-parseBounded reader input = do-  n <- runReader reader input-  if (n > h || n < l)-    then Left  ("out of bounds: `" <> input <> "' (should be between " <> showt l <> " and " <> showt h <> ")")-    else Right (fromInteger n)-  where-    l = toInteger (minBound :: a)-    h = toInteger (maxBound :: a)---- |--- >>> toUrlPiece ()--- "_"-instance ToHttpApiData () where-  toUrlPiece () = "_"--instance ToHttpApiData Char     where toUrlPiece = T.singleton---- |--- >>> toUrlPiece (Version [1, 2, 3] [])--- "1.2.3"-instance ToHttpApiData Version where-  toUrlPiece = T.pack . showVersion--#if MIN_VERSION_base(4,8,0)-instance ToHttpApiData Void where-  toUrlPiece = absurd-#endif--instance ToHttpApiData Bool     where toUrlPiece = showTextData-instance ToHttpApiData Ordering where toUrlPiece = showTextData--instance ToHttpApiData Double   where toUrlPiece = showt-instance ToHttpApiData Float    where toUrlPiece = showt-instance ToHttpApiData Int      where toUrlPiece = showt-instance ToHttpApiData Int8     where toUrlPiece = showt-instance ToHttpApiData Int16    where toUrlPiece = showt-instance ToHttpApiData Int32    where toUrlPiece = showt-instance ToHttpApiData Int64    where toUrlPiece = showt-instance ToHttpApiData Integer  where toUrlPiece = showt-instance ToHttpApiData Word     where toUrlPiece = showt-instance ToHttpApiData Word8    where toUrlPiece = showt-instance ToHttpApiData Word16   where toUrlPiece = showt-instance ToHttpApiData Word32   where toUrlPiece = showt-instance ToHttpApiData Word64   where toUrlPiece = showt---- |--- >>> toUrlPiece (fromGregorian 2015 10 03)--- "2015-10-03"-instance ToHttpApiData Day      where toUrlPiece = T.pack . show--timeToUrlPiece :: FormatTime t => String -> t -> Text-timeToUrlPiece fmt = T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just fmt))---- |--- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 01)--- "2015-10-03T14:55:01"-instance ToHttpApiData LocalTime where toUrlPiece = timeToUrlPiece "%H:%M:%S"---- |--- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 01)) utc--- "2015-10-03T14:55:01+0000"-instance ToHttpApiData ZonedTime where toUrlPiece = timeToUrlPiece "%H:%M:%S%z"---- |--- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864--- "2015-10-03T00:14:24Z"-instance ToHttpApiData UTCTime   where toUrlPiece = timeToUrlPiece "%H:%M:%SZ"--instance ToHttpApiData NominalDiffTime where toUrlPiece = toUrlPiece . (floor :: NominalDiffTime -> Integer)--instance ToHttpApiData String   where toUrlPiece = T.pack-instance ToHttpApiData Text     where toUrlPiece = id-instance ToHttpApiData L.Text   where toUrlPiece = L.toStrict--instance ToHttpApiData All where toUrlPiece = toUrlPiece . getAll-instance ToHttpApiData Any where toUrlPiece = toUrlPiece . getAny--instance ToHttpApiData a => ToHttpApiData (Dual a)    where toUrlPiece = toUrlPiece . getDual-instance ToHttpApiData a => ToHttpApiData (Sum a)     where toUrlPiece = toUrlPiece . getSum-instance ToHttpApiData a => ToHttpApiData (Product a) where toUrlPiece = toUrlPiece . getProduct-instance ToHttpApiData a => ToHttpApiData (First a)   where toUrlPiece = toUrlPiece . getFirst-instance ToHttpApiData a => ToHttpApiData (Last a)    where toUrlPiece = toUrlPiece . getLast---- |--- >>> toUrlPiece (Just "Hello")--- "just Hello"-instance ToHttpApiData a => ToHttpApiData (Maybe a) where-  toUrlPiece (Just x) = "just " <> toUrlPiece x-  toUrlPiece Nothing  = "nothing"---- |--- >>> toUrlPiece (Left "err" :: Either String Int)--- "left err"--- >>> toUrlPiece (Right 3 :: Either String Int)--- "right 3"-instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where-  toUrlPiece (Left x)  = "left " <> toUrlPiece x-  toUrlPiece (Right x) = "right " <> toUrlPiece x---- |--- >>> parseUrlPiece "_" :: Either Text ()--- Right ()-instance FromHttpApiData () where-  parseUrlPiece "_" = pure ()-  parseUrlPiece s   = defaultParseError s--instance FromHttpApiData Char where-  parseUrlPiece s =-    case T.uncons s of-      Just (c, s') | T.null s' -> pure c-      _                        -> defaultParseError s---- |--- >>> showVersion <$> parseUrlPiece "1.2.3"--- Right "1.2.3"-instance FromHttpApiData Version where-  parseUrlPiece s =-    case reverse (readP_to_S parseVersion (T.unpack s)) of-      ((x, ""):_) -> pure x-      _           -> defaultParseError s--#if MIN_VERSION_base(4,8,0)--- | Parsing a @'Void'@ value is always an error, considering @'Void'@ as a data type with no constructors.-instance FromHttpApiData Void where-  parseUrlPiece _ = Left "Void cannot be parsed!"-#endif--instance FromHttpApiData Bool     where parseUrlPiece = parseBoundedUrlPiece-instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece-instance FromHttpApiData Double   where parseUrlPiece = runReader rational-instance FromHttpApiData Float    where parseUrlPiece = runReader rational-instance FromHttpApiData Int      where parseUrlPiece = parseBounded (signed decimal)-instance FromHttpApiData Int8     where parseUrlPiece = parseBounded (signed decimal)-instance FromHttpApiData Int16    where parseUrlPiece = parseBounded (signed decimal)-instance FromHttpApiData Int32    where parseUrlPiece = parseBounded (signed decimal)-instance FromHttpApiData Int64    where parseUrlPiece = parseBounded (signed decimal)-instance FromHttpApiData Integer  where parseUrlPiece = runReader (signed decimal)-instance FromHttpApiData Word     where parseUrlPiece = parseBounded decimal-instance FromHttpApiData Word8    where parseUrlPiece = parseBounded decimal-instance FromHttpApiData Word16   where parseUrlPiece = parseBounded decimal-instance FromHttpApiData Word32   where parseUrlPiece = parseBounded decimal-instance FromHttpApiData Word64   where parseUrlPiece = parseBounded decimal-instance FromHttpApiData String   where parseUrlPiece = Right . T.unpack-instance FromHttpApiData Text     where parseUrlPiece = Right-instance FromHttpApiData L.Text   where parseUrlPiece = Right . L.fromStrict---- |--- >>> toGregorian <$> parseUrlPiece "2016-12-01"--- Right (2016,12,1)-instance FromHttpApiData Day      where parseUrlPiece = readTextData--timeParseUrlPiece :: ParseTime t => String -> Text -> Either Text t-timeParseUrlPiece fmt = parseMaybeTextData (timeParseUrlPieceMaybe . T.unpack)-  where-    timeParseUrlPieceMaybe = parseTime defaultTimeLocale (iso8601DateFormat (Just fmt))---- |--- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime--- Right 2015-10-03 14:55:01-instance FromHttpApiData LocalTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%S"---- |--- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime--- Right 2015-10-03 14:55:01 +0000-instance FromHttpApiData ZonedTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%S%z"---- |--- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime--- Right 2015-10-03 00:14:24 UTC-instance FromHttpApiData UTCTime   where parseUrlPiece = timeParseUrlPiece "%H:%M:%SZ"--instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap fromInteger . parseUrlPiece--instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece-instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece--instance FromHttpApiData a => FromHttpApiData (Dual a)    where parseUrlPiece = fmap Dual    . parseUrlPiece-instance FromHttpApiData a => FromHttpApiData (Sum a)     where parseUrlPiece = fmap Sum     . parseUrlPiece-instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = fmap Product . parseUrlPiece-instance FromHttpApiData a => FromHttpApiData (First a)   where parseUrlPiece = fmap First   . parseUrlPiece-instance FromHttpApiData a => FromHttpApiData (Last a)    where parseUrlPiece = fmap Last    . parseUrlPiece---- |--- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)--- Right (Just 123)-instance FromHttpApiData a => FromHttpApiData (Maybe a) where-  parseUrlPiece s-    | T.toLower (T.take 7 s) == "nothing" = pure Nothing-    | otherwise                           = Just <$> parseUrlPieceWithPrefix "Just " s---- |--- >>> parseUrlPiece "Right 123" :: Either Text (Either String Int)--- Right (Right 123)-instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b) where-  parseUrlPiece s =-        Right <$> parseUrlPieceWithPrefix "Right " s-    <!> Left  <$> parseUrlPieceWithPrefix "Left " s-    where-      infixl 3 <!>-      Left _ <!> y = y-      x      <!> _ = x-

@@ -0,0 +1,714 @@+{-# LANGUAGE ConstraintKinds            #-}+{-# LANGUAGE CPP                        #-}+{-# LANGUAGE DataKinds                  #-}+{-# LANGUAGE DefaultSignatures          #-}+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE FlexibleContexts           #-}+{-# LANGUAGE FlexibleInstances          #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE KindSignatures             #-}+{-# LANGUAGE MultiParamTypeClasses      #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE PolyKinds                  #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TypeFamilies               #-}+{-# LANGUAGE TypeOperators              #-}+{-# LANGUAGE UndecidableInstances       #-}+#include "overlapping-compat.h"+module Web.Internal.FormUrlEncoded where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+import Data.Traversable+#endif+++import           Control.Arrow              ((***))+import           Control.Monad              ((<=<))+import           Data.ByteString.Builder    (toLazyByteString, shortByteString)+import qualified Data.ByteString.Lazy       as BSL+import qualified Data.ByteString.Lazy.Char8 as BSL8+import qualified Data.Foldable              as F+import           Data.Hashable              (Hashable)+import           Data.HashMap.Strict        (HashMap)+import qualified Data.HashMap.Strict        as HashMap+import           Data.Int+import           Data.IntMap                (IntMap)+import qualified Data.IntMap                as IntMap+import           Data.List                  (intersperse)+import           Data.Map                   (Map)+import qualified Data.Map                   as Map+import           Data.Monoid++import           Data.Text                  (Text)+import qualified Data.Text                  as Text+import qualified Data.Text.Lazy             as Lazy+import           Data.Text.Encoding         as Text+import           Data.Text.Encoding.Error   (lenientDecode)++import           Data.Time+import           Data.Proxy+import           Data.Word++#if MIN_VERSION_base(4,8,0)+import Data.Void+import Numeric.Natural+#endif++import           GHC.Exts                   (IsList (..), Constraint)+import           GHC.Generics+import           GHC.TypeLits+import           URI.ByteString             (urlEncodeQuery, urlDecodeQuery)++import Web.Internal.HttpApiData++-- $setup+-- >>> :set -XDeriveGeneric+-- >>> :set -XOverloadedLists+-- >>> :set -XOverloadedStrings+-- >>> :set -XFlexibleContexts+-- >>> :set -XScopedTypeVariables+-- >>> :set -XTypeFamilies+-- >>> import Data.Char (toLower)+--+-- >>> data Person = Person { name :: String, age :: Int } deriving (Show, Generic)+-- >>> instance ToForm Person+-- >>> instance FromForm Person+--+-- >>> data Post = Post { title :: String, subtitle :: Maybe String, comments :: [String]} deriving (Generic, Show)+-- >>> instance ToForm Post+-- >>> instance FromForm Post+--+-- >>> data Project = Project { projectName :: String, projectSize :: Int } deriving (Generic, Show)+-- >>> let myOptions = FormOptions { fieldLabelModifier = map toLower . drop (length ("project" :: String)) }+-- >>> instance ToForm Project where toForm = genericToForm myOptions+-- >>> instance FromForm Project where fromForm = genericFromForm myOptions++-- | Typeclass for types that can be used as keys in a 'Form'-like container (like 'Map').+class ToFormKey k where+  -- | Render a key for a 'Form'.+  toFormKey :: k -> Text++instance ToFormKey ()       where toFormKey = toQueryParam+instance ToFormKey Char     where toFormKey = toQueryParam++instance ToFormKey Bool     where toFormKey = toQueryParam+instance ToFormKey Ordering where toFormKey = toQueryParam++instance ToFormKey Double   where toFormKey = toQueryParam+instance ToFormKey Float    where toFormKey = toQueryParam+instance ToFormKey Int      where toFormKey = toQueryParam+instance ToFormKey Int8     where toFormKey = toQueryParam+instance ToFormKey Int16    where toFormKey = toQueryParam+instance ToFormKey Int32    where toFormKey = toQueryParam+instance ToFormKey Int64    where toFormKey = toQueryParam+instance ToFormKey Integer  where toFormKey = toQueryParam+instance ToFormKey Word     where toFormKey = toQueryParam+instance ToFormKey Word8    where toFormKey = toQueryParam+instance ToFormKey Word16   where toFormKey = toQueryParam+instance ToFormKey Word32   where toFormKey = toQueryParam+instance ToFormKey Word64   where toFormKey = toQueryParam++instance ToFormKey Day              where toFormKey = toQueryParam+instance ToFormKey LocalTime        where toFormKey = toQueryParam+instance ToFormKey ZonedTime        where toFormKey = toQueryParam+instance ToFormKey UTCTime          where toFormKey = toQueryParam+instance ToFormKey NominalDiffTime  where toFormKey = toQueryParam++instance ToFormKey String     where toFormKey = toQueryParam+instance ToFormKey Text       where toFormKey = toQueryParam+instance ToFormKey Lazy.Text  where toFormKey = toQueryParam++instance ToFormKey All where toFormKey = toQueryParam+instance ToFormKey Any where toFormKey = toQueryParam++instance ToFormKey a => ToFormKey (Dual a)    where toFormKey = toFormKey . getDual+instance ToFormKey a => ToFormKey (Sum a)     where toFormKey = toFormKey . getSum+instance ToFormKey a => ToFormKey (Product a) where toFormKey = toFormKey . getProduct++#if MIN_VERSION_base(4,8,0)+instance ToFormKey Void     where toFormKey = toQueryParam+instance ToFormKey Natural  where toFormKey = toQueryParam+#endif++-- | Typeclass for types that can be parsed from keys of a 'Form'. This is the reverse of 'ToFormKey'.+class FromFormKey k where+  -- | Parse a key of a 'Form'.+  parseFormKey :: Text -> Either Text k++instance FromFormKey ()       where parseFormKey = parseQueryParam+instance FromFormKey Char     where parseFormKey = parseQueryParam++instance FromFormKey Bool     where parseFormKey = parseQueryParam+instance FromFormKey Ordering where parseFormKey = parseQueryParam++instance FromFormKey Double   where parseFormKey = parseQueryParam+instance FromFormKey Float    where parseFormKey = parseQueryParam+instance FromFormKey Int      where parseFormKey = parseQueryParam+instance FromFormKey Int8     where parseFormKey = parseQueryParam+instance FromFormKey Int16    where parseFormKey = parseQueryParam+instance FromFormKey Int32    where parseFormKey = parseQueryParam+instance FromFormKey Int64    where parseFormKey = parseQueryParam+instance FromFormKey Integer  where parseFormKey = parseQueryParam+instance FromFormKey Word     where parseFormKey = parseQueryParam+instance FromFormKey Word8    where parseFormKey = parseQueryParam+instance FromFormKey Word16   where parseFormKey = parseQueryParam+instance FromFormKey Word32   where parseFormKey = parseQueryParam+instance FromFormKey Word64   where parseFormKey = parseQueryParam++instance FromFormKey Day              where parseFormKey = parseQueryParam+instance FromFormKey LocalTime        where parseFormKey = parseQueryParam+instance FromFormKey ZonedTime        where parseFormKey = parseQueryParam+instance FromFormKey UTCTime          where parseFormKey = parseQueryParam+instance FromFormKey NominalDiffTime  where parseFormKey = parseQueryParam++instance FromFormKey String     where parseFormKey = parseQueryParam+instance FromFormKey Text       where parseFormKey = parseQueryParam+instance FromFormKey Lazy.Text  where parseFormKey = parseQueryParam++instance FromFormKey All where parseFormKey = parseQueryParam+instance FromFormKey Any where parseFormKey = parseQueryParam++instance FromFormKey a => FromFormKey (Dual a)    where parseFormKey = fmap Dual . parseFormKey+instance FromFormKey a => FromFormKey (Sum a)     where parseFormKey = fmap Sum . parseFormKey+instance FromFormKey a => FromFormKey (Product a) where parseFormKey = fmap Product . parseFormKey++#if MIN_VERSION_base(4,8,0)+instance FromFormKey Void     where parseFormKey = parseQueryParam+instance FromFormKey Natural  where parseFormKey = parseQueryParam+#endif++-- | The contents of a form, not yet URL-encoded.+--+-- 'Form' can be URL-encoded with 'urlEncodeForm' and URL-decoded with 'urlDecodeForm'.+newtype Form = Form { unForm :: HashMap Text [Text] }+  deriving (Eq, Read, Generic, Monoid)++instance Show Form where+  showsPrec d form = showParen (d > 10) $+    showString "fromList " . shows (toList form)++instance IsList Form where+  type Item Form = (Text, Text)+  fromList = Form . HashMap.fromListWith (flip (<>)) . fmap (\(k, v) -> (k, [v]))+  toList = concatMap (\(k, vs) -> map ((,) k) vs) . HashMap.toList . unForm++-- | Convert a value into 'Form'.+--+-- An example type and instance:+--+-- @+-- {-\# LANGUAGE OverloadedLists \#-}+--+-- data Person = Person+--   { name :: String+--   , age  :: Int }+--+-- instance 'ToForm' Person where+--   'toForm' person =+--     [ (\"name\", 'toQueryParam' (name person))+--     , (\"age\", 'toQueryParam' (age person)) ]+-- @+--+-- Instead of manually writing @'ToForm'@ instances you can+-- use a default generic implementation of @'toForm'@.+--+-- To do that, simply add @deriving 'Generic'@ clause to your datatype+-- and declare a 'ToForm' instance for your datatype without+-- giving definition for 'toForm'.+--+-- For instance, the previous example can be simplified into this:+--+-- @+-- data Person = Person+--   { name :: String+--   , age  :: Int+--   } deriving ('Generic')+--+-- instance 'ToForm' Person+-- @+--+-- The default implementation of 'toForm' is 'genericToForm'.+class ToForm a where+  -- | Convert a value into 'Form'.+  toForm :: a -> Form+  default toForm :: (Generic a, GToForm a (Rep a)) => a -> Form+  toForm = genericToForm defaultFormOptions++instance ToForm Form where toForm = id++instance (ToFormKey k, ToHttpApiData v) => ToForm [(k, v)] where+  toForm = fromList . map (toFormKey *** toQueryParam)++instance (ToFormKey k, ToHttpApiData v) => ToForm (Map k [v]) where+  toForm = fromEntriesByKey . Map.toList++instance (ToFormKey k, ToHttpApiData v) => ToForm (HashMap k [v]) where+  toForm = fromEntriesByKey . HashMap.toList++instance ToHttpApiData v => ToForm (IntMap [v]) where+  toForm = fromEntriesByKey . IntMap.toList++-- | Convert a list of entries groupped by key into a 'Form'.+--+-- >>> fromEntriesByKey [("name",["Nick"]),("color",["red","blue"])]+-- fromList [("color","red"),("color","blue"),("name","Nick")]+fromEntriesByKey :: (ToFormKey k, ToHttpApiData v) => [(k, [v])] -> Form+fromEntriesByKey = Form . HashMap.fromListWith (<>) . map (toFormKey *** map toQueryParam)++data Proxy3 a b c = Proxy3++type family NotSupported (cls :: k1) (a :: k2) (reason :: Symbol) :: Constraint where+#if __GLASGOW_HASKELL__ < 800+  -- this is just a placeholder case for older GHCs to not freak out on an empty closed type family+  NotSupported cls a "this type family is actually empty" = ()+#else+  NotSupported cls a reason = TypeError+    ( 'Text "Cannot derive a Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instance for " ':<>: 'ShowType a ':<>: 'Text "." ':$$:+      'ShowType a ':<>: 'Text " " ':<>: 'Text reason ':<>: 'Text "," ':$$:+      'Text "but Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instances can be derived only for records" ':$$:+      'Text "(i.e. product types with named fields)." )+#endif++-- | A 'Generic'-based implementation of 'toForm'.+-- This is used as a default implementation in 'ToForm'.+--+-- Note that this only works for records (i.e. product data types with named fields):+--+-- @+-- data Person = Person+--   { name :: String+--   , age  :: Int+--   } deriving ('Generic')+-- @+--+-- In this implementation each field's value gets encoded using `toQueryParam`.+-- Two field types are exceptions:+--+--    - for values of type @'Maybe' a@ an entry is added to the 'Form' only when it is @'Just' x@+--      and the encoded value is @'toQueryParam' x@; 'Nothing' values are omitted from the 'Form';+--+--    - for values of type @[a]@ (except @['Char']@) an entry is added for every item in the list;+--      if the list is empty no entries are added to the 'Form';+--+-- Here's an example:+--+-- @+-- data Post = Post+--   { title    :: String+--   , subtitle :: Maybe String+--   , comments :: [String]+--   } deriving ('Generic', 'Show')+--+-- instance 'ToForm' Post+-- @+--+-- >>> urlEncodeAsForm Post { title = "Test", subtitle = Nothing, comments = ["Nice post!", "+1"] }+-- "comments=Nice%20post%21&comments=%2B1&title=Test"+genericToForm :: forall a. (Generic a, GToForm a (Rep a)) => FormOptions -> a -> Form+genericToForm opts = gToForm (Proxy :: Proxy a) opts . from++class GToForm t (f :: * -> *) where+  gToForm :: Proxy t -> FormOptions -> f x -> Form++instance (GToForm t f, GToForm t g) => GToForm t (f :*: g) where+  gToForm p opts (a :*: b) = gToForm p opts a <> gToForm p opts b++instance (GToForm t f) => GToForm t (M1 D x f) where+  gToForm p opts (M1 a) = gToForm p opts a++instance (GToForm t f) => GToForm t (M1 C x f) where+  gToForm p opts (M1 a) = gToForm p opts a++instance OVERLAPPABLE_ (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i c)) where+  gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)]+    where+      key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i (Maybe c))) where+  gToForm _ opts (M1 (K1 c)) =+    case c of+      Nothing -> mempty+      Just x  -> fromList [(key, toQueryParam x)]+    where+      key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i [c])) where+  gToForm _ opts (M1 (K1 cs)) = fromList (map (\c -> (key, toQueryParam c)) cs)+    where+      key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance OVERLAPPING_ (Selector s) => GToForm t (M1 S s (K1 i String)) where+  gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)]+    where+      key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance NotSupported ToForm t "is a sum type" => GToForm t (f :+: g) where gToForm = error "impossible"++-- | Parse 'Form' into a value.+--+-- An example type and instance:+--+-- @+-- data Person = Person+--   { name :: String+--   , age  :: Int }+--+-- instance 'FromForm' Person where+--   'fromForm' (Form m) = Person+--     '<$>' 'parseUnique' "name" m+--     '<*>' 'parseUnique' "age"  m+-- @+--+-- Instead of manually writing @'FromForm'@ instances you can+-- use a default generic implementation of @'fromForm'@.+--+-- To do that, simply add @deriving 'Generic'@ clause to your datatype+-- and declare a 'FromForm' instance for your datatype without+-- giving definition for 'fromForm'.+--+-- For instance, the previous example can be simplified into this:+--+-- @+-- data Person = Person+--   { name :: String+--   , age  :: Int+--   } deriving ('Generic')+--+-- instance 'FromForm' Person+-- @+--+-- The default implementation of 'fromForm' is 'genericFromForm'.+-- It only works for records and it will use 'parseQueryParam' for each field's value.+class FromForm a where+  -- | Parse 'Form' into a value.+  fromForm :: Form -> Either Text a+  default fromForm :: (Generic a, GFromForm a (Rep a)) => Form -> Either Text a+  fromForm = genericFromForm defaultFormOptions++instance FromForm Form where fromForm = pure++instance (FromFormKey k, FromHttpApiData v) => FromForm [(k, v)] where+  fromForm = fmap (concatMap (\(k, vs) -> map ((,) k) vs)) . toEntriesByKey++instance (Ord k, FromFormKey k, FromHttpApiData v) => FromForm (Map k [v]) where+  fromForm = fmap (Map.fromListWith (<>)) . toEntriesByKey++instance (Eq k, Hashable k, FromFormKey k, FromHttpApiData v) => FromForm (HashMap k [v]) where+  fromForm = fmap (HashMap.fromListWith (<>)) . toEntriesByKey++instance FromHttpApiData v => FromForm (IntMap [v]) where+  fromForm = fmap (IntMap.fromListWith (<>)) . toEntriesByKey++-- | Parse a 'Form' into a list of entries groupped by key.+--+-- >>> toEntriesByKey [("name", "Nick"), ("color", "red"), ("color", "white")] :: Either Text [(Text, [Text])]+-- Right [("color",["red","white"]),("name",["Nick"])]+toEntriesByKey :: (FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])]+toEntriesByKey = traverse parseGroup . HashMap.toList . unForm+  where+    parseGroup (k, vs) = (,) <$> parseFormKey k <*> traverse parseQueryParam vs++-- | A 'Generic'-based implementation of 'fromForm'.+-- This is used as a default implementation in 'FromForm'.+--+-- Note that this only works for records (i.e. product data types with named fields):+--+-- @+-- data Person = Person+--   { name :: String+--   , age  :: Int+--   } deriving ('Generic')+-- @+--+-- In this implementation each field's value gets decoded using `parseQueryParam`.+-- Two field types are exceptions:+--+--    - for values of type @'Maybe' a@ an entry is parsed if present in the 'Form'+--      and the is decoded with 'parseQueryParam'; if no entry is present result is 'Nothing';+--+--    - for values of type @[a]@ (except @['Char']@) all entries are parsed to produce a list of parsed values;+--+-- Here's an example:+--+-- @+-- data Post = Post+--   { title    :: String+--   , subtitle :: Maybe String+--   , comments :: [String]+--   } deriving ('Generic', 'Show')+--+-- instance 'FromForm' Post+-- @+--+-- >>> urlDecodeAsForm "comments=Nice%20post%21&comments=%2B1&title=Test" :: Either Text Post+-- Right (Post {title = "Test", subtitle = Nothing, comments = ["Nice post!","+1"]})+genericFromForm :: forall a. (Generic a, GFromForm a (Rep a)) => FormOptions -> Form -> Either Text a+genericFromForm opts f = to <$> gFromForm (Proxy :: Proxy a) opts f++class GFromForm t (f :: * -> *) where+  gFromForm :: Proxy t -> FormOptions -> Form -> Either Text (f x)++instance (GFromForm t f, GFromForm t g) => GFromForm t (f :*: g) where+  gFromForm p opts f = (:*:) <$> gFromForm p opts f <*> gFromForm p opts f++instance GFromForm t f => GFromForm t (M1 D x f) where+  gFromForm p opts f = M1 <$> gFromForm p opts f++instance GFromForm t f => GFromForm t (M1 C x f) where+  gFromForm p opts f = M1 <$> gFromForm p opts f++instance OVERLAPPABLE_ (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i c)) where+  gFromForm _ opts form = M1 . K1 <$> parseUnique key form+    where+      key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i (Maybe c))) where+  gFromForm _ opts form = M1 . K1 <$> parseMaybe key form+    where+      key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i [c])) where+  gFromForm _ opts form = M1 . K1 <$> parseAll key form+    where+      key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance OVERLAPPING_ (Selector s) => GFromForm t (M1 S s (K1 i String)) where+  gFromForm _ opts form = M1 . K1 <$> parseUnique key form+    where+      key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p)++instance NotSupported FromForm t "is a sum type" => GFromForm t (f :+: g) where gFromForm = error "impossible"++-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'.+--+-- Key-value pairs get encoded to @key=value@ and separated by @&@:+--+-- >>> urlEncodeForm [("name", "Julian"), ("lastname", "Arni")]+-- "lastname=Arni&name=Julian"+--+-- Keys with empty values get encoded to just @key@ (without the @=@ sign):+--+-- >>> urlEncodeForm [("is_test", "")]+-- "is_test"+--+-- Empty keys are allowed too:+--+-- >>> urlEncodeForm [("", "foobar")]+-- "=foobar"+--+-- However, if not key and value are empty, the key-value pair is ignored.+-- (This prevents @'urlDecodeForm' . 'urlEncodeForm'@ from being a true isomorphism).+--+-- >>> urlEncodeForm [("", "")]+-- ""+--+-- Everything is escaped with @'escapeURIString' 'isUnreserved'@:+--+-- >>> urlEncodeForm [("fullname", "Andres Löh")]+-- "fullname=Andres%20L%C3%B6h"+urlEncodeForm :: Form -> BSL.ByteString+urlEncodeForm = toLazyByteString . mconcat . intersperse (shortByteString "&") . map encodePair . toList+  where+    escape = urlEncodeQuery . Text.encodeUtf8++    encodePair (k, "") = escape k+    encodePair (k, v) = escape k <> shortByteString "=" <> escape v+++-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a 'Form'.+--+-- Key-value pairs get decoded normally:+--+-- >>> urlDecodeForm "name=Greg&lastname=Weber"+-- Right (fromList [("lastname","Weber"),("name","Greg")])+--+-- Keys with no values get decoded to pairs with empty values.+--+-- >>> urlDecodeForm "is_test"+-- Right (fromList [("is_test","")])+--+-- Empty keys are allowed:+--+-- >>> urlDecodeForm "=foobar"+-- Right (fromList [("","foobar")])+--+-- The empty string gets decoded into an empty 'Form':+--+-- >>> urlDecodeForm ""+-- Right (fromList [])+--+-- Everything is un-escaped with 'unEscapeString':+--+-- >>> urlDecodeForm "fullname=Andres%20L%C3%B6h"+-- Right (fromList [("fullname","Andres L\246h")])+--+-- Improperly formed strings result in an error:+--+-- >>> urlDecodeForm "this=has=too=many=equals"+-- Left "not a valid pair: this=has=too=many=equals"+urlDecodeForm :: BSL.ByteString -> Either Text Form+urlDecodeForm bs = toForm <$> traverse parsePair pairs+  where+    pairs = map (BSL8.split '=') (BSL8.split '&' bs)++    unescape = Text.decodeUtf8With lenientDecode . urlDecodeQuery . BSL.toStrict++    parsePair p =+      case map unescape p of+        [k, v] -> return (k, v)+        [k]    -> return (k, "")+        xs     -> Left $ "not a valid pair: " <> Text.intercalate "=" xs++-- | This is a convenience function for decoding a+-- @application/x-www-form-urlencoded@ 'BSL.ByteString' directly to a datatype+-- that has an instance of 'FromForm'.+--+-- This is effectively @'fromForm' '<=<' 'urlDecodeForm'@.+--+-- >>> urlDecodeAsForm "name=Dennis&age=22" :: Either Text Person+-- Right (Person {name = "Dennis", age = 22})+urlDecodeAsForm :: FromForm a => BSL.ByteString -> Either Text a+urlDecodeAsForm = fromForm <=< urlDecodeForm++-- | This is a convenience function for encoding a datatype that has instance+-- of 'ToForm' directly to a @application/x-www-form-urlencoded@+-- 'BSL.ByteString'.+--+-- This is effectively @'urlEncodeForm' . 'toForm'@.+--+-- >>> urlEncodeAsForm Person {name = "Dennis", age = 22}+-- "age=22&name=Dennis"+urlEncodeAsForm :: ToForm a => a -> BSL.ByteString+urlEncodeAsForm = urlEncodeForm . toForm++-- | Find all values corresponding to a given key in a 'Form'.+--+-- >>> lookupAll "name" []+-- []+-- >>> lookupAll "name" [("name", "Oleg")]+-- ["Oleg"]+-- >>> lookupAll "name" [("name", "Oleg"), ("name", "David")]+-- ["Oleg","David"]+lookupAll :: Text -> Form -> [Text]+lookupAll key = F.concat . HashMap.lookup key . unForm++-- | Lookup an optional value for a key.+-- Fail if there is more than one value.+--+-- >>> lookupMaybe "name" []+-- Right Nothing+-- >>> lookupMaybe "name" [("name", "Oleg")]+-- Right (Just "Oleg")+-- >>> lookupMaybe "name" [("name", "Oleg"), ("name", "David")]+-- Left "Duplicate key \"name\""+lookupMaybe :: Text -> Form -> Either Text (Maybe Text)+lookupMaybe key form =+  case lookupAll key form of+    []  -> pure Nothing+    [v] -> pure (Just v)+    _   -> Left $ "Duplicate key " <> Text.pack (show key)++-- | Lookup a unique value for a key.+-- Fail if there is zero or more than one value.+--+-- >>> lookupUnique "name" []+-- Left "Could not find key \"name\""+-- >>> lookupUnique "name" [("name", "Oleg")]+-- Right "Oleg"+-- >>> lookupUnique "name" [("name", "Oleg"), ("name", "David")]+-- Left "Duplicate key \"name\""+lookupUnique :: Text -> Form -> Either Text Text+lookupUnique key form = do+  mv <- lookupMaybe key form+  case mv of+    Just v  -> pure v+    Nothing -> Left $ "Could not find key " <> Text.pack (show key)++-- | Lookup all values for a given key in a 'Form' and parse them with 'parseQueryParams'.+--+-- >>> parseAll "age" [] :: Either Text [Word8]+-- Right []+-- >>> parseAll "age" [("age", "8"), ("age", "seven")] :: Either Text [Word8]+-- Left "could not parse: `seven' (input does not start with a digit)"+-- >>> parseAll "age" [("age", "8"), ("age", "777")] :: Either Text [Word8]+-- Left "out of bounds: `777' (should be between 0 and 255)"+-- >>> parseAll "age" [("age", "12"), ("age", "25")] :: Either Text [Word8]+-- Right [12,25]+parseAll :: FromHttpApiData v => Text -> Form -> Either Text [v]+parseAll key = parseQueryParams . lookupAll key++-- | Lookup an optional value for a given key and parse it with 'parseQueryParam'.+-- Fail if there is more than one value for the key.+--+-- >>> parseMaybe "age" [] :: Either Text (Maybe Word8)+-- Right Nothing+-- >>> parseMaybe "age" [("age", "12"), ("age", "25")] :: Either Text (Maybe Word8)+-- Left "Duplicate key \"age\""+-- >>> parseMaybe "age" [("age", "seven")] :: Either Text (Maybe Word8)+-- Left "could not parse: `seven' (input does not start with a digit)"+-- >>> parseMaybe "age" [("age", "777")] :: Either Text (Maybe Word8)+-- Left "out of bounds: `777' (should be between 0 and 255)"+-- >>> parseMaybe "age" [("age", "7")] :: Either Text (Maybe Word8)+-- Right (Just 7)+parseMaybe :: FromHttpApiData v => Text -> Form -> Either Text (Maybe v)+parseMaybe key = parseQueryParams <=< lookupMaybe key++-- | Lookup a unique value for a given key and parse it with 'parseQueryParam'.+-- Fail if there is zero or more than one value for the key.+--+-- >>> parseUnique "age" [] :: Either Text Word8+-- Left "Could not find key \"age\""+-- >>> parseUnique "age" [("age", "12"), ("age", "25")] :: Either Text Word8+-- Left "Duplicate key \"age\""+-- >>> parseUnique "age" [("age", "seven")] :: Either Text Word8+-- Left "could not parse: `seven' (input does not start with a digit)"+-- >>> parseUnique "age" [("age", "777")] :: Either Text Word8+-- Left "out of bounds: `777' (should be between 0 and 255)"+-- >>> parseUnique "age" [("age", "7")] :: Either Text Word8+-- Right 7+parseUnique :: FromHttpApiData v => Text -> Form -> Either Text v+parseUnique key form = lookupUnique key form >>= parseQueryParam++-- | 'Generic'-based deriving options for 'ToForm' and 'FromForm'.+--+-- A common use case for non-default 'FormOptions'+-- is to strip a prefix off of field labels:+--+-- @+-- data Project = Project+--   { projectName :: String+--   , projectSize :: Int+--   } deriving ('Generic', 'Show')+--+-- myOptions :: 'FormOptions'+-- myOptions = 'FormOptions'+--  { 'fieldLabelModifier' = 'map' 'toLower' . 'drop' ('length' \"project\") }+--+-- instance 'ToForm' Project where+--   'toForm' = 'genericToForm' myOptions+--+-- instance 'FromForm' Project where+--   'fromForm' = 'genericFromForm' myOptions+-- @+--+-- >>> urlEncodeAsForm Project { projectName = "http-api-data", projectSize = 172 }+-- "size=172&name=http-api-data"+-- >>> urlDecodeAsForm "name=http-api-data&size=172" :: Either Text Project+-- Right (Project {projectName = "http-api-data", projectSize = 172})+data FormOptions = FormOptions+  { -- | Function applied to field labels. Handy for removing common record prefixes for example.+    fieldLabelModifier :: String -> String+  }++-- | Default encoding 'FormOptions'.+--+-- @+-- 'FormOptions'+-- { 'fieldLabelModifier' = id+-- }+-- @+defaultFormOptions :: FormOptions+defaultFormOptions = FormOptions+  { fieldLabelModifier = id+  }

@@ -0,0 +1,579 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeSynonymInstances #-}+-- |+-- Convert Haskell values to and from HTTP API data+-- such as URL pieces, headers and query parameters.+module Web.Internal.HttpApiData where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+import Data.Traversable (Traversable(traverse))+#endif++import Control.Arrow ((&&&), left)+import Control.Monad ((<=<))++import Data.Monoid+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS++import Data.Int+import Data.Word++import Data.Text (Text)+import Data.Text.Encoding (encodeUtf8, decodeUtf8')+import Data.Text.Read (signed, decimal, rational, Reader)+import qualified Data.Text as T+import qualified Data.Text.Lazy as L++import Data.Time.Locale.Compat+import Data.Time+import Data.Version++#if MIN_VERSION_base(4,8,0)+import Data.Void+import Numeric.Natural+#endif++import Text.Read (readMaybe)+import Text.ParserCombinators.ReadP (readP_to_S)++#if USE_TEXT_SHOW+import TextShow (TextShow, showt)+#endif++-- $setup+-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)+-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p++-- | Convert value to HTTP API data.+--+-- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated+-- instance will loop indefinitely.+class ToHttpApiData a where+  {-# MINIMAL toUrlPiece | toQueryParam #-}+  -- | Convert to URL path piece.+  toUrlPiece :: a -> Text+  toUrlPiece = toQueryParam++  -- | Convert to HTTP header value.+  toHeader :: a -> ByteString+  toHeader = encodeUtf8 . toUrlPiece++  -- | Convert to query param value.+  toQueryParam :: a -> Text+  toQueryParam = toUrlPiece++-- | Parse value from HTTP API data.+--+-- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated+-- instance will loop indefinitely.+class FromHttpApiData a where+  {-# MINIMAL parseUrlPiece | parseQueryParam #-}+  -- | Parse URL path piece.+  parseUrlPiece :: Text -> Either Text a+  parseUrlPiece = parseQueryParam++  -- | Parse HTTP header value.+  parseHeader :: ByteString -> Either Text a+  parseHeader = parseUrlPiece <=< (left (T.pack . show) . decodeUtf8')++  -- | Parse query param value.+  parseQueryParam :: Text -> Either Text a+  parseQueryParam = parseUrlPiece++-- | Convert multiple values to a list of URL pieces.+--+-- >>> toUrlPieces [1, 2, 3] :: [Text]+-- ["1","2","3"]+toUrlPieces :: (Functor t, ToHttpApiData a) => t a -> t Text+toUrlPieces = fmap toUrlPiece++-- | Parse multiple URL pieces.+--+-- >>> parseUrlPieces ["true", "false"] :: Either Text [Bool]+-- Right [True,False]+-- >>> parseUrlPieces ["123", "hello", "world"] :: Either Text [Int]+-- Left "could not parse: `hello' (input does not start with a digit)"+parseUrlPieces :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)+parseUrlPieces = traverse parseUrlPiece++-- | Convert multiple values to a list of query parameter values.+--+-- >>> toQueryParams [fromGregorian 2015 10 03, fromGregorian 2015 12 01] :: [Text]+-- ["2015-10-03","2015-12-01"]+toQueryParams :: (Functor t, ToHttpApiData a) => t a -> t Text+toQueryParams = fmap toQueryParam++-- | Parse multiple query parameters.+--+-- >>> parseQueryParams ["1", "2", "3"] :: Either Text [Int]+-- Right [1,2,3]+-- >>> parseQueryParams ["64", "128", "256"] :: Either Text [Word8]+-- Left "out of bounds: `256' (should be between 0 and 255)"+parseQueryParams :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)+parseQueryParams = traverse parseQueryParam++-- | Parse URL path piece in a @'Maybe'@.+--+-- >>> parseUrlPieceMaybe "12" :: Maybe Int+-- Just 12+parseUrlPieceMaybe :: FromHttpApiData a => Text -> Maybe a+parseUrlPieceMaybe = either (const Nothing) Just . parseUrlPiece++-- | Parse HTTP header value in a @'Maybe'@.+--+-- >>> parseHeaderMaybe "hello" :: Maybe Text+-- Just "hello"+parseHeaderMaybe :: FromHttpApiData a => ByteString -> Maybe a+parseHeaderMaybe = either (const Nothing) Just . parseHeader++-- | Parse query param value in a @'Maybe'@.+--+-- >>> parseQueryParamMaybe "true" :: Maybe Bool+-- Just True+parseQueryParamMaybe :: FromHttpApiData a => Text -> Maybe a+parseQueryParamMaybe = either (const Nothing) Just . parseQueryParam++-- | Default parsing error.+defaultParseError :: Text -> Either Text a+defaultParseError input = Left ("could not parse: `" <> input <> "'")++-- | Convert @'Maybe'@ parser into @'Either' 'Text'@ parser with default error message.+parseMaybeTextData :: (Text -> Maybe a) -> (Text -> Either Text a)+parseMaybeTextData parse input =+  case parse input of+    Nothing  -> defaultParseError input+    Just val -> Right val++#if USE_TEXT_SHOW+-- | /Lower case/.+--+-- Convert to URL piece using @'TextShow'@ instance.+-- The result is always lower cased.+--+-- >>> showTextData True+-- "true"+--+-- This can be used as a default implementation for enumeration types:+--+-- @+-- data MyData = Foo | Bar | Baz deriving (Generic)+--+-- instance TextShow MyData where+--   showt = genericShowt+--+-- instance ToHttpApiData MyData where+--   toUrlPiece = showTextData+-- @+showTextData :: TextShow a => a -> Text+showTextData = T.toLower . showt+#else+-- | /Lower case/.+--+-- Convert to URL piece using @'Show'@ instance.+-- The result is always lower cased.+--+-- >>> showTextData True+-- "true"+--+-- This can be used as a default implementation for enumeration types:+--+-- >>> data MyData = Foo | Bar | Baz deriving (Show)+-- >>> instance ToHttpApiData MyData where toUrlPiece = showTextData+-- >>> toUrlPiece Foo+-- "foo"+showTextData :: Show a => a -> Text+showTextData = T.toLower . showt++-- | Like @'show'@, but returns @'Text'@.+showt :: Show a => a -> Text+showt = T.pack . show+#endif++-- | /Case insensitive/.+--+-- Parse given text case insensitive and then parse the rest of the input+-- using @'parseUrlPiece'@.+--+-- >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int+-- Right 10+-- >>> parseUrlPieceWithPrefix "Left " "left" :: Either Text Bool+-- Left "could not parse: `left'"+--+-- This can be used to implement @'FromHttpApiData'@ for single field constructors:+--+-- >>> data Foo = Foo Int deriving (Show)+-- >>> instance FromHttpApiData Foo where parseUrlPiece s = Foo <$> parseUrlPieceWithPrefix "Foo " s+-- >>> parseUrlPiece "foo 1" :: Either Text Foo+-- Right (Foo 1)+parseUrlPieceWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a+parseUrlPieceWithPrefix pattern input+  | T.toLower pattern == T.toLower prefix = parseUrlPiece rest+  | otherwise                             = defaultParseError input+  where+    (prefix, rest) = T.splitAt (T.length pattern) input++-- | Parse given bytestring then parse the rest of the input using @'parseHeader'@.+--+-- @+-- data BasicAuthToken = BasicAuthToken Text deriving (Show)+--+-- instance FromHttpApiData BasicAuthToken where+--   parseHeader h     = BasicAuthToken \<$\> parseHeaderWithPrefix "Basic " h+--   parseQueryParam p = BasicAuthToken \<$\> parseQueryParam p+-- @+--+-- >>> parseHeader "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" :: Either Text BasicAuthToken+-- Right (BasicAuthToken "QWxhZGRpbjpvcGVuIHNlc2FtZQ==")+parseHeaderWithPrefix :: FromHttpApiData a => ByteString -> ByteString -> Either Text a+parseHeaderWithPrefix pattern input+  | pattern `BS.isPrefixOf` input = parseHeader (BS.drop (BS.length pattern) input)+  | otherwise                     = defaultParseError (showt input)++-- | /Case insensitive/.+--+-- Parse given text case insensitive and then parse the rest of the input+-- using @'parseQueryParam'@.+--+-- >>> parseQueryParamWithPrefix "z" "z10" :: Either Text Int+-- Right 10+parseQueryParamWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a+parseQueryParamWithPrefix pattern input+  | T.toLower pattern == T.toLower prefix = parseQueryParam rest+  | otherwise                             = defaultParseError input+  where+    (prefix, rest) = T.splitAt (T.length pattern) input++#if USE_TEXT_SHOW+-- | /Case insensitive/.+--+-- Parse values case insensitively based on @'TextShow'@ instance.+--+-- >>> parseBoundedTextData "true" :: Either Text Bool+-- Right True+-- >>> parseBoundedTextData "FALSE" :: Either Text Bool+-- Right False+--+-- This can be used as a default implementation for enumeration types:+--+-- @+-- data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum, Generic)+--+-- instance TextShow MyData where+--   showt = genericShowt+--+-- instance FromHttpApiData MyData where+--   parseUrlPiece = parseBoundedTextData+-- @+parseBoundedTextData :: (TextShow a, Bounded a, Enum a) => Text -> Either Text a+#else+-- | /Case insensitive/.+--+-- Parse values case insensitively based on @'Show'@ instance.+--+-- >>> parseBoundedTextData "true" :: Either Text Bool+-- Right True+-- >>> parseBoundedTextData "FALSE" :: Either Text Bool+-- Right False+--+-- This can be used as a default implementation for enumeration types:+--+-- >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum)+-- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedTextData+-- >>> parseUrlPiece "foo" :: Either Text MyData+-- Right Foo+parseBoundedTextData :: (Show a, Bounded a, Enum a) => Text -> Either Text a+#endif+parseBoundedTextData = parseBoundedEnumOfI showTextData++-- | Lookup values based on a precalculated mapping of their representations.+lookupBoundedEnumOf :: (Bounded a, Enum a, Eq b) => (a -> b) -> b -> Maybe a+lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])++-- | Parse values based on a precalculated mapping of their @'Text'@ representation.+--+-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool+-- Right True+--+-- For case sensitive parser see 'parseBoundedEnumOfI'.+parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a+parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf++-- | /Case insensitive/.+--+-- Parse values case insensitively based on a precalculated mapping+-- of their @'Text'@ representations.+--+-- >>> parseBoundedEnumOfI toUrlPiece "FALSE" :: Either Text Bool+-- Right False+--+-- For case sensitive parser see 'parseBoundedEnumOf'.+parseBoundedEnumOfI :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a+parseBoundedEnumOfI f = parseBoundedEnumOf (T.toLower . f) . T.toLower++-- | /Case insensitive/.+--+-- Parse values case insensitively based on @'ToHttpApiData'@ instance.+-- Uses @'toUrlPiece'@ to get possible values.+parseBoundedUrlPiece :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a+parseBoundedUrlPiece = parseBoundedEnumOfI toUrlPiece++-- | /Case insensitive/.+--+-- Parse values case insensitively based on @'ToHttpApiData'@ instance.+-- Uses @'toQueryParam'@ to get possible values.+parseBoundedQueryParam :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a+parseBoundedQueryParam = parseBoundedEnumOfI toQueryParam++-- | Parse values based on @'ToHttpApiData'@ instance.+-- Uses @'toHeader'@ to get possible values.+parseBoundedHeader :: (ToHttpApiData a, Bounded a, Enum a) => ByteString -> Either Text a+parseBoundedHeader bs = case lookupBoundedEnumOf toHeader bs of+  Nothing -> defaultParseError $ T.pack $ show bs+  Just x  -> return x++-- | Parse URL piece using @'Read'@ instance.+--+-- Use for types which do not involve letters:+--+-- >>> readTextData "1991-06-02" :: Either Text Day+-- Right 1991-06-02+--+-- This parser is case sensitive and will not match @'showTextData'@+-- in presense of letters:+--+-- >>> readTextData (showTextData True) :: Either Text Bool+-- Left "could not parse: `true'"+--+-- See @'parseBoundedTextData'@.+readTextData :: Read a => Text -> Either Text a+readTextData = parseMaybeTextData (readMaybe . T.unpack)++-- | Run @'Reader'@ as HTTP API data parser.+runReader :: Reader a -> Text -> Either Text a+runReader reader input =+  case reader input of+    Left err          -> Left ("could not parse: `" <> input <> "' (" <> T.pack err <> ")")+    Right (x, rest)+      | T.null rest -> Right x+      | otherwise   -> defaultParseError input++-- | Run @'Reader'@ to parse bounded integral value with bounds checking.+--+-- >>> parseBounded decimal "256" :: Either Text Word8+-- Left "out of bounds: `256' (should be between 0 and 255)"+parseBounded :: forall a. (Bounded a, Integral a) => Reader Integer -> Text -> Either Text a+parseBounded reader input = do+  n <- runReader reader input+  if (n > h || n < l)+    then Left  ("out of bounds: `" <> input <> "' (should be between " <> showt l <> " and " <> showt h <> ")")+    else Right (fromInteger n)+  where+    l = toInteger (minBound :: a)+    h = toInteger (maxBound :: a)++-- |+-- >>> toUrlPiece ()+-- "_"+instance ToHttpApiData () where+  toUrlPiece () = "_"++instance ToHttpApiData Char     where toUrlPiece = T.singleton++-- |+-- >>> toUrlPiece (Version [1, 2, 3] [])+-- "1.2.3"+instance ToHttpApiData Version where+  toUrlPiece = T.pack . showVersion++#if MIN_VERSION_base(4,8,0)+instance ToHttpApiData Void    where toUrlPiece = absurd+instance ToHttpApiData Natural where toUrlPiece = showt+#endif++instance ToHttpApiData Bool     where toUrlPiece = showTextData+instance ToHttpApiData Ordering where toUrlPiece = showTextData++instance ToHttpApiData Double   where toUrlPiece = showt+instance ToHttpApiData Float    where toUrlPiece = showt+instance ToHttpApiData Int      where toUrlPiece = showt+instance ToHttpApiData Int8     where toUrlPiece = showt+instance ToHttpApiData Int16    where toUrlPiece = showt+instance ToHttpApiData Int32    where toUrlPiece = showt+instance ToHttpApiData Int64    where toUrlPiece = showt+instance ToHttpApiData Integer  where toUrlPiece = showt+instance ToHttpApiData Word     where toUrlPiece = showt+instance ToHttpApiData Word8    where toUrlPiece = showt+instance ToHttpApiData Word16   where toUrlPiece = showt+instance ToHttpApiData Word32   where toUrlPiece = showt+instance ToHttpApiData Word64   where toUrlPiece = showt++-- |+-- >>> toUrlPiece (fromGregorian 2015 10 03)+-- "2015-10-03"+instance ToHttpApiData Day      where toUrlPiece = T.pack . show++timeToUrlPiece :: FormatTime t => String -> t -> Text+timeToUrlPiece fmt = T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just fmt))++-- |+-- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 01)+-- "2015-10-03T14:55:01"+instance ToHttpApiData LocalTime where toUrlPiece = timeToUrlPiece "%H:%M:%S"++-- |+-- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 01)) utc+-- "2015-10-03T14:55:01+0000"+instance ToHttpApiData ZonedTime where toUrlPiece = timeToUrlPiece "%H:%M:%S%z"++-- |+-- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864+-- "2015-10-03T00:14:24Z"+instance ToHttpApiData UTCTime   where toUrlPiece = timeToUrlPiece "%H:%M:%SZ"++instance ToHttpApiData NominalDiffTime where toUrlPiece = toUrlPiece . (floor :: NominalDiffTime -> Integer)++instance ToHttpApiData String   where toUrlPiece = T.pack+instance ToHttpApiData Text     where toUrlPiece = id+instance ToHttpApiData L.Text   where toUrlPiece = L.toStrict++instance ToHttpApiData All where toUrlPiece = toUrlPiece . getAll+instance ToHttpApiData Any where toUrlPiece = toUrlPiece . getAny++instance ToHttpApiData a => ToHttpApiData (Dual a)    where toUrlPiece = toUrlPiece . getDual+instance ToHttpApiData a => ToHttpApiData (Sum a)     where toUrlPiece = toUrlPiece . getSum+instance ToHttpApiData a => ToHttpApiData (Product a) where toUrlPiece = toUrlPiece . getProduct+instance ToHttpApiData a => ToHttpApiData (First a)   where toUrlPiece = toUrlPiece . getFirst+instance ToHttpApiData a => ToHttpApiData (Last a)    where toUrlPiece = toUrlPiece . getLast++-- |+-- >>> toUrlPiece (Just "Hello")+-- "just Hello"+instance ToHttpApiData a => ToHttpApiData (Maybe a) where+  toUrlPiece (Just x) = "just " <> toUrlPiece x+  toUrlPiece Nothing  = "nothing"++-- |+-- >>> toUrlPiece (Left "err" :: Either String Int)+-- "left err"+-- >>> toUrlPiece (Right 3 :: Either String Int)+-- "right 3"+instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where+  toUrlPiece (Left x)  = "left " <> toUrlPiece x+  toUrlPiece (Right x) = "right " <> toUrlPiece x++-- |+-- >>> parseUrlPiece "_" :: Either Text ()+-- Right ()+instance FromHttpApiData () where+  parseUrlPiece "_" = pure ()+  parseUrlPiece s   = defaultParseError s++instance FromHttpApiData Char where+  parseUrlPiece s =+    case T.uncons s of+      Just (c, s') | T.null s' -> pure c+      _                        -> defaultParseError s++-- |+-- >>> showVersion <$> parseUrlPiece "1.2.3"+-- Right "1.2.3"+instance FromHttpApiData Version where+  parseUrlPiece s =+    case reverse (readP_to_S parseVersion (T.unpack s)) of+      ((x, ""):_) -> pure x+      _           -> defaultParseError s++#if MIN_VERSION_base(4,8,0)+-- | Parsing a @'Void'@ value is always an error, considering @'Void'@ as a data type with no constructors.+instance FromHttpApiData Void where+  parseUrlPiece _ = Left "Void cannot be parsed!"++instance FromHttpApiData Natural where+  parseUrlPiece s = do+    n <- runReader (signed decimal) s+    if n < 0+      then Left ("undeflow: " <> s <> " (should be a non-negative integer)")+      else Right (fromInteger n)+#endif++instance FromHttpApiData Bool     where parseUrlPiece = parseBoundedUrlPiece+instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece+instance FromHttpApiData Double   where parseUrlPiece = runReader rational+instance FromHttpApiData Float    where parseUrlPiece = runReader rational+instance FromHttpApiData Int      where parseUrlPiece = parseBounded (signed decimal)+instance FromHttpApiData Int8     where parseUrlPiece = parseBounded (signed decimal)+instance FromHttpApiData Int16    where parseUrlPiece = parseBounded (signed decimal)+instance FromHttpApiData Int32    where parseUrlPiece = parseBounded (signed decimal)+instance FromHttpApiData Int64    where parseUrlPiece = parseBounded (signed decimal)+instance FromHttpApiData Integer  where parseUrlPiece = runReader (signed decimal)+instance FromHttpApiData Word     where parseUrlPiece = parseBounded decimal+instance FromHttpApiData Word8    where parseUrlPiece = parseBounded decimal+instance FromHttpApiData Word16   where parseUrlPiece = parseBounded decimal+instance FromHttpApiData Word32   where parseUrlPiece = parseBounded decimal+instance FromHttpApiData Word64   where parseUrlPiece = parseBounded decimal+instance FromHttpApiData String   where parseUrlPiece = Right . T.unpack+instance FromHttpApiData Text     where parseUrlPiece = Right+instance FromHttpApiData L.Text   where parseUrlPiece = Right . L.fromStrict++-- |+-- >>> toGregorian <$> parseUrlPiece "2016-12-01"+-- Right (2016,12,1)+instance FromHttpApiData Day      where parseUrlPiece = readTextData++timeParseUrlPiece :: ParseTime t => String -> Text -> Either Text t+timeParseUrlPiece fmt = parseMaybeTextData (timeParseUrlPieceMaybe . T.unpack)+  where+    timeParseUrlPieceMaybe = parseTime defaultTimeLocale (iso8601DateFormat (Just fmt))++-- |+-- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime+-- Right 2015-10-03 14:55:01+instance FromHttpApiData LocalTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%S"++-- |+-- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime+-- Right 2015-10-03 14:55:01 +0000+instance FromHttpApiData ZonedTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%S%z"++-- |+-- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime+-- Right 2015-10-03 00:14:24 UTC+instance FromHttpApiData UTCTime   where parseUrlPiece = timeParseUrlPiece "%H:%M:%SZ"++instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap fromInteger . parseUrlPiece++instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece+instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece++instance FromHttpApiData a => FromHttpApiData (Dual a)    where parseUrlPiece = fmap Dual    . parseUrlPiece+instance FromHttpApiData a => FromHttpApiData (Sum a)     where parseUrlPiece = fmap Sum     . parseUrlPiece+instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = fmap Product . parseUrlPiece+instance FromHttpApiData a => FromHttpApiData (First a)   where parseUrlPiece = fmap First   . parseUrlPiece+instance FromHttpApiData a => FromHttpApiData (Last a)    where parseUrlPiece = fmap Last    . parseUrlPiece++-- |+-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)+-- Right (Just 123)+instance FromHttpApiData a => FromHttpApiData (Maybe a) where+  parseUrlPiece s+    | T.toLower (T.take 7 s) == "nothing" = pure Nothing+    | otherwise                           = Just <$> parseUrlPieceWithPrefix "Just " s++-- |+-- >>> parseUrlPiece "Right 123" :: Either Text (Either String Int)+-- Right (Right 123)+instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b) where+  parseUrlPiece s =+        Right <$> parseUrlPieceWithPrefix "Right " s+    <!> Left  <$> parseUrlPieceWithPrefix "Left " s+    where+      infixl 3 <!>+      Left _ <!> y = y+      x      <!> _ = x+

@@ -11,6 +11,7 @@ main :: IO () main = getSources >>= \sources -> doctest $     "-isrc"+  : "-Iinclude"   : ("-i" ++ autogen_dir)   : "-optP-include"   : ("-optP" ++ autogen_dir ++ "/cabal_macros.h")

@@ -1,132 +1,1 @@-{-# Language ScopedTypeVariables #-}-{-# OPTIONS_GHC -fno-warn-orphans #-}-module Main where--import Control.Applicative--import Data.Int-import Data.Char-import Data.Word-import Data.Time-import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified Data.ByteString as BS-import Data.Version--import Test.Hspec-import Test.Hspec.QuickCheck(prop)-import Test.QuickCheck--import Web.HttpApiData--instance Arbitrary T.Text where-  arbitrary = T.pack <$> arbitrary--instance Arbitrary L.Text where-  arbitrary = L.pack <$> arbitrary--instance Arbitrary Day where-  arbitrary = liftA3 fromGregorian (fmap abs arbitrary) arbitrary arbitrary--instance Arbitrary LocalTime where-  arbitrary = LocalTime-    <$> arbitrary-    <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))--instance Eq ZonedTime where-  ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y--instance Arbitrary ZonedTime where-  arbitrary = ZonedTime-    <$> arbitrary-    <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))--instance Arbitrary UTCTime where-  arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))--instance Arbitrary NominalDiffTime where-  arbitrary = fromInteger <$> arbitrary--instance Arbitrary Version where-  arbitrary = (version . map abs) <$> nonempty-    where-      version branch = Version branch []-      nonempty = liftA2 (:) arbitrary arbitrary--main :: IO ()-main = hspec spec--(<=>) :: Eq a => (a -> b) -> (b -> Either T.Text a) -> a -> Bool-(f <=> g) x = g (f x) == Right x--data Proxy a = Proxy--checkUrlPiece :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a, Arbitrary a) => Proxy a -> String -> Spec-checkUrlPiece _ name = prop name (toUrlPiece <=> parseUrlPiece :: a -> Bool)--data RandomCase a = RandomCase [Bool] a--instance ToHttpApiData a => Show (RandomCase a) where-  show rc@(RandomCase _ x) = show (toUrlPiece rc) ++ " (original: " ++ show (toUrlPiece x) ++ ")"--instance Eq a => Eq (RandomCase a) where-  RandomCase _ x == RandomCase _ y = x == y--instance Arbitrary a => Arbitrary (RandomCase a) where-  arbitrary = liftA2 RandomCase nonempty arbitrary-    where-      nonempty = liftA2 (:) arbitrary arbitrary--instance ToHttpApiData a => ToHttpApiData (RandomCase a) where-  toUrlPiece (RandomCase us x) = T.pack (zipWith (\u -> if u then toUpper else toLower) (cycle us) (T.unpack (toUrlPiece x)))--instance FromHttpApiData a => FromHttpApiData (RandomCase a) where-  parseUrlPiece s = RandomCase [] <$> parseUrlPiece s---- | Check case insensitivity for @parseUrlPiece@.-checkUrlPieceI :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a, Arbitrary a) => Proxy a -> String -> Spec-checkUrlPieceI _ = checkUrlPiece (Proxy :: Proxy (RandomCase a))--spec :: Spec-spec = do-  describe "toUrlPiece <=> parseUrlPiece" $ do-    checkUrlPiece  (Proxy :: Proxy ())        "()"-    checkUrlPiece  (Proxy :: Proxy Char)      "Char"-    checkUrlPieceI (Proxy :: Proxy Bool)      "Bool"-    checkUrlPieceI (Proxy :: Proxy Ordering)  "Ordering"-    checkUrlPiece  (Proxy :: Proxy Int)       "Int"-    checkUrlPiece  (Proxy :: Proxy Int8)      "Int8"-    checkUrlPiece  (Proxy :: Proxy Int16)     "Int16"-    checkUrlPiece  (Proxy :: Proxy Int32)     "Int32"-    checkUrlPiece  (Proxy :: Proxy Int64)     "Int64"-    checkUrlPiece  (Proxy :: Proxy Integer)   "Integer"-    checkUrlPiece  (Proxy :: Proxy Word)      "Word"-    checkUrlPiece  (Proxy :: Proxy Word8)     "Word8"-    checkUrlPiece  (Proxy :: Proxy Word16)    "Word16"-    checkUrlPiece  (Proxy :: Proxy Word32)    "Word32"-    checkUrlPiece  (Proxy :: Proxy Word64)    "Word64"-    checkUrlPiece  (Proxy :: Proxy String)    "String"-    checkUrlPiece  (Proxy :: Proxy T.Text)    "Text.Strict"-    checkUrlPiece  (Proxy :: Proxy L.Text)    "Text.Lazy"-    checkUrlPiece  (Proxy :: Proxy Day)       "Day"-    checkUrlPiece  (Proxy :: Proxy LocalTime) "LocalTime"-    checkUrlPiece  (Proxy :: Proxy ZonedTime) "ZonedTime"-    checkUrlPiece  (Proxy :: Proxy UTCTime)   "UTCTime"-    checkUrlPiece  (Proxy :: Proxy NominalDiffTime) "NominalDiffTime"-    checkUrlPiece  (Proxy :: Proxy Version)   "Version"--    checkUrlPiece  (Proxy :: Proxy (Maybe String))            "Maybe String"-    checkUrlPieceI (Proxy :: Proxy (Maybe Integer))           "Maybe Integer"-    checkUrlPiece  (Proxy :: Proxy (Either Integer T.Text))   "Either Integer Text"-    checkUrlPieceI (Proxy :: Proxy (Either Version Day))      "Either Version Day"--  it "bad integers are rejected" $ do-    parseUrlPieceMaybe (T.pack "123hello") `shouldBe` (Nothing :: Maybe Int)--  it "bounds checking works" $ do-    parseUrlPieceMaybe (T.pack "256") `shouldBe` (Nothing :: Maybe Int8)-    parseUrlPieceMaybe (T.pack "-10") `shouldBe` (Nothing :: Maybe Word)--  it "invalid utf8 is handled" $ do-    parseHeaderMaybe (BS.pack [128]) `shouldBe` (Nothing :: Maybe T.Text)-+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}

@@ -0,0 +1,69 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Web.Internal.FormUrlEncodedSpec (spec) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative+import Data.Monoid+#endif++import Control.Monad ((<=<))+import qualified Data.ByteString.Lazy.Char8 as BSL+import qualified Data.HashMap.Strict as HashMap+import Data.Text (Text, unpack)+import Test.Hspec+import Test.QuickCheck++import GHC.Exts (fromList)++import Web.Internal.FormUrlEncoded+import Web.Internal.HttpApiData+import Web.Internal.TestInstances++spec :: Spec+spec = do+  genericSpec+  urlEncoding++genericSpec :: Spec+genericSpec = describe "Default (generic) instances" $ do++  context "ToForm" $ do++    it "contains the record names" $ property $ \(x :: SimpleRec) -> do+      let f = unForm $ toForm x+      HashMap.member "rec1" f `shouldBe` True+      HashMap.member "rec2" f `shouldBe` True++    it "contains the correct record values" $ property $ \(x :: SimpleRec) -> do+      let f = unForm $ toForm x+      HashMap.lookup "rec1" f `shouldBe` Just [rec1 x]+      (parseQueryParams <$> HashMap.lookup "rec2" f) `shouldBe` Just (Right [rec2 x])++  context "FromForm" $ do++    it "is the right inverse of ToForm" $ property $ \x (y :: Int) -> do+      let f1 = fromList [("rec1", x), ("rec2", toQueryParam y)]+          Right r1 = fromForm f1 :: Either Text SimpleRec+      toForm r1 `shouldBe` f1++    it "returns the underlying error" $ do+      let f = fromList [("rec1", "anything"), ("rec2", "bad")]+          Left e = fromForm f :: Either Text SimpleRec+      unpack e `shouldContain` "input does not start with a digit"++urlEncoding :: Spec+urlEncoding = describe "urlEncoding" $ do++  it "urlDecodeForm (urlEncodeForm x) == Right x" $ property $ \(NoEmptyKeyForm x) -> do+    urlDecodeForm (urlEncodeForm x) `shouldBe` Right x++  it "urlDecodeAsForm == (fromForm <=< urlDecodeForm)" $ property $ \(x :: BSL.ByteString) -> do+    (urlDecodeAsForm x :: Either Text Form) `shouldBe` (fromForm <=< urlDecodeForm) x++  it "urlEncodeAsForm == urlEncodeForm . toForm" $ property $ \(x :: Form) -> do+    urlEncodeAsForm x `shouldBe` (urlEncodeForm . toForm) x++  it "urlDecodeForm \"\" == Right mempty" $ do+    urlDecodeForm "" `shouldBe` Right mempty

@@ -0,0 +1,82 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Web.Internal.HttpApiDataSpec (spec) where++import Data.Int+import Data.Word+import Data.Time+import qualified Data.Text as T+import qualified Data.Text.Lazy as L+import qualified Data.ByteString as BS+import Data.Version++import Data.Proxy++#if MIN_VERSION_base(4,8,0)+import Numeric.Natural+#endif++import Test.Hspec+import Test.Hspec.QuickCheck(prop)+import Test.QuickCheck++import Web.Internal.HttpApiData++import Web.Internal.TestInstances++(<=>) :: Eq a => (a -> b) -> (b -> Either T.Text a) -> a -> Bool+(f <=> g) x = g (f x) == Right x++checkUrlPiece :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a, Arbitrary a) => Proxy a -> String -> Spec+checkUrlPiece _ name = prop name (toUrlPiece <=> parseUrlPiece :: a -> Bool)++-- | Check case insensitivity for @parseUrlPiece@.+checkUrlPieceI :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Arbitrary a) => Proxy a -> String -> Spec+checkUrlPieceI _ = checkUrlPiece (Proxy :: Proxy (RandomCase a))++spec :: Spec+spec = do+  describe "toUrlPiece <=> parseUrlPiece" $ do+    checkUrlPiece  (Proxy :: Proxy ())        "()"+    checkUrlPiece  (Proxy :: Proxy Char)      "Char"+    checkUrlPieceI (Proxy :: Proxy Bool)      "Bool"+    checkUrlPieceI (Proxy :: Proxy Ordering)  "Ordering"+    checkUrlPiece  (Proxy :: Proxy Int)       "Int"+    checkUrlPiece  (Proxy :: Proxy Int8)      "Int8"+    checkUrlPiece  (Proxy :: Proxy Int16)     "Int16"+    checkUrlPiece  (Proxy :: Proxy Int32)     "Int32"+    checkUrlPiece  (Proxy :: Proxy Int64)     "Int64"+    checkUrlPiece  (Proxy :: Proxy Integer)   "Integer"+    checkUrlPiece  (Proxy :: Proxy Word)      "Word"+    checkUrlPiece  (Proxy :: Proxy Word8)     "Word8"+    checkUrlPiece  (Proxy :: Proxy Word16)    "Word16"+    checkUrlPiece  (Proxy :: Proxy Word32)    "Word32"+    checkUrlPiece  (Proxy :: Proxy Word64)    "Word64"+    checkUrlPiece  (Proxy :: Proxy String)    "String"+    checkUrlPiece  (Proxy :: Proxy T.Text)    "Text.Strict"+    checkUrlPiece  (Proxy :: Proxy L.Text)    "Text.Lazy"+    checkUrlPiece  (Proxy :: Proxy Day)       "Day"+    checkUrlPiece  (Proxy :: Proxy LocalTime) "LocalTime"+    checkUrlPiece  (Proxy :: Proxy ZonedTime) "ZonedTime"+    checkUrlPiece  (Proxy :: Proxy UTCTime)   "UTCTime"+    checkUrlPiece  (Proxy :: Proxy NominalDiffTime) "NominalDiffTime"+    checkUrlPiece  (Proxy :: Proxy Version)   "Version"++    checkUrlPiece  (Proxy :: Proxy (Maybe String))            "Maybe String"+    checkUrlPieceI (Proxy :: Proxy (Maybe Integer))           "Maybe Integer"+    checkUrlPiece  (Proxy :: Proxy (Either Integer T.Text))   "Either Integer Text"+    checkUrlPieceI (Proxy :: Proxy (Either Version Day))      "Either Version Day"++#if MIN_VERSION_base(4,8,0)+    checkUrlPiece  (Proxy :: Proxy Natural)   "Natural"+#endif++  it "bad integers are rejected" $ do+    parseUrlPieceMaybe (T.pack "123hello") `shouldBe` (Nothing :: Maybe Int)++  it "bounds checking works" $ do+    parseUrlPieceMaybe (T.pack "256") `shouldBe` (Nothing :: Maybe Int8)+    parseUrlPieceMaybe (T.pack "-10") `shouldBe` (Nothing :: Maybe Word)++  it "invalid utf8 is handled" $ do+    parseHeaderMaybe (BS.pack [128]) `shouldBe` (Nothing :: Maybe T.Text)

@@ -0,0 +1,102 @@+{-# LANGUAGE DeriveGeneric       #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Web.Internal.TestInstances+   ( RandomCase(..)+   , SimpleRec(..)+   , NoEmptyKeyForm(..)+   ) where++import           Control.Applicative+import qualified Data.ByteString.Lazy.Char8 as BSL+import           Data.Char+import qualified Data.HashMap.Strict  as HashMap+import qualified Data.Text            as T+import qualified Data.Text.Lazy       as L+import           Data.Time+import           Data.Version+import           GHC.Exts             (fromList)+import           GHC.Generics++import Test.QuickCheck++import Web.Internal.FormUrlEncoded+import Web.Internal.HttpApiData++instance Arbitrary T.Text where+  arbitrary = T.pack <$> arbitrary++instance Arbitrary L.Text where+  arbitrary = L.pack <$> arbitrary++instance Arbitrary BSL.ByteString where+  arbitrary = BSL.pack <$> arbitrary++instance Arbitrary Day where+  arbitrary = liftA3 fromGregorian (fmap abs arbitrary) arbitrary arbitrary++instance Arbitrary LocalTime where+  arbitrary = LocalTime+    <$> arbitrary+    <*> liftA3 TimeOfDay (choose (0, 23)) (choose (0, 59)) (fromInteger <$> choose (0, 60))++instance Eq ZonedTime where+  ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y++instance Arbitrary ZonedTime where+  arbitrary = ZonedTime+    <$> arbitrary+    <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z']))++instance Arbitrary UTCTime where+  arbitrary = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400))++instance Arbitrary NominalDiffTime where+  arbitrary = fromInteger <$> arbitrary++instance Arbitrary Version where+  arbitrary = (version . map abs) <$> nonempty+    where+      version branch = Version branch []+      nonempty = liftA2 (:) arbitrary arbitrary++instance Arbitrary Form where+  arbitrary = fromList <$> arbitrary++data RandomCase a = RandomCase [Bool] a++instance ToHttpApiData a => Show (RandomCase a) where+  show rc@(RandomCase _ x) = show (toUrlPiece rc) ++ " (original: " ++ show (toUrlPiece x) ++ ")"++instance Eq a => Eq (RandomCase a) where+  RandomCase _ x == RandomCase _ y = x == y++instance Arbitrary a => Arbitrary (RandomCase a) where+  arbitrary = liftA2 RandomCase nonempty arbitrary+    where+      nonempty = liftA2 (:) arbitrary arbitrary++instance ToHttpApiData a => ToHttpApiData (RandomCase a) where+  toUrlPiece (RandomCase us x) = T.pack (zipWith (\u -> if u then toUpper else toLower) (cycle us) (T.unpack (toUrlPiece x)))++instance FromHttpApiData a => FromHttpApiData (RandomCase a) where+  parseUrlPiece s = RandomCase [] <$> parseUrlPiece s++data SimpleRec = SimpleRec { rec1 :: T.Text, rec2 :: Int }+  deriving (Eq, Show, Read, Generic)++instance ToForm SimpleRec+instance FromForm SimpleRec++instance Arbitrary SimpleRec where+  arbitrary = SimpleRec <$> arbitrary <*> arbitrary++newtype NoEmptyKeyForm =+    NoEmptyKeyForm { unNoEmptyKeyForm :: Form }+    deriving Show++instance Arbitrary NoEmptyKeyForm where+  arbitrary = NoEmptyKeyForm . removeEmptyKeys <$> arbitrary+    where+      removeEmptyKeys (Form m) = Form (HashMap.delete "" m)