@@ -1,64 +1,86 @@
1−{-# LANGUAGE CPP #-}
2−{-# LANGUAGE DefaultSignatures #-}
3−{-# LANGUAGE DeriveDataTypeable #-}
4−{-# LANGUAGE DeriveFunctor #-}
5−{-# LANGUAGE DeriveFoldable #-}
6−{-# LANGUAGE DeriveTraversable #-}
7−{-# LANGUAGE FlexibleInstances #-}
8−{-# LANGUAGE OverloadedStrings #-}
9−{-# LANGUAGE ScopedTypeVariables #-}
1+{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DefaultSignatures #-}
3+{-# LANGUAGE DeriveDataTypeable #-}
4+{-# LANGUAGE DeriveFoldable #-}
5+{-# LANGUAGE DeriveFunctor #-}
6+{-# LANGUAGE DeriveTraversable #-}
7+{-# LANGUAGE FlexibleInstances #-}
8+{-# LANGUAGE KindSignatures #-}
9+{-# LANGUAGE OverloadedStrings #-}
10+{-# LANGUAGE PolyKinds #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
1012{-# LANGUAGE TypeSynonymInstances #-}
1113-- |
1214-- Convert Haskell values to and from HTTP API data
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
21−
22−import Control.Arrow ((&&&), left)
23−import Control.Monad ((<=<))
24−
25−import Data.Monoid
26−import Data.ByteString (ByteString)
27−import qualified Data.ByteString as BS
28−
29−import Data.Int
30−import Data.Word
31−
32−import Data.Text (Text)
33−import Data.Text.Encoding (encodeUtf8, decodeUtf8')
34−import Data.Text.Read (signed, decimal, rational, Reader)
35−import qualified Data.Text as T
36−import qualified Data.Text.Lazy as L
37−
38−import Data.Time.Locale.Compat
39−import Data.Time
40−import Data.Version
41−
42−#if MIN_VERSION_base(4,8,0)
43−import Data.Void
44−import Numeric.Natural
45−#endif
46−
47−import Text.Read (readMaybe)
48−import Text.ParserCombinators.ReadP (readP_to_S)
18+import Prelude ()
19+import Prelude.Compat
20+
21+import Control.Applicative (Const(Const))
22+import Control.Arrow (left, (&&&))
23+import Control.Monad ((<=<))
24+import qualified Data.Attoparsec.Text as Atto
25+import qualified Data.Attoparsec.Time as Atto
26+import Data.ByteString (ByteString)
27+import qualified Data.ByteString as BS
28+import qualified Data.ByteString.Builder as BS
29+import qualified Data.ByteString.Lazy as LBS
30+import Data.Coerce (coerce)
31+import Data.Data (Data)
32+import 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 (..))
43+import Data.Text (Text)
44+import qualified Data.Text as T
45+import Data.Text.Encoding (decodeUtf8', decodeUtf8With,
46+ encodeUtf8)
47+import Data.Text.Encoding.Error (lenientDecode)
48+import qualified Data.Text.Lazy as L
49+import Data.Text.Read (Reader, decimal, rational,
50+ 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)
70+import Text.ParserCombinators.ReadP (readP_to_S)
71+import Text.Read (readMaybe)
72+import Web.Cookie (SetCookie, parseSetCookie,
73+ renderSetCookie)
4974
5075#if USE_TEXT_SHOW
51−import TextShow (TextShow, showt)
76+import TextShow (TextShow, showt)
5277#endif
5378
54−import qualified Data.UUID.Types as UUID
55−
56−import Data.Typeable (Typeable)
57−import Data.Data (Data)
58−
5979-- $setup
6080-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
6181-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p
82+-- >>> import Data.Time.Compat
83+-- >>> import Data.Version
6284
6385-- | Convert value to HTTP API data.
6486--
@@ -70,6 +92,12 @@ class ToHttpApiData a where
7092 toUrlPiece :: a -> Text
7193 toUrlPiece = toQueryParam
7294
95+ -- | Convert to a URL path piece, making sure to encode any special chars.
96+ -- The default definition uses 'H.encodePathSegmentsRelative',
97+ -- but this may be overriden with a more efficient version.
98+ toEncodedUrlPiece :: a -> BS.Builder
99+ toEncodedUrlPiece = H.urlEncodeBuilder True . encodeUtf8 . toUrlPiece
100+
73101 -- | Convert to HTTP header value.
74102 toHeader :: a -> ByteString
75103 toHeader = encodeUtf8 . toUrlPiece
@@ -310,7 +338,7 @@ lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])
310338-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool
311339-- Right True
312340--
313−-- For case sensitive parser see 'parseBoundedEnumOfI'.
341+-- For case insensitive parser see 'parseBoundedEnumOfI'.
314342parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
315343parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf
316344
@@ -355,7 +383,7 @@ parseBoundedHeader bs = case lookupBoundedEnumOf toHeader bs of
355383-- Right 1991-06-02
356384--
357385-- This parser is case sensitive and will not match @'showTextData'@
358−-- in presense of letters:
386+-- in presence of letters:
359387--
360388-- >>> readTextData (showTextData True) :: Either Text Bool
361389-- Left "could not parse: `true'"
@@ -387,79 +415,193 @@ parseBounded reader input = do
387415 l = toInteger (minBound :: a)
388416 h = toInteger (maxBound :: a)
389417
418+-- | Convert to a URL-encoded path piece using 'toUrlPiece'.
419+-- /Note/: this function does not check if the result contains unescaped characters!
420+-- This function can be used to override 'toEncodedUrlPiece' as a more efficient implementation
421+-- when the resulting URL piece /never/ has to be escaped.
422+unsafeToEncodedUrlPiece :: ToHttpApiData a => a -> BS.Builder
423+unsafeToEncodedUrlPiece = BS.byteString . encodeUtf8 . toUrlPiece
424+
390425-- |
391426-- >>> toUrlPiece ()
392427-- "_"
393428instance ToHttpApiData () where
394429 toUrlPiece () = "_"
430+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
395431
396−instance ToHttpApiData Char where toUrlPiece = T.singleton
432+instance ToHttpApiData Char where
433+ toUrlPiece = T.singleton
397434
398435-- |
399436-- >>> toUrlPiece (Version [1, 2, 3] [])
400437-- "1.2.3"
401438instance ToHttpApiData Version where
402439 toUrlPiece = T.pack . showVersion
440+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
403441
404−#if MIN_VERSION_base(4,8,0)
405442instance ToHttpApiData Void where toUrlPiece = absurd
406−instance ToHttpApiData Natural where toUrlPiece = showt
407−#endif
408−
409−instance ToHttpApiData Bool where toUrlPiece = showTextData
410−instance ToHttpApiData Ordering where toUrlPiece = showTextData
411−
412−instance ToHttpApiData Double where toUrlPiece = showt
413−instance ToHttpApiData Float where toUrlPiece = showt
414−instance ToHttpApiData Int where toUrlPiece = showt
415−instance ToHttpApiData Int8 where toUrlPiece = showt
416−instance ToHttpApiData Int16 where toUrlPiece = showt
417−instance ToHttpApiData Int32 where toUrlPiece = showt
418−instance ToHttpApiData Int64 where toUrlPiece = showt
419−instance ToHttpApiData Integer where toUrlPiece = showt
420−instance ToHttpApiData Word where toUrlPiece = showt
421−instance ToHttpApiData Word8 where toUrlPiece = showt
422−instance ToHttpApiData Word16 where toUrlPiece = showt
423−instance ToHttpApiData Word32 where toUrlPiece = showt
424−instance ToHttpApiData Word64 where toUrlPiece = showt
443+instance ToHttpApiData Natural where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
444+
445+instance ToHttpApiData Bool where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece
446+instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece
447+
448+instance ToHttpApiData Double where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
449+instance ToHttpApiData Float where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
450+instance ToHttpApiData Int where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
451+instance ToHttpApiData Int8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
452+instance ToHttpApiData Int16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
453+instance ToHttpApiData Int32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
454+instance ToHttpApiData Int64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
455+instance ToHttpApiData Integer where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
456+instance ToHttpApiData Word where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
457+instance ToHttpApiData Word8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
458+instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
459+instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
460+instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
461+
462+-- | Note: this instance is not polykinded
463+instance F.HasResolution a => ToHttpApiData (F.Fixed (a :: Type)) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
425464
426465-- |
427466-- >>> toUrlPiece (fromGregorian 2015 10 03)
428467-- "2015-10-03"
429−instance ToHttpApiData Day where toUrlPiece = T.pack . show
468+instance ToHttpApiData Day where
469+ toUrlPiece = T.pack . show
470+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
430471
431472timeToUrlPiece :: FormatTime t => String -> t -> Text
432473timeToUrlPiece fmt = T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just fmt))
433474
434475-- |
435−-- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 01)
436−-- "2015-10-03T14:55:01"
437−instance ToHttpApiData LocalTime where toUrlPiece = timeToUrlPiece "%H:%M:%S"
476+-- >>> toUrlPiece $ TimeOfDay 14 55 23.1
477+-- "14:55:23.1"
478+instance ToHttpApiData TimeOfDay where
479+ toUrlPiece = T.pack . formatTime defaultTimeLocale "%H:%M:%S%Q"
480+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
481+
482+-- |
483+-- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 21.687)
484+-- "2015-10-03T14:55:21.687"
485+instance ToHttpApiData LocalTime where
486+ toUrlPiece = timeToUrlPiece "%H:%M:%S%Q"
487+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
488+
489+-- |
490+-- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 51.001)) utc
491+-- "2015-10-03T14:55:51.001+0000"
492+instance ToHttpApiData ZonedTime where
493+ toUrlPiece = timeToUrlPiece "%H:%M:%S%Q%z"
494+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
495+
496+-- |
497+-- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864.5
498+-- "2015-10-03T00:14:24.5Z"
499+instance ToHttpApiData UTCTime where
500+ toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ"
501+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
438502
439503-- |
440−-- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 01)) utc
441−-- "2015-10-03T14:55:01+0000"
442−instance ToHttpApiData ZonedTime where toUrlPiece = timeToUrlPiece "%H:%M:%S%z"
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"
443542
444543-- |
445−-- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864
446−-- "2015-10-03T00:14:24Z"
447−instance ToHttpApiData UTCTime where toUrlPiece = timeToUrlPiece "%H:%M:%SZ"
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"
448553
449−instance ToHttpApiData NominalDiffTime where toUrlPiece = toUrlPiece . (floor :: NominalDiffTime -> Integer)
554+instance ToHttpApiData NominalDiffTime where
555+ toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds
556+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
450557
451558instance ToHttpApiData String where toUrlPiece = T.pack
452559instance ToHttpApiData Text where toUrlPiece = id
453560instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
454561
455−instance ToHttpApiData All where toUrlPiece = toUrlPiece . getAll
456−instance ToHttpApiData Any where toUrlPiece = toUrlPiece . 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)
569+
570+instance ToHttpApiData a => ToHttpApiData (Dual a) where
571+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
572+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
573+
574+instance ToHttpApiData a => ToHttpApiData (Sum a) where
575+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
576+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
577+
578+instance ToHttpApiData a => ToHttpApiData (Product a) where
579+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
580+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
457581
458−instance ToHttpApiData a => ToHttpApiData (Dual a) where toUrlPiece = toUrlPiece . getDual
459−instance ToHttpApiData a => ToHttpApiData (Sum a) where toUrlPiece = toUrlPiece . getSum
460−instance ToHttpApiData a => ToHttpApiData (Product a) where toUrlPiece = toUrlPiece . getProduct
461−instance ToHttpApiData a => ToHttpApiData (First a) where toUrlPiece = toUrlPiece . getFirst
462−instance ToHttpApiData a => ToHttpApiData (Last a) where toUrlPiece = toUrlPiece . getLast
582+instance ToHttpApiData a => ToHttpApiData (First a) where
583+ toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)
584+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)
585+
586+instance 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)
463605
464606-- |
465607-- >>> toUrlPiece (Just "Hello")
@@ -477,6 +619,41 @@ instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where
477619 toUrlPiece (Left x) = "left " <> toUrlPiece x
478620 toUrlPiece (Right x) = "right " <> toUrlPiece x
479621
622+-- | /Note:/ this instance works correctly for alphanumeric name and value
623+--
624+-- >>> let Right c = parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie
625+-- >>> toUrlPiece c
626+-- "SESSID=r2t5uvjq435r4q7ib3vtdjq120"
627+--
628+-- >>> toHeader c
629+-- "SESSID=r2t5uvjq435r4q7ib3vtdjq120"
630+--
631+instance ToHttpApiData SetCookie where
632+ toUrlPiece = decodeUtf8With lenientDecode . toHeader
633+ toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie
634+ -- toEncodedUrlPiece = renderSetCookie -- doesn't do things.
635+
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+
480657-- |
481658-- >>> parseUrlPiece "_" :: Either Text ()
482659-- Right ()
@@ -488,7 +665,7 @@ instance FromHttpApiData Char where
488665 parseUrlPiece s =
489666 case T.uncons s of
490667 Just (c, s') | T.null s' -> pure c
491− _ -> defaultParseError s
668+ _ -> defaultParseError s
492669
493670-- |
494671-- >>> showVersion <$> parseUrlPiece "1.2.3"
@@ -499,7 +676,6 @@ instance FromHttpApiData Version where
499676 ((x, ""):_) -> pure x
500677 _ -> defaultParseError s
501678
502−#if MIN_VERSION_base(4,8,0)
503679-- | Parsing a @'Void'@ value is always an error, considering @'Void'@ as a data type with no constructors.
504680instance FromHttpApiData Void where
505681 parseUrlPiece _ = Left "Void cannot be parsed!"
@@ -510,7 +686,6 @@ instance FromHttpApiData Natural where
510686 if n < 0
511687 then Left ("underflow: " <> s <> " (should be a non-negative integer)")
512688 else Right (fromInteger n)
513−#endif
514689
515690instance FromHttpApiData Bool where parseUrlPiece = parseBoundedUrlPiece
516691instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece
@@ -531,41 +706,89 @@ instance FromHttpApiData String where parseUrlPiece = Right . T.unpack
531706instance FromHttpApiData Text where parseUrlPiece = Right
532707instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
533708
709+-- | Note: this instance is not polykinded
710+instance F.HasResolution a => FromHttpApiData (F.Fixed (a :: Type)) where
711+ parseUrlPiece = runReader rational
712+
534713-- |
535714-- >>> toGregorian <$> parseUrlPiece "2016-12-01"
536715-- Right (2016,12,1)
537−instance FromHttpApiData Day where parseUrlPiece = readTextData
716+instance FromHttpApiData Day where parseUrlPiece = runAtto Atto.day
538717
539−timeParseUrlPiece :: ParseTime t => String -> Text -> Either Text t
540−timeParseUrlPiece fmt = parseMaybeTextData (timeParseUrlPieceMaybe . T.unpack)
541− where
542− timeParseUrlPieceMaybe = parseTime defaultTimeLocale (iso8601DateFormat (Just fmt))
718+-- |
719+-- >>> parseUrlPiece "14:55:01.333" :: Either Text TimeOfDay
720+-- Right 14:55:01.333
721+instance FromHttpApiData TimeOfDay where parseUrlPiece = runAtto Atto.timeOfDay
543722
544723-- |
545724-- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime
546725-- Right 2015-10-03 14:55:01
547−instance FromHttpApiData LocalTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%S"
726+instance FromHttpApiData LocalTime where parseUrlPiece = runAtto Atto.localTime
548727
549728-- |
550729-- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime
551730-- Right 2015-10-03 14:55:01 +0000
552−instance FromHttpApiData ZonedTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%S%z"
731+--
732+-- >>> parseQueryParam "2016-12-31T01:00:00Z" :: Either Text ZonedTime
733+-- Right 2016-12-31 01:00:00 +0000
734+instance FromHttpApiData ZonedTime where parseUrlPiece = runAtto Atto.zonedTime
553735
554736-- |
555737-- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime
556738-- Right 2015-10-03 00:14:24 UTC
557−instance FromHttpApiData UTCTime where parseUrlPiece = timeParseUrlPiece "%H:%M:%SZ"
739+instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime
558740
559−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] ]
560751
561−instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece
562−instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece
563752
564−instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = fmap Dual . parseUrlPiece
565−instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = fmap Sum . parseUrlPiece
566−instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = fmap Product . parseUrlPiece
567−instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = fmap First . parseUrlPiece
568−instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = fmap Last . parseUrlPiece
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"
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)
569792
570793-- |
571794-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
@@ -590,6 +813,7 @@ instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b)
590813instance ToHttpApiData UUID.UUID where
591814 toUrlPiece = UUID.toText
592815 toHeader = UUID.toASCIIBytes
816+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
593817
594818instance FromHttpApiData UUID.UUID where
595819 parseUrlPiece = maybe (Left "invalid UUID") Right . UUID.fromText
@@ -606,3 +830,38 @@ instance FromHttpApiData a => FromHttpApiData (LenientData a) where
606830 parseUrlPiece = Right . LenientData . parseUrlPiece
607831 parseHeader = Right . LenientData . parseHeader
608832 parseQueryParam = Right . LenientData . parseQueryParam
833+
834+-- | /Note:/ this instance works correctly for alphanumeric name and value
835+--
836+-- >>> parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie
837+-- Right (SetCookie {setCookieName = "SESSID", setCookieValue = "r2t5uvjq435r4q7ib3vtdjq120", setCookiePath = Nothing, setCookieExpires = Nothing, setCookieMaxAge = Nothing, setCookieDomain = Nothing, setCookieHttpOnly = False, setCookieSecure = False, setCookieSameSite = Nothing})
838+instance FromHttpApiData SetCookie where
839+ parseUrlPiece = parseHeader . encodeUtf8
840+ parseHeader = Right . parseSetCookie
841+
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+
860+-------------------------------------------------------------------------------
861+-- Attoparsec helpers
862+-------------------------------------------------------------------------------
863+
864+runAtto :: Atto.Parser a -> Text -> Either Text a
865+runAtto p t = case Atto.parseOnly (p <* Atto.endOfInput) t of
866+ Left err -> Left (T.pack err)
867+ Right x -> Right x