http-api-data-0.4/0000755000000000000000000000000007346545000012203 5ustar0000000000000000http-api-data-0.4/CHANGELOG.md0000755000000000000000000001006007346545000014014 0ustar00000000000000000.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/78)) * 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)). 0.2.3 --- * Add more parser helpers for `Bounded` `Enum` types. 0.2.2 --- * Add instances for more `time` types: `LocalTime`, `ZonedTime`, `UTCTime` and `NominalDiffTime` 0.2.1 --- * Add helpers for multiple URL pieces and query params: * `toUrlPieces`, `parseUrlPieces` * `toQueryParams`, `parseQueryParams` 0.2 --- * Export helper functions from `Web.HttpApiData`: * `parseUrlPieceMaybe`, `parseHeaderMaybe`, `parseQueryParamMaybe` * `parseUrlPieceWithPrefix`, `parseHeaderWithPrefix`, `parseQueryParamWithPrefix` * `showTextData`, `readTextData`, `parseBoundedTextData` * Fix AMP related warnings 0.1.1 --- * Add `use-text-show` flag to optionally use more efficient `TextShow` instances http-api-data-0.4/LICENSE0000644000000000000000000000253107346545000013211 0ustar0000000000000000The following license covers this documentation, and the source code, except where otherwise indicated. Copyright 2015, Nickolay Kudasov. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. http-api-data-0.4/README.md0000755000000000000000000000262707346545000013474 0ustar0000000000000000# 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. ### Examples Booleans: ``` >>> toUrlPiece True "true" >>> parseUrlPiece "false" :: Either Text Bool Right False >>> parseUrlPieces ["true", "false", "undefined"] :: Either Text [Bool] Left "could not parse: `undefined'" ``` Numbers: ``` >>> toQueryParam 45.2 "45.2" >>> parseQueryParam "452" :: Either Text Int Right 452 >>> toQueryParams [1..5] ["1","2","3","4","5"] >>> parseQueryParams ["127", "255"] :: Either Text [Int8] Left "out of bounds: `255' (should be between -128 and 127)" ``` Strings: ``` >>> toHeader "hello" "hello" >>> parseHeader "world" :: Either Text String Right "world" ``` Calendar day: ``` >>> toQueryParam (fromGregorian 2015 10 03) "2015-10-03" >>> toGregorian <$> parseQueryParam "2016-12-01" Right (2016,12,1) ``` ## Contributing Contributions and bug reports are welcome! http-api-data-0.4/Setup.lhs0000644000000000000000000000153207346545000014014 0ustar0000000000000000\begin{code} {-# LANGUAGE CPP #-} {-# OPTIONS_GHC -Wall #-} module Main (main) where #ifndef MIN_VERSION_cabal_doctest #define MIN_VERSION_cabal_doctest(x,y,z) 0 #endif #if MIN_VERSION_cabal_doctest(1,0,0) import Distribution.Extra.Doctest ( defaultMainWithDoctests ) main :: IO () main = defaultMainWithDoctests "doctests" #else #ifdef MIN_VERSION_Cabal -- If the macro is defined, we have new cabal-install, -- but for some reason we don't have cabal-doctest in package-db -- -- Probably we are running cabal sdist, when otherwise using new-build -- workflow #warning You are configuring this package without cabal-doctest installed. \ The doctests test-suite will not work as a result. \ To fix this, install cabal-doctest before configuring. #endif import Distribution.Simple main :: IO () main = defaultMain #endif \end{code} http-api-data-0.4/http-api-data.cabal0000644000000000000000000000757007346545000015635 0ustar0000000000000000cabal-version: >= 1.10 name: http-api-data version: 0.4 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 homepage: http://github.com/fizruk/http-api-data stability: unstable build-type: Custom extra-source-files: include/overlapping-compat.h test/*.hs CHANGELOG.md README.md tested-with: GHC==7.8.4, GHC==7.10.3, GHC==8.0.2, GHC==8.2.2, GHC==8.4.4, GHC==8.6.2 custom-setup setup-depends: base, Cabal, cabal-doctest >=1.0.6 && <1.1 flag use-text-show description: Use text-show library for efficient ToHttpApiData implementations. default: False manual: True library hs-source-dirs: src/ include-dirs: include/ -- GHC bundled build-depends: base >= 4.7 && < 4.13 , bytestring >= 0.10.4.0 && < 0.11 , containers >= 0.5.5.1 && < 0.7 , text >= 1.2.3.0 && < 1.3 , time >= 1.4.2 && < 1.9 -- other-dependencies build-depends: attoparsec >= 0.13.2.2 && < 0.14 , attoparsec-iso8601 >= 1.0.1.0 && < 1.1 , base-compat >= 0.10.5 && < 0.11 , cookie >= 0.4.3 && < 0.4.5 , hashable >= 1.2.7.0 && < 1.3 , http-types >= 0.12.2 && < 0.13 , tagged >= 0.8.5 && < 0.9 , time-locale-compat >= 0.1.1.5 && < 0.2 , unordered-containers >= 0.2.9.0 && < 0.3 , uuid-types >= 1.0.3 && <1.1 if !impl(ghc >= 7.10) build-depends: nats >= 1.1.2 && < 1.2, void >= 0.7.2 && < 0.8 if !impl(ghc >= 8.0) build-depends: semigroups >= 0.18.5 && < 0.19 if flag(use-text-show) cpp-options: -DUSE_TEXT_SHOW build-depends: text-show >= 3.7.4 && <3.8 exposed-modules: Web.HttpApiData 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 other-modules: Web.Internal.FormUrlEncodedSpec Web.Internal.HttpApiDataSpec Web.Internal.TestInstances hs-source-dirs: test ghc-options: -Wall default-language: Haskell2010 build-tool-depends: hspec-discover:hspec-discover >= 2.6.0 && <2.7 -- inherited depndencies build-depends: base , base-compat , bytestring , cookie , http-api-data , nats , text , time , unordered-containers , uuid-types build-depends: HUnit >= 1.6.0.0 && <1.7 , hspec >= 2.6.0 && <2.7 , QuickCheck >= 2.11.3 && <2.13 , quickcheck-instances >= 0.3.19 && <0.4 test-suite doctests ghc-options: -Wall build-depends: base, directory >= 1.0, doctest >= 0.16.0 && <0.17, filepath default-language: Haskell2010 hs-source-dirs: test main-is: doctests.hs type: exitcode-stdio-1.0 source-repository head type: git location: https://github.com/fizruk/http-api-data http-api-data-0.4/include/0000755000000000000000000000000007346545000013626 5ustar0000000000000000http-api-data-0.4/include/overlapping-compat.h0000755000000000000000000000032207346545000017606 0ustar0000000000000000#if __GLASGOW_HASKELL__ >= 710 #define OVERLAPPABLE_ {-# OVERLAPPABLE #-} #define OVERLAPPING_ {-# OVERLAPPING #-} #else {-# LANGUAGE OverlappingInstances #-} #define OVERLAPPABLE_ #define OVERLAPPING_ #endif http-api-data-0.4/src/Web/0000755000000000000000000000000007346545000013507 5ustar0000000000000000http-api-data-0.4/src/Web/FormUrlEncoded.hs0000644000000000000000000000146307346545000016717 0ustar0000000000000000-- | -- 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 http-api-data-0.4/src/Web/HttpApiData.hs0000644000000000000000000000360107346545000016206 0ustar0000000000000000-- | -- Convert Haskell values to and from HTTP API data -- such as URL pieces, headers and query parameters. module Web.HttpApiData ( -- * Examples -- $examples -- * Classes ToHttpApiData (..), FromHttpApiData (..), -- * @'Maybe'@ parsers parseUrlPieceMaybe, parseHeaderMaybe, parseQueryParamMaybe, -- * Prefix parsers parseUrlPieceWithPrefix, parseHeaderWithPrefix, parseQueryParamWithPrefix, -- * Multiple URL pieces toUrlPieces, parseUrlPieces, -- * Multiple query params toQueryParams, parseQueryParams, -- * Parsers for @'Bounded'@ @'Enum'@s parseBoundedUrlPiece, parseBoundedQueryParam, parseBoundedHeader, parseBoundedEnumOf, parseBoundedEnumOfI, parseBoundedTextData, -- * Lenient data LenientData (..), -- * Other helpers showTextData, readTextData, ) where import Web.Internal.HttpApiData -- $setup -- -- >>> :set -XOverloadedStrings -- >>> import Control.Applicative -- >>> import Data.Time -- >>> import Data.Int -- >>> import Data.Text (Text) -- >>> import Data.Time (Day) -- >>> import Data.Version -- $examples -- -- Booleans: -- -- >>> toUrlPiece True -- "true" -- >>> parseUrlPiece "false" :: Either Text Bool -- Right False -- >>> parseUrlPieces ["true", "false", "undefined"] :: Either Text [Bool] -- Left "could not parse: `undefined'" -- -- Numbers: -- -- >>> toQueryParam 45.2 -- "45.2" -- >>> parseQueryParam "452" :: Either Text Int -- Right 452 -- >>> 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)" -- -- Strings: -- -- >>> toHeader "hello" -- "hello" -- >>> parseHeader "world" :: Either Text String -- Right "world" -- -- Calendar day: -- -- >>> toQueryParam (fromGregorian 2015 10 03) -- "2015-10-03" -- >>> toGregorian <$> parseQueryParam "2016-12-01" -- Right (2016,12,1) http-api-data-0.4/src/Web/Internal/0000755000000000000000000000000007346545000015263 5ustar0000000000000000http-api-data-0.4/src/Web/Internal/FormUrlEncoded.hs0000644000000000000000000007535607346545000020507 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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 #-} #include "overlapping-compat.h" module Web.Internal.FormUrlEncoded where import Prelude () import Prelude.Compat 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.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap import Data.Int (Int16, Int32, Int64, Int8) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (intersperse, sortBy) import Data.Map (Map) import qualified Data.Map as Map 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 (Day, LocalTime, NominalDiffTime, UTCTime, ZonedTime) import Data.Void (Void) 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 -- >>> :set -XOverloadedLists -- >>> :set -XOverloadedStrings -- >>> :set -XFlexibleContexts -- >>> :set -XScopedTypeVariables -- >>> :set -XTypeFamilies -- >>> import Data.Char (toLower) -- -- >>> data Person = Person { name :: String, age :: Int } deriving (Show, Generic) -- >>> instance ToForm Person -- >>> instance FromForm Person -- -- >>> data Post = Post { title :: String, subtitle :: Maybe String, comments :: [String]} deriving (Generic, Show) -- >>> instance ToForm Post -- >>> instance FromForm Post -- -- >>> data Project = Project { projectName :: String, projectSize :: Int } deriving (Generic, Show) -- >>> let myOptions = FormOptions { fieldLabelModifier = map toLower . drop (length ("project" :: String)) } -- >>> instance ToForm Project where toForm = genericToForm myOptions -- >>> instance FromForm Project where fromForm = genericFromForm myOptions -- | Typeclass for types that can be used as keys in a 'Form'-like container (like 'Map'). class ToFormKey k where -- | Render a key for a 'Form'. toFormKey :: k -> Text instance ToFormKey () where toFormKey = toQueryParam instance ToFormKey Char where toFormKey = toQueryParam instance ToFormKey Bool where toFormKey = toQueryParam instance ToFormKey Ordering where toFormKey = toQueryParam instance ToFormKey Double where toFormKey = toQueryParam instance ToFormKey Float where toFormKey = toQueryParam instance ToFormKey Int where toFormKey = toQueryParam instance ToFormKey Int8 where toFormKey = toQueryParam instance ToFormKey Int16 where toFormKey = toQueryParam instance ToFormKey Int32 where toFormKey = toQueryParam instance ToFormKey Int64 where toFormKey = toQueryParam instance ToFormKey Integer where toFormKey = toQueryParam instance ToFormKey Word where toFormKey = toQueryParam instance ToFormKey Word8 where toFormKey = toQueryParam instance ToFormKey Word16 where toFormKey = toQueryParam instance ToFormKey Word32 where toFormKey = toQueryParam instance ToFormKey Word64 where toFormKey = toQueryParam instance ToFormKey Day where toFormKey = toQueryParam instance ToFormKey LocalTime where toFormKey = toQueryParam instance ToFormKey ZonedTime where toFormKey = toQueryParam instance ToFormKey UTCTime where toFormKey = toQueryParam instance ToFormKey NominalDiffTime where toFormKey = toQueryParam instance ToFormKey String where toFormKey = toQueryParam instance ToFormKey Text where toFormKey = toQueryParam instance ToFormKey Lazy.Text where toFormKey = toQueryParam instance ToFormKey All where toFormKey = toQueryParam instance ToFormKey Any where toFormKey = toQueryParam instance ToFormKey a => ToFormKey (Dual a) where toFormKey = 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) 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 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) 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 :: HashMap 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 . HashMap.fromListWith (flip (<>)) . fmap (\(k, v) -> (k, [v])) toList = concatMap (\(k, vs) -> map ((,) k) vs) . HashMap.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 instance (ToFormKey k, ToHttpApiData v) => ToForm [(k, v)] where toForm = fromList . map (toFormKey *** toQueryParam) instance (ToFormKey k, ToHttpApiData v) => ToForm (Map k [v]) where toForm = fromEntriesByKey . Map.toList instance (ToFormKey k, ToHttpApiData v) => ToForm (HashMap k [v]) where toForm = fromEntriesByKey . HashMap.toList instance ToHttpApiData v => ToForm (IntMap [v]) where toForm = fromEntriesByKey . IntMap.toList -- | Convert a list of entries groupped by key into a 'Form'. -- -- >>> fromEntriesByKey [("name",["Nick"]),("color",["red","blue"])] -- fromList [("color","red"),("color","blue"),("name","Nick")] fromEntriesByKey :: (ToFormKey k, ToHttpApiData v) => [(k, [v])] -> Form fromEntriesByKey = Form . HashMap.fromListWith (<>) . map (toFormKey *** map toQueryParam) data Proxy3 a b c = Proxy3 type family NotSupported (cls :: k1) (a :: k2) (reason :: Symbol) :: Constraint where #if __GLASGOW_HASKELL__ < 800 -- this is just a placeholder case for older GHCs to not freak out on an empty closed type family NotSupported cls a "this type family is actually empty" = () #else NotSupported cls a reason = TypeError ( 'Text "Cannot derive a Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instance for " ':<>: 'ShowType a ':<>: 'Text "." ':$$: 'ShowType a ':<>: 'Text " " ':<>: 'Text reason ':<>: 'Text "," ':$$: 'Text "but Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instances can be derived only for records" ':$$: 'Text "(i.e. product types with named fields)." ) #endif -- | A 'Generic'-based implementation of 'toForm'. -- This is used as a default implementation in 'ToForm'. -- -- Note that this only works for records (i.e. product data types with named fields): -- -- @ -- data Person = Person -- { name :: String -- , age :: Int -- } deriving ('Generic') -- @ -- -- In this implementation each field's value gets encoded using `toQueryParam`. -- Two field types are exceptions: -- -- - for values of type @'Maybe' a@ an entry is added to the 'Form' only when it is @'Just' x@ -- and the encoded value is @'toQueryParam' x@; 'Nothing' values are omitted from the 'Form'; -- -- - for values of type @[a]@ (except @['Char']@) an entry is added for every item in the list; -- if the list is empty no entries are added to the 'Form'; -- -- Here's an example: -- -- @ -- data Post = Post -- { title :: String -- , subtitle :: Maybe String -- , comments :: [String] -- } deriving ('Generic', 'Show') -- -- instance 'ToForm' Post -- @ -- -- >>> 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 -- | _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, FromFormKey k, FromHttpApiData v) => FromForm (Map k [v]) where fromForm = fmap (Map.fromListWith (<>)) . toEntriesByKey instance (Eq k, Hashable k, FromFormKey k, FromHttpApiData v) => FromForm (HashMap k [v]) where fromForm = fmap (HashMap.fromListWith (<>)) . toEntriesByKey instance FromHttpApiData v => FromForm (IntMap [v]) where fromForm = fmap (IntMap.fromListWith (<>)) . toEntriesByKey -- | Parse a 'Form' into a list of entries groupped by key. -- -- _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 . HashMap.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 . HashMap.lookup key . unForm -- | Lookup an optional value for a key. -- Fail if there is more than one value. -- -- >>> lookupMaybe "name" [] -- Right Nothing -- >>> lookupMaybe "name" [("name", "Oleg")] -- Right (Just "Oleg") -- >>> lookupMaybe "name" [("name", "Oleg"), ("name", "David")] -- Left "Duplicate key \"name\"" lookupMaybe :: Text -> Form -> Either Text (Maybe Text) lookupMaybe key form = case lookupAll key form of [] -> pure Nothing [v] -> pure (Just v) _ -> Left $ "Duplicate key " <> Text.pack (show key) -- | Lookup a unique value for a key. -- Fail if there is zero or more than one value. -- -- >>> lookupUnique "name" [] -- Left "Could not find key \"name\"" -- >>> lookupUnique "name" [("name", "Oleg")] -- Right "Oleg" -- >>> lookupUnique "name" [("name", "Oleg"), ("name", "David")] -- Left "Duplicate key \"name\"" lookupUnique :: Text -> Form -> Either Text Text lookupUnique key form = do mv <- lookupMaybe key form case mv of Just v -> pure v Nothing -> Left $ "Could not find key " <> Text.pack (show key) -- | Lookup all values for a given key in a 'Form' and parse them with 'parseQueryParams'. -- -- >>> parseAll "age" [] :: Either Text [Word8] -- Right [] -- >>> parseAll "age" [("age", "8"), ("age", "seven")] :: Either Text [Word8] -- Left "could not parse: `seven' (input does not start with a digit)" -- >>> parseAll "age" [("age", "8"), ("age", "777")] :: Either Text [Word8] -- Left "out of bounds: `777' (should be between 0 and 255)" -- >>> parseAll "age" [("age", "12"), ("age", "25")] :: Either Text [Word8] -- Right [12,25] parseAll :: FromHttpApiData v => Text -> Form -> Either Text [v] parseAll key = parseQueryParams . lookupAll key -- | Lookup an optional value for a given key and parse it with 'parseQueryParam'. -- Fail if there is more than one value for the key. -- -- >>> parseMaybe "age" [] :: Either Text (Maybe Word8) -- Right Nothing -- >>> parseMaybe "age" [("age", "12"), ("age", "25")] :: Either Text (Maybe Word8) -- Left "Duplicate key \"age\"" -- >>> parseMaybe "age" [("age", "seven")] :: Either Text (Maybe Word8) -- Left "could not parse: `seven' (input does not start with a digit)" -- >>> parseMaybe "age" [("age", "777")] :: Either Text (Maybe Word8) -- Left "out of bounds: `777' (should be between 0 and 255)" -- >>> parseMaybe "age" [("age", "7")] :: Either Text (Maybe Word8) -- Right (Just 7) parseMaybe :: FromHttpApiData v => Text -> Form -> Either Text (Maybe v) parseMaybe key = parseQueryParams <=< lookupMaybe key -- | Lookup a unique value for a given key and parse it with 'parseQueryParam'. -- Fail if there is zero or more than one value for the key. -- -- >>> parseUnique "age" [] :: Either Text Word8 -- Left "Could not find key \"age\"" -- >>> parseUnique "age" [("age", "12"), ("age", "25")] :: Either Text Word8 -- Left "Duplicate key \"age\"" -- >>> parseUnique "age" [("age", "seven")] :: Either Text Word8 -- Left "could not parse: `seven' (input does not start with a digit)" -- >>> parseUnique "age" [("age", "777")] :: Either Text Word8 -- Left "out of bounds: `777' (should be between 0 and 255)" -- >>> parseUnique "age" [("age", "7")] :: Either Text Word8 -- Right 7 parseUnique :: FromHttpApiData v => Text -> Form -> Either Text v parseUnique key form = lookupUnique key form >>= parseQueryParam -- | 'Generic'-based deriving options for 'ToForm' and 'FromForm'. -- -- A common use case for non-default 'FormOptions' -- is to strip a prefix off of field labels: -- -- @ -- data Project = Project -- { projectName :: String -- , projectSize :: Int -- } deriving ('Generic', 'Show') -- -- myOptions :: 'FormOptions' -- myOptions = 'FormOptions' -- { 'fieldLabelModifier' = 'map' 'toLower' . 'drop' ('length' \"project\") } -- -- instance 'ToForm' Project where -- 'toForm' = 'genericToForm' myOptions -- -- instance 'FromForm' Project where -- 'fromForm' = 'genericFromForm' myOptions -- @ -- -- >>> 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) http-api-data-0.4/src/Web/Internal/HttpApiData.hs0000644000000000000000000007537107346545000017777 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE DeriveFoldable #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} -- | -- Convert Haskell values to and from HTTP API data -- such as URL pieces, headers and query parameters. module Web.Internal.HttpApiData where import Prelude () import Prelude.Compat import Control.Arrow (left, (&&&)) import Control.Monad ((<=<)) import qualified Data.Attoparsec.Text as Atto import qualified Data.Attoparsec.Time as Atto 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.Int (Int16, Int32, Int64, Int8) import Data.Monoid (All (..), Any (..), Dual (..), First (..), Last (..), Product (..), Sum (..)) import Data.Semigroup (Semigroup (..)) 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.Read (Reader, decimal, rational, signed) import Data.Time (Day, FormatTime, LocalTime, NominalDiffTime, TimeOfDay, UTCTime, ZonedTime, formatTime) import Data.Time.Locale.Compat (defaultTimeLocale, iso8601DateFormat) 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 MIN_VERSION_time(1,9,1) import Data.Time (nominalDiffTimeToSeconds, secondsToNominalDiffTime) #endif #if USE_TEXT_SHOW import TextShow (TextShow, showt) #endif -- $setup -- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show) -- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p -- >>> import Data.Time -- >>> import Data.Version -- | 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.encodePathSegmentsRelative', -- but this may be overriden with a more efficient version. toEncodedUrlPiece :: a -> BS.Builder toEncodedUrlPiece = H.encodePathSegmentsRelative . (:[]) . toUrlPiece -- | Convert to HTTP header value. toHeader :: a -> ByteString toHeader = encodeUtf8 . toUrlPiece -- | Convert to query param value. toQueryParam :: a -> Text toQueryParam = toUrlPiece -- | Parse value from HTTP API data. -- -- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated -- instance will loop indefinitely. class FromHttpApiData a where {-# MINIMAL parseUrlPiece | parseQueryParam #-} -- | Parse URL path piece. parseUrlPiece :: Text -> Either Text a parseUrlPiece = parseQueryParam -- | Parse HTTP header value. parseHeader :: ByteString -> Either Text a parseHeader = parseUrlPiece <=< (left (T.pack . show) . decodeUtf8') -- | Parse query param value. parseQueryParam :: Text -> Either Text a parseQueryParam = parseUrlPiece -- | Convert multiple values to a list of URL pieces. -- -- >>> toUrlPieces [1, 2, 3] :: [Text] -- ["1","2","3"] toUrlPieces :: (Functor t, ToHttpApiData a) => t a -> t Text toUrlPieces = fmap toUrlPiece -- | Parse multiple URL pieces. -- -- >>> parseUrlPieces ["true", "false"] :: Either Text [Bool] -- Right [True,False] -- >>> parseUrlPieces ["123", "hello", "world"] :: Either Text [Int] -- Left "could not parse: `hello' (input does not start with a digit)" parseUrlPieces :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a) parseUrlPieces = traverse parseUrlPiece -- | Convert multiple values to a list of query parameter values. -- -- >>> toQueryParams [fromGregorian 2015 10 03, fromGregorian 2015 12 01] :: [Text] -- ["2015-10-03","2015-12-01"] toQueryParams :: (Functor t, ToHttpApiData a) => t a -> t Text toQueryParams = fmap toQueryParam -- | Parse multiple query parameters. -- -- >>> parseQueryParams ["1", "2", "3"] :: Either Text [Int] -- Right [1,2,3] -- >>> parseQueryParams ["64", "128", "256"] :: Either Text [Word8] -- Left "out of bounds: `256' (should be between 0 and 255)" parseQueryParams :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a) parseQueryParams = traverse parseQueryParam -- | Parse URL path piece in a @'Maybe'@. -- -- >>> parseUrlPieceMaybe "12" :: Maybe Int -- Just 12 parseUrlPieceMaybe :: FromHttpApiData a => Text -> Maybe a parseUrlPieceMaybe = either (const Nothing) Just . parseUrlPiece -- | Parse HTTP header value in a @'Maybe'@. -- -- >>> parseHeaderMaybe "hello" :: Maybe Text -- Just "hello" parseHeaderMaybe :: FromHttpApiData a => ByteString -> Maybe a parseHeaderMaybe = either (const Nothing) Just . parseHeader -- | Parse query param value in a @'Maybe'@. -- -- >>> parseQueryParamMaybe "true" :: Maybe Bool -- Just True parseQueryParamMaybe :: FromHttpApiData a => Text -> Maybe a parseQueryParamMaybe = either (const Nothing) Just . parseQueryParam -- | Default parsing error. defaultParseError :: Text -> Either Text a defaultParseError input = Left ("could not parse: `" <> input <> "'") -- | Convert @'Maybe'@ parser into @'Either' 'Text'@ parser with default error message. parseMaybeTextData :: (Text -> Maybe a) -> (Text -> Either Text a) parseMaybeTextData parse input = case parse input of Nothing -> defaultParseError input Just val -> Right val #if USE_TEXT_SHOW -- | /Lower case/. -- -- Convert to URL piece using @'TextShow'@ instance. -- The result is always lower cased. -- -- >>> showTextData True -- "true" -- -- This can be used as a default implementation for enumeration types: -- -- @ -- data MyData = Foo | Bar | Baz deriving (Generic) -- -- instance TextShow MyData where -- showt = genericShowt -- -- instance ToHttpApiData MyData where -- toUrlPiece = showTextData -- @ showTextData :: TextShow a => a -> Text showTextData = T.toLower . showt #else -- | /Lower case/. -- -- Convert to URL piece using @'Show'@ instance. -- The result is always lower cased. -- -- >>> showTextData True -- "true" -- -- This can be used as a default implementation for enumeration types: -- -- >>> data MyData = Foo | Bar | Baz deriving (Show) -- >>> instance ToHttpApiData MyData where toUrlPiece = showTextData -- >>> toUrlPiece Foo -- "foo" showTextData :: Show a => a -> Text showTextData = T.toLower . showt -- | Like @'show'@, but returns @'Text'@. showt :: Show a => a -> Text showt = T.pack . show #endif -- | /Case insensitive/. -- -- Parse given text case insensitive and then parse the rest of the input -- using @'parseUrlPiece'@. -- -- >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int -- Right 10 -- >>> parseUrlPieceWithPrefix "Left " "left" :: Either Text Bool -- Left "could not parse: `left'" -- -- This can be used to implement @'FromHttpApiData'@ for single field constructors: -- -- >>> data Foo = Foo Int deriving (Show) -- >>> instance FromHttpApiData Foo where parseUrlPiece s = Foo <$> parseUrlPieceWithPrefix "Foo " s -- >>> parseUrlPiece "foo 1" :: Either Text Foo -- Right (Foo 1) parseUrlPieceWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a parseUrlPieceWithPrefix pattern input | T.toLower pattern == T.toLower prefix = parseUrlPiece rest | otherwise = defaultParseError input where (prefix, rest) = T.splitAt (T.length pattern) input -- | Parse given bytestring then parse the rest of the input using @'parseHeader'@. -- -- @ -- data BasicAuthToken = BasicAuthToken Text deriving (Show) -- -- instance FromHttpApiData BasicAuthToken where -- parseHeader h = BasicAuthToken \<$\> parseHeaderWithPrefix "Basic " h -- parseQueryParam p = BasicAuthToken \<$\> parseQueryParam p -- @ -- -- >>> parseHeader "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" :: Either Text BasicAuthToken -- Right (BasicAuthToken "QWxhZGRpbjpvcGVuIHNlc2FtZQ==") parseHeaderWithPrefix :: FromHttpApiData a => ByteString -> ByteString -> Either Text a parseHeaderWithPrefix pattern input | pattern `BS.isPrefixOf` input = parseHeader (BS.drop (BS.length pattern) input) | otherwise = defaultParseError (showt input) -- | /Case insensitive/. -- -- Parse given text case insensitive and then parse the rest of the input -- using @'parseQueryParam'@. -- -- >>> parseQueryParamWithPrefix "z" "z10" :: Either Text Int -- Right 10 parseQueryParamWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a parseQueryParamWithPrefix pattern input | T.toLower pattern == T.toLower prefix = parseQueryParam rest | otherwise = defaultParseError input where (prefix, rest) = T.splitAt (T.length pattern) input #if USE_TEXT_SHOW -- | /Case insensitive/. -- -- Parse values case insensitively based on @'TextShow'@ instance. -- -- >>> parseBoundedTextData "true" :: Either Text Bool -- Right True -- >>> parseBoundedTextData "FALSE" :: Either Text Bool -- Right False -- -- This can be used as a default implementation for enumeration types: -- -- @ -- data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum, Generic) -- -- instance TextShow MyData where -- showt = genericShowt -- -- instance FromHttpApiData MyData where -- parseUrlPiece = parseBoundedTextData -- @ parseBoundedTextData :: (TextShow a, Bounded a, Enum a) => Text -> Either Text a #else -- | /Case insensitive/. -- -- Parse values case insensitively based on @'Show'@ instance. -- -- >>> parseBoundedTextData "true" :: Either Text Bool -- Right True -- >>> parseBoundedTextData "FALSE" :: Either Text Bool -- Right False -- -- This can be used as a default implementation for enumeration types: -- -- >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum) -- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedTextData -- >>> parseUrlPiece "foo" :: Either Text MyData -- Right Foo parseBoundedTextData :: (Show a, Bounded a, Enum a) => Text -> Either Text a #endif parseBoundedTextData = parseBoundedEnumOfI showTextData -- | Lookup values based on a precalculated mapping of their representations. lookupBoundedEnumOf :: (Bounded a, Enum a, Eq b) => (a -> b) -> b -> Maybe a lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound]) -- | Parse values based on a precalculated mapping of their @'Text'@ representation. -- -- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool -- Right True -- -- For case sensitive parser see 'parseBoundedEnumOfI'. parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf -- | /Case insensitive/. -- -- Parse values case insensitively based on a precalculated mapping -- of their @'Text'@ representations. -- -- >>> parseBoundedEnumOfI toUrlPiece "FALSE" :: Either Text Bool -- Right False -- -- For case sensitive parser see 'parseBoundedEnumOf'. parseBoundedEnumOfI :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a parseBoundedEnumOfI f = parseBoundedEnumOf (T.toLower . f) . T.toLower -- | /Case insensitive/. -- -- Parse values case insensitively based on @'ToHttpApiData'@ instance. -- Uses @'toUrlPiece'@ to get possible values. parseBoundedUrlPiece :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a parseBoundedUrlPiece = parseBoundedEnumOfI toUrlPiece -- | /Case insensitive/. -- -- Parse values case insensitively based on @'ToHttpApiData'@ instance. -- Uses @'toQueryParam'@ to get possible values. parseBoundedQueryParam :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a parseBoundedQueryParam = parseBoundedEnumOfI toQueryParam -- | Parse values based on @'ToHttpApiData'@ instance. -- Uses @'toHeader'@ to get possible values. parseBoundedHeader :: (ToHttpApiData a, Bounded a, Enum a) => ByteString -> Either Text a parseBoundedHeader bs = case lookupBoundedEnumOf toHeader bs of Nothing -> defaultParseError $ T.pack $ show bs Just x -> return x -- | Parse URL piece using @'Read'@ instance. -- -- Use for types which do not involve letters: -- -- >>> readTextData "1991-06-02" :: Either Text Day -- Right 1991-06-02 -- -- This parser is case sensitive and will not match @'showTextData'@ -- in 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 -- | -- >>> toUrlPiece () -- "_" instance ToHttpApiData () where toUrlPiece () = "_" toEncodedUrlPiece = unsafeToEncodedUrlPiece 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 instance ToHttpApiData Void where toUrlPiece = absurd instance ToHttpApiData Natural where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Bool where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Double where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Float where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Int where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Int8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Int16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Int32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Int64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Integer where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Word where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Word8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece instance F.HasResolution a => ToHttpApiData (F.Fixed a) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -- | -- >>> toUrlPiece (fromGregorian 2015 10 03) -- "2015-10-03" instance ToHttpApiData Day where toUrlPiece = T.pack . show toEncodedUrlPiece = unsafeToEncodedUrlPiece timeToUrlPiece :: FormatTime t => String -> t -> Text timeToUrlPiece fmt = T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just fmt)) -- | -- >>> toUrlPiece $ TimeOfDay 14 55 23.1 -- "14:55:23.1" instance ToHttpApiData TimeOfDay where toUrlPiece = T.pack . formatTime defaultTimeLocale "%H:%M:%S%Q" toEncodedUrlPiece = unsafeToEncodedUrlPiece -- | -- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 21.687) -- "2015-10-03T14:55:21.687" instance ToHttpApiData LocalTime where toUrlPiece = timeToUrlPiece "%H:%M:%S%Q" toEncodedUrlPiece = unsafeToEncodedUrlPiece -- | -- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 51.001)) utc -- "2015-10-03T14:55:51.001+0000" instance ToHttpApiData ZonedTime where toUrlPiece = timeToUrlPiece "%H:%M:%S%Q%z" toEncodedUrlPiece = unsafeToEncodedUrlPiece -- | -- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864.5 -- "2015-10-03T00:14:24.5Z" instance ToHttpApiData UTCTime where toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ" toEncodedUrlPiece = unsafeToEncodedUrlPiece -- The CPP in both this function and the function after it are to avoid -- exporting @nominalDiffTimeToSeconds@ and @secondsToNominalDiffTime@, -- since these names are already used by @Data.Time@ from the @time@ library -- starting in version @1.9.1@. nominalDiffTimeToSecs :: NominalDiffTime -> F.Pico nominalDiffTimeToSecs = #if !MIN_VERSION_time(1,9,1) realToFrac #else nominalDiffTimeToSeconds #endif secsToNominalDiffTime :: F.Pico -> NominalDiffTime secsToNominalDiffTime = #if !MIN_VERSION_time(1,9,1) realToFrac #else secondsToNominalDiffTime #endif instance ToHttpApiData NominalDiffTime where toUrlPiece = toUrlPiece . nominalDiffTimeToSecs 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) instance ToHttpApiData Any where toUrlPiece = coerce (toUrlPiece :: Bool -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Dual a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Sum a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Product a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (First a) where toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Last a) where toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Semi.Min a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Semi.Max a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Semi.First a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Semi.Last a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: 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. instance ToHttpApiData a => ToHttpApiData (Tagged b a) where toUrlPiece = coerce (toUrlPiece :: a -> Text) toHeader = coerce (toHeader :: a -> ByteString) toQueryParam = coerce (toQueryParam :: a -> Text) toEncodedUrlPiece = coerce (toEncodedUrlPiece :: 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 instance F.HasResolution a => FromHttpApiData (F.Fixed a) where parseUrlPiece = runReader rational -- | -- >>> toGregorian <$> parseUrlPiece "2016-12-01" -- Right (2016,12,1) instance FromHttpApiData Day where parseUrlPiece = runAtto Atto.day -- | -- >>> parseUrlPiece "14:55:01.333" :: Either Text TimeOfDay -- Right 14:55:01.333 instance FromHttpApiData TimeOfDay where parseUrlPiece = runAtto Atto.timeOfDay -- | -- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime -- Right 2015-10-03 14:55:01 instance FromHttpApiData LocalTime where parseUrlPiece = runAtto Atto.localTime -- | -- >>> 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 = runAtto Atto.zonedTime -- | -- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime -- Right 2015-10-03 00:14:24 UTC instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secsToNominalDiffTime . parseUrlPiece 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}) instance FromHttpApiData SetCookie where parseUrlPiece = parseHeader . encodeUtf8 parseHeader = Right . parseSetCookie instance FromHttpApiData a => FromHttpApiData (Tagged b a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) parseHeader = coerce (parseHeader :: ByteString -> Either Text a) parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a) ------------------------------------------------------------------------------- -- Attoparsec helpers ------------------------------------------------------------------------------- runAtto :: Atto.Parser a -> Text -> Either Text a runAtto p t = case Atto.parseOnly (p <* Atto.endOfInput) t of Left err -> Left (T.pack err) Right x -> Right x http-api-data-0.4/test/0000755000000000000000000000000007346545000013162 5ustar0000000000000000http-api-data-0.4/test/Spec.hs0000644000000000000000000000005407346545000014407 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} http-api-data-0.4/test/Spec.hs0000755000000000000000000000005407346545000014412 0ustar0000000000000000{-# OPTIONS_GHC -F -pgmF hspec-discover #-} http-api-data-0.4/test/Web/Internal/0000755000000000000000000000000007346545000015453 5ustar0000000000000000http-api-data-0.4/test/Web/Internal/FormUrlEncodedSpec.hs0000644000000000000000000000437007346545000021476 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Web.Internal.FormUrlEncodedSpec (spec) where #if __GLASGOW_HASKELL__ < 710 import Control.Applicative import Data.Monoid #endif import Control.Monad ((<=<)) import qualified Data.ByteString.Lazy.Char8 as BSL import qualified Data.HashMap.Strict as HashMap import Data.Text (Text, unpack) import Test.Hspec import Test.QuickCheck import GHC.Exts (fromList) import Web.Internal.FormUrlEncoded import Web.Internal.HttpApiData import Web.Internal.TestInstances spec :: Spec spec = do genericSpec urlEncoding genericSpec :: Spec genericSpec = describe "Default (generic) instances" $ do context "ToForm" $ do it "contains the record names" $ property $ \(x :: SimpleRec) -> do let f = unForm $ toForm x HashMap.member "rec1" f `shouldBe` True HashMap.member "rec2" f `shouldBe` True it "contains the correct record values" $ property $ \(x :: SimpleRec) -> do let f = unForm $ toForm x HashMap.lookup "rec1" f `shouldBe` Just [rec1 x] (parseQueryParams <$> HashMap.lookup "rec2" f) `shouldBe` Just (Right [rec2 x]) context "FromForm" $ do it "is the right inverse of ToForm" $ property $ \x (y :: Int) -> do let f1 = fromList [("rec1", x), ("rec2", toQueryParam y)] Right r1 = fromForm f1 :: Either Text SimpleRec toForm r1 `shouldBe` f1 it "returns the underlying error" $ do let f = fromList [("rec1", "anything"), ("rec2", "bad")] Left e = fromForm f :: Either Text SimpleRec unpack e `shouldContain` "input does not start with a digit" urlEncoding :: Spec urlEncoding = describe "urlEncoding" $ do it "urlDecodeForm (urlEncodeForm x) == Right x" $ property $ \(NoEmptyKeyForm x) -> do urlDecodeForm (urlEncodeForm x) `shouldBe` Right x it "urlDecodeAsForm == (fromForm <=< urlDecodeForm)" $ property $ \(x :: BSL.ByteString) -> do (urlDecodeAsForm x :: Either Text Form) `shouldBe` (fromForm <=< urlDecodeForm) x it "urlEncodeAsForm == urlEncodeForm . toForm" $ property $ \(x :: Form) -> do urlEncodeAsForm x `shouldBe` (urlEncodeForm . toForm) x it "urlDecodeForm \"\" == Right mempty" $ do urlDecodeForm "" `shouldBe` Right mempty http-api-data-0.4/test/Web/Internal/HttpApiDataSpec.hs0000644000000000000000000001261007346545000020765 0ustar0000000000000000{-# LANGUAGE ScopedTypeVariables #-} module Web.Internal.HttpApiDataSpec (spec) where import Prelude () import Prelude.Compat 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 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) -- | 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 -- | 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 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 } http-api-data-0.4/test/Web/Internal/TestInstances.hs0000644000000000000000000000405007346545000020575 0ustar0000000000000000{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Web.Internal.TestInstances ( RandomCase(..) , SimpleRec(..) , NoEmptyKeyForm(..) ) where import Control.Applicative import Data.Char import qualified Data.HashMap.Strict as HashMap import qualified Data.Text as T import Data.Time 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 (HashMap.delete "" m) http-api-data-0.4/test/doctests.hs0000644000000000000000000000147207346545000015352 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Main (doctests) -- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module provides doctests for a project based on the actual versions -- of the packages it was built with. It requires a corresponding Setup.lhs -- to be added to the project ----------------------------------------------------------------------------- module Main where import Build_doctests (flags, pkgs, module_sources) import Data.Foldable (traverse_) import Test.DocTest main :: IO () main = do traverse_ putStrLn args doctest args where args = flags ++ pkgs ++ module_sources http-api-data-0.4/test/doctests.hs0000755000000000000000000000147207346545000015355 0ustar0000000000000000----------------------------------------------------------------------------- -- | -- Module : Main (doctests) -- Copyright : (C) 2012-14 Edward Kmett -- License : BSD-style (see the file LICENSE) -- Maintainer : Edward Kmett -- Stability : provisional -- Portability : portable -- -- This module provides doctests for a project based on the actual versions -- of the packages it was built with. It requires a corresponding Setup.lhs -- to be added to the project ----------------------------------------------------------------------------- module Main where import Build_doctests (flags, pkgs, module_sources) import Data.Foldable (traverse_) import Test.DocTest main :: IO () main = do traverse_ putStrLn args doctest args where args = flags ++ pkgs ++ module_sources