├── Setup.hs ├── ChangeLog.md ├── README.md ├── servant-flatten.cabal ├── LICENSE ├── .travis.yml └── src └── Servant └── API └── Flatten.hs /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /ChangeLog.md: -------------------------------------------------------------------------------- 1 | # Revision history for servant-flatten 2 | 3 | ## 0.1 -- 2017-03-16 4 | 5 | * First version. 6 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # servant-flatten 2 | 3 | Utilities for flattening servant API types 4 | 5 | The main function from this library is: 6 | 7 | ``` haskell 8 | flatten :: Proxy api -> Proxy (Flat api) 9 | ``` 10 | 11 | Its purpose is to "flatten" an API type, by distributing 12 | any factored combinators, so as to end up with completely 13 | flat endpoint descriptions, separated by `:<|>`s. 14 | 15 | For example, it turns: 16 | 17 | ``` haskell 18 | type API = Capture "foo" Int :> 19 | ( Capture "bar" String :> 20 | ( Get '[JSON] String :<|> 21 | ReqBody '[JSON] Int :> Post '[JSON] Int 22 | ) :<|> 23 | Get '[JSON] Int 24 | ) :<|> 25 | Get '[JSON] [String] 26 | ``` 27 | 28 | into: 29 | 30 | ``` haskell 31 | Capture "foo" Int :> Capture "bar" String :> Get '[JSON] String :<|> 32 | Capture "foo" Int :> Capture "bar" String :> ReqBody '[JSON] Int :> Post '[JSON] Int :<|> 33 | Capture "foo" Int :> Get '[JSON] Int :<|> 34 | Get '[JSON] [String] 35 | ``` 36 | 37 | See the documentation of `flatten` in `Servant.API.Flatten` 38 | for more. 39 | -------------------------------------------------------------------------------- /servant-flatten.cabal: -------------------------------------------------------------------------------- 1 | name: servant-flatten 2 | version: 0.2 3 | synopsis: Utilities for flattening servant API types 4 | description: Utilities for flattening servant API types 5 | . 6 | See the documentation of @'Servant.API.Flatten.flatten'@. 7 | homepage: https://github.com/alpmestan/servant-flatten 8 | bug-reports: http://github.com/alpmestan/servant-flatten/issues 9 | license: BSD3 10 | license-file: LICENSE 11 | author: Alp Mestanogullari 12 | maintainer: alpmestan@gmail.com 13 | copyright: 2018 Alp Mestanogullari, Julian Arni 14 | category: Web 15 | build-type: Simple 16 | extra-source-files: ChangeLog.md, README.md 17 | cabal-version: >=1.10 18 | tested-with: GHC == 8.0.2, GHC == 8.2.2 19 | 20 | source-repository head 21 | type: git 22 | location: https://github.com/alpmestan/servant-flatten.git 23 | 24 | library 25 | exposed-modules: Servant.API.Flatten 26 | other-extensions: DataKinds, PolyKinds, TypeFamilies, TypeOperators, 27 | FlexibleContexts, UndecidableInstances 28 | build-depends: base >=4.8 && <5, servant >= 0.8 29 | hs-source-dirs: src 30 | default-language: Haskell2010 31 | ghc-options: -Wall 32 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018, Alp Mestanogullari 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Alp Mestanogullari nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # This Travis job script has been generated by a script via 2 | # 3 | # runghc make_travis_yml_2.hs './servant-flatten.cabal' 4 | # 5 | # For more information, see https://github.com/hvr/multi-ghc-travis 6 | # 7 | language: c 8 | sudo: false 9 | 10 | git: 11 | submodules: false # whether to recursively clone submodules 12 | 13 | cache: 14 | directories: 15 | - $HOME/.cabal/packages 16 | - $HOME/.cabal/store 17 | 18 | before_cache: 19 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log 20 | # remove files that are regenerated by 'cabal update' 21 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.* 22 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/*.json 23 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.cache 24 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar 25 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/01-index.tar.idx 26 | 27 | - rm -rfv $HOME/.cabal/packages/head.hackage 28 | 29 | matrix: 30 | include: 31 | - compiler: "ghc-8.0.2" 32 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 33 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.0.2], sources: [hvr-ghc]}} 34 | - compiler: "ghc-8.2.2" 35 | # env: TEST=--disable-tests BENCH=--disable-benchmarks 36 | addons: {apt: {packages: [ghc-ppa-tools,cabal-install-head,ghc-8.2.2], sources: [hvr-ghc]}} 37 | 38 | before_install: 39 | - HC=${CC} 40 | - HCPKG=${HC/ghc/ghc-pkg} 41 | - unset CC 42 | - ROOTDIR=$(pwd) 43 | - mkdir -p $HOME/.local/bin 44 | - "PATH=/opt/ghc/bin:/opt/ghc-ppa-tools/bin:$HOME/local/bin:$PATH" 45 | - HCNUMVER=$(( $(${HC} --numeric-version|sed -E 's/([0-9]+)\.([0-9]+)\.([0-9]+).*/\1 * 10000 + \2 * 100 + \3/') )) 46 | - echo $HCNUMVER 47 | 48 | install: 49 | - cabal --version 50 | - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" 51 | - BENCH=${BENCH---enable-benchmarks} 52 | - TEST=${TEST---enable-tests} 53 | - HADDOCK=${HADDOCK-true} 54 | - INSTALLED=${INSTALLED-true} 55 | - GHCHEAD=${GHCHEAD-false} 56 | - travis_retry cabal update -v 57 | - "sed -i.bak 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config" 58 | - rm -fv cabal.project cabal.project.local 59 | - grep -Ev -- '^\s*--' ${HOME}/.cabal/config | grep -Ev '^\s*$' 60 | - "printf 'packages: \".\"\\n' > cabal.project" 61 | - cat cabal.project 62 | - if [ -f "./configure.ac" ]; then 63 | (cd "." && autoreconf -i); 64 | fi 65 | - rm -f cabal.project.freeze 66 | - cabal new-build -w ${HC} ${TEST} ${BENCH} --project-file="cabal.project" --dep -j2 all 67 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks --project-file="cabal.project" --dep -j2 all 68 | - rm -rf .ghc.environment.* "."/dist 69 | - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) 70 | 71 | # Here starts the actual work to be performed for the package under test; 72 | # any command which exits with a non-zero exit code causes the build to fail. 73 | script: 74 | # test that source-distributions can be generated 75 | - (cd "." && cabal sdist) 76 | - mv "."/dist/servant-flatten-*.tar.gz ${DISTDIR}/ 77 | - cd ${DISTDIR} || false 78 | - find . -maxdepth 1 -name '*.tar.gz' -exec tar -xvf '{}' \; 79 | - "printf 'packages: servant-flatten-*/*.cabal\\n' > cabal.project" 80 | - cat cabal.project 81 | # this builds all libraries and executables (without tests/benchmarks) 82 | - cabal new-build -w ${HC} --disable-tests --disable-benchmarks all 83 | 84 | # Build with installed constraints for packages in global-db 85 | - if $INSTALLED; then echo cabal new-build -w ${HC} --disable-tests --disable-benchmarks $(${HCPKG} list --global --simple-output --names-only | sed 's/\([a-zA-Z0-9-]\{1,\}\) */--constraint="\1 installed" /g') all | sh; else echo "Not building with installed constraints"; fi 86 | 87 | # build & run tests, build benchmarks 88 | - cabal new-build -w ${HC} ${TEST} ${BENCH} all 89 | 90 | # cabal check 91 | - (cd servant-flatten-* && cabal check) 92 | 93 | # haddock 94 | - rm -rf ./dist-newstyle 95 | - if $HADDOCK; then cabal new-haddock -w ${HC} ${TEST} ${BENCH} all; else echo "Skipping haddock generation";fi 96 | 97 | # REGENDATA ["./servant-flatten.cabal"] 98 | # EOF 99 | -------------------------------------------------------------------------------- /src/Servant/API/Flatten.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE PolyKinds #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE UndecidableInstances #-} 7 | module Servant.API.Flatten where 8 | 9 | import Data.Proxy 10 | import GHC.TypeLits 11 | import Servant.API 12 | 13 | -- | Flatten (a 'Proxy' to) an API type. 14 | -- 15 | -- This performs a number of transformations on the API type so 16 | -- as to end up with all combinators distributed over endpoints. 17 | -- For example, the following API type: 18 | -- 19 | -- @ 20 | -- type API = 'Capture' "foo" 'Int' ':>' 21 | -- ( 'Capture' "bar" 'String' ':>' 22 | -- ( 'Get' '['JSON'] 'String' ':<|>' 23 | -- 'ReqBody' '['JSON'] 'Int' ':>' 'Post' '['JSON'] 'Int' 24 | -- ) ':<|>' 25 | -- 'Get' '['JSON'] 'Int' 26 | -- ) ':<|>' 27 | -- 'Get' '['JSON'] ['String'] 28 | -- @ 29 | -- 30 | -- gets transformed into: 31 | -- 32 | -- @ 33 | -- 'Capture' "foo" 'Int' ':>' 'Capture' "bar" 'String' ':>' 'Get' '['JSON'] 'String' ':<|>' 34 | -- 'Capture' "foo" 'Int' ':>' 'Capture' "bar" 'String' ':>' 'ReqBody' '[JSON] 'Int' ':>' 'Post' '['JSON'] 'Int' ':<|>' 35 | -- 'Capture' "foo" 'Int' ':>' 'Get' '['JSON'] 'Int' ':<|>' 36 | -- 'Get' '['JSON'] ['String'] 37 | -- @ 38 | -- 39 | -- The main point of doing this is to avoid \"nested types\" for server-side handlers 40 | -- and client functions. See 41 | -- (particularly the notes on @FactoringAPI@) for more about \"nested types\". 42 | -- 43 | -- To derive \"flat\" client functions for the API type above, @API@, you can do: 44 | -- 45 | -- @ 46 | -- getfoobar ':<|>' postfoobar ':<|>' getfoo ':<|>' getstrings 47 | -- = 'client' $ 'flatten' ('Proxy' :: 'Proxy' API) 48 | -- @ 49 | -- 50 | -- To serve an implementation for that API with \"flat\" handler types, you can do: 51 | -- 52 | -- @ 53 | -- -- we define all our handlers assuming all the arguments are distributed, 54 | -- -- and declare that this is an implementation for @Flat API@, not @API@. 55 | -- server :: Server ('Flat' API) 56 | -- server = (\foo bar -> return $ show (foo + bar)) 57 | -- ':<|>' (\foo bar body -> return $ show (foo + bar - body^2)) 58 | -- ':<|>' (\foo -> return (foo * 2)) 59 | -- ':<|>' (return ["hello", "world"]) 60 | -- 61 | -- api :: 'Proxy' API 62 | -- api = 'Proxy' 63 | -- 64 | -- main :: 'IO' () 65 | -- main = Network.Wai.Handler.Warp.run 8080 $ 66 | -- serve ('flatten' api) server 67 | -- @ 68 | flatten :: Proxy api -> Proxy (Flat api) 69 | flatten Proxy = Proxy 70 | 71 | -- | Flatten and transform the API type a little bit. 72 | type Flat api = Reassoc (Flatten api) 73 | -- looks like Flatten/Reassoc are missing some opportunities the first time, 74 | -- so we apply them twice for now... 75 | 76 | -- | Completely flattens an API type by applying a few simple transformations. 77 | -- The goal is to end up with an API type where things like @a ':>' (b ':<|>' c)@ 78 | -- are rewritten to @a ':>' b ':<|>' a ':>' c@, so as to have client with very simple 79 | -- types, instead of "nested clients". 80 | type family Flatten (api :: k) :: k where 81 | Flatten ((a :: k) :> (b :<|> c)) = Flatten (a :> b) :<|> Flatten (a :> c) 82 | Flatten ((a :: k) :> b) = Redex b (Flatten b) a 83 | Flatten (a :<|> b) = Flatten a :<|> Flatten b 84 | Flatten (a :: k) = a 85 | 86 | type family Redex a b (c :: k) :: * where 87 | Redex a a first = Flatten first :> a 88 | Redex a b first = Flatten (first :> b) 89 | 90 | -- | Reassociates ':<|>' to the right. 91 | type Reassoc api = ReassocBranch api '[] 92 | 93 | -- | Helper type family that "enumerates" the different endpoints left 94 | -- to right. 95 | type family ReassocBranch (currentAPI :: *) (otherEndpoints :: [*]) where 96 | ReassocBranch (a :<|> b) rest = ReassocBranch a (b ': rest) 97 | ReassocBranch a '[] = a 98 | ReassocBranch a (b ': rest) = a :<|> ReassocBranch b rest 99 | 100 | -- * Utilities that we can define on a flat representation 101 | 102 | -- | Get the endpoints with given indices in the all-flat 103 | -- representation of the API type, glueing them together 104 | -- with ':<|>'. 105 | type family Nths (idxs :: [Nat]) api where 106 | Nths '[i] api = Nth i api 107 | Nths (i ': is) api = Nth i api :<|> Nths is api 108 | 109 | -- | Get the endpoint with given index in the all-flat representation 110 | -- of the API type. 111 | type family Nth (i :: Nat) api where 112 | Nth 0 (a :<|> b) = a 113 | Nth 0 a = a 114 | Nth n (a :<|> b) = Nth (n - 1) b 115 | --------------------------------------------------------------------------------