diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,14 @@ +## 1.0.0.0 + +* The implementations of the `RawM` endpoint are divided into + `servant-rawm-client`, `servant-rawm-docs`, and `servant-rawm-server` to + avoid introducing unnecessary dependencies and reduce the compilation + overhead. You will need to add either of the implementations to your + dependencies, and import the corresponding implementation + (`Servant.RawM.Server`, `Servant.RawM.Client`, or `Servant.RawM.Docs`) for + the `RawM` endpoint to function correctly. + [#16](https://github.com/cdepillabout/servant-rawm/pull/16) + Thanks [@Krasjet](https://github.com/Krasjet)! ## 0.3.2.0 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright Dennis Gosnell (c) 2017 +Copyright Dennis Gosnell (c) 2017-2020 All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,4 +1,3 @@ - # Servant.RawM [![Build Status](https://secure.travis-ci.org/cdepillabout/servant-rawm.svg)](http://travis-ci.org/cdepillabout/servant-rawm) @@ -19,10 +18,20 @@ [`RawM`](https://hackage.haskell.org/package/servant-rawm/docs/Servant-RawM.html#t:RawM) type. +After `servant-rawm` 1.0.0.0, the implementations of the `RawM` endpoint are +divided into `servant-rawm-client`, `servant-rawm-docs`, and +`servant-rawm-server` to avoid introducing unnecessary dependencies and reduce +the compilation overhead. + +You will need to add either of the implementations to your dependencies, and +import the corresponding implementation (`Servant.RawM.Server`, +`Servant.RawM.Client`, or `Servant.RawM.Docs`) for the `RawM` endpoint to +function correctly. + ## Example There is code for an example server, client, and documentation located -in [`example/`](example/). The following section describes how to run the +in [`servant-rawm-examples-and-tests/example/`](servant-rawm-examples-and-tests/example/). The following section describes how to run the example executables. ### Building @@ -30,7 +39,7 @@ The example executables can be built with the following command: ```sh -$ stack build --flag servant-rawm:buildexample +$ stack build servant-rawm-examples-and-tests ``` ### Server @@ -42,7 +51,7 @@ ``` This runs a server on port 8201 serving files -in [`example/files/`](example/files/). +in [`servant-rawm-examples-and-tests/example/files/`](servant-rawm-examples-and-tests/example/files/). It can be accessed from `curl` like the following: @@ -53,7 +62,7 @@ ### Client -After building, the client can be run like the following: +After building and running the server, the client can be run like the following: ```sh $ stack exec -- servant-rawm-example-client @@ -65,9 +74,15 @@ ### 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): +documentation for the API defined in +[servant-rawm-examples-and-tests/example/Api.hs](servant-rawm-examples-and-tests/example/Api.hs): ```sh $ stack exec -- servant-rawm-example-docs ... ``` + +## Maintainers + +- [@cdepillabout](https://github.com/cdepillabout) +- [@Krasjet](https://github.com/Krasjet) diff --git a/example/Api.hs b/example/Api.hs deleted file mode 100644 --- a/example/Api.hs +++ /dev/null @@ -1,20 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} - -module Api where - -import Servant.API (Get, JSON, (:>), (:<|>)) - -import Servant.RawM (RawM) - -type Api = OtherEndpoint1 :<|> RawEndpoint :<|> OtherEndpoint2 - -type OtherEndpoint1 = "other-endpoint-1" :> Get '[JSON] Int - -type RawEndpoint = "serve-directory" :> RawM - -type OtherEndpoint2 = "other-endpoint-2" :> Get '[JSON] Int - --- | The port to run the server on. -port :: Int -port = 8201 diff --git a/example/Client.hs b/example/Client.hs deleted file mode 100644 --- a/example/Client.hs +++ /dev/null @@ -1,53 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Data.ByteString.Lazy (ByteString) -import qualified Data.ByteString.Lazy as LBS -import Data.Monoid ((<>)) -import Data.Proxy (Proxy(Proxy)) -import Data.Text (Text) -import Network.HTTP.Client (defaultManagerSettings, newManager) -import Network.HTTP.Types (methodGet) -import Servant.API ((:<|>)((:<|>))) -import Servant.Client - (BaseUrl(BaseUrl), ClientM, Response, Scheme(Http), - client, mkClientEnv, responseBody, runClientM) -import Servant.Client.Core (Request, appendToPath, requestMethod) -import Servant.RawM () - -import Api (Api, port) - ------------------------------------------ --- Clients generated by servant-client -- ------------------------------------------ - -otherEndpoint1 :: ClientM Int -getFile' :: (Request -> Request) -> ClientM Response -otherEndpoint2 :: ClientM Int -otherEndpoint1 :<|> getFile' :<|> otherEndpoint2 = client (Proxy :: Proxy Api) - -getFile :: Text -> ClientM ByteString -getFile filePath = do - resp <- - getFile' $ \req -> appendToPath filePath req { requestMethod = methodGet } - pure $ responseBody resp - - ----------- --- Main -- ----------- - -main :: IO () -main = do - manager <- newManager defaultManagerSettings - let clientEnv = mkClientEnv manager baseUrl - eitherRes <- runClientM (getFile "foo.txt") clientEnv - case eitherRes of - Left servantErr -> putStrLn $ "Got a ServantErr: " <> show servantErr - Right fileContents -> do - putStrLn "Successfully got file ./example/files/foo.txt:\n" - LBS.putStr fileContents - -baseUrl :: BaseUrl -baseUrl = BaseUrl Http "localhost" port "" diff --git a/example/Docs.hs b/example/Docs.hs deleted file mode 100644 --- a/example/Docs.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# LANGUAGE ConstraintKinds #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE EmptyCase #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Main where - -import Data.Proxy (Proxy(Proxy)) -import Data.Text (Text) -import Servant.Docs (ToSample(toSamples), docs, markdown) - -import Servant.RawM () - -import Api (Api) - -instance ToSample Int where - toSamples :: Proxy Int -> [(Text, Int)] - toSamples Proxy = [("example Int", 3)] - --- | Print the documentation rendered as markdown to stdout. -main :: IO () -main = putStrLn . markdown $ docs (Proxy :: Proxy Api) diff --git a/example/Server.hs b/example/Server.hs deleted file mode 100644 --- a/example/Server.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE TypeOperators #-} - -module Main where - -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) -import Data.Monoid ((<>)) -import Data.Proxy (Proxy(Proxy)) -import Network.Wai (Application) -import Network.Wai.Handler.Warp (run) -import Servant (Handler, (:<|>)((:<|>)), Server, ServerT, hoistServer, serve) - -import Servant.RawM (serveDirectoryWebApp) - -import Api (Api, port) - -data Config = Config - { configInt1 :: Int - , configInt2 :: Int - , configDir :: FilePath - } deriving Show - -config :: Config -config = Config {configInt1 = 3, configInt2 = 4, configDir = "./example/files"} - -serverRoot :: ServerT Api (ReaderT Config IO) -serverRoot = getOtherEndpoint1 :<|> rawEndpoint :<|> getOtherEndpoint2 - -getOtherEndpoint1 :: ReaderT Config IO Int -getOtherEndpoint1 = do - (Config int1 _ _) <- ask - pure int1 - -rawEndpoint :: ReaderT Config IO Application -rawEndpoint = do - (Config _ _ dir) <- ask - serveDirectoryWebApp dir - -getOtherEndpoint2 :: ReaderT Config IO Int -getOtherEndpoint2 = do - (Config _ int2 _) <- ask - pure int2 - -apiProxy :: Proxy Api -apiProxy = Proxy - -app :: Config -> Application -app conf = serve apiProxy apiServer - where - apiServer :: Server Api - apiServer = hoistServer apiProxy transformation serverRoot - - transformation :: ReaderT Config IO a -> Handler a - transformation readerT = liftIO $ runReaderT readerT conf - --- | Run the WAI 'Application' using 'run' on the port defined by 'port'. -main :: IO () -main = do - putStrLn $ "example RawM server running on port " <> show port - run port $ app config diff --git a/example/files/bar.txt b/example/files/bar.txt deleted file mode 100644 --- a/example/files/bar.txt +++ /dev/null @@ -1,1 +0,0 @@ -This is bar.txt. diff --git a/example/files/foo.txt b/example/files/foo.txt deleted file mode 100644 --- a/example/files/foo.txt +++ /dev/null @@ -1,3 +0,0 @@ -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,147 +1,36 @@ name: servant-rawm -version: 0.3.2.0 +version: 1.0.0.0 synopsis: Embed a raw 'Application' in a Servant API -description: Please see . +description: + Please see . + . + After @servant-rawm@ 1.0.0.0, the implementation are divided into + three packages: @servant-rawm-server@, @servant-rawm-client@, + and @servant-rawm-docs@. + . + You need to use either of the three implementations for the 'RawM' endpoint + to function correctly. homepage: https://github.com/cdepillabout/servant-rawm license: BSD3 license-file: LICENSE author: Dennis Gosnell maintainer: cdep.illabout@gmail.com + , nil.krjst@gmail.com copyright: 2017 Dennis Gosnell -category: Text +category: Servant + , Web build-type: Simple extra-source-files: CHANGELOG.md , README.md - , example/files/bar.txt - , example/files/foo.txt - , stack.yaml cabal-version: >=1.10 -flag buildexample - description: Build a small example program - default: False - library hs-source-dirs: src exposed-modules: Servant.RawM - , Servant.RawM.Internal - , Servant.RawM.Internal.API - , Servant.RawM.Internal.Client - , Servant.RawM.Internal.Docs - , Servant.RawM.Internal.Server build-depends: base >= 4.8 && < 5 - , bytestring >= 0.10 - , filepath >= 1.4 - , http-client >= 0.5 - , http-media >= 0.6 - , http-types >= 0.9 - , lens >= 4.0 - , resourcet >= 1.0 - , servant-client >= 0.16 - , servant-client-core >= 0.16 - , servant-docs >= 0.11.3 - , servant-server >= 0.16 - , wai >= 3.2 - , wai-app-static >= 3.1 + , servant >= 0.16 default-language: Haskell2010 ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -Wmissing-import-lists - - other-extensions: QuasiQuotes - , TemplateHaskell - -executable servant-rawm-example-client - main-is: Client.hs - other-modules: Api - hs-source-dirs: example - build-depends: base - , bytestring - , http-client - , http-media - , http-types - , servant - , servant-rawm - , servant-client - , servant-client-core - , text - default-language: Haskell2010 - ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -Wmissing-import-lists -threaded -rtsopts -with-rtsopts=-N - - if flag(buildexample) - buildable: True - else - buildable: False - -executable servant-rawm-example-docs - main-is: Docs.hs - other-modules: Api - hs-source-dirs: example - build-depends: base - , servant - , servant-rawm - , servant-docs - , text - default-language: Haskell2010 - ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -Wmissing-import-lists -threaded -rtsopts -with-rtsopts=-N - - if flag(buildexample) - buildable: True - else - buildable: False - -executable servant-rawm-example-server - main-is: Server.hs - other-modules: Api - hs-source-dirs: example - build-depends: base - , servant - , servant-rawm - , servant-server - , transformers - , wai - , warp - default-language: Haskell2010 - ghc-options: -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -Wmissing-import-lists -threaded -rtsopts -with-rtsopts=-N - - if flag(buildexample) - buildable: True - 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-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-client-core - , servant-rawm - , servant-server - , tasty - , tasty-hspec >= 0.2 - , tasty-hunit - , text - , 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 @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} +{-# LANGUAGE TypeFamilies #-} {- | Module : Servant.RawM @@ -7,8 +7,9 @@ License : BSD3 Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) + Krasjet (nil.krjst@gmail.com) -This module exposes a 'RawM' type that allows you to embed a WAI +This module defines the '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 @@ -19,6 +20,8 @@ 'RawM': @ + import "Servant.RawM.Server" + type Api = \"serve-directory-example\" :> 'RawM' serverRoot :: 'Servant.Server.ServerT' Api ('Control.Monad.Reader.ReaderT' 'FilePath' 'IO') @@ -27,7 +30,7 @@ rawEndpoint :: 'Control.Monad.Reader.ReaderT' 'FilePath' 'IO' 'Network.Wai.Application' rawEndpoint = do filePath <- 'Control.Monad.Reader.ask' - 'serveDirectoryWebApp' filePath + 'Servant.RawM.Server.serveDirectoryWebApp' filePath apiProxy :: 'Data.Proxy.Proxy' Api apiProxy = 'Data.Proxy.Proxy' @@ -49,7 +52,7 @@ following: @ - type Api\' = \"serve-directory-example\" :> 'Raw' + type Api\' = \"serve-directory-example\" :> 'Servant.API.Raw.Raw' serverRoot\' :: 'Server.ServerT' Api\' ('Control.Monad.Reader.ReaderT' 'FilePath' 'IO') serverRoot\' = rawEndpoint\' @@ -65,23 +68,55 @@ produced monadically. There is an - in -the source code repository that shows a more in-depth server, client, and + +in the source code repository that shows a more in-depth server, client, and documentation. + +After @servant-rawm@ 1.0.0.0, the implementations for 'RawM' server, client, +and documentation generator are divided into three packages: +, +, +and + +to avoid pulling in unnecessary dependencies. This module is re-exported in +"Servant.RawM.Server", "Servant.RawM.Client", and "Servant.RawM.Docs", so you +don't need to import this module explicitly. Import the corresponding +implementation instead. -} -module Servant.RawM - ( +module Servant.RawM ( -- * 'RawM' API parameter RawM , RawM' , FileServer - -- * Helper functions for writing simple file servers - , serveDirectoryWebApp - , serveDirectoryFileServer - , serveDirectoryWebAppLookup - , serveDirectoryEmbedded - , serveDirectoryWith - ) where +) + where -import Servant.RawM.Internal +import Data.Typeable (Typeable) +import Servant.Links (HasLink, MkLink, toLink) + +-- | Specialization of 'RawM'' to 'FileServer'. This can be used if you are +-- using 'Servant.RawM.Server.serveDirectoryWebApp', +-- 'Servant.RawM.Server.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 + +instance HasLink (RawM' st) where + type MkLink (RawM' st) a = a + toLink toA _ = toA + +-- | Used by 'RawM' as a phantom type. +data FileServer deriving Typeable diff --git a/src/Servant/RawM/Internal.hs b/src/Servant/RawM/Internal.hs deleted file mode 100644 --- a/src/Servant/RawM/Internal.hs +++ /dev/null @@ -1,26 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} - -{- | -Module : Servant.RawM.Internal - -Copyright : Dennis Gosnell 2017 -License : BSD3 - -Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) -Stability : experimental -Portability : unknown - -Export all of the instances for the Client, Docs, and Server. --} - -module Servant.RawM.Internal - ( 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 -import Servant.RawM.Internal.Client () -import Servant.RawM.Internal.Docs () -import Servant.RawM.Internal.Server diff --git a/src/Servant/RawM/Internal/API.hs b/src/Servant/RawM/Internal/API.hs deleted file mode 100644 --- a/src/Servant/RawM/Internal/API.hs +++ /dev/null @@ -1,42 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} - -{- | -Module : Servant.RawM.Internal.API - -Copyright : Dennis Gosnell 2017 -License : BSD3 - -Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) - --} - -module Servant.RawM.Internal.API where - -import Data.Typeable (Typeable) -import Servant (HasLink, MkLink, toLink) - --- | 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 - -instance HasLink (RawM' st) where - type MkLink (RawM' st) a = a - toLink toA _ = toA - --- | 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 deleted file mode 100644 --- a/src/Servant/RawM/Internal/Client.hs +++ /dev/null @@ -1,58 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{- | -Module : Servant.RawM.Internal.Client - -Copyright : Dennis Gosnell 2017 -License : BSD3 - -Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) -Stability : experimental -Portability : unknown - -This module only exports a 'HasClient' instance for 'RawM'. --} - -module Servant.RawM.Internal.Client where - -import Data.Proxy (Proxy(Proxy)) -import Servant.Client (Client, HasClient(clientWithRoute, hoistClientMonad)) -import Servant.Client.Core (runRequest, RunClient, Request, Response) -import Servant.RawM.Internal.API (RawM') - --- | Creates a client route like the following: --- --- >>> :set -XTypeOperators --- >>> import Data.Type.Equality ((:~:)(Refl)) --- >>> Refl :: Client m (RawM' a) :~: ((Request -> Request) -> m Response) --- Refl --- --- This allows modification of the underlying 'Request' 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 RunClient m => HasClient m (RawM' serverType) where - type Client m (RawM' serverType) = (Request -> Request) -> m Response - - clientWithRoute - :: Proxy m - -> Proxy (RawM' serverType) - -> Request - -> Client m (RawM' serverType) - clientWithRoute Proxy Proxy req reqFunc = runRequest $ reqFunc req - - hoistClientMonad - :: Proxy m - -> Proxy (RawM' serverType) - -> (forall x. mon x -> mon' x) - -> Client mon (RawM' serverType) - -> Client mon' (RawM' serverType) - hoistClientMonad Proxy Proxy f cl = \meth -> f (cl meth) diff --git a/src/Servant/RawM/Internal/Docs.hs b/src/Servant/RawM/Internal/Docs.hs deleted file mode 100644 --- a/src/Servant/RawM/Internal/Docs.hs +++ /dev/null @@ -1,93 +0,0 @@ -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE NoMonomorphismRestriction #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{- | -Module : Servant.RawM.Internal.Docs - -Copyright : Dennis Gosnell 2017 -License : BSD3 - -Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) -Stability : experimental -Portability : unknown - -This module exports a 'HasDocs' instance for 'RawM'. --} - -module Servant.RawM.Internal.Docs where - -import Control.Lens ((.~), (<>~)) -import Data.Function ((&)) -import Data.Proxy (Proxy(Proxy)) -import Data.Semigroup ((<>)) -import Network.HTTP.Media ((//)) -import Network.HTTP.Types (methodGet) -import Servant.Docs - (Action, API, DocCapture(DocCapture), DocNote(DocNote), DocOptions, - Endpoint, HasDocs(docsFor), captures, defResponse, method, notes, - path, respBody, respStatus, respTypes, response, single) - -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) _ = - let captureSymbol = ":filename" - captureDesc = "the name of the file to GET" - capture = DocCapture captureSymbol captureDesc - htmlMediaType = "text" // "html" - jsMediaType = "application" // "javascript" - possibleRespMediaTypes = - [ jsMediaType - , "application" // "xml" - , "application" // "zip" - , "application" // "pdf" - , "audio" // "mpeg" - , "text" // "css" - , htmlMediaType - , "text" // "csv" - , "text" // "plain" - , "image" // "png" - , "image" // "jpeg" - , "image" // "gif" - ] - sampleHtml = "

