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