git.iko.soy/typeable/http-api-data
on master help sign in
Merge pull request #15 from fizruk/lower-case

Encode in lowercase, decode case insensitive

commitded768b9453a2ed848c682850672d53925b7e234 authorNickolay Kudasov <fizruk@users.noreply.github.com> dateWed 7 Oct 2015, 12:03 (11 years ago) parent743ba337a83597
3 files changed+132−77
compare with master
unifiedsplit
Web/HttpApiData.hs+74−50 Web/PathPieces.hs+1−1 test/main.hs+57−26
Web/HttpApiData.hs+74−50
@@ -16,13 +16,14 @@ module Web.HttpApiData (
1616 FromHttpApiData (..),
1717
1818 -- * Utility functions
19− parseMaybeHttpApiData,
20− showUrlPiece,
21− readMaybeUrlPiece,
22− readEitherUrlPiece,
19+ parseMaybeTextData,
20+ showTextData,
21+ readMaybeTextData,
22+ readEitherTextData,
2323) where
2424
2525import Control.Applicative
26+import Control.Arrow ((&&&))
2627
2728import Data.Monoid
2829import Data.ByteString (ByteString)
@@ -87,23 +88,47 @@ defaultParseError :: Text -> Either Text a
8788defaultParseError input = Left ("could not convert: `" <> input <> "'")
8889
8990-- | Convert @'Maybe'@ parser into @'Either' 'Text'@ parser with default error message.
90−parseMaybeHttpApiData :: (Text -> Maybe a) -> (Text -> Either Text a)
91−parseMaybeHttpApiData parse input =
91+parseMaybeTextData :: (Text -> Maybe a) -> (Text -> Either Text a)
92+parseMaybeTextData parse input =
9293 case parse input of
9394 Nothing -> defaultParseError input
9495 Just val -> Right val
9596
9697-- | Convert to URL piece using @'Show'@ instance.
97−showUrlPiece :: Show a => a -> Text
98−showUrlPiece = T.pack . show
98+showTextData :: Show a => a -> Text
99+showTextData = T.toLower . T.pack . show
100+
101+-- | Parse given text case insensitive and return the rest of the input.
102+--
103+-- >>> parseUrlPieceWithPrefix "Just " "just 10" :: Either Text Int
104+-- Right 10
105+-- >>> parseUrlPieceWithPrefix "Left " "left" :: Either Text Bool
106+-- Left "could not convert: `left'"
107+parseUrlPieceWithPrefix :: FromHttpApiData a => Text -> Text -> Either Text a
108+parseUrlPieceWithPrefix pattern input
109+ | T.toLower pattern == T.toLower prefix = parseUrlPiece rest
110+ | otherwise = defaultParseError input
111+ where
112+ (prefix, rest) = T.splitAt (T.length pattern) input
113+
114+-- | Parse values case insensitively based on @'Show'@ instance.
115+--
116+-- >>> parseBoundedCaseInsensitiveTextData "true" :: Either Text Bool
117+-- Right True
118+-- >>> parseBoundedCaseInsensitiveTextData "FALSE" :: Either Text Bool
119+-- Right False
120+parseBoundedCaseInsensitiveTextData :: forall a. (Show a, Bounded a, Enum a) => Text -> Either Text a
121+parseBoundedCaseInsensitiveTextData = parseMaybeTextData (flip lookup values . T.toLower)
122+ where
123+ values = map (showTextData &&& id) [minBound..maxBound :: a]
99124
100125-- | Parse URL piece using @'Read'@ instance.
101−readMaybeUrlPiece :: Read a => Text -> Maybe a
102−readMaybeUrlPiece = readMaybe . T.unpack
126+readMaybeTextData :: Read a => Text -> Maybe a
127+readMaybeTextData = readMaybe . T.unpack
103128
104129-- | Parse URL piece using @'Read'@ instance.
105−readEitherUrlPiece :: Read a => Text -> Either Text a
106−readEitherUrlPiece = parseMaybeHttpApiData readMaybeUrlPiece
130+readEitherTextData :: Read a => Text -> Either Text a
131+readEitherTextData = parseMaybeTextData readMaybeTextData
107132
108133-- | Run @'Reader'@ as HTTP API data parser.
109134runReader :: Reader a -> Text -> Either Text a
@@ -144,25 +169,25 @@ instance ToHttpApiData Void where
144169 toUrlPiece = absurd
145170#endif
146171
147−instance ToHttpApiData Bool where toUrlPiece = showUrlPiece
148−instance ToHttpApiData Ordering where toUrlPiece = showUrlPiece
149−instance ToHttpApiData Double where toUrlPiece = showUrlPiece
150−instance ToHttpApiData Float where toUrlPiece = showUrlPiece
151−instance ToHttpApiData Int where toUrlPiece = showUrlPiece
152−instance ToHttpApiData Int8 where toUrlPiece = showUrlPiece
153−instance ToHttpApiData Int16 where toUrlPiece = showUrlPiece
154−instance ToHttpApiData Int32 where toUrlPiece = showUrlPiece
155−instance ToHttpApiData Int64 where toUrlPiece = showUrlPiece
156−instance ToHttpApiData Integer where toUrlPiece = showUrlPiece
157−instance ToHttpApiData Word where toUrlPiece = showUrlPiece
158−instance ToHttpApiData Word8 where toUrlPiece = showUrlPiece
159−instance ToHttpApiData Word16 where toUrlPiece = showUrlPiece
160−instance ToHttpApiData Word32 where toUrlPiece = showUrlPiece
161−instance ToHttpApiData Word64 where toUrlPiece = showUrlPiece
172+instance ToHttpApiData Bool where toUrlPiece = showTextData
173+instance ToHttpApiData Ordering where toUrlPiece = showTextData
174+instance ToHttpApiData Double where toUrlPiece = showTextData
175+instance ToHttpApiData Float where toUrlPiece = showTextData
176+instance ToHttpApiData Int where toUrlPiece = showTextData
177+instance ToHttpApiData Int8 where toUrlPiece = showTextData
178+instance ToHttpApiData Int16 where toUrlPiece = showTextData
179+instance ToHttpApiData Int32 where toUrlPiece = showTextData
180+instance ToHttpApiData Int64 where toUrlPiece = showTextData
181+instance ToHttpApiData Integer where toUrlPiece = showTextData
182+instance ToHttpApiData Word where toUrlPiece = showTextData
183+instance ToHttpApiData Word8 where toUrlPiece = showTextData
184+instance ToHttpApiData Word16 where toUrlPiece = showTextData
185+instance ToHttpApiData Word32 where toUrlPiece = showTextData
186+instance ToHttpApiData Word64 where toUrlPiece = showTextData
162187instance ToHttpApiData String where toUrlPiece = T.pack
163188instance ToHttpApiData Text where toUrlPiece = id
164189instance ToHttpApiData L.Text where toUrlPiece = L.toStrict
165−instance ToHttpApiData Day where toUrlPiece = showUrlPiece
190+instance ToHttpApiData Day where toUrlPiece = showTextData
166191
167192instance ToHttpApiData All where toUrlPiece = toUrlPiece . getAll
168193instance ToHttpApiData Any where toUrlPiece = toUrlPiece . getAny
@@ -175,19 +200,19 @@ instance ToHttpApiData a => ToHttpApiData (Last a) where toUrlPiece = toUrlPi
175200
176201-- |
177202-- >>> toUrlPiece (Just "Hello")
178−-- "Just Hello"
203+-- "just Hello"
179204instance ToHttpApiData a => ToHttpApiData (Maybe a) where
180− toUrlPiece (Just x) = "Just " <> toUrlPiece x
181− toUrlPiece Nothing = "Nothing"
205+ toUrlPiece (Just x) = "just " <> toUrlPiece x
206+ toUrlPiece Nothing = "nothing"
182207
183208-- |
184209-- >>> toUrlPiece (Left "err" :: Either String Int)
185−-- "Left err"
210+-- "left err"
186211-- >>> toUrlPiece (Right 3 :: Either String Int)
187−-- "Right 3"
212+-- "right 3"
188213instance (ToHttpApiData a, ToHttpApiData b) => ToHttpApiData (Either a b) where
189− toUrlPiece (Left x) = "Left " <> toUrlPiece x
190− toUrlPiece (Right x) = "Right " <> toUrlPiece x
214+ toUrlPiece (Left x) = "left " <> toUrlPiece x
215+ toUrlPiece (Right x) = "right " <> toUrlPiece x
191216
192217-- |
193218-- >>> parseUrlPiece "_" :: Either Text ()
@@ -216,8 +241,8 @@ instance FromHttpApiData Void where
216241 parseUrlPiece _ = Left "Void cannot be parsed!"
217242#endif
218243
219−instance FromHttpApiData Bool where parseUrlPiece = readEitherUrlPiece
220−instance FromHttpApiData Ordering where parseUrlPiece = readEitherUrlPiece
244+instance FromHttpApiData Bool where parseUrlPiece = parseBoundedCaseInsensitiveTextData
245+instance FromHttpApiData Ordering where parseUrlPiece = parseBoundedCaseInsensitiveTextData
221246instance FromHttpApiData Double where parseUrlPiece = runReader rational
222247instance FromHttpApiData Float where parseUrlPiece = runReader rational
223248instance FromHttpApiData Int where parseUrlPiece = parseBounded (signed decimal)
@@ -234,7 +259,7 @@ instance FromHttpApiData Word64 where parseUrlPiece = parseBounded decimal
234259instance FromHttpApiData String where parseUrlPiece = Right . T.unpack
235260instance FromHttpApiData Text where parseUrlPiece = Right
236261instance FromHttpApiData L.Text where parseUrlPiece = Right . L.fromStrict
237−instance FromHttpApiData Day where parseUrlPiece = readEitherUrlPiece
262+instance FromHttpApiData Day where parseUrlPiece = readEitherTextData
238263
239264instance FromHttpApiData All where parseUrlPiece = fmap All . parseUrlPiece
240265instance FromHttpApiData Any where parseUrlPiece = fmap Any . parseUrlPiece
@@ -249,30 +274,29 @@ instance FromHttpApiData a => FromHttpApiData (Last a) where parseUrlPiece =
249274-- >>> parseUrlPiece "Just 123" :: Either Text (Maybe Int)
250275-- Right (Just 123)
251276instance FromHttpApiData a => FromHttpApiData (Maybe a) where
252− parseUrlPiece "Nothing" = return Nothing
253− parseUrlPiece s =
254− case T.stripPrefix "Just " s of
255− Nothing -> defaultParseError s
256− Just x -> Just <$> parseUrlPiece x
277+ parseUrlPiece s
278+ | T.toLower (T.take 7 s) == "nothing" = return Nothing
279+ | otherwise = Just <$> parseUrlPieceWithPrefix "Just " s
257280
258281-- |
259282-- >>> parseUrlPiece "Right 123" :: Either Text (Either String Int)
260283-- Right (Right 123)
261284instance (FromHttpApiData a, FromHttpApiData b) => FromHttpApiData (Either a b) where
262285 parseUrlPiece s =
263− case T.stripPrefix "Right " s of
264− Just r -> Right <$> parseUrlPiece r
265− _ -> case T.stripPrefix "Left " s of
266− Just l -> Left <$> parseUrlPiece l
267− _ -> defaultParseError s
286+ Right <$> parseUrlPieceWithPrefix "Right " s
287+ <!> Left <$> parseUrlPieceWithPrefix "Left " s
288+ where
289+ infixl 3 <!>
290+ Left _ <!> y = y
291+ x <!> _ = x
268292
269293-- $examples
270294--
271295-- Booleans:
272296--
273297-- >>> toUrlPiece True
274−-- "True"
275−-- >>> parseUrlPiece "False" :: Either Text Bool
298+-- "true"
299+-- >>> parseUrlPiece "false" :: Either Text Bool
276300-- Right False
277301-- >>> parseUrlPiece "something else" :: Either Text Bool
278302-- Left "could not convert: `something else'"
Web/PathPieces.hs+1−1
@@ -109,7 +109,7 @@ instance PathPiece a => ToHttpApiData (WrappedPathPiece a) where
109109 toUrlPiece = toPathPiece . unwrapPathPiece
110110
111111instance PathPiece a => FromHttpApiData (WrappedPathPiece a) where
112− parseUrlPiece = fmap WrappedPathPiece . parseMaybeHttpApiData fromPathPiece
112+ parseUrlPiece = fmap WrappedPathPiece . parseMaybeTextData fromPathPiece
113113
114114-- | Convert value to route piece using @'PathPiece'@ instance for its parameter.
115115toPathPiece1 :: forall f a. (PathPiece a, ToHttpApiData (f (WrappedPathPiece a))) => f a -> S.Text
test/main.hs+57−26
@@ -5,6 +5,7 @@ module Main where
55import Control.Applicative
66
77import Data.Int
8+import Data.Char
89import Data.Word
910import Data.Time
1011import qualified Data.Text as T
@@ -38,37 +39,67 @@ main = hspec spec
3839(<=>) :: Eq a => (a -> b) -> (b -> Maybe a) -> a -> Bool
3940(f <=> g) x = g (f x) == Just x
4041
42+data Proxy a = Proxy
43+
44+checkPathPiece :: forall a. (Eq a, PathPiece a, Show a, Arbitrary a) => Proxy a -> String -> Spec
45+checkPathPiece _ name = prop ("toPathPiece <=> fromPathPiece " ++ name) (toPathPiece <=> fromPathPiece :: a -> Bool)
46+
47+checkPathMultiPiece :: forall a. (Eq a, PathMultiPiece a, Show a, Arbitrary a) => Proxy a -> String -> Spec
48+checkPathMultiPiece _ name = prop ("toPathMultiPiece <=> fromPathMultiPiece " ++ name) (toPathMultiPiece <=> fromPathMultiPiece :: a -> Bool)
49+
50+data RandomCase a = RandomCase [Bool] a
51+
52+instance PathPiece a => Show (RandomCase a) where
53+ show rc@(RandomCase _ x) = show (toPathPiece rc) ++ " (original: " ++ show (toPathPiece x) ++ ")"
54+
55+instance Eq a => Eq (RandomCase a) where
56+ RandomCase _ x == RandomCase _ y = x == y
57+
58+instance Arbitrary a => Arbitrary (RandomCase a) where
59+ arbitrary = liftA2 RandomCase nonempty arbitrary
60+ where
61+ nonempty = liftA2 (:) arbitrary arbitrary
62+
63+instance PathPiece a => PathPiece (RandomCase a) where
64+ toPathPiece (RandomCase us x) = T.pack (zipWith (\u -> if u then toUpper else toLower) (cycle us) (T.unpack (toPathPiece x)))
65+ fromPathPiece s = RandomCase [] <$> fromPathPiece s
66+
67+-- | Check case insensitivity for @fromPathPiece@.
68+checkPathPieceI :: forall a. (Eq a, PathPiece a, Show a, Arbitrary a) => Proxy a -> String -> Spec
69+checkPathPieceI _ = checkPathPiece (Proxy :: Proxy (RandomCase a))
70+
4171spec :: Spec
4272spec = do
4373 describe "PathPiece" $ do
44− prop "toPathPiece <=> fromPathPiece ()" $ \(p :: ()) -> (toPathPiece <=> fromPathPiece) p
45− prop "toPathPiece <=> fromPathPiece Char" $ \(p :: Char) -> (toPathPiece <=> fromPathPiece) p
46− prop "toPathPiece <=> fromPathPiece Bool" $ \(p :: Bool) -> (toPathPiece <=> fromPathPiece) p
47− prop "toPathPiece <=> fromPathPiece Ordering" $ \(p :: Ordering) -> (toPathPiece <=> fromPathPiece) p
48− prop "toPathPiece <=> fromPathPiece Int" $ \(p :: Int) -> (toPathPiece <=> fromPathPiece) p
49− prop "toPathPiece <=> fromPathPiece Int8" $ \(p :: Int8) -> (toPathPiece <=> fromPathPiece) p
50− prop "toPathPiece <=> fromPathPiece Int16" $ \(p :: Int16) -> (toPathPiece <=> fromPathPiece) p
51− prop "toPathPiece <=> fromPathPiece Int32" $ \(p :: Int32) -> (toPathPiece <=> fromPathPiece) p
52− prop "toPathPiece <=> fromPathPiece Int64" $ \(p :: Int64) -> (toPathPiece <=> fromPathPiece) p
53− prop "toPathPiece <=> fromPathPiece Integer" $ \(p :: Integer) -> (toPathPiece <=> fromPathPiece) p
54− prop "toPathPiece <=> fromPathPiece Word" $ \(p :: Word) -> (toPathPiece <=> fromPathPiece) p
55− prop "toPathPiece <=> fromPathPiece Word8" $ \(p :: Word8) -> (toPathPiece <=> fromPathPiece) p
56− prop "toPathPiece <=> fromPathPiece Word16" $ \(p :: Word16) -> (toPathPiece <=> fromPathPiece) p
57− prop "toPathPiece <=> fromPathPiece Word32" $ \(p :: Word32) -> (toPathPiece <=> fromPathPiece) p
58− prop "toPathPiece <=> fromPathPiece Word64" $ \(p :: Word64) -> (toPathPiece <=> fromPathPiece) p
59− prop "toPathPiece <=> fromPathPiece Word64" $ \(p :: Word64) -> (toPathPiece <=> fromPathPiece) p
60− prop "toPathPiece <=> fromPathPiece String" $ \(p :: String) -> (toPathPiece <=> fromPathPiece) p
61− prop "toPathPiece <=> fromPathPiece Text.Strict" $ \(p :: T.Text) -> (toPathPiece <=> fromPathPiece) p
62− prop "toPathPiece <=> fromPathPiece Text.Lazy" $ \(p :: L.Text) -> (toPathPiece <=> fromPathPiece) p
63− prop "toPathPiece <=> fromPathPiece Day" $ \(p :: Day) -> (toPathPiece <=> fromPathPiece) p
64− prop "toPathPiece <=> fromPathPiece Version" $ \(p :: Version) -> (toPathPiece <=> fromPathPiece) p
65−
66− prop "toPathPiece <=> fromPathPiece Maybe String" $ \(p::Maybe String) -> (toPathPiece <=> fromPathPiece) p
67− prop "toPathPiece <=> fromPathPiece Either Integer Text" $ \(p::Either Integer T.Text) -> (toPathPiece <=> fromPathPiece) p
74+ checkPathPiece (Proxy :: Proxy ()) "()"
75+ checkPathPiece (Proxy :: Proxy Char) "Char"
76+ checkPathPieceI (Proxy :: Proxy Bool) "Bool"
77+ checkPathPieceI (Proxy :: Proxy Ordering) "Ordering"
78+ checkPathPiece (Proxy :: Proxy Int) "Int"
79+ checkPathPiece (Proxy :: Proxy Int8) "Int8"
80+ checkPathPiece (Proxy :: Proxy Int16) "Int16"
81+ checkPathPiece (Proxy :: Proxy Int32) "Int32"
82+ checkPathPiece (Proxy :: Proxy Int64) "Int64"
83+ checkPathPiece (Proxy :: Proxy Integer) "Integer"
84+ checkPathPiece (Proxy :: Proxy Word) "Word"
85+ checkPathPiece (Proxy :: Proxy Word8) "Word8"
86+ checkPathPiece (Proxy :: Proxy Word16) "Word16"
87+ checkPathPiece (Proxy :: Proxy Word32) "Word32"
88+ checkPathPiece (Proxy :: Proxy Word64) "Word64"
89+ checkPathPiece (Proxy :: Proxy String) "String"
90+ checkPathPiece (Proxy :: Proxy T.Text) "Text.Strict"
91+ checkPathPiece (Proxy :: Proxy L.Text) "Text.Lazy"
92+ checkPathPiece (Proxy :: Proxy Day) "Day"
93+ checkPathPiece (Proxy :: Proxy Version) "Version"
94+
95+ checkPathPiece (Proxy :: Proxy (Maybe String)) "Maybe String"
96+ checkPathPieceI (Proxy :: Proxy (Maybe Integer)) "Maybe Integer"
97+ checkPathPiece (Proxy :: Proxy (Either Integer T.Text)) "Either Integer Text"
98+ checkPathPieceI (Proxy :: Proxy (Either Version Day)) "Either Version Day"
6899
69100 describe "PathMultiPiece" $ do
70− prop "toPathMultiPiece <=> fromPathMultiPiece String" $ \(p::[String]) -> (toPathMultiPiece <=> fromPathMultiPiece) p
71− prop "toPathMultiPiece <=> fromPathMultiPiece Text" $ \(p::[T.Text]) -> (toPathMultiPiece <=> fromPathMultiPiece) p
101+ checkPathMultiPiece (Proxy :: Proxy [String]) "[String]"
102+ checkPathMultiPiece (Proxy :: Proxy [T.Text]) "[Text]"
72103
73104 it "bad integers are rejected" $ do
74105 fromPathPiece (T.pack "123hello") `shouldBe` (Nothing :: Maybe Int)