diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,4 @@ + +## 0.1.0.0 + +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Dennis Gosnell (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,10 @@ + +# Servant.RawM + +[![Build Status](https://secure.travis-ci.org/cdepillabout/servant-rawm.svg)](http://travis-ci.org/cdepillabout/servant-rawm) +[![Hackage](https://img.shields.io/hackage/v/servant-rawm.svg)](https://hackage.haskell.org/package/servant-rawm) +[![Stackage LTS](http://stackage.org/package/servant-rawm/badge/lts)](http://stackage.org/lts/package/servant-rawm) +[![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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/example/Api.hs b/example/Api.hs new file mode 100644 --- /dev/null +++ b/example/Api.hs @@ -0,0 +1,20 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/example/Client.hs @@ -0,0 +1,56 @@ +{-# 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 Network.HTTP.Client (Response, defaultManagerSettings, newManager, responseBody) +import Network.HTTP.Media (MediaType) +import Network.HTTP.Types (Header, Method, methodGet) +import Servant.API ((:<|>)((:<|>))) +import Servant.Client + (BaseUrl(BaseUrl), ClientEnv(ClientEnv), ClientM, Scheme(Http), + client, runClientM) +import Servant.Common.Req (Req, appendToPath) + +import Servant.RawM () + +import Api (Api, port) + +----------------------------------------- +-- Clients generated by servant-client -- +----------------------------------------- + +-- We generate the client functions just like normal. Note that when we use +-- 'Throws' or 'NoThrow', the client functions get generated with the +-- 'Envelope' type. + +otherEndpoint1 :: ClientM Int +getFile' :: Method -> (Req -> Req) -> ClientM (Int, ByteString, MediaType, [Header], Response ByteString) +otherEndpoint2 :: ClientM Int +otherEndpoint1 :<|> getFile' :<|> otherEndpoint2 = client (Proxy :: Proxy Api) + +getFile :: String -> ClientM ByteString +getFile filePath = do + (_, _, _, _, resp) <- getFile' methodGet $ \req -> appendToPath filePath req + pure $ responseBody resp + +---------- +-- Main -- +---------- + +main :: IO () +main = do + manager <- newManager defaultManagerSettings + let clientEnv = ClientEnv 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/Server.hs b/example/Server.hs new file mode 100644 --- /dev/null +++ b/example/Server.hs @@ -0,0 +1,61 @@ +{-# 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, serve) +import Servant.Utils.Enter ((:~>)(NT), enter) + +import Servant.RawM (serveDirectoryWebApp) + +import Api (Api, port) + +data Config = Config + { configInt1 :: Int + , configInt2 :: Int + , configDir :: FilePath + } deriving Show + +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 + +app :: Config -> Application +app conf = serve (Proxy :: Proxy Api) apiServer + where + apiServer :: Server Api + apiServer = enter naturalTrans serverRoot + + naturalTrans :: ReaderT Config IO :~> Handler + naturalTrans = NT transformation + + transformation :: ReaderT Config IO a -> Handler a + transformation readerT = liftIO $ runReaderT readerT conf + +config :: Config +config = Config {configInt1 = 3, configInt2 = 4, configDir = "./example/files"} + +-- | 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/servant-rawm.cabal b/servant-rawm.cabal new file mode 100644 --- /dev/null +++ b/servant-rawm.cabal @@ -0,0 +1,138 @@ +name: servant-rawm +version: 0.1.0.0 +synopsis: Embed a raw 'Application' in a Servant API +description: Please see . +homepage: https://github.com/cdepillabout/servant-rawm +license: BSD3 +license-file: LICENSE +author: Dennis Gosnell +maintainer: cdep.illabout@gmail.com +copyright: 2017 Dennis Gosnell +category: Text +build-type: Simple +extra-source-files: CHANGELOG.md + , README.md + , 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 + , resourcet >= 1.0 + , servant >= 0.9 + , servant-client >= 0.9 + , servant-docs >= 0.9 + , servant-server >= 0.9 + , wai >= 3.2 + , wai-app-static >= 3.1 + 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 + , 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 +-- , aeson +-- , http-api-data +-- , 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 +-- , 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 + +source-repository head + type: git + location: git@github.com:cdepillabout/servant-rawm.git diff --git a/src/Servant/RawM.hs b/src/Servant/RawM.hs new file mode 100644 --- /dev/null +++ b/src/Servant/RawM.hs @@ -0,0 +1,25 @@ +{-# OPTIONS_GHC -fno-warn-missing-import-lists #-} + +{- | +Module : Servant.RawM + +Copyright : Dennis Gosnell 2017 +License : BSD3 + +Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) + +-} + +module Servant.RawM + ( + -- * 'RawM' API parameter + RawM + -- * Helper functions for writing simple file servers + , serveDirectoryWebApp + , serveDirectoryFileServer + , serveDirectoryWebAppLookup + , serveDirectoryEmbedded + , serveDirectoryWith + ) where + +import Servant.RawM.Internal diff --git a/src/Servant/RawM/Internal.hs b/src/Servant/RawM/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Servant/RawM/Internal.hs @@ -0,0 +1,23 @@ +{-# 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 X + ) where + +import Servant.RawM.Internal.API as X +import Servant.RawM.Internal.Client () +import Servant.RawM.Internal.Docs () +import Servant.RawM.Internal.Server as X diff --git a/src/Servant/RawM/Internal/API.hs b/src/Servant/RawM/Internal/API.hs new file mode 100644 --- /dev/null +++ b/src/Servant/RawM/Internal/API.hs @@ -0,0 +1,15 @@ +{- | +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) + +data RawM deriving Typeable diff --git a/src/Servant/RawM/Internal/Client.hs b/src/Servant/RawM/Internal/Client.hs new file mode 100644 --- /dev/null +++ b/src/Servant/RawM/Internal/Client.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE InstanceSigs #-} +{-# 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.ByteString.Lazy (ByteString) +import Data.Proxy (Proxy(Proxy)) +import Network.HTTP.Client (Response) +import Network.HTTP.Media (MediaType) +import Network.HTTP.Types (Header, Method) +import Servant.Client (Client, ClientM, HasClient(clientWithRoute)) +import Servant.Common.Req (Req, performRequest) + +import Servant.RawM.Internal.API (RawM) + +instance HasClient RawM where + type Client RawM = Method -> (Req -> Req) -> ClientM (Int, ByteString, MediaType, [Header], Response ByteString) + + clientWithRoute :: Proxy RawM -> Req -> Client RawM + clientWithRoute Proxy req method f = performRequest method $ f req diff --git a/src/Servant/RawM/Internal/Docs.hs b/src/Servant/RawM/Internal/Docs.hs new file mode 100644 --- /dev/null +++ b/src/Servant/RawM/Internal/Docs.hs @@ -0,0 +1,150 @@ +{-# 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 Data.Proxy (Proxy(Proxy)) +-- import Data.ByteString.Lazy (ByteString) +-- import Data.Function ((&)) +-- import Data.Monoid ((<>)) +-- import Data.Text (Text) +-- import Network.HTTP.Media (MediaType) +-- import Servant.API (Verb, (:>)) +-- import Servant.API.ContentTypes (AllMimeRender(allMimeRender)) +-- import Servant.Docs +-- (Action, API, DocOptions, Endpoint, HasDocs(docsFor), +-- ToSample(toSamples)) +-- import Servant.Docs.Internal (apiEndpoints, respBody, response) + +-- import Servant.RawM.Internal.Envelope +-- (Envelope, toErrEnvelope, toSuccEnvelope) +-- import Servant.RawM.Internal.Prism ((<>~)) +-- import Servant.RawM.Internal.Servant.API +-- (NoThrow, Throws, Throwing) +-- import Servant.RawM.Internal.Util (Snoc) + +-- -- TODO: Make sure to also account for when headers are being used. + +-- -- | Change a 'Throws' into 'Throwing'. +-- instance (HasDocs (Throwing '[e] :> api)) => HasDocs (Throws e :> api) where +-- docsFor +-- :: Proxy (Throws e :> api) +-- -> (Endpoint, Action) +-- -> DocOptions +-- -> API +-- docsFor Proxy = docsFor (Proxy :: Proxy (Throwing '[e] :> api)) + +-- -- | When @'Throwing' es@ comes before a 'Verb', generate the documentation for +-- -- the same 'Verb', but returning an @'Envelope' es@. Also add documentation +-- -- for the potential @es@. +-- instance +-- ( CreateRespBodiesFor es ctypes +-- , HasDocs (Verb method status ctypes (Envelope es a)) +-- ) +-- => HasDocs (Throwing es :> Verb method status ctypes a) where +-- docsFor +-- :: Proxy (Throwing es :> Verb method status ctypes a) +-- -> (Endpoint, Action) +-- -> DocOptions +-- -> API +-- docsFor Proxy (endpoint, action) docOpts = +-- let api = +-- docsFor +-- (Proxy :: Proxy (Verb method status ctypes (Envelope es a))) +-- (endpoint, action) +-- docOpts +-- in api & apiEndpoints . traverse . response . respBody <>~ +-- createRespBodiesFor (Proxy :: Proxy es) (Proxy :: Proxy ctypes) + +-- -- | When 'NoThrow' comes before a 'Verb', generate the documentation for +-- -- the same 'Verb', but returning an @'Envelope' \'[]@. +-- instance (HasDocs (Verb method status ctypes (Envelope '[] a))) +-- => HasDocs (NoThrow :> Verb method status ctypes a) where +-- docsFor +-- :: Proxy (NoThrow :> Verb method status ctypes a) +-- -> (Endpoint, Action) +-- -> DocOptions +-- -> API +-- docsFor Proxy (endpoint, action) docOpts = +-- docsFor +-- (Proxy :: Proxy (Verb method status ctypes (Envelope '[] a))) +-- (endpoint, action) +-- docOpts + +-- -- | Create samples for a given @list@ of types, under given @ctypes@. +-- -- +-- -- Additional instances of this class should not need to be created. +-- class CreateRespBodiesFor list ctypes where +-- createRespBodiesFor +-- :: Proxy list +-- -> Proxy ctypes +-- -> [(Text, MediaType, ByteString)] + +-- -- | An empty list of types has no samples. +-- instance CreateRespBodiesFor '[] ctypes where +-- createRespBodiesFor +-- :: Proxy '[] +-- -> Proxy ctypes +-- -> [(Text, MediaType, ByteString)] +-- createRespBodiesFor Proxy Proxy = [] + +-- -- | Create a response body for each of the error types. +-- instance +-- ( AllMimeRender ctypes (Envelope '[e] ()) +-- , CreateRespBodiesFor es ctypes +-- , ToSample e +-- ) +-- => CreateRespBodiesFor (e ': es) ctypes where +-- createRespBodiesFor +-- :: Proxy (e ': es) +-- -> Proxy ctypes +-- -> [(Text, MediaType, ByteString)] +-- createRespBodiesFor Proxy ctypes = +-- createRespBodyFor (Proxy :: Proxy e) ctypes <> +-- createRespBodiesFor (Proxy :: Proxy es) ctypes + +-- -- | Create a sample for a given @e@ under given @ctypes@. +-- createRespBodyFor +-- :: forall e ctypes. +-- (AllMimeRender ctypes (Envelope '[e] ()), ToSample e) +-- => Proxy e -> Proxy ctypes -> [(Text, MediaType, ByteString)] +-- createRespBodyFor Proxy ctypes = concatMap enc samples +-- where +-- samples :: [(Text, Envelope '[e] ())] +-- samples = fmap toErrEnvelope <$> toSamples (Proxy :: Proxy e) + +-- enc :: (Text, Envelope '[e] ()) -> [(Text, MediaType, ByteString)] +-- enc (t, s) = uncurry (t,,) <$> allMimeRender ctypes s + +-- -- | When a @'Throws' e@ comes immediately after a @'Throwing' es@, 'Snoc' the +-- -- @e@ onto the @es@. +-- instance (HasDocs (Throwing (Snoc es e) :> api)) => +-- HasDocs (Throwing es :> Throws e :> api) where +-- docsFor +-- :: Proxy (Throwing es :> Throws e :> api) +-- -> (Endpoint, Action) +-- -> DocOptions +-- -> API +-- docsFor Proxy = +-- docsFor (Proxy :: Proxy (Throwing (Snoc es e) :> api)) + +-- -- | We can generate a sample of an @'Envelope' es a@ as long as there is a way +-- -- to generate a sample of the @a@. +-- -- +-- -- This doesn't need to worry about generating a sample of @es@, because that is +-- -- taken care of in the 'HasDocs' instance for @'Throwing' es@. +-- instance ToSample a => ToSample (Envelope es a) where +-- toSamples :: Proxy (Envelope es a) -> [(Text, Envelope es a)] +-- toSamples Proxy = fmap toSuccEnvelope <$> toSamples (Proxy :: Proxy a) diff --git a/src/Servant/RawM/Internal/Server.hs b/src/Servant/RawM/Internal/Server.hs new file mode 100644 --- /dev/null +++ b/src/Servant/RawM/Internal/Server.hs @@ -0,0 +1,114 @@ +{-# 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), Handler, ServerT, runHandler) +import Servant.Server.Internal + (Delayed, Router'(RawRouter), RouteResult(Fail, FailFatal, Route), responseServantErr, + runDelayed) +import System.FilePath (addTrailingPathSeparator) +import WaiAppStatic.Storage.Filesystem (ETagLookup) + +import Servant.RawM.Internal.API (RawM) + +instance HasServer RawM context where + type ServerT RawM m = m Application + route + :: forall env. + Proxy RawM + -> 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 $ responseServantErr err + Right app -> app request (respond . Route) + + +-- | 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 m +serveDirectoryWebApp = serveDirectoryWith . defaultWebAppSettings . addTrailingPathSeparator + +-- | Same as 'serveDirectoryWebApp', but uses `defaultFileServerSettings`. +serveDirectoryFileServer :: Applicative m => FilePath -> ServerT RawM m +serveDirectoryFileServer = serveDirectoryWith . defaultFileServerSettings . addTrailingPathSeparator + +-- | Same as 'serveDirectoryWebApp', but uses 'webAppSettingsWithLookup'. +serveDirectoryWebAppLookup :: Applicative m => ETagLookup -> FilePath -> ServerT RawM m +serveDirectoryWebAppLookup etag = + serveDirectoryWith . flip webAppSettingsWithLookup etag . addTrailingPathSeparator + +-- | Uses 'embeddedSettings'. +serveDirectoryEmbedded :: Applicative m => [(FilePath, ByteString)] -> ServerT RawM 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 m +serveDirectoryWith = pure . staticApp diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,41 @@ +# 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) +resolver: lts-9.2 + +# 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