@@ -5,7 +5,9 @@
5{-# LANGUAGE DeriveFunctor #-}
5{-# LANGUAGE DeriveFunctor #-}
6{-# LANGUAGE DeriveTraversable #-}
6{-# LANGUAGE DeriveTraversable #-}
7{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE KindSignatures #-}
8{-# LANGUAGE OverloadedStrings #-}
9{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeSynonymInstances #-}
12{-# LANGUAGE TypeSynonymInstances #-}
@@ -16,6 +18,7 @@ module Web.Internal.HttpApiData where
16import Prelude ()
18import Prelude ()
17import Prelude.Compat
19import Prelude.Compat
21+import Control.Applicative (Const(Const))
19import Control.Arrow (left, (&&&))
22import Control.Arrow (left, (&&&))
20import Control.Monad ((<=<))
23import Control.Monad ((<=<))
21import qualified Data.Attoparsec.Text as Atto
24import qualified Data.Attoparsec.Text as Atto
@@ -27,7 +30,10 @@ import qualified Data.ByteString.Lazy as LBS
27import Data.Coerce (coerce)
30import Data.Coerce (coerce)
28import Data.Data (Data)
31import Data.Data (Data)
29import qualified Data.Fixed as F
32import qualified Data.Fixed as F
33+import Data.Functor.Identity (Identity(Identity))
30import Data.Int (Int16, Int32, Int64, Int8)
34import Data.Int (Int16, Int32, Int64, Int8)
35+import Data.Kind (Type)
36+import qualified Data.Map as Map
31import Data.Monoid (All (..), Any (..), Dual (..),
37import Data.Monoid (All (..), Any (..), Dual (..),
32 First (..), Last (..),
38 First (..), Last (..),
33 Product (..), Sum (..))
39 Product (..), Sum (..))
@@ -42,11 +48,17 @@ import Data.Text.Encoding.Error (lenientDecode)
42import qualified Data.Text.Lazy as L
48import qualified Data.Text.Lazy as L
43import Data.Text.Read (Reader, decimal, rational,
49import Data.Text.Read (Reader, decimal, rational,
45−import Data.Time (Day, FormatTime, LocalTime,
51+import Data.Time.Compat (Day, FormatTime, LocalTime,
46 NominalDiffTime, TimeOfDay,
52 NominalDiffTime, TimeOfDay,
47− UTCTime, ZonedTime, formatTime)
53+ UTCTime, ZonedTime, formatTime,
55+ nominalDiffTimeToSeconds,
56+ secondsToNominalDiffTime)
48−import Data.Time.Locale.Compat (defaultTimeLocale,
57+import Data.Time.Format.Compat (defaultTimeLocale,
49 iso8601DateFormat)
58 iso8601DateFormat)
59+import Data.Time.Calendar.Month.Compat (Month)
60+import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..),
50import Data.Typeable (Typeable)
62import Data.Typeable (Typeable)
51import qualified Data.UUID.Types as UUID
63import qualified Data.UUID.Types as UUID
52import Data.Version (Version, parseVersion,
64import Data.Version (Version, parseVersion,
@@ -60,22 +72,14 @@ import Text.Read (readMaybe)
60import Web.Cookie (SetCookie, parseSetCookie,
72import Web.Cookie (SetCookie, parseSetCookie,
61 renderSetCookie)
73 renderSetCookie)
63−#if MIN_VERSION_time(1,9,1)
64−import Data.Time (nominalDiffTimeToSeconds,
65− secondsToNominalDiffTime)
68#if USE_TEXT_SHOW
75#if USE_TEXT_SHOW
69import TextShow (TextShow, showt)
76import TextShow (TextShow, showt)
76-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
80-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
77-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p
81-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p
78−-- >>> import Data.Time
82+-- >>> import Data.Time.Compat
79-- >>> import Data.Version
83-- >>> import Data.Version
81-- | Convert value to HTTP API data.
85-- | Convert value to HTTP API data.
@@ -92,7 +96,7 @@ class ToHttpApiData a where
92 -- The default definition uses 'H.encodePathSegmentsRelative',
96 -- The default definition uses 'H.encodePathSegmentsRelative',
93 -- but this may be overriden with a more efficient version.
97 -- but this may be overriden with a more efficient version.
94 toEncodedUrlPiece :: a -> BS.Builder
98 toEncodedUrlPiece :: a -> BS.Builder
95− toEncodedUrlPiece = H.encodePathSegmentsRelative . (:[]) . toUrlPiece
99+ toEncodedUrlPiece = H.urlEncodeBuilder True . encodeUtf8 . toUrlPiece
97 -- | Convert to HTTP header value.
101 -- | Convert to HTTP header value.
98 toHeader :: a -> ByteString
102 toHeader :: a -> ByteString
@@ -334,7 +338,7 @@ lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])
334-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool
338-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool
335-- Right True
339-- Right True
337−-- For case sensitive parser see 'parseBoundedEnumOfI'.
341+-- For case insensitive parser see 'parseBoundedEnumOfI'.
338parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
342parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
339parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf
343parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf
@@ -455,7 +459,8 @@ instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = un
455instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
459instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
456instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
460instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
462+-- | Note: this instance is not polykinded
458−instance F.HasResolution a => ToHttpApiData (F.Fixed a) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
463+instance F.HasResolution a => ToHttpApiData (F.Fixed (a :: Type)) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
461-- >>> toUrlPiece (fromGregorian 2015 10 03)
466-- >>> toUrlPiece (fromGregorian 2015 10 03)
@@ -495,28 +500,59 @@ instance ToHttpApiData UTCTime where
495 toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ"
500 toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ"
496 toEncodedUrlPiece = unsafeToEncodedUrlPiece
501 toEncodedUrlPiece = unsafeToEncodedUrlPiece
498−-- The CPP in both this function and the function after it are to avoid
503+-- |
499−-- exporting @nominalDiffTimeToSeconds@ and @secondsToNominalDiffTime@,
504+-- >>> toUrlPiece Monday
500−-- since these names are already used by @Data.Time@ from the @time@ library
505+-- "monday"
501−-- starting in version @1.9.1@.
506+instance ToHttpApiData DayOfWeek where
502−nominalDiffTimeToSecs :: NominalDiffTime -> F.Pico
507+ toUrlPiece Monday = "monday"
503−nominalDiffTimeToSecs =
508+ toUrlPiece Tuesday = "tuesday"
504−#if !MIN_VERSION_time(1,9,1)
509+ toUrlPiece Wednesday = "wednesday"
505− realToFrac
510+ toUrlPiece Thursday = "thursday"
506−#else
511+ toUrlPiece Friday = "friday"
507− nominalDiffTimeToSeconds
512+ toUrlPiece Saturday = "saturday"
508−#endif
513+ toUrlPiece Sunday = "sunday"
510−secsToNominalDiffTime :: F.Pico -> NominalDiffTime
515+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
511−secsToNominalDiffTime =
516+
512−#if !MIN_VERSION_time(1,9,1)
517+-- |
513− realToFrac
518+-- >>> toUrlPiece Q4
515− secondsToNominalDiffTime
520+instance ToHttpApiData QuarterOfYear where
516−#endif
521+ toUrlPiece Q1 = "q1"
522+ toUrlPiece Q2 = "q2"
523+ toUrlPiece Q3 = "q3"
524+ toUrlPiece Q4 = "q4"
527+-- >>> import Data.Time.Calendar.Quarter.Compat (Quarter (..))
528+-- >>> MkQuarter 8040
531+-- >>> toUrlPiece $ MkQuarter 8040
534+instance ToHttpApiData Quarter where
535+ toUrlPiece q = case toYearQuarter q of
536+ (y, qoy) -> T.pack (show y ++ "-" ++ f qoy)
544+-- >>> import Data.Time.Calendar.Month.Compat (Month (..))
548+-- >>> toUrlPiece $ MkMonth 24482
551+instance ToHttpApiData Month where
552+ toUrlPiece = T.pack . formatTime defaultTimeLocale "%Y-%m"
518instance ToHttpApiData NominalDiffTime where
554instance ToHttpApiData NominalDiffTime where
519− toUrlPiece = toUrlPiece . nominalDiffTimeToSecs
555+ toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds
520 toEncodedUrlPiece = unsafeToEncodedUrlPiece
556 toEncodedUrlPiece = unsafeToEncodedUrlPiece
522instance ToHttpApiData String where toUrlPiece = T.pack
558instance ToHttpApiData String where toUrlPiece = T.pack
@@ -597,7 +633,22 @@ instance ToHttpApiData SetCookie where
597 toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie
633 toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie
598 -- toEncodedUrlPiece = renderSetCookie -- doesn't do things.
634 -- toEncodedUrlPiece = renderSetCookie -- doesn't do things.
636+-- | Note: this instance is not polykinded
600−instance ToHttpApiData a => ToHttpApiData (Tagged b a) where
637+instance ToHttpApiData a => ToHttpApiData (Tagged (b :: Type) a) where
638+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
639+ toHeader = coerce (toHeader :: a -> ByteString)
640+ toQueryParam = coerce (toQueryParam :: a -> Text)
641+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
644+instance ToHttpApiData a => ToHttpApiData (Const a b) where
645+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
646+ toHeader = coerce (toHeader :: a -> ByteString)
647+ toQueryParam = coerce (toQueryParam :: a -> Text)
648+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
651+instance ToHttpApiData a => ToHttpApiData (Identity a) where
601 toUrlPiece = coerce (toUrlPiece :: a -> Text)
652 toUrlPiece = coerce (toUrlPiece :: a -> Text)
602 toHeader = coerce (toHeader :: a -> ByteString)
653 toHeader = coerce (toHeader :: a -> ByteString)
603 toQueryParam = coerce (toQueryParam :: a -> Text)
654 toQueryParam = coerce (toQueryParam :: a -> Text)
@@ -655,7 +706,8 @@ instance FromHttpApiData String where parseUrlPiece = Right . T.unpack
655instance FromHttpApiData Text where parseUrlPiece = Right
706instance FromHttpApiData Text where parseUrlPiece = Right
656instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
707instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
709+-- | Note: this instance is not polykinded
658−instance F.HasResolution a => FromHttpApiData (F.Fixed a) where
710+instance F.HasResolution a => FromHttpApiData (F.Fixed (a :: Type)) where
659 parseUrlPiece = runReader rational
711 parseUrlPiece = runReader rational
@@ -686,7 +738,43 @@ instance FromHttpApiData ZonedTime where parseUrlPiece = runAtto Atto.zonedTime
686-- Right 2015-10-03 00:14:24 UTC
738-- Right 2015-10-03 00:14:24 UTC
687instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime
739instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime
742+-- >>> parseUrlPiece "Monday" :: Either Text DayOfWeek
744+instance FromHttpApiData DayOfWeek where
745+ parseUrlPiece t = case Map.lookup (T.toLower t) m of
746+ Just dow -> Right dow
747+ Nothing -> Left $ "Incorrect DayOfWeek: " <> T.take 10 t
749+ m :: Map.Map Text DayOfWeek
750+ m = Map.fromList [ (toUrlPiece dow, dow) | dow <- [Monday .. Sunday] ]
689−instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secsToNominalDiffTime . parseUrlPiece
753+instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secondsToNominalDiffTime . parseUrlPiece
756+-- >>> parseUrlPiece "2021-01" :: Either Text Month
758+instance FromHttpApiData Month where parseUrlPiece = runAtto Atto.month
761+-- >>> parseUrlPiece "2021-q1" :: Either Text Quarter
763+instance FromHttpApiData Quarter where parseUrlPiece = runAtto Atto.quarter
766+-- >>> parseUrlPiece "q2" :: Either Text QuarterOfYear
769+-- >>> parseUrlPiece "Q3" :: Either Text QuarterOfYear
771+instance FromHttpApiData QuarterOfYear where
772+ parseUrlPiece t = case T.toLower t of
777+ _ -> Left "Invalid quarter of year"
691instance FromHttpApiData All where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
779instance FromHttpApiData All where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
692instance FromHttpApiData Any where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
780instance FromHttpApiData Any where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
@@ -751,7 +839,20 @@ instance FromHttpApiData SetCookie where
751 parseUrlPiece = parseHeader . encodeUtf8
839 parseUrlPiece = parseHeader . encodeUtf8
752 parseHeader = Right . parseSetCookie
840 parseHeader = Right . parseSetCookie
842+-- | Note: this instance is not polykinded
754−instance FromHttpApiData a => FromHttpApiData (Tagged b a) where
843+instance FromHttpApiData a => FromHttpApiData (Tagged (b :: Type) a) where
844+ parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
845+ parseHeader = coerce (parseHeader :: ByteString -> Either Text a)
846+ parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)
849+instance FromHttpApiData a => FromHttpApiData (Const a b) where
850+ parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
851+ parseHeader = coerce (parseHeader :: ByteString -> Either Text a)
852+ parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)
855+instance FromHttpApiData a => FromHttpApiData (Identity a) where
755 parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
856 parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
756 parseHeader = coerce (parseHeader :: ByteString -> Either Text a)
857 parseHeader = coerce (parseHeader :: ByteString -> Either Text a)
757 parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)
858 parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)
@@ -764,5 +865,3 @@ runAtto :: Atto.Parser a -> Text -> Either Text a
764runAtto p t = case Atto.parseOnly (p <* Atto.endOfInput) t of
865runAtto p t = case Atto.parseOnly (p <* Atto.endOfInput) t of
765 Left err -> Left (T.pack err)
866 Left err -> Left (T.pack err)
766 Right x -> Right x
867 Right x -> Right x