From d1d87f391ab329a35d2e59e92f8fc071016641d0 Mon Sep 17 00:00:00 2001 From: Brandon Martin Date: Mon, 10 Aug 2015 15:16:42 -0600 Subject: [PATCH] finish swapping Raw args, add a number of instances for Raw --- servant-client/src/Servant/Client.hs | 4 +- servant-client/test/Servant/ClientSpec.hs | 10 +- servant-docs/src/Servant/Docs/Internal.hs | 2 +- servant-js/README.md | 2 +- servant-js/examples/counter.hs | 2 +- servant-js/test/Servant/JSSpec.hs | 2 +- .../src/Servant/Server/Internal/Enter.hs | 20 ++- .../test/Servant/Server/Internal/EnterSpec.hs | 2 +- servant-server/test/Servant/ServerSpec.hs | 4 +- .../test/Servant/Utils/StaticFilesSpec.hs | 2 +- servant/CHANGELOG.md | 2 +- servant/src/Servant/API/Raw.hs | 135 +++++++++++++++++- servant/src/Servant/Utils/Links.hs | 4 +- servant/test/Servant/API/RawSpec.hs | 2 +- servant/test/Servant/Utils/LinksSpec.hs | 4 +- 15 files changed, 167 insertions(+), 30 deletions(-) diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 43c7deb3..ecfe1d37 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -618,8 +618,8 @@ instance (KnownSymbol sym, HasClient sublayout) -- | Pick a 'Method' and specify where the server you want to query is. You get -- back the full `Response`. -instance HasClient Raw where - type Client Raw = H.Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) +instance HasClient (Raw m a) where + type Client (Raw m a) = H.Method -> ExceptT ServantError IO (Int, ByteString, MediaType, [HTTP.Header], Response ByteString) clientWithRoute :: Proxy (Raw m a) -> Req -> BaseUrl -> Manager -> Client (Raw m a) clientWithRoute Proxy req baseurl manager httpMethod = do diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 5301aff0..d7a8c194 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -84,8 +84,8 @@ type Api = :<|> "matrixparam" :> MatrixParam "name" String :> Get '[JSON] Person :<|> "matrixparams" :> MatrixParams "name" String :> Get '[JSON] [Person] :<|> "matrixflag" :> MatrixFlag "flag" :> Get '[JSON] Bool - :<|> "rawSuccess" :> Raw Application IO - :<|> "rawFailure" :> Raw Application IO + :<|> "rawSuccess" :> Raw IO Application + :<|> "rawFailure" :> Raw IO Application :<|> "multiple" :> Capture "first" String :> QueryParam "second" Int :> @@ -126,9 +126,9 @@ withServer :: (BaseUrl -> IO a) -> IO a withServer action = withWaiDaemon (return server) action type FailApi = - "get" :> Raw Application IO - :<|> "capture" :> Capture "name" String :> Raw Application IO - :<|> "body" :> Raw Application IO + "get" :> Raw IO Application + :<|> "capture" :> Capture "name" String :> Raw IO Application + :<|> "body" :> Raw IO Application failApi :: Proxy FailApi failApi = Proxy diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 78eb10cd..37eb5c90 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -940,7 +940,7 @@ instance (KnownSymbol sym, {- ToParam (MatrixFlag sym), -} HasDocs sublayout) endpoint' = over path (\p -> p ++ [";" ++ symbolVal symP]) endpoint symP = Proxy :: Proxy sym -instance HasDocs (Raw a m) where +instance HasDocs (Raw m a) where docsFor _proxy (endpoint, action) = single endpoint action diff --git a/servant-js/README.md b/servant-js/README.md index 8100f039..8141c21d 100644 --- a/servant-js/README.md +++ b/servant-js/README.md @@ -50,7 +50,7 @@ currentValue counter = liftIO $ readTVarIO counter -- * Our API type type TestApi = "counter" :> Post Counter -- endpoint for increasing the counter :<|> "counter" :> Get Counter -- endpoint to get the current value - :<|> Raw Application IO -- used for serving static files + :<|> Raw IO Application -- used for serving static files testApi :: Proxy TestApi testApi = Proxy diff --git a/servant-js/examples/counter.hs b/servant-js/examples/counter.hs index e55954d5..ceb25f20 100644 --- a/servant-js/examples/counter.hs +++ b/servant-js/examples/counter.hs @@ -43,7 +43,7 @@ type TestApi = "counter" :> Post '[JSON] Counter -- endpoint for increasing the :<|> "counter" :> Get '[JSON] Counter -- endpoint to get the current value type TestApi' = TestApi - :<|> Raw Application IO -- used for serving static files + :<|> Raw IO Application -- used for serving static files -- this proxy only targets the proper endpoints of our API, -- not the static file serving bit diff --git a/servant-js/test/Servant/JSSpec.hs b/servant-js/test/Servant/JSSpec.hs index efbb2f5f..ea90d417 100644 --- a/servant-js/test/Servant/JSSpec.hs +++ b/servant-js/test/Servant/JSSpec.hs @@ -24,7 +24,7 @@ type TestAPI = "simple" :> ReqBody '[JSON,FormUrlEncoded] String :> Post '[JSON] :<|> "has.extension" :> Get '[FormUrlEncoded,JSON] Bool type TopLevelRawAPI = "something" :> Get '[JSON] Int - :<|> Raw () IO + :<|> Raw IO () type HeaderHandlingAPI = "something" :> Header "Foo" String :> Get '[JSON] Int diff --git a/servant-server/src/Servant/Server/Internal/Enter.hs b/servant-server/src/Servant/Server/Internal/Enter.hs index 9b66ae49..0dde0c57 100644 --- a/servant-server/src/Servant/Server/Internal/Enter.hs +++ b/servant-server/src/Servant/Server/Internal/Enter.hs @@ -7,8 +7,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -{-# LANGUAGE OverlappingInstances #-} {-# LANGUAGE UndecidableInstances #-} +#if !MIN_VERSION_base(4,8,0) +{-# LANGUAGE OverlappingInstances #-} +#endif module Servant.Server.Internal.Enter where #if !MIN_VERSION_base(4,8,0) @@ -52,11 +54,19 @@ instance C.Category (:~>) where id = Nat id Nat f . Nat g = Nat (f . g) -instance (Raw m' ~ m, Raw n' ~ n) => Enter (m a) (m' :~> n') (n a) where - enter _ (Raw a) = Raw a +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPABLE #-} +#endif + (Raw m' ~ m, Raw n' ~ n) => Enter (m a) (m' :~> n') (n a) where + enter _ (Raw a) = Raw a -instance Enter (m a) (m :~> n) (n a) where - enter (Nat f) = f +instance +#if MIN_VERSION_base(4,8,0) + {-# OVERLAPPING #-} +#endif + Enter (m a) (m :~> n) (n a) where + enter (Nat f) = f -- | Like `lift`. liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs index 87cd3cea..dfed3759 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -26,7 +26,7 @@ spec = describe "module Servant.Server.Enter" $ do type ReaderAPI = "int" :> Get '[JSON] Int :<|> "string" :> Post '[JSON] String - :<|> "static" :> Raw Application (Reader String) + :<|> "static" :> Raw (Reader String) Application type IdentityAPI = "bool" :> Get '[JSON] Bool diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 2dbab03c..4ee1811a 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -118,7 +118,7 @@ captureSpec = do get "/notAnInt" `shouldRespondWith` 404 with (return (serve - (Proxy :: Proxy (Capture "captured" String :> Raw Application IO)) + (Proxy :: Proxy (Capture "captured" String :> Raw IO Application)) (\ "captured" -> Raw (\ request_ respond -> respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_))))) $ do it "strips the captured path snippet from pathInfo" $ do @@ -502,7 +502,7 @@ headerSpec = describe "Servant.API.Header" $ do delete' "/" "" `shouldRespondWith` 204 -type RawApi = "foo" :> Raw Application IO +type RawApi = "foo" :> Raw IO Application rawApi :: Proxy RawApi rawApi = Proxy rawApplication :: Show a => (Request -> a) -> Application diff --git a/servant-server/test/Servant/Utils/StaticFilesSpec.hs b/servant-server/test/Servant/Utils/StaticFilesSpec.hs index c0d111ab..80a76767 100644 --- a/servant-server/test/Servant/Utils/StaticFilesSpec.hs +++ b/servant-server/test/Servant/Utils/StaticFilesSpec.hs @@ -27,7 +27,7 @@ import Servant.Utils.StaticFiles (serveDirectory) type Api = "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person - :<|> "static" :> Raw Application IO + :<|> "static" :> Raw IO Application api :: Proxy Api diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index 2cd00ab9..e1eecb31 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,6 +1,6 @@ HEAD ---- -* Change Raw from `data Raw ...` to `newtype Raw a (m :: * -> *) = Raw a ...` +* Change Raw from `data Raw ...` to `newtype Raw (m :: * -> *) a = Raw ... a` * Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Fix safeLink, so Header is not in fact required. * Added more instances for (:<|>) diff --git a/servant/src/Servant/API/Raw.hs b/servant/src/Servant/API/Raw.hs index bd21934f..736e1d22 100644 --- a/servant/src/Servant/API/Raw.hs +++ b/servant/src/Servant/API/Raw.hs @@ -1,9 +1,25 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE KindSignatures #-} -{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# OPTIONS_HADDOCK not-home #-} + module Servant.API.Raw where -import Data.Typeable (Typeable) +import Control.Monad (liftM) +import Data.Typeable (Typeable) +import Data.Data (Data) +import Data.Foldable +import Data.Ix (Ix(..)) +import GHC.Generics (Generic, Generic1) +#if !MIN_VERSION_base(4,8,0) +import Data.Monoid +import Data.Traversable (Traversable(..)) +import Control.Applicative (liftA2, (<$>), Applicative(..)) +#else +import Control.Applicative (liftA2) +#endif -- | Endpoint for plugging in your own Wai 'Application's. -- -- The given 'Application' will get the request as received by the server, potentially with @@ -14,5 +30,116 @@ import Data.Typeable (Typeable) -- static files stored in a particular directory on your filesystem newtype Raw (m :: * -> *) a = Raw { unRaw :: a - } - deriving (Eq, Show, Typeable) + } deriving (Eq, Read, Show, Ord, Typeable, Ix, Bounded, Data, Generic, Generic1) + +instance Monoid a => Monoid (Raw m a) where + mempty = Raw mempty + mappend (Raw a) (Raw b) = Raw (mappend a b) + +instance Functor (Raw m) where + fmap f (Raw x) = Raw (f x) + +instance Applicative (Raw m) where + pure = Raw + Raw f <*> Raw x = Raw (f x) + +instance Monad (Raw m) where + return = Raw + Raw m >>= k = k m + _ >> n = n + +instance Foldable (Raw m) where + foldMap f (Raw x) = f x + fold (Raw x) = x + foldr f z (Raw x) = f x z + foldl f z (Raw x) = f z x + foldl1 _ (Raw x) = x + foldr1 _ (Raw x) = x + +instance Traversable (Raw m) where + traverse f (Raw x) = Raw <$> f x + sequenceA (Raw x) = Raw <$> x + mapM f (Raw x) = liftM Raw (f x) + sequence (Raw x) = liftM Raw x + +instance Enum a => Enum (Raw m a) where + succ = fmap succ + pred = fmap pred + toEnum = Raw . toEnum + fromEnum (Raw x) = fromEnum x + enumFrom (Raw x) = map Raw (enumFrom x) + enumFromThen (Raw x) (Raw y) = map Raw (enumFromThen x y) + enumFromTo (Raw x) (Raw y) = map Raw (enumFromTo x y) + enumFromThenTo (Raw x) (Raw y) (Raw z) = map Raw (enumFromThenTo x y z) + +instance Num a => Num (Raw m a) where + (+) = liftA2 (+) + (-) = liftA2 (-) + (*) = liftA2 (*) + negate = fmap negate + abs = fmap abs + signum = fmap signum + fromInteger = Raw . fromInteger + +instance Real a => Real (Raw m a) where + toRational (Raw x) = toRational x + +instance Integral a => Integral (Raw m a) where + quot = liftA2 quot + rem = liftA2 rem + div = liftA2 div + mod = liftA2 mod + quotRem (Raw x) (Raw y) = (Raw a, Raw b) where + (a, b) = quotRem x y + divMod (Raw x) (Raw y) = (Raw a, Raw b) where + (a, b) = divMod x y + toInteger (Raw x) = toInteger x + +instance Fractional a => Fractional (Raw m a) where + (/) = liftA2 (/) + recip = fmap recip + fromRational = Raw . fromRational + +instance Floating a => Floating (Raw m a) where + pi = Raw pi + exp = fmap exp + log = fmap log + sqrt = fmap sqrt + sin = fmap sin + cos = fmap cos + tan = fmap tan + asin = fmap asin + acos = fmap acos + atan = fmap atan + sinh = fmap sinh + cosh = fmap cosh + tanh = fmap tanh + asinh = fmap asinh + acosh = fmap acosh + atanh = fmap atanh + (**) = liftA2 (**) + logBase = liftA2 (**) + +instance RealFrac a => RealFrac (Raw m a) where + properFraction (Raw x) = (a, Raw b) where + (a, b) = properFraction x + truncate (Raw x) = truncate x + round (Raw x) = round x + ceiling (Raw x) = ceiling x + floor (Raw x) = floor x + +instance RealFloat a => RealFloat (Raw m a) where + floatRadix (Raw x) = floatRadix x + floatDigits (Raw x) = floatDigits x + floatRange (Raw x) = floatRange x + decodeFloat (Raw x) = decodeFloat x + encodeFloat m n = Raw (encodeFloat m n) + exponent (Raw x) = exponent x + significand = fmap significand + scaleFloat n = fmap (scaleFloat n) + isNaN (Raw x) = isNaN x + isInfinite (Raw x) = isInfinite x + isDenormalized (Raw x) = isDenormalized x + isNegativeZero (Raw x) = isNegativeZero x + isIEEE (Raw x) = isIEEE x + atan2 = liftA2 atan2 diff --git a/servant/src/Servant/Utils/Links.hs b/servant/src/Servant/Utils/Links.hs index dab4378a..4fb9036e 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -366,6 +366,6 @@ instance HasLink (Delete y r) where type MkLink (Delete y r) = URI toLink _ = linkURI -instance HasLink (Raw a m) where - type MkLink (Raw a m) = URI +instance HasLink (Raw m a) where + type MkLink (Raw m a) = URI toLink _ = linkURI diff --git a/servant/test/Servant/API/RawSpec.hs b/servant/test/Servant/API/RawSpec.hs index 107a65f1..022d5470 100644 --- a/servant/test/Servant/API/RawSpec.hs +++ b/servant/test/Servant/API/RawSpec.hs @@ -10,6 +10,6 @@ spec :: Spec spec = describe "Servant.API.Raw" $ do describe "unRaw" $ do it "unRaw returns proper value" $ do - let p = Raw "testing" :: Raw String IO + let p = Raw "testing" :: Raw IO String p `shouldBe` (Raw "testing") (unRaw p) `shouldBe` "testing" diff --git a/servant/test/Servant/Utils/LinksSpec.hs b/servant/test/Servant/Utils/LinksSpec.hs index 1c65d302..19e66fe9 100644 --- a/servant/test/Servant/Utils/LinksSpec.hs +++ b/servant/test/Servant/Utils/LinksSpec.hs @@ -26,7 +26,7 @@ type TestApi = :<|> "put" :> Put '[JSON] () :<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] () :<|> "delete" :> Header "ponies" String :> Delete '[JSON] () - :<|> "raw" :> Raw () IO + :<|> "raw" :> Raw IO () type TestLink = "hello" :> "hi" :> Get '[JSON] Bool type TestLink2 = "greet" :> ReqBody '[JSON] [Int] :> Post '[PlainText] Bool @@ -87,4 +87,4 @@ spec = describe "Servant.Utils.Links" $ do apiLink (Proxy :: Proxy ("put" :> Put '[JSON] ())) `shouldBeURI` "put" apiLink (Proxy :: Proxy ("post" :> Post '[JSON] ())) `shouldBeURI` "post" apiLink (Proxy :: Proxy ("delete" :> Delete '[JSON] ())) `shouldBeURI` "delete" - apiLink (Proxy :: Proxy ("raw" :> Raw () IO)) `shouldBeURI` "raw" + apiLink (Proxy :: Proxy ("raw" :> Raw IO ())) `shouldBeURI` "raw"