Hello World

" - sampleHtmlResp = ("example HTML response", htmlMediaType, sampleHtml) - sampleJs = "alert(\"Hello World\");" - sampleJsResp = ("example JS response", jsMediaType, sampleJs) - noteBody1 = - "This route is a file server. If you specify the filename, it " <> - "will serve up the file with the appropriate content type. If " <> - "the file doesn't exist, it will return a 404." - noteBody2 = - "The supported content types below are just examples. A full " <> - "list of recognized MIME types can be found " <> - "[here](https://hackage.haskell.org/package/mime-types-0.1.0.7/docs/src/Network.Mime.html#defaultMimeMap)." - note = DocNote "File Server" [noteBody1, noteBody2] - resp = - defResponse - & respStatus .~ 200 - & respTypes .~ possibleRespMediaTypes - & respBody .~ [sampleHtmlResp, sampleJsResp] - newEndpoint = - endpoint - & method .~ methodGet - & path <>~ [captureSymbol] - newAction = - action - & captures <>~ [capture] - & notes <>~ [note] - & response .~ resp - in single newEndpoint newAction diff --git a/src/Servant/RawM/Internal/Server.hs b/src/Servant/RawM/Internal/Server.hs deleted file mode 100644 --- a/src/Servant/RawM/Internal/Server.hs +++ /dev/null @@ -1,126 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE InstanceSigs #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -{- | -Module : Servant.RawM.Internal.Server - -Copyright : Dennis Gosnell 2017 -License : BSD3 - -Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) -Stability : experimental -Portability : unknown - -This module exports 'HasServer' instances for 'RawM'', as well as some helper -functions for serving directories of files. --} - -module Servant.RawM.Internal.Server where - -import Control.Monad.IO.Class (liftIO) -import Control.Monad.Trans.Resource (runResourceT) -import Data.ByteString (ByteString) -import Data.Proxy (Proxy(Proxy)) -import Network.Wai - (Application, Request, Response, ResponseReceived) -import Network.Wai.Application.Static - (StaticSettings, defaultFileServerSettings, defaultWebAppSettings, - embeddedSettings, staticApp, webAppSettingsWithLookup) -import Servant (Context, HasServer(route, hoistServerWithContext), Handler, ServerT, runHandler) -import Servant.Server.Internal - (Delayed, Router'(RawRouter), RouteResult(Fail, FailFatal, Route), responseServerError, runDelayed) -import System.FilePath (addTrailingPathSeparator) -import WaiAppStatic.Storage.Filesystem (ETagLookup) - -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 - :: forall env. - Proxy (RawM' serverType) - -> Context context - -> Delayed env (Handler Application) - -> Router' env (Request -> (RouteResult Response -> IO ResponseReceived) -> IO ResponseReceived) - route Proxy _ rawApplication = RawRouter go - where - go - :: env - -> Request - -> (RouteResult Response -> IO ResponseReceived) - -> IO ResponseReceived - go env request respond = - runResourceT $ do - routeRes <- runDelayed rawApplication env request - liftIO $ - case routeRes of - (Fail e) -> respond $ Fail e - (FailFatal e) -> respond $ FailFatal e - (Route handlerApp) -> do - eitherApp <- runHandler handlerApp - case eitherApp of - Left err -> respond . Route $ responseServerError err - Right app -> app request (respond . Route) - hoistServerWithContext - :: Proxy (RawM' serverType) - -> Proxy context - -> (forall x. m x -> n x) - -> m Application - -> n Application - hoistServerWithContext Proxy Proxy f m = f m - --- | Serve anything under the specified directory as a 'RawM'' endpoint. --- --- @ --- type MyApi = "static" :> RawM' --- --- server :: ServerT MyApi m --- server = serveDirectoryWebApp "\/var\/www" --- @ --- --- would capture any request to @\/static\/\@ and look for --- @\@ under @\/var\/www@. --- --- It will do its best to guess the MIME type for that file, based on the extension, --- and send an appropriate /Content-Type/ header if possible. --- --- If your goal is to serve HTML, CSS and Javascript files that use the rest of the API --- as a webapp backend, you will most likely not want the static files to be hidden --- behind a /\/static\// prefix. In that case, remember to put the 'serveDirectoryWebApp' --- handler in the last position, because /servant/ will try to match the handlers --- in order. --- --- Corresponds to the `defaultWebAppSettings` `StaticSettings` value. -serveDirectoryWebApp :: Applicative m => FilePath -> ServerT (RawM' serverType) m -serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . addTrailingPathSeparator - --- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`. -serveDirectoryFileServer :: Applicative m => FilePath -> ServerT (RawM' serverType) m -serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . addTrailingPathSeparator - --- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'. -serveDirectoryWebAppLookup :: Applicative m => ETagLookup -> FilePath -> ServerT (RawM' serverType) m -serveDirectoryWebAppLookup etag = - serveDirectoryWith . flip webAppSettingsWithLookup etag . addTrailingPathSeparator - --- | Uses 'embeddedSettings'. -serveDirectoryEmbedded :: Applicative m => [(FilePath, ByteString)] -> ServerT (RawM' serverType) m -serveDirectoryEmbedded files = serveDirectoryWith (embeddedSettings files) - --- | Alias for 'staticApp'. Lets you serve a directory with arbitrary --- 'StaticSettings'. Useful when you want particular settings not covered by --- the four other variants. This is the most flexible method. -serveDirectoryWith :: Applicative m => StaticSettings -> ServerT (RawM' serverType) m -serveDirectoryWith = pure . staticApp diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 --- a/stack.yaml +++ /dev/null @@ -1,47 +0,0 @@ -# For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration.html - -# Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) -# nightly is used for the servant-0.16 dependencies. When lts-14 is released, this can be updated to -# use that. -resolver: lts-14.3 - -# Local packages, usually specified by relative directory name -packages: -- '.' - -# Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) -extra-deps: [] - -# Override default flag values for local packages and extra-deps -flags: {} - -# Extra package databases containing global packages -extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true - -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: >= 1.0.0 - -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 - -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] - -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor - -# Enable Hackage-friendly mode, for more details see -# https://docs.haskellstack.org/en/stable/yaml_configuration/#pvp-bounds -# This has been disabled because of the following exchange: -# https://github.com/cdepillabout/pretty-simple/pull/1#issuecomment-272706215 -#pvp-bounds: both - -nix: - packages: - - zlib diff --git a/test/DocTest.hs b/test/DocTest.hs deleted file mode 100644 --- a/test/DocTest.hs +++ /dev/null @@ -1,40 +0,0 @@ - -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 deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,170 +0,0 @@ -{-# 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.Text (Text) -import Data.Type.Equality ((:~:)(Refl)) -import Data.Typeable (Typeable) -import Network.HTTP.Client (defaultManagerSettings, newManager) -import Network.HTTP.Types (methodGet) -import Network.Wai (Application) -import Network.Wai.Handler.Warp (run) -import Servant ((:>), Handler, ServerT, hoistServer, serve) -import Servant.Client - (Client, ClientM, Response, client, mkClientEnv, parseBaseUrl, responseBody, runClientM) -import Servant.Client.Core (Request, appendToPath, requestMethod) -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 m RawM :~: ((Request -> Request) -> m Response) -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 = - let proxy = Proxy :: Proxy Api - in - serve proxy $ hoistServer proxy trans server - where - trans :: forall a. 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' - :: (Request -> Request) - -> ClientM Response -getFile' = client (Proxy :: Proxy Api) - -getFile :: Text -> ClientM ByteString -getFile filePath = do - resp <- - getFile' $ \req -> appendToPath filePath req { requestMethod = methodGet } - pure $ responseBody resp - -clientTestsIO :: IO TestTree -clientTestsIO = do - manager <- newManager defaultManagerSettings - baseUrl <- parseBaseUrl $ "http://localhost:" <> show port <> "/" - let clientEnv = mkClientEnv 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