@@ -9,11 +9,14 @@
99-- such as URL pieces, headers and query parameters.
1010module Web.HttpApiData.Internal where
1111
12+#if __GLASGOW_HASKELL__ < 710
1213import Control.Applicative
14+#endif
1315import Control.Arrow ((&&&))
1416
1517import Data.Monoid
1618import Data.ByteString (ByteString)
19+import qualified Data.ByteString as BS
1720
1821import Data.Int
1922import Data.Word
@@ -24,7 +27,7 @@ import Data.Text.Read (signed, decimal, rational, Reader)
2427import qualified Data.Text as T
2528import qualified Data.Text.Lazy as L
2629
27−import Data.Time (Day)
30+import Data.Time
2831import Data.Version
2932
3033#if MIN_VERSION_base(4,8,0)
@@ -38,9 +41,6 @@ import Text.ParserCombinators.ReadP (readP_to_S)
3841import TextShow (TextShow, showt)
3942#endif
4043
41−-- $setup
42−-- >>> import Data.Time
43−
4444-- | Convert value to HTTP API data.
4545class ToHttpApiData a where
4646 {-# MINIMAL toUrlPiece | toQueryParam #-}
@@ -104,7 +104,9 @@ parseMaybeTextData parse input =
104104 Just val -> Right val
105105
106106#if USE_TEXT_SHOW
107−-- | Convert to URL piece using @'TextShow'@ instance.
107+-- | /Lower case/.
108+--
109+-- Convert to URL piece using @'TextShow'@ instance.
108110-- The result is always lower cased.
109111--
110112-- >>> showTextData True
@@ -124,7 +126,9 @@ parseMaybeTextData parse input =
124126showTextData :: TextShow a => a -> Text
125127showTextData = T.toLower . showt
126128#else
127−-- | Convert to URL piece using @'Show'@ instance.
129+-- | /Lower case/.
130+--
131+-- Convert to URL piece using @'Show'@ instance.
128132-- The result is always lower cased.
129133--
130134-- >>> showTextData True
@@ -144,7 +148,10 @@ showt :: Show a => a -> Text
144148showt = T.pack . show
145149#endif
146150
147−-- | Parse given text case insensitive and return the rest of the input.
151+-- | /Case insensitive/.
152+--
153+-- Parse given text case insensitive and then parse the rest of the input
154+-- using @'parseUrlPiece'@.
148155--
149156-- >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int
150157-- Right 10
@@ -164,12 +171,49 @@ parseUrlPieceWithPrefix pattern input
164171 where
165172 (prefix, rest) = T.splitAt (T.length pattern) input
166173
174+-- $setup
175+-- >>> data BasicAuthToken = BasicAuthToken Text deriving (Show)
176+-- >>> instance FromHttpApiData BasicAuthToken where parseHeader h = BasicAuthToken <$> parseHeaderWithPrefix "Basic " h; parseQueryParam p = BasicAuthToken <$> parseQueryParam p
177+
178+-- | Parse given bytestring then parse the rest of the input using @'parseHeader'@.
179+--
180+-- @
181+-- data BasicAuthToken = BasicAuthToken Text deriving (Show)
182+--
183+-- instance FromHttpApiData BasicAuthToken where
184+-- parseHeader h = BasicAuthToken \<$\> parseHeaderWithPrefix "Basic " h
185+-- parseQueryParam p = BasicAuthToken \<$\> parseQueryParam p
186+-- @
187+--
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)
194+
195+-- | /Case insensitive/.
196+--
197+-- Parse given text case insensitive and then parse the rest of the input
198+-- using @'parseQueryParam'@.
199+--
200+-- >>> parseQueryParamWithPrefix "z" "z10" :: Either Text Int
201+-- Right 10
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
206+ where
207+ (prefix, rest) = T.splitAt (T.length pattern) input
208+
167209#if USE_TEXT_SHOW
168−-- | Parse values case insensitively based on @'TextShow'@ instance.
210+-- | /Case insensitive/.
211+--
212+-- Parse values case insensitively based on @'TextShow'@ instance.
169213--
170−-- >>> parseBoundedCaseInsensitiveTextData "true" :: Either Text Bool
214+-- >>> parseBoundedTextData "true" :: Either Text Bool
171215-- Right True
172−-- >>> parseBoundedCaseInsensitiveTextData "FALSE" :: Either Text Bool
216+-- >>> parseBoundedTextData "FALSE" :: Either Text Bool
173217-- Right False
174218--
175219-- This can be used as a default implementation for enumeration types:
@@ -181,36 +225,47 @@ parseUrlPieceWithPrefix pattern input
181225-- showt = genericShowt
182226--
183227-- instance FromHttpApiData MyData where
184−-- parseUrlPiece = parseBoundedCaseInsensitiveTextData
228+-- parseUrlPiece = parseBoundedTextData
185229-- @
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
187231#else
188−-- | Parse values case insensitively based on @'Show'@ instance.
232+-- | /Case insensitive/.
233+--
234+-- Parse values case insensitively based on @'Show'@ instance.
189235--
190−-- >>> parseBoundedCaseInsensitiveTextData "true" :: Either Text Bool
236+-- >>> parseBoundedTextData "true" :: Either Text Bool
191237-- Right True
192−-- >>> parseBoundedCaseInsensitiveTextData "FALSE" :: Either Text Bool
238+-- >>> parseBoundedTextData "FALSE" :: Either Text Bool
193239-- Right False
194240--
195241-- This can be used as a default implementation for enumeration types:
196242--
197243-- >>> data MyData = Foo | Bar | Baz deriving (Show, Bounded, Enum)
198−-- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedCaseInsensitiveTextData
244+-- >>> instance FromHttpApiData MyData where parseUrlPiece = parseBoundedTextData
199245-- >>> parseUrlPiece "foo" :: Either Text MyData
200246-- 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
202248#endif
203−parseBoundedCaseInsensitiveTextData = parseMaybeTextData (flip lookup values . T.toLower)
249+parseBoundedTextData = parseMaybeTextData (flip lookup values . T.toLower)
204250 where
205− values = map (showTextData &&& id) [minBound..maxBound :: a]
251+ values = map (showTextData &&& id) [minBound..maxBound]
206252
207253-- | Parse URL piece using @'Read'@ instance.
208−readMaybeTextData :: Read a => Text -> Maybe a
209−readMaybeTextData = readMaybe . T.unpack
210−
211−-- | Parse URL piece using @'Read'@ instance.
212−readEitherTextData :: Read a => Text -> Either Text a
213−readEitherTextData = parseMaybeTextData readMaybeTextData
254+--
255+-- Use for types which do not involve letters:
256+--
257+-- >>> readTextData "1991-06-02" :: Either Text Day
258+-- Right 1991-06-02
259+--
260+-- This parser is case sensitive and will not match @'showTextData'@
261+-- in presense of letters:
262+--
263+-- >>> readTextData (showTextData True) :: Either Text Bool
264+-- Left "could not parse: `true'"
265+--
266+-- See @'parseBoundedTextData'@.
267+readTextData :: Read a => Text -> Either Text a
268+readTextData = parseMaybeTextData (readMaybe . T.unpack)
214269
215270-- | Run @'Reader'@ as HTTP API data parser.
216271runReader :: Reader a -> Text -> Either Text a
@@ -229,7 +284,7 @@ parseBounded :: forall a. (Bounded a, Integral a) => Reader Integer -> Text -> E
229284parseBounded reader input = do
230285 n <- runReader reader input
231286 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 <> ")")
233288 else Right (fromInteger n)
234289 where
235290 l = toInteger (minBound :: a)
@@ -309,13 +364,13 @@ instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where
309364-- >>> parseUrlPiece "_" :: Either Text ()
310365-- Right ()
311366instance FromHttpApiData () where
312− parseUrlPiece "_" = return ()
367+ parseUrlPiece "_" = pure ()
313368 parseUrlPiece s = defaultParseError s
314369
315370instance FromHttpApiData Char where
316371 parseUrlPiece s =
317372 case T.uncons s of
318− Just (c, s') | T.null s' -> return c
373+ Just (c, s') | T.null s' -> pure c
319374 _ -> defaultParseError s
320375
321376-- |
@@ -324,7 +379,7 @@ instance FromHttpApiData Char where
324379instance FromHttpApiData Version where
325380 parseUrlPiece s =
326381 case reverse (readP_to_S parseVersion (T.unpack s)) of
327− ((x, ""):_) -> return x
382+ ((x, ""):_) -> pure x
328383 _ -> defaultParseError s
329384
330385#if MIN_VERSION_base(4,8,0)
@@ -333,8 +388,8 @@ instance FromHttpApiData Void where
333388 parseUrlPiece _ = Left "Void cannot be parsed!"
334389#endif
335390
336−instance FromHttpApiData Bool where parseUrlPiece = parseBoundedCaseInsensitiveTextData
337−instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedCaseInsensitiveTextData
391+instance FromHttpApiData Bool where parseUrlPiece = parseBoundedTextData
392+instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedTextData
338393instance FromHttpApiData Double where parseUrlPiece = runReader rational
339394instance FromHttpApiData Float where parseUrlPiece = runReader rational
340395instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal)
@@ -355,7 +410,7 @@ instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
355410-- |
356411-- >>> toGregorian <$> parseUrlPiece "2016-12-01"
357412-- Right (2016,12,1)
358−instance FromHttpApiData Day where parseUrlPiece = readEitherTextData
413+instance FromHttpApiData Day where parseUrlPiece = readTextData
359414
360415instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece
361416instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece
@@ -371,7 +426,7 @@ instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece =
371426-- Right (Just 123)
372427instance FromHttpApiData a => FromHttpApiData (Maybe a) where
373428 parseUrlPiece s
374− | T.toLower (T.take 7 s) == "nothing" = return Nothing
429+ | T.toLower (T.take 7 s) == "nothing" = pure Nothing
375430 | otherwise = Just <$> parseUrlPieceWithPrefix "Just " s
376431
377432-- |