diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,37 @@ +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 ----- 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.5.1 +version: 0.7 synopsis: Converting to/from HTTP API data like URL pieces, headers and query parameters. category: Web @@ -18,22 +18,21 @@ build-type: Simple extra-source-files: - include/overlapping-compat.h test/*.hs CHANGELOG.md README.md tested-with: - GHC==8.0.2, - GHC==8.2.2, - GHC==8.4.4, GHC==8.6.5, GHC==8.8.4, GHC==8.10.7, GHC==9.0.2, - GHC==9.2.7, - GHC==9.4.4, - GHC==9.6.1 + 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. @@ -42,31 +41,26 @@ library hs-source-dirs: src/ - include-dirs: include/ -- GHC bundled - build-depends: base >= 4.9 && < 4.19 - , bytestring >= 0.10.8.1 && < 0.12 - , containers >= 0.5.7.1 && < 0.7 - , text >= 1.2.3.0 && < 1.3 || >=2.0 && <2.1 - , transformers >= 0.5.2.0 && < 0.7 + 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.15 - , attoparsec-iso8601 >= 1.1.0.0 && < 1.2 - , base-compat >= 0.10.5 && < 0.14 - , cookie >= 0.4.3 && < 0.5 - , hashable >= 1.2.7.0 && < 1.5 - , http-types >= 0.12.3 && < 0.13 - , tagged >= 0.8.5 && < 0.9 + 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 - , unordered-containers >= 0.2.10.0 && < 0.3 - , uuid-types >= 1.0.3 && < 1.1 + , uuid-types >= 1.0.6 && < 1.1 if flag(use-text-show) cpp-options: -DUSE_TEXT_SHOW - build-depends: text-show >= 3.8.2 && <3.11 + build-depends: text-show >= 3.10.5 && <3.12 exposed-modules: Web.HttpApiData @@ -86,25 +80,20 @@ hs-source-dirs: test ghc-options: -Wall default-language: Haskell2010 - build-tool-depends: hspec-discover:hspec-discover >= 2.7.1 && <2.11 + build-tool-depends: hspec-discover:hspec-discover >= 2.7.1 && <2.12 -- inherited depndencies build-depends: base - , base-compat , bytestring , cookie , http-api-data , text , time-compat - , unordered-containers + , containers , uuid-types - if !impl(ghc >= 7.10) - build-depends: nats - - build-depends: HUnit >= 1.6.0.0 && <1.7 - , hspec >= 2.7.1 && <2.11 - , QuickCheck >= 2.13.1 && <2.15 + 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 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/Internal/FormUrlEncoded.hs b/src/Web/Internal/FormUrlEncoded.hs --- a/src/Web/Internal/FormUrlEncoded.hs +++ b/src/Web/Internal/FormUrlEncoded.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE CPP #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveGeneric #-} @@ -14,12 +13,8 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -#include "overlapping-compat.h" module Web.Internal.FormUrlEncoded where -import Prelude () -import Prelude.Compat - import Control.Applicative (Const(Const)) import Control.Arrow ((***)) import Control.Monad ((<=<)) @@ -30,14 +25,11 @@ 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 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 (All (..), Any (..), Dual (..), Product (..), Sum (..)) import Data.Ord (comparing) @@ -54,7 +46,7 @@ UTCTime, ZonedTime) import Data.Time.Calendar.Month.Compat (Month) import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) -import Data.Void (Void) +import Data.Void (Void, absurd) import Data.Word (Word16, Word32, Word64, Word8) import GHC.Exts (Constraint, IsList (..)) import GHC.Generics @@ -64,13 +56,11 @@ 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 @@ -212,7 +202,7 @@ -- | 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] } +newtype Form = Form { unForm :: Map.Map Text [Text] } deriving (Eq, Read, Generic, Semigroup, Monoid) instance Show Form where @@ -223,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)] @@ -274,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 @@ -291,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'. @@ -357,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) @@ -375,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) @@ -425,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 @@ -443,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 @@ -505,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) @@ -520,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) @@ -670,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 @@ -15,14 +15,9 @@ -- such as URL pieces, headers and query parameters. module Web.Internal.HttpApiData where -import Prelude () -import Prelude.Compat - import Control.Applicative (Const(Const)) import Control.Arrow (left, (&&&)) import Control.Monad ((<=<)) -import qualified Data.Attoparsec.Text as Atto -import qualified Data.Attoparsec.Time as Atto import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BS @@ -33,11 +28,10 @@ import Data.Functor.Identity (Identity(Identity)) import Data.Int (Int16, Int32, Int64, Int8) import Data.Kind (Type) -import qualified Data.Map as Map +import qualified Data.Map.Strict as Map import Data.Monoid (All (..), Any (..), Dual (..), First (..), Last (..), Product (..), Sum (..)) -import Data.Semigroup (Semigroup (..)) import qualified Data.Semigroup as Semi import Data.Tagged (Tagged (..)) import Data.Text (Text) @@ -46,19 +40,18 @@ 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.Compat (Day, FormatTime, LocalTime, +import qualified Data.Time.ToText as TT +import qualified Data.Time.FromText as FT +import Data.Time.Compat (Day, LocalTime, NominalDiffTime, TimeOfDay, - UTCTime, ZonedTime, formatTime, - DayOfWeek (..), + UTCTime, ZonedTime, DayOfWeek (..), nominalDiffTimeToSeconds, secondsToNominalDiffTime) -import Data.Time.Format.Compat (defaultTimeLocale, - iso8601DateFormat) import Data.Time.Calendar.Month.Compat (Month) -import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..), - toYearQuarter) +import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..)) import Data.Typeable (Typeable) import qualified Data.UUID.Types as UUID import Data.Version (Version, parseVersion, @@ -77,10 +70,17 @@ #endif -- $setup --- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show) --- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p +-- >>> :set -XOverloadedStrings +-- >>> import Data.Text (Text) +-- >>> import Data.Word (Word8) +-- >>> import Data.Text.Read (decimal) -- >>> import Data.Time.Compat +-- >>> import Data.Time.Calendar.Month.Compat +-- >>> import Data.Time.Calendar.Quarter.Compat -- >>> import Data.Version +-- >>> import Web.Cookie (SetCookie) +-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show) +-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p -- | Convert value to HTTP API data. -- @@ -484,18 +484,15 @@ -- >>> toUrlPiece (fromGregorian 2015 10 03) -- "2015-10-03" instance ToHttpApiData Day where - toUrlPiece = T.pack . show + toUrlPiece = runTT TT.buildDay toEncodedUrlPiece = unsafeToEncodedUrlPiece toEncodedQueryParam = unsafeToEncodedQueryParam -timeToUrlPiece :: FormatTime t => String -> t -> Text -timeToUrlPiece fmt = T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just fmt)) - -- | -- >>> toUrlPiece $ TimeOfDay 14 55 23.1 --- "14:55:23.1" +-- "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. @@ -503,23 +500,27 @@ -- >>> 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. @@ -542,10 +543,7 @@ -- >>> toUrlPiece Q4 -- "q4" instance ToHttpApiData QuarterOfYear where - toUrlPiece Q1 = "q1" - toUrlPiece Q2 = "q2" - toUrlPiece Q3 = "q3" - toUrlPiece Q4 = "q4" + toUrlPiece = runTT TT.buildQuarterOfYear toEncodedUrlPiece = unsafeToEncodedUrlPiece toEncodedQueryParam = unsafeToEncodedQueryParam @@ -559,13 +557,7 @@ -- "2010-q1" -- instance ToHttpApiData Quarter where - toUrlPiece q = case toYearQuarter q of - (y, qoy) -> T.pack (show y ++ "-" ++ f qoy) - where - f Q1 = "q1" - f Q2 = "q2" - f Q3 = "q3" - f Q4 = "q4" + toUrlPiece = runTT TT.buildQuarter toEncodedUrlPiece = unsafeToEncodedUrlPiece toEncodedQueryParam = unsafeToEncodedQueryParam @@ -579,7 +571,7 @@ -- "2040-03" -- instance ToHttpApiData Month where - toUrlPiece = T.pack . formatTime defaultTimeLocale "%Y-%m" + toUrlPiece = runTT TT.buildMonth toEncodedUrlPiece = unsafeToEncodedUrlPiece toEncodedQueryParam = unsafeToEncodedQueryParam @@ -762,17 +754,17 @@ -- | -- >>> 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 @@ -780,12 +772,12 @@ -- -- >>> 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 -- | -- >>> parseUrlPiece "Monday" :: Either Text DayOfWeek @@ -804,12 +796,12 @@ -- | -- >>> parseUrlPiece "2021-01" :: Either Text Month -- Right 2021-01 -instance FromHttpApiData Month where parseUrlPiece = runAtto Atto.month +instance FromHttpApiData Month where parseUrlPiece = runFT FT.parseMonth -- | -- >>> parseUrlPiece "2021-q1" :: Either Text Quarter -- Right 2021-Q1 -instance FromHttpApiData Quarter where parseUrlPiece = runAtto Atto.quarter +instance FromHttpApiData Quarter where parseUrlPiece = runFT FT.parseQuarter -- | -- >>> parseUrlPiece "q2" :: Either Text QuarterOfYear @@ -817,13 +809,7 @@ -- -- >>> parseUrlPiece "Q3" :: Either Text QuarterOfYear -- Right Q3 -instance FromHttpApiData QuarterOfYear where - parseUrlPiece t = case T.toLower t of - "q1" -> return Q1 - "q2" -> return Q2 - "q3" -> return Q3 - "q4" -> return Q4 - _ -> Left "Invalid quarter of year" +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) @@ -883,7 +869,7 @@ -- | /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 @@ -907,12 +893,13 @@ 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 @@ -2,9 +2,6 @@ module Web.Internal.HttpApiDataSpec (spec) where -import Prelude () -import Prelude.Compat - import qualified Data.ByteString as BS import Data.ByteString.Builder (toLazyByteString) import Data.Char 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,9 +8,9 @@ , 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.Compat import GHC.Exts (fromList) @@ -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)