Merge pull request #26 from haskell-servant/wip-allow-bodies-for-links

Fix a HasLink instance, also fix float text handling/tests.

src/Servant/Common/Text.hs

@@ -11,6 +11,7 @@ import           Data.String.Conversions (cs)
 import           Data.Text               (Text)
 import           Data.Text.Read          (Reader, decimal, rational, signed)
 import           Data.Word               (Word, Word16, Word32, Word64, Word8)
+import           GHC.Float               (double2Float)
 
 -- | For getting values from url captures and query string parameters
 -- Instances should obey:
@@ -130,7 +131,9 @@ instance ToText Double where
   toText = cs . show
 
 instance FromText Float where
-  fromText = runReader rational
+  -- Double is more practically accurate due to weird rounding when using
+  -- rational. We convert to double and then convert to Float.
+  fromText = fmap double2Float . runReader rational
 
 instance ToText Float where
   toText = cs . show

src/Servant/Utils/Links.hs

@@ -159,7 +159,7 @@ type family IsElem' a s :: Constraint
 type family IsElem endpoint api :: Constraint where
     IsElem e (sa :<|> sb)                = Or (IsElem e sa) (IsElem e sb)
     IsElem (e :> sa) (e :> sb)           = IsElem sa sb
-    IsElem sa (Header x :> sb)          = IsElem sa sb
+    IsElem sa (Header x :> sb)           = IsElem sa sb
     IsElem sa (ReqBody y x :> sb)        = IsElem sa sb
     IsElem (e :> sa) (Capture x y :> sb) = IsElem sa sb
     IsElem sa (QueryParam x y :> sb)     = IsElem sa sb
@@ -320,8 +320,8 @@ instance (KnownSymbol sym, HasLink sub)
         k = symbolVal (Proxy :: Proxy sym)
 
 -- Misc instances
-instance HasLink sub => HasLink (ReqBody a :> sub) where
+instance HasLink sub => HasLink (ReqBody ct a :> sub) where
-    type MkLink (ReqBody a :> sub) = MkLink sub
+    type MkLink (ReqBody ct a :> sub) = MkLink sub
     toLink _ = toLink (Proxy :: Proxy sub)
 
 instance (ToText v, HasLink sub)

test/Servant/Common/TextSpec.hs

@@ -55,11 +55,19 @@ spec = describe "Servant.Common.Text" $ do
         it "holds for Integer" $
             property $ \x -> textLaw (x :: Integer)
 
+        -- The following two properties are only reasonably expected to hold up
+        -- to a certain precision.
+        --
+        -- http://en.wikipedia.org/wiki/Floating_point#Internal_representation
         it "holds for Double" $
-            property $ \x -> textLaw (x :: Double)
+            property $ \x ->
+                x < 1.0e15 && x > 1.0e-16 ==>
+                    textLaw (x :: Double)
 
         it "holds for Float" $
-            property $ \x -> textLaw (x :: Float)
+            property $ \x ->
+                x < 1.0e7 && x > 1.0e-7 ==>
+                    textLaw (x :: Float)
 
 textLaw :: (FromText a, ToText a, Eq a) => a -> Bool
 textLaw a = fromText (toText a) == Just a

test/Servant/Utils/LinksSpec.hs

@@ -29,7 +29,7 @@ type TestApi =
   :<|> "raw" :> Raw
 
 type TestLink = "hello" :> "hi" :> Get '[JSON] Bool
-type TestLink2 = "greet" :> Post '[PlainText] Bool
+type TestLink2 = "greet" :> ReqBody '[JSON] [Int] :> Post '[PlainText] Bool
 type TestLink3 = "parent" :> "child" :> Get '[JSON] String
 
 type BadTestLink = "hallo" :> "hi" :> Get '[JSON] Bool