@@ -5,9 +5,7 @@
5{-# LANGUAGE DeriveFunctor #-}
5{-# LANGUAGE DeriveFunctor #-}
6{-# LANGUAGE DeriveTraversable #-}
6{-# LANGUAGE DeriveTraversable #-}
7{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE FlexibleInstances #-}
8−{-# LANGUAGE KindSignatures #-}
9{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeSynonymInstances #-}
10{-# LANGUAGE TypeSynonymInstances #-}
@@ -15,31 +13,21 @@
15-- such as URL pieces, headers and query parameters.
13-- such as URL pieces, headers and query parameters.
16module Web.Internal.HttpApiData where
14module Web.Internal.HttpApiData where
18−import Prelude ()
16+import Prelude ()
19import Prelude.Compat
17import Prelude.Compat
21−import Control.Applicative (Const(Const))
22import Control.Arrow (left, (&&&))
19import Control.Arrow (left, (&&&))
23import Control.Monad ((<=<))
20import Control.Monad ((<=<))
24−import qualified Data.Attoparsec.Text as Atto
21+
25−import qualified Data.Attoparsec.Time as Atto
26import Data.ByteString (ByteString)
22import Data.ByteString (ByteString)
27import qualified Data.ByteString as BS
23import qualified Data.ByteString as BS
28−import qualified Data.ByteString.Builder as BS
29import qualified Data.ByteString.Lazy as LBS
24import qualified Data.ByteString.Lazy as LBS
30−import Data.Coerce (coerce)
25+import Data.Monoid
31−import Data.Data (Data)
26+
32import qualified Data.Fixed as F
27import qualified Data.Fixed as F
33−import Data.Functor.Identity (Identity(Identity))
28+import Data.Int
34−import Data.Int (Int16, Int32, Int64, Int8)
35−import Data.Kind (Type)
36−import qualified Data.Map as Map
37−import Data.Monoid (All (..), Any (..), Dual (..),
29+import Data.Word
38− First (..), Last (..),
30+
39− Product (..), Sum (..))
40−import Data.Semigroup (Semigroup (..))
41−import qualified Data.Semigroup as Semi
42−import Data.Tagged (Tagged (..))
43import Data.Text (Text)
31import Data.Text (Text)
44import qualified Data.Text as T
32import qualified Data.Text as T
45import Data.Text.Encoding (decodeUtf8', decodeUtf8With,
33import Data.Text.Encoding (decodeUtf8', decodeUtf8With,
@@ -48,39 +36,43 @@ import Data.Text.Encoding.Error (lenientDecode)
48import qualified Data.Text.Lazy as L
36import qualified Data.Text.Lazy as L
49import Data.Text.Read (Reader, decimal, rational,
37import Data.Text.Read (Reader, decimal, rational,
51−import Data.Time.Compat (Day, FormatTime, LocalTime,
41+import Data.Time.Locale.Compat
52− NominalDiffTime, TimeOfDay,
42+
53− UTCTime, ZonedTime, formatTime,
43+#if MIN_VERSION_time(1,9,1)
55− nominalDiffTimeToSeconds,
44+import Data.Time (nominalDiffTimeToSeconds, secondsToNominalDiffTime)
56− secondsToNominalDiffTime)
45+#endif
57−import Data.Time.Format.Compat (defaultTimeLocale,
46+
59−import Data.Time.Calendar.Month.Compat (Month)
60−import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..),
62−import Data.Typeable (Typeable)
63−import qualified Data.UUID.Types as UUID
64−import Data.Version (Version, parseVersion,
47+import Data.Version
66−import Data.Void (Void, absurd)
49+import Data.Void
67−import Data.Word (Word16, Word32, Word64, Word8)
68−import qualified Network.HTTP.Types as H
69−import Numeric.Natural (Natural)
50+import Numeric.Natural
70import Text.ParserCombinators.ReadP (readP_to_S)
52import Text.ParserCombinators.ReadP (readP_to_S)
71import Text.Read (readMaybe)
53import Text.Read (readMaybe)
72−import Web.Cookie (SetCookie, parseSetCookie,
75#if USE_TEXT_SHOW
55#if USE_TEXT_SHOW
76import TextShow (TextShow, showt)
56import TextShow (TextShow, showt)
59+import qualified Data.UUID.Types as UUID
61+import qualified Data.ByteString.Builder as BS
62+import Data.Data (Data)
63+import Data.Typeable (Typeable)
64+import qualified Network.HTTP.Types as H
66+import qualified Data.Attoparsec.Text as Atto
67+import qualified Data.Attoparsec.Time as Atto
69+import Web.Cookie (SetCookie, parseSetCookie,
80-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
74-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
81-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p
75-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p
82−-- >>> import Data.Time.Compat
83−-- >>> import Data.Version
85-- | Convert value to HTTP API data.
77-- | Convert value to HTTP API data.
@@ -96,7 +88,7 @@ class ToHttpApiData a where
96 -- The default definition uses 'H.encodePathSegmentsRelative',
88 -- The default definition uses 'H.encodePathSegmentsRelative',
97 -- but this may be overriden with a more efficient version.
89 -- but this may be overriden with a more efficient version.
98 toEncodedUrlPiece :: a -> BS.Builder
90 toEncodedUrlPiece :: a -> BS.Builder
99− toEncodedUrlPiece = H.urlEncodeBuilder True . encodeUtf8 . toUrlPiece
91+ toEncodedUrlPiece = H.encodePathSegmentsRelative . (:[]) . toUrlPiece
101 -- | Convert to HTTP header value.
93 -- | Convert to HTTP header value.
102 toHeader :: a -> ByteString
94 toHeader :: a -> ByteString
@@ -338,7 +330,7 @@ lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])
338-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool
330-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool
339-- Right True
331-- Right True
341−-- For case insensitive parser see 'parseBoundedEnumOfI'.
333+-- For case sensitive parser see 'parseBoundedEnumOfI'.
342parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
334parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
343parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf
335parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf
@@ -459,8 +451,7 @@ instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = un
459instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
451instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
460instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
452instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
462−-- | Note: this instance is not polykinded
463−instance F.HasResolution a => ToHttpApiData (F.Fixed (a :: Type)) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
454+instance F.HasResolution a => ToHttpApiData (F.Fixed a) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
466-- >>> toUrlPiece (fromGregorian 2015 10 03)
457-- >>> toUrlPiece (fromGregorian 2015 10 03)
@@ -500,108 +491,56 @@ instance ToHttpApiData UTCTime where
500 toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ"
491 toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ"
501 toEncodedUrlPiece = unsafeToEncodedUrlPiece
492 toEncodedUrlPiece = unsafeToEncodedUrlPiece
503−-- |
494+-- The CPP in both this function and the function after it are to avoid
504−-- >>> toUrlPiece Monday
495+-- exporting @nominalDiffTimeToSeconds@ and @secondsToNominalDiffTime@,
505−-- "monday"
496+-- since these names are already used by @Data.Time@ from the @time@ library
506−instance ToHttpApiData DayOfWeek where
497+-- starting in version @1.9.1@.
507− toUrlPiece Monday = "monday"
498+nominalDiffTimeToSecs :: NominalDiffTime -> F.Pico
508− toUrlPiece Tuesday = "tuesday"
499+nominalDiffTimeToSecs =
509− toUrlPiece Wednesday = "wednesday"
500+#if !MIN_VERSION_time(1,9,1)
510− toUrlPiece Thursday = "thursday"
501+ realToFrac
511− toUrlPiece Friday = "friday"
502+#else
512− toUrlPiece Saturday = "saturday"
503+ nominalDiffTimeToSeconds
513− toUrlPiece Sunday = "sunday"
504+#endif
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)
543−-- |
506+secsToNominalDiffTime :: F.Pico -> NominalDiffTime
544−-- >>> import Data.Time.Calendar.Month.Compat (Month (..))
507+secsToNominalDiffTime =
545−-- >>> MkMonth 24482
508+#if !MIN_VERSION_time(1,9,1)
546−-- 2040-03
509+ realToFrac
548−-- >>> toUrlPiece $ MkMonth 24482
511+ secondsToNominalDiffTime
549−-- "2040-03"
512+#endif
551−instance ToHttpApiData Month where
552− toUrlPiece = T.pack . formatTime defaultTimeLocale "%Y-%m"
554instance ToHttpApiData NominalDiffTime where
514instance ToHttpApiData NominalDiffTime where
555− toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds
515+ toUrlPiece = toUrlPiece . nominalDiffTimeToSecs
556 toEncodedUrlPiece = unsafeToEncodedUrlPiece
516 toEncodedUrlPiece = unsafeToEncodedUrlPiece
558instance ToHttpApiData String where toUrlPiece = T.pack
518instance ToHttpApiData String where toUrlPiece = T.pack
559instance ToHttpApiData Text where toUrlPiece = id
519instance ToHttpApiData Text where toUrlPiece = id
560instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
520instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
562−instance ToHttpApiData All where
522+instance ToHttpApiData All where toUrlPiece = toUrlPiece . getAll; toEncodedUrlPiece = toEncodedUrlPiece . getAll
563− toUrlPiece = coerce (toUrlPiece :: Bool -> Text)
564− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder)
566−instance ToHttpApiData Any where
523+instance ToHttpApiData Any where toUrlPiece = toUrlPiece . getAny; toEncodedUrlPiece = toEncodedUrlPiece . getAny
567− toUrlPiece = coerce (toUrlPiece :: Bool -> Text)
568− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder)
570instance ToHttpApiData a => ToHttpApiData (Dual a) where
525instance ToHttpApiData a => ToHttpApiData (Dual a) where
571− toUrlPiece = coerce (toUrlPiece :: a -> Text)
526+ toUrlPiece = toUrlPiece . getDual
572− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
527+ toEncodedUrlPiece = toEncodedUrlPiece . getDual
574instance ToHttpApiData a => ToHttpApiData (Sum a) where
529instance ToHttpApiData a => ToHttpApiData (Sum a) where
575− toUrlPiece = coerce (toUrlPiece :: a -> Text)
530+ toUrlPiece = toUrlPiece . getSum
576− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
531+ toEncodedUrlPiece = toEncodedUrlPiece . getSum
578instance ToHttpApiData a => ToHttpApiData (Product a) where
533instance ToHttpApiData a => ToHttpApiData (Product a) where
579− toUrlPiece = coerce (toUrlPiece :: a -> Text)
534+ toUrlPiece = toUrlPiece . getProduct
580− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
535+ toEncodedUrlPiece = toEncodedUrlPiece . getProduct
582instance ToHttpApiData a => ToHttpApiData (First a) where
537instance ToHttpApiData a => ToHttpApiData (First a) where
583− toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)
538+ toUrlPiece = toUrlPiece . getFirst
584− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)
539+ toEncodedUrlPiece = toEncodedUrlPiece . getFirst
586instance ToHttpApiData a => ToHttpApiData (Last a) where
541instance ToHttpApiData a => ToHttpApiData (Last a) where
587− toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)
542+ toUrlPiece = toUrlPiece . getLast
588− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)
590−instance ToHttpApiData a => ToHttpApiData (Semi.Min a) where
591− toUrlPiece = coerce (toUrlPiece :: a -> Text)
592− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
594−instance ToHttpApiData a => ToHttpApiData (Semi.Max a) where
595− toUrlPiece = coerce (toUrlPiece :: a -> Text)
596− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
543+ toEncodedUrlPiece = toEncodedUrlPiece . getLast
598−instance ToHttpApiData a => ToHttpApiData (Semi.First a) where
599− toUrlPiece = coerce (toUrlPiece :: a -> Text)
600− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
602−instance ToHttpApiData a => ToHttpApiData (Semi.Last a) where
603− toUrlPiece = coerce (toUrlPiece :: a -> Text)
604− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
607-- >>> toUrlPiece (Just "Hello")
546-- >>> toUrlPiece (Just "Hello")
@@ -633,27 +572,6 @@ instance ToHttpApiData SetCookie where
633 toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie
572 toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie
634 -- toEncodedUrlPiece = renderSetCookie -- doesn't do things.
573 -- toEncodedUrlPiece = renderSetCookie -- doesn't do things.
636−-- | Note: this instance is not polykinded
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
652− toUrlPiece = coerce (toUrlPiece :: a -> Text)
653− toHeader = coerce (toHeader :: a -> ByteString)
654− toQueryParam = coerce (toQueryParam :: a -> Text)
655− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
658-- >>> parseUrlPiece "_" :: Either Text ()
576-- >>> parseUrlPiece "_" :: Either Text ()
659-- Right ()
577-- Right ()
@@ -706,8 +624,7 @@ instance FromHttpApiData String where parseUrlPiece = Right . T.unpack
706instance FromHttpApiData Text where parseUrlPiece = Right
624instance FromHttpApiData Text where parseUrlPiece = Right
707instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
625instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
709−-- | Note: this instance is not polykinded
710−instance F.HasResolution a => FromHttpApiData (F.Fixed (a :: Type)) where
627+instance F.HasResolution a => FromHttpApiData (F.Fixed a) where
711 parseUrlPiece = runReader rational
628 parseUrlPiece = runReader rational
@@ -738,57 +655,16 @@ instance FromHttpApiData ZonedTime where parseUrlPiece = runAtto Atto.zonedTime
738-- Right 2015-10-03 00:14:24 UTC
655-- Right 2015-10-03 00:14:24 UTC
739instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime
656instance 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] ]
753−instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secondsToNominalDiffTime . parseUrlPiece
658+instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secsToNominalDiffTime . parseUrlPiece
756−-- >>> parseUrlPiece "2021-01" :: Either Text Month
758−instance FromHttpApiData Month where parseUrlPiece = runAtto Atto.month
760−-- |
660+instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece
761−-- >>> parseUrlPiece "2021-q1" :: Either Text Quarter
763−instance FromHttpApiData Quarter where parseUrlPiece = runAtto Atto.quarter
661+instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece
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"
779−instance FromHttpApiData All where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
780−instance FromHttpApiData Any where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
782−instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
663+instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = fmap Dual . parseUrlPiece
783−instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
664+instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = fmap Sum . parseUrlPiece
784−instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
665+instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = fmap Product . parseUrlPiece
785−instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a))
666+instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = fmap First . parseUrlPiece
786−instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a))
788−instance FromHttpApiData a => FromHttpApiData (Semi.Min a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
789−instance FromHttpApiData a => FromHttpApiData (Semi.Max a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
667+instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = fmap Last . parseUrlPiece
790−instance FromHttpApiData a => FromHttpApiData (Semi.First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
791−instance FromHttpApiData a => FromHttpApiData (Semi.Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
794-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
670-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
@@ -839,24 +715,6 @@ instance FromHttpApiData SetCookie where
839 parseUrlPiece = parseHeader . encodeUtf8
715 parseUrlPiece = parseHeader . encodeUtf8
840 parseHeader = Right . parseSetCookie
716 parseHeader = Right . parseSetCookie
842−-- | Note: this instance is not polykinded
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
856− parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
857− parseHeader = coerce (parseHeader :: ByteString -> Either Text a)
858− parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)
860-------------------------------------------------------------------------------
718-------------------------------------------------------------------------------
861-- Attoparsec helpers
719-- Attoparsec helpers
862-------------------------------------------------------------------------------
720-------------------------------------------------------------------------------