diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,12 @@ +## 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)! + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Dennis Gosnell (c) 2017-2020 + +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,20 @@ +# Servant.RawM.Server + +[![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-server.svg)](https://hackage.haskell.org/package/servant-rawm-server) +[![Stackage LTS](http://stackage.org/package/servant-rawm-server/badge/lts)](http://stackage.org/lts/package/servant-rawm-server) +[![Stackage Nightly](http://stackage.org/package/servant-rawm-server/badge/nightly)](http://stackage.org/nightly/package/servant-rawm-server) +![BSD3 license](https://img.shields.io/badge/license-BSD3-blue.svg) + +This is the server-side library for +[`servant-rawm`](https://github.com/cdepillabout/servant-rawm). + +See the `servant-rawm` +[`README.md`](https://github.com/cdepillabout/servant-rawm) and +[Haddocks](side://hackage.haskell.org/package/servant-rawm) +for a short explanation of how to use this package. + +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. diff --git a/servant-rawm-server.cabal b/servant-rawm-server.cabal new file mode 100644 --- /dev/null +++ b/servant-rawm-server.cabal @@ -0,0 +1,48 @@ +name: servant-rawm-server +version: 1.0.0.0 +synopsis: The server implementation of servant-rawm. +description: Please see . +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: Servant + , Web +build-type: Simple +extra-source-files: CHANGELOG.md + , README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Servant.RawM.Server + build-depends: base >= 4.8 && < 5 + , bytestring >= 0.10 + , filepath >= 1.4 + , servant-rawm + , servant-server >= 0.16 + , resourcet >= 1.0 + , 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 + +-- TODO: These doctests need to be moved to cabal-doctest, since just using +-- doctest directly is not reliable. +-- test-suite servant-rawm-server-doctest +-- type: exitcode-stdio-1.0 +-- main-is: DocTest.hs +-- hs-source-dirs: test +-- build-depends: base +-- , doctest +-- , Glob +-- , servant-server +-- default-language: Haskell2010 +-- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + +source-repository head + type: git + location: git@github.com:cdepillabout/servant-rawm.git diff --git a/src/Servant/RawM/Server.hs b/src/Servant/RawM/Server.hs new file mode 100644 --- /dev/null +++ b/src/Servant/RawM/Server.hs @@ -0,0 +1,143 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +{- | +Module : Servant.RawM.Server + +Copyright : Dennis Gosnell 2017 +License : BSD3 + +Maintainer : Dennis Gosnell (cdep.illabout@gmail.com) + Krasjet (nil.krjst@gmail.com) +Stability : experimental +Portability : unknown + +This module exports 'HasServer' instances for 'RawM'', as well as some helper +functions for serving directories of files. It provides the server +implementation for the 'RawM' endpoint. +-} + +module Servant.RawM.Server ( + -- * Reexport RawM API + module Servant.RawM, + -- * Helper functions for writing simple file servers + serveDirectoryWebApp, + serveDirectoryFileServer, + serveDirectoryWebAppLookup, + serveDirectoryEmbedded, + serveDirectoryWith +) + 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, Handler, HasServer (hoistServerWithContext, route), + ServerT, runHandler) +import Servant.Server.Internal (Delayed, + RouteResult (Fail, FailFatal, Route), + Router' (RawRouter), + responseServerError, runDelayed) +import System.FilePath (addTrailingPathSeparator) +import WaiAppStatic.Storage.Filesystem (ETagLookup) + +import Servant.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