diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,80 @@ +0.7 + +* Change Form representation to use Map (from `containers`) instead of `HashMap`. + This prevents possible HashDOS attacks. + +0.6.3 + +* Add To/FromForm instances for () and Void + +0.6.2 + +* Support GHC-9.12 +* Require `cookie-0.5.1` + +0.6.1 + +* Require at least GHC-8.6 +* Support `cookie-0.5.0`, see [#137](https://github.com/fizruk/http-api-data/pull/137). + + Note that `cookie-0.5.0`'s parser now removes double quotes around cookie values. + +0.6 +--- + +* Use [`text-iso8601`](https://hackage.haskell.org/package/text-iso8601) + to parse and serialise `time` types. (Instead of `attoparsec-iso8601`). + Due this change some formats are slightly changed: + + - Space between timezone is not accepted + - Timezone offset can be between -23:59..23:59 + - Timezone offset is output with colon between hours and minutes + +* Require at least GHC-8.2 + +0.5.1 +----- + +* Add `toEncodedQueryParam` to `ToHttpApiData` type class. It has default + implementation using `toQueryParam`, but may be overriden with more efficient + one. + +0.5 +--- + +* Use `attoparsec-iso8601-1.1.0.0`. + `Day` and `UTCTime` parsers require at least 4 digits now, which is a breaking change. +* Drop GHC-7.8 and GHC-7.10 support. + +0.4.3 +----- + +* Add `Quarter`, `QuarterOfYear` and `Month` instances +* Support `bytestring-0.11` + +0.4.2 +----- + +* Add instances for `Const` and `Identity` + +0.4.1.1 +------- + +* Allow cookie <0.5 +* Change to `build-type: Simple` + +0.4.1 +----- + +* Use `time-compat` to provide instances for `DayOfWeek`. + +0.4 +--- + +* `NominalDiffTime` instances preserve precision (roundtrip) +* Add `Semigroup.Min`, `Max`, `First`, `Last` instances +* Add `Tagged b a` instances + 0.3.10 --- @@ -11,7 +88,7 @@ * GHC-8.6 support * Remove dependency on `uri-bytestring` and use functions from `http-types` instead - (see [#75](https://github.com/fizruk/http-api-data/pull/78)) + (see [#75](https://github.com/fizruk/http-api-data/pull/75)) * Add support for `SetCookie` (see [#74](https://github.com/fizruk/http-api-data/pull/74)) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Setup.lhs b/Setup.lhs deleted file mode 100644 --- a/Setup.lhs +++ /dev/null @@ -1,36 +0,0 @@ -\begin{code} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -Wall #-} -module Main (main) where - -#ifndef MIN_VERSION_cabal_doctest -#define MIN_VERSION_cabal_doctest(x,y,z) 0 -#endif - -#if MIN_VERSION_cabal_doctest(1,0,0) - -import Distribution.Extra.Doctest ( defaultMainWithDoctests ) -main :: IO () -main = defaultMainWithDoctests "doctests" - -#else - -#ifdef MIN_VERSION_Cabal --- If the macro is defined, we have new cabal-install, --- but for some reason we don't have cabal-doctest in package-db --- --- Probably we are running cabal sdist, when otherwise using new-build --- workflow -#warning You are configuring this package without cabal-doctest installed. \ - The doctests test-suite will not work as a result. \ - To fix this, install cabal-doctest before configuring. -#endif - -import Distribution.Simple - -main :: IO () -main = defaultMain - -#endif - -\end{code} diff --git a/http-api-data.cabal b/http-api-data.cabal --- a/http-api-data.cabal +++ b/http-api-data.cabal @@ -1,6 +1,6 @@ -cabal-version: >= 1.10 +cabal-version: 1.12 name: http-api-data -version: 0.3.10 +version: 0.7 synopsis: Converting to/from HTTP API data like URL pieces, headers and query parameters. category: Web @@ -15,26 +15,24 @@ maintainer: Nickolay Kudasov homepage: http://github.com/fizruk/http-api-data stability: unstable -build-type: Custom +build-type: Simple extra-source-files: - include/overlapping-compat.h test/*.hs CHANGELOG.md README.md -tested-with: - GHC==7.8.4, - GHC==7.10.3, - GHC==8.0.2, - GHC==8.2.2, - GHC==8.4.3, - GHC==8.6.1 -custom-setup - setup-depends: - base, - Cabal, - cabal-doctest >=1.0.6 && <1.1 +tested-with: + GHC==8.6.5, + GHC==8.8.4, + GHC==8.10.7, + GHC==9.0.2, + GHC==9.2.8, + GHC==9.4.8, + GHC==9.6.7, + GHC==9.8.4, + GHC==9.10.1, + GHC==9.12.2 flag use-text-show description: Use text-show library for efficient ToHttpApiData implementations. @@ -43,32 +41,26 @@ library hs-source-dirs: src/ - include-dirs: include/ -- GHC bundled - build-depends: base >= 4.7 && < 4.13 - , bytestring >= 0.10.4.0 && < 0.11 - , containers >= 0.5.5.1 && < 0.7 - , text >= 1.2.3.0 && < 1.3 - , time >= 1.4.2 && < 1.9 + build-depends: base >= 4.12.0.0 && < 4.22 + , bytestring >= 0.10.8.2 && < 0.13 + , containers >= 0.6.0.1 && < 0.8 + , text >= 1.2.3.0 && < 1.3 || >=2.0 && <2.2 -- other-dependencies build-depends: - attoparsec >= 0.13.2.2 && < 0.14 - , attoparsec-iso8601 >= 1.0.0.0 && < 1.1 - , cookie >= 0.4.3 && < 0.4.5 - , hashable >= 1.2.7.0 && < 1.3 - , http-types >= 0.12.1 && < 0.13 - , time-locale-compat >= 0.1.1.5 && < 0.2 - , unordered-containers >= 0.2.9.0 && < 0.3 - , uuid-types >= 1.0.3 && <1.1 - - if !impl(ghc >= 8.0) - build-depends: semigroups >= 0.18.5 && < 0.19 + cookie >= 0.5.1 && < 0.6 + , hashable >= 1.4.4.0 && < 1.6 + , http-types >= 0.12.4 && < 0.13 + , text-iso8601 >= 0.1.1 && < 0.2 + , tagged >= 0.8.8 && < 0.9 + , time-compat >= 1.9.5 && < 1.10 + , uuid-types >= 1.0.6 && < 1.1 if flag(use-text-show) cpp-options: -DUSE_TEXT_SHOW - build-depends: text-show >= 3.7.4 && <3.8 + build-depends: text-show >= 3.10.5 && <3.12 exposed-modules: Web.HttpApiData @@ -88,35 +80,21 @@ hs-source-dirs: test ghc-options: -Wall default-language: Haskell2010 - build-tool-depends: hspec-discover:hspec-discover >= 2.5.5 && <2.6 + build-tool-depends: hspec-discover:hspec-discover >= 2.7.1 && <2.12 -- inherited depndencies build-depends: base , bytestring - , unordered-containers + , cookie , http-api-data , text - , time - , bytestring + , time-compat + , containers , uuid-types - , cookie - build-depends: HUnit >= 1.6.0.0 && <1.7 - , hspec >= 2.5.5 && <2.6 - , QuickCheck >= 2.11.3 && <2.13 - , quickcheck-instances >= 0.3.19 && <0.4 - -test-suite doctests - ghc-options: -Wall - build-depends: - base, - directory >= 1.0, - doctest >= 0.16.0 && <0.17, - filepath - default-language: Haskell2010 - hs-source-dirs: test - main-is: doctests.hs - type: exitcode-stdio-1.0 + build-depends: hspec >= 2.7.1 && <2.12 + , QuickCheck >= 2.13.1 && <2.16 + , quickcheck-instances >= 0.3.25.2 && <0.4 source-repository head type: git diff --git a/include/overlapping-compat.h b/include/overlapping-compat.h deleted file mode 100644 --- a/include/overlapping-compat.h +++ /dev/null @@ -1,8 +0,0 @@ -#if __GLASGOW_HASKELL__ >= 710 -#define OVERLAPPABLE_ {-# OVERLAPPABLE #-} -#define OVERLAPPING_ {-# OVERLAPPING #-} -#else -{-# LANGUAGE OverlappingInstances #-} -#define OVERLAPPABLE_ -#define OVERLAPPING_ -#endif diff --git a/src/Web/HttpApiData.hs b/src/Web/HttpApiData.hs --- a/src/Web/HttpApiData.hs +++ b/src/Web/HttpApiData.hs @@ -49,10 +49,9 @@ -- -- >>> :set -XOverloadedStrings -- >>> import Control.Applicative --- >>> import Data.Time +-- >>> import Data.Time.Compat -- >>> import Data.Int -- >>> import Data.Text (Text) --- >>> import Data.Time (Day) -- >>> import Data.Version -- $examples diff --git a/src/Web/Internal/FormUrlEncoded.hs b/src/Web/Internal/FormUrlEncoded.hs --- a/src/Web/Internal/FormUrlEncoded.hs +++ b/src/Web/Internal/FormUrlEncoded.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ConstraintKinds #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} @@ -14,64 +13,54 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#include "overlapping-compat.h" module Web.Internal.FormUrlEncoded where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -import Data.Traversable -#endif - - +import Control.Applicative (Const(Const)) import Control.Arrow ((***)) import Control.Monad ((<=<)) import Data.ByteString.Builder (shortByteString, toLazyByteString) import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Lazy.Char8 as BSL8 +import Data.Coerce (coerce) import qualified Data.Foldable as F +import Data.Functor.Identity (Identity(Identity)) import Data.Hashable (Hashable) -import Data.HashMap.Strict (HashMap) -import qualified Data.HashMap.Strict as HashMap -import Data.Int +import qualified Data.Map.Strict as Map +import Data.Int (Int16, Int32, Int64, Int8) import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.List (intersperse, sortBy) -import Data.Map (Map) -import qualified Data.Map as Map -import Data.Monoid +import Data.Monoid (All (..), Any (..), Dual (..), + Product (..), Sum (..)) import Data.Ord (comparing) +import Data.Proxy (Proxy (..)) +import Data.Semigroup (Semigroup (..)) import qualified Data.Semigroup as Semi - +import Data.Tagged (Tagged (..)) import Data.Text (Text) import qualified Data.Text as Text -import Data.Text.Encoding as Text +import qualified Data.Text.Encoding as Text import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as Lazy - -import Data.Proxy -import Data.Time -import Data.Word - -#if MIN_VERSION_base(4,8,0) -import Data.Void -import Numeric.Natural -#endif - +import Data.Time.Compat (Day, LocalTime, NominalDiffTime, + UTCTime, ZonedTime) +import Data.Time.Calendar.Month.Compat (Month) +import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) +import Data.Void (Void, absurd) +import Data.Word (Word16, Word32, Word64, Word8) import GHC.Exts (Constraint, IsList (..)) import GHC.Generics import GHC.TypeLits import Network.HTTP.Types.URI (urlDecode, urlEncodeBuilder) - +import Numeric.Natural (Natural) import Web.Internal.HttpApiData -- $setup --- >>> :set -XDeriveGeneric --- >>> :set -XOverloadedLists --- >>> :set -XOverloadedStrings --- >>> :set -XFlexibleContexts --- >>> :set -XScopedTypeVariables --- >>> :set -XTypeFamilies +-- >>> :set -XDeriveGeneric -XOverloadedLists -XOverloadedStrings -XFlexibleContexts -XScopedTypeVariables -XTypeFamilies +-- >>> import GHC.Generics (Generic) -- >>> import Data.Char (toLower) +-- >>> import Data.Text (Text) +-- >>> import Data.Word (Word8) -- -- >>> data Person = Person { name :: String, age :: Int } deriving (Show, Generic) -- >>> instance ToForm Person @@ -116,6 +105,9 @@ instance ToFormKey ZonedTime where toFormKey = toQueryParam instance ToFormKey UTCTime where toFormKey = toQueryParam instance ToFormKey NominalDiffTime where toFormKey = toQueryParam +instance ToFormKey Quarter where toFormKey = toQueryParam +instance ToFormKey QuarterOfYear where toFormKey = toQueryParam +instance ToFormKey Month where toFormKey = toQueryParam instance ToFormKey String where toFormKey = toQueryParam instance ToFormKey Text where toFormKey = toQueryParam @@ -124,14 +116,26 @@ instance ToFormKey All where toFormKey = toQueryParam instance ToFormKey Any where toFormKey = toQueryParam -instance ToFormKey a => ToFormKey (Dual a) where toFormKey = toFormKey . getDual -instance ToFormKey a => ToFormKey (Sum a) where toFormKey = toFormKey . getSum -instance ToFormKey a => ToFormKey (Product a) where toFormKey = toFormKey . getProduct +instance ToFormKey a => ToFormKey (Dual a) where toFormKey = coerce (toFormKey :: a -> Text) +instance ToFormKey a => ToFormKey (Sum a) where toFormKey = coerce (toFormKey :: a -> Text) +instance ToFormKey a => ToFormKey (Product a) where toFormKey = coerce (toFormKey :: a -> Text) -#if MIN_VERSION_base(4,8,0) +instance ToFormKey a => ToFormKey (Semi.Min a) where toFormKey = coerce (toFormKey :: a -> Text) +instance ToFormKey a => ToFormKey (Semi.Max a) where toFormKey = coerce (toFormKey :: a -> Text) +instance ToFormKey a => ToFormKey (Semi.First a) where toFormKey = coerce (toFormKey :: a -> Text) +instance ToFormKey a => ToFormKey (Semi.Last a) where toFormKey = coerce (toFormKey :: a -> Text) + +instance ToFormKey a => ToFormKey (Tagged b a) where toFormKey = coerce (toFormKey :: a -> Text) + +-- | @since 0.4.2 +instance ToFormKey a => ToFormKey (Identity a) where toFormKey = coerce (toFormKey :: a -> Text) + +-- | @since 0.4.2 +instance ToFormKey a => ToFormKey (Const a b) where + toFormKey = coerce (toFormKey :: a -> Text) + instance ToFormKey Void where toFormKey = toQueryParam instance ToFormKey Natural where toFormKey = toQueryParam -#endif -- | Typeclass for types that can be parsed from keys of a 'Form'. This is the reverse of 'ToFormKey'. class FromFormKey k where @@ -163,6 +167,9 @@ instance FromFormKey ZonedTime where parseFormKey = parseQueryParam instance FromFormKey UTCTime where parseFormKey = parseQueryParam instance FromFormKey NominalDiffTime where parseFormKey = parseQueryParam +instance FromFormKey Quarter where parseFormKey = parseQueryParam +instance FromFormKey QuarterOfYear where parseFormKey = parseQueryParam +instance FromFormKey Month where parseFormKey = parseQueryParam instance FromFormKey String where parseFormKey = parseQueryParam instance FromFormKey Text where parseFormKey = parseQueryParam @@ -171,20 +178,32 @@ instance FromFormKey All where parseFormKey = parseQueryParam instance FromFormKey Any where parseFormKey = parseQueryParam -instance FromFormKey a => FromFormKey (Dual a) where parseFormKey = fmap Dual . parseFormKey -instance FromFormKey a => FromFormKey (Sum a) where parseFormKey = fmap Sum . parseFormKey -instance FromFormKey a => FromFormKey (Product a) where parseFormKey = fmap Product . parseFormKey +instance FromFormKey a => FromFormKey (Dual a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) +instance FromFormKey a => FromFormKey (Sum a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) +instance FromFormKey a => FromFormKey (Product a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) -#if MIN_VERSION_base(4,8,0) +instance FromFormKey a => FromFormKey (Semi.Min a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) +instance FromFormKey a => FromFormKey (Semi.Max a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) +instance FromFormKey a => FromFormKey (Semi.First a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) +instance FromFormKey a => FromFormKey (Semi.Last a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) + +instance FromFormKey a => FromFormKey (Tagged b a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) + +-- | @since 0.4.2 +instance FromFormKey a => FromFormKey (Identity a) where parseFormKey = coerce (parseFormKey :: Text -> Either Text a) + +-- | @since 0.4.2 +instance FromFormKey a => FromFormKey (Const a b) where + parseFormKey = coerce (parseFormKey :: Text -> Either Text a) + instance FromFormKey Void where parseFormKey = parseQueryParam instance FromFormKey Natural where parseFormKey = parseQueryParam -#endif -- | The contents of a form, not yet URL-encoded. -- -- 'Form' can be URL-encoded with 'urlEncodeForm' and URL-decoded with 'urlDecodeForm'. -newtype Form = Form { unForm :: HashMap Text [Text] } - deriving (Eq, Read, Generic, Semi.Semigroup, Monoid) +newtype Form = Form { unForm :: Map.Map Text [Text] } + deriving (Eq, Read, Generic, Semigroup, Monoid) instance Show Form where showsPrec d form = showParen (d > 10) $ @@ -194,8 +213,8 @@ -- For a stable conversion use 'toListStable'. instance IsList Form where type Item Form = (Text, Text) - fromList = Form . HashMap.fromListWith (flip (<>)) . fmap (\(k, v) -> (k, [v])) - toList = concatMap (\(k, vs) -> map ((,) k) vs) . HashMap.toList . unForm + fromList = Form . Map.fromListWith (flip (<>)) . fmap (\(k, v) -> (k, [v])) + toList = concatMap (\(k, vs) -> map ((,) k) vs) . Map.toList . unForm -- | A stable version of 'toList'. toListStable :: Form -> [(Text, Text)] @@ -245,15 +264,22 @@ instance ToForm Form where toForm = id +-- | +-- +-- @since 0.6.3 +instance ToForm Void where toForm = absurd + +-- | +-- +-- @since 0.6.3 +instance ToForm () where toForm _ = Form Map.empty + instance (ToFormKey k, ToHttpApiData v) => ToForm [(k, v)] where toForm = fromList . map (toFormKey *** toQueryParam) -instance (ToFormKey k, ToHttpApiData v) => ToForm (Map k [v]) where +instance (ToFormKey k, ToHttpApiData v) => ToForm (Map.Map k [v]) where toForm = fromEntriesByKey . Map.toList -instance (ToFormKey k, ToHttpApiData v) => ToForm (HashMap k [v]) where - toForm = fromEntriesByKey . HashMap.toList - instance ToHttpApiData v => ToForm (IntMap [v]) where toForm = fromEntriesByKey . IntMap.toList @@ -262,21 +288,16 @@ -- >>> fromEntriesByKey [("name",["Nick"]),("color",["red","blue"])] -- fromList [("color","red"),("color","blue"),("name","Nick")] fromEntriesByKey :: (ToFormKey k, ToHttpApiData v) => [(k, [v])] -> Form -fromEntriesByKey = Form . HashMap.fromListWith (<>) . map (toFormKey *** map toQueryParam) +fromEntriesByKey = Form . Map.fromListWith (<>) . map (toFormKey *** map toQueryParam) data Proxy3 a b c = Proxy3 type family NotSupported (cls :: k1) (a :: k2) (reason :: Symbol) :: Constraint where -#if __GLASGOW_HASKELL__ < 800 - -- this is just a placeholder case for older GHCs to not freak out on an empty closed type family - NotSupported cls a "this type family is actually empty" = () -#else NotSupported cls a reason = TypeError ( 'Text "Cannot derive a Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instance for " ':<>: 'ShowType a ':<>: 'Text "." ':$$: 'ShowType a ':<>: 'Text " " ':<>: 'Text reason ':<>: 'Text "," ':$$: 'Text "but Generic-based " ':<>: 'ShowType cls ':<>: 'Text " instances can be derived only for records" ':$$: 'Text "(i.e. product types with named fields)." ) -#endif -- | A 'Generic'-based implementation of 'toForm'. -- This is used as a default implementation in 'ToForm'. @@ -328,7 +349,7 @@ instance (GToForm t f) => GToForm t (M1 C x f) where gToForm p opts (M1 a) = gToForm p opts a -instance OVERLAPPABLE_ (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i c)) where +instance {-# OVERLAPPABLE #-} (Selector s, ToHttpApiData c) => GToForm t (M1 S s (K1 i c)) where gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)] where key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) @@ -346,7 +367,7 @@ where key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) -instance OVERLAPPING_ (Selector s) => GToForm t (M1 S s (K1 i String)) where +instance {-# OVERLAPPING #-} (Selector s) => GToForm t (M1 S s (K1 i String)) where gToForm _ opts (M1 (K1 c)) = fromList [(key, toQueryParam c)] where key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) @@ -396,16 +417,23 @@ instance FromForm Form where fromForm = pure +-- | +-- +-- @since 0.6.3 +instance FromForm Void where fromForm _ = Left "fromForm: Void" + +-- | +-- +-- @since 0.6.3 +instance FromForm () where fromForm _ = Right () + -- | _NOTE:_ this conversion is unstable and may result in different key order (but not values). instance (FromFormKey k, FromHttpApiData v) => FromForm [(k, v)] where fromForm = fmap (concatMap (\(k, vs) -> map ((,) k) vs)) . toEntriesByKey -instance (Ord k, FromFormKey k, FromHttpApiData v) => FromForm (Map k [v]) where +instance (Ord k, Eq k, Hashable k, FromFormKey k, FromHttpApiData v) => FromForm (Map.Map k [v]) where fromForm = fmap (Map.fromListWith (<>)) . toEntriesByKey -instance (Eq k, Hashable k, FromFormKey k, FromHttpApiData v) => FromForm (HashMap k [v]) where - fromForm = fmap (HashMap.fromListWith (<>)) . toEntriesByKey - instance FromHttpApiData v => FromForm (IntMap [v]) where fromForm = fmap (IntMap.fromListWith (<>)) . toEntriesByKey @@ -414,7 +442,7 @@ -- _NOTE:_ this conversion is unstable and may result in different key order -- (but not values). For a stable encoding see 'toEntriesByKeyStable'. toEntriesByKey :: (FromFormKey k, FromHttpApiData v) => Form -> Either Text [(k, [v])] -toEntriesByKey = traverse parseGroup . HashMap.toList . unForm +toEntriesByKey = traverse parseGroup . Map.toList . unForm where parseGroup (k, vs) = (,) <$> parseFormKey k <*> traverse parseQueryParam vs @@ -476,7 +504,7 @@ instance GFromForm t f => GFromForm t (M1 C x f) where gFromForm p opts f = M1 <$> gFromForm p opts f -instance OVERLAPPABLE_ (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i c)) where +instance {-# OVERLAPPABLE #-} (Selector s, FromHttpApiData c) => GFromForm t (M1 S s (K1 i c)) where gFromForm _ opts form = M1 . K1 <$> parseUnique key form where key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) @@ -491,7 +519,7 @@ where key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) -instance OVERLAPPING_ (Selector s) => GFromForm t (M1 S s (K1 i String)) where +instance {-# OVERLAPPING #-} (Selector s) => GFromForm t (M1 S s (K1 i String)) where gFromForm _ opts form = M1 . K1 <$> parseUnique key form where key = Text.pack $ fieldLabelModifier opts $ selName (Proxy3 :: Proxy3 s g p) @@ -641,7 +669,7 @@ -- >>> lookupAll "name" [("name", "Oleg"), ("name", "David")] -- ["Oleg","David"] lookupAll :: Text -> Form -> [Text] -lookupAll key = F.concat . HashMap.lookup key . unForm +lookupAll key = F.concat . Map.lookup key . unForm -- | Lookup an optional value for a key. -- Fail if there is more than one value. diff --git a/src/Web/Internal/HttpApiData.hs b/src/Web/Internal/HttpApiData.hs --- a/src/Web/Internal/HttpApiData.hs +++ b/src/Web/Internal/HttpApiData.hs @@ -5,7 +5,9 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeSynonymInstances #-} -- | @@ -13,65 +15,70 @@ -- such as URL pieces, headers and query parameters. module Web.Internal.HttpApiData where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -import Data.Foldable (Foldable) -import Data.Traversable (Traversable (traverse)) -#endif - +import Control.Applicative (Const(Const)) import Control.Arrow (left, (&&&)) import Control.Monad ((<=<)) - import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Builder as BS import qualified Data.ByteString.Lazy as LBS -import Data.Monoid - +import Data.Coerce (coerce) +import Data.Data (Data) import qualified Data.Fixed as F -import Data.Int -import Data.Word - +import Data.Functor.Identity (Identity(Identity)) +import Data.Int (Int16, Int32, Int64, Int8) +import Data.Kind (Type) +import qualified Data.Map.Strict as Map +import Data.Monoid (All (..), Any (..), Dual (..), + First (..), Last (..), + Product (..), Sum (..)) +import qualified Data.Semigroup as Semi +import Data.Tagged (Tagged (..)) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With, decodeUtf8', encodeUtf8) +import Data.Text.Encoding (decodeUtf8', decodeUtf8With, + encodeUtf8) import Data.Text.Encoding.Error (lenientDecode) import qualified Data.Text.Lazy as L +import Data.Text.Lazy.Builder (Builder, toLazyText) import Data.Text.Read (Reader, decimal, rational, signed) - -import Data.Time -#if __GLASGOW_HASKELL__ < 710 -import Data.Time.Locale.Compat -#endif -import Data.Version - -#if MIN_VERSION_base(4,8,0) -import Data.Void -import Numeric.Natural -#endif - +import qualified Data.Time.ToText as TT +import qualified Data.Time.FromText as FT +import Data.Time.Compat (Day, LocalTime, + NominalDiffTime, TimeOfDay, + UTCTime, ZonedTime, DayOfWeek (..), + nominalDiffTimeToSeconds, + secondsToNominalDiffTime) +import Data.Time.Calendar.Month.Compat (Month) +import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) +import Data.Typeable (Typeable) +import qualified Data.UUID.Types as UUID +import Data.Version (Version, parseVersion, + showVersion) +import Data.Void (Void, absurd) +import Data.Word (Word16, Word32, Word64, Word8) +import qualified Network.HTTP.Types as H +import Numeric.Natural (Natural) import Text.ParserCombinators.ReadP (readP_to_S) import Text.Read (readMaybe) +import Web.Cookie (SetCookie, parseSetCookie, + renderSetCookie) #if USE_TEXT_SHOW import TextShow (TextShow, showt) #endif -import qualified Data.UUID.Types as UUID - -import qualified Data.ByteString.Builder as BS -import Data.Data (Data) -import Data.Typeable (Typeable) -import qualified Network.HTTP.Types as H - -import qualified Data.Attoparsec.Text as Atto -import qualified Data.Attoparsec.Time as Atto - -import Web.Cookie (SetCookie, parseSetCookie, - renderSetCookie) - - -- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.Text (Text) +-- >>> import Data.Word (Word8) +-- >>> import Data.Text.Read (decimal) +-- >>> import Data.Time.Compat +-- >>> import Data.Time.Calendar.Month.Compat +-- >>> import Data.Time.Calendar.Quarter.Compat +-- >>> import Data.Version +-- >>> import Web.Cookie (SetCookie) -- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show) -- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p @@ -86,10 +93,10 @@ toUrlPiece = toQueryParam -- | Convert to a URL path piece, making sure to encode any special chars. - -- The default definition uses 'H.encodePathSegmentsRelative', + -- The default definition uses @'H.urlEncodeBuilder' 'False'@ -- but this may be overriden with a more efficient version. toEncodedUrlPiece :: a -> BS.Builder - toEncodedUrlPiece = H.encodePathSegmentsRelative . (:[]) . toUrlPiece + toEncodedUrlPiece = H.urlEncodeBuilder False . encodeUtf8 . toUrlPiece -- | Convert to HTTP header value. toHeader :: a -> ByteString @@ -99,6 +106,14 @@ toQueryParam :: a -> Text toQueryParam = toUrlPiece + -- | Convert to URL query param, + -- The default definition uses @'H.urlEncodeBuilder' 'True'@ + -- but this may be overriden with a more efficient version. + -- + -- @since 0.5.1 + toEncodedQueryParam :: a -> BS.Builder + toEncodedQueryParam = H.urlEncodeBuilder True . encodeUtf8 . toQueryParam + -- | Parse value from HTTP API data. -- -- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated @@ -331,7 +346,7 @@ -- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool -- Right True -- --- For case sensitive parser see 'parseBoundedEnumOfI'. +-- For case insensitive parser see 'parseBoundedEnumOfI'. parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf @@ -415,12 +430,21 @@ unsafeToEncodedUrlPiece :: ToHttpApiData a => a -> BS.Builder unsafeToEncodedUrlPiece = BS.byteString . encodeUtf8 . toUrlPiece +-- | Convert to a URL-encoded query param using 'toQueryParam'. +-- /Note/: this function does not check if the result contains unescaped characters! +-- +-- @since 0.5.1 +unsafeToEncodedQueryParam :: ToHttpApiData a => a -> BS.Builder +unsafeToEncodedQueryParam = BS.byteString . encodeUtf8 . toQueryParam + -- | -- >>> toUrlPiece () -- "_" instance ToHttpApiData () where - toUrlPiece () = "_" - toEncodedUrlPiece = unsafeToEncodedUrlPiece + toUrlPiece _ = "_" + toHeader _ = "_" + toEncodedUrlPiece _ = "_" + toEncodedQueryParam _ = "_" instance ToHttpApiData Char where toUrlPiece = T.singleton @@ -431,100 +455,192 @@ instance ToHttpApiData Version where toUrlPiece = T.pack . showVersion toEncodedUrlPiece = unsafeToEncodedUrlPiece + toEncodedQueryParam = unsafeToEncodedQueryParam -#if MIN_VERSION_base(4,8,0) instance ToHttpApiData Void where toUrlPiece = absurd -instance ToHttpApiData Natural where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -#endif +instance ToHttpApiData Natural where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam -instance ToHttpApiData Bool where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Bool where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam -instance ToHttpApiData Double where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Float where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Int where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Int8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Int16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Int32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Int64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Integer where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Word where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Word8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece -instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece +instance ToHttpApiData Double where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Float where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Int where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Int8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Int16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Int32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Int64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Integer where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Word where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Word8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam +instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam -instance F.HasResolution a => ToHttpApiData (F.Fixed a) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece +-- | Note: this instance is not polykinded +instance F.HasResolution a => ToHttpApiData (F.Fixed (a :: Type)) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece; toEncodedQueryParam = unsafeToEncodedQueryParam -- | -- >>> toUrlPiece (fromGregorian 2015 10 03) -- "2015-10-03" instance ToHttpApiData Day where - toUrlPiece = T.pack . show + toUrlPiece = runTT TT.buildDay toEncodedUrlPiece = unsafeToEncodedUrlPiece - -timeToUrlPiece :: FormatTime t => String -> t -> Text -timeToUrlPiece fmt = T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just fmt)) + toEncodedQueryParam = unsafeToEncodedQueryParam -- | -- >>> toUrlPiece $ TimeOfDay 14 55 23.1 --- "14:55:23.1" +-- "14:55:23.100" instance ToHttpApiData TimeOfDay where - toUrlPiece = T.pack . formatTime defaultTimeLocale "%H:%M:%S%Q" + toUrlPiece = runTT TT.buildTimeOfDay toEncodedUrlPiece = unsafeToEncodedUrlPiece + -- no toEncodedQueryParam as : is unsafe char. -- | -- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 21.687) -- "2015-10-03T14:55:21.687" instance ToHttpApiData LocalTime where - toUrlPiece = timeToUrlPiece "%H:%M:%S%Q" + toUrlPiece = runTT TT.buildLocalTime toEncodedUrlPiece = unsafeToEncodedUrlPiece + -- no toEncodedQueryParam as : is unsafe char. -- | -- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 51.001)) utc --- "2015-10-03T14:55:51.001+0000" +-- "2015-10-03T14:55:51.001Z" +-- +-- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 51.001)) (TimeZone 120 True "EET") +-- "2015-10-03T14:55:51.001+02:00" +-- instance ToHttpApiData ZonedTime where - toUrlPiece = timeToUrlPiece "%H:%M:%S%Q%z" + toUrlPiece = runTT TT.buildZonedTime toEncodedUrlPiece = unsafeToEncodedUrlPiece + -- no toEncodedQueryParam as : is unsafe char. -- | -- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864.5 --- "2015-10-03T00:14:24.5Z" +-- "2015-10-03T00:14:24.500Z" instance ToHttpApiData UTCTime where - toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ" + toUrlPiece = runTT TT.buildUTCTime toEncodedUrlPiece = unsafeToEncodedUrlPiece + -- no toEncodedQueryParam as : is unsafe char. +-- | +-- >>> toUrlPiece Monday +-- "monday" +instance ToHttpApiData DayOfWeek where + toUrlPiece Monday = "monday" + toUrlPiece Tuesday = "tuesday" + toUrlPiece Wednesday = "wednesday" + toUrlPiece Thursday = "thursday" + toUrlPiece Friday = "friday" + toUrlPiece Saturday = "saturday" + toUrlPiece Sunday = "sunday" + + toEncodedUrlPiece = unsafeToEncodedUrlPiece + toEncodedQueryParam = unsafeToEncodedQueryParam + +-- | +-- >>> toUrlPiece Q4 +-- "q4" +instance ToHttpApiData QuarterOfYear where + toUrlPiece = runTT TT.buildQuarterOfYear + + toEncodedUrlPiece = unsafeToEncodedUrlPiece + toEncodedQueryParam = unsafeToEncodedQueryParam + +-- | +-- >>> import Data.Time.Calendar.Quarter.Compat (Quarter (..)) +-- >>> MkQuarter 8040 +-- 2010-Q1 +-- +-- >>> toUrlPiece $ MkQuarter 8040 +-- "2010-q1" +-- +instance ToHttpApiData Quarter where + toUrlPiece = runTT TT.buildQuarter + + toEncodedUrlPiece = unsafeToEncodedUrlPiece + toEncodedQueryParam = unsafeToEncodedQueryParam + +-- | +-- >>> import Data.Time.Calendar.Month.Compat (Month (..)) +-- >>> MkMonth 24482 +-- 2040-03 +-- +-- >>> toUrlPiece $ MkMonth 24482 +-- "2040-03" +-- +instance ToHttpApiData Month where + toUrlPiece = runTT TT.buildMonth + + toEncodedUrlPiece = unsafeToEncodedUrlPiece + toEncodedQueryParam = unsafeToEncodedQueryParam + instance ToHttpApiData NominalDiffTime where - toUrlPiece = toUrlPiece . (floor :: NominalDiffTime -> Integer) + toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds + + toEncodedQueryParam = unsafeToEncodedQueryParam toEncodedUrlPiece = unsafeToEncodedUrlPiece instance ToHttpApiData String where toUrlPiece = T.pack instance ToHttpApiData Text where toUrlPiece = id instance ToHttpApiData L.Text where toUrlPiece = L.toStrict -instance ToHttpApiData All where toUrlPiece = toUrlPiece . getAll; toEncodedUrlPiece = toEncodedUrlPiece . getAll -instance ToHttpApiData Any where toUrlPiece = toUrlPiece . getAny; toEncodedUrlPiece = toEncodedUrlPiece . getAny +instance ToHttpApiData All where + toUrlPiece = coerce (toUrlPiece :: Bool -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: Bool -> BS.Builder) +instance ToHttpApiData Any where + toUrlPiece = coerce (toUrlPiece :: Bool -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: Bool -> BS.Builder) + instance ToHttpApiData a => ToHttpApiData (Dual a) where - toUrlPiece = toUrlPiece . getDual - toEncodedUrlPiece = toEncodedUrlPiece . getDual + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Sum a) where - toUrlPiece = toUrlPiece . getSum - toEncodedUrlPiece = toEncodedUrlPiece . getSum + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Product a) where - toUrlPiece = toUrlPiece . getProduct - toEncodedUrlPiece = toEncodedUrlPiece . getProduct + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (First a) where - toUrlPiece = toUrlPiece . getFirst - toEncodedUrlPiece = toEncodedUrlPiece . getFirst + toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: Maybe a -> BS.Builder) instance ToHttpApiData a => ToHttpApiData (Last a) where - toUrlPiece = toUrlPiece . getLast - toEncodedUrlPiece = toEncodedUrlPiece . getLast + toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: Maybe a -> BS.Builder) +instance ToHttpApiData a => ToHttpApiData (Semi.Min a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +instance ToHttpApiData a => ToHttpApiData (Semi.Max a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +instance ToHttpApiData a => ToHttpApiData (Semi.First a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +instance ToHttpApiData a => ToHttpApiData (Semi.Last a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + -- | -- >>> toUrlPiece (Just "Hello") -- "just Hello" @@ -555,6 +671,30 @@ toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie -- toEncodedUrlPiece = renderSetCookie -- doesn't do things. +-- | Note: this instance is not polykinded +instance ToHttpApiData a => ToHttpApiData (Tagged (b :: Type) a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toHeader = coerce (toHeader :: a -> ByteString) + toQueryParam = coerce (toQueryParam :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +-- | @since 0.4.2 +instance ToHttpApiData a => ToHttpApiData (Const a b) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toHeader = coerce (toHeader :: a -> ByteString) + toQueryParam = coerce (toQueryParam :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + +-- | @since 0.4.2 +instance ToHttpApiData a => ToHttpApiData (Identity a) where + toUrlPiece = coerce (toUrlPiece :: a -> Text) + toHeader = coerce (toHeader :: a -> ByteString) + toQueryParam = coerce (toQueryParam :: a -> Text) + toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder) + toEncodedQueryParam = coerce (toEncodedQueryParam :: a -> BS.Builder) + -- | -- >>> parseUrlPiece "_" :: Either Text () -- Right () @@ -566,7 +706,7 @@ parseUrlPiece s = case T.uncons s of Just (c, s') | T.null s' -> pure c - _ -> defaultParseError s + _ -> defaultParseError s -- | -- >>> showVersion <$> parseUrlPiece "1.2.3" @@ -577,7 +717,6 @@ ((x, ""):_) -> pure x _ -> defaultParseError s -#if MIN_VERSION_base(4,8,0) -- | Parsing a @'Void'@ value is always an error, considering @'Void'@ as a data type with no constructors. instance FromHttpApiData Void where parseUrlPiece _ = Left "Void cannot be parsed!" @@ -588,7 +727,6 @@ if n < 0 then Left ("underflow: " <> s <> " (should be a non-negative integer)") else Right (fromInteger n) -#endif instance FromHttpApiData Bool where parseUrlPiece = parseBoundedUrlPiece instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece @@ -609,23 +747,24 @@ instance FromHttpApiData Text where parseUrlPiece = Right instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict -instance F.HasResolution a => FromHttpApiData (F.Fixed a) where +-- | Note: this instance is not polykinded +instance F.HasResolution a => FromHttpApiData (F.Fixed (a :: Type)) where parseUrlPiece = runReader rational -- | -- >>> toGregorian <$> parseUrlPiece "2016-12-01" -- Right (2016,12,1) -instance FromHttpApiData Day where parseUrlPiece = runAtto Atto.day +instance FromHttpApiData Day where parseUrlPiece = runFT FT.parseDay -- | -- >>> parseUrlPiece "14:55:01.333" :: Either Text TimeOfDay -- Right 14:55:01.333 -instance FromHttpApiData TimeOfDay where parseUrlPiece = runAtto Atto.timeOfDay +instance FromHttpApiData TimeOfDay where parseUrlPiece = runFT FT.parseTimeOfDay -- | -- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime -- Right 2015-10-03 14:55:01 -instance FromHttpApiData LocalTime where parseUrlPiece = runAtto Atto.localTime +instance FromHttpApiData LocalTime where parseUrlPiece = runFT FT.parseLocalTime -- | -- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime @@ -633,25 +772,60 @@ -- -- >>> parseQueryParam "2016-12-31T01:00:00Z" :: Either Text ZonedTime -- Right 2016-12-31 01:00:00 +0000 -instance FromHttpApiData ZonedTime where parseUrlPiece = runAtto Atto.zonedTime +instance FromHttpApiData ZonedTime where parseUrlPiece = runFT FT.parseZonedTime -- | -- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime -- Right 2015-10-03 00:14:24 UTC -instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime +instance FromHttpApiData UTCTime where parseUrlPiece = runFT FT.parseUTCTime -instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap fromInteger . parseUrlPiece +-- | +-- >>> parseUrlPiece "Monday" :: Either Text DayOfWeek +-- Right Monday +instance FromHttpApiData DayOfWeek where + parseUrlPiece t = case Map.lookup (T.toLower t) m of + Just dow -> Right dow + Nothing -> Left $ "Incorrect DayOfWeek: " <> T.take 10 t + where + m :: Map.Map Text DayOfWeek + m = Map.fromList [ (toUrlPiece dow, dow) | dow <- [Monday .. Sunday] ] -instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece -instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece -instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = fmap Dual . parseUrlPiece -instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = fmap Sum . parseUrlPiece -instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = fmap Product . parseUrlPiece -instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = fmap First . parseUrlPiece -instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = fmap Last . parseUrlPiece +instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secondsToNominalDiffTime . parseUrlPiece -- | +-- >>> parseUrlPiece "2021-01" :: Either Text Month +-- Right 2021-01 +instance FromHttpApiData Month where parseUrlPiece = runFT FT.parseMonth + +-- | +-- >>> parseUrlPiece "2021-q1" :: Either Text Quarter +-- Right 2021-Q1 +instance FromHttpApiData Quarter where parseUrlPiece = runFT FT.parseQuarter + +-- | +-- >>> parseUrlPiece "q2" :: Either Text QuarterOfYear +-- Right Q2 +-- +-- >>> parseUrlPiece "Q3" :: Either Text QuarterOfYear +-- Right Q3 +instance FromHttpApiData QuarterOfYear where parseUrlPiece = runFT FT.parseQuarterOfYear + +instance FromHttpApiData All where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool) +instance FromHttpApiData Any where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool) + +instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) +instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) +instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) +instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a)) +instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a)) + +instance FromHttpApiData a => FromHttpApiData (Semi.Min a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) +instance FromHttpApiData a => FromHttpApiData (Semi.Max a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) +instance FromHttpApiData a => FromHttpApiData (Semi.First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) +instance FromHttpApiData a => FromHttpApiData (Semi.Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) + +-- | -- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int) -- Right (Just 123) instance FromHttpApiData a => FromHttpApiData (Maybe a) where @@ -695,16 +869,37 @@ -- | /Note:/ this instance works correctly for alphanumeric name and value -- -- >>> parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie --- Right (SetCookie {setCookieName = "SESSID", setCookieValue = "r2t5uvjq435r4q7ib3vtdjq120", setCookiePath = Nothing, setCookieExpires = Nothing, setCookieMaxAge = Nothing, setCookieDomain = Nothing, setCookieHttpOnly = False, setCookieSecure = False, setCookieSameSite = Nothing}) +-- Right (SetCookie {setCookieName = "SESSID", setCookieValue = "r2t5uvjq435r4q7ib3vtdjq120", setCookiePath = Nothing, setCookieExpires = Nothing, setCookieMaxAge = Nothing, setCookieDomain = Nothing, setCookieHttpOnly = False, setCookieSecure = False, setCookieSameSite = Nothing, setCookiePartitioned = False}) instance FromHttpApiData SetCookie where parseUrlPiece = parseHeader . encodeUtf8 parseHeader = Right . parseSetCookie +-- | Note: this instance is not polykinded +instance FromHttpApiData a => FromHttpApiData (Tagged (b :: Type) a) where + parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) + parseHeader = coerce (parseHeader :: ByteString -> Either Text a) + parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a) + +-- | @since 0.4.2 +instance FromHttpApiData a => FromHttpApiData (Const a b) where + parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) + parseHeader = coerce (parseHeader :: ByteString -> Either Text a) + parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a) + +-- | @since 0.4.2 +instance FromHttpApiData a => FromHttpApiData (Identity a) where + parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a) + parseHeader = coerce (parseHeader :: ByteString -> Either Text a) + parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a) + ------------------------------------------------------------------------------- --- Attoparsec helpers +-- Helpers ------------------------------------------------------------------------------- -runAtto :: Atto.Parser a -> Text -> Either Text a -runAtto p t = case Atto.parseOnly (p <* Atto.endOfInput) t of +runTT :: (a -> Builder) -> a -> Text +runTT f x = L.toStrict (toLazyText (f x)) + +runFT :: (Text -> Either String a) -> Text -> Either Text a +runFT f t = case f t of Left err -> Left (T.pack err) Right x -> Right x diff --git a/test/Web/Internal/FormUrlEncodedSpec.hs b/test/Web/Internal/FormUrlEncodedSpec.hs --- a/test/Web/Internal/FormUrlEncodedSpec.hs +++ b/test/Web/Internal/FormUrlEncodedSpec.hs @@ -1,16 +1,10 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Web.Internal.FormUrlEncodedSpec (spec) where -#if __GLASGOW_HASKELL__ < 710 -import Control.Applicative -import Data.Monoid -#endif - import Control.Monad ((<=<)) import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map.Strict as Map import Data.Text (Text, unpack) import Test.Hspec import Test.QuickCheck @@ -33,24 +27,24 @@ it "contains the record names" $ property $ \(x :: SimpleRec) -> do let f = unForm $ toForm x - HashMap.member "rec1" f `shouldBe` True - HashMap.member "rec2" f `shouldBe` True + Map.member "rec1" f `shouldBe` True + Map.member "rec2" f `shouldBe` True it "contains the correct record values" $ property $ \(x :: SimpleRec) -> do let f = unForm $ toForm x - HashMap.lookup "rec1" f `shouldBe` Just [rec1 x] - (parseQueryParams <$> HashMap.lookup "rec2" f) `shouldBe` Just (Right [rec2 x]) + Map.lookup "rec1" f `shouldBe` Just [rec1 x] + (parseQueryParams <$> Map.lookup "rec2" f) `shouldBe` Just (Right [rec2 x]) context "FromForm" $ do it "is the right inverse of ToForm" $ property $ \x (y :: Int) -> do let f1 = fromList [("rec1", x), ("rec2", toQueryParam y)] - Right r1 = fromForm f1 :: Either Text SimpleRec - toForm r1 `shouldBe` f1 + r1 = fromForm f1 :: Either Text SimpleRec + fmap toForm r1 `shouldBe` Right f1 it "returns the underlying error" $ do let f = fromList [("rec1", "anything"), ("rec2", "bad")] - Left e = fromForm f :: Either Text SimpleRec + e = either id (const "no error") (fromForm f :: Either Text SimpleRec) unpack e `shouldContain` "input does not start with a digit" urlEncoding :: Spec diff --git a/test/Web/Internal/HttpApiDataSpec.hs b/test/Web/Internal/HttpApiDataSpec.hs --- a/test/Web/Internal/HttpApiDataSpec.hs +++ b/test/Web/Internal/HttpApiDataSpec.hs @@ -1,36 +1,36 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE ScopedTypeVariables #-} module Web.Internal.HttpApiDataSpec (spec) where -import Control.Applicative -import qualified Data.Fixed as F -import Data.Int -import Data.Char -import Data.Word -import Data.Time -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import qualified Data.Text.Lazy as L -import qualified Data.ByteString as BS -import Data.ByteString.Builder (toLazyByteString) -import Data.Version -import qualified Data.UUID.Types as UUID -import Web.Cookie (SetCookie, defaultSetCookie, setCookieName, setCookieValue) -import Data.Proxy +import qualified Data.ByteString as BS +import Data.ByteString.Builder (toLazyByteString) +import Data.Char +import qualified Data.Fixed as F +import Data.Int +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy as L +import Data.Time.Compat +import Data.Time.Calendar.Month.Compat (Month) +import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) +import qualified Data.UUID.Types as UUID +import Data.Version +import Data.Word +import Web.Cookie (SetCookie, defaultSetCookie, + setCookieName, setCookieValue) -#if MIN_VERSION_base(4,8,0) -import Numeric.Natural -#endif +import Data.Proxy -import Test.Hspec -import Test.Hspec.QuickCheck(prop) -import Test.QuickCheck +import Numeric.Natural -import Web.Internal.HttpApiData +import Test.Hspec +import Test.Hspec.QuickCheck (prop) +import Test.QuickCheck -import Web.Internal.TestInstances +import Web.Internal.HttpApiData +import Web.Internal.TestInstances + (<=>) :: forall a b. (Show a, Show b, Eq a) => (a -> b) -> (b -> Either T.Text a) -> a -> Property (f <=> g) x = counterexample (show lhs' ++ " : " ++ show lhs ++ " /= " ++ show rhs) @@ -43,6 +43,9 @@ encodedUrlPieceProp :: ToHttpApiData a => a -> Property encodedUrlPieceProp x = toLazyByteString (toEncodedUrlPiece (toUrlPiece x)) === toLazyByteString (toEncodedUrlPiece x) +encodedQueryParamProp :: ToHttpApiData a => a -> Property +encodedQueryParamProp x = toLazyByteString (toEncodedQueryParam (toQueryParam x)) === toLazyByteString (toEncodedQueryParam x) + -- | Check 'ToHttpApiData' and 'FromHttpApiData' compatibility checkUrlPiece :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Show a, Arbitrary a) => Proxy a -> String -> Spec checkUrlPiece _ = checkUrlPiece' (arbitrary :: Gen a) @@ -53,6 +56,7 @@ prop "toQueryParam <=> parseQueryParam" $ forAll gen (toQueryParam <=> parseQueryParam :: a -> Property) prop "toHeader <=> parseHeader" $ forAll gen (toHeader <=> parseHeader :: a -> Property) prop "toEncodedUrlPiece encodes correctly" $ forAll gen encodedUrlPieceProp + prop "toEncodedQueryParam encodes correctly" $ forAll gen encodedQueryParamProp -- | Check case insensitivity for @parseUrlPiece@. checkUrlPieceI :: forall a. (Eq a, ToHttpApiData a, FromHttpApiData a, Arbitrary a) => Proxy a -> String -> Spec @@ -80,13 +84,18 @@ checkUrlPiece (Proxy :: Proxy T.Text) "Text.Strict" checkUrlPiece (Proxy :: Proxy L.Text) "Text.Lazy" checkUrlPiece (Proxy :: Proxy Day) "Day" - checkUrlPiece' timeOfDayGen "TimeOfDay" - checkUrlPiece' localTimeGen "LocalTime" - checkUrlPiece' zonedTimeGen "ZonedTime" - checkUrlPiece' utcTimeGen "UTCTime" - checkUrlPiece' nominalDiffTimeGen "NominalDiffTime" + checkUrlPiece (Proxy :: Proxy TimeOfDay) "TimeOfDay" + checkUrlPiece (Proxy :: Proxy LocalTime) "LocalTime" + checkUrlPiece (Proxy :: Proxy ZonedTime) "ZonedTime" + checkUrlPiece (Proxy :: Proxy UTCTime) "UTCTime" + checkUrlPiece (Proxy :: Proxy NominalDiffTime) "NominalDiffTime" + checkUrlPiece (Proxy :: Proxy DayOfWeek) "DayOfWeek" + checkUrlPiece (Proxy :: Proxy Quarter) "Quarter" + checkUrlPiece (Proxy :: Proxy QuarterOfYear) "QuarterOfYear" + checkUrlPiece (Proxy :: Proxy Month) "Month" + checkUrlPiece (Proxy :: Proxy DayOfWeek) "DayOfWeek" checkUrlPiece (Proxy :: Proxy Version) "Version" - checkUrlPiece' uuidGen "UUID" + checkUrlPiece (Proxy :: Proxy UUID.UUID) "UUID" checkUrlPiece' setCookieGen "Cookie" checkUrlPiece (Proxy :: Proxy F.Uni) "Uni" @@ -102,9 +111,7 @@ checkUrlPiece (Proxy :: Proxy (Either Integer T.Text)) "Either Integer Text" checkUrlPieceI (Proxy :: Proxy (Either Version Day)) "Either Version Day" -#if MIN_VERSION_base(4,8,0) checkUrlPiece (Proxy :: Proxy Natural) "Natural" -#endif it "bad integers are rejected" $ do parseUrlPieceMaybe (T.pack "123hello") `shouldBe` (Nothing :: Maybe Int) @@ -115,31 +122,6 @@ it "invalid utf8 is handled" $ do parseHeaderMaybe (BS.pack [128]) `shouldBe` (Nothing :: Maybe T.Text) - - -uuidGen :: Gen UUID.UUID -uuidGen = UUID.fromWords <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary - --- TODO: this generators don't generate full range items -localTimeGen :: Gen LocalTime -localTimeGen = LocalTime <$> arbitrary <*> timeOfDayGen - -timeOfDayGen :: Gen TimeOfDay -timeOfDayGen = TimeOfDay - <$> choose (0, 23) - <*> choose (0, 59) - <*> fmap (\x -> 0.1 * fromInteger x) (choose (0, 600)) - -zonedTimeGen :: Gen ZonedTime -zonedTimeGen = ZonedTime - <$> localTimeGen -- Note: not arbitrary! - <*> liftA3 TimeZone arbitrary arbitrary (vectorOf 3 (elements ['A'..'Z'])) - -utcTimeGen :: Gen UTCTime -utcTimeGen = UTCTime <$> arbitrary <*> fmap fromInteger (choose (0, 86400)) - -nominalDiffTimeGen :: Gen NominalDiffTime -nominalDiffTimeGen = fromInteger <$> arbitrary setCookieGen :: Gen SetCookie setCookieGen = do diff --git a/test/Web/Internal/TestInstances.hs b/test/Web/Internal/TestInstances.hs --- a/test/Web/Internal/TestInstances.hs +++ b/test/Web/Internal/TestInstances.hs @@ -8,11 +8,11 @@ , NoEmptyKeyForm(..) ) where -import Control.Applicative +import Control.Applicative -- for ghc < 9.6 import Data.Char -import qualified Data.HashMap.Strict as HashMap +import qualified Data.Map.Strict as Map import qualified Data.Text as T -import Data.Time +import Data.Time.Compat import GHC.Exts (fromList) import GHC.Generics @@ -63,4 +63,4 @@ instance Arbitrary NoEmptyKeyForm where arbitrary = NoEmptyKeyForm . removeEmptyKeys <$> arbitrary where - removeEmptyKeys (Form m) = Form (HashMap.delete "" m) + removeEmptyKeys (Form m) = Form (Map.delete "" m) diff --git a/test/doctests.hs b/test/doctests.hs deleted file mode 100644 --- a/test/doctests.hs +++ /dev/null @@ -1,25 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Main (doctests) --- Copyright : (C) 2012-14 Edward Kmett --- License : BSD-style (see the file LICENSE) --- Maintainer : Edward Kmett --- Stability : provisional --- Portability : portable --- --- This module provides doctests for a project based on the actual versions --- of the packages it was built with. It requires a corresponding Setup.lhs --- to be added to the project ------------------------------------------------------------------------------ -module Main where - -import Build_doctests (flags, pkgs, module_sources) -import Data.Foldable (traverse_) -import Test.DocTest - -main :: IO () -main = do - traverse_ putStrLn args - doctest args - where - args = flags ++ pkgs ++ module_sources