@@ -5,7 +5,9 @@
55{-# LANGUAGE DeriveFunctor #-}
66{-# LANGUAGE DeriveTraversable #-}
77{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE KindSignatures #-}
89{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
911{-# LANGUAGE ScopedTypeVariables #-}
1012{-# LANGUAGE TypeSynonymInstances #-}
1113-- |
@@ -16,6 +18,7 @@ module Web.Internal.HttpApiData where
1618import Prelude ()
1719import Prelude.Compat
1820
21+import Control.Applicative (Const(Const))
1922import Control.Arrow (left, (&&&))
2023import Control.Monad ((<=<))
2124import qualified Data.Attoparsec.Text as Atto
@@ -27,7 +30,10 @@ import qualified Data.ByteString.Lazy as LBS
2730import Data.Coerce (coerce)
2831import Data.Data (Data)
2932import qualified Data.Fixed as F
33+import Data.Functor.Identity (Identity(Identity))
3034import Data.Int (Int16, Int32, Int64, Int8)
35+import Data.Kind (Type)
36+import qualified Data.Map as Map
3137import Data.Monoid (All (..), Any (..), Dual (..),
3238 First (..), Last (..),
3339 Product (..), Sum (..))
@@ -42,11 +48,17 @@ import Data.Text.Encoding.Error (lenientDecode)
4248import qualified Data.Text.Lazy as L
4349import Data.Text.Read (Reader, decimal, rational,
4450 signed)
45−import Data.Time (Day, FormatTime, LocalTime,
51+import Data.Time.Compat (Day, FormatTime, LocalTime,
4652 NominalDiffTime, TimeOfDay,
47− UTCTime, ZonedTime, formatTime)
48−import Data.Time.Locale.Compat (defaultTimeLocale,
53+ UTCTime, ZonedTime, formatTime,
54+ DayOfWeek (..),
55+ nominalDiffTimeToSeconds,
56+ secondsToNominalDiffTime)
57+import Data.Time.Format.Compat (defaultTimeLocale,
4958 iso8601DateFormat)
59+import Data.Time.Calendar.Month.Compat (Month)
60+import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..),
61+ toYearQuarter)
5062import Data.Typeable (Typeable)
5163import qualified Data.UUID.Types as UUID
5264import Data.Version (Version, parseVersion,
@@ -60,22 +72,14 @@ import Text.Read (readMaybe)
6072import Web.Cookie (SetCookie, parseSetCookie,
6173 renderSetCookie)
6274
63−#if MIN_VERSION_time(1,9,1)
64−import Data.Time (nominalDiffTimeToSeconds,
65− secondsToNominalDiffTime)
66−#endif
67−
6875#if USE_TEXT_SHOW
6976import TextShow (TextShow, showt)
7077#endif
7178
72−
73−
74−
7579-- $setup
7680-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
7781-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p
78−-- >>> import Data.Time
82+-- >>> import Data.Time.Compat
7983-- >>> import Data.Version
8084
8185-- | Convert value to HTTP API data.
@@ -92,7 +96,7 @@ class ToHttpApiData a where
9296 -- The default definition uses 'H.encodePathSegmentsRelative',
9397 -- but this may be overriden with a more efficient version.
9498 toEncodedUrlPiece :: a -> BS.Builder
95− toEncodedUrlPiece = H.encodePathSegmentsRelative . (:[]) . toUrlPiece
99+ toEncodedUrlPiece = H.urlEncodeBuilder True . encodeUtf8 . toUrlPiece
96100
97101 -- | Convert to HTTP header value.
98102 toHeader :: a -> ByteString
@@ -334,7 +338,7 @@ lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])
334338-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool
335339-- Right True
336340--
337−-- For case sensitive parser see 'parseBoundedEnumOfI'.
341+-- For case insensitive parser see 'parseBoundedEnumOfI'.
338342parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
339343parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf
340344
@@ -455,7 +459,8 @@ instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = un
455459instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
456460instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
457461
458−instance F.HasResolution a => ToHttpApiData (F.Fixed a) 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
459464
460465-- |
461466-- >>> toUrlPiece (fromGregorian 2015 10 03)
@@ -495,28 +500,59 @@ instance ToHttpApiData UTCTime where
495500 toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ"
496501 toEncodedUrlPiece = unsafeToEncodedUrlPiece
497502
498−-- The CPP in both this function and the function after it are to avoid
499−-- exporting @nominalDiffTimeToSeconds@ and @secondsToNominalDiffTime@,
500−-- since these names are already used by @Data.Time@ from the @time@ library
501−-- starting in version @1.9.1@.
502−nominalDiffTimeToSecs :: NominalDiffTime -> F.Pico
503−nominalDiffTimeToSecs =
504−#if !MIN_VERSION_time(1,9,1)
505− realToFrac
506−#else
507− nominalDiffTimeToSeconds
508−#endif
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"
509514
510−secsToNominalDiffTime :: F.Pico -> NominalDiffTime
511−secsToNominalDiffTime =
512−#if !MIN_VERSION_time(1,9,1)
513− realToFrac
514−#else
515− secondsToNominalDiffTime
516−#endif
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"
542+
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"
517553
518554instance ToHttpApiData NominalDiffTime where
519− toUrlPiece = toUrlPiece . nominalDiffTimeToSecs
555+ toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds
520556 toEncodedUrlPiece = unsafeToEncodedUrlPiece
521557
522558instance ToHttpApiData String where toUrlPiece = T.pack
@@ -597,7 +633,22 @@ instance ToHttpApiData SetCookie where
597633 toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie
598634 -- toEncodedUrlPiece = renderSetCookie -- doesn't do things.
599635
600−instance ToHttpApiData a => ToHttpApiData (Tagged b a) where
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
601652 toUrlPiece = coerce (toUrlPiece :: a -> Text)
602653 toHeader = coerce (toHeader :: a -> ByteString)
603654 toQueryParam = coerce (toQueryParam :: a -> Text)
@@ -655,7 +706,8 @@ instance FromHttpApiData String where parseUrlPiece = Right . T.unpack
655706instance FromHttpApiData Text where parseUrlPiece = Right
656707instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
657708
658−instance F.HasResolution a => FromHttpApiData (F.Fixed a) where
709+-- | Note: this instance is not polykinded
710+instance F.HasResolution a => FromHttpApiData (F.Fixed (a :: Type)) where
659711 parseUrlPiece = runReader rational
660712
661713-- |
@@ -686,7 +738,43 @@ instance FromHttpApiData ZonedTime where parseUrlPiece = runAtto Atto.zonedTime
686738-- Right 2015-10-03 00:14:24 UTC
687739instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime
688740
689−instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secsToNominalDiffTime . parseUrlPiece
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
759+
760+-- |
761+-- >>> parseUrlPiece "2021-q1" :: Either Text Quarter
762+-- Right 2021-Q1
763+instance FromHttpApiData Quarter where parseUrlPiece = runAtto Atto.quarter
764+
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"
690778
691779instance FromHttpApiData All where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
692780instance FromHttpApiData Any where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
@@ -751,7 +839,20 @@ instance FromHttpApiData SetCookie where
751839 parseUrlPiece = parseHeader . encodeUtf8
752840 parseHeader = Right . parseSetCookie
753841
754−instance FromHttpApiData a => FromHttpApiData (Tagged b a) where
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
755856 parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
756857 parseHeader = coerce (parseHeader :: ByteString -> Either Text a)
757858 parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)
@@ -764,5 +865,3 @@ runAtto :: Atto.Parser a -> Text -> Either Text a
764865runAtto p t = case Atto.parseOnly (p <* Atto.endOfInput) t of
765866 Left err -> Left (T.pack err)
766867 Right x -> Right x
767−
768−