git.iko.soy/typeable/http-api-data
on master help sign in
typeable/http-api-data/src/Web/Internal/HttpApiData.hs
867 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 Data.Kind (Type)
36import qualified Data.Map as Map
37import Data.Monoid (All (..), Any (..), Dual (..),
38 First (..), Last (..),
39 Product (..), Sum (..))
40import Data.Semigroup (Semigroup (..))
41import qualified Data.Semigroup as Semi
42import Data.Tagged (Tagged (..))
43import Data.Text (Text)
44import qualified Data.Text as T
45import Data.Text.Encoding (decodeUtf8', decodeUtf8With,
46 encodeUtf8)
47import Data.Text.Encoding.Error (lenientDecode)
48import qualified Data.Text.Lazy as L
49import Data.Text.Read (Reader, decimal, rational,
50 signed)
51import Data.Time.Compat (Day, FormatTime, LocalTime,
52 NominalDiffTime, TimeOfDay,
53 UTCTime, ZonedTime, formatTime,
54 DayOfWeek (..),
55 nominalDiffTimeToSeconds,
56 secondsToNominalDiffTime)
57import Data.Time.Format.Compat (defaultTimeLocale,
58 iso8601DateFormat)
59import Data.Time.Calendar.Month.Compat (Month)
60import Data.Time.Calendar.Quarter.Compat (Quarter, QuarterOfYear (..),
61 toYearQuarter)
62import Data.Typeable (Typeable)
63import qualified Data.UUID.Types as UUID
64import Data.Version (Version, parseVersion,
65 showVersion)
66import Data.Void (Void, absurd)
67import Data.Word (Word16, Word32, Word64, Word8)
68import qualified Network.HTTP.Types as H
69import Numeric.Natural (Natural)
70import Text.ParserCombinators.ReadP (readP_to_S)
71import Text.Read (readMaybe)
72import Web.Cookie (SetCookie, parseSetCookie,
73 renderSetCookie)
75#if USE_TEXT_SHOW
76import TextShow (TextShow, showt)
77#endif
79-- $setup
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.
86--
87-- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated
88-- instance will loop indefinitely.
89class 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.
110--
111-- __WARNING__: Do not derive this using @DeriveAnyClass@ as the generated
112-- instance will loop indefinitely.
113class 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.
128--
129-- >>> toUrlPieces [1, 2, 3] :: [Text]
130-- ["1","2","3"]
131toUrlPieces :: (Functor t, ToHttpApiData a) => t a -> t Text
132toUrlPieces = fmap toUrlPiece
134-- | Parse multiple URL pieces.
135--
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)"
140parseUrlPieces :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)
141parseUrlPieces = traverse parseUrlPiece
143-- | Convert multiple values to a list of query parameter values.
144--
145-- >>> toQueryParams [fromGregorian 2015 10 03, fromGregorian 2015 12 01] :: [Text]
146-- ["2015-10-03","2015-12-01"]
147toQueryParams :: (Functor t, ToHttpApiData a) => t a -> t Text
148toQueryParams = fmap toQueryParam
150-- | Parse multiple query parameters.
151--
152-- >>> parseQueryParams ["1", "2", "3"] :: Either Text [Int]
153-- Right [1,2,3]
154-- >>> parseQueryParams ["64", "128", "256"] :: Either Text [Word8]
155-- Left "out of bounds: `256' (should be between 0 and 255)"
156parseQueryParams :: (Traversable t, FromHttpApiData a) => t Text -> Either Text (t a)
157parseQueryParams = traverse parseQueryParam
159-- | Parse URL path piece in a @'Maybe'@.
160--
161-- >>> parseUrlPieceMaybe "12" :: Maybe Int
162-- Just 12
163parseUrlPieceMaybe :: FromHttpApiData a => Text -> Maybe a
164parseUrlPieceMaybe = either (const Nothing) Just . parseUrlPiece
166-- | Parse HTTP header value in a @'Maybe'@.
167--
168-- >>> parseHeaderMaybe "hello" :: Maybe Text
169-- Just "hello"
170parseHeaderMaybe :: FromHttpApiData a => ByteString -> Maybe a
171parseHeaderMaybe = either (const Nothing) Just . parseHeader
173-- | Parse query param value in a @'Maybe'@.
174--
175-- >>> parseQueryParamMaybe "true" :: Maybe Bool
176-- Just True
177parseQueryParamMaybe :: FromHttpApiData a => Text -> Maybe a
178parseQueryParamMaybe = either (const Nothing) Just . parseQueryParam
180-- | Default parsing error.
181defaultParseError :: Text -> Either Text a
182defaultParseError input = Left ("could not parse: `" <> input <> "'")
184-- | Convert @'Maybe'@ parser into @'Either' 'Text'@ parser with default error message.
185parseMaybeTextData :: (Text -> Maybe a) -> (Text -> Either Text a)
186parseMaybeTextData parse input =
187 case parse input of
188 Nothing -> defaultParseError input
189 Just val -> Right val
191#if USE_TEXT_SHOW
192-- | /Lower case/.
193--
194-- Convert to URL piece using @'TextShow'@ instance.
195-- The result is always lower cased.
196--
197-- >>> showTextData True
198-- "true"
199--
200-- This can be used as a default implementation for enumeration types:
201--
202-- @
203-- data MyData = Foo | Bar | Baz deriving (Generic)
204--
205-- instance TextShow MyData where
206-- showt = genericShowt
207--
208-- instance ToHttpApiData MyData where
209-- toUrlPiece = showTextData
210-- @
211showTextData :: TextShow a => a -> Text
212showTextData = T.toLower . showt
213#else
214-- | /Lower case/.
215--
216-- Convert to URL piece using @'Show'@ instance.
217-- The result is always lower cased.
218--
219-- >>> showTextData True
220-- "true"
221--
222-- This can be used as a default implementation for enumeration types:
223--
224-- >>> data MyData = Foo | Bar | Baz deriving (Show)
225-- >>> instance ToHttpApiData MyData where toUrlPiece = showTextData
226-- >>> toUrlPiece Foo
227-- "foo"
228showTextData :: Show a => a -> Text
229showTextData = T.toLower . showt
231-- | Like @'show'@, but returns @'Text'@.
232showt :: Show a => a -> Text
233showt = T.pack . show
234#endif
236-- | /Case insensitive/.
237--
238-- Parse given text case insensitive and then parse the rest of the input
239-- using @'parseUrlPiece'@.
240--
241-- >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int
242-- Right 10
243-- >>> parseUrlPieceWithPrefix "Left " "left" :: Either Text Bool
244-- Left "could not parse: `left'"
245--
246-- This can be used to implement @'FromHttpApiData'@ for single field constructors:
247--
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
251-- Right (Foo 1)
252parseUrlPieceWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a
253parseUrlPieceWithPrefix pattern input
254 | T.toLower pattern == T.toLower prefix = parseUrlPiece rest
255 | otherwise = defaultParseError input
256 where
257 (prefix, rest) = T.splitAt (T.length pattern) input
259-- | Parse given bytestring then parse the rest of the input using @'parseHeader'@.
260--
261-- @
262-- data BasicAuthToken = BasicAuthToken Text deriving (Show)
263--
264-- instance FromHttpApiData BasicAuthToken where
265-- parseHeader h = BasicAuthToken \<$\> parseHeaderWithPrefix "Basic " h
266-- parseQueryParam p = BasicAuthToken \<$\> parseQueryParam p
267-- @
268--
269-- >>> parseHeader "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" :: Either Text BasicAuthToken
270-- Right (BasicAuthToken "QWxhZGRpbjpvcGVuIHNlc2FtZQ==")
271parseHeaderWithPrefix :: FromHttpApiData a => ByteString -> ByteString -> Either Text a
272parseHeaderWithPrefix pattern input
273 | pattern `BS.isPrefixOf` input = parseHeader (BS.drop (BS.length pattern) input)
274 | otherwise = defaultParseError (showt input)
276-- | /Case insensitive/.
277--
278-- Parse given text case insensitive and then parse the rest of the input
279-- using @'parseQueryParam'@.
280--
281-- >>> parseQueryParamWithPrefix "z" "z10" :: Either Text Int
282-- Right 10
283parseQueryParamWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a
284parseQueryParamWithPrefix pattern input
285 | T.toLower pattern == T.toLower prefix = parseQueryParam rest
286 | otherwise = defaultParseError input
287 where
288 (prefix, rest) = T.splitAt (T.length pattern) input
290#if USE_TEXT_SHOW
291-- | /Case insensitive/.
292--
293-- Parse values case insensitively based on @'TextShow'@ instance.
294--
295-- >>> parseBoundedTextData "true" :: Either Text Bool
296-- Right True
297-- >>> parseBoundedTextData "FALSE" :: Either Text Bool
298-- Right False
299--
300-- This can be used as a default implementation for enumeration types:
301--
302-- @
303-- data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum, Generic)
304--
305-- instance TextShow MyData where
306-- showt = genericShowt
307--
308-- instance FromHttpApiData MyData where
309-- parseUrlPiece = parseBoundedTextData
310-- @
311parseBoundedTextData :: (TextShow a, Bounded a, Enum a) => Text -> Either Text a
312#else
313-- | /Case insensitive/.
314--
315-- Parse values case insensitively based on @'Show'@ instance.
316--
317-- >>> parseBoundedTextData "true" :: Either Text Bool
318-- Right True
319-- >>> parseBoundedTextData "FALSE" :: Either Text Bool
320-- Right False
321--
322-- This can be used as a default implementation for enumeration types:
323--
324-- >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum)
325-- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedTextData
326-- >>> parseUrlPiece "foo" :: Either Text MyData
327-- Right Foo
328parseBoundedTextData :: (Show a, Bounded a, Enum a) => Text -> Either Text a
329#endif
330parseBoundedTextData = parseBoundedEnumOfI showTextData
332-- | Lookup values based on a precalculated mapping of their representations.
333lookupBoundedEnumOf :: (Bounded a, Enum a, Eq b) => (a -> b) -> b -> Maybe a
334lookupBoundedEnumOf f = flip lookup (map (f &&& id) [minBound..maxBound])
336-- | Parse values based on a precalculated mapping of their @'Text'@ representation.
337--
338-- >>> parseBoundedEnumOf toUrlPiece "true" :: Either Text Bool
339-- Right True
340--
341-- For case insensitive parser see 'parseBoundedEnumOfI'.
342parseBoundedEnumOf :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
343parseBoundedEnumOf = parseMaybeTextData . lookupBoundedEnumOf
345-- | /Case insensitive/.
346--
347-- Parse values case insensitively based on a precalculated mapping
348-- of their @'Text'@ representations.
349--
350-- >>> parseBoundedEnumOfI toUrlPiece "FALSE" :: Either Text Bool
351-- Right False
352--
353-- For case sensitive parser see 'parseBoundedEnumOf'.
354parseBoundedEnumOfI :: (Bounded a, Enum a) => (a -> Text) -> Text -> Either Text a
355parseBoundedEnumOfI f = parseBoundedEnumOf (T.toLower . f) . T.toLower
357-- | /Case insensitive/.
358--
359-- Parse values case insensitively based on @'ToHttpApiData'@ instance.
360-- Uses @'toUrlPiece'@ to get possible values.
361parseBoundedUrlPiece :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a
362parseBoundedUrlPiece = parseBoundedEnumOfI toUrlPiece
364-- | /Case insensitive/.
365--
366-- Parse values case insensitively based on @'ToHttpApiData'@ instance.
367-- Uses @'toQueryParam'@ to get possible values.
368parseBoundedQueryParam :: (ToHttpApiData a, Bounded a, Enum a) => Text -> Either Text a
369parseBoundedQueryParam = parseBoundedEnumOfI toQueryParam
371-- | Parse values based on @'ToHttpApiData'@ instance.
372-- Uses @'toHeader'@ to get possible values.
373parseBoundedHeader :: (ToHttpApiData a, Bounded a, Enum a) => ByteString -> Either Text a
374parseBoundedHeader bs = case lookupBoundedEnumOf toHeader bs of
375 Nothing -> defaultParseError $ T.pack $ show bs
376 Just x -> return x
378-- | Parse URL piece using @'Read'@ instance.
379--
380-- Use for types which do not involve letters:
381--
382-- >>> readTextData "1991-06-02" :: Either Text Day
383-- Right 1991-06-02
384--
385-- This parser is case sensitive and will not match @'showTextData'@
386-- in presence of letters:
387--
388-- >>> readTextData (showTextData True) :: Either Text Bool
389-- Left "could not parse: `true'"
390--
391-- See @'parseBoundedTextData'@.
392readTextData :: Read a => Text -> Either Text a
393readTextData = parseMaybeTextData (readMaybe . T.unpack)
395-- | Run @'Reader'@ as HTTP API data parser.
396runReader :: Reader a -> Text -> Either Text a
397runReader reader input =
398 case reader input of
399 Left err -> Left ("could not parse: `" <> input <> "' (" <> T.pack err <> ")")
400 Right (x, rest)
401 | T.null rest -> Right x
402 | otherwise -> defaultParseError input
404-- | Run @'Reader'@ to parse bounded integral value with bounds checking.
405--
406-- >>> parseBounded decimal "256" :: Either Text Word8
407-- Left "out of bounds: `256' (should be between 0 and 255)"
408parseBounded :: forall a. (Bounded a, Integral a) => Reader Integer -> Text -> Either Text a
409parseBounded reader input = do
410 n <- runReader reader input
411 if (n > h || n < l)
412 then Left ("out of bounds: `" <> input <> "' (should be between " <> showt l <> " and " <> showt h <> ")")
413 else Right (fromInteger n)
414 where
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.
422unsafeToEncodedUrlPiece :: ToHttpApiData a => a -> BS.Builder
423unsafeToEncodedUrlPiece = BS.byteString . encodeUtf8 . toUrlPiece
425-- |
426-- >>> toUrlPiece ()
427-- "_"
428instance ToHttpApiData () where
429 toUrlPiece () = "_"
430 toEncodedUrlPiece = unsafeToEncodedUrlPiece
432instance ToHttpApiData Char where
433 toUrlPiece = T.singleton
435-- |
436-- >>> toUrlPiece (Version [1, 2, 3] [])
437-- "1.2.3"
438instance ToHttpApiData Version where
439 toUrlPiece = T.pack . showVersion
440 toEncodedUrlPiece = unsafeToEncodedUrlPiece
442instance ToHttpApiData Void where toUrlPiece = absurd
443instance ToHttpApiData Natural where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
445instance ToHttpApiData Bool where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece
446instance ToHttpApiData Ordering where toUrlPiece = showTextData; toEncodedUrlPiece = unsafeToEncodedUrlPiece
448instance ToHttpApiData Double where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
449instance ToHttpApiData Float where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
450instance ToHttpApiData Int where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
451instance ToHttpApiData Int8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
452instance ToHttpApiData Int16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
453instance ToHttpApiData Int32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
454instance ToHttpApiData Int64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
455instance ToHttpApiData Integer where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
456instance ToHttpApiData Word where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
457instance ToHttpApiData Word8 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
458instance ToHttpApiData Word16 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
459instance ToHttpApiData Word32 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
460instance ToHttpApiData Word64 where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
462-- | Note: this instance is not polykinded
463instance F.HasResolution a => ToHttpApiData (F.Fixed (a :: Type)) where toUrlPiece = showt; toEncodedUrlPiece = unsafeToEncodedUrlPiece
465-- |
466-- >>> toUrlPiece (fromGregorian 2015 10 03)
467-- "2015-10-03"
468instance ToHttpApiData Day where
469 toUrlPiece = T.pack . show
470 toEncodedUrlPiece = unsafeToEncodedUrlPiece
472timeToUrlPiece :: FormatTime t => String -> t -> Text
473timeToUrlPiece fmt = T.pack . formatTime defaultTimeLocale (iso8601DateFormat (Just fmt))
475-- |
476-- >>> toUrlPiece $ TimeOfDay 14 55 23.1
477-- "14:55:23.1"
478instance ToHttpApiData TimeOfDay where
479 toUrlPiece = T.pack . formatTime defaultTimeLocale "%H:%M:%S%Q"
480 toEncodedUrlPiece = unsafeToEncodedUrlPiece
482-- |
483-- >>> toUrlPiece $ LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 21.687)
484-- "2015-10-03T14:55:21.687"
485instance ToHttpApiData LocalTime where
486 toUrlPiece = timeToUrlPiece "%H:%M:%S%Q"
487 toEncodedUrlPiece = unsafeToEncodedUrlPiece
489-- |
490-- >>> toUrlPiece $ ZonedTime (LocalTime (fromGregorian 2015 10 03) (TimeOfDay 14 55 51.001)) utc
491-- "2015-10-03T14:55:51.001+0000"
492instance ToHttpApiData ZonedTime where
493 toUrlPiece = timeToUrlPiece "%H:%M:%S%Q%z"
494 toEncodedUrlPiece = unsafeToEncodedUrlPiece
496-- |
497-- >>> toUrlPiece $ UTCTime (fromGregorian 2015 10 03) 864.5
498-- "2015-10-03T00:14:24.5Z"
499instance ToHttpApiData UTCTime where
500 toUrlPiece = timeToUrlPiece "%H:%M:%S%QZ"
501 toEncodedUrlPiece = unsafeToEncodedUrlPiece
503-- |
504-- >>> toUrlPiece Monday
505-- "monday"
506instance 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
517-- |
518-- >>> toUrlPiece Q4
519-- "q4"
520instance ToHttpApiData QuarterOfYear where
521 toUrlPiece Q1 = "q1"
522 toUrlPiece Q2 = "q2"
523 toUrlPiece Q3 = "q3"
524 toUrlPiece Q4 = "q4"
526-- |
527-- >>> import Data.Time.Calendar.Quarter.Compat (Quarter (..))
528-- >>> MkQuarter 8040
529-- 2010-Q1
530--
531-- >>> toUrlPiece $ MkQuarter 8040
532-- "2010-q1"
533--
534instance 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"
543-- |
544-- >>> import Data.Time.Calendar.Month.Compat (Month (..))
545-- >>> MkMonth 24482
546-- 2040-03
547--
548-- >>> toUrlPiece $ MkMonth 24482
549-- "2040-03"
550--
551instance ToHttpApiData Month where
552 toUrlPiece = T.pack . formatTime defaultTimeLocale "%Y-%m"
554instance ToHttpApiData NominalDiffTime where
555 toUrlPiece = toUrlPiece . nominalDiffTimeToSeconds
556 toEncodedUrlPiece = unsafeToEncodedUrlPiece
558instance ToHttpApiData String where toUrlPiece = T.pack
559instance ToHttpApiData Text where toUrlPiece = id
560instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
562instance ToHttpApiData All where
563 toUrlPiece = coerce (toUrlPiece :: Bool -> Text)
564 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder)
566instance ToHttpApiData Any where
567 toUrlPiece = coerce (toUrlPiece :: Bool -> Text)
568 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Bool -> BS.Builder)
570instance ToHttpApiData a => ToHttpApiData (Dual a) where
571 toUrlPiece = coerce (toUrlPiece :: a -> Text)
572 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
574instance ToHttpApiData a => ToHttpApiData (Sum a) where
575 toUrlPiece = coerce (toUrlPiece :: a -> Text)
576 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
578instance ToHttpApiData a => ToHttpApiData (Product a) where
579 toUrlPiece = coerce (toUrlPiece :: a -> Text)
580 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
582instance ToHttpApiData a => ToHttpApiData (First a) where
583 toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)
584 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)
586instance ToHttpApiData a => ToHttpApiData (Last a) where
587 toUrlPiece = coerce (toUrlPiece :: Maybe a -> Text)
588 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: Maybe a -> BS.Builder)
590instance ToHttpApiData a => ToHttpApiData (Semi.Min a) where
591 toUrlPiece = coerce (toUrlPiece :: a -> Text)
592 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
594instance ToHttpApiData a => ToHttpApiData (Semi.Max a) where
595 toUrlPiece = coerce (toUrlPiece :: a -> Text)
596 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
598instance ToHttpApiData a => ToHttpApiData (Semi.First a) where
599 toUrlPiece = coerce (toUrlPiece :: a -> Text)
600 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
602instance ToHttpApiData a => ToHttpApiData (Semi.Last a) where
603 toUrlPiece = coerce (toUrlPiece :: a -> Text)
604 toEncodedUrlPiece = coerce (toEncodedUrlPiece :: a -> BS.Builder)
606-- |
607-- >>> toUrlPiece (Just "Hello")
608-- "just Hello"
609instance ToHttpApiData a => ToHttpApiData (Maybe a) where
610 toUrlPiece (Just x) = "just " <> toUrlPiece x
611 toUrlPiece Nothing = "nothing"
613-- |
614-- >>> toUrlPiece (Left "err" :: Either String Int)
615-- "left err"
616-- >>> toUrlPiece (Right 3 :: Either String Int)
617-- "right 3"
618instance (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
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--
631instance 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
637instance 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)
643-- | @since 0.4.2
644instance 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)
650-- | @since 0.4.2
651instance 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)
657-- |
658-- >>> parseUrlPiece "_" :: Either Text ()
659-- Right ()
660instance FromHttpApiData () where
661 parseUrlPiece "_" = pure ()
662 parseUrlPiece s = defaultParseError s
664instance FromHttpApiData Char where
665 parseUrlPiece s =
666 case T.uncons s of
667 Just (c, s') | T.null s' -> pure c
668 _ -> defaultParseError s
670-- |
671-- >>> showVersion <$> parseUrlPiece "1.2.3"
672-- Right "1.2.3"
673instance FromHttpApiData Version where
674 parseUrlPiece s =
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.
680instance FromHttpApiData Void where
681 parseUrlPiece _ = Left "Void cannot be parsed!"
683instance FromHttpApiData Natural where
684 parseUrlPiece s = do
685 n <- runReader (signed decimal) s
686 if n < 0
687 then Left ("underflow: " <> s <> " (should be a non-negative integer)")
688 else Right (fromInteger n)
690instance FromHttpApiData Bool where parseUrlPiece = parseBoundedUrlPiece
691instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedUrlPiece
692instance FromHttpApiData Double where parseUrlPiece = runReader rational
693instance FromHttpApiData Float where parseUrlPiece = runReader rational
694instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal)
695instance FromHttpApiData Int8 where parseUrlPiece = parseBounded (signed decimal)
696instance FromHttpApiData Int16 where parseUrlPiece = parseBounded (signed decimal)
697instance FromHttpApiData Int32 where parseUrlPiece = parseBounded (signed decimal)
698instance FromHttpApiData Int64 where parseUrlPiece = parseBounded (signed decimal)
699instance FromHttpApiData Integer where parseUrlPiece = runReader (signed decimal)
700instance FromHttpApiData Word where parseUrlPiece = parseBounded decimal
701instance FromHttpApiData Word8 where parseUrlPiece = parseBounded decimal
702instance FromHttpApiData Word16 where parseUrlPiece = parseBounded decimal
703instance FromHttpApiData Word32 where parseUrlPiece = parseBounded decimal
704instance FromHttpApiData Word64 where parseUrlPiece = parseBounded decimal
705instance FromHttpApiData String where parseUrlPiece = Right . T.unpack
706instance FromHttpApiData Text where parseUrlPiece = Right
707instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
709-- | Note: this instance is not polykinded
710instance F.HasResolution a => FromHttpApiData (F.Fixed (a :: Type)) where
711 parseUrlPiece = runReader rational
713-- |
714-- >>> toGregorian <$> parseUrlPiece "2016-12-01"
715-- Right (2016,12,1)
716instance FromHttpApiData Day where parseUrlPiece = runAtto Atto.day
718-- |
719-- >>> parseUrlPiece "14:55:01.333" :: Either Text TimeOfDay
720-- Right 14:55:01.333
721instance FromHttpApiData TimeOfDay where parseUrlPiece = runAtto Atto.timeOfDay
723-- |
724-- >>> parseUrlPiece "2015-10-03T14:55:01" :: Either Text LocalTime
725-- Right 2015-10-03 14:55:01
726instance FromHttpApiData LocalTime where parseUrlPiece = runAtto Atto.localTime
728-- |
729-- >>> parseUrlPiece "2015-10-03T14:55:01+0000" :: Either Text ZonedTime
730-- Right 2015-10-03 14:55:01 +0000
731--
732-- >>> parseQueryParam "2016-12-31T01:00:00Z" :: Either Text ZonedTime
733-- Right 2016-12-31 01:00:00 +0000
734instance FromHttpApiData ZonedTime where parseUrlPiece = runAtto Atto.zonedTime
736-- |
737-- >>> parseUrlPiece "2015-10-03T00:14:24Z" :: Either Text UTCTime
738-- Right 2015-10-03 00:14:24 UTC
739instance FromHttpApiData UTCTime where parseUrlPiece = runAtto Atto.utcTime
741-- |
742-- >>> parseUrlPiece "Monday" :: Either Text DayOfWeek
743-- Right Monday
744instance 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] ]
753instance FromHttpApiData NominalDiffTime where parseUrlPiece = fmap secondsToNominalDiffTime . parseUrlPiece
755-- |
756-- >>> parseUrlPiece "2021-01" :: Either Text Month
757-- Right 2021-01
758instance FromHttpApiData Month where parseUrlPiece = runAtto Atto.month
760-- |
761-- >>> parseUrlPiece "2021-q1" :: Either Text Quarter
762-- Right 2021-Q1
763instance FromHttpApiData Quarter where parseUrlPiece = runAtto Atto.quarter
765-- |
766-- >>> parseUrlPiece "q2" :: Either Text QuarterOfYear
767-- Right Q2
768--
769-- >>> parseUrlPiece "Q3" :: Either Text QuarterOfYear
770-- Right Q3
771instance 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"
779instance FromHttpApiData All where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
780instance FromHttpApiData Any where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text Bool)
782instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
783instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
784instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
785instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a))
786instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text (Maybe a))
788instance FromHttpApiData a => FromHttpApiData (Semi.Min a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
789instance FromHttpApiData a => FromHttpApiData (Semi.Max a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
790instance FromHttpApiData a => FromHttpApiData (Semi.First a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
791instance FromHttpApiData a => FromHttpApiData (Semi.Last a) where parseUrlPiece = coerce (parseUrlPiece :: Text -> Either Text a)
793-- |
794-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
795-- Right (Just 123)
796instance FromHttpApiData a => FromHttpApiData (Maybe a) where
797 parseUrlPiece s
798 | T.toLower (T.take 7 s) == "nothing" = pure Nothing
799 | otherwise = Just <$> parseUrlPieceWithPrefix "Just " s
801-- |
802-- >>> parseUrlPiece "Right 123" :: Either Text (Either String Int)
803-- Right (Right 123)
804instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b) where
805 parseUrlPiece s =
806 Right <$> parseUrlPieceWithPrefix "Right " s
807 <!> Left <$> parseUrlPieceWithPrefix "Left " s
808 where
809 infixl 3 <!>
810 Left _ <!> y = y
811 x <!> _ = x
813instance ToHttpApiData UUID.UUID where
814 toUrlPiece = UUID.toText
815 toHeader = UUID.toASCIIBytes
816 toEncodedUrlPiece = unsafeToEncodedUrlPiece
818instance 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`.
824--
825-- @since 0.3.5
826newtype LenientData a = LenientData { getLenientData :: Either Text a }
827 deriving (Eq, Ord, Show, Read, Typeable, Data, Functor, Foldable, Traversable)
829instance 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
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})
838instance FromHttpApiData SetCookie where
839 parseUrlPiece = parseHeader . encodeUtf8
840 parseHeader = Right . parseSetCookie
842-- | Note: this instance is not polykinded
843instance 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)
848-- | @since 0.4.2
849instance 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)
854-- | @since 0.4.2
855instance 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-------------------------------------------------------------------------------
864runAtto :: Atto.Parser a -> Text -> Either Text a
865runAtto p t = case Atto.parseOnly (p <* Atto.endOfInput) t of
866 Left err -> Left (T.pack err)
867 Right x -> Right x