@@ -5,9 +5,7 @@
55{-# LANGUAGE DeriveFunctor #-}
66{-# LANGUAGE DeriveTraversable #-}
77{-# LANGUAGE FlexibleInstances #-}
8−{-# LANGUAGE KindSignatures #-}
98{-# LANGUAGE OverloadedStrings #-}
10−{-# LANGUAGE PolyKinds #-}
119{-# LANGUAGE ScopedTypeVariables #-}
1210{-# LANGUAGE TypeSynonymInstances #-}
1311-- |
@@ -15,31 +13,21 @@
1513-- such as URL pieces, headers and query parameters.
1614module Web.Internal.HttpApiData where
1715
18−import Prelude ()
16+import Prelude ()
1917import Prelude.Compat
2018
21−import Control.Applicative (Const(Const))
2219import Control.Arrow (left, (&&&))
2320import Control.Monad ((<=<))
24−import qualified Data.Attoparsec.Text as Atto
25−import qualified Data.Attoparsec.Time as Atto
21+
2622import Data.ByteString (ByteString)
2723import qualified Data.ByteString as BS
28−import qualified Data.ByteString.Builder as BS
2924import qualified Data.ByteString.Lazy as LBS
30−import Data.Coerce (coerce)
31−import Data.Data (Data)
25+import Data.Monoid
26+
3227import qualified Data.Fixed as F
33−import Data.Functor.Identity (Identity(Identity))
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 (..),
38− First (..), Last (..),
39− Product (..), Sum (..))
40−import Data.Semigroup (Semigroup (..))
41−import qualified Data.Semigroup as Semi
42−import Data.Tagged (Tagged (..))
28+import Data.Int
29+import Data.Word
30+
4331import Data.Text (Text)
4432import qualified Data.Text as T
4533import Data.Text.Encoding (decodeUtf8', decodeUtf8With,
@@ -48,39 +36,43 @@ import Data.Text.Encoding.Error (lenientDecode)
4836import qualified Data.Text.Lazy as L
4937import Data.Text.Read (Reader, decimal, rational,
5038 signed)
51−import Data.Time.Compat (Day, FormatTime, LocalTime,
52− NominalDiffTime, TimeOfDay,
53− UTCTime, ZonedTime, formatTime,
54− DayOfWeek (..),
55− nominalDiffTimeToSeconds,
56− secondsToNominalDiffTime)
57−import Data.Time.Format.Compat (defaultTimeLocale,
58− iso8601DateFormat)
59−import Data.Time.Calendar.Month.Compat (Month)
60−import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..),
61− toYearQuarter)
62−import Data.Typeable (Typeable)
63−import qualified Data.UUID.Types as UUID
64−import Data.Version (Version, parseVersion,
65− showVersion)
66−import Data.Void (Void, absurd)
67−import Data.Word (Word16, Word32, Word64, Word8)
68−import qualified Network.HTTP.Types as H
69−import Numeric.Natural (Natural)
39+
40+import Data.Time
41+import Data.Time.Locale.Compat
42+
43+#if MIN_VERSION_time(1,9,1)
44+import Data.Time (nominalDiffTimeToSeconds, secondsToNominalDiffTime)
45+#endif
46+
47+import Data.Version
48+
49+import Data.Void
50+import Numeric.Natural
51+
7052import Text.ParserCombinators.ReadP (readP_to_S)
7153import Text.Read (readMaybe)
72−import Web.Cookie (SetCookie, parseSetCookie,
73− renderSetCookie)
7454
7555#if USE_TEXT_SHOW
7656import TextShow (TextShow, showt)
7757#endif
7858
59+import qualified Data.UUID.Types as UUID
60+
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
65+
66+import qualified Data.Attoparsec.Text as Atto
67+import qualified Data.Attoparsec.Time as Atto
68+
69+import Web.Cookie (SetCookie, parseSetCookie,
70+ renderSetCookie)
71+
72+
7973-- $setup
8074-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
8175-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p
82−-- >>> import Data.Time.Compat
83−-- >>> import Data.Version
8476
8577-- | Convert value to HTTP API data.
8678--
@@ -96,7 +88,7 @@ class ToHttpApiData a where
9688 -- The default definition uses 'H.encodePathSegmentsRelative',
9789 -- but this may be overriden with a more efficient version.
9890 toEncodedUrlPiece :: a -> BS.Builder
99− toEncodedUrlPiece = H.urlEncodeBuilder True . encodeUtf8 . toUrlPiece
91+ toEncodedUrlPiece = H.encodePathSegmentsRelative . (:[]) . toUrlPiece
10092
10193 -- | Convert to HTTP header value.
10294 toHeader :: a -> ByteString
@@ -338,7 +330,7 @@ lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])
338330-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool
339331-- Right True
340332--
341−-- For case insensitive parser see 'parseBoundedEnumOfI'.
333+-- For case sensitive parser see 'parseBoundedEnumOfI'.
342334parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
343335parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf
344336
@@ -459,8 +451,7 @@ instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = un
459451instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
460452instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
461453
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
464455
465456-- |
466457-- >>> toUrlPiece (fromGregorian 2015 10 03)
@@ -500,108 +491,56 @@ instance ToHttpApiData UTCTime where
500491 toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ"
501492 toEncodedUrlPiece = unsafeToEncodedUrlPiece
502493
503−-- |
504−-- >>> toUrlPiece Monday
505−-- "monday"
506−instance ToHttpApiData DayOfWeek where
507− toUrlPiece Monday = "monday"
508− toUrlPiece Tuesday = "tuesday"
509− toUrlPiece Wednesday = "wednesday"
510− toUrlPiece Thursday = "thursday"
511− toUrlPiece Friday = "friday"
512− toUrlPiece Saturday = "saturday"
513− toUrlPiece Sunday = "sunday"
514−
515− toEncodedUrlPiece = unsafeToEncodedUrlPiece
516−
517−-- |
518−-- >>> toUrlPiece Q4
519−-- "q4"
520−instance ToHttpApiData QuarterOfYear where
521− toUrlPiece Q1 = "q1"
522− toUrlPiece Q2 = "q2"
523− toUrlPiece Q3 = "q3"
524− toUrlPiece Q4 = "q4"
525−
526−-- |
527−-- >>> import Data.Time.Calendar.Quarter.Compat (Quarter (..))
528−-- >>> MkQuarter 8040
529−-- 2010-Q1
530−--
531−-- >>> toUrlPiece $ MkQuarter 8040
532−-- "2010-q1"
533−--
534−instance ToHttpApiData Quarter where
535− toUrlPiece q = case toYearQuarter q of
536− (y, qoy) -> T.pack (show y ++ "-" ++ f qoy)
537− where
538− f Q1 = "q1"
539− f Q2 = "q2"
540− f Q3 = "q3"
541− f Q4 = "q4"
494+-- The CPP in both this function and the function after it are to avoid
495+-- exporting @nominalDiffTimeToSeconds@ and @secondsToNominalDiffTime@,
496+-- since these names are already used by @Data.Time@ from the @time@ library
497+-- starting in version @1.9.1@.
498+nominalDiffTimeToSecs :: NominalDiffTime -> F.Pico
499+nominalDiffTimeToSecs =
500+#if !MIN_VERSION_time(1,9,1)
501+ realToFrac
502+#else
503+ nominalDiffTimeToSeconds
504+#endif
542505
543−-- |
544−-- >>> import Data.Time.Calendar.Month.Compat (Month (..))
545−-- >>> MkMonth 24482
546−-- 2040-03
547−--
548−-- >>> toUrlPiece $ MkMonth 24482
549−-- "2040-03"
550−--
551−instance ToHttpApiData Month where
552− toUrlPiece = T.pack . formatTime defaultTimeLocale "%Y-%m"
506+secsToNominalDiffTime :: F.Pico -> NominalDiffTime
507+secsToNominalDiffTime =
508+#if !MIN_VERSION_time(1,9,1)
509+ realToFrac
510+#else
511+ secondsToNominalDiffTime
512+#endif
553513
554514instance ToHttpApiData NominalDiffTime where
555− toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds
515+ toUrlPiece = toUrlPiece . nominalDiffTimeToSecs
556516 toEncodedUrlPiece = unsafeToEncodedUrlPiece
557517
558518instance ToHttpApiData String where toUrlPiece = T.pack
559519instance ToHttpApiData Text where toUrlPiece = id
560520instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
561521
562−instance ToHttpApiData All where
563− toUrlPiece = coerce (toUrlPiece :: Bool -> Text)
564− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder)
565−
566−instance ToHttpApiData Any where
567− toUrlPiece = coerce (toUrlPiece :: Bool -> Text)
568− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder)
522+instance ToHttpApiData All where toUrlPiece = toUrlPiece . getAll; toEncodedUrlPiece = toEncodedUrlPiece . getAll
523+instance ToHttpApiData Any where toUrlPiece = toUrlPiece . getAny; toEncodedUrlPiece = toEncodedUrlPiece . getAny
569524
570525instance ToHttpApiData a => ToHttpApiData (Dual a) where
571− toUrlPiece = coerce (toUrlPiece :: a -> Text)
572− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
526+ toUrlPiece = toUrlPiece . getDual
527+ toEncodedUrlPiece = toEncodedUrlPiece . getDual
573528
574529instance ToHttpApiData a => ToHttpApiData (Sum a) where
575− toUrlPiece = coerce (toUrlPiece :: a -> Text)
576− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
530+ toUrlPiece = toUrlPiece . getSum
531+ toEncodedUrlPiece = toEncodedUrlPiece . getSum
577532
578533instance ToHttpApiData a => ToHttpApiData (Product a) where
579− toUrlPiece = coerce (toUrlPiece :: a -> Text)
580− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
534+ toUrlPiece = toUrlPiece . getProduct
535+ toEncodedUrlPiece = toEncodedUrlPiece . getProduct
581536
582537instance ToHttpApiData a => ToHttpApiData (First a) where
583− toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)
584− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)
538+ toUrlPiece = toUrlPiece . getFirst
539+ toEncodedUrlPiece = toEncodedUrlPiece . getFirst
585540
586541instance ToHttpApiData a => ToHttpApiData (Last a) where
587− toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)
588− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)
589−
590−instance ToHttpApiData a => ToHttpApiData (Semi.Min a) where
591− toUrlPiece = coerce (toUrlPiece :: a -> Text)
592− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
593−
594−instance ToHttpApiData a => ToHttpApiData (Semi.Max a) where
595− toUrlPiece = coerce (toUrlPiece :: a -> Text)
596− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
597−
598−instance ToHttpApiData a => ToHttpApiData (Semi.First a) where
599− toUrlPiece = coerce (toUrlPiece :: a -> Text)
600− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
601−
602−instance ToHttpApiData a => ToHttpApiData (Semi.Last a) where
603− toUrlPiece = coerce (toUrlPiece :: a -> Text)
604− toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
542+ toUrlPiece = toUrlPiece . getLast
543+ toEncodedUrlPiece = toEncodedUrlPiece . getLast
605544
606545-- |
607546-- >>> toUrlPiece (Just "Hello")
@@ -633,27 +572,6 @@ instance ToHttpApiData SetCookie where
633572 toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie
634573 -- toEncodedUrlPiece = renderSetCookie -- doesn't do things.
635574
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)
642−
643−-- | @since 0.4.2
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)
649−
650−-- | @since 0.4.2
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)
656−
657575-- |
658576-- >>> parseUrlPiece "_" :: Either Text ()
659577-- Right ()
@@ -706,8 +624,7 @@ instance FromHttpApiData String where parseUrlPiece = Right . T.unpack
706624instance FromHttpApiData Text where parseUrlPiece = Right
707625instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
708626
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
711628 parseUrlPiece = runReader rational
712629
713630-- |
@@ -738,57 +655,16 @@ instance FromHttpApiData ZonedTime where parseUrlPiece = runAtto Atto.zonedTime
738655-- Right 2015-10-03 00:14:24 UTC
739656instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime
740657
741−-- |
742−-- >>> parseUrlPiece "Monday" :: Either Text DayOfWeek
743−-- Right Monday
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
748− where
749− m :: Map.Map Text DayOfWeek
750− m = Map.fromList [ (toUrlPiece dow, dow) | dow <- [Monday .. Sunday] ]
751−
752−
753−instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secondsToNominalDiffTime . parseUrlPiece
754−
755−-- |
756−-- >>> parseUrlPiece "2021-01" :: Either Text Month
757−-- Right 2021-01
758−instance FromHttpApiData Month where parseUrlPiece = runAtto Atto.month
658+instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secsToNominalDiffTime . parseUrlPiece
759659
760−-- |
761−-- >>> parseUrlPiece "2021-q1" :: Either Text Quarter
762−-- Right 2021-Q1
763−instance FromHttpApiData Quarter where parseUrlPiece = runAtto Atto.quarter
660+instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece
661+instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece
764662
765−-- |
766−-- >>> parseUrlPiece "q2" :: Either Text QuarterOfYear
767−-- Right Q2
768−--
769−-- >>> parseUrlPiece "Q3" :: Either Text QuarterOfYear
770−-- Right Q3
771−instance FromHttpApiData QuarterOfYear where
772− parseUrlPiece t = case T.toLower t of
773− "q1" -> return Q1
774− "q2" -> return Q2
775− "q3" -> return Q3
776− "q4" -> return Q4
777− _ -> Left "Invalid quarter of year"
778−
779−instance FromHttpApiData All where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
780−instance FromHttpApiData Any where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
781−
782−instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
783−instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
784−instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
785−instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a))
786−instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a))
787−
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)
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)
663+instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = fmap Dual . parseUrlPiece
664+instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = fmap Sum . parseUrlPiece
665+instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = fmap Product . parseUrlPiece
666+instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = fmap First . parseUrlPiece
667+instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = fmap Last . parseUrlPiece
792668
793669-- |
794670-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
@@ -839,24 +715,6 @@ instance FromHttpApiData SetCookie where
839715 parseUrlPiece = parseHeader . encodeUtf8
840716 parseHeader = Right . parseSetCookie
841717
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)
847−
848−-- | @since 0.4.2
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)
853−
854−-- | @since 0.4.2
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)
859−
860718-------------------------------------------------------------------------------
861719-- Attoparsec helpers
862720-------------------------------------------------------------------------------