git.iko.soy/typeable/http-api-data
on 640178b help sign in
typeable/http-api-data/src/Web/Internal/HttpApiData.hs
874 lines 35 kB history raw
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 #-}
12{-# LANGUAGE TypeSynonymInstances #-}
13-- |
14-- Convert Haskell values to and from HTTP API data
15-- such as URL pieces, headers and query parameters.
16module Web.Internal.HttpApiData where
18import Prelude ()
19import Prelude.Compat
21import Control.Applicative (Const(Const))
22import Control.Arrow (left, (&&&))
23import Control.Monad ((<=<))
24import qualified Data.Attoparsec.Text as Atto
25import qualified Data.Attoparsec.Time as Atto
26import Data.ByteString (ByteString)
27import qualified Data.ByteString as BS
28import qualified Data.ByteString.Builder as BS
29import qualified Data.ByteString.Lazy as LBS
30import Data.Coerce (coerce)
31import Data.Data (Data)
32import qualified Data.Fixed as F
33import Data.Functor.Identity (Identity(Identity))
34import Data.Int (Int16, Int32, Int64, Int8)
35import qualified Data.Map as Map
36import Data.Monoid (All (..), Any (..), Dual (..),
37 First (..), Last (..),
38 Product (..), Sum (..))
39import Data.Semigroup (Semigroup (..))
40import qualified Data.Semigroup as Semi
41import Data.Tagged (Tagged (..))
42import Data.Text (Text)
43import qualified Data.Text as T
44import Data.Text.Encoding (decodeUtf8', decodeUtf8With,
45 encodeUtf8)
46import Data.Text.Encoding.Error (lenientDecode)
47import qualified Data.Text.Lazy as L
48import Data.Text.Read (Reader, decimal, rational,
49 signed)
50import Data.Time.Compat (Day, FormatTime, LocalTime,
51 NominalDiffTime, TimeOfDay,
52 UTCTime, ZonedTime, formatTime,
53 DayOfWeek (..),
54 nominalDiffTimeToSeconds,
55 secondsToNominalDiffTime)
56import Data.Time.Format.Compat (defaultTimeLocale,
57 iso8601DateFormat)
58import Data.Time.Calendar.Month.Compat (Month)
59import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..),
60 toYearQuarter)
61import Data.Typeable (Typeable)
62import qualified Data.UUID.Types as UUID
63import Data.Version (Version, parseVersion,
64 showVersion)
65import Data.Void (Void, absurd)
66import Data.Word (Word16, Word32, Word64, Word8)
67import qualified Network.HTTP.Types as H
68import Numeric.Natural (Natural)
69import Text.ParserCombinators.ReadP (readP_to_S)
70import Text.Read (readMaybe)
71import Web.Cookie (SetCookie, parseSetCookie,
72 renderSetCookie)
74#if MIN_VERSION_base(4,9,0)
75import Data.Kind (Type)
76#else
77#define Type *
78#endif
80#if USE_TEXT_SHOW
81import TextShow (TextShow, showt)
82#endif
84-- $setup
85-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
86-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p
87-- >>> import Data.Time.Compat
88-- >>> import Data.Version
90-- | Convert value to HTTP API data.
91--
92-- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated
93-- instance will loop indefinitely.
94class ToHttpApiData a where
95 {-# MINIMAL toUrlPiece | toQueryParam #-}
96 -- | Convert to URL path piece.
97 toUrlPiece :: a -> Text
98 toUrlPiece = toQueryParam
100 -- | Convert to a URL path piece, making sure to encode any special chars.
101 -- The default definition uses 'H.encodePathSegmentsRelative',
102 -- but this may be overriden with a more efficient version.
103 toEncodedUrlPiece :: a -> BS.Builder
104 toEncodedUrlPiece = H.encodePathSegmentsRelative . (:[]) . toUrlPiece
106 -- | Convert to HTTP header value.
107 toHeader :: a -> ByteString
108 toHeader = encodeUtf8 . toUrlPiece
110 -- | Convert to query param value.
111 toQueryParam :: a -> Text
112 toQueryParam = toUrlPiece
114-- | Parse value from HTTP API data.
115--
116-- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated
117-- instance will loop indefinitely.
118class FromHttpApiData a where
119 {-# MINIMAL parseUrlPiece | parseQueryParam #-}
120 -- | Parse URL path piece.
121 parseUrlPiece :: Text -> Either Text a
122 parseUrlPiece = parseQueryParam
124 -- | Parse HTTP header value.
125 parseHeader :: ByteString -> Either Text a
126 parseHeader = parseUrlPiece <=< (left (T.pack . show) . decodeUtf8')
128 -- | Parse query param value.
129 parseQueryParam :: Text -> Either Text a
130 parseQueryParam = parseUrlPiece
132-- | Convert multiple values to a list of URL pieces.
133--
134-- >>> toUrlPieces [1, 2, 3] :: [Text]
135-- ["1","2","3"]
136toUrlPieces :: (Functor t, ToHttpApiData a) => t a -> t Text
137toUrlPieces = fmap toUrlPiece
139-- | Parse multiple URL pieces.
140--
141-- >>> parseUrlPieces ["true", "false"] :: Either Text [Bool]
142-- Right [True,False]
143-- >>> parseUrlPieces ["123", "hello", "world"] :: Either Text [Int]
144-- Left "could not parse: `hello' (input does not start with a digit)"
145parseUrlPieces :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)
146parseUrlPieces = traverse parseUrlPiece
148-- | Convert multiple values to a list of query parameter values.
149--
150-- >>> toQueryParams [fromGregorian 2015 10 03, fromGregorian 2015 12 01] :: [Text]
151-- ["2015-10-03","2015-12-01"]
152toQueryParams :: (Functor t, ToHttpApiData a) => t a -> t Text
153toQueryParams = fmap toQueryParam
155-- | Parse multiple query parameters.
156--
157-- >>> parseQueryParams ["1", "2", "3"] :: Either Text [Int]
158-- Right [1,2,3]
159-- >>> parseQueryParams ["64", "128", "256"] :: Either Text [Word8]
160-- Left "out of bounds: `256' (should be between 0 and 255)"
161parseQueryParams :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)
162parseQueryParams = traverse parseQueryParam
164-- | Parse URL path piece in a @'Maybe'@.
165--
166-- >>> parseUrlPieceMaybe "12" :: Maybe Int
167-- Just 12
168parseUrlPieceMaybe :: FromHttpApiData a => Text -> Maybe a
169parseUrlPieceMaybe = either (const Nothing) Just . parseUrlPiece
171-- | Parse HTTP header value in a @'Maybe'@.
172--
173-- >>> parseHeaderMaybe "hello" :: Maybe Text
174-- Just "hello"
175parseHeaderMaybe :: FromHttpApiData a => ByteString -> Maybe a
176parseHeaderMaybe = either (const Nothing) Just . parseHeader
178-- | Parse query param value in a @'Maybe'@.
179--
180-- >>> parseQueryParamMaybe "true" :: Maybe Bool
181-- Just True
182parseQueryParamMaybe :: FromHttpApiData a => Text -> Maybe a
183parseQueryParamMaybe = either (const Nothing) Just . parseQueryParam
185-- | Default parsing error.
186defaultParseError :: Text -> Either Text a
187defaultParseError input = Left ("could not parse: `" <> input <> "'")
189-- | Convert @'Maybe'@ parser into @'Either' 'Text'@ parser with default error message.
190parseMaybeTextData :: (Text -> Maybe a) -> (Text -> Either Text a)
191parseMaybeTextData parse input =
192 case parse input of
193 Nothing -> defaultParseError input
194 Just val -> Right val
196#if USE_TEXT_SHOW
197-- | /Lower case/.
198--
199-- Convert to URL piece using @'TextShow'@ instance.
200-- The result is always lower cased.
201--
202-- >>> showTextData True
203-- "true"
204--
205-- This can be used as a default implementation for enumeration types:
206--
207-- @
208-- data MyData = Foo | Bar | Baz deriving (Generic)
209--
210-- instance TextShow MyData where
211-- showt = genericShowt
212--
213-- instance ToHttpApiData MyData where
214-- toUrlPiece = showTextData
215-- @
216showTextData :: TextShow a => a -> Text
217showTextData = T.toLower . showt
218#else
219-- | /Lower case/.
220--
221-- Convert to URL piece using @'Show'@ instance.
222-- The result is always lower cased.
223--
224-- >>> showTextData True
225-- "true"
226--
227-- This can be used as a default implementation for enumeration types:
228--
229-- >>> data MyData = Foo | Bar | Baz deriving (Show)
230-- >>> instance ToHttpApiData MyData where toUrlPiece = showTextData
231-- >>> toUrlPiece Foo
232-- "foo"
233showTextData :: Show a => a -> Text
234showTextData = T.toLower . showt
236-- | Like @'show'@, but returns @'Text'@.
237showt :: Show a => a -> Text
238showt = T.pack . show
239#endif
241-- | /Case insensitive/.
242--
243-- Parse given text case insensitive and then parse the rest of the input
244-- using @'parseUrlPiece'@.
245--
246-- >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int
247-- Right 10
248-- >>> parseUrlPieceWithPrefix "Left " "left" :: Either Text Bool
249-- Left "could not parse: `left'"
250--
251-- This can be used to implement @'FromHttpApiData'@ for single field constructors:
252--
253-- >>> data Foo = Foo Int deriving (Show)
254-- >>> instance FromHttpApiData Foo where parseUrlPiece s = Foo <$> parseUrlPieceWithPrefix "Foo " s
255-- >>> parseUrlPiece "foo 1" :: Either Text Foo
256-- Right (Foo 1)
257parseUrlPieceWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a
258parseUrlPieceWithPrefix pattern input
259 | T.toLower pattern == T.toLower prefix = parseUrlPiece rest
260 | otherwise = defaultParseError input
261 where
262 (prefix, rest) = T.splitAt (T.length pattern) input
264-- | Parse given bytestring then parse the rest of the input using @'parseHeader'@.
265--
266-- @
267-- data BasicAuthToken = BasicAuthToken Text deriving (Show)
268--
269-- instance FromHttpApiData BasicAuthToken where
270-- parseHeader h = BasicAuthToken \<$\> parseHeaderWithPrefix "Basic " h
271-- parseQueryParam p = BasicAuthToken \<$\> parseQueryParam p
272-- @
273--
274-- >>> parseHeader "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" :: Either Text BasicAuthToken
275-- Right (BasicAuthToken "QWxhZGRpbjpvcGVuIHNlc2FtZQ==")
276parseHeaderWithPrefix :: FromHttpApiData a => ByteString -> ByteString -> Either Text a
277parseHeaderWithPrefix pattern input
278 | pattern `BS.isPrefixOf` input = parseHeader (BS.drop (BS.length pattern) input)
279 | otherwise = defaultParseError (showt input)
281-- | /Case insensitive/.
282--
283-- Parse given text case insensitive and then parse the rest of the input
284-- using @'parseQueryParam'@.
285--
286-- >>> parseQueryParamWithPrefix "z" "z10" :: Either Text Int
287-- Right 10
288parseQueryParamWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a
289parseQueryParamWithPrefix pattern input
290 | T.toLower pattern == T.toLower prefix = parseQueryParam rest
291 | otherwise = defaultParseError input
292 where
293 (prefix, rest) = T.splitAt (T.length pattern) input
295#if USE_TEXT_SHOW
296-- | /Case insensitive/.
297--
298-- Parse values case insensitively based on @'TextShow'@ instance.
299--
300-- >>> parseBoundedTextData "true" :: Either Text Bool
301-- Right True
302-- >>> parseBoundedTextData "FALSE" :: Either Text Bool
303-- Right False
304--
305-- This can be used as a default implementation for enumeration types:
306--
307-- @
308-- data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum, Generic)
309--
310-- instance TextShow MyData where
311-- showt = genericShowt
312--
313-- instance FromHttpApiData MyData where
314-- parseUrlPiece = parseBoundedTextData
315-- @
316parseBoundedTextData :: (TextShow a, Bounded a, Enum a) => Text -> Either Text a
317#else
318-- | /Case insensitive/.
319--
320-- Parse values case insensitively based on @'Show'@ instance.
321--
322-- >>> parseBoundedTextData "true" :: Either Text Bool
323-- Right True
324-- >>> parseBoundedTextData "FALSE" :: Either Text Bool
325-- Right False
326--
327-- This can be used as a default implementation for enumeration types:
328--
329-- >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum)
330-- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedTextData
331-- >>> parseUrlPiece "foo" :: Either Text MyData
332-- Right Foo
333parseBoundedTextData :: (Show a, Bounded a, Enum a) => Text -> Either Text a
334#endif
335parseBoundedTextData = parseBoundedEnumOfI showTextData
337-- | Lookup values based on a precalculated mapping of their representations.
338lookupBoundedEnumOf :: (Bounded a, Enum a, Eq b) => (a -> b) -> b -> Maybe a
339lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])
341-- | Parse values based on a precalculated mapping of their @'Text'@ representation.
342--
343-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool
344-- Right True
345--
346-- For case insensitive parser see 'parseBoundedEnumOfI'.
347parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
348parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf
350-- | /Case insensitive/.
351--
352-- Parse values case insensitively based on a precalculated mapping
353-- of their @'Text'@ representations.
354--
355-- >>> parseBoundedEnumOfI toUrlPiece "FALSE" :: Either Text Bool
356-- Right False
357--
358-- For case sensitive parser see 'parseBoundedEnumOf'.
359parseBoundedEnumOfI :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
360parseBoundedEnumOfI f = parseBoundedEnumOf (T.toLower . f) . T.toLower
362-- | /Case insensitive/.
363--
364-- Parse values case insensitively based on @'ToHttpApiData'@ instance.
365-- Uses @'toUrlPiece'@ to get possible values.
366parseBoundedUrlPiece :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a
367parseBoundedUrlPiece = parseBoundedEnumOfI toUrlPiece
369-- | /Case insensitive/.
370--
371-- Parse values case insensitively based on @'ToHttpApiData'@ instance.
372-- Uses @'toQueryParam'@ to get possible values.
373parseBoundedQueryParam :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a
374parseBoundedQueryParam = parseBoundedEnumOfI toQueryParam
376-- | Parse values based on @'ToHttpApiData'@ instance.
377-- Uses @'toHeader'@ to get possible values.
378parseBoundedHeader :: (ToHttpApiData a, Bounded a, Enum a) => ByteString -> Either Text a
379parseBoundedHeader bs = case lookupBoundedEnumOf toHeader bs of
380 Nothing -> defaultParseError $ T.pack $ show bs
381 Just x -> return x
383-- | Parse URL piece using @'Read'@ instance.
384--
385-- Use for types which do not involve letters:
386--
387-- >>> readTextData "1991-06-02" :: Either Text Day
388-- Right 1991-06-02
389--
390-- This parser is case sensitive and will not match @'showTextData'@
391-- in presence of letters:
392--
393-- >>> readTextData (showTextData True) :: Either Text Bool
394-- Left "could not parse: `true'"
395--
396-- See @'parseBoundedTextData'@.
397readTextData :: Read a => Text -> Either Text a
398readTextData = parseMaybeTextData (readMaybe . T.unpack)
400-- | Run @'Reader'@ as HTTP API data parser.
401runReader :: Reader a -> Text -> Either Text a
402runReader reader input =
403 case reader input of
404 Left err -> Left ("could not parse: `" <> input <> "' (" <> T.pack err <> ")")
405 Right (x, rest)
406 | T.null rest -> Right x
407 | otherwise -> defaultParseError input
409-- | Run @'Reader'@ to parse bounded integral value with bounds checking.
410--
411-- >>> parseBounded decimal "256" :: Either Text Word8
412-- Left "out of bounds: `256' (should be between 0 and 255)"
413parseBounded :: forall a. (Bounded a, Integral a) => Reader Integer -> Text -> Either Text a
414parseBounded reader input = do
415 n <- runReader reader input
416 if (n > h || n < l)
417 then Left ("out of bounds: `" <> input <> "' (should be between " <> showt l <> " and " <> showt h <> ")")
418 else Right (fromInteger n)
419 where
420 l = toInteger (minBound :: a)
421 h = toInteger (maxBound :: a)
423-- | Convert to a URL-encoded path piece using 'toUrlPiece'.
424-- /Note/: this function does not check if the result contains unescaped characters!
425-- This function can be used to override 'toEncodedUrlPiece' as a more efficient implementation
426-- when the resulting URL piece /never/ has to be escaped.
427unsafeToEncodedUrlPiece :: ToHttpApiData a => a -> BS.Builder
428unsafeToEncodedUrlPiece = BS.byteString . encodeUtf8 . toUrlPiece
430-- |
431-- >>> toUrlPiece ()
432-- "_"
433instance ToHttpApiData () where
434 toUrlPiece () = "_"
435 toEncodedUrlPiece = unsafeToEncodedUrlPiece
437instance ToHttpApiData Char where
438 toUrlPiece = T.singleton
440-- |
441-- >>> toUrlPiece (Version [1, 2, 3] [])
442-- "1.2.3"
443instance ToHttpApiData Version where
444 toUrlPiece = T.pack . showVersion
445 toEncodedUrlPiece = unsafeToEncodedUrlPiece
447instance ToHttpApiData Void where toUrlPiece = absurd
448instance ToHttpApiData Natural where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
450instance ToHttpApiData Bool where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece
451instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece
453instance ToHttpApiData Double where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
454instance ToHttpApiData Float where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
455instance ToHttpApiData Int where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
456instance ToHttpApiData Int8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
457instance ToHttpApiData Int16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
458instance ToHttpApiData Int32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
459instance ToHttpApiData Int64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
460instance ToHttpApiData Integer where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
461instance ToHttpApiData Word where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
462instance ToHttpApiData Word8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
463instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
464instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
465instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
467-- | Note: this instance is not polykinded
468instance F.HasResolution a => ToHttpApiData (F.Fixed (a :: Type)) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
470-- |
471-- >>> toUrlPiece (fromGregorian 2015 10 03)
472-- "2015-10-03"
473instance ToHttpApiData Day where
474 toUrlPiece = T.pack . show
475 toEncodedUrlPiece = unsafeToEncodedUrlPiece
477timeToUrlPiece :: FormatTime t => String -> t -> Text
478timeToUrlPiece fmt = T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just fmt))
480-- |
481-- >>> toUrlPiece $ TimeOfDay 14 55 23.1
482-- "14:55:23.1"
483instance ToHttpApiData TimeOfDay where
484 toUrlPiece = T.pack . formatTime defaultTimeLocale "%H:%M:%S%Q"
485 toEncodedUrlPiece = unsafeToEncodedUrlPiece
487-- |
488-- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 21.687)
489-- "2015-10-03T14:55:21.687"
490instance ToHttpApiData LocalTime where
491 toUrlPiece = timeToUrlPiece "%H:%M:%S%Q"
492 toEncodedUrlPiece = unsafeToEncodedUrlPiece
494-- |
495-- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 51.001)) utc
496-- "2015-10-03T14:55:51.001+0000"
497instance ToHttpApiData ZonedTime where
498 toUrlPiece = timeToUrlPiece "%H:%M:%S%Q%z"
499 toEncodedUrlPiece = unsafeToEncodedUrlPiece
501-- |
502-- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864.5
503-- "2015-10-03T00:14:24.5Z"
504instance ToHttpApiData UTCTime where
505 toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ"
506 toEncodedUrlPiece = unsafeToEncodedUrlPiece
508-- |
509-- >>> toUrlPiece Monday
510-- "monday"
511instance ToHttpApiData DayOfWeek where
512 toUrlPiece Monday = "monday"
513 toUrlPiece Tuesday = "tuesday"
514 toUrlPiece Wednesday = "wednesday"
515 toUrlPiece Thursday = "thursday"
516 toUrlPiece Friday = "friday"
517 toUrlPiece Saturday = "saturday"
518 toUrlPiece Sunday = "sunday"
520 toEncodedUrlPiece = unsafeToEncodedUrlPiece
522-- |
523-- >>> toUrlPiece Q4
524-- "q4"
525instance ToHttpApiData QuarterOfYear where
526 toUrlPiece Q1 = "q1"
527 toUrlPiece Q2 = "q2"
528 toUrlPiece Q3 = "q3"
529 toUrlPiece Q4 = "q4"
531-- |
532-- >>> import Data.Time.Calendar.Quarter.Compat (Quarter (..))
533-- >>> MkQuarter 8040
534-- 2010-Q1
535--
536-- >>> toUrlPiece $ MkQuarter 8040
537-- "2010-q1"
538--
539instance ToHttpApiData Quarter where
540 toUrlPiece q = case toYearQuarter q of
541 (y, qoy) -> T.pack (show y ++ "-" ++ f qoy)
542 where
543 f Q1 = "q1"
544 f Q2 = "q2"
545 f Q3 = "q3"
546 f Q4 = "q4"
548-- |
549-- >>> import Data.Time.Calendar.Month.Compat (Month (..))
550-- >>> MkMonth 24482
551-- 2040-03
552--
553-- >>> toUrlPiece $ MkMonth 24482
554-- "2040-03"
555--
556instance ToHttpApiData Month where
557 toUrlPiece = T.pack . formatTime defaultTimeLocale "%Y-%m"
559instance ToHttpApiData NominalDiffTime where
560 toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds
561 toEncodedUrlPiece = unsafeToEncodedUrlPiece
563instance ToHttpApiData String where toUrlPiece = T.pack
564instance ToHttpApiData Text where toUrlPiece = id
565instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
567instance ToHttpApiData All where
568 toUrlPiece = coerce (toUrlPiece :: Bool -> Text)
569 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder)
571instance ToHttpApiData Any where
572 toUrlPiece = coerce (toUrlPiece :: Bool -> Text)
573 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder)
575instance ToHttpApiData a => ToHttpApiData (Dual a) where
576 toUrlPiece = coerce (toUrlPiece :: a -> Text)
577 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
579instance ToHttpApiData a => ToHttpApiData (Sum a) where
580 toUrlPiece = coerce (toUrlPiece :: a -> Text)
581 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
583instance ToHttpApiData a => ToHttpApiData (Product a) where
584 toUrlPiece = coerce (toUrlPiece :: a -> Text)
585 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
587instance ToHttpApiData a => ToHttpApiData (First a) where
588 toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)
589 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)
591instance ToHttpApiData a => ToHttpApiData (Last a) where
592 toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)
593 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)
595instance ToHttpApiData a => ToHttpApiData (Semi.Min a) where
596 toUrlPiece = coerce (toUrlPiece :: a -> Text)
597 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
599instance ToHttpApiData a => ToHttpApiData (Semi.Max a) where
600 toUrlPiece = coerce (toUrlPiece :: a -> Text)
601 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
603instance ToHttpApiData a => ToHttpApiData (Semi.First a) where
604 toUrlPiece = coerce (toUrlPiece :: a -> Text)
605 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
607instance ToHttpApiData a => ToHttpApiData (Semi.Last a) where
608 toUrlPiece = coerce (toUrlPiece :: a -> Text)
609 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
611-- |
612-- >>> toUrlPiece (Just "Hello")
613-- "just Hello"
614instance ToHttpApiData a => ToHttpApiData (Maybe a) where
615 toUrlPiece (Just x) = "just " <> toUrlPiece x
616 toUrlPiece Nothing = "nothing"
618-- |
619-- >>> toUrlPiece (Left "err" :: Either String Int)
620-- "left err"
621-- >>> toUrlPiece (Right 3 :: Either String Int)
622-- "right 3"
623instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where
624 toUrlPiece (Left x) = "left " <> toUrlPiece x
625 toUrlPiece (Right x) = "right " <> toUrlPiece x
627-- | /Note:/ this instance works correctly for alphanumeric name and value
628--
629-- >>> let Right c = parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie
630-- >>> toUrlPiece c
631-- "SESSID=r2t5uvjq435r4q7ib3vtdjq120"
632--
633-- >>> toHeader c
634-- "SESSID=r2t5uvjq435r4q7ib3vtdjq120"
635--
636instance ToHttpApiData SetCookie where
637 toUrlPiece = decodeUtf8With lenientDecode . toHeader
638 toHeader = LBS.toStrict . BS.toLazyByteString . renderSetCookie
639 -- toEncodedUrlPiece = renderSetCookie -- doesn't do things.
641-- | Note: this instance is not polykinded
642instance ToHttpApiData a => ToHttpApiData (Tagged (b :: Type) a) where
643 toUrlPiece = coerce (toUrlPiece :: a -> Text)
644 toHeader = coerce (toHeader :: a -> ByteString)
645 toQueryParam = coerce (toQueryParam :: a -> Text)
646 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
648-- | @since 0.4.2
649instance ToHttpApiData a => ToHttpApiData (Const a b) where
650 toUrlPiece = coerce (toUrlPiece :: a -> Text)
651 toHeader = coerce (toHeader :: a -> ByteString)
652 toQueryParam = coerce (toQueryParam :: a -> Text)
653 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
655-- | @since 0.4.2
656instance ToHttpApiData a => ToHttpApiData (Identity a) where
657 toUrlPiece = coerce (toUrlPiece :: a -> Text)
658 toHeader = coerce (toHeader :: a -> ByteString)
659 toQueryParam = coerce (toQueryParam :: a -> Text)
660 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
662-- |
663-- >>> parseUrlPiece "_" :: Either Text ()
664-- Right ()
665instance FromHttpApiData () where
666 parseUrlPiece "_" = pure ()
667 parseUrlPiece s = defaultParseError s
669instance FromHttpApiData Char where
670 parseUrlPiece s =
671 case T.uncons s of
672 Just (c, s') | T.null s' -> pure c
673 _ -> defaultParseError s
675-- |
676-- >>> showVersion <$> parseUrlPiece "1.2.3"
677-- Right "1.2.3"
678instance FromHttpApiData Version where
679 parseUrlPiece s =
680 case reverse (readP_to_S parseVersion (T.unpack s)) of
681 ((x, ""):_) -> pure x
682 _ -> defaultParseError s
684-- | Parsing a @'Void'@ value is always an error, considering @'Void'@ as a data type with no constructors.
685instance FromHttpApiData Void where
686 parseUrlPiece _ = Left "Void cannot be parsed!"
688instance FromHttpApiData Natural where
689 parseUrlPiece s = do
690 n <- runReader (signed decimal) s
691 if n < 0
692 then Left ("underflow: " <> s <> " (should be a non-negative integer)")
693 else Right (fromInteger n)
695instance FromHttpApiData Bool where parseUrlPiece = parseBoundedUrlPiece
696instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece
697instance FromHttpApiData Double where parseUrlPiece = runReader rational
698instance FromHttpApiData Float where parseUrlPiece = runReader rational
699instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal)
700instance FromHttpApiData Int8 where parseUrlPiece = parseBounded (signed decimal)
701instance FromHttpApiData Int16 where parseUrlPiece = parseBounded (signed decimal)
702instance FromHttpApiData Int32 where parseUrlPiece = parseBounded (signed decimal)
703instance FromHttpApiData Int64 where parseUrlPiece = parseBounded (signed decimal)
704instance FromHttpApiData Integer where parseUrlPiece = runReader (signed decimal)
705instance FromHttpApiData Word where parseUrlPiece = parseBounded decimal
706instance FromHttpApiData Word8 where parseUrlPiece = parseBounded decimal
707instance FromHttpApiData Word16 where parseUrlPiece = parseBounded decimal
708instance FromHttpApiData Word32 where parseUrlPiece = parseBounded decimal
709instance FromHttpApiData Word64 where parseUrlPiece = parseBounded decimal
710instance FromHttpApiData String where parseUrlPiece = Right . T.unpack
711instance FromHttpApiData Text where parseUrlPiece = Right
712instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
714-- | Note: this instance is not polykinded
715instance F.HasResolution a => FromHttpApiData (F.Fixed (a :: Type)) where
716 parseUrlPiece = runReader rational
718-- |
719-- >>> toGregorian <$> parseUrlPiece "2016-12-01"
720-- Right (2016,12,1)
721instance FromHttpApiData Day where parseUrlPiece = runAtto Atto.day
723-- |
724-- >>> parseUrlPiece "14:55:01.333" :: Either Text TimeOfDay
725-- Right 14:55:01.333
726instance FromHttpApiData TimeOfDay where parseUrlPiece = runAtto Atto.timeOfDay
728-- |
729-- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime
730-- Right 2015-10-03 14:55:01
731instance FromHttpApiData LocalTime where parseUrlPiece = runAtto Atto.localTime
733-- |
734-- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime
735-- Right 2015-10-03 14:55:01 +0000
736--
737-- >>> parseQueryParam "2016-12-31T01:00:00Z" :: Either Text ZonedTime
738-- Right 2016-12-31 01:00:00 +0000
739instance FromHttpApiData ZonedTime where parseUrlPiece = runAtto Atto.zonedTime
741-- |
742-- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime
743-- Right 2015-10-03 00:14:24 UTC
744instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime
746-- |
747-- >>> parseUrlPiece "Monday" :: Either Text DayOfWeek
748-- Right Monday
749instance FromHttpApiData DayOfWeek where
750 parseUrlPiece t = case Map.lookup (T.toLower t) m of
751 Just dow -> Right dow
752 Nothing -> Left $ "Incorrect DayOfWeek: " <> T.take 10 t
753 where
754 m :: Map.Map Text DayOfWeek
755 m = Map.fromList [ (toUrlPiece dow, dow) | dow <- [Monday .. Sunday] ]
758instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secondsToNominalDiffTime . parseUrlPiece
760-- |
761-- >>> parseUrlPiece "2021-01" :: Either Text Month
762-- Right 2021-01
763instance FromHttpApiData Month where parseUrlPiece = runAtto Atto.month
765-- |
766-- >>> parseUrlPiece "2021-q1" :: Either Text Quarter
767-- Right 2021-Q1
768instance FromHttpApiData Quarter where parseUrlPiece = runAtto Atto.quarter
770-- |
771-- >>> parseUrlPiece "q2" :: Either Text QuarterOfYear
772-- Right Q2
773--
774-- >>> parseUrlPiece "Q3" :: Either Text QuarterOfYear
775-- Right Q3
776instance FromHttpApiData QuarterOfYear where
777 parseUrlPiece t = case T.toLower t of
778 "q1" -> return Q1
779 "q2" -> return Q2
780 "q3" -> return Q3
781 "q4" -> return Q4
782 _ -> Left "Invalid quarter of year"
784instance FromHttpApiData All where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
785instance FromHttpApiData Any where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
787instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
788instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
789instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
790instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a))
791instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a))
793instance FromHttpApiData a => FromHttpApiData (Semi.Min a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
794instance FromHttpApiData a => FromHttpApiData (Semi.Max a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
795instance FromHttpApiData a => FromHttpApiData (Semi.First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
796instance FromHttpApiData a => FromHttpApiData (Semi.Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
798-- |
799-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
800-- Right (Just 123)
801instance FromHttpApiData a => FromHttpApiData (Maybe a) where
802 parseUrlPiece s
803 | T.toLower (T.take 7 s) == "nothing" = pure Nothing
804 | otherwise = Just <$> parseUrlPieceWithPrefix "Just " s
806-- |
807-- >>> parseUrlPiece "Right 123" :: Either Text (Either String Int)
808-- Right (Right 123)
809instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b) where
810 parseUrlPiece s =
811 Right <$> parseUrlPieceWithPrefix "Right " s
812 <!> Left <$> parseUrlPieceWithPrefix "Left " s
813 where
814 infixl 3 <!>
815 Left _ <!> y = y
816 x <!> _ = x
818instance ToHttpApiData UUID.UUID where
819 toUrlPiece = UUID.toText
820 toHeader = UUID.toASCIIBytes
821 toEncodedUrlPiece = unsafeToEncodedUrlPiece
823instance FromHttpApiData UUID.UUID where
824 parseUrlPiece = maybe (Left "invalid UUID") Right . UUID.fromText
825 parseHeader = maybe (Left "invalid UUID") Right . UUID.fromASCIIBytes
828-- | Lenient parameters. 'FromHttpApiData' combinators always return `Right`.
829--
830-- @since 0.3.5
831newtype LenientData a = LenientData { getLenientData :: Either Text a }
832 deriving (Eq, Ord, Show, Read, Typeable, Data, Functor, Foldable, Traversable)
834instance FromHttpApiData a => FromHttpApiData (LenientData a) where
835 parseUrlPiece = Right . LenientData . parseUrlPiece
836 parseHeader = Right . LenientData . parseHeader
837 parseQueryParam = Right . LenientData . parseQueryParam
839-- | /Note:/ this instance works correctly for alphanumeric name and value
840--
841-- >>> parseUrlPiece "SESSID=r2t5uvjq435r4q7ib3vtdjq120" :: Either Text SetCookie
842-- Right (SetCookie {setCookieName = "SESSID", setCookieValue = "r2t5uvjq435r4q7ib3vtdjq120", setCookiePath = Nothing, setCookieExpires = Nothing, setCookieMaxAge = Nothing, setCookieDomain = Nothing, setCookieHttpOnly = False, setCookieSecure = False, setCookieSameSite = Nothing})
843instance FromHttpApiData SetCookie where
844 parseUrlPiece = parseHeader . encodeUtf8
845 parseHeader = Right . parseSetCookie
847-- | Note: this instance is not polykinded
848instance FromHttpApiData a => FromHttpApiData (Tagged (b :: Type) a) where
849 parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
850 parseHeader = coerce (parseHeader :: ByteString -> Either Text a)
851 parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)
853-- | @since 0.4.2
854instance FromHttpApiData a => FromHttpApiData (Const a b) where
855 parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
856 parseHeader = coerce (parseHeader :: ByteString -> Either Text a)
857 parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)
859-- | @since 0.4.2
860instance FromHttpApiData a => FromHttpApiData (Identity a) where
861 parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
862 parseHeader = coerce (parseHeader :: ByteString -> Either Text a)
863 parseQueryParam = coerce (parseQueryParam :: Text -> Either Text a)
865-------------------------------------------------------------------------------
866-- Attoparsec helpers
867-------------------------------------------------------------------------------
869runAtto :: Atto.Parser a -> Text -> Either Text a
870runAtto p t = case Atto.parseOnly (p <* Atto.endOfInput) t of
871 Left err -> Left (T.pack err)
872 Right x -> Right x