@@ -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,9 @@ 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)
31import qualified Data.Map as Map
36import qualified Data.Map as Map
32import Data.Monoid (All (..), Any (..), Dual (..),
37import Data.Monoid (All (..), Any (..), Dual (..),
33 First (..), Last (..),
38 First (..), Last (..),
@@ -51,6 +56,9 @@ import Data.Time.Compat (Day, FormatTime, LocalTime,
51 secondsToNominalDiffTime)
56 secondsToNominalDiffTime)
52import Data.Time.Format.Compat (defaultTimeLocale,
57import Data.Time.Format.Compat (defaultTimeLocale,
53 iso8601DateFormat)
58 iso8601DateFormat)
59+import Data.Time.Calendar.Month.Compat (Month)
60+import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..),
54import Data.Typeable (Typeable)
62import Data.Typeable (Typeable)
55import qualified Data.UUID.Types as UUID
63import qualified Data.UUID.Types as UUID
56import Data.Version (Version, parseVersion,
64import Data.Version (Version, parseVersion,
@@ -64,14 +72,10 @@ import Text.Read (readMaybe)
64import Web.Cookie (SetCookie, parseSetCookie,
72import Web.Cookie (SetCookie, parseSetCookie,
65 renderSetCookie)
73 renderSetCookie)
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
@@ -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)
@@ -509,6 +514,42 @@ instance ToHttpApiData DayOfWeek where
510 toEncodedUrlPiece = unsafeToEncodedUrlPiece
515 toEncodedUrlPiece = unsafeToEncodedUrlPiece
520+instance ToHttpApiData QuarterOfYear where
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"
513instance ToHttpApiData NominalDiffTime where
554instance ToHttpApiData NominalDiffTime where
514 toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds
555 toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds
@@ -592,7 +633,22 @@ instance ToHttpApiData SetCookie where
592 toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie
633 toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie
593 -- toEncodedUrlPiece = renderSetCookie -- doesn't do things.
634 -- toEncodedUrlPiece = renderSetCookie -- doesn't do things.
636+-- | Note: this instance is not polykinded
595−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
596 toUrlPiece = coerce (toUrlPiece :: a -> Text)
652 toUrlPiece = coerce (toUrlPiece :: a -> Text)
597 toHeader = coerce (toHeader :: a -> ByteString)
653 toHeader = coerce (toHeader :: a -> ByteString)
598 toQueryParam = coerce (toQueryParam :: a -> Text)
654 toQueryParam = coerce (toQueryParam :: a -> Text)
@@ -650,7 +706,8 @@ instance FromHttpApiData String where parseUrlPiece = Right . T.unpack
650instance FromHttpApiData Text where parseUrlPiece = Right
706instance FromHttpApiData Text where parseUrlPiece = Right
651instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
707instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
709+-- | Note: this instance is not polykinded
653−instance F.HasResolution a => FromHttpApiData (F.Fixed a) where
710+instance F.HasResolution a => FromHttpApiData (F.Fixed (a :: Type)) where
654 parseUrlPiece = runReader rational
711 parseUrlPiece = runReader rational
@@ -681,6 +738,9 @@ instance FromHttpApiData ZonedTime where parseUrlPiece = runAtto Atto.zonedTime
681-- Right 2015-10-03 00:14:24 UTC
738-- Right 2015-10-03 00:14:24 UTC
682instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime
739instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime
742+-- >>> parseUrlPiece "Monday" :: Either Text DayOfWeek
684instance FromHttpApiData DayOfWeek where
744instance FromHttpApiData DayOfWeek where
685 parseUrlPiece t = case Map.lookup (T.toLower t) m of
745 parseUrlPiece t = case Map.lookup (T.toLower t) m of
686 Just dow -> Right dow
746 Just dow -> Right dow
@@ -692,6 +752,30 @@ instance FromHttpApiData DayOfWeek where
693instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secondsToNominalDiffTime . parseUrlPiece
753instance 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"
695instance FromHttpApiData All where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
779instance FromHttpApiData All where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
696instance FromHttpApiData Any where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
780instance FromHttpApiData Any where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
@@ -755,7 +839,20 @@ instance FromHttpApiData SetCookie where
755 parseUrlPiece = parseHeader . encodeUtf8
839 parseUrlPiece = parseHeader . encodeUtf8
756 parseHeader = Right . parseSetCookie
840 parseHeader = Right . parseSetCookie
842+-- | Note: this instance is not polykinded
758−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
759 parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
856 parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
760 parseHeader = coerce (parseHeader :: ByteString -> Either Text a)
857 parseHeader = coerce (parseHeader :: ByteString -> Either Text a)
761 parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)
858 parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)
@@ -768,5 +865,3 @@ runAtto :: Atto.Parser a -> Text -> Either Text a
768runAtto p t = case Atto.parseOnly (p <* Atto.endOfInput) t of
865runAtto p t = case Atto.parseOnly (p <* Atto.endOfInput) t of
769 Left err -> Left (T.pack err)
866 Left err -> Left (T.pack err)
770 Right x -> Right x
867 Right x -> Right x