diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml new file mode 100644 index 0000000..196274b --- /dev/null +++ b/.github/workflows/haskell-ci.yml @@ -0,0 +1,206 @@ +# This GitHub workflow config has been generated by a script via +# +# haskell-ci 'github' 'unliftio-servant-server.cabal' +# +# To regenerate the script (for example after adjusting tested-with) run +# +# haskell-ci regenerate +# +# For more information, see https://github.com/haskell-CI/haskell-ci +# +# version: 0.16.6 +# +# REGENDATA ("0.16.6",["github","unliftio-servant-server.cabal"]) +# +name: Haskell-CI +on: + - push + - pull_request +jobs: + linux: + name: Haskell-CI - Linux - ${{ matrix.compiler }} + runs-on: ubuntu-20.04 + timeout-minutes: + 60 + container: + image: buildpack-deps:bionic + continue-on-error: ${{ matrix.allow-failure }} + strategy: + matrix: + include: + - compiler: ghc-9.6.2 + compilerKind: ghc + compilerVersion: 9.6.2 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.4.5 + compilerKind: ghc + compilerVersion: 9.4.5 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.2.7 + compilerKind: ghc + compilerVersion: 9.2.7 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.0.2 + compilerKind: ghc + compilerVersion: 9.0.2 + setup-method: ghcup + allow-failure: false + - compiler: ghc-8.10.7 + compilerKind: ghc + compilerVersion: 8.10.7 + setup-method: ghcup + allow-failure: false + fail-fast: false + steps: + - name: apt + run: | + apt-get update + apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.19.2/x86_64-linux-ghcup-0.1.19.2 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" || (cat "$HOME"/.ghcup/logs/*.* && false) + "$HOME/.ghcup/bin/ghcup" install cabal 3.10.1.0 || (cat "$HOME"/.ghcup/logs/*.* && false) + env: + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} + - name: Set PATH and environment variables + run: | + echo "$HOME/.cabal/bin" >> $GITHUB_PATH + echo "LANG=C.UTF-8" >> "$GITHUB_ENV" + echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" + echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" + HCDIR=/opt/$HCKIND/$HCVER + HC=$HOME/.ghcup/bin/$HCKIND-$HCVER + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" + echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.10.1.0 -vnormal+nowrap" >> "$GITHUB_ENV" + HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') + echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" + echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" + echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" + echo "HEADHACKAGE=false" >> "$GITHUB_ENV" + echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" + echo "GHCJSARITH=0" >> "$GITHUB_ENV" + env: + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} + - name: env + run: | + env + - name: write cabal config + run: | + mkdir -p $CABAL_DIR + cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz + echo 'f62ccb2971567a5f638f2005ad3173dba14693a45154c1508645c52289714cb2 cabal-plan.xz' | sha256sum -c - + xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan + rm -f cabal-plan.xz + chmod a+x $HOME/.cabal/bin/cabal-plan + cabal-plan --version + - name: checkout + uses: actions/checkout@v3 + with: + path: source + - name: initial cabal.project for sdist + run: | + touch cabal.project + echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project + cat cabal.project + - name: sdist + run: | + mkdir -p sdist + $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist + - name: unpack + run: | + mkdir -p unpacked + find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; + - name: generate cabal.project + run: | + PKGDIR_unliftio_servant_server="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/unliftio-servant-server-[0-9.]*')" + echo "PKGDIR_unliftio_servant_server=${PKGDIR_unliftio_servant_server}" >> "$GITHUB_ENV" + rm -f cabal.project cabal.project.local + touch cabal.project + touch cabal.project.local + echo "packages: ${PKGDIR_unliftio_servant_server}" >> cabal.project + echo "package unliftio-servant-server" >> cabal.project + echo " ghc-options: -Werror=missing-methods" >> cabal.project + cat >> cabal.project <> cabal.project.local + cat cabal.project + cat cabal.project.local + - name: dump install plan + run: | + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all + cabal-plan + - name: restore cache + uses: actions/cache/restore@v3 + with: + key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} + path: ~/.cabal/store + restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- + - name: install dependencies + run: | + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all + - name: build w/o tests + run: | + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all + - name: build + run: | + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always + - name: cabal check + run: | + cd ${PKGDIR_unliftio_servant_server} || false + ${CABAL} -vnormal check + - name: haddock + run: | + $CABAL v2-haddock --disable-documentation --haddock-all $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all + - name: unconstrained build + run: | + rm -f cabal.project.local + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all + - name: save cache + uses: actions/cache/save@v3 + if: always() + with: + key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} + path: ~/.cabal/store diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..8184986 --- /dev/null +++ b/.gitignore @@ -0,0 +1,4 @@ +.dir-locals.el +dist-newstyle/ +dist/ +result diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 index 0000000..4e1d073 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for servant-activeresource + +## 0.1.0.0 -- unreleased + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 index 0000000..23a76bc --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (C) 2024 Bellroy Pty Ltd + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + +2. 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. + +3. Neither the name of the copyright holder nor the names of its + 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 +HOLDER 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/flake.lock b/flake.lock new file mode 100644 index 0000000..985c419 --- /dev/null +++ b/flake.lock @@ -0,0 +1,95 @@ +{ + "nodes": { + "bellroy-nix-foss": { + "inputs": { + "flake-compat": "flake-compat", + "flake-utils": "flake-utils", + "nixpkgs": "nixpkgs" + }, + "locked": { + "lastModified": 1709697643, + "narHash": "sha256-w3yK1C6/JsBVvZRKnZw4HPBajYWpcA2BR3t13mfALzE=", + "owner": "bellroy", + "repo": "bellroy-nix-foss", + "rev": "1e130e6a80cfc7afc5246bb14c6b090aa06a7af0", + "type": "github" + }, + "original": { + "owner": "bellroy", + "repo": "bellroy-nix-foss", + "type": "github" + } + }, + "flake-compat": { + "flake": false, + "locked": { + "lastModified": 1673956053, + "narHash": "sha256-4gtG9iQuiKITOjNQQeQIpoIB6b16fm+504Ch3sNKLd8=", + "owner": "edolstra", + "repo": "flake-compat", + "rev": "35bb57c0c8d8b62bbfd284272c928ceb64ddbde9", + "type": "github" + }, + "original": { + "owner": "edolstra", + "repo": "flake-compat", + "type": "github" + } + }, + "flake-utils": { + "inputs": { + "systems": "systems" + }, + "locked": { + "lastModified": 1687709756, + "narHash": "sha256-Y5wKlQSkgEK2weWdOu4J3riRd+kV/VCgHsqLNTTWQ/0=", + "owner": "numtide", + "repo": "flake-utils", + "rev": "dbabf0ca0c0c4bce6ea5eaf65af5cb694d2082c7", + "type": "github" + }, + "original": { + "owner": "numtide", + "repo": "flake-utils", + "type": "github" + } + }, + "nixpkgs": { + "locked": { + "lastModified": 1710408871, + "narHash": "sha256-YpSGYZR96I8g5OK/Fdm0O4+mHLen6YPA1cPanqqNqT0=", + "owner": "NixOS", + "repo": "nixpkgs", + "rev": "bd5ddf2c6bfafff031edf80221e1ee94e86ca10a", + "type": "github" + }, + "original": { + "id": "nixpkgs", + "ref": "nixpkgs-unstable", + "type": "indirect" + } + }, + "root": { + "inputs": { + "bellroy-nix-foss": "bellroy-nix-foss" + } + }, + "systems": { + "locked": { + "lastModified": 1681028828, + "narHash": "sha256-Vy1rq5AaRuLzOxct8nz4T6wlgyUR7zLU309k9mBC768=", + "owner": "nix-systems", + "repo": "default", + "rev": "da67096a3b9bf56a91d16901293e51ba5b49a27e", + "type": "github" + }, + "original": { + "owner": "nix-systems", + "repo": "default", + "type": "github" + } + } + }, + "root": "root", + "version": 7 +} diff --git a/flake.nix b/flake.nix new file mode 100644 index 0000000..2e4ba9d --- /dev/null +++ b/flake.nix @@ -0,0 +1,21 @@ +{ + inputs = { + bellroy-nix-foss.url = "github:bellroy/bellroy-nix-foss"; + }; + + outputs = inputs: + inputs.bellroy-nix-foss.lib.haskellProject { + cabalPackages = [ + { + name = "unliftio-servant-server"; + path = ./unliftio-servant-server.nix; + } + ]; + supportedCompilers = [ "ghc810" "ghc90" "ghc92" "ghc94" "ghc96" ]; + defaultCompiler = "ghc92"; + haskellPackagesOverride = { haskellLib, prev, ... }: { + servant = haskellLib.doJailbreak prev.servant; + servant-server = haskellLib.doJailbreak prev.servant-server; + }; + }; +} diff --git a/src/UnliftIO/Servant/Server.hs b/src/UnliftIO/Servant/Server.hs index 849dbd3..4904d3e 100644 --- a/src/UnliftIO/Servant/Server.hs +++ b/src/UnliftIO/Servant/Server.hs @@ -3,7 +3,54 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module UnliftIO.Servant.Server where +-- | +-- +-- Module : UnliftIO.Servant.Server +-- Copyright : (C) 2024 Bellroy Pty Ltd +-- License : BSD-3-Clause +-- Maintainer : Bellroy Tech Team +-- Stability : experimental +-- +-- The functions in this module make it easier to serve a Servant API, +-- when its API endpoints are implemented in a monad that has an +-- 'MonadUnliftIO' instance. Many monad transformers are morally just +-- 'ReaderT' or 'IdentityT' over some kind of base monad, and these +-- monads can be unlifted. +-- +-- This isn't magic—you'll still have to unwrap the outer transformers +-- to get at the returned 'Application'—but for simpler application +-- monads it frees you from fiddling around with rank-2 functions just +-- to serve your API. +-- +-- Example use: +-- +-- @ +-- -- Some kind of Servant API +-- type MyApi = ... :\<|\> ... :\<|\> ... +-- +-- -- API implemented in terms of some application monad, which has a 'MonadUnliftIO' instance. +-- myApi :: ServerT MyApi SomeApplicationMonad +-- myApi = undefined -- details unimportant +-- +-- main :: IO () +-- main = runSomeApplicationMonad $ do +-- app <- 'serve' myApi +-- liftIO $ runEnv 3000 app +-- @ +module UnliftIO.Servant.Server + ( -- * Helpers for traditional-style APIs + serve, + serveExceptT, + serveWithContext, + serveExceptTWithContext, + + -- * Helpers for Generic/records-based APIs + genericServe, + genericServeExceptT, + genericServeWithContext, + genericServeExceptTWithContext, + ) +where import Control.Monad ((>=>)) import Control.Monad.Except (ExceptT, runExceptT, throwError) @@ -14,7 +61,6 @@ import Servant.Server Context, HasServer, ServerContext, - ServerError, ServerT, ) import qualified Servant.Server as Servant @@ -22,6 +68,8 @@ import Servant.Server.Generic (AsServerT) import qualified Servant.Server.Generic as Servant import UnliftIO (MonadUnliftIO (..), liftIO) +-- | Convert a Servant API into an 'Application', by unlifting the +-- monad in which it runs. serve :: (MonadUnliftIO m, HasServer api '[]) => Proxy api -> @@ -29,6 +77,9 @@ serve :: m Application serve proxy = serveWithContext proxy Servant.EmptyContext +-- | Convert a Servant API which uses 'ExceptT' above an unliftable +-- monad, by converting its errors into Servant's +-- 'Servant.ServerError' and returning them to the API caller. serveExceptT :: (MonadUnliftIO m, HasServer api '[]) => Proxy api -> @@ -38,6 +89,7 @@ serveExceptT :: serveExceptT proxy toServerError = serveExceptTWithContext proxy toServerError Servant.EmptyContext +-- | As 'serve', with an additional 'Context' parameter. serveWithContext :: (HasServer api context, ServerContext context, MonadUnliftIO m) => Proxy api -> @@ -48,10 +100,11 @@ serveWithContext proxy context api = withRunInIO $ \runInIO -> pure $ Servant.serveWithContextT proxy context (liftIO . runInIO) api +-- | As 'serveExceptT', with an additional 'Context' parameter. serveExceptTWithContext :: (HasServer api context, ServerContext context, MonadUnliftIO m) => Proxy api -> - (e -> ServerError) -> + (e -> Servant.ServerError) -> Context context -> ServerT api (ExceptT e m) -> m Application @@ -66,6 +119,9 @@ serveExceptTWithContext proxy toServerError context api = ) api +-- | As 'serve', but for Servant's generic records. +-- +-- /See:/ "Servant.API.Generic" genericServe :: ( GenericServant routes (AsServerT m), GenericServant routes AsApi, @@ -78,6 +134,9 @@ genericServe :: genericServe routes = withRunInIO $ \runInIO -> pure $ Servant.genericServeT (liftIO . runInIO) routes +-- | As 'genericServe', but for when you have an 'ExceptT' above the +-- unliftable monad. As with 'serveExceptT', errors are returned to +-- the API caller. genericServeExceptT :: ( GenericServant routes (AsServerT (ExceptT e m)), GenericServant routes AsApi, @@ -86,12 +145,13 @@ genericServeExceptT :: ~ ToServant routes (AsServerT (ExceptT e m)), MonadUnliftIO m ) => - (e -> ServerError) -> + (e -> Servant.ServerError) -> routes (AsServerT (ExceptT e m)) -> m Application genericServeExceptT toServerError routes = genericServeExceptTWithContext toServerError routes Servant.EmptyContext +-- | As 'genericServe', but with an additional 'Context' parameter. genericServeWithContext :: ( GenericServant routes (AsServerT m), GenericServant routes AsApi, @@ -106,6 +166,7 @@ genericServeWithContext :: genericServeWithContext routes context = withRunInIO $ \runInIO -> pure $ Servant.genericServeTWithContext (liftIO . runInIO) routes context +-- | As 'genericServeExceptT', but with an additional 'Context' parameter. genericServeExceptTWithContext :: ( GenericServant routes (AsServerT (ExceptT e m)), GenericServant routes AsApi, @@ -115,7 +176,7 @@ genericServeExceptTWithContext :: ~ ToServant routes (AsServerT (ExceptT e m)), MonadUnliftIO m ) => - (e -> ServerError) -> + (e -> Servant.ServerError) -> routes (AsServerT (ExceptT e m)) -> Context context -> m Application diff --git a/unliftio-servant-server.cabal b/unliftio-servant-server.cabal index 259b1ef..0a8c968 100644 --- a/unliftio-servant-server.cabal +++ b/unliftio-servant-server.cabal @@ -1,17 +1,23 @@ cabal-version: 3.0 name: unliftio-servant-server version: 0.1.0.0 -category: lib +synopsis: Use MonadUnliftIO on servant APIs +description: + unliftio-servant-server provides convenience functions for running + servant APIs whose monads have a 'MonadUnliftIO' instance. +category: Servant, Server homepage: https://github.com/bellroy/haskell/tree/master/lib/unliftio-servant-server bug-reports: https://github.com/bellroy/haskell/issues -author: Bellroy -maintainer: geeks@bellroy.com -copyright: Bellroy -license: +author: Bellroy Tech Team +maintainer: Bellroy Tech Team +copyright: Copyright (C) 2024 Bellroy Pty Ltd +license: BSD-3-Clause +license-file: LICENSE build-type: Simple -extra-source-files: README.md +extra-doc-files: CHANGELOG.md README.md +tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.7 || ==9.4.5 || ==9.6.2 source-repository head type: git @@ -31,10 +37,10 @@ common opts-exe common deps build-depends: - , base ^>=4.17 - , mtl ^>=2.2.2 - , servant ^>=0.20 - , servant-server ^>=0.20 + , base >=4.14 && <4.19 + , mtl >=2.2.2 && <2.4 + , servant >=0.19 && <0.21 + , servant-server >=0.19 && <0.21 , unliftio >=0.1.0.0 && <0.3.0.0 library diff --git a/unliftio-servant-server.nix b/unliftio-servant-server.nix new file mode 100644 index 0000000..b2acb01 --- /dev/null +++ b/unliftio-servant-server.nix @@ -0,0 +1,12 @@ +{ mkDerivation, base, lib, mtl, servant, servant-server, unliftio +}: +mkDerivation { + pname = "unliftio-servant-server"; + version = "0.1.0.0"; + src = ./.; + libraryHaskellDepends = [ + base mtl servant servant-server unliftio + ]; + homepage = "https://github.com/bellroy/haskell/tree/master/lib/unliftio-servant-server"; + license = lib.licenses.bsd3; +}