├── cabal.project ├── Setup.hs ├── test ├── Spec.hs └── Web │ └── Internal │ ├── TestInstances.hs │ ├── FormUrlEncodedSpec.hs │ └── HttpApiDataSpec.hs ├── stack.yaml ├── cabal.haskell-ci ├── .gitignore ├── src └── Web │ ├── FormUrlEncoded.hs │ ├── HttpApiData.hs │ └── Internal │ ├── FormUrlEncoded.hs │ └── HttpApiData.hs ├── LICENSE ├── README.md ├── http-api-data.cabal ├── CHANGELOG.md └── .github └── workflows └── haskell-ci.yml /cabal.project: -------------------------------------------------------------------------------- 1 | packages: . 2 | tests: True 3 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-12.10 2 | packages: 3 | - '.' 4 | flags: 5 | http-api-data: 6 | use-text-show: false 7 | -------------------------------------------------------------------------------- /cabal.haskell-ci: -------------------------------------------------------------------------------- 1 | branches: master 2 | docspec: True 3 | 4 | constraint-set text-show 5 | constraints: http-api-data +use-text-show 6 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /dist/ 2 | /dist-newstyle/ 3 | /.ghc.environment.* 4 | /.shelly/ 5 | /tarballs/ 6 | *.swp 7 | .stack-work/ 8 | src/highlight.js 9 | src/style.css 10 | -------------------------------------------------------------------------------- /src/Web/FormUrlEncoded.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Convert Haskell values to and from @application/xxx-form-urlencoded@ format. 3 | module Web.FormUrlEncoded ( 4 | -- * Classes 5 | ToForm (..), 6 | FromForm (..), 7 | 8 | -- ** Keys for 'Form' entries 9 | ToFormKey(..), 10 | FromFormKey(..), 11 | 12 | -- * 'Form' type 13 | Form(..), 14 | 15 | -- * Encoding and decoding @'Form'@s 16 | urlEncodeAsForm, 17 | urlEncodeAsFormStable, 18 | urlDecodeAsForm, 19 | 20 | urlEncodeForm, 21 | urlEncodeFormStable, 22 | urlDecodeForm, 23 | 24 | -- * 'Generic's 25 | genericToForm, 26 | genericFromForm, 27 | 28 | -- ** Encoding options 29 | FormOptions(..), 30 | defaultFormOptions, 31 | 32 | -- * Helpers 33 | toListStable, 34 | toEntriesByKey, 35 | toEntriesByKeyStable, 36 | fromEntriesByKey, 37 | 38 | lookupAll, 39 | lookupMaybe, 40 | lookupUnique, 41 | 42 | parseAll, 43 | parseMaybe, 44 | parseUnique, 45 | 46 | urlEncodeParams, 47 | urlDecodeParams, 48 | ) where 49 | 50 | import Web.Internal.FormUrlEncoded 51 | 52 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The following license covers this documentation, and the source code, except 2 | where otherwise indicated. 3 | 4 | Copyright 2015, Nickolay Kudasov. All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright notice, this 10 | list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above copyright notice, 13 | this list of conditions and the following disclaimer in the documentation 14 | and/or other materials provided with the distribution. 15 | 16 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR 17 | IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 18 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO 19 | EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, 20 | INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT 21 | NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, 22 | OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 23 | LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE 24 | OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 25 | ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 26 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # http-api-data 2 | 3 | [![Build Status](https://secure.travis-ci.org/fizruk/http-api-data.png?branch=master)](http://travis-ci.org/fizruk/http-api-data) 4 | [![Hackage package](http://img.shields.io/hackage/v/http-api-data.svg)](http://hackage.haskell.org/package/http-api-data) 5 | [![Stackage LTS](http://stackage.org/package/http-api-data/badge/lts)](http://stackage.org/lts/package/http-api-data) 6 | [![Stackage Nightly](http://stackage.org/package/http-api-data/badge/nightly)](http://stackage.org/nightly/package/http-api-data) 7 | 8 | This package defines typeclasses used for converting Haskell data types to and from HTTP API data. 9 | 10 | ### Examples 11 | 12 | Booleans: 13 | 14 | ``` 15 | >>> toUrlPiece True 16 | "true" 17 | >>> parseUrlPiece "false" :: Either Text Bool 18 | Right False 19 | >>> parseUrlPieces ["true", "false", "undefined"] :: Either Text [Bool] 20 | Left "could not parse: `undefined'" 21 | ``` 22 | 23 | Numbers: 24 | 25 | ``` 26 | >>> toQueryParam 45.2 27 | "45.2" 28 | >>> parseQueryParam "452" :: Either Text Int 29 | Right 452 30 | >>> toQueryParams [1..5] 31 | ["1","2","3","4","5"] 32 | >>> parseQueryParams ["127", "255"] :: Either Text [Int8] 33 | Left "out of bounds: `255' (should be between -128 and 127)" 34 | ``` 35 | 36 | Strings: 37 | 38 | ``` 39 | >>> toHeader "hello" 40 | "hello" 41 | >>> parseHeader "world" :: Either Text String 42 | Right "world" 43 | ``` 44 | 45 | Calendar day: 46 | 47 | ``` 48 | >>> toQueryParam (fromGregorian 2015 10 03) 49 | "2015-10-03" 50 | >>> toGregorian <$> parseQueryParam "2016-12-01" 51 | Right (2016,12,1) 52 | ``` 53 | 54 | ## Contributing 55 | 56 | Contributions and bug reports are welcome! 57 | 58 | -------------------------------------------------------------------------------- /src/Web/HttpApiData.hs: -------------------------------------------------------------------------------- 1 | -- | 2 | -- Convert Haskell values to and from HTTP API data 3 | -- such as URL pieces, headers and query parameters. 4 | module Web.HttpApiData ( 5 | -- * Examples 6 | -- $examples 7 | 8 | -- * Classes 9 | ToHttpApiData (..), 10 | FromHttpApiData (..), 11 | 12 | -- * @'Maybe'@ parsers 13 | parseUrlPieceMaybe, 14 | parseHeaderMaybe, 15 | parseQueryParamMaybe, 16 | 17 | -- * Prefix parsers 18 | parseUrlPieceWithPrefix, 19 | parseHeaderWithPrefix, 20 | parseQueryParamWithPrefix, 21 | 22 | -- * Multiple URL pieces 23 | toUrlPieces, 24 | parseUrlPieces, 25 | 26 | -- * Multiple query params 27 | toQueryParams, 28 | parseQueryParams, 29 | 30 | -- * Parsers for @'Bounded'@ @'Enum'@s 31 | parseBoundedUrlPiece, 32 | parseBoundedQueryParam, 33 | parseBoundedHeader, 34 | parseBoundedEnumOf, 35 | parseBoundedEnumOfI, 36 | parseBoundedTextData, 37 | 38 | -- * Lenient data 39 | LenientData (..), 40 | 41 | -- * Other helpers 42 | showTextData, 43 | readTextData, 44 | ) where 45 | 46 | import Web.Internal.HttpApiData 47 | 48 | -- $setup 49 | -- 50 | -- >>> :set -XOverloadedStrings 51 | -- >>> import Control.Applicative 52 | -- >>> import Data.Time.Compat 53 | -- >>> import Data.Int 54 | -- >>> import Data.Text (Text) 55 | -- >>> import Data.Version 56 | 57 | -- $examples 58 | -- 59 | -- Booleans: 60 | -- 61 | -- >>> toUrlPiece True 62 | -- "true" 63 | -- >>> parseUrlPiece "false" :: Either Text Bool 64 | -- Right False 65 | -- >>> parseUrlPieces ["true", "false", "undefined"] :: Either Text [Bool] 66 | -- Left "could not parse: `undefined'" 67 | -- 68 | -- Numbers: 69 | -- 70 | -- >>> toQueryParam 45.2 71 | -- "45.2" 72 | -- >>> parseQueryParam "452" :: Either Text Int 73 | -- Right 452 74 | -- >>> toQueryParams [1..5] :: [Text] 75 | -- ["1","2","3","4","5"] 76 | -- >>> parseQueryParams ["127", "255"] :: Either Text [Int8] 77 | -- Left "out of bounds: `255' (should be between -128 and 127)" 78 | -- 79 | -- Strings: 80 | -- 81 | -- >>> toHeader "hello" 82 | -- "hello" 83 | -- >>> parseHeader "world" :: Either Text String 84 | -- Right "world" 85 | -- 86 | -- Calendar day: 87 | -- 88 | -- >>> toQueryParam (fromGregorian 2015 10 03) 89 | -- "2015-10-03" 90 | -- >>> toGregorian <$> parseQueryParam "2016-12-01" 91 | -- Right (2016,12,1) 92 | 93 | -------------------------------------------------------------------------------- /test/Web/Internal/TestInstances.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE ScopedTypeVariables #-} 4 | {-# OPTIONS_GHC -fno-warn-orphans #-} 5 | module Web.Internal.TestInstances 6 | ( RandomCase(..) 7 | , SimpleRec(..) 8 | , NoEmptyKeyForm(..) 9 | ) where 10 | 11 | import Control.Applicative 12 | import Data.Char 13 | import qualified Data.HashMap.Strict as HashMap 14 | import qualified Data.Text as T 15 | import Data.Time.Compat 16 | import GHC.Exts (fromList) 17 | import GHC.Generics 18 | 19 | import Test.QuickCheck 20 | import Test.QuickCheck.Instances () 21 | 22 | import Web.Internal.FormUrlEncoded 23 | import Web.Internal.HttpApiData 24 | 25 | instance Eq ZonedTime where 26 | ZonedTime t (TimeZone x _ _) == ZonedTime t' (TimeZone y _ _) = t == t' && x == y 27 | 28 | instance Arbitrary Form where 29 | arbitrary = fromList <$> arbitrary 30 | 31 | data RandomCase a = RandomCase [Bool] a 32 | 33 | instance ToHttpApiData a => Show (RandomCase a) where 34 | show rc@(RandomCase _ x) = show (toUrlPiece rc) ++ " (original: " ++ show (toUrlPiece x) ++ ")" 35 | 36 | instance Eq a => Eq (RandomCase a) where 37 | RandomCase _ x == RandomCase _ y = x == y 38 | 39 | instance Arbitrary a => Arbitrary (RandomCase a) where 40 | arbitrary = liftA2 RandomCase nonempty arbitrary 41 | where 42 | nonempty = liftA2 (:) arbitrary arbitrary 43 | 44 | instance ToHttpApiData a => ToHttpApiData (RandomCase a) where 45 | toUrlPiece (RandomCase us x) = T.pack (zipWith (\u -> if u then toUpper else toLower) (cycle us) (T.unpack (toUrlPiece x))) 46 | 47 | instance FromHttpApiData a => FromHttpApiData (RandomCase a) where 48 | parseUrlPiece s = RandomCase [] <$> parseUrlPiece s 49 | 50 | data SimpleRec = SimpleRec { rec1 :: T.Text, rec2 :: Int } 51 | deriving (Eq, Show, Read, Generic) 52 | 53 | instance ToForm SimpleRec 54 | instance FromForm SimpleRec 55 | 56 | instance Arbitrary SimpleRec where 57 | arbitrary = SimpleRec <$> arbitrary <*> arbitrary 58 | 59 | newtype NoEmptyKeyForm = 60 | NoEmptyKeyForm { unNoEmptyKeyForm :: Form } 61 | deriving Show 62 | 63 | instance Arbitrary NoEmptyKeyForm where 64 | arbitrary = NoEmptyKeyForm . removeEmptyKeys <$> arbitrary 65 | where 66 | removeEmptyKeys (Form m) = Form (HashMap.delete "" m) 67 | -------------------------------------------------------------------------------- /test/Web/Internal/FormUrlEncodedSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | module Web.Internal.FormUrlEncodedSpec (spec) where 4 | 5 | import Control.Monad ((<=<)) 6 | import qualified Data.ByteString.Lazy.Char8 as BSL 7 | import qualified Data.HashMap.Strict as HashMap 8 | import Data.Text (Text, unpack) 9 | import Test.Hspec 10 | import Test.QuickCheck 11 | 12 | import GHC.Exts (fromList) 13 | 14 | import Web.Internal.FormUrlEncoded 15 | import Web.Internal.HttpApiData 16 | import Web.Internal.TestInstances 17 | 18 | spec :: Spec 19 | spec = do 20 | genericSpec 21 | urlEncoding 22 | 23 | genericSpec :: Spec 24 | genericSpec = describe "Default (generic) instances" $ do 25 | 26 | context "ToForm" $ do 27 | 28 | it "contains the record names" $ property $ \(x :: SimpleRec) -> do 29 | let f = unForm $ toForm x 30 | HashMap.member "rec1" f `shouldBe` True 31 | HashMap.member "rec2" f `shouldBe` True 32 | 33 | it "contains the correct record values" $ property $ \(x :: SimpleRec) -> do 34 | let f = unForm $ toForm x 35 | HashMap.lookup "rec1" f `shouldBe` Just [rec1 x] 36 | (parseQueryParams <$> HashMap.lookup "rec2" f) `shouldBe` Just (Right [rec2 x]) 37 | 38 | context "FromForm" $ do 39 | 40 | it "is the right inverse of ToForm" $ property $ \x (y :: Int) -> do 41 | let f1 = fromList [("rec1", x), ("rec2", toQueryParam y)] 42 | Right r1 = fromForm f1 :: Either Text SimpleRec 43 | toForm r1 `shouldBe` f1 44 | 45 | it "returns the underlying error" $ do 46 | let f = fromList [("rec1", "anything"), ("rec2", "bad")] 47 | Left e = fromForm f :: Either Text SimpleRec 48 | unpack e `shouldContain` "input does not start with a digit" 49 | 50 | urlEncoding :: Spec 51 | urlEncoding = describe "urlEncoding" $ do 52 | 53 | it "urlDecodeForm (urlEncodeForm x) == Right x" $ property $ \(NoEmptyKeyForm x) -> do 54 | urlDecodeForm (urlEncodeForm x) `shouldBe` Right x 55 | 56 | it "urlDecodeAsForm == (fromForm <=< urlDecodeForm)" $ property $ \(x :: BSL.ByteString) -> do 57 | (urlDecodeAsForm x :: Either Text Form) `shouldBe` (fromForm <=< urlDecodeForm) x 58 | 59 | it "urlEncodeAsForm == urlEncodeForm . toForm" $ property $ \(x :: Form) -> do 60 | urlEncodeAsForm x `shouldBe` (urlEncodeForm . toForm) x 61 | 62 | it "urlDecodeForm \"\" == Right mempty" $ do 63 | urlDecodeForm "" `shouldBe` Right mempty 64 | -------------------------------------------------------------------------------- /http-api-data.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | name: http-api-data 3 | version: 0.6.2 4 | 5 | synopsis: Converting to/from HTTP API data like URL pieces, headers and query parameters. 6 | category: Web 7 | description: 8 | This package defines typeclasses used for converting Haskell data types to and from HTTP API data. 9 | . 10 | Please see README.md 11 | 12 | license: BSD3 13 | license-file: LICENSE 14 | author: Nickolay Kudasov 15 | maintainer: Nickolay Kudasov 16 | homepage: http://github.com/fizruk/http-api-data 17 | stability: unstable 18 | build-type: Simple 19 | 20 | extra-source-files: 21 | test/*.hs 22 | CHANGELOG.md 23 | README.md 24 | 25 | tested-with: 26 | GHC==8.6.5, 27 | GHC==8.8.4, 28 | GHC==8.10.7, 29 | GHC==9.0.2, 30 | GHC==9.2.8, 31 | GHC==9.4.8, 32 | GHC==9.6.7, 33 | GHC==9.8.4, 34 | GHC==9.10.1, 35 | GHC==9.12.2 36 | 37 | flag use-text-show 38 | description: Use text-show library for efficient ToHttpApiData implementations. 39 | default: False 40 | manual: True 41 | 42 | library 43 | hs-source-dirs: src/ 44 | 45 | -- GHC bundled 46 | build-depends: base >= 4.12.0.0 && < 4.22 47 | , bytestring >= 0.10.8.2 && < 0.13 48 | , containers >= 0.6.0.1 && < 0.8 49 | , text >= 1.2.3.0 && < 1.3 || >=2.0 && <2.2 50 | , transformers >= 0.5.6.2 && < 0.7 51 | 52 | -- other-dependencies 53 | build-depends: 54 | cookie >= 0.5.1 && < 0.6 55 | , hashable >= 1.4.4.0 && < 1.6 56 | , http-types >= 0.12.4 && < 0.13 57 | , text-iso8601 >= 0.1.1 && < 0.2 58 | , tagged >= 0.8.8 && < 0.9 59 | , time-compat >= 1.9.5 && < 1.10 60 | , unordered-containers >= 0.2.20 && < 0.3 61 | , uuid-types >= 1.0.6 && < 1.1 62 | 63 | if flag(use-text-show) 64 | cpp-options: -DUSE_TEXT_SHOW 65 | build-depends: text-show >= 3.10.5 && <3.12 66 | 67 | exposed-modules: 68 | Web.HttpApiData 69 | Web.FormUrlEncoded 70 | Web.Internal.FormUrlEncoded 71 | Web.Internal.HttpApiData 72 | ghc-options: -Wall 73 | default-language: Haskell2010 74 | 75 | test-suite spec 76 | type: exitcode-stdio-1.0 77 | main-is: Spec.hs 78 | other-modules: 79 | Web.Internal.FormUrlEncodedSpec 80 | Web.Internal.HttpApiDataSpec 81 | Web.Internal.TestInstances 82 | hs-source-dirs: test 83 | ghc-options: -Wall 84 | default-language: Haskell2010 85 | build-tool-depends: hspec-discover:hspec-discover >= 2.7.1 && <2.12 86 | -- inherited depndencies 87 | build-depends: 88 | base 89 | , bytestring 90 | , cookie 91 | , http-api-data 92 | , text 93 | , time-compat 94 | , unordered-containers 95 | , uuid-types 96 | 97 | build-depends: HUnit >= 1.6.0.0 && <1.7 98 | , hspec >= 2.7.1 && <2.12 99 | , QuickCheck >= 2.13.1 && <2.16 100 | , quickcheck-instances >= 0.3.25.2 && <0.4 101 | 102 | source-repository head 103 | type: git 104 | location: https://github.com/fizruk/http-api-data 105 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | 0.6.2 2 | 3 | * Support GHC-9.12 4 | * Require `cookie-0.5.1` 5 | 6 | 0.6.1 7 | 8 | * Require at least GHC-8.6 9 | * Support `cookie-0.5.0`, see [#137](https://github.com/fizruk/http-api-data/pull/137). 10 | 11 | Note that `cookie-0.5.0`'s parser now removes double quotes around cookie values. 12 | 13 | 0.6 14 | --- 15 | 16 | * Use [`text-iso8601`](https://hackage.haskell.org/package/text-iso8601) 17 | to parse and serialise `time` types. (Instead of `attoparsec-iso8601`). 18 | Due this change some formats are slightly changed: 19 | 20 | - Space between timezone is not accepted 21 | - Timezone offset can be between -23:59..23:59 22 | - Timezone offset is output with colon between hours and minutes 23 | 24 | * Require at least GHC-8.2 25 | 26 | 0.5.1 27 | ----- 28 | 29 | * Add `toEncodedQueryParam` to `ToHttpApiData` type class. It has default 30 | implementation using `toQueryParam`, but may be overriden with more efficient 31 | one. 32 | 33 | 0.5 34 | --- 35 | 36 | * Use `attoparsec-iso8601-1.1.0.0`. 37 | `Day` and `UTCTime` parsers require at least 4 digits now, which is a breaking change. 38 | * Drop GHC-7.8 and GHC-7.10 support. 39 | 40 | 0.4.3 41 | ----- 42 | 43 | * Add `Quarter`, `QuarterOfYear` and `Month` instances 44 | * Support `bytestring-0.11` 45 | 46 | 0.4.2 47 | ----- 48 | 49 | * Add instances for `Const` and `Identity` 50 | 51 | 0.4.1.1 52 | ------- 53 | 54 | * Allow cookie <0.5 55 | * Change to `build-type: Simple` 56 | 57 | 0.4.1 58 | ----- 59 | 60 | * Use `time-compat` to provide instances for `DayOfWeek`. 61 | 62 | 0.4 63 | --- 64 | 65 | * `NominalDiffTime` instances preserve precision (roundtrip) 66 | * Add `Semigroup.Min`, `Max`, `First`, `Last` instances 67 | * Add `Tagged b a` instances 68 | 69 | 0.3.10 70 | --- 71 | 72 | * Fix 'SetCookie' instances 73 | (see [#86](https://github.com/fizruk/http-api-data/pull/86)) 74 | * Add support for `Fixed` 75 | (see [#78](https://github.com/fizruk/http-api-data/pull/87)) 76 | 77 | 0.3.9 78 | --- 79 | 80 | * GHC-8.6 support 81 | * Remove dependency on `uri-bytestring` and use functions from `http-types` instead 82 | (see [#75](https://github.com/fizruk/http-api-data/pull/75)) 83 | * Add support for `SetCookie` 84 | (see [#74](https://github.com/fizruk/http-api-data/pull/74)) 85 | 86 | 0.3.8.1 87 | --- 88 | 89 | * GHC-8.4.1 support 90 | 91 | 0.3.8 92 | --- 93 | 94 | * Minor changes: 95 | * Stable URL-encoding for `Form`s (see [#67](https://github.com/fizruk/http-api-data/pull/67)): 96 | * Introduce `urlEncodeParams` and `urlDecodeParams`; 97 | * Introduce `urlEncodeAsFormStable` and use stable encoding for doctests; 98 | * Add `toEntriesByKeyStable` and `toListStable`; 99 | * Add `Semigroup` instance for `Form` (see [#69](https://github.com/fizruk/http-api-data/pull/69)); 100 | * Relax upper bound on Cabal (see [#73](https://github.com/fizruk/http-api-data/pull/73)). 101 | 102 | 0.3.7.2 103 | --- 104 | 105 | * Allow http-types-0.12 106 | * .cabal file adjustments 107 | 108 | 0.3.7.1 109 | --- 110 | 111 | * GHC-8.2 support (see [#55](https://github.com/fizruk/http-api-data/pull/55)). 112 | 113 | 0.3.7 114 | --- 115 | 116 | * Minor changes: 117 | * Use [`attoparsec-iso8601`](http://hackage.haskell.org/package/attoparsec-iso8601) 118 | for parsing of time types. Now the accepted formats are the same as by `aeson`, 119 | i.e. parsers are more lenient 120 | (see [#41](https://github.com/fizruk/http-api-data/pull/41)); 121 | * Preserve fractions of a second in `ToHttpApiData` instances (see [#53](https://github.com/fizruk/http-api-data/pull/53)); 122 | * Add `ToHttpApiData` and `FromHttpApiData` instances for `TimeOfDay` (see [#53](https://github.com/fizruk/http-api-data/pull/53)). 123 | 124 | 0.3.6 125 | --- 126 | 127 | * Minor change: 128 | * 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. 129 | 130 | 0.3.5 131 | --- 132 | 133 | * Minor changes: 134 | * Add `LenientData` which always succeeds to parse (see [#45](https://github.com/fizruk/http-api-data/pull/45)). 135 | 136 | 0.3.4 137 | --- 138 | 139 | * Minor changes: 140 | * Add support for GHC 8.2, drop support for GHC 7.6 (see [#44](https://github.com/fizruk/http-api-data/pull/44)). 141 | 142 | 0.3.3 143 | --- 144 | 145 | * Minor changes: 146 | * Expose `Form` constructor from `Web.FromUrlEncoded` (see [#40](https://github.com/fizruk/http-api-data/pull/40)); 147 | * Fix example in `FromForm` documentation (see [#39](https://github.com/fizruk/http-api-data/issues/39)). 148 | 149 | 0.3.2 150 | --- 151 | 152 | * Minor change: 153 | * Export `Form` type from `Web.FormUrlEncoded` (see [#37](https://github.com/fizruk/http-api-data/pull/37)). 154 | 155 | 0.3.1 156 | --- 157 | 158 | * Minor changes: 159 | * Add instances for `Data.UUID` (see [#34](https://github.com/fizruk/http-api-data/pull/34)). 160 | 161 | 0.3 162 | --- 163 | * Major changes: 164 | * Add `Web.FormUrlEncoded` to work with form data (see [#32](https://github.com/fizruk/http-api-data/pull/32)). 165 | 166 | * Minor changes: 167 | * Add instances for `Numeric.Natural` (see [`d944721`](https://github.com/fizruk/http-api-data/commit/d944721ac94929a7ed9e66f25e23221799c08d83)). 168 | 169 | 0.2.4 170 | --- 171 | * Make `parseHeader` total (instead of throwing exceptions on invalid Unicode, see [#30](https://github.com/fizruk/http-api-data/pull/30)). 172 | 173 | 0.2.3 174 | --- 175 | * Add more parser helpers for `Bounded` `Enum` types. 176 | 177 | 0.2.2 178 | --- 179 | 180 | * Add instances for more `time` types: `LocalTime`, `ZonedTime`, `UTCTime` and `NominalDiffTime` 181 | 182 | 0.2.1 183 | --- 184 | 185 | * Add helpers for multiple URL pieces and query params: 186 | * `toUrlPieces`, `parseUrlPieces` 187 | * `toQueryParams`, `parseQueryParams` 188 | 189 | 0.2 190 | --- 191 | 192 | * Export helper functions from `Web.HttpApiData`: 193 | * `parseUrlPieceMaybe`, `parseHeaderMaybe`, `parseQueryParamMaybe` 194 | * `parseUrlPieceWithPrefix`, `parseHeaderWithPrefix`, `parseQueryParamWithPrefix` 195 | * `showTextData`, `readTextData`, `parseBoundedTextData` 196 | * Fix AMP related warnings 197 | 198 | 0.1.1 199 | --- 200 | 201 | * Add `use-text-show` flag to optionally use more efficient `TextShow` instances 202 | -------------------------------------------------------------------------------- /test/Web/Internal/HttpApiDataSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ScopedTypeVariables #-} 2 | module Web.Internal.HttpApiDataSpec (spec) where 3 | 4 | 5 | import qualified Data.ByteString as BS 6 | import Data.ByteString.Builder (toLazyByteString) 7 | import Data.Char 8 | import qualified Data.Fixed as F 9 | import Data.Int 10 | import qualified Data.Text as T 11 | import qualified Data.Text.Encoding as TE 12 | import qualified Data.Text.Lazy as L 13 | import Data.Time.Compat 14 | import Data.Time.Calendar.Month.Compat (Month) 15 | import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) 16 | import qualified Data.UUID.Types as UUID 17 | import Data.Version 18 | import Data.Word 19 | import Web.Cookie (SetCookie, defaultSetCookie, 20 | setCookieName, setCookieValue) 21 | 22 | import Data.Proxy 23 | 24 | import Numeric.Natural 25 | 26 | import Test.Hspec 27 | import Test.Hspec.QuickCheck (prop) 28 | import Test.QuickCheck 29 | 30 | import Web.Internal.HttpApiData 31 | 32 | import Web.Internal.TestInstances 33 | 34 | (<=>) :: forall a b. (Show a, Show b, Eq a) => (a -> b) -> (b -> Either T.Text a) -> a -> Property 35 | (f <=> g) x = counterexample 36 | (show lhs' ++ " : " ++ show lhs ++ " /= " ++ show rhs) 37 | (lhs == rhs) 38 | where 39 | lhs' = f x 40 | lhs = g lhs' :: Either T.Text a 41 | rhs = Right x :: Either T.Text a 42 | 43 | encodedUrlPieceProp :: ToHttpApiData a => a -> Property 44 | encodedUrlPieceProp x = toLazyByteString (toEncodedUrlPiece (toUrlPiece x)) === toLazyByteString (toEncodedUrlPiece x) 45 | 46 | encodedQueryParamProp :: ToHttpApiData a => a -> Property 47 | encodedQueryParamProp x = toLazyByteString (toEncodedQueryParam (toQueryParam x)) === toLazyByteString (toEncodedQueryParam x) 48 | 49 | -- | Check 'ToHttpApiData' and 'FromHttpApiData' compatibility 50 | checkUrlPiece :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a, Arbitrary a) => Proxy a -> String -> Spec 51 | checkUrlPiece _ = checkUrlPiece' (arbitrary :: Gen a) 52 | 53 | checkUrlPiece' :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a) => Gen a -> String -> Spec 54 | checkUrlPiece' gen name = describe name $ do 55 | prop "toUrlPiece <=> parseUrlPiece" $ forAll gen (toUrlPiece <=> parseUrlPiece :: a -> Property) 56 | prop "toQueryParam <=> parseQueryParam" $ forAll gen (toQueryParam <=> parseQueryParam :: a -> Property) 57 | prop "toHeader <=> parseHeader" $ forAll gen (toHeader <=> parseHeader :: a -> Property) 58 | prop "toEncodedUrlPiece encodes correctly" $ forAll gen encodedUrlPieceProp 59 | prop "toEncodedQueryParam encodes correctly" $ forAll gen encodedQueryParamProp 60 | 61 | -- | Check case insensitivity for @parseUrlPiece@. 62 | checkUrlPieceI :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Arbitrary a) => Proxy a -> String -> Spec 63 | checkUrlPieceI _ = checkUrlPiece (Proxy :: Proxy (RandomCase a)) 64 | 65 | spec :: Spec 66 | spec = do 67 | describe "Instances" $ do 68 | checkUrlPiece (Proxy :: Proxy ()) "()" 69 | checkUrlPiece (Proxy :: Proxy Char) "Char" 70 | checkUrlPieceI (Proxy :: Proxy Bool) "Bool" 71 | checkUrlPieceI (Proxy :: Proxy Ordering) "Ordering" 72 | checkUrlPiece (Proxy :: Proxy Int) "Int" 73 | checkUrlPiece (Proxy :: Proxy Int8) "Int8" 74 | checkUrlPiece (Proxy :: Proxy Int16) "Int16" 75 | checkUrlPiece (Proxy :: Proxy Int32) "Int32" 76 | checkUrlPiece (Proxy :: Proxy Int64) "Int64" 77 | checkUrlPiece (Proxy :: Proxy Integer) "Integer" 78 | checkUrlPiece (Proxy :: Proxy Word) "Word" 79 | checkUrlPiece (Proxy :: Proxy Word8) "Word8" 80 | checkUrlPiece (Proxy :: Proxy Word16) "Word16" 81 | checkUrlPiece (Proxy :: Proxy Word32) "Word32" 82 | checkUrlPiece (Proxy :: Proxy Word64) "Word64" 83 | checkUrlPiece (Proxy :: Proxy String) "String" 84 | checkUrlPiece (Proxy :: Proxy T.Text) "Text.Strict" 85 | checkUrlPiece (Proxy :: Proxy L.Text) "Text.Lazy" 86 | checkUrlPiece (Proxy :: Proxy Day) "Day" 87 | checkUrlPiece (Proxy :: Proxy TimeOfDay) "TimeOfDay" 88 | checkUrlPiece (Proxy :: Proxy LocalTime) "LocalTime" 89 | checkUrlPiece (Proxy :: Proxy ZonedTime) "ZonedTime" 90 | checkUrlPiece (Proxy :: Proxy UTCTime) "UTCTime" 91 | checkUrlPiece (Proxy :: Proxy NominalDiffTime) "NominalDiffTime" 92 | checkUrlPiece (Proxy :: Proxy DayOfWeek) "DayOfWeek" 93 | checkUrlPiece (Proxy :: Proxy Quarter) "Quarter" 94 | checkUrlPiece (Proxy :: Proxy QuarterOfYear) "QuarterOfYear" 95 | checkUrlPiece (Proxy :: Proxy Month) "Month" 96 | checkUrlPiece (Proxy :: Proxy DayOfWeek) "DayOfWeek" 97 | checkUrlPiece (Proxy :: Proxy Version) "Version" 98 | checkUrlPiece (Proxy :: Proxy UUID.UUID) "UUID" 99 | checkUrlPiece' setCookieGen "Cookie" 100 | 101 | checkUrlPiece (Proxy :: Proxy F.Uni) "Uni" 102 | checkUrlPiece (Proxy :: Proxy F.Deci) "Deci" 103 | checkUrlPiece (Proxy :: Proxy F.Centi) "Centi" 104 | checkUrlPiece (Proxy :: Proxy F.Milli) "Milli" 105 | checkUrlPiece (Proxy :: Proxy F.Micro) "Micro" 106 | checkUrlPiece (Proxy :: Proxy F.Nano) "Nano" 107 | checkUrlPiece (Proxy :: Proxy F.Pico) "Pico" 108 | 109 | checkUrlPiece (Proxy :: Proxy (Maybe String)) "Maybe String" 110 | checkUrlPieceI (Proxy :: Proxy (Maybe Integer)) "Maybe Integer" 111 | checkUrlPiece (Proxy :: Proxy (Either Integer T.Text)) "Either Integer Text" 112 | checkUrlPieceI (Proxy :: Proxy (Either Version Day)) "Either Version Day" 113 | 114 | checkUrlPiece (Proxy :: Proxy Natural) "Natural" 115 | 116 | it "bad integers are rejected" $ do 117 | parseUrlPieceMaybe (T.pack "123hello") `shouldBe` (Nothing :: Maybe Int) 118 | 119 | it "bounds checking works" $ do 120 | parseUrlPieceMaybe (T.pack "256") `shouldBe` (Nothing :: Maybe Int8) 121 | parseUrlPieceMaybe (T.pack "-10") `shouldBe` (Nothing :: Maybe Word) 122 | 123 | it "invalid utf8 is handled" $ do 124 | parseHeaderMaybe (BS.pack [128]) `shouldBe` (Nothing :: Maybe T.Text) 125 | 126 | setCookieGen :: Gen SetCookie 127 | setCookieGen = do 128 | n <- TE.encodeUtf8 . T.pack . filter isAlphaNum <$> arbitrary 129 | v <- TE.encodeUtf8 . T.pack . filter isAlphaNum <$> arbitrary 130 | return $ defaultSetCookie { setCookieName = n, setCookieValue = v } 131 | -------------------------------------------------------------------------------- /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'cabal.project' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.19.20250330 12 | # 13 | # REGENDATA ("0.19.20250330",["github","cabal.project"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | push: 18 | branches: 19 | - master 20 | pull_request: 21 | branches: 22 | - master 23 | jobs: 24 | linux: 25 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 26 | runs-on: ubuntu-24.04 27 | timeout-minutes: 28 | 60 29 | container: 30 | image: buildpack-deps:jammy 31 | continue-on-error: ${{ matrix.allow-failure }} 32 | strategy: 33 | matrix: 34 | include: 35 | - compiler: ghc-9.12.2 36 | compilerKind: ghc 37 | compilerVersion: 9.12.2 38 | setup-method: ghcup 39 | allow-failure: false 40 | - compiler: ghc-9.10.1 41 | compilerKind: ghc 42 | compilerVersion: 9.10.1 43 | setup-method: ghcup 44 | allow-failure: false 45 | - compiler: ghc-9.8.4 46 | compilerKind: ghc 47 | compilerVersion: 9.8.4 48 | setup-method: ghcup 49 | allow-failure: false 50 | - compiler: ghc-9.6.7 51 | compilerKind: ghc 52 | compilerVersion: 9.6.7 53 | setup-method: ghcup 54 | allow-failure: false 55 | - compiler: ghc-9.4.8 56 | compilerKind: ghc 57 | compilerVersion: 9.4.8 58 | setup-method: ghcup 59 | allow-failure: false 60 | - compiler: ghc-9.2.8 61 | compilerKind: ghc 62 | compilerVersion: 9.2.8 63 | setup-method: ghcup 64 | allow-failure: false 65 | - compiler: ghc-9.0.2 66 | compilerKind: ghc 67 | compilerVersion: 9.0.2 68 | setup-method: ghcup 69 | allow-failure: false 70 | - compiler: ghc-8.10.7 71 | compilerKind: ghc 72 | compilerVersion: 8.10.7 73 | setup-method: ghcup 74 | allow-failure: false 75 | - compiler: ghc-8.8.4 76 | compilerKind: ghc 77 | compilerVersion: 8.8.4 78 | setup-method: ghcup 79 | allow-failure: false 80 | - compiler: ghc-8.6.5 81 | compilerKind: ghc 82 | compilerVersion: 8.6.5 83 | setup-method: ghcup 84 | allow-failure: false 85 | fail-fast: false 86 | steps: 87 | - name: apt-get install 88 | run: | 89 | apt-get update 90 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 91 | - name: Install GHCup 92 | run: | 93 | mkdir -p "$HOME/.ghcup/bin" 94 | curl -sL https://downloads.haskell.org/ghcup/0.1.50.1/x86_64-linux-ghcup-0.1.50.1 > "$HOME/.ghcup/bin/ghcup" 95 | chmod a+x "$HOME/.ghcup/bin/ghcup" 96 | - name: Install cabal-install 97 | run: | 98 | "$HOME/.ghcup/bin/ghcup" install cabal 3.14.1.1-p1 || (cat "$HOME"/.ghcup/logs/*.* && false) 99 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.14.1.1-p1 -vnormal+nowrap" >> "$GITHUB_ENV" 100 | - name: Install GHC (GHCup) 101 | if: matrix.setup-method == 'ghcup' 102 | run: | 103 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) 104 | HC=$("$HOME/.ghcup/bin/ghcup" whereis ghc "$HCVER") 105 | HCPKG=$(echo "$HC" | sed 's#ghc$#ghc-pkg#') 106 | HADDOCK=$(echo "$HC" | sed 's#ghc$#haddock#') 107 | echo "HC=$HC" >> "$GITHUB_ENV" 108 | echo "HCPKG=$HCPKG" >> "$GITHUB_ENV" 109 | echo "HADDOCK=$HADDOCK" >> "$GITHUB_ENV" 110 | env: 111 | HCKIND: ${{ matrix.compilerKind }} 112 | HCNAME: ${{ matrix.compiler }} 113 | HCVER: ${{ matrix.compilerVersion }} 114 | - name: Set PATH and environment variables 115 | run: | 116 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 117 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 118 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 119 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 120 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 121 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 122 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 123 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 124 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 125 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 126 | env: 127 | HCKIND: ${{ matrix.compilerKind }} 128 | HCNAME: ${{ matrix.compiler }} 129 | HCVER: ${{ matrix.compilerVersion }} 130 | - name: env 131 | run: | 132 | env 133 | - name: write cabal config 134 | run: | 135 | mkdir -p $CABAL_DIR 136 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 169 | echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - 170 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 171 | rm -f cabal-plan.xz 172 | chmod a+x $HOME/.cabal/bin/cabal-plan 173 | cabal-plan --version 174 | - name: install cabal-docspec 175 | run: | 176 | mkdir -p $HOME/.cabal/bin 177 | curl -sL https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20240703/cabal-docspec-0.0.0.20240703-x86_64-linux.xz > cabal-docspec.xz 178 | echo '48bf3b7fd2f7f0caa6162afee57a755be8523e7f467b694900eb420f5f9a7b76 cabal-docspec.xz' | sha256sum -c - 179 | xz -d < cabal-docspec.xz > $HOME/.cabal/bin/cabal-docspec 180 | rm -f cabal-docspec.xz 181 | chmod a+x $HOME/.cabal/bin/cabal-docspec 182 | cabal-docspec --version 183 | - name: checkout 184 | uses: actions/checkout@v4 185 | with: 186 | path: source 187 | - name: initial cabal.project for sdist 188 | run: | 189 | touch cabal.project 190 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 191 | cat cabal.project 192 | - name: sdist 193 | run: | 194 | mkdir -p sdist 195 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 196 | - name: unpack 197 | run: | 198 | mkdir -p unpacked 199 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 200 | - name: generate cabal.project 201 | run: | 202 | PKGDIR_http_api_data="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/http-api-data-[0-9.]*')" 203 | echo "PKGDIR_http_api_data=${PKGDIR_http_api_data}" >> "$GITHUB_ENV" 204 | rm -f cabal.project cabal.project.local 205 | touch cabal.project 206 | touch cabal.project.local 207 | echo "packages: ${PKGDIR_http_api_data}" >> cabal.project 208 | echo "package http-api-data" >> cabal.project 209 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 210 | cat >> cabal.project <> cabal.project.local 213 | cat cabal.project 214 | cat cabal.project.local 215 | - name: dump install plan 216 | run: | 217 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 218 | cabal-plan 219 | - name: restore cache 220 | uses: actions/cache/restore@v4 221 | with: 222 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 223 | path: ~/.cabal/store 224 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 225 | - name: install dependencies 226 | run: | 227 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 228 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 229 | - name: build w/o tests 230 | run: | 231 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 232 | - name: build 233 | run: | 234 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 235 | - name: tests 236 | run: | 237 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 238 | - name: docspec 239 | run: | 240 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all 241 | cabal-docspec $ARG_COMPILER 242 | - name: cabal check 243 | run: | 244 | cd ${PKGDIR_http_api_data} || false 245 | ${CABAL} -vnormal check 246 | - name: haddock 247 | run: | 248 | $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 249 | - name: unconstrained build 250 | run: | 251 | rm -f cabal.project.local 252 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 253 | - name: prepare for constraint sets 254 | run: | 255 | rm -f cabal.project.local 256 | - name: constraint set text-show 257 | run: | 258 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='http-api-data +use-text-show' all --dry-run 259 | cabal-plan topo | sort 260 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='http-api-data +use-text-show' --dependencies-only -j2 all 261 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='http-api-data +use-text-show' all 262 | - name: save cache 263 | if: always() 264 | uses: actions/cache/save@v4 265 | with: 266 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 267 | path: ~/.cabal/store 268 | -------------------------------------------------------------------------------- /src/Web/Internal/FormUrlEncoded.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DefaultSignatures #-} 4 | {-# LANGUAGE DeriveGeneric #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE FlexibleInstances #-} 7 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 8 | {-# LANGUAGE KindSignatures #-} 9 | {-# LANGUAGE MultiParamTypeClasses #-} 10 | {-# LANGUAGE OverloadedStrings #-} 11 | {-# LANGUAGE PolyKinds #-} 12 | {-# LANGUAGE ScopedTypeVariables #-} 13 | {-# LANGUAGE TypeFamilies #-} 14 | {-# LANGUAGE TypeOperators #-} 15 | {-# LANGUAGE UndecidableInstances #-} 16 | module Web.Internal.FormUrlEncoded where 17 | 18 | import Control.Applicative (Const(Const)) 19 | import Control.Arrow ((***)) 20 | import Control.Monad ((<=<)) 21 | import Data.ByteString.Builder (shortByteString, toLazyByteString) 22 | import qualified Data.ByteString.Lazy as BSL 23 | import qualified Data.ByteString.Lazy.Char8 as BSL8 24 | import Data.Coerce (coerce) 25 | import qualified Data.Foldable as F 26 | import Data.Functor.Identity (Identity(Identity)) 27 | import Data.Hashable (Hashable) 28 | import Data.HashMap.Strict (HashMap) 29 | import qualified Data.HashMap.Strict as HashMap 30 | import Data.Int (Int16, Int32, Int64, Int8) 31 | import Data.IntMap (IntMap) 32 | import qualified Data.IntMap as IntMap 33 | import Data.List (intersperse, sortBy) 34 | import Data.Map (Map) 35 | import qualified Data.Map as Map 36 | import Data.Monoid (All (..), Any (..), Dual (..), 37 | Product (..), Sum (..)) 38 | import Data.Ord (comparing) 39 | import Data.Proxy (Proxy (..)) 40 | import Data.Semigroup (Semigroup (..)) 41 | import qualified Data.Semigroup as Semi 42 | import Data.Tagged (Tagged (..)) 43 | import Data.Text (Text) 44 | import qualified Data.Text as Text 45 | import qualified Data.Text.Encoding as Text 46 | import Data.Text.Encoding.Error (lenientDecode) 47 | import qualified Data.Text.Lazy as Lazy 48 | import Data.Time.Compat (Day, LocalTime, NominalDiffTime, 49 | UTCTime, ZonedTime) 50 | import Data.Time.Calendar.Month.Compat (Month) 51 | import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) 52 | import Data.Void (Void) 53 | import Data.Word (Word16, Word32, Word64, Word8) 54 | import GHC.Exts (Constraint, IsList (..)) 55 | import GHC.Generics 56 | import GHC.TypeLits 57 | import Network.HTTP.Types.URI (urlDecode, urlEncodeBuilder) 58 | import Numeric.Natural (Natural) 59 | import Web.Internal.HttpApiData 60 | 61 | -- $setup 62 | -- >>> :set -XDeriveGeneric -XOverloadedLists -XOverloadedStrings -XFlexibleContexts -XScopedTypeVariables -XTypeFamilies 63 | -- >>> import GHC.Generics (Generic) 64 | -- >>> import Data.Char (toLower) 65 | -- >>> import Data.Text (Text) 66 | -- >>> import Data.Word (Word8) 67 | -- 68 | -- >>> data Person = Person { name :: String, age :: Int } deriving (Show, Generic) 69 | -- >>> instance ToForm Person 70 | -- >>> instance FromForm Person 71 | -- 72 | -- >>> data Post = Post { title :: String, subtitle :: Maybe String, comments :: [String]} deriving (Generic, Show) 73 | -- >>> instance ToForm Post 74 | -- >>> instance FromForm Post 75 | -- 76 | -- >>> data Project = Project { projectName :: String, projectSize :: Int } deriving (Generic, Show) 77 | -- >>> let myOptions = FormOptions { fieldLabelModifier = map toLower . drop (length ("project" :: String)) } 78 | -- >>> instance ToForm Project where toForm = genericToForm myOptions 79 | -- >>> instance FromForm Project where fromForm = genericFromForm myOptions 80 | 81 | -- | Typeclass for types that can be used as keys in a 'Form'-like container (like 'Map'). 82 | class ToFormKey k where 83 | -- | Render a key for a 'Form'. 84 | toFormKey :: k -> Text 85 | 86 | instance ToFormKey () where toFormKey = toQueryParam 87 | instance ToFormKey Char where toFormKey = toQueryParam 88 | 89 | instance ToFormKey Bool where toFormKey = toQueryParam 90 | instance ToFormKey Ordering where toFormKey = toQueryParam 91 | 92 | instance ToFormKey Double where toFormKey = toQueryParam 93 | instance ToFormKey Float where toFormKey = toQueryParam 94 | instance ToFormKey Int where toFormKey = toQueryParam 95 | instance ToFormKey Int8 where toFormKey = toQueryParam 96 | instance ToFormKey Int16 where toFormKey = toQueryParam 97 | instance ToFormKey Int32 where toFormKey = toQueryParam 98 | instance ToFormKey Int64 where toFormKey = toQueryParam 99 | instance ToFormKey Integer where toFormKey = toQueryParam 100 | instance ToFormKey Word where toFormKey = toQueryParam 101 | instance ToFormKey Word8 where toFormKey = toQueryParam 102 | instance ToFormKey Word16 where toFormKey = toQueryParam 103 | instance ToFormKey Word32 where toFormKey = toQueryParam 104 | instance ToFormKey Word64 where toFormKey = toQueryParam 105 | 106 | instance ToFormKey Day where toFormKey = toQueryParam 107 | instance ToFormKey LocalTime where toFormKey = toQueryParam 108 | instance ToFormKey ZonedTime where toFormKey = toQueryParam 109 | instance ToFormKey UTCTime where toFormKey = toQueryParam 110 | instance ToFormKey NominalDiffTime where toFormKey = toQueryParam 111 | instance ToFormKey Quarter where toFormKey = toQueryParam 112 | instance ToFormKey QuarterOfYear where toFormKey = toQueryParam 113 | instance ToFormKey Month where toFormKey = toQueryParam 114 | 115 | instance ToFormKey String where toFormKey = toQueryParam 116 | instance ToFormKey Text where toFormKey = toQueryParam 117 | instance ToFormKey Lazy.Text where toFormKey = toQueryParam 118 | 119 | instance ToFormKey All where toFormKey = toQueryParam 120 | instance ToFormKey Any where toFormKey = toQueryParam 121 | 122 | instance ToFormKey a => ToFormKey (Dual a) where toFormKey = coerce (toFormKey :: a -> Text) 123 | instance ToFormKey a => ToFormKey (Sum a) where toFormKey = coerce (toFormKey :: a -> Text) 124 | instance ToFormKey a => ToFormKey (Product a) where toFormKey = coerce (toFormKey :: a -> Text) 125 | 126 | instance ToFormKey a => ToFormKey (Semi.Min a) where toFormKey = coerce (toFormKey :: a -> Text) 127 | instance ToFormKey a => ToFormKey (Semi.Max a) where toFormKey = coerce (toFormKey :: a -> Text) 128 | instance ToFormKey a => ToFormKey (Semi.First a) where toFormKey = coerce (toFormKey :: a -> Text) 129 | instance ToFormKey a => ToFormKey (Semi.Last a) where toFormKey = coerce (toFormKey :: a -> Text) 130 | 131 | instance ToFormKey a => ToFormKey (Tagged b a) where toFormKey = coerce (toFormKey :: a -> Text) 132 | 133 | -- | @since 0.4.2 134 | instance ToFormKey a => ToFormKey (Identity a) where toFormKey = coerce (toFormKey :: a -> Text) 135 | 136 | -- | @since 0.4.2 137 | instance ToFormKey a => ToFormKey (Const a b) where 138 | toFormKey = coerce (toFormKey :: a -> Text) 139 | 140 | instance ToFormKey Void where toFormKey = toQueryParam 141 | instance ToFormKey Natural where toFormKey = toQueryParam 142 | 143 | -- | Typeclass for types that can be parsed from keys of a 'Form'. This is the reverse of 'ToFormKey'. 144 | class FromFormKey k where 145 | -- | Parse a key of a 'Form'. 146 | parseFormKey :: Text -> Either Text k 147 | 148 | instance FromFormKey () where parseFormKey = parseQueryParam 149 | instance FromFormKey Char where parseFormKey = parseQueryParam 150 | 151 | instance FromFormKey Bool where parseFormKey = parseQueryParam 152 | instance FromFormKey Ordering where parseFormKey = parseQueryParam 153 | 154 | instance FromFormKey Double where parseFormKey = parseQueryParam 155 | instance FromFormKey Float where parseFormKey = parseQueryParam 156 | instance FromFormKey Int where parseFormKey = parseQueryParam 157 | instance FromFormKey Int8 where parseFormKey = parseQueryParam 158 | instance FromFormKey Int16 where parseFormKey = parseQueryParam 159 | instance FromFormKey Int32 where parseFormKey = parseQueryParam 160 | instance FromFormKey Int64 where parseFormKey = parseQueryParam 161 | instance FromFormKey Integer where parseFormKey = parseQueryParam 162 | instance FromFormKey Word where parseFormKey = parseQueryParam 163 | instance FromFormKey Word8 where parseFormKey = parseQueryParam 164 | instance FromFormKey Word16 where parseFormKey = parseQueryParam 165 | instance FromFormKey Word32 where parseFormKey = parseQueryParam 166 | instance FromFormKey Word64 where parseFormKey = parseQueryParam 167 | 168 | instance FromFormKey Day where parseFormKey = parseQueryParam 169 | instance FromFormKey LocalTime where parseFormKey = parseQueryParam 170 | instance FromFormKey ZonedTime where parseFormKey = parseQueryParam 171 | instance FromFormKey UTCTime where parseFormKey = parseQueryParam 172 | instance FromFormKey NominalDiffTime where parseFormKey = parseQueryParam 173 | instance FromFormKey Quarter where parseFormKey = parseQueryParam 174 | instance FromFormKey QuarterOfYear where parseFormKey = parseQueryParam 175 | instance FromFormKey Month where parseFormKey = parseQueryParam 176 | 177 | instance FromFormKey String where parseFormKey = parseQueryParam 178 | instance FromFormKey Text where parseFormKey = parseQueryParam 179 | instance FromFormKey Lazy.Text where parseFormKey = parseQueryParam 180 | 181 | instance FromFormKey All where parseFormKey = parseQueryParam 182 | instance FromFormKey Any where parseFormKey = parseQueryParam 183 | 184 | instance FromFormKey a => FromFormKey (Dual a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 185 | instance FromFormKey a => FromFormKey (Sum a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 186 | instance FromFormKey a => FromFormKey (Product a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 187 | 188 | instance FromFormKey a => FromFormKey (Semi.Min a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 189 | instance FromFormKey a => FromFormKey (Semi.Max a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 190 | instance FromFormKey a => FromFormKey (Semi.First a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 191 | instance FromFormKey a => FromFormKey (Semi.Last a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 192 | 193 | instance FromFormKey a => FromFormKey (Tagged b a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 194 | 195 | -- | @since 0.4.2 196 | instance FromFormKey a => FromFormKey (Identity a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 197 | 198 | -- | @since 0.4.2 199 | instance FromFormKey a => FromFormKey (Const a b) where 200 | parseFormKey = coerce (parseFormKey :: Text -> Either Text a) 201 | 202 | instance FromFormKey Void where parseFormKey = parseQueryParam 203 | instance FromFormKey Natural where parseFormKey = parseQueryParam 204 | 205 | -- | The contents of a form, not yet URL-encoded. 206 | -- 207 | -- 'Form' can be URL-encoded with 'urlEncodeForm' and URL-decoded with 'urlDecodeForm'. 208 | newtype Form = Form { unForm :: HashMap Text [Text] } 209 | deriving (Eq, Read, Generic, Semigroup, Monoid) 210 | 211 | instance Show Form where 212 | showsPrec d form = showParen (d > 10) $ 213 | showString "fromList " . shows (toListStable form) 214 | 215 | -- | _NOTE:_ 'toList' is unstable and may result in different key order (but not values). 216 | -- For a stable conversion use 'toListStable'. 217 | instance IsList Form where 218 | type Item Form = (Text, Text) 219 | fromList = Form . HashMap.fromListWith (flip (<>)) . fmap (\(k, v) -> (k, [v])) 220 | toList = concatMap (\(k, vs) -> map ((,) k) vs) . HashMap.toList . unForm 221 | 222 | -- | A stable version of 'toList'. 223 | toListStable :: Form -> [(Text, Text)] 224 | toListStable = sortOn fst . toList 225 | 226 | -- | Convert a value into 'Form'. 227 | -- 228 | -- An example type and instance: 229 | -- 230 | -- @ 231 | -- {-\# LANGUAGE OverloadedLists \#-} 232 | -- 233 | -- data Person = Person 234 | -- { name :: String 235 | -- , age :: Int } 236 | -- 237 | -- instance 'ToForm' Person where 238 | -- 'toForm' person = 239 | -- [ (\"name\", 'toQueryParam' (name person)) 240 | -- , (\"age\", 'toQueryParam' (age person)) ] 241 | -- @ 242 | -- 243 | -- Instead of manually writing @'ToForm'@ instances you can 244 | -- use a default generic implementation of @'toForm'@. 245 | -- 246 | -- To do that, simply add @deriving 'Generic'@ clause to your datatype 247 | -- and declare a 'ToForm' instance for your datatype without 248 | -- giving definition for 'toForm'. 249 | -- 250 | -- For instance, the previous example can be simplified into this: 251 | -- 252 | -- @ 253 | -- data Person = Person 254 | -- { name :: String 255 | -- , age :: Int 256 | -- } deriving ('Generic') 257 | -- 258 | -- instance 'ToForm' Person 259 | -- @ 260 | -- 261 | -- The default implementation of 'toForm' is 'genericToForm'. 262 | class ToForm a where 263 | -- | Convert a value into 'Form'. 264 | toForm :: a -> Form 265 | default toForm :: (Generic a, GToForm a (Rep a)) => a -> Form 266 | toForm = genericToForm defaultFormOptions 267 | 268 | instance ToForm Form where toForm = id 269 | 270 | instance (ToFormKey k, ToHttpApiData v) => ToForm [(k, v)] where 271 | toForm = fromList . map (toFormKey *** toQueryParam) 272 | 273 | instance (ToFormKey k, ToHttpApiData v) => ToForm (Map k [v]) where 274 | toForm = fromEntriesByKey . Map.toList 275 | 276 | instance (ToFormKey k, ToHttpApiData v) => ToForm (HashMap k [v]) where 277 | toForm = fromEntriesByKey . HashMap.toList 278 | 279 | instance ToHttpApiData v => ToForm (IntMap [v]) where 280 | toForm = fromEntriesByKey . IntMap.toList 281 | 282 | -- | Convert a list of entries groupped by key into a 'Form'. 283 | -- 284 | -- >>> fromEntriesByKey [("name",["Nick"]),("color",["red","blue"])] 285 | -- fromList [("color","red"),("color","blue"),("name","Nick")] 286 | fromEntriesByKey :: (ToFormKey k, ToHttpApiData v) => [(k, [v])] -> Form 287 | fromEntriesByKey = Form . HashMap.fromListWith (<>) . map (toFormKey *** map toQueryParam) 288 | 289 | data Proxy3 a b c = Proxy3 290 | 291 | type family NotSupported (cls :: k1) (a :: k2) (reason :: Symbol) :: Constraint where 292 | NotSupported cls a reason = TypeError 293 | ( 'Text "Cannot derive a Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instance for " ':<>: 'ShowType a ':<>: 'Text "." ':$$: 294 | 'ShowType a ':<>: 'Text " " ':<>: 'Text reason ':<>: 'Text "," ':$$: 295 | 'Text "but Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instances can be derived only for records" ':$$: 296 | 'Text "(i.e. product types with named fields)." ) 297 | 298 | -- | A 'Generic'-based implementation of 'toForm'. 299 | -- This is used as a default implementation in 'ToForm'. 300 | -- 301 | -- Note that this only works for records (i.e. product data types with named fields): 302 | -- 303 | -- @ 304 | -- data Person = Person 305 | -- { name :: String 306 | -- , age :: Int 307 | -- } deriving ('Generic') 308 | -- @ 309 | -- 310 | -- In this implementation each field's value gets encoded using `toQueryParam`. 311 | -- Two field types are exceptions: 312 | -- 313 | -- - for values of type @'Maybe' a@ an entry is added to the 'Form' only when it is @'Just' x@ 314 | -- and the encoded value is @'toQueryParam' x@; 'Nothing' values are omitted from the 'Form'; 315 | -- 316 | -- - for values of type @[a]@ (except @['Char']@) an entry is added for every item in the list; 317 | -- if the list is empty no entries are added to the 'Form'; 318 | -- 319 | -- Here's an example: 320 | -- 321 | -- @ 322 | -- data Post = Post 323 | -- { title :: String 324 | -- , subtitle :: Maybe String 325 | -- , comments :: [String] 326 | -- } deriving ('Generic', 'Show') 327 | -- 328 | -- instance 'ToForm' Post 329 | -- @ 330 | -- 331 | -- >>> urlEncodeAsFormStable Post { title = "Test", subtitle = Nothing, comments = ["Nice post!", "+1"] } 332 | -- "comments=Nice%20post%21&comments=%2B1&title=Test" 333 | genericToForm :: forall a. (Generic a, GToForm a (Rep a)) => FormOptions -> a -> Form 334 | genericToForm opts = gToForm (Proxy :: Proxy a) opts . from 335 | 336 | class GToForm t (f :: * -> *) where 337 | gToForm :: Proxy t -> FormOptions -> f x -> Form 338 | 339 | instance (GToForm t f, GToForm t g) => GToForm t (f :*: g) where 340 | gToForm p opts (a :*: b) = gToForm p opts a <> gToForm p opts b 341 | 342 | instance (GToForm t f) => GToForm t (M1 D x f) where 343 | gToForm p opts (M1 a) = gToForm p opts a 344 | 345 | instance (GToForm t f) => GToForm t (M1 C x f) where 346 | gToForm p opts (M1 a) = gToForm p opts a 347 | 348 | instance {-# OVERLAPPABLE #-} (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i c)) where 349 | gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)] 350 | where 351 | key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) 352 | 353 | instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i (Maybe c))) where 354 | gToForm _ opts (M1 (K1 c)) = 355 | case c of 356 | Nothing -> mempty 357 | Just x -> fromList [(key, toQueryParam x)] 358 | where 359 | key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) 360 | 361 | instance (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i [c])) where 362 | gToForm _ opts (M1 (K1 cs)) = fromList (map (\c -> (key, toQueryParam c)) cs) 363 | where 364 | key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) 365 | 366 | instance {-# OVERLAPPING #-} (Selector s) => GToForm t (M1 S s (K1 i String)) where 367 | gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)] 368 | where 369 | key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) 370 | 371 | instance NotSupported ToForm t "is a sum type" => GToForm t (f :+: g) where gToForm = error "impossible" 372 | 373 | -- | Parse 'Form' into a value. 374 | -- 375 | -- An example type and instance: 376 | -- 377 | -- @ 378 | -- data Person = Person 379 | -- { name :: String 380 | -- , age :: Int } 381 | -- 382 | -- instance 'FromForm' Person where 383 | -- 'fromForm' f = Person 384 | -- '<$>' 'parseUnique' "name" f 385 | -- '<*>' 'parseUnique' "age" f 386 | -- @ 387 | -- 388 | -- Instead of manually writing @'FromForm'@ instances you can 389 | -- use a default generic implementation of @'fromForm'@. 390 | -- 391 | -- To do that, simply add @deriving 'Generic'@ clause to your datatype 392 | -- and declare a 'FromForm' instance for your datatype without 393 | -- giving definition for 'fromForm'. 394 | -- 395 | -- For instance, the previous example can be simplified into this: 396 | -- 397 | -- @ 398 | -- data Person = Person 399 | -- { name :: String 400 | -- , age :: Int 401 | -- } deriving ('Generic') 402 | -- 403 | -- instance 'FromForm' Person 404 | -- @ 405 | -- 406 | -- The default implementation of 'fromForm' is 'genericFromForm'. 407 | -- It only works for records and it will use 'parseQueryParam' for each field's value. 408 | class FromForm a where 409 | -- | Parse 'Form' into a value. 410 | fromForm :: Form -> Either Text a 411 | default fromForm :: (Generic a, GFromForm a (Rep a)) => Form -> Either Text a 412 | fromForm = genericFromForm defaultFormOptions 413 | 414 | instance FromForm Form where fromForm = pure 415 | 416 | -- | _NOTE:_ this conversion is unstable and may result in different key order (but not values). 417 | instance (FromFormKey k, FromHttpApiData v) => FromForm [(k, v)] where 418 | fromForm = fmap (concatMap (\(k, vs) -> map ((,) k) vs)) . toEntriesByKey 419 | 420 | instance (Ord k, FromFormKey k, FromHttpApiData v) => FromForm (Map k [v]) where 421 | fromForm = fmap (Map.fromListWith (<>)) . toEntriesByKey 422 | 423 | instance (Eq k, Hashable k, FromFormKey k, FromHttpApiData v) => FromForm (HashMap k [v]) where 424 | fromForm = fmap (HashMap.fromListWith (<>)) . toEntriesByKey 425 | 426 | instance FromHttpApiData v => FromForm (IntMap [v]) where 427 | fromForm = fmap (IntMap.fromListWith (<>)) . toEntriesByKey 428 | 429 | -- | Parse a 'Form' into a list of entries groupped by key. 430 | -- 431 | -- _NOTE:_ this conversion is unstable and may result in different key order 432 | -- (but not values). For a stable encoding see 'toEntriesByKeyStable'. 433 | toEntriesByKey :: (FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])] 434 | toEntriesByKey = traverse parseGroup . HashMap.toList . unForm 435 | where 436 | parseGroup (k, vs) = (,) <$> parseFormKey k <*> traverse parseQueryParam vs 437 | 438 | -- | Parse a 'Form' into a list of entries groupped by key. 439 | -- 440 | -- >>> toEntriesByKeyStable [("name", "Nick"), ("color", "red"), ("color", "white")] :: Either Text [(Text, [Text])] 441 | -- Right [("color",["red","white"]),("name",["Nick"])] 442 | -- 443 | -- For an unstable (but faster) conversion see 'toEntriesByKey'. 444 | toEntriesByKeyStable :: (Ord k, FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])] 445 | toEntriesByKeyStable = fmap (sortOn fst) . toEntriesByKey 446 | 447 | -- | A 'Generic'-based implementation of 'fromForm'. 448 | -- This is used as a default implementation in 'FromForm'. 449 | -- 450 | -- Note that this only works for records (i.e. product data types with named fields): 451 | -- 452 | -- @ 453 | -- data Person = Person 454 | -- { name :: String 455 | -- , age :: Int 456 | -- } deriving ('Generic') 457 | -- @ 458 | -- 459 | -- In this implementation each field's value gets decoded using `parseQueryParam`. 460 | -- Two field types are exceptions: 461 | -- 462 | -- - for values of type @'Maybe' a@ an entry is parsed if present in the 'Form' 463 | -- and the is decoded with 'parseQueryParam'; if no entry is present result is 'Nothing'; 464 | -- 465 | -- - for values of type @[a]@ (except @['Char']@) all entries are parsed to produce a list of parsed values; 466 | -- 467 | -- Here's an example: 468 | -- 469 | -- @ 470 | -- data Post = Post 471 | -- { title :: String 472 | -- , subtitle :: Maybe String 473 | -- , comments :: [String] 474 | -- } deriving ('Generic', 'Show') 475 | -- 476 | -- instance 'FromForm' Post 477 | -- @ 478 | -- 479 | -- >>> urlDecodeAsForm "comments=Nice%20post%21&comments=%2B1&title=Test" :: Either Text Post 480 | -- Right (Post {title = "Test", subtitle = Nothing, comments = ["Nice post!","+1"]}) 481 | genericFromForm :: forall a. (Generic a, GFromForm a (Rep a)) => FormOptions -> Form -> Either Text a 482 | genericFromForm opts f = to <$> gFromForm (Proxy :: Proxy a) opts f 483 | 484 | class GFromForm t (f :: * -> *) where 485 | gFromForm :: Proxy t -> FormOptions -> Form -> Either Text (f x) 486 | 487 | instance (GFromForm t f, GFromForm t g) => GFromForm t (f :*: g) where 488 | gFromForm p opts f = (:*:) <$> gFromForm p opts f <*> gFromForm p opts f 489 | 490 | instance GFromForm t f => GFromForm t (M1 D x f) where 491 | gFromForm p opts f = M1 <$> gFromForm p opts f 492 | 493 | instance GFromForm t f => GFromForm t (M1 C x f) where 494 | gFromForm p opts f = M1 <$> gFromForm p opts f 495 | 496 | instance {-# OVERLAPPABLE #-} (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i c)) where 497 | gFromForm _ opts form = M1 . K1 <$> parseUnique key form 498 | where 499 | key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) 500 | 501 | instance (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i (Maybe c))) where 502 | gFromForm _ opts form = M1 . K1 <$> parseMaybe key form 503 | where 504 | key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) 505 | 506 | instance (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i [c])) where 507 | gFromForm _ opts form = M1 . K1 <$> parseAll key form 508 | where 509 | key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) 510 | 511 | instance {-# OVERLAPPING #-} (Selector s) => GFromForm t (M1 S s (K1 i String)) where 512 | gFromForm _ opts form = M1 . K1 <$> parseUnique key form 513 | where 514 | key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) 515 | 516 | instance NotSupported FromForm t "is a sum type" => GFromForm t (f :+: g) where gFromForm = error "impossible" 517 | 518 | -- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'. 519 | -- 520 | -- _NOTE:_ this encoding is unstable and may result in different key order 521 | -- (but not values). For a stable encoding see 'urlEncodeFormStable'. 522 | urlEncodeForm :: Form -> BSL.ByteString 523 | urlEncodeForm = urlEncodeParams . toList 524 | 525 | -- | Encode a 'Form' to an @application/x-www-form-urlencoded@ 'BSL.ByteString'. 526 | -- 527 | -- For an unstable (but faster) encoding see 'urlEncodeForm'. 528 | -- 529 | -- Key-value pairs get encoded to @key=value@ and separated by @&@: 530 | -- 531 | -- >>> urlEncodeFormStable [("name", "Julian"), ("lastname", "Arni")] 532 | -- "lastname=Arni&name=Julian" 533 | -- 534 | -- Keys with empty values get encoded to just @key@ (without the @=@ sign): 535 | -- 536 | -- >>> urlEncodeFormStable [("is_test", "")] 537 | -- "is_test" 538 | -- 539 | -- Empty keys are allowed too: 540 | -- 541 | -- >>> urlEncodeFormStable [("", "foobar")] 542 | -- "=foobar" 543 | -- 544 | -- However, if both key and value are empty, the key-value pair is ignored. 545 | -- (This prevents @'urlDecodeForm' . 'urlEncodeFormStable'@ from being a true isomorphism). 546 | -- 547 | -- >>> urlEncodeFormStable [("", "")] 548 | -- "" 549 | -- 550 | -- Everything is escaped with @'escapeURIString' 'isUnreserved'@: 551 | -- 552 | -- >>> urlEncodeFormStable [("fullname", "Andres Löh")] 553 | -- "fullname=Andres%20L%C3%B6h" 554 | urlEncodeFormStable :: Form -> BSL.ByteString 555 | urlEncodeFormStable = urlEncodeParams . sortOn fst . toList 556 | 557 | -- | Encode a list of key-value pairs to an @application/x-www-form-urlencoded@ 'BSL.ByteString'. 558 | -- 559 | -- See also 'urlEncodeFormStable'. 560 | urlEncodeParams :: [(Text, Text)] -> BSL.ByteString 561 | urlEncodeParams = toLazyByteString . mconcat . intersperse (shortByteString "&") . map encodePair 562 | where 563 | escape = urlEncodeBuilder True . Text.encodeUtf8 564 | 565 | encodePair (k, "") = escape k 566 | encodePair (k, v) = escape k <> shortByteString "=" <> escape v 567 | 568 | -- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a 'Form'. 569 | -- 570 | -- Key-value pairs get decoded normally: 571 | -- 572 | -- >>> urlDecodeForm "name=Greg&lastname=Weber" 573 | -- Right (fromList [("lastname","Weber"),("name","Greg")]) 574 | -- 575 | -- Keys with no values get decoded to pairs with empty values. 576 | -- 577 | -- >>> urlDecodeForm "is_test" 578 | -- Right (fromList [("is_test","")]) 579 | -- 580 | -- Empty keys are allowed: 581 | -- 582 | -- >>> urlDecodeForm "=foobar" 583 | -- Right (fromList [("","foobar")]) 584 | -- 585 | -- The empty string gets decoded into an empty 'Form': 586 | -- 587 | -- >>> urlDecodeForm "" 588 | -- Right (fromList []) 589 | -- 590 | -- Everything is un-escaped with 'unEscapeString': 591 | -- 592 | -- >>> urlDecodeForm "fullname=Andres%20L%C3%B6h" 593 | -- Right (fromList [("fullname","Andres L\246h")]) 594 | -- 595 | -- Improperly formed strings result in an error: 596 | -- 597 | -- >>> urlDecodeForm "this=has=too=many=equals" 598 | -- Left "not a valid pair: this=has=too=many=equals" 599 | urlDecodeForm :: BSL.ByteString -> Either Text Form 600 | urlDecodeForm = fmap toForm . urlDecodeParams 601 | 602 | -- | Decode an @application/x-www-form-urlencoded@ 'BSL.ByteString' to a list of key-value pairs. 603 | -- 604 | -- See also 'urlDecodeForm'. 605 | urlDecodeParams :: BSL.ByteString -> Either Text [(Text, Text)] 606 | urlDecodeParams bs = traverse parsePair pairs 607 | where 608 | pairs = map (BSL8.split '=') (BSL8.split '&' bs) 609 | 610 | unescape = Text.decodeUtf8With lenientDecode . urlDecode True . BSL.toStrict 611 | 612 | parsePair p = 613 | case map unescape p of 614 | [k, v] -> return (k, v) 615 | [k] -> return (k, "") 616 | xs -> Left $ "not a valid pair: " <> Text.intercalate "=" xs 617 | 618 | 619 | -- | This is a convenience function for decoding a 620 | -- @application/x-www-form-urlencoded@ 'BSL.ByteString' directly to a datatype 621 | -- that has an instance of 'FromForm'. 622 | -- 623 | -- This is effectively @'fromForm' '<=<' 'urlDecodeForm'@. 624 | -- 625 | -- >>> urlDecodeAsForm "name=Dennis&age=22" :: Either Text Person 626 | -- Right (Person {name = "Dennis", age = 22}) 627 | urlDecodeAsForm :: FromForm a => BSL.ByteString -> Either Text a 628 | urlDecodeAsForm = fromForm <=< urlDecodeForm 629 | 630 | -- | This is a convenience function for encoding a datatype that has instance 631 | -- of 'ToForm' directly to a @application/x-www-form-urlencoded@ 632 | -- 'BSL.ByteString'. 633 | -- 634 | -- This is effectively @'urlEncodeForm' . 'toForm'@. 635 | -- 636 | -- _NOTE:_ this encoding is unstable and may result in different key order 637 | -- (but not values). For a stable encoding see 'urlEncodeAsFormStable'. 638 | urlEncodeAsForm :: ToForm a => a -> BSL.ByteString 639 | urlEncodeAsForm = urlEncodeForm . toForm 640 | 641 | -- | This is a convenience function for encoding a datatype that has instance 642 | -- of 'ToForm' directly to a @application/x-www-form-urlencoded@ 643 | -- 'BSL.ByteString'. 644 | -- 645 | -- This is effectively @'urlEncodeFormStable' . 'toForm'@. 646 | -- 647 | -- >>> urlEncodeAsFormStable Person {name = "Dennis", age = 22} 648 | -- "age=22&name=Dennis" 649 | urlEncodeAsFormStable :: ToForm a => a -> BSL.ByteString 650 | urlEncodeAsFormStable = urlEncodeFormStable . toForm 651 | 652 | -- | Find all values corresponding to a given key in a 'Form'. 653 | -- 654 | -- >>> lookupAll "name" [] 655 | -- [] 656 | -- >>> lookupAll "name" [("name", "Oleg")] 657 | -- ["Oleg"] 658 | -- >>> lookupAll "name" [("name", "Oleg"), ("name", "David")] 659 | -- ["Oleg","David"] 660 | lookupAll :: Text -> Form -> [Text] 661 | lookupAll key = F.concat . HashMap.lookup key . unForm 662 | 663 | -- | Lookup an optional value for a key. 664 | -- Fail if there is more than one value. 665 | -- 666 | -- >>> lookupMaybe "name" [] 667 | -- Right Nothing 668 | -- >>> lookupMaybe "name" [("name", "Oleg")] 669 | -- Right (Just "Oleg") 670 | -- >>> lookupMaybe "name" [("name", "Oleg"), ("name", "David")] 671 | -- Left "Duplicate key \"name\"" 672 | lookupMaybe :: Text -> Form -> Either Text (Maybe Text) 673 | lookupMaybe key form = 674 | case lookupAll key form of 675 | [] -> pure Nothing 676 | [v] -> pure (Just v) 677 | _ -> Left $ "Duplicate key " <> Text.pack (show key) 678 | 679 | -- | Lookup a unique value for a key. 680 | -- Fail if there is zero or more than one value. 681 | -- 682 | -- >>> lookupUnique "name" [] 683 | -- Left "Could not find key \"name\"" 684 | -- >>> lookupUnique "name" [("name", "Oleg")] 685 | -- Right "Oleg" 686 | -- >>> lookupUnique "name" [("name", "Oleg"), ("name", "David")] 687 | -- Left "Duplicate key \"name\"" 688 | lookupUnique :: Text -> Form -> Either Text Text 689 | lookupUnique key form = do 690 | mv <- lookupMaybe key form 691 | case mv of 692 | Just v -> pure v 693 | Nothing -> Left $ "Could not find key " <> Text.pack (show key) 694 | 695 | -- | Lookup all values for a given key in a 'Form' and parse them with 'parseQueryParams'. 696 | -- 697 | -- >>> parseAll "age" [] :: Either Text [Word8] 698 | -- Right [] 699 | -- >>> parseAll "age" [("age", "8"), ("age", "seven")] :: Either Text [Word8] 700 | -- Left "could not parse: `seven' (input does not start with a digit)" 701 | -- >>> parseAll "age" [("age", "8"), ("age", "777")] :: Either Text [Word8] 702 | -- Left "out of bounds: `777' (should be between 0 and 255)" 703 | -- >>> parseAll "age" [("age", "12"), ("age", "25")] :: Either Text [Word8] 704 | -- Right [12,25] 705 | parseAll :: FromHttpApiData v => Text -> Form -> Either Text [v] 706 | parseAll key = parseQueryParams . lookupAll key 707 | 708 | -- | Lookup an optional value for a given key and parse it with 'parseQueryParam'. 709 | -- Fail if there is more than one value for the key. 710 | -- 711 | -- >>> parseMaybe "age" [] :: Either Text (Maybe Word8) 712 | -- Right Nothing 713 | -- >>> parseMaybe "age" [("age", "12"), ("age", "25")] :: Either Text (Maybe Word8) 714 | -- Left "Duplicate key \"age\"" 715 | -- >>> parseMaybe "age" [("age", "seven")] :: Either Text (Maybe Word8) 716 | -- Left "could not parse: `seven' (input does not start with a digit)" 717 | -- >>> parseMaybe "age" [("age", "777")] :: Either Text (Maybe Word8) 718 | -- Left "out of bounds: `777' (should be between 0 and 255)" 719 | -- >>> parseMaybe "age" [("age", "7")] :: Either Text (Maybe Word8) 720 | -- Right (Just 7) 721 | parseMaybe :: FromHttpApiData v => Text -> Form -> Either Text (Maybe v) 722 | parseMaybe key = parseQueryParams <=< lookupMaybe key 723 | 724 | -- | Lookup a unique value for a given key and parse it with 'parseQueryParam'. 725 | -- Fail if there is zero or more than one value for the key. 726 | -- 727 | -- >>> parseUnique "age" [] :: Either Text Word8 728 | -- Left "Could not find key \"age\"" 729 | -- >>> parseUnique "age" [("age", "12"), ("age", "25")] :: Either Text Word8 730 | -- Left "Duplicate key \"age\"" 731 | -- >>> parseUnique "age" [("age", "seven")] :: Either Text Word8 732 | -- Left "could not parse: `seven' (input does not start with a digit)" 733 | -- >>> parseUnique "age" [("age", "777")] :: Either Text Word8 734 | -- Left "out of bounds: `777' (should be between 0 and 255)" 735 | -- >>> parseUnique "age" [("age", "7")] :: Either Text Word8 736 | -- Right 7 737 | parseUnique :: FromHttpApiData v => Text -> Form -> Either Text v 738 | parseUnique key form = lookupUnique key form >>= parseQueryParam 739 | 740 | -- | 'Generic'-based deriving options for 'ToForm' and 'FromForm'. 741 | -- 742 | -- A common use case for non-default 'FormOptions' 743 | -- is to strip a prefix off of field labels: 744 | -- 745 | -- @ 746 | -- data Project = Project 747 | -- { projectName :: String 748 | -- , projectSize :: Int 749 | -- } deriving ('Generic', 'Show') 750 | -- 751 | -- myOptions :: 'FormOptions' 752 | -- myOptions = 'FormOptions' 753 | -- { 'fieldLabelModifier' = 'map' 'toLower' . 'drop' ('length' \"project\") } 754 | -- 755 | -- instance 'ToForm' Project where 756 | -- 'toForm' = 'genericToForm' myOptions 757 | -- 758 | -- instance 'FromForm' Project where 759 | -- 'fromForm' = 'genericFromForm' myOptions 760 | -- @ 761 | -- 762 | -- >>> urlEncodeAsFormStable Project { projectName = "http-api-data", projectSize = 172 } 763 | -- "name=http-api-data&size=172" 764 | -- >>> urlDecodeAsForm "name=http-api-data&size=172" :: Either Text Project 765 | -- Right (Project {projectName = "http-api-data", projectSize = 172}) 766 | data FormOptions = FormOptions 767 | { -- | Function applied to field labels. Handy for removing common record prefixes for example. 768 | fieldLabelModifier :: String -> String 769 | } 770 | 771 | -- | Default encoding 'FormOptions'. 772 | -- 773 | -- @ 774 | -- 'FormOptions' 775 | -- { 'fieldLabelModifier' = id 776 | -- } 777 | -- @ 778 | defaultFormOptions :: FormOptions 779 | defaultFormOptions = FormOptions 780 | { fieldLabelModifier = id 781 | } 782 | 783 | sortOn :: Ord b => (a -> b) -> [a] -> [a] 784 | sortOn f = sortBy (comparing f) 785 | -------------------------------------------------------------------------------- /src/Web/Internal/HttpApiData.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DefaultSignatures #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE DeriveFoldable #-} 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE DeriveTraversable #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE KindSignatures #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE PolyKinds #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeSynonymInstances #-} 13 | -- | 14 | -- Convert Haskell values to and from HTTP API data 15 | -- such as URL pieces, headers and query parameters. 16 | module Web.Internal.HttpApiData where 17 | 18 | import Control.Applicative (Const(Const)) 19 | import Control.Arrow (left, (&&&)) 20 | import Control.Monad ((<=<)) 21 | import Data.ByteString (ByteString) 22 | import qualified Data.ByteString as BS 23 | import qualified Data.ByteString.Builder as BS 24 | import qualified Data.ByteString.Lazy as LBS 25 | import Data.Coerce (coerce) 26 | import Data.Data (Data) 27 | import qualified Data.Fixed as F 28 | import Data.Functor.Identity (Identity(Identity)) 29 | import Data.Int (Int16, Int32, Int64, Int8) 30 | import Data.Kind (Type) 31 | import qualified Data.Map as Map 32 | import Data.Monoid (All (..), Any (..), Dual (..), 33 | First (..), Last (..), 34 | Product (..), Sum (..)) 35 | import Data.Semigroup (Semigroup (..)) 36 | import qualified Data.Semigroup as Semi 37 | import Data.Tagged (Tagged (..)) 38 | import Data.Text (Text) 39 | import qualified Data.Text as T 40 | import Data.Text.Encoding (decodeUtf8', decodeUtf8With, 41 | encodeUtf8) 42 | import Data.Text.Encoding.Error (lenientDecode) 43 | import qualified Data.Text.Lazy as L 44 | import Data.Text.Lazy.Builder (Builder, toLazyText) 45 | import Data.Text.Read (Reader, decimal, rational, 46 | signed) 47 | import qualified Data.Time.ToText as TT 48 | import qualified Data.Time.FromText as FT 49 | import Data.Time.Compat (Day, LocalTime, 50 | NominalDiffTime, TimeOfDay, 51 | UTCTime, ZonedTime, DayOfWeek (..), 52 | nominalDiffTimeToSeconds, 53 | secondsToNominalDiffTime) 54 | import Data.Time.Calendar.Month.Compat (Month) 55 | import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) 56 | import Data.Typeable (Typeable) 57 | import qualified Data.UUID.Types as UUID 58 | import Data.Version (Version, parseVersion, 59 | showVersion) 60 | import Data.Void (Void, absurd) 61 | import Data.Word (Word16, Word32, Word64, Word8) 62 | import qualified Network.HTTP.Types as H 63 | import Numeric.Natural (Natural) 64 | import Text.ParserCombinators.ReadP (readP_to_S) 65 | import Text.Read (readMaybe) 66 | import Web.Cookie (SetCookie, parseSetCookie, 67 | renderSetCookie) 68 | 69 | #if USE_TEXT_SHOW 70 | import TextShow (TextShow, showt) 71 | #endif 72 | 73 | -- $setup 74 | -- >>> :set -XOverloadedStrings 75 | -- >>> import Data.Text (Text) 76 | -- >>> import Data.Word (Word8) 77 | -- >>> import Data.Text.Read (decimal) 78 | -- >>> import Data.Time.Compat 79 | -- >>> import Data.Time.Calendar.Month.Compat 80 | -- >>> import Data.Time.Calendar.Quarter.Compat 81 | -- >>> import Data.Version 82 | -- >>> import Web.Cookie (SetCookie) 83 | -- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show) 84 | -- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p 85 | 86 | -- | Convert value to HTTP API data. 87 | -- 88 | -- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated 89 | -- instance will loop indefinitely. 90 | class ToHttpApiData a where 91 | {-# MINIMAL toUrlPiece | toQueryParam #-} 92 | -- | Convert to URL path piece. 93 | toUrlPiece :: a -> Text 94 | toUrlPiece = toQueryParam 95 | 96 | -- | Convert to a URL path piece, making sure to encode any special chars. 97 | -- The default definition uses @'H.urlEncodeBuilder' 'False'@ 98 | -- but this may be overriden with a more efficient version. 99 | toEncodedUrlPiece :: a -> BS.Builder 100 | toEncodedUrlPiece = H.urlEncodeBuilder False . encodeUtf8 . toUrlPiece 101 | 102 | -- | Convert to HTTP header value. 103 | toHeader :: a -> ByteString 104 | toHeader = encodeUtf8 . toUrlPiece 105 | 106 | -- | Convert to query param value. 107 | toQueryParam :: a -> Text 108 | toQueryParam = toUrlPiece 109 | 110 | -- | Convert to URL query param, 111 | -- The default definition uses @'H.urlEncodeBuilder' 'True'@ 112 | -- but this may be overriden with a more efficient version. 113 | -- 114 | -- @since 0.5.1 115 | toEncodedQueryParam :: a -> BS.Builder 116 | toEncodedQueryParam = H.urlEncodeBuilder True . encodeUtf8 . toQueryParam 117 | 118 | -- | Parse value from HTTP API data. 119 | -- 120 | -- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated 121 | -- instance will loop indefinitely. 122 | class FromHttpApiData a where 123 | {-# MINIMAL parseUrlPiece | parseQueryParam #-} 124 | -- | Parse URL path piece. 125 | parseUrlPiece :: Text -> Either Text a 126 | parseUrlPiece = parseQueryParam 127 | 128 | -- | Parse HTTP header value. 129 | parseHeader :: ByteString -> Either Text a 130 | parseHeader = parseUrlPiece <=< (left (T.pack . show) . decodeUtf8') 131 | 132 | -- | Parse query param value. 133 | parseQueryParam :: Text -> Either Text a 134 | parseQueryParam = parseUrlPiece 135 | 136 | -- | Convert multiple values to a list of URL pieces. 137 | -- 138 | -- >>> toUrlPieces [1, 2, 3] :: [Text] 139 | -- ["1","2","3"] 140 | toUrlPieces :: (Functor t, ToHttpApiData a) => t a -> t Text 141 | toUrlPieces = fmap toUrlPiece 142 | 143 | -- | Parse multiple URL pieces. 144 | -- 145 | -- >>> parseUrlPieces ["true", "false"] :: Either Text [Bool] 146 | -- Right [True,False] 147 | -- >>> parseUrlPieces ["123", "hello", "world"] :: Either Text [Int] 148 | -- Left "could not parse: `hello' (input does not start with a digit)" 149 | parseUrlPieces :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a) 150 | parseUrlPieces = traverse parseUrlPiece 151 | 152 | -- | Convert multiple values to a list of query parameter values. 153 | -- 154 | -- >>> toQueryParams [fromGregorian 2015 10 03, fromGregorian 2015 12 01] :: [Text] 155 | -- ["2015-10-03","2015-12-01"] 156 | toQueryParams :: (Functor t, ToHttpApiData a) => t a -> t Text 157 | toQueryParams = fmap toQueryParam 158 | 159 | -- | Parse multiple query parameters. 160 | -- 161 | -- >>> parseQueryParams ["1", "2", "3"] :: Either Text [Int] 162 | -- Right [1,2,3] 163 | -- >>> parseQueryParams ["64", "128", "256"] :: Either Text [Word8] 164 | -- Left "out of bounds: `256' (should be between 0 and 255)" 165 | parseQueryParams :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a) 166 | parseQueryParams = traverse parseQueryParam 167 | 168 | -- | Parse URL path piece in a @'Maybe'@. 169 | -- 170 | -- >>> parseUrlPieceMaybe "12" :: Maybe Int 171 | -- Just 12 172 | parseUrlPieceMaybe :: FromHttpApiData a => Text -> Maybe a 173 | parseUrlPieceMaybe = either (const Nothing) Just . parseUrlPiece 174 | 175 | -- | Parse HTTP header value in a @'Maybe'@. 176 | -- 177 | -- >>> parseHeaderMaybe "hello" :: Maybe Text 178 | -- Just "hello" 179 | parseHeaderMaybe :: FromHttpApiData a => ByteString -> Maybe a 180 | parseHeaderMaybe = either (const Nothing) Just . parseHeader 181 | 182 | -- | Parse query param value in a @'Maybe'@. 183 | -- 184 | -- >>> parseQueryParamMaybe "true" :: Maybe Bool 185 | -- Just True 186 | parseQueryParamMaybe :: FromHttpApiData a => Text -> Maybe a 187 | parseQueryParamMaybe = either (const Nothing) Just . parseQueryParam 188 | 189 | -- | Default parsing error. 190 | defaultParseError :: Text -> Either Text a 191 | defaultParseError input = Left ("could not parse: `" <> input <> "'") 192 | 193 | -- | Convert @'Maybe'@ parser into @'Either' 'Text'@ parser with default error message. 194 | parseMaybeTextData :: (Text -> Maybe a) -> (Text -> Either Text a) 195 | parseMaybeTextData parse input = 196 | case parse input of 197 | Nothing -> defaultParseError input 198 | Just val -> Right val 199 | 200 | #if USE_TEXT_SHOW 201 | -- | /Lower case/. 202 | -- 203 | -- Convert to URL piece using @'TextShow'@ instance. 204 | -- The result is always lower cased. 205 | -- 206 | -- >>> showTextData True 207 | -- "true" 208 | -- 209 | -- This can be used as a default implementation for enumeration types: 210 | -- 211 | -- @ 212 | -- data MyData = Foo | Bar | Baz deriving (Generic) 213 | -- 214 | -- instance TextShow MyData where 215 | -- showt = genericShowt 216 | -- 217 | -- instance ToHttpApiData MyData where 218 | -- toUrlPiece = showTextData 219 | -- @ 220 | showTextData :: TextShow a => a -> Text 221 | showTextData = T.toLower . showt 222 | #else 223 | -- | /Lower case/. 224 | -- 225 | -- Convert to URL piece using @'Show'@ instance. 226 | -- The result is always lower cased. 227 | -- 228 | -- >>> showTextData True 229 | -- "true" 230 | -- 231 | -- This can be used as a default implementation for enumeration types: 232 | -- 233 | -- >>> data MyData = Foo | Bar | Baz deriving (Show) 234 | -- >>> instance ToHttpApiData MyData where toUrlPiece = showTextData 235 | -- >>> toUrlPiece Foo 236 | -- "foo" 237 | showTextData :: Show a => a -> Text 238 | showTextData = T.toLower . showt 239 | 240 | -- | Like @'show'@, but returns @'Text'@. 241 | showt :: Show a => a -> Text 242 | showt = T.pack . show 243 | #endif 244 | 245 | -- | /Case insensitive/. 246 | -- 247 | -- Parse given text case insensitive and then parse the rest of the input 248 | -- using @'parseUrlPiece'@. 249 | -- 250 | -- >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int 251 | -- Right 10 252 | -- >>> parseUrlPieceWithPrefix "Left " "left" :: Either Text Bool 253 | -- Left "could not parse: `left'" 254 | -- 255 | -- This can be used to implement @'FromHttpApiData'@ for single field constructors: 256 | -- 257 | -- >>> data Foo = Foo Int deriving (Show) 258 | -- >>> instance FromHttpApiData Foo where parseUrlPiece s = Foo <$> parseUrlPieceWithPrefix "Foo " s 259 | -- >>> parseUrlPiece "foo 1" :: Either Text Foo 260 | -- Right (Foo 1) 261 | parseUrlPieceWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a 262 | parseUrlPieceWithPrefix pattern input 263 | | T.toLower pattern == T.toLower prefix = parseUrlPiece rest 264 | | otherwise = defaultParseError input 265 | where 266 | (prefix, rest) = T.splitAt (T.length pattern) input 267 | 268 | -- | Parse given bytestring then parse the rest of the input using @'parseHeader'@. 269 | -- 270 | -- @ 271 | -- data BasicAuthToken = BasicAuthToken Text deriving (Show) 272 | -- 273 | -- instance FromHttpApiData BasicAuthToken where 274 | -- parseHeader h = BasicAuthToken \<$\> parseHeaderWithPrefix "Basic " h 275 | -- parseQueryParam p = BasicAuthToken \<$\> parseQueryParam p 276 | -- @ 277 | -- 278 | -- >>> parseHeader "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" :: Either Text BasicAuthToken 279 | -- Right (BasicAuthToken "QWxhZGRpbjpvcGVuIHNlc2FtZQ==") 280 | parseHeaderWithPrefix :: FromHttpApiData a => ByteString -> ByteString -> Either Text a 281 | parseHeaderWithPrefix pattern input 282 | | pattern `BS.isPrefixOf` input = parseHeader (BS.drop (BS.length pattern) input) 283 | | otherwise = defaultParseError (showt input) 284 | 285 | -- | /Case insensitive/. 286 | -- 287 | -- Parse given text case insensitive and then parse the rest of the input 288 | -- using @'parseQueryParam'@. 289 | -- 290 | -- >>> parseQueryParamWithPrefix "z" "z10" :: Either Text Int 291 | -- Right 10 292 | parseQueryParamWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a 293 | parseQueryParamWithPrefix pattern input 294 | | T.toLower pattern == T.toLower prefix = parseQueryParam rest 295 | | otherwise = defaultParseError input 296 | where 297 | (prefix, rest) = T.splitAt (T.length pattern) input 298 | 299 | #if USE_TEXT_SHOW 300 | -- | /Case insensitive/. 301 | -- 302 | -- Parse values case insensitively based on @'TextShow'@ instance. 303 | -- 304 | -- >>> parseBoundedTextData "true" :: Either Text Bool 305 | -- Right True 306 | -- >>> parseBoundedTextData "FALSE" :: Either Text Bool 307 | -- Right False 308 | -- 309 | -- This can be used as a default implementation for enumeration types: 310 | -- 311 | -- @ 312 | -- data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum, Generic) 313 | -- 314 | -- instance TextShow MyData where 315 | -- showt = genericShowt 316 | -- 317 | -- instance FromHttpApiData MyData where 318 | -- parseUrlPiece = parseBoundedTextData 319 | -- @ 320 | parseBoundedTextData :: (TextShow a, Bounded a, Enum a) => Text -> Either Text a 321 | #else 322 | -- | /Case insensitive/. 323 | -- 324 | -- Parse values case insensitively based on @'Show'@ instance. 325 | -- 326 | -- >>> parseBoundedTextData "true" :: Either Text Bool 327 | -- Right True 328 | -- >>> parseBoundedTextData "FALSE" :: Either Text Bool 329 | -- Right False 330 | -- 331 | -- This can be used as a default implementation for enumeration types: 332 | -- 333 | -- >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum) 334 | -- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedTextData 335 | -- >>> parseUrlPiece "foo" :: Either Text MyData 336 | -- Right Foo 337 | parseBoundedTextData :: (Show a, Bounded a, Enum a) => Text -> Either Text a 338 | #endif 339 | parseBoundedTextData = parseBoundedEnumOfI showTextData 340 | 341 | -- | Lookup values based on a precalculated mapping of their representations. 342 | lookupBoundedEnumOf :: (Bounded a, Enum a, Eq b) => (a -> b) -> b -> Maybe a 343 | lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound]) 344 | 345 | -- | Parse values based on a precalculated mapping of their @'Text'@ representation. 346 | -- 347 | -- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool 348 | -- Right True 349 | -- 350 | -- For case insensitive parser see 'parseBoundedEnumOfI'. 351 | parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a 352 | parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf 353 | 354 | -- | /Case insensitive/. 355 | -- 356 | -- Parse values case insensitively based on a precalculated mapping 357 | -- of their @'Text'@ representations. 358 | -- 359 | -- >>> parseBoundedEnumOfI toUrlPiece "FALSE" :: Either Text Bool 360 | -- Right False 361 | -- 362 | -- For case sensitive parser see 'parseBoundedEnumOf'. 363 | parseBoundedEnumOfI :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a 364 | parseBoundedEnumOfI f = parseBoundedEnumOf (T.toLower . f) . T.toLower 365 | 366 | -- | /Case insensitive/. 367 | -- 368 | -- Parse values case insensitively based on @'ToHttpApiData'@ instance. 369 | -- Uses @'toUrlPiece'@ to get possible values. 370 | parseBoundedUrlPiece :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a 371 | parseBoundedUrlPiece = parseBoundedEnumOfI toUrlPiece 372 | 373 | -- | /Case insensitive/. 374 | -- 375 | -- Parse values case insensitively based on @'ToHttpApiData'@ instance. 376 | -- Uses @'toQueryParam'@ to get possible values. 377 | parseBoundedQueryParam :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a 378 | parseBoundedQueryParam = parseBoundedEnumOfI toQueryParam 379 | 380 | -- | Parse values based on @'ToHttpApiData'@ instance. 381 | -- Uses @'toHeader'@ to get possible values. 382 | parseBoundedHeader :: (ToHttpApiData a, Bounded a, Enum a) => ByteString -> Either Text a 383 | parseBoundedHeader bs = case lookupBoundedEnumOf toHeader bs of 384 | Nothing -> defaultParseError $ T.pack $ show bs 385 | Just x -> return x 386 | 387 | -- | Parse URL piece using @'Read'@ instance. 388 | -- 389 | -- Use for types which do not involve letters: 390 | -- 391 | -- >>> readTextData "1991-06-02" :: Either Text Day 392 | -- Right 1991-06-02 393 | -- 394 | -- This parser is case sensitive and will not match @'showTextData'@ 395 | -- in presence of letters: 396 | -- 397 | -- >>> readTextData (showTextData True) :: Either Text Bool 398 | -- Left "could not parse: `true'" 399 | -- 400 | -- See @'parseBoundedTextData'@. 401 | readTextData :: Read a => Text -> Either Text a 402 | readTextData = parseMaybeTextData (readMaybe . T.unpack) 403 | 404 | -- | Run @'Reader'@ as HTTP API data parser. 405 | runReader :: Reader a -> Text -> Either Text a 406 | runReader reader input = 407 | case reader input of 408 | Left err -> Left ("could not parse: `" <> input <> "' (" <> T.pack err <> ")") 409 | Right (x, rest) 410 | | T.null rest -> Right x 411 | | otherwise -> defaultParseError input 412 | 413 | -- | Run @'Reader'@ to parse bounded integral value with bounds checking. 414 | -- 415 | -- >>> parseBounded decimal "256" :: Either Text Word8 416 | -- Left "out of bounds: `256' (should be between 0 and 255)" 417 | parseBounded :: forall a. (Bounded a, Integral a) => Reader Integer -> Text -> Either Text a 418 | parseBounded reader input = do 419 | n <- runReader reader input 420 | if (n > h || n < l) 421 | then Left ("out of bounds: `" <> input <> "' (should be between " <> showt l <> " and " <> showt h <> ")") 422 | else Right (fromInteger n) 423 | where 424 | l = toInteger (minBound :: a) 425 | h = toInteger (maxBound :: a) 426 | 427 | -- | Convert to a URL-encoded path piece using 'toUrlPiece'. 428 | -- /Note/: this function does not check if the result contains unescaped characters! 429 | -- This function can be used to override 'toEncodedUrlPiece' as a more efficient implementation 430 | -- when the resulting URL piece /never/ has to be escaped. 431 | unsafeToEncodedUrlPiece :: ToHttpApiData a => a -> BS.Builder 432 | unsafeToEncodedUrlPiece = BS.byteString . encodeUtf8 . toUrlPiece 433 | 434 | -- | Convert to a URL-encoded query param using 'toQueryParam'. 435 | -- /Note/: this function does not check if the result contains unescaped characters! 436 | -- 437 | -- @since 0.5.1 438 | unsafeToEncodedQueryParam :: ToHttpApiData a => a -> BS.Builder 439 | unsafeToEncodedQueryParam = BS.byteString . encodeUtf8 . toQueryParam 440 | 441 | -- | 442 | -- >>> toUrlPiece () 443 | -- "_" 444 | instance ToHttpApiData () where 445 | toUrlPiece _ = "_" 446 | toHeader _ = "_" 447 | toEncodedUrlPiece _ = "_" 448 | toEncodedQueryParam _ = "_" 449 | 450 | instance ToHttpApiData Char where 451 | toUrlPiece = T.singleton 452 | 453 | -- | 454 | -- >>> toUrlPiece (Version [1, 2, 3] []) 455 | -- "1.2.3" 456 | instance ToHttpApiData Version where 457 | toUrlPiece = T.pack . showVersion 458 | toEncodedUrlPiece = unsafeToEncodedUrlPiece 459 | toEncodedQueryParam = unsafeToEncodedQueryParam 460 | 461 | instance ToHttpApiData Void where toUrlPiece = absurd 462 | instance ToHttpApiData Natural where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 463 | 464 | instance ToHttpApiData Bool where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 465 | instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 466 | 467 | instance ToHttpApiData Double where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 468 | instance ToHttpApiData Float where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 469 | instance ToHttpApiData Int where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 470 | instance ToHttpApiData Int8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 471 | instance ToHttpApiData Int16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 472 | instance ToHttpApiData Int32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 473 | instance ToHttpApiData Int64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 474 | instance ToHttpApiData Integer where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 475 | instance ToHttpApiData Word where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 476 | instance ToHttpApiData Word8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 477 | instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 478 | instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 479 | instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 480 | 481 | -- | Note: this instance is not polykinded 482 | instance F.HasResolution a => ToHttpApiData (F.Fixed (a :: Type)) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam 483 | 484 | -- | 485 | -- >>> toUrlPiece (fromGregorian 2015 10 03) 486 | -- "2015-10-03" 487 | instance ToHttpApiData Day where 488 | toUrlPiece = runTT TT.buildDay 489 | toEncodedUrlPiece = unsafeToEncodedUrlPiece 490 | toEncodedQueryParam = unsafeToEncodedQueryParam 491 | 492 | -- | 493 | -- >>> toUrlPiece $ TimeOfDay 14 55 23.1 494 | -- "14:55:23.100" 495 | instance ToHttpApiData TimeOfDay where 496 | toUrlPiece = runTT TT.buildTimeOfDay 497 | toEncodedUrlPiece = unsafeToEncodedUrlPiece 498 | -- no toEncodedQueryParam as : is unsafe char. 499 | 500 | -- | 501 | -- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 21.687) 502 | -- "2015-10-03T14:55:21.687" 503 | instance ToHttpApiData LocalTime where 504 | toUrlPiece = runTT TT.buildLocalTime 505 | toEncodedUrlPiece = unsafeToEncodedUrlPiece 506 | -- no toEncodedQueryParam as : is unsafe char. 507 | 508 | -- | 509 | -- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 51.001)) utc 510 | -- "2015-10-03T14:55:51.001Z" 511 | -- 512 | -- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 51.001)) (TimeZone 120 True "EET") 513 | -- "2015-10-03T14:55:51.001+02:00" 514 | -- 515 | instance ToHttpApiData ZonedTime where 516 | toUrlPiece = runTT TT.buildZonedTime 517 | toEncodedUrlPiece = unsafeToEncodedUrlPiece 518 | -- no toEncodedQueryParam as : is unsafe char. 519 | 520 | -- | 521 | -- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864.5 522 | -- "2015-10-03T00:14:24.500Z" 523 | instance ToHttpApiData UTCTime where 524 | toUrlPiece = runTT TT.buildUTCTime 525 | toEncodedUrlPiece = unsafeToEncodedUrlPiece 526 | -- no toEncodedQueryParam as : is unsafe char. 527 | 528 | -- | 529 | -- >>> toUrlPiece Monday 530 | -- "monday" 531 | instance ToHttpApiData DayOfWeek where 532 | toUrlPiece Monday = "monday" 533 | toUrlPiece Tuesday = "tuesday" 534 | toUrlPiece Wednesday = "wednesday" 535 | toUrlPiece Thursday = "thursday" 536 | toUrlPiece Friday = "friday" 537 | toUrlPiece Saturday = "saturday" 538 | toUrlPiece Sunday = "sunday" 539 | 540 | toEncodedUrlPiece = unsafeToEncodedUrlPiece 541 | toEncodedQueryParam = unsafeToEncodedQueryParam 542 | 543 | -- | 544 | -- >>> toUrlPiece Q4 545 | -- "q4" 546 | instance ToHttpApiData QuarterOfYear where 547 | toUrlPiece = runTT TT.buildQuarterOfYear 548 | 549 | toEncodedUrlPiece = unsafeToEncodedUrlPiece 550 | toEncodedQueryParam = unsafeToEncodedQueryParam 551 | 552 | -- | 553 | -- >>> import Data.Time.Calendar.Quarter.Compat (Quarter (..)) 554 | -- >>> MkQuarter 8040 555 | -- 2010-Q1 556 | -- 557 | -- >>> toUrlPiece $ MkQuarter 8040 558 | -- "2010-q1" 559 | -- 560 | instance ToHttpApiData Quarter where 561 | toUrlPiece = runTT TT.buildQuarter 562 | 563 | toEncodedUrlPiece = unsafeToEncodedUrlPiece 564 | toEncodedQueryParam = unsafeToEncodedQueryParam 565 | 566 | -- | 567 | -- >>> import Data.Time.Calendar.Month.Compat (Month (..)) 568 | -- >>> MkMonth 24482 569 | -- 2040-03 570 | -- 571 | -- >>> toUrlPiece $ MkMonth 24482 572 | -- "2040-03" 573 | -- 574 | instance ToHttpApiData Month where 575 | toUrlPiece = runTT TT.buildMonth 576 | 577 | toEncodedUrlPiece = unsafeToEncodedUrlPiece 578 | toEncodedQueryParam = unsafeToEncodedQueryParam 579 | 580 | instance ToHttpApiData NominalDiffTime where 581 | toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds 582 | 583 | toEncodedQueryParam = unsafeToEncodedQueryParam 584 | toEncodedUrlPiece = unsafeToEncodedUrlPiece 585 | 586 | instance ToHttpApiData String where toUrlPiece = T.pack 587 | instance ToHttpApiData Text where toUrlPiece = id 588 | instance ToHttpApiData L.Text where toUrlPiece = L.toStrict 589 | 590 | instance ToHttpApiData All where 591 | toUrlPiece = coerce (toUrlPiece :: Bool -> Text) 592 | toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder) 593 | toEncodedQueryParam = coerce (toEncodedQueryParam :: Bool -> BS.Builder) 594 | 595 | instance ToHttpApiData Any where 596 | toUrlPiece = coerce (toUrlPiece :: Bool -> Text) 597 | toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder) 598 | toEncodedQueryParam = coerce (toEncodedQueryParam :: Bool -> BS.Builder) 599 | 600 | instance ToHttpApiData a => ToHttpApiData (Dual a) where 601 | toUrlPiece = coerce (toUrlPiece :: a -> Text) 602 | toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) 603 | toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) 604 | 605 | instance ToHttpApiData a => ToHttpApiData (Sum a) where 606 | toUrlPiece = coerce (toUrlPiece :: a -> Text) 607 | toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) 608 | toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) 609 | 610 | instance ToHttpApiData a => ToHttpApiData (Product a) where 611 | toUrlPiece = coerce (toUrlPiece :: a -> Text) 612 | toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) 613 | toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) 614 | 615 | instance ToHttpApiData a => ToHttpApiData (First a) where 616 | toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text) 617 | toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder) 618 | toEncodedQueryParam = coerce (toEncodedQueryParam :: Maybe a -> BS.Builder) 619 | 620 | instance ToHttpApiData a => ToHttpApiData (Last a) where 621 | toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text) 622 | toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder) 623 | toEncodedQueryParam = coerce (toEncodedQueryParam :: Maybe a -> BS.Builder) 624 | 625 | instance ToHttpApiData a => ToHttpApiData (Semi.Min a) where 626 | toUrlPiece = coerce (toUrlPiece :: a -> Text) 627 | toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) 628 | toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) 629 | 630 | instance ToHttpApiData a => ToHttpApiData (Semi.Max a) where 631 | toUrlPiece = coerce (toUrlPiece :: a -> Text) 632 | toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) 633 | toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) 634 | 635 | instance ToHttpApiData a => ToHttpApiData (Semi.First a) where 636 | toUrlPiece = coerce (toUrlPiece :: a -> Text) 637 | toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) 638 | toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) 639 | 640 | instance ToHttpApiData a => ToHttpApiData (Semi.Last a) where 641 | toUrlPiece = coerce (toUrlPiece :: a -> Text) 642 | toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) 643 | toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) 644 | 645 | -- | 646 | -- >>> toUrlPiece (Just "Hello") 647 | -- "just Hello" 648 | instance ToHttpApiData a => ToHttpApiData (Maybe a) where 649 | toUrlPiece (Just x) = "just " <> toUrlPiece x 650 | toUrlPiece Nothing = "nothing" 651 | 652 | -- | 653 | -- >>> toUrlPiece (Left "err" :: Either String Int) 654 | -- "left err" 655 | -- >>> toUrlPiece (Right 3 :: Either String Int) 656 | -- "right 3" 657 | instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where 658 | toUrlPiece (Left x) = "left " <> toUrlPiece x 659 | toUrlPiece (Right x) = "right " <> toUrlPiece x 660 | 661 | -- | /Note:/ this instance works correctly for alphanumeric name and value 662 | -- 663 | -- >>> let Right c = parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie 664 | -- >>> toUrlPiece c 665 | -- "SESSID=r2t5uvjq435r4q7ib3vtdjq120" 666 | -- 667 | -- >>> toHeader c 668 | -- "SESSID=r2t5uvjq435r4q7ib3vtdjq120" 669 | -- 670 | instance ToHttpApiData SetCookie where 671 | toUrlPiece = decodeUtf8With lenientDecode . toHeader 672 | toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie 673 | -- toEncodedUrlPiece = renderSetCookie -- doesn't do things. 674 | 675 | -- | Note: this instance is not polykinded 676 | instance ToHttpApiData a => ToHttpApiData (Tagged (b :: Type) a) where 677 | toUrlPiece = coerce (toUrlPiece :: a -> Text) 678 | toHeader = coerce (toHeader :: a -> ByteString) 679 | toQueryParam = coerce (toQueryParam :: a -> Text) 680 | toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) 681 | toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) 682 | 683 | -- | @since 0.4.2 684 | instance ToHttpApiData a => ToHttpApiData (Const a b) where 685 | toUrlPiece = coerce (toUrlPiece :: a -> Text) 686 | toHeader = coerce (toHeader :: a -> ByteString) 687 | toQueryParam = coerce (toQueryParam :: a -> Text) 688 | toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) 689 | toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) 690 | 691 | -- | @since 0.4.2 692 | instance ToHttpApiData a => ToHttpApiData (Identity a) where 693 | toUrlPiece = coerce (toUrlPiece :: a -> Text) 694 | toHeader = coerce (toHeader :: a -> ByteString) 695 | toQueryParam = coerce (toQueryParam :: a -> Text) 696 | toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) 697 | toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) 698 | 699 | -- | 700 | -- >>> parseUrlPiece "_" :: Either Text () 701 | -- Right () 702 | instance FromHttpApiData () where 703 | parseUrlPiece "_" = pure () 704 | parseUrlPiece s = defaultParseError s 705 | 706 | instance FromHttpApiData Char where 707 | parseUrlPiece s = 708 | case T.uncons s of 709 | Just (c, s') | T.null s' -> pure c 710 | _ -> defaultParseError s 711 | 712 | -- | 713 | -- >>> showVersion <$> parseUrlPiece "1.2.3" 714 | -- Right "1.2.3" 715 | instance FromHttpApiData Version where 716 | parseUrlPiece s = 717 | case reverse (readP_to_S parseVersion (T.unpack s)) of 718 | ((x, ""):_) -> pure x 719 | _ -> defaultParseError s 720 | 721 | -- | Parsing a @'Void'@ value is always an error, considering @'Void'@ as a data type with no constructors. 722 | instance FromHttpApiData Void where 723 | parseUrlPiece _ = Left "Void cannot be parsed!" 724 | 725 | instance FromHttpApiData Natural where 726 | parseUrlPiece s = do 727 | n <- runReader (signed decimal) s 728 | if n < 0 729 | then Left ("underflow: " <> s <> " (should be a non-negative integer)") 730 | else Right (fromInteger n) 731 | 732 | instance FromHttpApiData Bool where parseUrlPiece = parseBoundedUrlPiece 733 | instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece 734 | instance FromHttpApiData Double where parseUrlPiece = runReader rational 735 | instance FromHttpApiData Float where parseUrlPiece = runReader rational 736 | instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal) 737 | instance FromHttpApiData Int8 where parseUrlPiece = parseBounded (signed decimal) 738 | instance FromHttpApiData Int16 where parseUrlPiece = parseBounded (signed decimal) 739 | instance FromHttpApiData Int32 where parseUrlPiece = parseBounded (signed decimal) 740 | instance FromHttpApiData Int64 where parseUrlPiece = parseBounded (signed decimal) 741 | instance FromHttpApiData Integer where parseUrlPiece = runReader (signed decimal) 742 | instance FromHttpApiData Word where parseUrlPiece = parseBounded decimal 743 | instance FromHttpApiData Word8 where parseUrlPiece = parseBounded decimal 744 | instance FromHttpApiData Word16 where parseUrlPiece = parseBounded decimal 745 | instance FromHttpApiData Word32 where parseUrlPiece = parseBounded decimal 746 | instance FromHttpApiData Word64 where parseUrlPiece = parseBounded decimal 747 | instance FromHttpApiData String where parseUrlPiece = Right . T.unpack 748 | instance FromHttpApiData Text where parseUrlPiece = Right 749 | instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict 750 | 751 | -- | Note: this instance is not polykinded 752 | instance F.HasResolution a => FromHttpApiData (F.Fixed (a :: Type)) where 753 | parseUrlPiece = runReader rational 754 | 755 | -- | 756 | -- >>> toGregorian <$> parseUrlPiece "2016-12-01" 757 | -- Right (2016,12,1) 758 | instance FromHttpApiData Day where parseUrlPiece = runFT FT.parseDay 759 | 760 | -- | 761 | -- >>> parseUrlPiece "14:55:01.333" :: Either Text TimeOfDay 762 | -- Right 14:55:01.333 763 | instance FromHttpApiData TimeOfDay where parseUrlPiece = runFT FT.parseTimeOfDay 764 | 765 | -- | 766 | -- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime 767 | -- Right 2015-10-03 14:55:01 768 | instance FromHttpApiData LocalTime where parseUrlPiece = runFT FT.parseLocalTime 769 | 770 | -- | 771 | -- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime 772 | -- Right 2015-10-03 14:55:01 +0000 773 | -- 774 | -- >>> parseQueryParam "2016-12-31T01:00:00Z" :: Either Text ZonedTime 775 | -- Right 2016-12-31 01:00:00 +0000 776 | instance FromHttpApiData ZonedTime where parseUrlPiece = runFT FT.parseZonedTime 777 | 778 | -- | 779 | -- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime 780 | -- Right 2015-10-03 00:14:24 UTC 781 | instance FromHttpApiData UTCTime where parseUrlPiece = runFT FT.parseUTCTime 782 | 783 | -- | 784 | -- >>> parseUrlPiece "Monday" :: Either Text DayOfWeek 785 | -- Right Monday 786 | instance FromHttpApiData DayOfWeek where 787 | parseUrlPiece t = case Map.lookup (T.toLower t) m of 788 | Just dow -> Right dow 789 | Nothing -> Left $ "Incorrect DayOfWeek: " <> T.take 10 t 790 | where 791 | m :: Map.Map Text DayOfWeek 792 | m = Map.fromList [ (toUrlPiece dow, dow) | dow <- [Monday .. Sunday] ] 793 | 794 | 795 | instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secondsToNominalDiffTime . parseUrlPiece 796 | 797 | -- | 798 | -- >>> parseUrlPiece "2021-01" :: Either Text Month 799 | -- Right 2021-01 800 | instance FromHttpApiData Month where parseUrlPiece = runFT FT.parseMonth 801 | 802 | -- | 803 | -- >>> parseUrlPiece "2021-q1" :: Either Text Quarter 804 | -- Right 2021-Q1 805 | instance FromHttpApiData Quarter where parseUrlPiece = runFT FT.parseQuarter 806 | 807 | -- | 808 | -- >>> parseUrlPiece "q2" :: Either Text QuarterOfYear 809 | -- Right Q2 810 | -- 811 | -- >>> parseUrlPiece "Q3" :: Either Text QuarterOfYear 812 | -- Right Q3 813 | instance FromHttpApiData QuarterOfYear where parseUrlPiece = runFT FT.parseQuarterOfYear 814 | 815 | instance FromHttpApiData All where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool) 816 | instance FromHttpApiData Any where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool) 817 | 818 | instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) 819 | instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) 820 | instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) 821 | instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a)) 822 | instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a)) 823 | 824 | instance FromHttpApiData a => FromHttpApiData (Semi.Min a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) 825 | instance FromHttpApiData a => FromHttpApiData (Semi.Max a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) 826 | instance FromHttpApiData a => FromHttpApiData (Semi.First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) 827 | instance FromHttpApiData a => FromHttpApiData (Semi.Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) 828 | 829 | -- | 830 | -- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int) 831 | -- Right (Just 123) 832 | instance FromHttpApiData a => FromHttpApiData (Maybe a) where 833 | parseUrlPiece s 834 | | T.toLower (T.take 7 s) == "nothing" = pure Nothing 835 | | otherwise = Just <$> parseUrlPieceWithPrefix "Just " s 836 | 837 | -- | 838 | -- >>> parseUrlPiece "Right 123" :: Either Text (Either String Int) 839 | -- Right (Right 123) 840 | instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b) where 841 | parseUrlPiece s = 842 | Right <$> parseUrlPieceWithPrefix "Right " s 843 | Left <$> parseUrlPieceWithPrefix "Left " s 844 | where 845 | infixl 3 846 | Left _ y = y 847 | x _ = x 848 | 849 | instance ToHttpApiData UUID.UUID where 850 | toUrlPiece = UUID.toText 851 | toHeader = UUID.toASCIIBytes 852 | toEncodedUrlPiece = unsafeToEncodedUrlPiece 853 | 854 | instance FromHttpApiData UUID.UUID where 855 | parseUrlPiece = maybe (Left "invalid UUID") Right . UUID.fromText 856 | parseHeader = maybe (Left "invalid UUID") Right . UUID.fromASCIIBytes 857 | 858 | 859 | -- | Lenient parameters. 'FromHttpApiData' combinators always return `Right`. 860 | -- 861 | -- @since 0.3.5 862 | newtype LenientData a = LenientData { getLenientData :: Either Text a } 863 | deriving (Eq, Ord, Show, Read, Typeable, Data, Functor, Foldable, Traversable) 864 | 865 | instance FromHttpApiData a => FromHttpApiData (LenientData a) where 866 | parseUrlPiece = Right . LenientData . parseUrlPiece 867 | parseHeader = Right . LenientData . parseHeader 868 | parseQueryParam = Right . LenientData . parseQueryParam 869 | 870 | -- | /Note:/ this instance works correctly for alphanumeric name and value 871 | -- 872 | -- >>> parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie 873 | -- Right (SetCookie {setCookieName = "SESSID", setCookieValue = "r2t5uvjq435r4q7ib3vtdjq120", setCookiePath = Nothing, setCookieExpires = Nothing, setCookieMaxAge = Nothing, setCookieDomain = Nothing, setCookieHttpOnly = False, setCookieSecure = False, setCookieSameSite = Nothing, setCookiePartitioned = False}) 874 | instance FromHttpApiData SetCookie where 875 | parseUrlPiece = parseHeader . encodeUtf8 876 | parseHeader = Right . parseSetCookie 877 | 878 | -- | Note: this instance is not polykinded 879 | instance FromHttpApiData a => FromHttpApiData (Tagged (b :: Type) a) where 880 | parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) 881 | parseHeader = coerce (parseHeader :: ByteString -> Either Text a) 882 | parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a) 883 | 884 | -- | @since 0.4.2 885 | instance FromHttpApiData a => FromHttpApiData (Const a b) where 886 | parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) 887 | parseHeader = coerce (parseHeader :: ByteString -> Either Text a) 888 | parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a) 889 | 890 | -- | @since 0.4.2 891 | instance FromHttpApiData a => FromHttpApiData (Identity a) where 892 | parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) 893 | parseHeader = coerce (parseHeader :: ByteString -> Either Text a) 894 | parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a) 895 | 896 | ------------------------------------------------------------------------------- 897 | -- Helpers 898 | ------------------------------------------------------------------------------- 899 | 900 | runTT :: (a -> Builder) -> a -> Text 901 | runTT f x = L.toStrict (toLazyText (f x)) 902 | 903 | runFT :: (Text -> Either String a) -> Text -> Either Text a 904 | runFT f t = case f t of 905 | Left err -> Left (T.pack err) 906 | Right x -> Right x 907 | --------------------------------------------------------------------------------