From b7c788a1d80d0242d4b202475f534c11de55d104 Mon Sep 17 00:00:00 2001 From: Brandon Martin Date: Thu, 30 Jul 2015 10:44:13 -0600 Subject: [PATCH] modify Raw to work with Enter --- servant-client/CHANGELOG.md | 1 + servant-client/src/Servant/Client.hs | 6 +- servant-client/test/Servant/ClientSpec.hs | 22 +-- servant-docs/CHANGELOG.md | 2 +- .../socket-io-chat/socket-io-chat.hs | 6 +- servant-examples/tutorial/T10.hs | 6 +- servant-examples/tutorial/T6.hs | 2 +- servant-examples/tutorial/T9.hs | 2 +- .../src/Servant/Foreign/Internal.hs | 4 +- servant-js/CHANGELOG.md | 2 +- servant-js/README.md | 2 +- servant-js/examples/counter.hs | 2 +- servant-js/test/Servant/JSSpec.hs | 2 +- servant-mock/CHANGELOG.md | 0 servant-mock/src/Servant/Mock.hs | 7 +- servant-server/CHANGELOG.md | 8 +- servant-server/src/Servant/Server/Internal.hs | 15 +- .../src/Servant/Server/Internal/Enter.hs | 25 ++- .../src/Servant/Utils/StaticFiles.hs | 20 ++- .../test/Servant/Server/Internal/EnterSpec.hs | 75 ++++++++- servant-server/test/Servant/ServerSpec.hs | 14 +- .../test/Servant/Utils/StaticFilesSpec.hs | 4 +- servant/CHANGELOG.md | 2 +- servant/src/Servant/API.hs | 2 +- servant/src/Servant/API/Raw.hs | 147 +++++++++++++++++- servant/src/Servant/Utils/Links.hs | 4 +- servant/test/Servant/API/RawSpec.hs | 15 ++ servant/test/Servant/Utils/LinksSpec.hs | 4 +- 28 files changed, 322 insertions(+), 79 deletions(-) create mode 100644 servant-mock/CHANGELOG.md create mode 100644 servant/test/Servant/API/RawSpec.hs diff --git a/servant-client/CHANGELOG.md b/servant-client/CHANGELOG.md index 2c9f5279..fa24de48 100644 --- a/servant-client/CHANGELOG.md +++ b/servant-client/CHANGELOG.md @@ -2,6 +2,7 @@ HEAD ---- * Use the `text` package instead of `String`. +* Update `instance HasClient Raw` for servant Raw changes * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Added support for `path` on `BaseUrl`. * `client` now takes an explicit `Manager` argument. diff --git a/servant-client/src/Servant/Client.hs b/servant-client/src/Servant/Client.hs index 82779651..1975bc14 100644 --- a/servant-client/src/Servant/Client.hs +++ b/servant-client/src/Servant/Client.hs @@ -347,10 +347,10 @@ 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 -> Req -> BaseUrl -> Manager -> Client Raw + clientWithRoute :: Proxy (Raw m a) -> Req -> BaseUrl -> Manager -> Client (Raw m a) clientWithRoute Proxy req baseurl manager httpMethod = do performRequest httpMethod req baseurl manager diff --git a/servant-client/test/Servant/ClientSpec.hs b/servant-client/test/Servant/ClientSpec.hs index 4cb1ef4c..ef61da00 100644 --- a/servant-client/test/Servant/ClientSpec.hs +++ b/servant-client/test/Servant/ClientSpec.hs @@ -40,7 +40,7 @@ import qualified Network.HTTP.Client as C import Network.HTTP.Media import Network.HTTP.Types (Status (..), badRequest400, methodGet, ok200, status400) -import Network.Socket +import Network.Socket hiding (Raw) import Network.Wai (Application, responseLBS) import Network.Wai.Handler.Warp import System.IO.Unsafe (unsafePerformIO) @@ -101,8 +101,8 @@ type Api = :<|> "param" :> QueryParam "name" String :> Get '[FormUrlEncoded,JSON] Person :<|> "params" :> QueryParams "names" String :> Get '[JSON] [Person] :<|> "flag" :> QueryFlag "flag" :> Get '[JSON] Bool - :<|> "rawSuccess" :> Raw - :<|> "rawFailure" :> Raw + :<|> "rawSuccess" :> Raw IO Application + :<|> "rawFailure" :> Raw IO Application :<|> "multiple" :> Capture "first" String :> QueryParam "second" Int :> @@ -126,8 +126,8 @@ server = serve api EmptyConfig ( Nothing -> throwE $ ServantErr 400 "missing parameter" "" []) :<|> (\ names -> return (zipWith Person names [0..])) :<|> return - :<|> (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") - :<|> (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") + :<|> Raw (\ _request respond -> respond $ responseLBS ok200 [] "rawSuccess") + :<|> Raw (\ _request respond -> respond $ responseLBS badRequest400 [] "rawFailure") :<|> (\ a b c d -> return (a, b, c, d)) :<|> (return $ addHeader 1729 $ addHeader "eg2" True) :<|> return NoContent @@ -135,17 +135,17 @@ server = serve api EmptyConfig ( type FailApi = - "get" :> Raw - :<|> "capture" :> Capture "name" String :> Raw - :<|> "body" :> Raw + "get" :> Raw IO Application + :<|> "capture" :> Capture "name" String :> Raw IO Application + :<|> "body" :> Raw IO Application failApi :: Proxy FailApi failApi = Proxy failServer :: Application failServer = serve failApi EmptyConfig ( - (\ _request respond -> respond $ responseLBS ok200 [] "") - :<|> (\ _capture _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "") - :<|> (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") + Raw (\ _request respond -> respond $ responseLBS ok200 [] "") + :<|> (\ _capture -> Raw (\ _request respond -> respond $ responseLBS ok200 [("content-type", "application/json")] "")) + :<|> Raw (\_request respond -> respond $ responseLBS ok200 [("content-type", "fooooo")] "") ) {-# NOINLINE manager #-} diff --git a/servant-docs/CHANGELOG.md b/servant-docs/CHANGELOG.md index a5be837a..2230dd57 100644 --- a/servant-docs/CHANGELOG.md +++ b/servant-docs/CHANGELOG.md @@ -1,6 +1,6 @@ HEAD ---- - +* Update `instance HasDocs Raw` for servant Raw changes * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Support maximum samples setting with new `DocOptions` type (used by `docsWithOptions` and `docsWith`) * Remove redundant second parameter of ToSample diff --git a/servant-examples/socket-io-chat/socket-io-chat.hs b/servant-examples/socket-io-chat/socket-io-chat.hs index 4f5e649a..33791970 100644 --- a/servant-examples/socket-io-chat/socket-io-chat.hs +++ b/servant-examples/socket-io-chat/socket-io-chat.hs @@ -21,8 +21,8 @@ import qualified Network.SocketIO as SocketIO import Chat (ServerState (..), eioServer) -type API = "socket.io" :> Raw - :<|> Raw +type API = "socket.io" :> Raw IO Application + :<|> Raw IO Application api :: Proxy API @@ -34,7 +34,7 @@ server sHandler = socketIOHandler :<|> serveDirectory "socket-io-chat/resources" where - socketIOHandler req respond = toWaiApplication sHandler req respond + socketIOHandler = Raw $ toWaiApplication sHandler app :: WaiMonad () -> Application diff --git a/servant-examples/tutorial/T10.hs b/servant-examples/tutorial/T10.hs index 859ff2cb..60b4ec7e 100644 --- a/servant-examples/tutorial/T10.hs +++ b/servant-examples/tutorial/T10.hs @@ -15,7 +15,7 @@ import Servant import Servant.Docs import qualified T3 -type DocsAPI = T3.API :<|> Raw +type DocsAPI = T3.API :<|> Raw IO Application instance ToCapture (Capture "x" Int) where toCapture _ = DocCapture "x" "(integer) position on the x axis" @@ -62,8 +62,8 @@ docsBS = encodeUtf8 server :: Server DocsAPI server = T3.server :<|> serveDocs - where serveDocs _ respond = - respond $ responseLBS ok200 [plain] docsBS + where serveDocs = Raw (\_ respond -> + respond $ responseLBS ok200 [plain] docsBS) plain = ("Content-Type", "text/plain") diff --git a/servant-examples/tutorial/T6.hs b/servant-examples/tutorial/T6.hs index 3e24647d..68963d31 100644 --- a/servant-examples/tutorial/T6.hs +++ b/servant-examples/tutorial/T6.hs @@ -6,7 +6,7 @@ module T6 where import Network.Wai import Servant -type API = "code" :> Raw +type API = "code" :> Raw IO Application api :: Proxy API api = Proxy diff --git a/servant-examples/tutorial/T9.hs b/servant-examples/tutorial/T9.hs index a9fd575b..f5fb6a0c 100644 --- a/servant-examples/tutorial/T9.hs +++ b/servant-examples/tutorial/T9.hs @@ -76,7 +76,7 @@ searchBook (Just q) = return (mkSearch q books') type API = "point" :> Get '[JSON] Point :<|> "books" :> QueryParam "q" Text :> Get '[JSON] (Search Book) -type API' = API :<|> Raw +type API' = API :<|> Raw IO Application api :: Proxy API api = Proxy diff --git a/servant-foreign/src/Servant/Foreign/Internal.hs b/servant-foreign/src/Servant/Foreign/Internal.hs index bb2e4b1e..182f4ab7 100644 --- a/servant-foreign/src/Servant/Foreign/Internal.hs +++ b/servant-foreign/src/Servant/Foreign/Internal.hs @@ -249,8 +249,8 @@ instance (KnownSymbol sym, HasForeignType lang a, a ~ Bool, HasForeign lang subl str = pack . symbolVal $ (Proxy :: Proxy sym) arg = (str, typeFor lang (Proxy :: Proxy a)) -instance HasForeign lang Raw where - type Foreign Raw = HTTP.Method -> Req +instance HasForeign lang (Raw m a) where + type Foreign (Raw m a) = HTTP.Method -> Req foreignFor _ Proxy req method = req & funcName %~ ((toLower $ decodeUtf8 method) :) diff --git a/servant-js/CHANGELOG.md b/servant-js/CHANGELOG.md index 575391d0..619fbd5c 100644 --- a/servant-js/CHANGELOG.md +++ b/servant-js/CHANGELOG.md @@ -1,6 +1,6 @@ HEAD ---- - +* Update `instance HasJS Raw` for servant Raw changes * Provide new targets for code generation along with the old jQuery one: vanilla Javascript and Angular.js * Greatly simplify usage of this library by reducing down the API to just 2 functions: `jsForAPI` and `writeJSForAPI` + the choice of a code generator * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators diff --git a/servant-js/README.md b/servant-js/README.md index e92f9f2d..7c13a44f 100644 --- a/servant-js/README.md +++ b/servant-js/README.md @@ -55,7 +55,7 @@ type TestApi = "counter" :> Post '[JSON] Counter -- endpoint for increasing the :<|> "counter" :> Get '[JSON] Counter -- endpoint to get the current value type TestApi' = TestApi -- The API we want a JS handler for - :<|> Raw -- used for serving static files + :<|> Raw Application IO -- 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/examples/counter.hs b/servant-js/examples/counter.hs index 5d2b80d0..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 -- 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 371d39db..2b8a0a1a 100644 --- a/servant-js/test/Servant/JSSpec.hs +++ b/servant-js/test/Servant/JSSpec.hs @@ -41,7 +41,7 @@ type TestAPI = "simple" :> ReqBody '[JSON,FormUrlEncoded] Text :> Post '[JSON] B :<|> "has.extension" :> Get '[FormUrlEncoded,JSON] Bool type TopLevelRawAPI = "something" :> Get '[JSON] Int - :<|> Raw + :<|> Raw IO () type HeaderHandlingAPI = "something" :> Header "Foo" Text :> Get '[JSON] Int diff --git a/servant-mock/CHANGELOG.md b/servant-mock/CHANGELOG.md new file mode 100644 index 00000000..e69de29b diff --git a/servant-mock/src/Servant/Mock.hs b/servant-mock/src/Servant/Mock.hs index 2c447ca0..c2389be9 100644 --- a/servant-mock/src/Servant/Mock.hs +++ b/servant-mock/src/Servant/Mock.hs @@ -68,6 +68,7 @@ import Network.Wai import Servant import Servant.API.ContentTypes import Servant.Server.Internal.Config +import Servant.Server.Internal (ToRawApplication) import Test.QuickCheck.Arbitrary (Arbitrary (..), vector) import Test.QuickCheck.Gen (Gen, generate) @@ -155,10 +156,10 @@ instance OVERLAPPING_ => HasMock (Verb method status ctypes (Headers headerTypes a)) config where mock _ _ = mockArbitrary -instance HasMock Raw config where - mock _ _ = \_req respond -> do +instance HasMock (Raw m Application) config where + mock _ _ = Raw (\_req respond -> do bdy <- genBody - respond $ responseLBS status200 [] bdy + respond $ responseLBS status200 [] bdy) where genBody = pack <$> generate (vector 100 :: Gen [Char]) diff --git a/servant-server/CHANGELOG.md b/servant-server/CHANGELOG.md index bfdbe421..0a764268 100644 --- a/servant-server/CHANGELOG.md +++ b/servant-server/CHANGELOG.md @@ -1,9 +1,13 @@ HEAD ---- - + typeclass `HasServer` now take an additional parameter. +* Add `serveDirectoryWith` user can supply custom `StaticSettings` +* Update `serveDirectory` for servant Raw changes +* Add `class ToRawApplication` for servant Raw changes +* Update `instance Server Raw` for servant Raw changes +* Add `instance Enter Raw` for servant Raw changes * Add `Config` machinery (https://github.com/haskell-servant/servant/pull/327). This is a breaking change, as the signatures of both `route`, `serve` and the - typeclass `HasServer` now take an additional parameter. * Support for the `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Drop `EitherT` in favor of `ExceptT` * Use `http-api-data` instead of `Servant.Common.Text` diff --git a/servant-server/src/Servant/Server/Internal.hs b/servant-server/src/Servant/Server/Internal.hs index daf44640..39518556 100644 --- a/servant-server/src/Servant/Server/Internal.hs +++ b/servant-server/src/Servant/Server/Internal.hs @@ -52,7 +52,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Verb, ReflectMethod(reflectMethod), IsSecure(..), Header, QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, Vault, + Raw(..), RemoteHost, ReqBody, Vault, WithNamedConfig) import Servant.API.ContentTypes (AcceptHeader (..), AllCTRender (..), @@ -354,18 +354,23 @@ instance (KnownSymbol sym, HasServer sublayout config) -- -- Example: -- --- > type MyApi = "images" :> Raw +-- > type MyApi = "images" :> Raw IO Application -- > -- > server :: Server MyApi -- > server = serveDirectory "/var/www/images" -instance HasServer Raw config where +class ToRawApplication a where + toRawApplication :: a -> Application - type ServerT Raw m = Application +instance ToRawApplication Application where + toRawApplication = id + +instance ToRawApplication a => HasServer (Raw m a) config where + type ServerT (Raw m a) n = Raw n a route Proxy _ rawApplication = LeafRouter $ \ request respond -> do r <- runDelayed rawApplication case r of - Route app -> app request (respond . Route) + Route (Raw app) -> (toRawApplication app) request (respond . Route) Fail a -> respond $ Fail a FailFatal e -> respond $ FailFatal e diff --git a/servant-server/src/Servant/Server/Internal/Enter.hs b/servant-server/src/Servant/Server/Internal/Enter.hs index 5bcebe9d..e166c85a 100644 --- a/servant-server/src/Servant/Server/Internal/Enter.hs +++ b/servant-server/src/Servant/Server/Internal/Enter.hs @@ -8,6 +8,9 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# 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) @@ -27,16 +30,15 @@ import qualified Control.Monad.Writer.Strict as SWriter import Data.Typeable import Servant.API -class Enter typ arg ret | typ arg -> ret, typ ret -> arg where +class Enter typ arg ret | typ ret -> arg, arg ret -> typ where enter :: arg -> typ -> ret -- ** Servant combinators -instance ( Enter typ1 arg1 ret1, Enter typ2 arg2 ret2 - , arg1 ~ arg2 +instance ( Enter typ1 arg1 ret1 , Enter typ2 arg1 ret2 ) => Enter (typ1 :<|> typ2) arg1 (ret1 :<|> ret2) where enter e (a :<|> b) = enter e a :<|> enter e b -instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where +instance (Enter b arg ret) => Enter (a -> b) arg (a -> ret) where enter arg f a = enter arg (f a) -- ** Useful instances @@ -49,8 +51,19 @@ instance C.Category (:~>) where id = Nat id Nat f . Nat g = Nat (f . g) -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 + +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 -- | Like `lift`. liftNat :: (Control.Monad.Morph.MonadTrans t, Monad m) => m :~> t m diff --git a/servant-server/src/Servant/Utils/StaticFiles.hs b/servant-server/src/Servant/Utils/StaticFiles.hs index 08d01ada..b0fe1a5c 100644 --- a/servant-server/src/Servant/Utils/StaticFiles.hs +++ b/servant-server/src/Servant/Utils/StaticFiles.hs @@ -8,9 +8,11 @@ module Servant.Utils.StaticFiles ( ) where import Network.Wai.Application.Static (defaultFileServerSettings, + StaticSettings, staticApp) -import Servant.API.Raw (Raw) -import Servant.Server (Server) +import Network.Wai (Application) +import Servant.API.Raw (Raw(..)) +import Servant.Server (ServerT) import System.FilePath (addTrailingPathSeparator) #if !MIN_VERSION_wai_app_static(3,1,0) import Filesystem.Path.CurrentOS (decodeString) @@ -36,10 +38,12 @@ import Filesystem.Path.CurrentOS (decodeString) -- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectory' -- handler in the last position, because /servant/ will try to match the handlers -- in order. -serveDirectory :: FilePath -> Server Raw -serveDirectory = -#if MIN_VERSION_wai_app_static(3,1,0) - staticApp . defaultFileServerSettings . addTrailingPathSeparator -#else - staticApp . defaultFileServerSettings . decodeString . addTrailingPathSeparator +serveDirectoryWith :: StaticSettings -> ServerT (Raw m Application) n +serveDirectoryWith settings = Raw (staticApp settings) + +serveDirectory :: FilePath -> ServerT (Raw m Application) n +serveDirectory = serveDirectoryWith . defaultFileServerSettings . +#if !MIN_VERSION_wai_app_static(3,1,0) + decodeString . #endif + addTrailingPathSeparator diff --git a/servant-server/test/Servant/Server/Internal/EnterSpec.hs b/servant-server/test/Servant/Server/Internal/EnterSpec.hs index 06e8af9b..cd5d9f85 100644 --- a/servant-server/test/Servant/Server/Internal/EnterSpec.hs +++ b/servant-server/test/Servant/Server/Internal/EnterSpec.hs @@ -6,12 +6,24 @@ module Servant.Server.Internal.EnterSpec where import qualified Control.Category as C import Control.Monad.Reader import Control.Monad.Trans.Except +import Control.Monad.Writer +import Data.IORef import Data.Proxy import Servant.API import Servant.Server -import Test.Hspec (Spec, describe, it) -import Test.Hspec.Wai (get, matchStatus, post, +import Control.Exception (bracket) +import Network.Wai (Application) +import Network.HTTP.Types (methodPost) +import Servant.Utils.StaticFiles (serveDirectory) +import System.Directory (createDirectory, + getCurrentDirectory, + setCurrentDirectory) +import System.IO.Temp (withSystemTempDirectory) +import System.IO.Unsafe (unsafePerformIO) +import Test.Hspec (Spec, around_, context, describe, + it, shouldReturn) +import Test.Hspec.Wai (get, matchStatus, post, request, shouldRespondWith, with) spec :: Spec @@ -20,22 +32,35 @@ spec = describe "module Servant.Server.Enter" $ do type ReaderAPI = "int" :> Get '[JSON] Int :<|> "string" :> Post '[JSON] String + :<|> "static" :> Raw (Reader String) Application type IdentityAPI = "bool" :> Get '[JSON] Bool +type WriterAPI = "fn" :> ReqBody '[JSON] Int :> Post '[JSON] Int + type CombinedAPI = ReaderAPI :<|> IdentityAPI +type CombinedAPI2 = CombinedAPI :<|> WriterAPI + readerAPI :: Proxy ReaderAPI readerAPI = Proxy combinedAPI :: Proxy CombinedAPI combinedAPI = Proxy +combinedAPI2 :: Proxy CombinedAPI2 +combinedAPI2 = Proxy + readerServer' :: ServerT ReaderAPI (Reader String) -readerServer' = return 1797 :<|> ask +readerServer' = return 1797 + :<|> ask + :<|> serveDirectory "static" + +writerServer :: ServerT WriterAPI (WriterT String IO) +writerServer x = tell "hi" >> return x fReader :: Reader String :~> ExceptT ServantErr IO -fReader = generalizeNat C.. (runReaderTNat "hi") +fReader = generalizeNat C.. runReaderTNat "hi" readerServer :: Server ReaderAPI readerServer = enter fReader readerServer' @@ -46,14 +71,52 @@ combinedReaderServer' = readerServer' :<|> enter generalizeNat (return True) combinedReaderServer :: Server CombinedAPI combinedReaderServer = enter fReader combinedReaderServer' +combinedServer2 :: IORef String -> Server CombinedAPI2 +combinedServer2 ref' + = enter fReader combinedReaderServer' + :<|> enter (liftNat C.. logWriterTLNat (writeIORef ref')) writerServer + +withStaticFiles :: IO () -> IO () +withStaticFiles action = withSystemTempDirectory "servant-test" $ \ tmpDir -> + bracket (setup tmpDir) teardown (const action) + where + setup tmpDir = do + outer <- getCurrentDirectory + setCurrentDirectory tmpDir + createDirectory "static" + writeFile "static/foo.txt" "bar" + writeFile "static/index.html" "index" + return outer + + teardown outer = do + setCurrentDirectory outer + enterSpec :: Spec enterSpec = describe "Enter" $ do - with (return (serve readerAPI EmptyConfig readerServer)) $ do + around_ withStaticFiles $ with (return (serve readerAPI EmptyConfig readerServer)) $ do it "allows running arbitrary monads" $ do get "int" `shouldRespondWith` "1797" post "string" "3" `shouldRespondWith` "\"hi\""{ matchStatus = 200 } with (return (serve combinedAPI EmptyConfig combinedReaderServer)) $ do - it "allows combnation of enters" $ do + it "allows combination of enters" $ do get "bool" `shouldRespondWith` "true" + + with (newIORef "h" >>= \r -> return (serve combinedAPI2 EmptyConfig $ combinedServer2 r)) $ do + it "allows nested combination of enters" $ do + get "bool" `shouldRespondWith` "true" + request methodPost "fn" [("Content-Type", "application/json")] "3" + `shouldRespondWith` "3"{ matchStatus = 200 } + + + context "logWriter" $ do + with (return (serve combinedAPI2 EmptyConfig $ combinedServer2 ref)) $ do + it "runs the function provided with the logs as argument" $ do + void $ request methodPost "fn" [("Content-Type", "application/json")] "3" + liftIO $ readIORef ref `shouldReturn` "hi" + + +{-# NOINLINE ref #-} +ref :: IORef String +ref = unsafePerformIO $ newIORef "" diff --git a/servant-server/test/Servant/ServerSpec.hs b/servant-server/test/Servant/ServerSpec.hs index 04461566..403c676d 100644 --- a/servant-server/test/Servant/ServerSpec.hs +++ b/servant-server/test/Servant/ServerSpec.hs @@ -45,7 +45,7 @@ import Servant.API ((:<|>) (..), (:>), Capture, Delete, NoContent (..), Patch, PlainText, Post, Put, QueryFlag, QueryParam, QueryParams, - Raw, RemoteHost, ReqBody, + Raw(..), RemoteHost, ReqBody, StdMethod (..), Verb, addHeader) import Servant.API.Internal.Test.ComprehensiveAPI import Servant.Server (ServantErr (..), Server, err404, @@ -197,10 +197,10 @@ captureSpec = do get "/notAnInt" `shouldRespondWith` 404 with (return (serve - (Proxy :: Proxy (Capture "captured" String :> Raw)) + (Proxy :: Proxy (Capture "captured" String :> Raw IO Application)) EmptyConfig - (\ "captured" request_ respond -> - respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_)))) $ do + (\ "captured" -> Raw (\ request_ respond -> + respond $ responseLBS ok200 [] (cs $ show $ pathInfo request_))))) $ do it "strips the captured path snippet from pathInfo" $ do get "/captured/foo" `shouldRespondWith` (fromString (show ["foo" :: String])) @@ -360,7 +360,7 @@ headerSpec = describe "Servant.API.Header" $ do -- * rawSpec {{{ ------------------------------------------------------------------------------ -type RawApi = "foo" :> Raw +type RawApi = "foo" :> Raw IO Application rawApi :: Proxy RawApi rawApi = Proxy @@ -373,7 +373,7 @@ rawSpec :: Spec rawSpec = do describe "Servant.API.Raw" $ do it "runs applications" $ do - (flip runSession) (serve rawApi EmptyConfig (rawApplication (const (42 :: Integer)))) $ do + (flip runSession) (serve rawApi EmptyConfig (Raw (rawApplication (const (42 :: Integer))))) $ do response <- Network.Wai.Test.request defaultRequest{ pathInfo = ["foo"] } @@ -381,7 +381,7 @@ rawSpec = do simpleBody response `shouldBe` "42" it "gets the pathInfo modified" $ do - (flip runSession) (serve rawApi EmptyConfig (rawApplication pathInfo)) $ do + (flip runSession) (serve rawApi EmptyConfig (Raw (rawApplication pathInfo))) $ do response <- Network.Wai.Test.request defaultRequest{ pathInfo = ["foo", "bar"] } diff --git a/servant-server/test/Servant/Utils/StaticFilesSpec.hs b/servant-server/test/Servant/Utils/StaticFilesSpec.hs index e6430b5c..d5f56a71 100644 --- a/servant-server/test/Servant/Utils/StaticFilesSpec.hs +++ b/servant-server/test/Servant/Utils/StaticFilesSpec.hs @@ -15,14 +15,14 @@ import System.IO.Temp (withSystemTempDirectory) import Test.Hspec (Spec, around_, describe, it) import Test.Hspec.Wai (get, shouldRespondWith, with) -import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw, (:>), JSON) +import Servant.API ((:<|>) ((:<|>)), Capture, Get, Raw(..), (:>), JSON) import Servant.Server (Server, serve, Config(EmptyConfig)) import Servant.ServerSpec (Person (Person)) import Servant.Utils.StaticFiles (serveDirectory) type Api = "dummy_api" :> Capture "person_name" String :> Get '[JSON] Person - :<|> "static" :> Raw + :<|> "static" :> Raw IO Application api :: Proxy Api diff --git a/servant/CHANGELOG.md b/servant/CHANGELOG.md index ef344650..ce1ba8c0 100644 --- a/servant/CHANGELOG.md +++ b/servant/CHANGELOG.md @@ -1,6 +1,6 @@ HEAD ---- - +* Change Raw from `data Raw ...` to `newtype Raw (m :: * -> *) a = Raw ... a` * Add `WithNamedConfig` combinator. * Add `HttpVersion`, `IsSecure`, `RemoteHost` and `Vault` combinators * Fix safeLink, so Header is not in fact required. diff --git a/servant/src/Servant/API.hs b/servant/src/Servant/API.hs index 2da0d4cf..165106f7 100644 --- a/servant/src/Servant/API.hs +++ b/servant/src/Servant/API.hs @@ -62,7 +62,7 @@ import Servant.API.HttpVersion (HttpVersion (..)) import Servant.API.IsSecure (IsSecure (..)) import Servant.API.QueryParam (QueryFlag, QueryParam, QueryParams) -import Servant.API.Raw (Raw) +import Servant.API.Raw (Raw(..)) import Servant.API.RemoteHost (RemoteHost) import Servant.API.ReqBody (ReqBody) import Servant.API.ResponseHeaders (AddHeader (addHeader), diff --git a/servant/src/Servant/API/Raw.hs b/servant/src/Servant/API/Raw.hs index 90a5f4bd..f35709c3 100644 --- a/servant/src/Servant/API/Raw.hs +++ b/servant/src/Servant/API/Raw.hs @@ -1,14 +1,151 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS_HADDOCK not-home #-} +{-# LANGUAGE KindSignatures #-} +{-# 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 --- a modified (stripped) 'pathInfo' if the 'Application' is being routed with 'Servant.API.Sub.:>'. +-- The given 'Application' will get the request as received by the server, +-- potentially with a modified (stripped) 'pathInfo' if the 'Application' is +-- being routed with 'Servant.API.Sub.:>'. -- -- In addition to just letting you plug in your existing WAI 'Application's, -- this can also be used with 'Servant.Utils.StaticFiles.serveDirectory' to serve -- static files stored in a particular directory on your filesystem -data Raw deriving Typeable +-- +-- The phantom type (@m@) is used to describe which monad your web handlers run +-- in: IO for wai (the default server provided in servant-server), or another +-- monad specific to your handler or application (e.g. @AppHandler@ in @Snap@). +-- Non-server Servant interpretations generally don't look at (@m@). +newtype Raw (m :: * -> *) a = Raw { + unRaw :: a + } 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 d83ffc7e..c8acd4f2 100644 --- a/servant/src/Servant/Utils/Links.hs +++ b/servant/src/Servant/Utils/Links.hs @@ -300,6 +300,6 @@ instance HasLink (Verb m s ct a) where type MkLink (Verb m s ct a) = URI toLink _ = linkURI -instance HasLink Raw where - type MkLink Raw = 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 new file mode 100644 index 00000000..022d5470 --- /dev/null +++ b/servant/test/Servant/API/RawSpec.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +module Servant.API.RawSpec where + +import Test.Hspec + +import Servant.API.Raw + +spec :: Spec +spec = describe "Servant.API.Raw" $ do + describe "unRaw" $ do + it "unRaw returns proper value" $ do + 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 07e0b068..f31d7923 100644 --- a/servant/test/Servant/Utils/LinksSpec.hs +++ b/servant/test/Servant/Utils/LinksSpec.hs @@ -22,7 +22,7 @@ type TestApi = :<|> "put" :> Put '[JSON] () :<|> "post" :> ReqBody '[JSON] 'True :> Post '[JSON] () :<|> "delete" :> Header "ponies" String :> Delete '[JSON] () - :<|> "raw" :> Raw + :<|> "raw" :> Raw IO () apiLink :: (IsElem endpoint TestApi, HasLink endpoint) @@ -58,7 +58,7 @@ 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)) `shouldBeURI` "raw" + apiLink (Proxy :: Proxy ("raw" :> Raw IO ())) `shouldBeURI` "raw" -- |