git.iko.soy/typeable/http-api-data
on 008fff8 help sign in
typeable/http-api-data/Web/HttpApiData/Internal.hs
376 lines 14 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE DefaultSignatures #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TypeSynonymInstances #-}
7-- |
8-- Convert Haskell values to and from HTTP API data
9-- such as URL pieces, headers and query parameters.
10module Web.HttpApiData.Internal where
12import Control.Applicative
13import Control.Arrow ((&&&))
15import Data.Monoid
16import Data.ByteString (ByteString)
18import Data.Int
19import Data.Word
21import Data.Text (Text)
22import Data.Text.Encoding (encodeUtf8, decodeUtf8)
23import Data.Text.Read (signed, decimal, rational, Reader)
24import qualified Data.Text as T
25import qualified Data.Text.Lazy as L
27import Data.Time (Day)
28import Data.Version
30#if MIN_VERSION_base(4,8,0)
31import Data.Void
32#endif
34import Text.Read (readMaybe)
35import Text.ParserCombinators.ReadP (readP_to_S)
37#if USE_TEXT_SHOW
38import TextShow (TextShow, showt)
39#endif
41-- | Convert value to HTTP API data.
42class ToHttpApiData a where
43 {-# MINIMAL toUrlPiece | toQueryParam #-}
44 -- | Convert to URL path piece.
45 toUrlPiece :: a -> Text
46 toUrlPiece = toQueryParam
48 -- | Convert to HTTP header value.
49 toHeader :: a -> ByteString
50 toHeader = encodeUtf8 . toUrlPiece
52 -- | Convert to query param value.
53 toQueryParam :: a -> Text
54 toQueryParam = toUrlPiece
56-- | Parse value from HTTP API data.
57class FromHttpApiData a where
58 {-# MINIMAL parseUrlPiece | parseQueryParam #-}
59 -- | Parse URL path piece.
60 parseUrlPiece :: Text -> Either Text a
61 parseUrlPiece = parseQueryParam
63 -- | Parse HTTP header value.
64 parseHeader :: ByteString -> Either Text a
65 parseHeader = parseUrlPiece . decodeUtf8
67 -- | Parse query param value.
68 parseQueryParam :: Text -> Either Text a
69 parseQueryParam = parseUrlPiece
71-- | Parse URL path piece in a @'Maybe'@.
72--
73-- >>> parseUrlPieceMaybe "12" :: Maybe Int
74-- Just 12
75parseUrlPieceMaybe :: FromHttpApiData a => Text -> Maybe a
76parseUrlPieceMaybe = either (const Nothing) Just . parseUrlPiece
78-- | Parse HTTP header value in a @'Maybe'@.
79--
80-- >>> parseHeaderMaybe "hello" :: Maybe Text
81-- Just "hello"
82parseHeaderMaybe :: FromHttpApiData a => ByteString -> Maybe a
83parseHeaderMaybe = either (const Nothing) Just . parseHeader
85-- | Parse query param value in a @'Maybe'@.
86--
87-- >>> parseQueryParamMaybe "true" :: Maybe Bool
88-- Just True
89parseQueryParamMaybe :: FromHttpApiData a => Text -> Maybe a
90parseQueryParamMaybe = either (const Nothing) Just . parseQueryParam
92-- | Default parsing error.
93defaultParseError :: Text -> Either Text a
94defaultParseError input = Left ("could not parse: `" <> input <> "'")
96-- | Convert @'Maybe'@ parser into @'Either' 'Text'@ parser with default error message.
97parseMaybeTextData :: (Text -> Maybe a) -> (Text -> Either Text a)
98parseMaybeTextData parse input =
99 case parse input of
100 Nothing -> defaultParseError input
101 Just val -> Right val
103#if USE_TEXT_SHOW
104-- | Convert to URL piece using @'TextShow'@ instance.
105-- The result is always lower cased.
106--
107-- >>> showTextData True
108-- "true"
109--
110-- This can be used as a default implementation for enumeration types:
111--
112-- @
113-- data MyData = Foo | Bar | Baz deriving (Generic)
114--
115-- instance TextShow MyData where
116-- showt = genericShowt
117--
118-- instance ToHttpApiData MyData where
119-- toUrlPiece = showTextData
120-- @
121showTextData :: TextShow a => a -> Text
122showTextData = T.toLower . showt
123#else
124-- | Convert to URL piece using @'Show'@ instance.
125-- The result is always lower cased.
126--
127-- >>> showTextData True
128-- "true"
129--
130-- This can be used as a default implementation for enumeration types:
131--
132-- >>> data MyData = Foo | Bar | Baz deriving (Show)
133-- >>> instance ToHttpApiData MyData where toUrlPiece = showTextData
134-- >>> toUrlPiece Foo
135-- "foo"
136showTextData :: Show a => a -> Text
137showTextData = T.toLower . showt
139-- | Like @'show'@, but returns @'Text'@.
140showt :: Show a => a -> Text
141showt = T.pack . show
142#endif
144-- | Parse given text case insensitive and return the rest of the input.
145--
146-- >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int
147-- Right 10
148-- >>> parseUrlPieceWithPrefix "Left " "left" :: Either Text Bool
149-- Left "could not parse: `left'"
150--
151-- This can be used to implement @'FromHttpApiData'@ for single field constructors:
152--
153-- >>> data Foo = Foo Int deriving (Show)
154-- >>> instance FromHttpApiData Foo where parseUrlPiece s = Foo <$> parseUrlPieceWithPrefix "Foo " s
155-- >>> parseUrlPiece "foo 1" :: Either Text Foo
156-- Right (Foo 1)
157parseUrlPieceWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a
158parseUrlPieceWithPrefix pattern input
159 | T.toLower pattern == T.toLower prefix = parseUrlPiece rest
160 | otherwise = defaultParseError input
161 where
162 (prefix, rest) = T.splitAt (T.length pattern) input
164#if USE_TEXT_SHOW
165-- | Parse values case insensitively based on @'TextShow'@ instance.
166--
167-- >>> parseBoundedCaseInsensitiveTextData "true" :: Either Text Bool
168-- Right True
169-- >>> parseBoundedCaseInsensitiveTextData "FALSE" :: Either Text Bool
170-- Right False
171--
172-- This can be used as a default implementation for enumeration types:
173--
174-- @
175-- data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum, Generic)
176--
177-- instance TextShow MyData where
178-- showt = genericShowt
179--
180-- instance FromHttpApiData MyData where
181-- parseUrlPiece = parseBoundedCaseInsensitiveTextData
182-- @
183parseBoundedCaseInsensitiveTextData :: forall a. (TextShow a, Bounded a, Enum a) => Text -> Either Text a
184#else
185-- | Parse values case insensitively based on @'Show'@ instance.
186--
187-- >>> parseBoundedCaseInsensitiveTextData "true" :: Either Text Bool
188-- Right True
189-- >>> parseBoundedCaseInsensitiveTextData "FALSE" :: Either Text Bool
190-- Right False
191--
192-- This can be used as a default implementation for enumeration types:
193--
194-- >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum)
195-- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedCaseInsensitiveTextData
196-- >>> parseUrlPiece "foo" :: Either Text MyData
197-- Right Foo
198parseBoundedCaseInsensitiveTextData :: forall a. (Show a, Bounded a, Enum a) => Text -> Either Text a
199#endif
200parseBoundedCaseInsensitiveTextData = parseMaybeTextData (flip lookup values . T.toLower)
201 where
202 values = map (showTextData &&& id) [minBound..maxBound :: a]
204-- | Parse URL piece using @'Read'@ instance.
205readMaybeTextData :: Read a => Text -> Maybe a
206readMaybeTextData = readMaybe . T.unpack
208-- | Parse URL piece using @'Read'@ instance.
209readEitherTextData :: Read a => Text -> Either Text a
210readEitherTextData = parseMaybeTextData readMaybeTextData
212-- | Run @'Reader'@ as HTTP API data parser.
213runReader :: Reader a -> Text -> Either Text a
214runReader reader input =
215 case reader input of
216 Left err -> Left (T.pack err)
217 Right (x, rest)
218 | T.null rest -> Right x
219 | otherwise -> defaultParseError input
221-- | Run @'Reader'@ to parse bounded integral value with bounds checking.
222--
223-- >>> parseBounded decimal "256" :: Either Text Word8
224-- Left "out of bounds: `256' (should be between 0 and 255)"
225parseBounded :: forall a. (Bounded a, Integral a) => Reader Integer -> Text -> Either Text a
226parseBounded reader input = do
227 n <- runReader reader input
228 if (n > h || n < l)
229 then Left ("out of bounds: `" <> input <> "' (should be between " <> T.pack (show l) <> " and " <> T.pack (show h) <> ")")
230 else Right (fromInteger n)
231 where
232 l = toInteger (minBound :: a)
233 h = toInteger (maxBound :: a)
235-- |
236-- >>> toUrlPiece ()
237-- "_"
238instance ToHttpApiData () where
239 toUrlPiece () = "_"
241instance ToHttpApiData Char where toUrlPiece = T.singleton
243-- |
244-- >>> toUrlPiece (Version [1, 2, 3] [])
245-- "1.2.3"
246instance ToHttpApiData Version where
247 toUrlPiece = T.pack . showVersion
249#if MIN_VERSION_base(4,8,0)
250instance ToHttpApiData Void where
251 toUrlPiece = absurd
252#endif
254instance ToHttpApiData Bool where toUrlPiece = showTextData
255instance ToHttpApiData Ordering where toUrlPiece = showTextData
257instance ToHttpApiData Double where toUrlPiece = showt
258instance ToHttpApiData Float where toUrlPiece = showt
259instance ToHttpApiData Int where toUrlPiece = showt
260instance ToHttpApiData Int8 where toUrlPiece = showt
261instance ToHttpApiData Int16 where toUrlPiece = showt
262instance ToHttpApiData Int32 where toUrlPiece = showt
263instance ToHttpApiData Int64 where toUrlPiece = showt
264instance ToHttpApiData Integer where toUrlPiece = showt
265instance ToHttpApiData Word where toUrlPiece = showt
266instance ToHttpApiData Word8 where toUrlPiece = showt
267instance ToHttpApiData Word16 where toUrlPiece = showt
268instance ToHttpApiData Word32 where toUrlPiece = showt
269instance ToHttpApiData Word64 where toUrlPiece = showt
270instance ToHttpApiData Day where toUrlPiece = T.pack . show
272instance ToHttpApiData String where toUrlPiece = T.pack
273instance ToHttpApiData Text where toUrlPiece = id
274instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
276instance ToHttpApiData All where toUrlPiece = toUrlPiece . getAll
277instance ToHttpApiData Any where toUrlPiece = toUrlPiece . getAny
279instance ToHttpApiData a => ToHttpApiData (Dual a) where toUrlPiece = toUrlPiece . getDual
280instance ToHttpApiData a => ToHttpApiData (Sum a) where toUrlPiece = toUrlPiece . getSum
281instance ToHttpApiData a => ToHttpApiData (Product a) where toUrlPiece = toUrlPiece . getProduct
282instance ToHttpApiData a => ToHttpApiData (First a) where toUrlPiece = toUrlPiece . getFirst
283instance ToHttpApiData a => ToHttpApiData (Last a) where toUrlPiece = toUrlPiece . getLast
285-- |
286-- >>> toUrlPiece (Just "Hello")
287-- "just Hello"
288instance ToHttpApiData a => ToHttpApiData (Maybe a) where
289 toUrlPiece (Just x) = "just " <> toUrlPiece x
290 toUrlPiece Nothing = "nothing"
292-- |
293-- >>> toUrlPiece (Left "err" :: Either String Int)
294-- "left err"
295-- >>> toUrlPiece (Right 3 :: Either String Int)
296-- "right 3"
297instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where
298 toUrlPiece (Left x) = "left " <> toUrlPiece x
299 toUrlPiece (Right x) = "right " <> toUrlPiece x
301-- |
302-- >>> parseUrlPiece "_" :: Either Text ()
303-- Right ()
304instance FromHttpApiData () where
305 parseUrlPiece "_" = return ()
306 parseUrlPiece s = defaultParseError s
308instance FromHttpApiData Char where
309 parseUrlPiece s =
310 case T.uncons s of
311 Just (c, s') | T.null s' -> return c
312 _ -> defaultParseError s
314-- |
315-- >>> showVersion <$> parseUrlPiece "1.2.3"
316-- Right "1.2.3"
317instance FromHttpApiData Version where
318 parseUrlPiece s =
319 case reverse (readP_to_S parseVersion (T.unpack s)) of
320 ((x, ""):_) -> return x
321 _ -> defaultParseError s
323#if MIN_VERSION_base(4,8,0)
324instance FromHttpApiData Void where
325 parseUrlPiece _ = Left "Void cannot be parsed!"
326#endif
328instance FromHttpApiData Bool where parseUrlPiece = parseBoundedCaseInsensitiveTextData
329instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedCaseInsensitiveTextData
330instance FromHttpApiData Double where parseUrlPiece = runReader rational
331instance FromHttpApiData Float where parseUrlPiece = runReader rational
332instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal)
333instance FromHttpApiData Int8 where parseUrlPiece = parseBounded (signed decimal)
334instance FromHttpApiData Int16 where parseUrlPiece = parseBounded (signed decimal)
335instance FromHttpApiData Int32 where parseUrlPiece = parseBounded (signed decimal)
336instance FromHttpApiData Int64 where parseUrlPiece = parseBounded (signed decimal)
337instance FromHttpApiData Integer where parseUrlPiece = runReader (signed decimal)
338instance FromHttpApiData Word where parseUrlPiece = parseBounded decimal
339instance FromHttpApiData Word8 where parseUrlPiece = parseBounded decimal
340instance FromHttpApiData Word16 where parseUrlPiece = parseBounded decimal
341instance FromHttpApiData Word32 where parseUrlPiece = parseBounded decimal
342instance FromHttpApiData Word64 where parseUrlPiece = parseBounded decimal
343instance FromHttpApiData String where parseUrlPiece = Right . T.unpack
344instance FromHttpApiData Text where parseUrlPiece = Right
345instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
346instance FromHttpApiData Day where parseUrlPiece = readEitherTextData
348instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece
349instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece
351instance FromHttpApiData a => FromHttpApiData (Dual a) where parseUrlPiece = fmap Dual . parseUrlPiece
352instance FromHttpApiData a => FromHttpApiData (Sum a) where parseUrlPiece = fmap Sum . parseUrlPiece
353instance FromHttpApiData a => FromHttpApiData (Product a) where parseUrlPiece = fmap Product . parseUrlPiece
354instance FromHttpApiData a => FromHttpApiData (First a) where parseUrlPiece = fmap First . parseUrlPiece
355instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece = fmap Last . parseUrlPiece
357-- |
358-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
359-- Right (Just 123)
360instance FromHttpApiData a => FromHttpApiData (Maybe a) where
361 parseUrlPiece s
362 | T.toLower (T.take 7 s) == "nothing" = return Nothing
363 | otherwise = Just <$> parseUrlPieceWithPrefix "Just " s
365-- |
366-- >>> parseUrlPiece "Right 123" :: Either Text (Either String Int)
367-- Right (Right 123)
368instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b) where
369 parseUrlPiece s =
370 Right <$> parseUrlPieceWithPrefix "Right " s
371 <!> Left <$> parseUrlPieceWithPrefix "Left " s
372 where
373 infixl 3 <!>
374 Left _ <!> y = y
375 x <!> _ = x