diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,180 @@ +0.7 + +* Change Form representation to use Map (from `containers`) instead of `HashMap`. + This prevents possible HashDOS attacks. + +0.6.3 + +* Add To/FromForm instances for () and Void + +0.6.2 + +* Support GHC-9.12 +* Require `cookie-0.5.1` + +0.6.1 + +* Require at least GHC-8.6 +* Support `cookie-0.5.0`, see [#137](https://github.com/fizruk/http-api-data/pull/137). + + Note that `cookie-0.5.0`'s parser now removes double quotes around cookie values. + +0.6 +--- + +* Use [`text-iso8601`](https://hackage.haskell.org/package/text-iso8601) + to parse and serialise `time` types. (Instead of `attoparsec-iso8601`). + Due this change some formats are slightly changed: + + - Space between timezone is not accepted + - Timezone offset can be between -23:59..23:59 + - Timezone offset is output with colon between hours and minutes + +* Require at least GHC-8.2 + +0.5.1 +----- + +* Add `toEncodedQueryParam` to `ToHttpApiData` type class. It has default + implementation using `toQueryParam`, but may be overriden with more efficient + one. + +0.5 +--- + +* Use `attoparsec-iso8601-1.1.0.0`. + `Day` and `UTCTime` parsers require at least 4 digits now, which is a breaking change. +* Drop GHC-7.8 and GHC-7.10 support. + +0.4.3 +----- + +* Add `Quarter`, `QuarterOfYear` and `Month` instances +* Support `bytestring-0.11` + +0.4.2 +----- + +* Add instances for `Const` and `Identity` + +0.4.1.1 +------- + +* Allow cookie <0.5 +* Change to `build-type: Simple` + +0.4.1 +----- + +* Use `time-compat` to provide instances for `DayOfWeek`. + +0.4 +--- + +* `NominalDiffTime` instances preserve precision (roundtrip) +* Add `Semigroup.Min`, `Max`, `First`, `Last` instances +* Add `Tagged b a` instances + +0.3.10 +--- + +* Fix 'SetCookie' instances + (see [#86](https://github.com/fizruk/http-api-data/pull/86)) +* Add support for `Fixed` + (see [#78](https://github.com/fizruk/http-api-data/pull/87)) + +0.3.9 +--- + +* GHC-8.6 support +* Remove dependency on `uri-bytestring` and use functions from `http-types` instead + (see [#75](https://github.com/fizruk/http-api-data/pull/75)) +* Add support for `SetCookie` + (see [#74](https://github.com/fizruk/http-api-data/pull/74)) + +0.3.8.1 +--- + +* GHC-8.4.1 support + +0.3.8 +--- + +* Minor changes: + * Stable URL-encoding for `Form`s (see [#67](https://github.com/fizruk/http-api-data/pull/67)): + * Introduce `urlEncodeParams` and `urlDecodeParams`; + * Introduce `urlEncodeAsFormStable` and use stable encoding for doctests; + * Add `toEntriesByKeyStable` and `toListStable`; + * Add `Semigroup` instance for `Form` (see [#69](https://github.com/fizruk/http-api-data/pull/69)); + * Relax upper bound on Cabal (see [#73](https://github.com/fizruk/http-api-data/pull/73)). + +0.3.7.2 +--- + +* Allow http-types-0.12 +* .cabal file adjustments + +0.3.7.1 +--- + +* GHC-8.2 support (see [#55](https://github.com/fizruk/http-api-data/pull/55)). + +0.3.7 +--- + +* Minor changes: + * Use [`attoparsec-iso8601`](http://hackage.haskell.org/package/attoparsec-iso8601) + for parsing of time types. Now the accepted formats are the same as by `aeson`, + i.e. parsers are more lenient + (see [#41](https://github.com/fizruk/http-api-data/pull/41)); + * Preserve fractions of a second in `ToHttpApiData` instances (see [#53](https://github.com/fizruk/http-api-data/pull/53)); + * Add `ToHttpApiData` and `FromHttpApiData` instances for `TimeOfDay` (see [#53](https://github.com/fizruk/http-api-data/pull/53)). + +0.3.6 +--- + +* Minor change: + * Add `toEncodedUrlPiece` class method for URL-encoded path segments (see [#50](https://github.com/fizruk/http-api-data/pull/50)); use efficient encoding for types whose values don't need URL-encoding. + +0.3.5 +--- + +* Minor changes: + * Add `LenientData` which always succeeds to parse (see [#45](https://github.com/fizruk/http-api-data/pull/45)). + +0.3.4 +--- + +* Minor changes: + * Add support for GHC 8.2, drop support for GHC 7.6 (see [#44](https://github.com/fizruk/http-api-data/pull/44)). + +0.3.3 +--- + +* Minor changes: + * Expose `Form` constructor from `Web.FromUrlEncoded` (see [#40](https://github.com/fizruk/http-api-data/pull/40)); + * Fix example in `FromForm` documentation (see [#39](https://github.com/fizruk/http-api-data/issues/39)). + +0.3.2 +--- + +* Minor change: + * Export `Form` type from `Web.FormUrlEncoded` (see [#37](https://github.com/fizruk/http-api-data/pull/37)). + +0.3.1 +--- + +* Minor changes: + * Add instances for `Data.UUID` (see [#34](https://github.com/fizruk/http-api-data/pull/34)). + +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)). diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,48 +0,0 @@ -#!/usr/bin/runhaskell -\begin{code} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -import Data.List ( nub ) -import Data.Version ( showVersion ) -import Distribution.Package ( PackageName(PackageName), PackageId, InstalledPackageId, packageVersion, packageName ) -import Distribution.PackageDescription ( PackageDescription(), TestSuite(..) ) -import Distribution.Simple ( defaultMainWithHooks, UserHooks(..), simpleUserHooks ) -import Distribution.Simple.Utils ( rewriteFile, createDirectoryIfMissingVerbose ) -import Distribution.Simple.BuildPaths ( autogenModulesDir ) -import Distribution.Simple.Setup ( BuildFlags(buildVerbosity), fromFlag ) -import Distribution.Simple.LocalBuildInfo ( withLibLBI, withTestLBI, LocalBuildInfo(), ComponentLocalBuildInfo(componentPackageDeps) ) -import Distribution.Verbosity ( Verbosity ) -import System.FilePath ( () ) - -main :: IO () -main = defaultMainWithHooks simpleUserHooks - { buildHook = \pkg lbi hooks flags -> do - generateBuildModule (fromFlag (buildVerbosity flags)) pkg lbi - buildHook simpleUserHooks pkg lbi hooks flags - } - -generateBuildModule :: Verbosity -> PackageDescription -> LocalBuildInfo -> IO () -generateBuildModule verbosity pkg lbi = do - let dir = autogenModulesDir lbi - createDirectoryIfMissingVerbose verbosity True dir - withLibLBI pkg lbi $ \_ libcfg -> do - withTestLBI pkg lbi $ \suite suitecfg -> do - rewriteFile (dir "Build_" ++ testName suite ++ ".hs") $ unlines - [ "module Build_" ++ testName suite ++ " where" - , "" - , "autogen_dir :: String" - , "autogen_dir = " ++ show dir - , "" - , "deps :: [String]" - , "deps = " ++ (show $ formatdeps (testDeps libcfg suitecfg)) - ] - where - formatdeps = map (formatone . snd) - formatone p = case packageName p of - PackageName n -> n ++ "-" ++ showVersion (packageVersion p) - -testDeps :: ComponentLocalBuildInfo -> ComponentLocalBuildInfo -> [(InstalledPackageId, PackageId)] -testDeps xs ys = nub $ componentPackageDeps xs ++ componentPackageDeps ys - -\end{code} diff --git a/http-api-data.cabal b/http-api-data.cabal --- a/http-api-data.cabal +++ b/http-api-data.cabal @@ -1,65 +1,100 @@ +cabal-version: 1.12 name: http-api-data -version: 0.2.4 +version: 0.7 + +synopsis: Converting to/from HTTP API data like URL pieces, headers and query parameters. +category: Web +description: + This package defines typeclasses used for converting Haskell data types to and from HTTP API data. + . + Please see README.md + license: BSD3 license-file: LICENSE author: Nickolay Kudasov maintainer: Nickolay Kudasov -synopsis: Converting to/from HTTP API data like URL pieces, headers and query parameters. -description: Please see README.md homepage: http://github.com/fizruk/http-api-data -category: Web stability: unstable -cabal-version: >= 1.8 -build-type: Custom +build-type: Simple + extra-source-files: test/*.hs CHANGELOG.md README.md +tested-with: + GHC==8.6.5, + GHC==8.8.4, + GHC==8.10.7, + GHC==9.0.2, + GHC==9.2.8, + GHC==9.4.8, + GHC==9.6.7, + GHC==9.8.4, + GHC==9.10.1, + GHC==9.12.2 + flag use-text-show description: Use text-show library for efficient ToHttpApiData implementations. default: False + manual: True library hs-source-dirs: src/ - build-depends: base >= 4.6 && < 4.10 - , text >= 0.5 - , bytestring - , time - , time-locale-compat >=0.1.1.0 && <0.2 + + -- GHC bundled + build-depends: base >= 4.12.0.0 && < 4.22 + , bytestring >= 0.10.8.2 && < 0.13 + , containers >= 0.6.0.1 && < 0.8 + , text >= 1.2.3.0 && < 1.3 || >=2.0 && <2.2 + + -- other-dependencies + build-depends: + cookie >= 0.5.1 && < 0.6 + , hashable >= 1.4.4.0 && < 1.6 + , http-types >= 0.12.4 && < 0.13 + , text-iso8601 >= 0.1.1 && < 0.2 + , tagged >= 0.8.8 && < 0.9 + , time-compat >= 1.9.5 && < 1.10 + , uuid-types >= 1.0.6 && < 1.1 + if flag(use-text-show) cpp-options: -DUSE_TEXT_SHOW - build-depends: text-show >= 2 + build-depends: text-show >= 3.10.5 && <3.12 + 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 - build-depends: HUnit - , hspec >= 1.3 - , base >= 4 && < 5 - , QuickCheck + default-language: Haskell2010 + build-tool-depends: hspec-discover:hspec-discover >= 2.7.1 && <2.12 + -- inherited depndencies + build-depends: + base + , bytestring + , cookie , http-api-data , text - , time - , bytestring + , time-compat + , containers + , uuid-types -test-suite doctest - ghc-options: -Wall - build-depends: - base, - directory >= 1.0, - doctest >= 0.11 && <0.12, - filepath - default-language: Haskell2010 - hs-source-dirs: test - main-is: DocTest.hs - type: exitcode-stdio-1.0 + build-depends: hspec >= 2.7.1 && <2.12 + , QuickCheck >= 2.13.1 && <2.16 + , quickcheck-instances >= 0.3.25.2 && <0.4 source-repository head type: git diff --git a/src/Web/FormUrlEncoded.hs b/src/Web/FormUrlEncoded.hs new file mode 100644 --- /dev/null +++ b/src/Web/FormUrlEncoded.hs @@ -0,0 +1,51 @@ +-- | +-- Convert Haskell values to and from @application/xxx-form-urlencoded@ format. +module Web.FormUrlEncoded ( + -- * Classes + ToForm (..), + FromForm (..), + + -- ** Keys for 'Form' entries + ToFormKey(..), + FromFormKey(..), + + -- * 'Form' type + Form(..), + + -- * Encoding and decoding @'Form'@s + urlEncodeAsForm, + urlEncodeAsFormStable, + urlDecodeAsForm, + + urlEncodeForm, + urlEncodeFormStable, + urlDecodeForm, + + -- * 'Generic's + genericToForm, + genericFromForm, + + -- ** Encoding options + FormOptions(..), + defaultFormOptions, + + -- * Helpers + toListStable, + toEntriesByKey, + toEntriesByKeyStable, + fromEntriesByKey, + + lookupAll, + lookupMaybe, + lookupUnique, + + parseAll, + parseMaybe, + parseUnique, + + urlEncodeParams, + urlDecodeParams, +) where + +import Web.Internal.FormUrlEncoded + diff --git a/src/Web/HttpApiData.hs b/src/Web/HttpApiData.hs --- a/src/Web/HttpApiData.hs +++ b/src/Web/HttpApiData.hs @@ -35,21 +35,23 @@ parseBoundedEnumOfI, parseBoundedTextData, + -- * Lenient data + LenientData (..), + -- * Other helpers showTextData, readTextData, ) where -import Web.HttpApiData.Internal +import Web.Internal.HttpApiData -- $setup -- -- >>> :set -XOverloadedStrings -- >>> import Control.Applicative --- >>> import Data.Time +-- >>> import Data.Time.Compat -- >>> import Data.Int -- >>> import Data.Text (Text) --- >>> import Data.Time (Day) -- >>> import Data.Version -- $examples @@ -69,7 +71,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)" diff --git a/src/Web/HttpApiData/Internal.hs b/src/Web/HttpApiData/Internal.hs deleted file mode 100644 --- a/src/Web/HttpApiData/Internal.hs +++ /dev/null @@ -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 - diff --git a/src/Web/Internal/FormUrlEncoded.hs b/src/Web/Internal/FormUrlEncoded.hs new file mode 100644 --- /dev/null +++ b/src/Web/Internal/FormUrlEncoded.hs @@ -0,0 +1,795 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# 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 #-} +module Web.Internal.FormUrlEncoded where + +import Control.Applicative (Const(Const)) +import Control.Arrow ((***)) +import Control.Monad ((<=<)) +import Data.ByteString.Builder (shortByteString, toLazyByteString) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.ByteString.Lazy.Char8 as BSL8 +import Data.Coerce (coerce) +import qualified Data.Foldable as F +import Data.Functor.Identity (Identity(Identity)) +import Data.Hashable (Hashable) +import qualified Data.Map.Strict as Map +import Data.Int (Int16, Int32, Int64, Int8) +import Data.IntMap (IntMap) +import qualified Data.IntMap as IntMap +import Data.List (intersperse, sortBy) +import Data.Monoid (All (..), Any (..), Dual (..), + Product (..), Sum (..)) +import Data.Ord (comparing) +import Data.Proxy (Proxy (..)) +import Data.Semigroup (Semigroup (..)) +import qualified Data.Semigroup as Semi +import Data.Tagged (Tagged (..)) +import Data.Text (Text) +import qualified Data.Text as Text +import qualified Data.Text.Encoding as Text +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.Lazy as Lazy +import Data.Time.Compat (Day, LocalTime, NominalDiffTime, + UTCTime, ZonedTime) +import Data.Time.Calendar.Month.Compat (Month) +import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) +import Data.Void (Void, absurd) +import Data.Word (Word16, Word32, Word64, Word8) +import GHC.Exts (Constraint, IsList (..)) +import GHC.Generics +import GHC.TypeLits +import Network.HTTP.Types.URI (urlDecode, urlEncodeBuilder) +import Numeric.Natural (Natural) +import Web.Internal.HttpApiData + +-- $setup +-- >>> :set -XDeriveGeneric -XOverloadedLists -XOverloadedStrings -XFlexibleContexts -XScopedTypeVariables -XTypeFamilies +-- >>> import GHC.Generics (Generic) +-- >>> import Data.Char (toLower) +-- >>> import Data.Text (Text) +-- >>> import Data.Word (Word8) +-- +-- >>> 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 Quarter where toFormKey = toQueryParam +instance ToFormKey QuarterOfYear where toFormKey = toQueryParam +instance ToFormKey Month 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 = coerce (toFormKey :: a -> Text) +instance ToFormKey a => ToFormKey (Sum a) where toFormKey = coerce (toFormKey :: a -> Text) +instance ToFormKey a => ToFormKey (Product a) where toFormKey = coerce (toFormKey :: a -> Text) + +instance ToFormKey a => ToFormKey (Semi.Min a) where toFormKey = coerce (toFormKey :: a -> Text) +instance ToFormKey a => ToFormKey (Semi.Max a) where toFormKey = coerce (toFormKey :: a -> Text) +instance ToFormKey a => ToFormKey (Semi.First a) where toFormKey = coerce (toFormKey :: a -> Text) +instance ToFormKey a => ToFormKey (Semi.Last a) where toFormKey = coerce (toFormKey :: a -> Text) + +instance ToFormKey a => ToFormKey (Tagged b a) where toFormKey = coerce (toFormKey :: a -> Text) + +-- | @since 0.4.2 +instance ToFormKey a => ToFormKey (Identity a) where toFormKey = coerce (toFormKey :: a -> Text) + +-- | @since 0.4.2 +instance ToFormKey a => ToFormKey (Const a b) where + toFormKey = coerce (toFormKey :: a -> Text) + +instance ToFormKey Void where toFormKey = toQueryParam +instance ToFormKey Natural where toFormKey = toQueryParam + +-- | 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 Quarter where parseFormKey = parseQueryParam +instance FromFormKey QuarterOfYear where parseFormKey = parseQueryParam +instance FromFormKey Month 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 = coerce (parseFormKey :: Text -> Either Text a) +instance FromFormKey a => FromFormKey (Sum a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) +instance FromFormKey a => FromFormKey (Product a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) + +instance FromFormKey a => FromFormKey (Semi.Min a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) +instance FromFormKey a => FromFormKey (Semi.Max a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) +instance FromFormKey a => FromFormKey (Semi.First a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) +instance FromFormKey a => FromFormKey (Semi.Last a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) + +instance FromFormKey a => FromFormKey (Tagged b a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) + +-- | @since 0.4.2 +instance FromFormKey a => FromFormKey (Identity a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) + +-- | @since 0.4.2 +instance FromFormKey a => FromFormKey (Const a b) where + parseFormKey = coerce (parseFormKey :: Text -> Either Text a) + +instance FromFormKey Void where parseFormKey = parseQueryParam +instance FromFormKey Natural where parseFormKey = parseQueryParam + +-- | 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 :: Map.Map Text [Text] } + deriving (Eq, Read, Generic, Semigroup, Monoid) + +instance Show Form where + showsPrec d form = showParen (d > 10) $ + showString "fromList " . shows (toListStable form) + +-- | _NOTE:_ 'toList' is unstable and may result in different key order (but not values). +-- For a stable conversion use 'toListStable'. +instance IsList Form where + type Item Form = (Text, Text) + fromList = Form . Map.fromListWith (flip (<>)) . fmap (\(k, v) -> (k, [v])) + toList = concatMap (\(k, vs) -> map ((,) k) vs) . Map.toList . unForm + +-- | A stable version of 'toList'. +toListStable :: Form -> [(Text, Text)] +toListStable = sortOn fst . toList + +-- | 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 + +-- | +-- +-- @since 0.6.3 +instance ToForm Void where toForm = absurd + +-- | +-- +-- @since 0.6.3 +instance ToForm () where toForm _ = Form Map.empty + +instance (ToFormKey k, ToHttpApiData v) => ToForm [(k, v)] where + toForm = fromList . map (toFormKey *** toQueryParam) + +instance (ToFormKey k, ToHttpApiData v) => ToForm (Map.Map k [v]) where + toForm = fromEntriesByKey . Map.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 . Map.fromListWith (<>) . map (toFormKey *** map toQueryParam) + +data Proxy3 a b c = Proxy3 + +type family NotSupported (cls :: k1) (a :: k2) (reason :: Symbol) :: Constraint where + 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)." ) + +-- | 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 +-- @ +-- +-- >>> urlEncodeAsFormStable 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' f = Person +-- '<$>' 'parseUnique' "name" f +-- '<*>' 'parseUnique' "age" f +-- @ +-- +-- 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 + +-- | +-- +-- @since 0.6.3 +instance FromForm Void where fromForm _ = Left "fromForm: Void" + +-- | +-- +-- @since 0.6.3 +instance FromForm () where fromForm _ = Right () + +-- | _NOTE:_ this conversion is unstable and may result in different key order (but not values). +instance (FromFormKey k, FromHttpApiData v) => FromForm [(k, v)] where + fromForm = fmap (concatMap (\(k, vs) -> map ((,) k) vs)) . toEntriesByKey + +instance (Ord k, Eq k, Hashable k, FromFormKey k, FromHttpApiData v) => FromForm (Map.Map k [v]) where + fromForm = fmap (Map.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. +-- +-- _NOTE:_ this conversion is unstable and may result in different key order +-- (but not values). For a stable encoding see 'toEntriesByKeyStable'. +toEntriesByKey :: (FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])] +toEntriesByKey = traverse parseGroup . Map.toList . unForm + where + parseGroup (k, vs) = (,) <$> parseFormKey k <*> traverse parseQueryParam vs + +-- | Parse a 'Form' into a list of entries groupped by key. +-- +-- >>> toEntriesByKeyStable [("name", "Nick"), ("color", "red"), ("color", "white")] :: Either Text [(Text, [Text])] +-- Right [("color",["red","white"]),("name",["Nick"])] +-- +-- For an unstable (but faster) conversion see 'toEntriesByKey'. +toEntriesByKeyStable :: (Ord k, FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])] +toEntriesByKeyStable = fmap (sortOn fst) . toEntriesByKey + +-- | 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'. +-- +-- _NOTE:_ this encoding is unstable and may result in different key order +-- (but not values). For a stable encoding see 'urlEncodeFormStable'. +urlEncodeForm :: Form -> BSL.ByteString +urlEncodeForm = urlEncodeParams . toList + +-- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'. +-- +-- For an unstable (but faster) encoding see 'urlEncodeForm'. +-- +-- Key-value pairs get encoded to @key=value@ and separated by @&@: +-- +-- >>> urlEncodeFormStable [("name", "Julian"), ("lastname", "Arni")] +-- "lastname=Arni&name=Julian" +-- +-- Keys with empty values get encoded to just @key@ (without the @=@ sign): +-- +-- >>> urlEncodeFormStable [("is_test", "")] +-- "is_test" +-- +-- Empty keys are allowed too: +-- +-- >>> urlEncodeFormStable [("", "foobar")] +-- "=foobar" +-- +-- However, if both key and value are empty, the key-value pair is ignored. +-- (This prevents @'urlDecodeForm' . 'urlEncodeFormStable'@ from being a true isomorphism). +-- +-- >>> urlEncodeFormStable [("", "")] +-- "" +-- +-- Everything is escaped with @'escapeURIString' 'isUnreserved'@: +-- +-- >>> urlEncodeFormStable [("fullname", "Andres Löh")] +-- "fullname=Andres%20L%C3%B6h" +urlEncodeFormStable :: Form -> BSL.ByteString +urlEncodeFormStable = urlEncodeParams . sortOn fst . toList + +-- | Encode a list of key-value pairs to an @application/x-www-form-urlencoded@ 'BSL.ByteString'. +-- +-- See also 'urlEncodeFormStable'. +urlEncodeParams :: [(Text, Text)] -> BSL.ByteString +urlEncodeParams = toLazyByteString . mconcat . intersperse (shortByteString "&") . map encodePair + where + escape = urlEncodeBuilder True . 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 = fmap toForm . urlDecodeParams + +-- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a list of key-value pairs. +-- +-- See also 'urlDecodeForm'. +urlDecodeParams :: BSL.ByteString -> Either Text [(Text, Text)] +urlDecodeParams bs = traverse parsePair pairs + where + pairs = map (BSL8.split '=') (BSL8.split '&' bs) + + unescape = Text.decodeUtf8With lenientDecode . urlDecode True . 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'@. +-- +-- _NOTE:_ this encoding is unstable and may result in different key order +-- (but not values). For a stable encoding see 'urlEncodeAsFormStable'. +urlEncodeAsForm :: ToForm a => a -> BSL.ByteString +urlEncodeAsForm = urlEncodeForm . toForm + +-- | 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 @'urlEncodeFormStable' . 'toForm'@. +-- +-- >>> urlEncodeAsFormStable Person {name = "Dennis", age = 22} +-- "age=22&name=Dennis" +urlEncodeAsFormStable :: ToForm a => a -> BSL.ByteString +urlEncodeAsFormStable = urlEncodeFormStable . 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 . Map.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 +-- @ +-- +-- >>> urlEncodeAsFormStable Project { projectName = "http-api-data", projectSize = 172 } +-- "name=http-api-data&size=172" +-- >>> 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 + } + +sortOn :: Ord b => (a -> b) -> [a] -> [a] +sortOn f = sortBy (comparing f) diff --git a/src/Web/Internal/HttpApiData.hs b/src/Web/Internal/HttpApiData.hs new file mode 100644 --- /dev/null +++ b/src/Web/Internal/HttpApiData.hs @@ -0,0 +1,905 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# 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 + +import Control.Applicative (Const(Const)) +import Control.Arrow (left, (&&&)) +import Control.Monad ((<=<)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Coerce (coerce) +import Data.Data (Data) +import qualified Data.Fixed as F +import Data.Functor.Identity (Identity(Identity)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import qualified Data.Map.Strict as Map +import Data.Monoid (All (..), Any (..), Dual (..), + First (..), Last (..), + Product (..), Sum (..)) +import qualified Data.Semigroup as Semi +import Data.Tagged (Tagged (..)) +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8', decodeUtf8With, + encodeUtf8) +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.Lazy as L +import Data.Text.Lazy.Builder (Builder, toLazyText) +import Data.Text.Read (Reader, decimal, rational, + signed) +import qualified Data.Time.ToText as TT +import qualified Data.Time.FromText as FT +import Data.Time.Compat (Day, LocalTime, + NominalDiffTime, TimeOfDay, + UTCTime, ZonedTime, DayOfWeek (..), + nominalDiffTimeToSeconds, + secondsToNominalDiffTime) +import Data.Time.Calendar.Month.Compat (Month) +import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) +import Data.Typeable (Typeable) +import qualified Data.UUID.Types as UUID +import Data.Version (Version, parseVersion, + showVersion) +import Data.Void (Void, absurd) +import Data.Word (Word16, Word32, Word64, Word8) +import qualified Network.HTTP.Types as H +import Numeric.Natural (Natural) +import Text.ParserCombinators.ReadP (readP_to_S) +import Text.Read (readMaybe) +import Web.Cookie (SetCookie, parseSetCookie, + renderSetCookie) + +#if USE_TEXT_SHOW +import TextShow (TextShow, showt) +#endif + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.Text (Text) +-- >>> import Data.Word (Word8) +-- >>> import Data.Text.Read (decimal) +-- >>> import Data.Time.Compat +-- >>> import Data.Time.Calendar.Month.Compat +-- >>> import Data.Time.Calendar.Quarter.Compat +-- >>> import Data.Version +-- >>> import Web.Cookie (SetCookie) +-- >>> 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 a URL path piece, making sure to encode any special chars. + -- The default definition uses @'H.urlEncodeBuilder' 'False'@ + -- but this may be overriden with a more efficient version. + toEncodedUrlPiece :: a -> BS.Builder + toEncodedUrlPiece = H.urlEncodeBuilder False . encodeUtf8 . toUrlPiece + + -- | Convert to HTTP header value. + toHeader :: a -> ByteString + toHeader = encodeUtf8 . toUrlPiece + + -- | Convert to query param value. + toQueryParam :: a -> Text + toQueryParam = toUrlPiece + + -- | Convert to URL query param, + -- The default definition uses @'H.urlEncodeBuilder' 'True'@ + -- but this may be overriden with a more efficient version. + -- + -- @since 0.5.1 + toEncodedQueryParam :: a -> BS.Builder + toEncodedQueryParam = H.urlEncodeBuilder True . encodeUtf8 . toQueryParam + +-- | 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 insensitive 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 presence 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) + +-- | Convert to a URL-encoded path piece using 'toUrlPiece'. +-- /Note/: this function does not check if the result contains unescaped characters! +-- This function can be used to override 'toEncodedUrlPiece' as a more efficient implementation +-- when the resulting URL piece /never/ has to be escaped. +unsafeToEncodedUrlPiece :: ToHttpApiData a => a -> BS.Builder +unsafeToEncodedUrlPiece = BS.byteString . encodeUtf8 . toUrlPiece + +-- | Convert to a URL-encoded query param using 'toQueryParam'. +-- /Note/: this function does not check if the result contains unescaped characters! +-- +-- @since 0.5.1 +unsafeToEncodedQueryParam :: ToHttpApiData a => a -> BS.Builder +unsafeToEncodedQueryParam = BS.byteString . encodeUtf8 . toQueryParam + +-- | +-- >>> toUrlPiece () +-- "_" +instance ToHttpApiData () where + toUrlPiece _ = "_" + toHeader _ = "_" + toEncodedUrlPiece _ = "_" + toEncodedQueryParam _ = "_" + +instance ToHttpApiData Char where + toUrlPiece = T.singleton + +-- | +-- >>> toUrlPiece (Version [1, 2, 3] []) +-- "1.2.3" +instance ToHttpApiData Version where + toUrlPiece = T.pack . showVersion + toEncodedUrlPiece = unsafeToEncodedUrlPiece + toEncodedQueryParam = unsafeToEncodedQueryParam + +instance ToHttpApiData Void where toUrlPiece = absurd +instance ToHttpApiData Natural where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam + +instance ToHttpApiData Bool where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam + +instance ToHttpApiData Double where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Float where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Int where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Int8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Int16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Int32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Int64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Integer where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Word where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Word8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam + +-- | Note: this instance is not polykinded +instance F.HasResolution a => ToHttpApiData (F.Fixed (a :: Type)) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam + +-- | +-- >>> toUrlPiece (fromGregorian 2015 10 03) +-- "2015-10-03" +instance ToHttpApiData Day where + toUrlPiece = runTT TT.buildDay + toEncodedUrlPiece = unsafeToEncodedUrlPiece + toEncodedQueryParam = unsafeToEncodedQueryParam + +-- | +-- >>> toUrlPiece $ TimeOfDay 14 55 23.1 +-- "14:55:23.100" +instance ToHttpApiData TimeOfDay where + toUrlPiece = runTT TT.buildTimeOfDay + toEncodedUrlPiece = unsafeToEncodedUrlPiece + -- no toEncodedQueryParam as : is unsafe char. + +-- | +-- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 21.687) +-- "2015-10-03T14:55:21.687" +instance ToHttpApiData LocalTime where + toUrlPiece = runTT TT.buildLocalTime + toEncodedUrlPiece = unsafeToEncodedUrlPiece + -- no toEncodedQueryParam as : is unsafe char. + +-- | +-- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 51.001)) utc +-- "2015-10-03T14:55:51.001Z" +-- +-- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 51.001)) (TimeZone 120 True "EET") +-- "2015-10-03T14:55:51.001+02:00" +-- +instance ToHttpApiData ZonedTime where + toUrlPiece = runTT TT.buildZonedTime + toEncodedUrlPiece = unsafeToEncodedUrlPiece + -- no toEncodedQueryParam as : is unsafe char. + +-- | +-- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864.5 +-- "2015-10-03T00:14:24.500Z" +instance ToHttpApiData UTCTime where + toUrlPiece = runTT TT.buildUTCTime + toEncodedUrlPiece = unsafeToEncodedUrlPiece + -- no toEncodedQueryParam as : is unsafe char. + +-- | +-- >>> toUrlPiece Monday +-- "monday" +instance ToHttpApiData DayOfWeek where + toUrlPiece Monday = "monday" + toUrlPiece Tuesday = "tuesday" + toUrlPiece Wednesday = "wednesday" + toUrlPiece Thursday = "thursday" + toUrlPiece Friday = "friday" + toUrlPiece Saturday = "saturday" + toUrlPiece Sunday = "sunday" + + toEncodedUrlPiece = unsafeToEncodedUrlPiece + toEncodedQueryParam = unsafeToEncodedQueryParam + +-- | +-- >>> toUrlPiece Q4 +-- "q4" +instance ToHttpApiData QuarterOfYear where + toUrlPiece = runTT TT.buildQuarterOfYear + + toEncodedUrlPiece = unsafeToEncodedUrlPiece + toEncodedQueryParam = unsafeToEncodedQueryParam + +-- | +-- >>> import Data.Time.Calendar.Quarter.Compat (Quarter (..)) +-- >>> MkQuarter 8040 +-- 2010-Q1 +-- +-- >>> toUrlPiece $ MkQuarter 8040 +-- "2010-q1" +-- +instance ToHttpApiData Quarter where + toUrlPiece = runTT TT.buildQuarter + + toEncodedUrlPiece = unsafeToEncodedUrlPiece + toEncodedQueryParam = unsafeToEncodedQueryParam + +-- | +-- >>> import Data.Time.Calendar.Month.Compat (Month (..)) +-- >>> MkMonth 24482 +-- 2040-03 +-- +-- >>> toUrlPiece $ MkMonth 24482 +-- "2040-03" +-- +instance ToHttpApiData Month where + toUrlPiece = runTT TT.buildMonth + + toEncodedUrlPiece = unsafeToEncodedUrlPiece + toEncodedQueryParam = unsafeToEncodedQueryParam + +instance ToHttpApiData NominalDiffTime where + toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds + + toEncodedQueryParam = unsafeToEncodedQueryParam + toEncodedUrlPiece = unsafeToEncodedUrlPiece + +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 = coerce (toUrlPiece :: Bool -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: Bool -> BS.Builder) + +instance ToHttpApiData Any where + toUrlPiece = coerce (toUrlPiece :: Bool -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: Bool -> BS.Builder) + +instance ToHttpApiData a => ToHttpApiData (Dual a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +instance ToHttpApiData a => ToHttpApiData (Sum a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +instance ToHttpApiData a => ToHttpApiData (Product a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +instance ToHttpApiData a => ToHttpApiData (First a) where + toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: Maybe a -> BS.Builder) + +instance ToHttpApiData a => ToHttpApiData (Last a) where + toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: Maybe a -> BS.Builder) + +instance ToHttpApiData a => ToHttpApiData (Semi.Min a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +instance ToHttpApiData a => ToHttpApiData (Semi.Max a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +instance ToHttpApiData a => ToHttpApiData (Semi.First a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +instance ToHttpApiData a => ToHttpApiData (Semi.Last a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +-- | +-- >>> 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 + +-- | /Note:/ this instance works correctly for alphanumeric name and value +-- +-- >>> let Right c = parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie +-- >>> toUrlPiece c +-- "SESSID=r2t5uvjq435r4q7ib3vtdjq120" +-- +-- >>> toHeader c +-- "SESSID=r2t5uvjq435r4q7ib3vtdjq120" +-- +instance ToHttpApiData SetCookie where + toUrlPiece = decodeUtf8With lenientDecode . toHeader + toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie + -- toEncodedUrlPiece = renderSetCookie -- doesn't do things. + +-- | Note: this instance is not polykinded +instance ToHttpApiData a => ToHttpApiData (Tagged (b :: Type) a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toHeader = coerce (toHeader :: a -> ByteString) + toQueryParam = coerce (toQueryParam :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +-- | @since 0.4.2 +instance ToHttpApiData a => ToHttpApiData (Const a b) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toHeader = coerce (toHeader :: a -> ByteString) + toQueryParam = coerce (toQueryParam :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +-- | @since 0.4.2 +instance ToHttpApiData a => ToHttpApiData (Identity a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toHeader = coerce (toHeader :: a -> ByteString) + toQueryParam = coerce (toQueryParam :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +-- | +-- >>> 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 + +-- | 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 ("underflow: " <> s <> " (should be a non-negative integer)") + else Right (fromInteger n) + +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 + +-- | Note: this instance is not polykinded +instance F.HasResolution a => FromHttpApiData (F.Fixed (a :: Type)) where + parseUrlPiece = runReader rational + +-- | +-- >>> toGregorian <$> parseUrlPiece "2016-12-01" +-- Right (2016,12,1) +instance FromHttpApiData Day where parseUrlPiece = runFT FT.parseDay + +-- | +-- >>> parseUrlPiece "14:55:01.333" :: Either Text TimeOfDay +-- Right 14:55:01.333 +instance FromHttpApiData TimeOfDay where parseUrlPiece = runFT FT.parseTimeOfDay + +-- | +-- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime +-- Right 2015-10-03 14:55:01 +instance FromHttpApiData LocalTime where parseUrlPiece = runFT FT.parseLocalTime + +-- | +-- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime +-- Right 2015-10-03 14:55:01 +0000 +-- +-- >>> parseQueryParam "2016-12-31T01:00:00Z" :: Either Text ZonedTime +-- Right 2016-12-31 01:00:00 +0000 +instance FromHttpApiData ZonedTime where parseUrlPiece = runFT FT.parseZonedTime + +-- | +-- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime +-- Right 2015-10-03 00:14:24 UTC +instance FromHttpApiData UTCTime where parseUrlPiece = runFT FT.parseUTCTime + +-- | +-- >>> parseUrlPiece "Monday" :: Either Text DayOfWeek +-- Right Monday +instance FromHttpApiData DayOfWeek where + parseUrlPiece t = case Map.lookup (T.toLower t) m of + Just dow -> Right dow + Nothing -> Left $ "Incorrect DayOfWeek: " <> T.take 10 t + where + m :: Map.Map Text DayOfWeek + m = Map.fromList [ (toUrlPiece dow, dow) | dow <- [Monday .. Sunday] ] + + +instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secondsToNominalDiffTime . parseUrlPiece + +-- | +-- >>> parseUrlPiece "2021-01" :: Either Text Month +-- Right 2021-01 +instance FromHttpApiData Month where parseUrlPiece = runFT FT.parseMonth + +-- | +-- >>> parseUrlPiece "2021-q1" :: Either Text Quarter +-- Right 2021-Q1 +instance FromHttpApiData Quarter where parseUrlPiece = runFT FT.parseQuarter + +-- | +-- >>> parseUrlPiece "q2" :: Either Text QuarterOfYear +-- Right Q2 +-- +-- >>> parseUrlPiece "Q3" :: Either Text QuarterOfYear +-- Right Q3 +instance FromHttpApiData QuarterOfYear where parseUrlPiece = runFT FT.parseQuarterOfYear + +instance FromHttpApiData All where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool) +instance FromHttpApiData Any where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool) + +instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) +instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) +instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) +instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a)) +instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a)) + +instance FromHttpApiData a => FromHttpApiData (Semi.Min a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) +instance FromHttpApiData a => FromHttpApiData (Semi.Max a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) +instance FromHttpApiData a => FromHttpApiData (Semi.First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) +instance FromHttpApiData a => FromHttpApiData (Semi.Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) + +-- | +-- >>> 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 + +instance ToHttpApiData UUID.UUID where + toUrlPiece = UUID.toText + toHeader = UUID.toASCIIBytes + toEncodedUrlPiece = unsafeToEncodedUrlPiece + +instance FromHttpApiData UUID.UUID where + parseUrlPiece = maybe (Left "invalid UUID") Right . UUID.fromText + parseHeader = maybe (Left "invalid UUID") Right . UUID.fromASCIIBytes + + +-- | Lenient parameters. 'FromHttpApiData' combinators always return `Right`. +-- +-- @since 0.3.5 +newtype LenientData a = LenientData { getLenientData :: Either Text a } + deriving (Eq, Ord, Show, Read, Typeable, Data, Functor, Foldable, Traversable) + +instance FromHttpApiData a => FromHttpApiData (LenientData a) where + parseUrlPiece = Right . LenientData . parseUrlPiece + parseHeader = Right . LenientData . parseHeader + parseQueryParam = Right . LenientData . parseQueryParam + +-- | /Note:/ this instance works correctly for alphanumeric name and value +-- +-- >>> parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie +-- Right (SetCookie {setCookieName = "SESSID", setCookieValue = "r2t5uvjq435r4q7ib3vtdjq120", setCookiePath = Nothing, setCookieExpires = Nothing, setCookieMaxAge = Nothing, setCookieDomain = Nothing, setCookieHttpOnly = False, setCookieSecure = False, setCookieSameSite = Nothing, setCookiePartitioned = False}) +instance FromHttpApiData SetCookie where + parseUrlPiece = parseHeader . encodeUtf8 + parseHeader = Right . parseSetCookie + +-- | Note: this instance is not polykinded +instance FromHttpApiData a => FromHttpApiData (Tagged (b :: Type) a) where + parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) + parseHeader = coerce (parseHeader :: ByteString -> Either Text a) + parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a) + +-- | @since 0.4.2 +instance FromHttpApiData a => FromHttpApiData (Const a b) where + parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) + parseHeader = coerce (parseHeader :: ByteString -> Either Text a) + parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a) + +-- | @since 0.4.2 +instance FromHttpApiData a => FromHttpApiData (Identity a) where + parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) + parseHeader = coerce (parseHeader :: ByteString -> Either Text a) + parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a) + +------------------------------------------------------------------------------- +-- Helpers +------------------------------------------------------------------------------- + +runTT :: (a -> Builder) -> a -> Text +runTT f x = L.toStrict (toLazyText (f x)) + +runFT :: (Text -> Either String a) -> Text -> Either Text a +runFT f t = case f t of + Left err -> Left (T.pack err) + Right x -> Right x diff --git a/test/DocTest.hs b/test/DocTest.hs deleted file mode 100644 --- a/test/DocTest.hs +++ /dev/null @@ -1,30 +0,0 @@ -module Main where - -import Build_doctest (autogen_dir, deps) -import Control.Applicative -import Control.Monad -import Data.List -import System.Directory -import System.FilePath -import Test.DocTest - -main :: IO () -main = getSources >>= \sources -> doctest $ - "-isrc" - : ("-i" ++ autogen_dir) - : "-optP-include" - : ("-optP" ++ autogen_dir ++ "/cabal_macros.h") - : "-hide-all-packages" - : map ("-package="++) deps ++ sources - -getSources :: IO [FilePath] -getSources = filter (isSuffixOf ".hs") <$> go "src" - where - go dir = do - (dirs, files) <- getFilesAndDirectories dir - (files ++) . concat <$> mapM go dirs - -getFilesAndDirectories :: FilePath -> IO ([FilePath], [FilePath]) -getFilesAndDirectories dir = do - c <- map (dir ) . filter (`notElem` ["..", "."]) <$> getDirectoryContents dir - (,) <$> filterM doesDirectoryExist c <*> filterM doesFileExist c diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -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 #-} diff --git a/test/Web/Internal/FormUrlEncodedSpec.hs b/test/Web/Internal/FormUrlEncodedSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/Internal/FormUrlEncodedSpec.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Web.Internal.FormUrlEncodedSpec (spec) where + +import Control.Monad ((<=<)) +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.Map.Strict as Map +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 + Map.member "rec1" f `shouldBe` True + Map.member "rec2" f `shouldBe` True + + it "contains the correct record values" $ property $ \(x :: SimpleRec) -> do + let f = unForm $ toForm x + Map.lookup "rec1" f `shouldBe` Just [rec1 x] + (parseQueryParams <$> Map.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)] + r1 = fromForm f1 :: Either Text SimpleRec + fmap toForm r1 `shouldBe` Right f1 + + it "returns the underlying error" $ do + let f = fromList [("rec1", "anything"), ("rec2", "bad")] + e = either id (const "no error") (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 diff --git a/test/Web/Internal/HttpApiDataSpec.hs b/test/Web/Internal/HttpApiDataSpec.hs new file mode 100644 --- /dev/null +++ b/test/Web/Internal/HttpApiDataSpec.hs @@ -0,0 +1,130 @@ +{-# LANGUAGE ScopedTypeVariables #-} +module Web.Internal.HttpApiDataSpec (spec) where + + +import qualified Data.ByteString as BS +import Data.ByteString.Builder (toLazyByteString) +import Data.Char +import qualified Data.Fixed as F +import Data.Int +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as L +import Data.Time.Compat +import Data.Time.Calendar.Month.Compat (Month) +import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) +import qualified Data.UUID.Types as UUID +import Data.Version +import Data.Word +import Web.Cookie (SetCookie, defaultSetCookie, + setCookieName, setCookieValue) + +import Data.Proxy + +import Numeric.Natural + +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck + +import Web.Internal.HttpApiData + +import Web.Internal.TestInstances + +(<=>) :: forall a b. (Show a, Show b, Eq a) => (a -> b) -> (b -> Either T.Text a) -> a -> Property +(f <=> g) x = counterexample + (show lhs' ++ " : " ++ show lhs ++ " /= " ++ show rhs) + (lhs == rhs) + where + lhs' = f x + lhs = g lhs' :: Either T.Text a + rhs = Right x :: Either T.Text a + +encodedUrlPieceProp :: ToHttpApiData a => a -> Property +encodedUrlPieceProp x = toLazyByteString (toEncodedUrlPiece (toUrlPiece x)) === toLazyByteString (toEncodedUrlPiece x) + +encodedQueryParamProp :: ToHttpApiData a => a -> Property +encodedQueryParamProp x = toLazyByteString (toEncodedQueryParam (toQueryParam x)) === toLazyByteString (toEncodedQueryParam x) + +-- | Check 'ToHttpApiData' and 'FromHttpApiData' compatibility +checkUrlPiece :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a, Arbitrary a) => Proxy a -> String -> Spec +checkUrlPiece _ = checkUrlPiece' (arbitrary :: Gen a) + +checkUrlPiece' :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a) => Gen a -> String -> Spec +checkUrlPiece' gen name = describe name $ do + prop "toUrlPiece <=> parseUrlPiece" $ forAll gen (toUrlPiece <=> parseUrlPiece :: a -> Property) + prop "toQueryParam <=> parseQueryParam" $ forAll gen (toQueryParam <=> parseQueryParam :: a -> Property) + prop "toHeader <=> parseHeader" $ forAll gen (toHeader <=> parseHeader :: a -> Property) + prop "toEncodedUrlPiece encodes correctly" $ forAll gen encodedUrlPieceProp + prop "toEncodedQueryParam encodes correctly" $ forAll gen encodedQueryParamProp + +-- | 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 "Instances" $ 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 TimeOfDay) "TimeOfDay" + checkUrlPiece (Proxy :: Proxy LocalTime) "LocalTime" + checkUrlPiece (Proxy :: Proxy ZonedTime) "ZonedTime" + checkUrlPiece (Proxy :: Proxy UTCTime) "UTCTime" + checkUrlPiece (Proxy :: Proxy NominalDiffTime) "NominalDiffTime" + checkUrlPiece (Proxy :: Proxy DayOfWeek) "DayOfWeek" + checkUrlPiece (Proxy :: Proxy Quarter) "Quarter" + checkUrlPiece (Proxy :: Proxy QuarterOfYear) "QuarterOfYear" + checkUrlPiece (Proxy :: Proxy Month) "Month" + checkUrlPiece (Proxy :: Proxy DayOfWeek) "DayOfWeek" + checkUrlPiece (Proxy :: Proxy Version) "Version" + checkUrlPiece (Proxy :: Proxy UUID.UUID) "UUID" + checkUrlPiece' setCookieGen "Cookie" + + checkUrlPiece (Proxy :: Proxy F.Uni) "Uni" + checkUrlPiece (Proxy :: Proxy F.Deci) "Deci" + checkUrlPiece (Proxy :: Proxy F.Centi) "Centi" + checkUrlPiece (Proxy :: Proxy F.Milli) "Milli" + checkUrlPiece (Proxy :: Proxy F.Micro) "Micro" + checkUrlPiece (Proxy :: Proxy F.Nano) "Nano" + checkUrlPiece (Proxy :: Proxy F.Pico) "Pico" + + 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" + + checkUrlPiece (Proxy :: Proxy Natural) "Natural" + + 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) + +setCookieGen :: Gen SetCookie +setCookieGen = do + n <- TE.encodeUtf8 . T.pack . filter isAlphaNum <$> arbitrary + v <- TE.encodeUtf8 . T.pack . filter isAlphaNum <$> arbitrary + return $ defaultSetCookie { setCookieName = n, setCookieValue = v } diff --git a/test/Web/Internal/TestInstances.hs b/test/Web/Internal/TestInstances.hs new file mode 100644 --- /dev/null +++ b/test/Web/Internal/TestInstances.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Web.Internal.TestInstances + ( RandomCase(..) + , SimpleRec(..) + , NoEmptyKeyForm(..) + ) where + +import Control.Applicative -- for ghc < 9.6 +import Data.Char +import qualified Data.Map.Strict as Map +import qualified Data.Text as T +import Data.Time.Compat +import GHC.Exts (fromList) +import GHC.Generics + +import Test.QuickCheck +import Test.QuickCheck.Instances () + +import Web.Internal.FormUrlEncoded +import Web.Internal.HttpApiData + +instance Eq ZonedTime where + ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y + +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 (Map.delete "" m)