@@ -0,0 +1,867 @@
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 #-}
12+{-# LANGUAGE TypeSynonymInstances #-}
14+-- Convert Haskell values to and from HTTP API data
15+-- such as URL pieces, headers and query parameters.
16+module Web.Internal.HttpApiData where
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,
47+import Data.Text.Encoding.Error (lenientDecode)
48+import qualified Data.Text.Lazy as L
49+import Data.Text.Read (Reader, decimal, rational,
51+import Data.Time.Compat (Day, FormatTime, LocalTime,
52+ NominalDiffTime, TimeOfDay,
53+ UTCTime, ZonedTime, formatTime,
55+ nominalDiffTimeToSeconds,
56+ secondsToNominalDiffTime)
57+import Data.Time.Format.Compat (defaultTimeLocale,
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,
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,
76+import TextShow (TextShow, showt)
80+-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
81+-- >>> 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.
87+-- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated
88+-- instance will loop indefinitely.
89+class ToHttpApiData a where
90+ {-# MINIMAL toUrlPiece | toQueryParam #-}
91+ -- | Convert to URL path piece.
92+ toUrlPiece :: a -> Text
93+ toUrlPiece = toQueryParam
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
101+ -- | Convert to HTTP header value.
102+ toHeader :: a -> ByteString
103+ toHeader = encodeUtf8 . toUrlPiece
105+ -- | Convert to query param value.
106+ toQueryParam :: a -> Text
107+ toQueryParam = toUrlPiece
109+-- | Parse value from HTTP API data.
111+-- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated
112+-- instance will loop indefinitely.
113+class FromHttpApiData a where
114+ {-# MINIMAL parseUrlPiece | parseQueryParam #-}
115+ -- | Parse URL path piece.
116+ parseUrlPiece :: Text -> Either Text a
117+ parseUrlPiece = parseQueryParam
119+ -- | Parse HTTP header value.
120+ parseHeader :: ByteString -> Either Text a
121+ parseHeader = parseUrlPiece <=< (left (T.pack . show) . decodeUtf8')
123+ -- | Parse query param value.
124+ parseQueryParam :: Text -> Either Text a
125+ parseQueryParam = parseUrlPiece
127+-- | Convert multiple values to a list of URL pieces.
129+-- >>> toUrlPieces [1, 2, 3] :: [Text]
131+toUrlPieces :: (Functor t, ToHttpApiData a) => t a -> t Text
132+toUrlPieces = fmap toUrlPiece
134+-- | Parse multiple URL pieces.
136+-- >>> parseUrlPieces ["true", "false"] :: Either Text [Bool]
137+-- Right [True,False]
138+-- >>> parseUrlPieces ["123", "hello", "world"] :: Either Text [Int]
139+-- Left "could not parse: `hello' (input does not start with a digit)"
140+parseUrlPieces :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)
141+parseUrlPieces = traverse parseUrlPiece
143+-- | Convert multiple values to a list of query parameter values.
145+-- >>> toQueryParams [fromGregorian 2015 10 03, fromGregorian 2015 12 01] :: [Text]
146+-- ["2015-10-03","2015-12-01"]
147+toQueryParams :: (Functor t, ToHttpApiData a) => t a -> t Text
148+toQueryParams = fmap toQueryParam
150+-- | Parse multiple query parameters.
152+-- >>> parseQueryParams ["1", "2", "3"] :: Either Text [Int]
154+-- >>> parseQueryParams ["64", "128", "256"] :: Either Text [Word8]
155+-- Left "out of bounds: `256' (should be between 0 and 255)"
156+parseQueryParams :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)
157+parseQueryParams = traverse parseQueryParam
159+-- | Parse URL path piece in a @'Maybe'@.
161+-- >>> parseUrlPieceMaybe "12" :: Maybe Int
163+parseUrlPieceMaybe :: FromHttpApiData a => Text -> Maybe a
164+parseUrlPieceMaybe = either (const Nothing) Just . parseUrlPiece
166+-- | Parse HTTP header value in a @'Maybe'@.
168+-- >>> parseHeaderMaybe "hello" :: Maybe Text
170+parseHeaderMaybe :: FromHttpApiData a => ByteString -> Maybe a
171+parseHeaderMaybe = either (const Nothing) Just . parseHeader
173+-- | Parse query param value in a @'Maybe'@.
175+-- >>> parseQueryParamMaybe "true" :: Maybe Bool
177+parseQueryParamMaybe :: FromHttpApiData a => Text -> Maybe a
178+parseQueryParamMaybe = either (const Nothing) Just . parseQueryParam
180+-- | Default parsing error.
181+defaultParseError :: Text -> Either Text a
182+defaultParseError input = Left ("could not parse: `" <> input <> "'")
184+-- | Convert @'Maybe'@ parser into @'Either' 'Text'@ parser with default error message.
185+parseMaybeTextData :: (Text -> Maybe a) -> (Text -> Either Text a)
186+parseMaybeTextData parse input =
188+ Nothing -> defaultParseError input
189+ Just val -> Right val
194+-- Convert to URL piece using @'TextShow'@ instance.
195+-- The result is always lower cased.
197+-- >>> showTextData True
200+-- This can be used as a default implementation for enumeration types:
203+-- data MyData = Foo | Bar | Baz deriving (Generic)
205+-- instance TextShow MyData where
206+-- showt = genericShowt
208+-- instance ToHttpApiData MyData where
209+-- toUrlPiece = showTextData
211+showTextData :: TextShow a => a -> Text
212+showTextData = T.toLower . showt
216+-- Convert to URL piece using @'Show'@ instance.
217+-- The result is always lower cased.
219+-- >>> showTextData True
222+-- This can be used as a default implementation for enumeration types:
224+-- >>> data MyData = Foo | Bar | Baz deriving (Show)
225+-- >>> instance ToHttpApiData MyData where toUrlPiece = showTextData
226+-- >>> toUrlPiece Foo
228+showTextData :: Show a => a -> Text
229+showTextData = T.toLower . showt
231+-- | Like @'show'@, but returns @'Text'@.
232+showt :: Show a => a -> Text
233+showt = T.pack . show
236+-- | /Case insensitive/.
238+-- Parse given text case insensitive and then parse the rest of the input
239+-- using @'parseUrlPiece'@.
241+-- >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int
243+-- >>> parseUrlPieceWithPrefix "Left " "left" :: Either Text Bool
244+-- Left "could not parse: `left'"
246+-- This can be used to implement @'FromHttpApiData'@ for single field constructors:
248+-- >>> data Foo = Foo Int deriving (Show)
249+-- >>> instance FromHttpApiData Foo where parseUrlPiece s = Foo <$> parseUrlPieceWithPrefix "Foo " s
250+-- >>> parseUrlPiece "foo 1" :: Either Text Foo
252+parseUrlPieceWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a
253+parseUrlPieceWithPrefix pattern input
254+ | T.toLower pattern == T.toLower prefix = parseUrlPiece rest
255+ | otherwise = defaultParseError input
257+ (prefix, rest) = T.splitAt (T.length pattern) input
259+-- | Parse given bytestring then parse the rest of the input using @'parseHeader'@.
262+-- data BasicAuthToken = BasicAuthToken Text deriving (Show)
264+-- instance FromHttpApiData BasicAuthToken where
265+-- parseHeader h = BasicAuthToken \<$\> parseHeaderWithPrefix "Basic " h
266+-- parseQueryParam p = BasicAuthToken \<$\> parseQueryParam p
269+-- >>> parseHeader "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" :: Either Text BasicAuthToken
270+-- Right (BasicAuthToken "QWxhZGRpbjpvcGVuIHNlc2FtZQ==")
271+parseHeaderWithPrefix :: FromHttpApiData a => ByteString -> ByteString -> Either Text a
272+parseHeaderWithPrefix pattern input
273+ | pattern `BS.isPrefixOf` input = parseHeader (BS.drop (BS.length pattern) input)
274+ | otherwise = defaultParseError (showt input)
276+-- | /Case insensitive/.
278+-- Parse given text case insensitive and then parse the rest of the input
279+-- using @'parseQueryParam'@.
281+-- >>> parseQueryParamWithPrefix "z" "z10" :: Either Text Int
283+parseQueryParamWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a
284+parseQueryParamWithPrefix pattern input
285+ | T.toLower pattern == T.toLower prefix = parseQueryParam rest
286+ | otherwise = defaultParseError input
288+ (prefix, rest) = T.splitAt (T.length pattern) input
291+-- | /Case insensitive/.
293+-- Parse values case insensitively based on @'TextShow'@ instance.
295+-- >>> parseBoundedTextData "true" :: Either Text Bool
297+-- >>> parseBoundedTextData "FALSE" :: Either Text Bool
300+-- This can be used as a default implementation for enumeration types:
303+-- data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum, Generic)
305+-- instance TextShow MyData where
306+-- showt = genericShowt
308+-- instance FromHttpApiData MyData where
309+-- parseUrlPiece = parseBoundedTextData
311+parseBoundedTextData :: (TextShow a, Bounded a, Enum a) => Text -> Either Text a
313+-- | /Case insensitive/.
315+-- Parse values case insensitively based on @'Show'@ instance.
317+-- >>> parseBoundedTextData "true" :: Either Text Bool
319+-- >>> parseBoundedTextData "FALSE" :: Either Text Bool
322+-- This can be used as a default implementation for enumeration types:
324+-- >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum)
325+-- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedTextData
326+-- >>> parseUrlPiece "foo" :: Either Text MyData
328+parseBoundedTextData :: (Show a, Bounded a, Enum a) => Text -> Either Text a
330+parseBoundedTextData = parseBoundedEnumOfI showTextData
332+-- | Lookup values based on a precalculated mapping of their representations.
333+lookupBoundedEnumOf :: (Bounded a, Enum a, Eq b) => (a -> b) -> b -> Maybe a
334+lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])
336+-- | Parse values based on a precalculated mapping of their @'Text'@ representation.
338+-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool
341+-- For case insensitive parser see 'parseBoundedEnumOfI'.
342+parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
343+parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf
345+-- | /Case insensitive/.
347+-- Parse values case insensitively based on a precalculated mapping
348+-- of their @'Text'@ representations.
350+-- >>> parseBoundedEnumOfI toUrlPiece "FALSE" :: Either Text Bool
353+-- For case sensitive parser see 'parseBoundedEnumOf'.
354+parseBoundedEnumOfI :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
355+parseBoundedEnumOfI f = parseBoundedEnumOf (T.toLower . f) . T.toLower
357+-- | /Case insensitive/.
359+-- Parse values case insensitively based on @'ToHttpApiData'@ instance.
360+-- Uses @'toUrlPiece'@ to get possible values.
361+parseBoundedUrlPiece :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a
362+parseBoundedUrlPiece = parseBoundedEnumOfI toUrlPiece
364+-- | /Case insensitive/.
366+-- Parse values case insensitively based on @'ToHttpApiData'@ instance.
367+-- Uses @'toQueryParam'@ to get possible values.
368+parseBoundedQueryParam :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a
369+parseBoundedQueryParam = parseBoundedEnumOfI toQueryParam
371+-- | Parse values based on @'ToHttpApiData'@ instance.
372+-- Uses @'toHeader'@ to get possible values.
373+parseBoundedHeader :: (ToHttpApiData a, Bounded a, Enum a) => ByteString -> Either Text a
374+parseBoundedHeader bs = case lookupBoundedEnumOf toHeader bs of
375+ Nothing -> defaultParseError $ T.pack $ show bs
378+-- | Parse URL piece using @'Read'@ instance.
380+-- Use for types which do not involve letters:
382+-- >>> readTextData "1991-06-02" :: Either Text Day
385+-- This parser is case sensitive and will not match @'showTextData'@
386+-- in presence of letters:
388+-- >>> readTextData (showTextData True) :: Either Text Bool
389+-- Left "could not parse: `true'"
391+-- See @'parseBoundedTextData'@.
392+readTextData :: Read a => Text -> Either Text a
393+readTextData = parseMaybeTextData (readMaybe . T.unpack)
395+-- | Run @'Reader'@ as HTTP API data parser.
396+runReader :: Reader a -> Text -> Either Text a
397+runReader reader input =
398+ case reader input of
399+ Left err -> Left ("could not parse: `" <> input <> "' (" <> T.pack err <> ")")
401+ | T.null rest -> Right x
402+ | otherwise -> defaultParseError input
404+-- | Run @'Reader'@ to parse bounded integral value with bounds checking.
406+-- >>> parseBounded decimal "256" :: Either Text Word8
407+-- Left "out of bounds: `256' (should be between 0 and 255)"
408+parseBounded :: forall a. (Bounded a, Integral a) => Reader Integer -> Text -> Either Text a
409+parseBounded reader input = do
410+ n <- runReader reader input
412+ then Left ("out of bounds: `" <> input <> "' (should be between " <> showt l <> " and " <> showt h <> ")")
413+ else Right (fromInteger n)
415+ l = toInteger (minBound :: a)
416+ h = toInteger (maxBound :: a)
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
428+instance ToHttpApiData () where
430+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
432+instance ToHttpApiData Char where
433+ toUrlPiece = T.singleton
436+-- >>> toUrlPiece (Version [1, 2, 3] [])
438+instance ToHttpApiData Version where
439+ toUrlPiece = T.pack . showVersion
440+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
442+instance ToHttpApiData Void where toUrlPiece = absurd
443+instance ToHttpApiData Natural where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
445+instance ToHttpApiData Bool where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece
446+instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece
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
462+-- | Note: this instance is not polykinded
463+instance F.HasResolution a => ToHttpApiData (F.Fixed (a :: Type)) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
466+-- >>> toUrlPiece (fromGregorian 2015 10 03)
468+instance ToHttpApiData Day where
469+ toUrlPiece = T.pack . show
470+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
472+timeToUrlPiece :: FormatTime t => String -> t -> Text
473+timeToUrlPiece fmt = T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just fmt))
476+-- >>> toUrlPiece $ TimeOfDay 14 55 23.1
478+instance ToHttpApiData TimeOfDay where
479+ toUrlPiece = T.pack . formatTime defaultTimeLocale "%H:%M:%S%Q"
480+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
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
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
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
504+-- >>> toUrlPiece 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"
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)
544+-- >>> import Data.Time.Calendar.Month.Compat (Month (..))
548+-- >>> toUrlPiece $ MkMonth 24482
551+instance ToHttpApiData Month where
552+ toUrlPiece = T.pack . formatTime defaultTimeLocale "%Y-%m"
554+instance ToHttpApiData NominalDiffTime where
555+ toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds
556+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
558+instance ToHttpApiData String where toUrlPiece = T.pack
559+instance ToHttpApiData Text where toUrlPiece = id
560+instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
562+instance ToHttpApiData All where
563+ toUrlPiece = coerce (toUrlPiece :: Bool -> Text)
564+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder)
566+instance ToHttpApiData Any where
567+ toUrlPiece = coerce (toUrlPiece :: Bool -> Text)
568+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder)
570+instance ToHttpApiData a => ToHttpApiData (Dual a) where
571+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
572+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
574+instance ToHttpApiData a => ToHttpApiData (Sum a) where
575+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
576+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
578+instance ToHttpApiData a => ToHttpApiData (Product a) where
579+ toUrlPiece = coerce (toUrlPiece :: a -> Text)
580+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
582+instance ToHttpApiData a => ToHttpApiData (First a) where
583+ toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)
584+ toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)
586+instance ToHttpApiData a => ToHttpApiData (Last a) where
587+ toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)
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)
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")
609+instance ToHttpApiData a => ToHttpApiData (Maybe a) where
610+ toUrlPiece (Just x) = "just " <> toUrlPiece x
611+ toUrlPiece Nothing = "nothing"
614+-- >>> toUrlPiece (Left "err" :: Either String Int)
616+-- >>> toUrlPiece (Right 3 :: Either String Int)
618+instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where
619+ toUrlPiece (Left x) = "left " <> toUrlPiece x
620+ toUrlPiece (Right x) = "right " <> toUrlPiece x
622+-- | /Note:/ this instance works correctly for alphanumeric name and value
624+-- >>> let Right c = parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie
626+-- "SESSID=r2t5uvjq435r4q7ib3vtdjq120"
629+-- "SESSID=r2t5uvjq435r4q7ib3vtdjq120"
631+instance ToHttpApiData SetCookie where
632+ toUrlPiece = decodeUtf8With lenientDecode . toHeader
633+ toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie
634+ -- 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 ()
660+instance FromHttpApiData () where
661+ parseUrlPiece "_" = pure ()
662+ parseUrlPiece s = defaultParseError s
664+instance FromHttpApiData Char where
667+ Just (c, s') | T.null s' -> pure c
668+ _ -> defaultParseError s
671+-- >>> showVersion <$> parseUrlPiece "1.2.3"
673+instance FromHttpApiData Version where
675+ case reverse (readP_to_S parseVersion (T.unpack s)) of
676+ ((x, ""):_) -> pure x
677+ _ -> defaultParseError s
679+-- | Parsing a @'Void'@ value is always an error, considering @'Void'@ as a data type with no constructors.
680+instance FromHttpApiData Void where
681+ parseUrlPiece _ = Left "Void cannot be parsed!"
683+instance FromHttpApiData Natural where
684+ parseUrlPiece s = do
685+ n <- runReader (signed decimal) s
687+ then Left ("underflow: " <> s <> " (should be a non-negative integer)")
688+ else Right (fromInteger n)
690+instance FromHttpApiData Bool where parseUrlPiece = parseBoundedUrlPiece
691+instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece
692+instance FromHttpApiData Double where parseUrlPiece = runReader rational
693+instance FromHttpApiData Float where parseUrlPiece = runReader rational
694+instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal)
695+instance FromHttpApiData Int8 where parseUrlPiece = parseBounded (signed decimal)
696+instance FromHttpApiData Int16 where parseUrlPiece = parseBounded (signed decimal)
697+instance FromHttpApiData Int32 where parseUrlPiece = parseBounded (signed decimal)
698+instance FromHttpApiData Int64 where parseUrlPiece = parseBounded (signed decimal)
699+instance FromHttpApiData Integer where parseUrlPiece = runReader (signed decimal)
700+instance FromHttpApiData Word where parseUrlPiece = parseBounded decimal
701+instance FromHttpApiData Word8 where parseUrlPiece = parseBounded decimal
702+instance FromHttpApiData Word16 where parseUrlPiece = parseBounded decimal
703+instance FromHttpApiData Word32 where parseUrlPiece = parseBounded decimal
704+instance FromHttpApiData Word64 where parseUrlPiece = parseBounded decimal
705+instance FromHttpApiData String where parseUrlPiece = Right . T.unpack
706+instance FromHttpApiData Text where parseUrlPiece = Right
707+instance 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
711+ parseUrlPiece = runReader rational
714+-- >>> toGregorian <$> parseUrlPiece "2016-12-01"
716+instance FromHttpApiData Day where parseUrlPiece = runAtto Atto.day
719+-- >>> parseUrlPiece "14:55:01.333" :: Either Text TimeOfDay
720+-- Right 14:55:01.333
721+instance FromHttpApiData TimeOfDay where parseUrlPiece = runAtto Atto.timeOfDay
724+-- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime
725+-- Right 2015-10-03 14:55:01
726+instance FromHttpApiData LocalTime where parseUrlPiece = runAtto Atto.localTime
729+-- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime
730+-- Right 2015-10-03 14:55:01 +0000
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
737+-- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime
738+-- Right 2015-10-03 00:14:24 UTC
739+instance 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
756+-- >>> parseUrlPiece "2021-01" :: Either Text Month
758+instance FromHttpApiData Month where parseUrlPiece = runAtto Atto.month
761+-- >>> parseUrlPiece "2021-q1" :: Either Text Quarter
763+instance FromHttpApiData Quarter where parseUrlPiece = runAtto Atto.quarter
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)
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))
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)
794+-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
796+instance FromHttpApiData a => FromHttpApiData (Maybe a) where
798+ | T.toLower (T.take 7 s) == "nothing" = pure Nothing
799+ | otherwise = Just <$> parseUrlPieceWithPrefix "Just " s
802+-- >>> parseUrlPiece "Right 123" :: Either Text (Either String Int)
804+instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b) where
806+ Right <$> parseUrlPieceWithPrefix "Right " s
807+ <!> Left <$> parseUrlPieceWithPrefix "Left " s
813+instance ToHttpApiData UUID.UUID where
814+ toUrlPiece = UUID.toText
815+ toHeader = UUID.toASCIIBytes
816+ toEncodedUrlPiece = unsafeToEncodedUrlPiece
818+instance FromHttpApiData UUID.UUID where
819+ parseUrlPiece = maybe (Left "invalid UUID") Right . UUID.fromText
820+ parseHeader = maybe (Left "invalid UUID") Right . UUID.fromASCIIBytes
823+-- | Lenient parameters. 'FromHttpApiData' combinators always return `Right`.
826+newtype LenientData a = LenientData { getLenientData :: Either Text a }
827+ deriving (Eq, Ord, Show, Read, Typeable, Data, Functor, Foldable, Traversable)
829+instance FromHttpApiData a => FromHttpApiData (LenientData a) where
830+ parseUrlPiece = Right . LenientData . parseUrlPiece
831+ parseHeader = Right . LenientData . parseHeader
832+ parseQueryParam = Right . LenientData . parseQueryParam
834+-- | /Note:/ this instance works correctly for alphanumeric name and value
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
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+-------------------------------------------------------------------------------
861+-- Attoparsec helpers
862+-------------------------------------------------------------------------------
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)