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