@@ -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-- |
@@ -13,67 +15,72 @@
1315-- such as URL pieces, headers and query parameters.
1416module Web.Internal.HttpApiData where
1517
16−#if __GLASGOW_HASKELL__ < 710
17−import Control.Applicative
18−import Data.Foldable (Foldable)
19−import Data.Traversable (Traversable (traverse))
20−#endif
18+import Prelude ()
19+import Prelude.Compat
2120
21+import Control.Applicative (Const(Const))
2222import Control.Arrow (left, (&&&))
2323import Control.Monad ((<=<))
24−
24+import qualified Data.Attoparsec.Text as Atto
25+import qualified Data.Attoparsec.Time as Atto
2526import Data.ByteString (ByteString)
2627import qualified Data.ByteString as BS
28+import qualified Data.ByteString.Builder as BS
2729import qualified Data.ByteString.Lazy as LBS
28−import Data.Monoid
29−
30+import Data.Coerce (coerce)
31+import Data.Data (Data)
3032import qualified Data.Fixed as F
31−import Data.Int
32−import Data.Word
33−
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 (..))
3443import Data.Text (Text)
3544import qualified Data.Text as T
36−import Data.Text.Encoding (decodeUtf8With, decodeUtf8', encodeUtf8)
45+import Data.Text.Encoding (decodeUtf8', decodeUtf8With,
46+ encodeUtf8)
3747import Data.Text.Encoding.Error (lenientDecode)
3848import qualified Data.Text.Lazy as L
3949import Data.Text.Read (Reader, decimal, rational,
4050 signed)
41−
42−import Data.Time
43−#if __GLASGOW_HASKELL__ < 710
44−import Data.Time.Locale.Compat
45−#endif
46−import Data.Version
47−
48−#if MIN_VERSION_base(4,8,0)
49−import Data.Void
50−import Numeric.Natural
51−#endif
52−
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)
5370import Text.ParserCombinators.ReadP (readP_to_S)
5471import Text.Read (readMaybe)
72+import Web.Cookie (SetCookie, parseSetCookie,
73+ renderSetCookie)
5574
5675#if USE_TEXT_SHOW
5776import TextShow (TextShow, showt)
5877#endif
5978
60−import qualified Data.UUID.Types as UUID
61−
62−import qualified Data.ByteString.Builder as BS
63−import Data.Data (Data)
64−import Data.Typeable (Typeable)
65−import qualified Network.HTTP.Types as H
66−
67−import qualified Data.Attoparsec.Text as Atto
68−import qualified Data.Attoparsec.Time as Atto
69−
70−import Web.Cookie (SetCookie, parseSetCookie,
71− renderSetCookie)
72−
73−
7479-- $setup
7580-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
7681-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p
82+-- >>> import Data.Time.Compat
83+-- >>> import Data.Version
7784
7885-- | Convert value to HTTP API data.
7986--
@@ -89,7 +96,7 @@ class ToHttpApiData a where
8996 -- The default definition uses 'H.encodePathSegmentsRelative',
9097 -- but this may be overriden with a more efficient version.
9198 toEncodedUrlPiece :: a -> BS.Builder
92− toEncodedUrlPiece = H.encodePathSegmentsRelative . (:[]) . toUrlPiece
99+ toEncodedUrlPiece = H.urlEncodeBuilder True . encodeUtf8 . toUrlPiece
93100
94101 -- | Convert to HTTP header value.
95102 toHeader :: a -> ByteString
@@ -331,7 +338,7 @@ lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])
331338-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool
332339-- Right True
333340--
334−-- For case sensitive parser see 'parseBoundedEnumOfI'.
341+-- For case insensitive parser see 'parseBoundedEnumOfI'.
335342parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
336343parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf
337344
@@ -432,10 +439,8 @@ instance ToHttpApiData Version where
432439 toUrlPiece = T.pack . showVersion
433440 toEncodedUrlPiece = unsafeToEncodedUrlPiece
434441
435−#if MIN_VERSION_base(4,8,0)
436442instance ToHttpApiData Void where toUrlPiece = absurd
437443instance ToHttpApiData Natural where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
438−#endif
439444
440445instance ToHttpApiData Bool where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece
441446instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece
@@ -454,7 +459,8 @@ instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = un
454459instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
455460instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
456461
457−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
458464
459465-- |
460466-- >>> toUrlPiece (fromGregorian 2015 10 03)
@@ -494,36 +500,108 @@ instance ToHttpApiData UTCTime where
494500 toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ"
495501 toEncodedUrlPiece = unsafeToEncodedUrlPiece
496502
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"
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"
553+
497554instance ToHttpApiData NominalDiffTime where
498− toUrlPiece = toUrlPiece . (floor :: NominalDiffTime -> Integer)
555+ toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds
499556 toEncodedUrlPiece = unsafeToEncodedUrlPiece
500557
501558instance ToHttpApiData String where toUrlPiece = T.pack
502559instance ToHttpApiData Text where toUrlPiece = id
503560instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
504561
505−instance ToHttpApiData All where toUrlPiece = toUrlPiece . getAll; toEncodedUrlPiece = toEncodedUrlPiece . getAll
506−instance ToHttpApiData Any where toUrlPiece = toUrlPiece . getAny; toEncodedUrlPiece = toEncodedUrlPiece . getAny
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)
507569
508570instance ToHttpApiData a => ToHttpApiData (Dual a) where
509− toUrlPiece = toUrlPiece . getDual
510− toEncodedUrlPiece = toEncodedUrlPiece . getDual
571+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
572+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
511573
512574instance ToHttpApiData a => ToHttpApiData (Sum a) where
513− toUrlPiece = toUrlPiece . getSum
514− toEncodedUrlPiece = toEncodedUrlPiece . getSum
575+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
576+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
515577
516578instance ToHttpApiData a => ToHttpApiData (Product a) where
517− toUrlPiece = toUrlPiece . getProduct
518− toEncodedUrlPiece = toEncodedUrlPiece . getProduct
579+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
580+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
519581
520582instance ToHttpApiData a => ToHttpApiData (First a) where
521− toUrlPiece = toUrlPiece . getFirst
522− toEncodedUrlPiece = toEncodedUrlPiece . getFirst
583+ toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)
584+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)
523585
524586instance ToHttpApiData a => ToHttpApiData (Last a) where
525− toUrlPiece = toUrlPiece . getLast
526− toEncodedUrlPiece = toEncodedUrlPiece . getLast
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)
527605
528606-- |
529607-- >>> toUrlPiece (Just "Hello")
@@ -555,6 +633,27 @@ instance ToHttpApiData SetCookie where
555633 toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie
556634 -- toEncodedUrlPiece = renderSetCookie -- doesn't do things.
557635
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+
558657-- |
559658-- >>> parseUrlPiece "_" :: Either Text ()
560659-- Right ()
@@ -566,7 +665,7 @@ instance FromHttpApiData Char where
566665 parseUrlPiece s =
567666 case T.uncons s of
568667 Just (c, s') | T.null s' -> pure c
569− _ -> defaultParseError s
668+ _ -> defaultParseError s
570669
571670-- |
572671-- >>> showVersion <$> parseUrlPiece "1.2.3"
@@ -577,7 +676,6 @@ instance FromHttpApiData Version where
577676 ((x, ""):_) -> pure x
578677 _ -> defaultParseError s
579678
580−#if MIN_VERSION_base(4,8,0)
581679-- | Parsing a @'Void'@ value is always an error, considering @'Void'@ as a data type with no constructors.
582680instance FromHttpApiData Void where
583681 parseUrlPiece _ = Left "Void cannot be parsed!"
@@ -588,7 +686,6 @@ instance FromHttpApiData Natural where
588686 if n < 0
589687 then Left ("underflow: " <> s <> " (should be a non-negative integer)")
590688 else Right (fromInteger n)
591−#endif
592689
593690instance FromHttpApiData Bool where parseUrlPiece = parseBoundedUrlPiece
594691instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece
@@ -609,7 +706,8 @@ instance FromHttpApiData String where parseUrlPiece = Right . T.unpack
609706instance FromHttpApiData Text where parseUrlPiece = Right
610707instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
611708
612−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
613711 parseUrlPiece = runReader rational
614712
615713-- |
@@ -640,16 +738,57 @@ instance FromHttpApiData ZonedTime where parseUrlPiece = runAtto Atto.zonedTime
640738-- Right 2015-10-03 00:14:24 UTC
641739instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime
642740
643−instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap fromInteger . 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
644759
645−instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece
646−instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece
760+-- |
761+-- >>> parseUrlPiece "2021-q1" :: Either Text Quarter
762+-- Right 2021-Q1
763+instance FromHttpApiData Quarter where parseUrlPiece = runAtto Atto.quarter
647764
648−instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = fmap Dual . parseUrlPiece
649−instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = fmap Sum . parseUrlPiece
650−instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = fmap Product . parseUrlPiece
651−instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = fmap First . parseUrlPiece
652−instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = fmap Last . parseUrlPiece
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)
653792
654793-- |
655794-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
@@ -700,6 +839,24 @@ instance FromHttpApiData SetCookie where
700839 parseUrlPiece = parseHeader . encodeUtf8
701840 parseHeader = Right . parseSetCookie
702841
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+
703860-------------------------------------------------------------------------------
704861-- Attoparsec helpers
705862-------------------------------------------------------------------------------