diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,4 +1,8 @@ +## 0.2.0.1 + +* Add tests and more documentation. + ## 0.2.0.0 * (commit 30a2cd48488d) Add a phantom type to `RawM` to allow the user to diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,4 +7,67 @@ [![Stackage Nightly](http://stackage.org/package/servant-rawm/badge/nightly)](http://stackage.org/nightly/package/servant-rawm) ![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg) -`servant-rawm` provides a way to embed a WAI `Application` in a Servant handler. +`servant-rawm` provides a way to embed a WAI +[`Application`](https://hackage.haskell.org/package/wai-3.2.1.1/docs/Network-Wai.html#t:Application) +in a Servant handler. It is more convenient and powerful than the +[`Raw`](https://hackage.haskell.org/package/servant-0.11/docs/Servant-API-Raw.html#t:Raw) +type provided by [`servant`](https://hackage.haskell.org/package/servant). + +See the +[Haddocks on Hackage for `servant-rawm`](https://hackage.haskell.org/package/servant-rawm/docs/Servant-RawM.html) +for an explanation of how to use the +[`RawM`](https://hackage.haskell.org/package/servant-rawm/docs/Servant-RawM.html#t:RawM) +type. + +## Example + +There is code for an example server, client, and documentation located +in [`example/`](example/). The following section describes how to run the +example executables. + +### Building + +The example executables can be built with the following command: + +```sh +$ stack build --flag servant-rawm:buildexample +``` + +### Server + +After building, the server can be run with the following command: + +```sh +$ stack exec -- servant-rawm-example-server +``` + +This runs a server on port 8201 serving files +in [`example/files/`](example/files/). + +It can be accessed from `curl` like the following: + +```sh +$ curl http://localhost:8201/serve-directory/foo.txt +This is an example text file. +``` + +### Client + +After building, the client can be run like the following: + +```sh +$ stack exec -- servant-rawm-example-client +Successfully got file ./example/files/foo.txt: + +This is an example text file. +``` + +### Documentation + +After building, the documentation can be generated like the following. This is +documentation for the API defined in [example/Api.hs](example/Api.hs): + +```sh +$ stack exec -- servant-rawm-example-docs +... +``` diff --git a/example/Client.hs b/example/Client.hs --- a/example/Client.hs +++ b/example/Client.hs @@ -14,7 +14,6 @@ (BaseUrl(BaseUrl), ClientEnv(ClientEnv), ClientM, Scheme(Http), client, runClientM) import Servant.Common.Req (Req, appendToPath) - import Servant.RawM () import Api (Api, port) diff --git a/example/files/foo.txt b/example/files/foo.txt new file mode 100644 --- /dev/null +++ b/example/files/foo.txt @@ -0,0 +1,3 @@ +This is an example text file. + +The example API will serve any file in the ./example/files directory. diff --git a/servant-rawm.cabal b/servant-rawm.cabal --- a/servant-rawm.cabal +++ b/servant-rawm.cabal @@ -1,5 +1,5 @@ name: servant-rawm -version: 0.2.0.0 +version: 0.2.0.1 synopsis: Embed a raw 'Application' in a Servant API description: Please see . homepage: https://github.com/cdepillabout/servant-rawm @@ -12,6 +12,7 @@ build-type: Simple extra-source-files: CHANGELOG.md , README.md + , example/files/foo.txt , stack.yaml cabal-version: >=1.10 @@ -29,14 +30,12 @@ , Servant.RawM.Internal.Server build-depends: base >= 4.8 && < 5 , bytestring >= 0.10 - , containers >= 0.5 , filepath >= 1.4 , http-client >= 0.5 , http-media >= 0.6 , http-types >= 0.9 , lens >= 4.0 , resourcet >= 1.0 - , servant >= 0.9 , servant-client >= 0.9 , servant-docs >= 0.9 , servant-server >= 0.9 @@ -105,33 +104,39 @@ else buildable: False --- test-suite servant-rawm-doctest --- type: exitcode-stdio-1.0 --- main-is: DocTest.hs --- hs-source-dirs: test --- build-depends: base --- , doctest --- , Glob --- default-language: Haskell2010 --- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N +test-suite servant-rawm-doctest + type: exitcode-stdio-1.0 + main-is: DocTest.hs + hs-source-dirs: test + build-depends: base + , doctest + , Glob + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N --- test-suite servant-rawm-test --- type: exitcode-stdio-1.0 --- main-is: Spec.hs --- other-modules: --- hs-source-dirs: test --- build-depends: base --- , bytestring --- , hspec-wai --- , tasty --- , tasty-hspec --- , tasty-hunit --- , servant --- , servant-rawm --- , servant-server --- , wai --- default-language: Haskell2010 --- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -Wmissing-import-lists +test-suite servant-rawm-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + hs-source-dirs: test + build-depends: base + , bytestring + , hspec-wai + , http-client + , http-media + , http-types + , servant + , servant-client + , servant-rawm + , servant-server + , tasty + , tasty-hspec + , tasty-hunit + , transformers + , wai + , warp + default-language: Haskell2010 + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -Wmissing-import-lists source-repository head type: git diff --git a/src/Servant/RawM.hs b/src/Servant/RawM.hs --- a/src/Servant/RawM.hs +++ b/src/Servant/RawM.hs @@ -8,6 +8,63 @@ Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) +This module exposes a 'RawM' type that allows you to embed a WAI +'Network.Wai.Application' in your Servant API. + +It is similar to 'Servant.API.Raw.Raw' provided by Servant, but there is one big +difference. 'RawM' allows you to use monadic effects to create the +'Network.Wai.Application'. + +What does this look like in practice? The following is an example of using +'RawM': + +@ + type Api = \"serve-directory-example\" :> 'RawM' + + serverRoot :: 'Servant.Server.ServerT' Api ('Control.Monad.Reader.ReaderT' 'FilePath' 'IO') + serverRoot = rawEndpoint + + rawEndpoint :: 'Control.Monad.Reader.ReaderT' 'FilePath' 'IO' 'Network.Wai.Application' + rawEndpoint = do + filePath <- 'Control.Monad.Reader.ask' + 'serveDirectoryWebApp' filePath + + app :: FilePath -> 'Network.Wai.Application' + app filePath = + 'Servant.Server.serve' ('Data.Proxy.Proxy' :: 'Data.Proxy.Proxy' Api) apiServer + where + apiServer :: Server Api + apiServer = 'Servant.Utils.Enter.enter' ('Servant.Utils.Enter.NT' transformation) serverRoot + + transformation :: 'Control.Monad.Reader.ReaderT' 'FilePath' 'IO' a -> 'Servant.Server.Handler' a + transformation readerT = 'Control.Monad.IO.Class.liftIO' $ 'Control.Monad.Reader.runReaderT' readerT filePath +@ + +Notice how the above @rawEndpoint@ handler is able to get the @filePath@ from +the 'Control.Monad.Reader.ReaderT'. Using Servant's default +'Servant.API.Raw.Raw' type, @rawEndpoint@ would have to be written like the +following: + +@ + type Api\' = \"serve-directory-example\" :> 'Raw' + + serverRoot\' :: 'Server.ServerT' Api ('Control.Monad.Reader.ReaderT' 'FilePath' 'IO') + serverRoot\' = rawEndpoint\' + + rawEndpoint\' :: 'Data.Tagged.Tagged' ('Control.Monad.Reader.ReaderT' 'FilePath' 'IO') 'Network.Wai.Application' + rawEndpoint\' = ... +@ + +@rawEndpoint\'@ does not have access to the 'Control.Monad.Reader.ReaderT' monad, +so there is no way to get the directory path. + +'RawM' solves this problem by allowing the 'Network.Wai.Application' to be +produced monadically. + +There is an + in +the source code repository that shows a more in-depth server, client, and +documentation. -} module Servant.RawM diff --git a/src/Servant/RawM/Internal.hs b/src/Servant/RawM/Internal.hs --- a/src/Servant/RawM/Internal.hs +++ b/src/Servant/RawM/Internal.hs @@ -14,10 +14,13 @@ -} module Servant.RawM.Internal - ( module X + ( module Servant.RawM.Internal.API + -- , module Servant.RawM.Internal.Client + -- , module Servant.RawM.Internal.Docs + , module Servant.RawM.Internal.Server ) where -import Servant.RawM.Internal.API as X +import Servant.RawM.Internal.API import Servant.RawM.Internal.Client () import Servant.RawM.Internal.Docs () -import Servant.RawM.Internal.Server as X +import Servant.RawM.Internal.Server diff --git a/src/Servant/RawM/Internal/API.hs b/src/Servant/RawM/Internal/API.hs --- a/src/Servant/RawM/Internal/API.hs +++ b/src/Servant/RawM/Internal/API.hs @@ -12,8 +12,24 @@ import Data.Typeable (Typeable) +-- | Specialization of 'RawM'' to 'FileServer'. This can be used if you are +-- using 'Servant.RawM.serveDirectoryWebApp', +-- 'Servant.RawM.serveDirectoryFileServer', etc. type RawM = RawM' FileServer +-- | This is a type to use to define a Servant API. It signifies a route that +-- allows embedding of a WAI 'Network.Wai.Application'. It is similar to +-- 'Servant.API.Raw.Raw', but it has a 'Servant.Server.HasServer' instance that +-- allows embedding of monadic effects. This should be more convenient than +-- 'Servant.API.Raw.Raw'. +-- +-- The phantom type @serverType@ is used for defining the 'Servant.Docs.HasDocs' +-- instance. There are instances for 'Servant.Client.HasClient' and +-- 'Servant.Server.HasServer' for 'RawM'' with a polymorphic phantom type, but +-- there is only a 'Servant.Docs.HasDocs' instance specified for @'RawM'' +-- 'FileServer'@. This allows the end-user to easily create a +-- 'Servant.Docs.HasDocs' instance for a custom 'Network.Wai.Application'. data RawM' serverType deriving Typeable +-- | Used by 'RawM' as a phantom type. data FileServer deriving Typeable diff --git a/src/Servant/RawM/Internal/Client.hs b/src/Servant/RawM/Internal/Client.hs --- a/src/Servant/RawM/Internal/Client.hs +++ b/src/Servant/RawM/Internal/Client.hs @@ -27,6 +27,20 @@ import Servant.RawM.Internal.API (RawM') +-- | Creates a client route like the following: +-- +-- >>> :set -XTypeOperators +-- >>> import Data.Type.Equality ((:~:)(Refl)) +-- >>> Refl :: Client (RawM' a) :~: (Method -> (Req -> Req) -> ClientM (Int, ByteString, MediaType, [Header], Response ByteString)) +-- Refl +-- +-- This allows modification of the underlying 'Req' to work for any sort of +-- 'Network.Wai.Application'. +-- +-- Check out the +-- in +-- the source code repository that shows a more in-depth server, client, and +-- documentation. instance HasClient (RawM' serverType) where type Client (RawM' serverType) = Method diff --git a/src/Servant/RawM/Internal/Docs.hs b/src/Servant/RawM/Internal/Docs.hs --- a/src/Servant/RawM/Internal/Docs.hs +++ b/src/Servant/RawM/Internal/Docs.hs @@ -29,15 +29,18 @@ (Action, API, DocCapture(DocCapture), DocNote(DocNote), DocOptions, Endpoint, HasDocs(docsFor), captures, defResponse, method, notes, path, respBody, respStatus, respTypes, response, single) --- import Servant.Docs.Internal (apiEndpoints, respBody, response) import Servant.RawM.Internal.API (FileServer, RawM') +-- | This just defers to the 'HasDocs' instance for the @serverType@ phantom +-- type. instance (HasDocs serverType) => HasDocs (RawM' serverType) where docsFor :: Proxy (RawM' serverType) -> (Endpoint, Action) -> DocOptions -> API docsFor Proxy (endpoint, action) docOpts = docsFor (Proxy :: Proxy serverType) (endpoint, action) docOpts +-- | This is a 'HasDocs' instance compatible with the file servers defined in +-- "Servant.RawM.Internal.Server". instance HasDocs FileServer where docsFor :: Proxy FileServer -> (Endpoint, Action) -> DocOptions -> API docsFor Proxy (endpoint, action) _ = diff --git a/src/Servant/RawM/Internal/Server.hs b/src/Servant/RawM/Internal/Server.hs --- a/src/Servant/RawM/Internal/Server.hs +++ b/src/Servant/RawM/Internal/Server.hs @@ -40,6 +40,13 @@ import Servant.RawM.Internal.API (RawM') +-- | Creates a server instance like the following: +-- +-- +-- >>> :set -XTypeOperators +-- >>> import Data.Type.Equality ((:~:)(Refl)) +-- >>> Refl :: ServerT (RawM' a) m :~: m Application +-- Refl instance HasServer (RawM' serverType) context where type ServerT (RawM' serverType) m = m Application route diff --git a/test/DocTest.hs b/test/DocTest.hs new file mode 100644 --- /dev/null +++ b/test/DocTest.hs @@ -0,0 +1,40 @@ + +module Main (main) where + +import Prelude + +import Data.Monoid ((<>)) +import System.FilePath.Glob (glob) +import Test.DocTest (doctest) + +main :: IO () +main = glob "src/**/*.hs" >>= doDocTest + +doDocTest :: [String] -> IO () +doDocTest options = doctest $ options <> ghcExtensions + +ghcExtensions :: [String] +ghcExtensions = + [ + -- "-XConstraintKinds" + -- , "-XDataKinds" + "-XDeriveDataTypeable" + , "-XDeriveGeneric" + -- , "-XEmptyDataDecls" + , "-XFlexibleContexts" + -- , "-XFlexibleInstances" + -- , "-XGADTs" + -- , "-XGeneralizedNewtypeDeriving" + -- , "-XInstanceSigs" + -- , "-XMultiParamTypeClasses" + -- , "-XNoImplicitPrelude" + , "-XOverloadedStrings" + -- , "-XPolyKinds" + -- , "-XRankNTypes" + -- , "-XRecordWildCards" + , "-XScopedTypeVariables" + -- , "-XStandaloneDeriving" + -- , "-XTupleSections" + -- , "-XTypeFamilies" + -- , "-XTypeOperators" + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,173 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeOperators #-} + +module Main where + +import Control.Concurrent + (ThreadId, forkIO, killThread, threadDelay) +import Control.Exception (Exception, SomeException, catch) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Data.ByteString.Lazy (ByteString) +import Data.Either (isLeft) +import Data.Monoid ((<>)) +import Data.Proxy (Proxy(Proxy)) +import Data.Type.Equality ((:~:)(Refl)) +import Data.Typeable (Typeable) +import Network.HTTP.Client + (Response, defaultManagerSettings, newManager, responseBody) +import Network.HTTP.Media (MediaType) +import Network.HTTP.Types (Header, Method, methodGet) +import Network.Wai (Application) +import Network.Wai.Handler.Warp (run) +import Servant ((:>), (:~>)(NT), Handler, ServerT, enter, serve) +import Servant.Client + (Client, ClientEnv(ClientEnv), ClientM, client, runClientM) +import Servant.Common.BaseUrl (parseBaseUrl) +import Servant.Common.Req (Req, appendToPath) +import Test.Hspec.Wai (get, shouldRespondWith, with) +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.Hspec (afterAll, beforeAll, it, shouldBe, testSpec) +import Test.Tasty.HUnit ((@?=), assertFailure, testCase) + +import Servant.RawM (RawM, serveDirectoryWebApp) + +main :: IO () +main = do + tests <- testsIO + defaultMain tests + +testsIO :: IO TestTree +testsIO = do + clientTests <- clientTestsIO + serverTests <- serverTestsIO + pure $ + testGroup + "tests" + [ instanceTests + , clientTests + , serverTests + ] + +------------- +-- Helpers -- +------------- + +type Selector e = e -> Bool + +anyException :: Selector SomeException +anyException _ = True + +-- | Extra HUnit assertion to make sure an expression throws an exception. +assertThrows + :: forall e a. + (Exception e, Typeable e) + => IO a -> Selector e -> IO () +assertThrows ioAction selector = do + didCatch <- catch (ioAction *> pure False) (pure . selector) + case didCatch of + False -> + assertFailure "expecting an exception, but no exception occurred" + True -> pure () + +-- | Infix version of 'assertThrows'. +(@!) + :: (Exception e, Typeable e) + => IO a -> Selector e -> IO () +(@!) = assertThrows + +infix 1 @! + +------------------------------ +-- HasServer instance tests -- +------------------------------ + +checkRawMServer :: ServerT RawM m :~: m Application +checkRawMServer = Refl + +checkRawMClient + :: Client RawM :~: + ( Method -> + (Req -> Req) -> + ClientM (Int, ByteString, MediaType, [Header], Response ByteString) + ) +checkRawMClient = Refl + +instanceTests :: TestTree +instanceTests = + testGroup + "instances" + [ testCase "HasServer" $ checkRawMServer @?= Refl + , testCase "HasClient" $ checkRawMClient @?= Refl + ] + +-------------------------------- +-- Real Server Tests (Server) -- +-------------------------------- + +type Api = "test" :> RawM + +server :: ServerT Api (ReaderT FilePath IO) +server = fileServer + +fileServer :: ReaderT FilePath IO Application +fileServer = do + path <- ask + serveDirectoryWebApp path + +app :: Application +app = serve (Proxy :: Proxy Api) $ enter (NT trans) server + where + trans :: ReaderT FilePath IO a -> Handler a + trans readerT = liftIO $ runReaderT readerT "example/files" + +serverTestsIO :: IO TestTree +serverTestsIO = + testSpec "server" $ + with (pure app) $ do + it "correctly serves files" $ + get "/test/bar.txt" `shouldRespondWith` "This is bar.txt.\n" + it "returns 404 for non-existent files" $ + get "/test/non-existent-file.txt" `shouldRespondWith` 404 + +-------------------------------- +-- Real Server Tests (Client) -- +-------------------------------- + +getFile' + :: Method + -> (Req -> Req) + -> ClientM (Int, ByteString, MediaType, [Header], Response ByteString) +getFile' = client (Proxy :: Proxy Api) + +getFile :: String -> ClientM ByteString +getFile filePath = do + (_, _, _, _, resp) <- getFile' methodGet $ \req -> appendToPath filePath req + pure $ responseBody resp + +clientTestsIO :: IO TestTree +clientTestsIO = do + manager <- newManager defaultManagerSettings + baseUrl <- parseBaseUrl $ "http://localhost:" <> show port <> "/" + let clientEnv = ClientEnv manager baseUrl + testSpec "client" . beforeAll runServer . afterAll killServer $ do + it "correctly gets files" $ \_ -> do + eitherRes <- runClientM (getFile "bar.txt") clientEnv + eitherRes `shouldBe` Right "This is bar.txt.\n" + it "returns ServantErr for non-existent files" $ \_ -> do + eitherRes <- runClientM (getFile "non-existent-file.txt") clientEnv + isLeft eitherRes `shouldBe` True + +runServer :: IO ThreadId +runServer = do + threadId <- forkIO (run port app) + threadDelay $ 250 * 1000 + pure threadId + +killServer :: ThreadId -> IO () +killServer = killThread + +port :: Int +port = 51135