@@ -9,11 +9,14 @@
9-- such as URL pieces, headers and query parameters.
9-- such as URL pieces, headers and query parameters.
10module Web.HttpApiData.Internal where
10module Web.HttpApiData.Internal where
12+#if __GLASGOW_HASKELL__ < 710
12import Control.Applicative
13import Control.Applicative
13import Control.Arrow ((&&&))
15import Control.Arrow ((&&&))
15import Data.Monoid
17import Data.Monoid
16import Data.ByteString (ByteString)
18import Data.ByteString (ByteString)
19+import qualified Data.ByteString as BS
18import Data.Int
21import Data.Int
19import Data.Word
22import Data.Word
@@ -24,7 +27,7 @@ import Data.Text.Read (signed, decimal, rational, Reader)
24import qualified Data.Text as T
27import qualified Data.Text as T
25import qualified Data.Text.Lazy as L
28import qualified Data.Text.Lazy as L
27−import Data.Time (Day)
30+import Data.Time
28import Data.Version
31import Data.Version
30#if MIN_VERSION_base(4,8,0)
33#if MIN_VERSION_base(4,8,0)
@@ -38,9 +41,6 @@ import Text.ParserCombinators.ReadP (readP_to_S)
38import TextShow (TextShow, showt)
41import TextShow (TextShow, showt)
42−-- >>> import Data.Time
44-- | Convert value to HTTP API data.
44-- | Convert value to HTTP API data.
45class ToHttpApiData a where
45class ToHttpApiData a where
46 {-# MINIMAL toUrlPiece | toQueryParam #-}
46 {-# MINIMAL toUrlPiece | toQueryParam #-}
@@ -104,7 +104,9 @@ parseMaybeTextData parse input =
104 Just val -> Right val
104 Just val -> Right val
106#if USE_TEXT_SHOW
106#if USE_TEXT_SHOW
107−-- | Convert to URL piece using @'TextShow'@ instance.
109+-- Convert to URL piece using @'TextShow'@ instance.
108-- The result is always lower cased.
110-- The result is always lower cased.
110-- >>> showTextData True
112-- >>> showTextData True
@@ -124,7 +126,9 @@ parseMaybeTextData parse input =
124showTextData :: TextShow a => a -> Text
126showTextData :: TextShow a => a -> Text
125showTextData = T.toLower . showt
127showTextData = T.toLower . showt
127−-- | Convert to URL piece using @'Show'@ instance.
131+-- Convert to URL piece using @'Show'@ instance.
128-- The result is always lower cased.
132-- The result is always lower cased.
130-- >>> showTextData True
134-- >>> showTextData True
@@ -144,7 +148,10 @@ showt :: Show a => a -> Text
144showt = T.pack . show
148showt = T.pack . show
151+-- | /Case insensitive/.
147−-- | Parse given text case insensitive and return the rest of the input.
153+-- Parse given text case insensitive and then parse the rest of the input
154+-- using @'parseUrlPiece'@.
149-- >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int
156-- >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int
150-- Right 10
157-- Right 10
@@ -164,12 +171,49 @@ parseUrlPieceWithPrefix pattern input
165 (prefix, rest) = T.splitAt (T.length pattern) input
172 (prefix, rest) = T.splitAt (T.length pattern) input
175+-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
176+-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p
178+-- | Parse given bytestring then parse the rest of the input using @'parseHeader'@.
181+-- data BasicAuthToken = BasicAuthToken Text deriving (Show)
183+-- instance FromHttpApiData BasicAuthToken where
184+-- parseHeader h = BasicAuthToken \<$\> parseHeaderWithPrefix "Basic " h
185+-- parseQueryParam p = BasicAuthToken \<$\> parseQueryParam p
188+-- >>> parseHeader "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" :: Either Text BasicAuthToken
189+-- Right (BasicAuthToken "QWxhZGRpbjpvcGVuIHNlc2FtZQ==")
190+parseHeaderWithPrefix :: FromHttpApiData a => ByteString -> ByteString -> Either Text a
191+parseHeaderWithPrefix pattern input
192+ | pattern `BS.isPrefixOf` input = parseHeader (BS.drop (BS.length pattern) input)
193+ | otherwise = defaultParseError (showt input)
195+-- | /Case insensitive/.
197+-- Parse given text case insensitive and then parse the rest of the input
198+-- using @'parseQueryParam'@.
200+-- >>> parseQueryParamWithPrefix "z" "z10" :: Either Text Int
202+parseQueryParamWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a
203+parseQueryParamWithPrefix pattern input
204+ | T.toLower pattern == T.toLower prefix = parseQueryParam rest
205+ | otherwise = defaultParseError input
207+ (prefix, rest) = T.splitAt (T.length pattern) input
167#if USE_TEXT_SHOW
209#if USE_TEXT_SHOW
210+-- | /Case insensitive/.
168−-- | Parse values case insensitively based on @'TextShow'@ instance.
212+-- Parse values case insensitively based on @'TextShow'@ instance.
170−-- >>> parseBoundedCaseInsensitiveTextData "true" :: Either Text Bool
214+-- >>> parseBoundedTextData "true" :: Either Text Bool
171-- Right True
215-- Right True
172−-- >>> parseBoundedCaseInsensitiveTextData "FALSE" :: Either Text Bool
216+-- >>> parseBoundedTextData "FALSE" :: Either Text Bool
173-- Right False
217-- Right False
175-- This can be used as a default implementation for enumeration types:
219-- This can be used as a default implementation for enumeration types:
@@ -181,36 +225,47 @@ parseUrlPieceWithPrefix pattern input
181-- showt = genericShowt
225-- showt = genericShowt
183-- instance FromHttpApiData MyData where
227-- instance FromHttpApiData MyData where
184−-- parseUrlPiece = parseBoundedCaseInsensitiveTextData
228+-- parseUrlPiece = parseBoundedTextData
186−parseBoundedCaseInsensitiveTextData :: forall a. (TextShow a, Bounded a, Enum a) => Text -> Either Text a
230+parseBoundedTextData :: (TextShow a, Bounded a, Enum a) => Text -> Either Text a
232+-- | /Case insensitive/.
188−-- | Parse values case insensitively based on @'Show'@ instance.
234+-- Parse values case insensitively based on @'Show'@ instance.
190−-- >>> parseBoundedCaseInsensitiveTextData "true" :: Either Text Bool
236+-- >>> parseBoundedTextData "true" :: Either Text Bool
191-- Right True
237-- Right True
192−-- >>> parseBoundedCaseInsensitiveTextData "FALSE" :: Either Text Bool
238+-- >>> parseBoundedTextData "FALSE" :: Either Text Bool
193-- Right False
239-- Right False
195-- This can be used as a default implementation for enumeration types:
241-- This can be used as a default implementation for enumeration types:
197-- >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum)
243-- >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum)
198−-- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedCaseInsensitiveTextData
244+-- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedTextData
199-- >>> parseUrlPiece "foo" :: Either Text MyData
245-- >>> parseUrlPiece "foo" :: Either Text MyData
200-- Right Foo
246-- Right Foo
201−parseBoundedCaseInsensitiveTextData :: forall a. (Show a, Bounded a, Enum a) => Text -> Either Text a
247+parseBoundedTextData :: (Show a, Bounded a, Enum a) => Text -> Either Text a
203−parseBoundedCaseInsensitiveTextData = parseMaybeTextData (flip lookup values . T.toLower)
249+parseBoundedTextData = parseMaybeTextData (flip lookup values . T.toLower)
205− values = map (showTextData &&& id) [minBound..maxBound :: a]
251+ values = map (showTextData &&& id) [minBound..maxBound]
207-- | Parse URL piece using @'Read'@ instance.
253-- | Parse URL piece using @'Read'@ instance.
208−readMaybeTextData :: Read a => Text -> Maybe a
254+--
255+-- Use for types which do not involve letters:
257+-- >>> readTextData "1991-06-02" :: Either Text Day
260+-- This parser is case sensitive and will not match @'showTextData'@
261+-- in presense of letters:
263+-- >>> readTextData (showTextData True) :: Either Text Bool
264+-- Left "could not parse: `true'"
266+-- See @'parseBoundedTextData'@.
267+readTextData :: Read a => Text -> Either Text a
209−readMaybeTextData = readMaybe . T.unpack
268+readTextData = parseMaybeTextData (readMaybe . T.unpack)
211−-- | Parse URL piece using @'Read'@ instance.
212−readEitherTextData :: Read a => Text -> Either Text a
213−readEitherTextData = parseMaybeTextData readMaybeTextData
215-- | Run @'Reader'@ as HTTP API data parser.
270-- | Run @'Reader'@ as HTTP API data parser.
216runReader :: Reader a -> Text -> Either Text a
271runReader :: Reader a -> Text -> Either Text a
@@ -229,7 +284,7 @@ parseBounded :: forall a. (Bounded a, Integral a) => Reader Integer -> Text -> E
229parseBounded reader input = do
284parseBounded reader input = do
230 n <- runReader reader input
285 n <- runReader reader input
231 if (n > h || n < l)
286 if (n > h || n < l)
232− then Left ("out of bounds: `" <> input <> "' (should be between " <> T.pack (show l) <> " and " <> T.pack (show h) <> ")")
287+ then Left ("out of bounds: `" <> input <> "' (should be between " <> showt l <> " and " <> showt h <> ")")
233 else Right (fromInteger n)
288 else Right (fromInteger n)
235 l = toInteger (minBound :: a)
290 l = toInteger (minBound :: a)
@@ -309,13 +364,13 @@ instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where
309-- >>> parseUrlPiece "_" :: Either Text ()
364-- >>> parseUrlPiece "_" :: Either Text ()
310-- Right ()
365-- Right ()
311instance FromHttpApiData () where
366instance FromHttpApiData () where
312− parseUrlPiece "_" = return ()
367+ parseUrlPiece "_" = pure ()
313 parseUrlPiece s = defaultParseError s
368 parseUrlPiece s = defaultParseError s
315instance FromHttpApiData Char where
370instance FromHttpApiData Char where
316 parseUrlPiece s =
371 parseUrlPiece s =
317 case T.uncons s of
372 case T.uncons s of
318− Just (c, s') | T.null s' -> return c
373+ Just (c, s') | T.null s' -> pure c
319 _ -> defaultParseError s
374 _ -> defaultParseError s
@@ -324,7 +379,7 @@ instance FromHttpApiData Char where
324instance FromHttpApiData Version where
379instance FromHttpApiData Version where
325 parseUrlPiece s =
380 parseUrlPiece s =
326 case reverse (readP_to_S parseVersion (T.unpack s)) of
381 case reverse (readP_to_S parseVersion (T.unpack s)) of
327− ((x, ""):_) -> return x
382+ ((x, ""):_) -> pure x
328 _ -> defaultParseError s
383 _ -> defaultParseError s
330#if MIN_VERSION_base(4,8,0)
385#if MIN_VERSION_base(4,8,0)
@@ -333,8 +388,8 @@ instance FromHttpApiData Void where
333 parseUrlPiece _ = Left "Void cannot be parsed!"
388 parseUrlPiece _ = Left "Void cannot be parsed!"
336−instance FromHttpApiData Bool where parseUrlPiece = parseBoundedCaseInsensitiveTextData
391+instance FromHttpApiData Bool where parseUrlPiece = parseBoundedTextData
337−instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedCaseInsensitiveTextData
392+instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedTextData
338instance FromHttpApiData Double where parseUrlPiece = runReader rational
393instance FromHttpApiData Double where parseUrlPiece = runReader rational
339instance FromHttpApiData Float where parseUrlPiece = runReader rational
394instance FromHttpApiData Float where parseUrlPiece = runReader rational
340instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal)
395instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal)
@@ -355,7 +410,7 @@ instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
356-- >>> toGregorian <$> parseUrlPiece "2016-12-01"
411-- >>> toGregorian <$> parseUrlPiece "2016-12-01"
357-- Right (2016,12,1)
412-- Right (2016,12,1)
358−instance FromHttpApiData Day where parseUrlPiece = readEitherTextData
413+instance FromHttpApiData Day where parseUrlPiece = readTextData
360instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece
415instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece
361instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece
416instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece
@@ -371,7 +426,7 @@ instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece =
371-- Right (Just 123)
426-- Right (Just 123)
372instance FromHttpApiData a => FromHttpApiData (Maybe a) where
427instance FromHttpApiData a => FromHttpApiData (Maybe a) where
373 parseUrlPiece s
428 parseUrlPiece s
374− | T.toLower (T.take 7 s) == "nothing" = return Nothing
429+ | T.toLower (T.take 7 s) == "nothing" = pure Nothing
375 | otherwise = Just <$> parseUrlPieceWithPrefix "Just " s
430 | otherwise = Just <$> parseUrlPieceWithPrefix "Just " s