├── .github └── workflows │ └── haskell-ci.yml ├── .gitignore ├── .travis.yml ├── LICENSE ├── Readme.md ├── Setup.hs ├── devEnv.sh ├── examples └── central-counter │ ├── LICENSE │ ├── README.md │ ├── central-counter.cabal │ ├── default.nix │ ├── devEnv.sh │ ├── frontend │ ├── .gitignore │ ├── bower.json │ ├── dist │ │ ├── app.css │ │ └── index.html │ ├── package.json │ └── src │ │ └── Main.purs │ ├── packages.nix │ ├── src │ ├── Counter │ │ └── WebAPI.hs │ ├── Main.hs │ └── PSGenerator.hs │ └── stack.yaml ├── packages.nix ├── servant-purescript.cabal ├── src └── Servant │ ├── API │ └── BrowserHeader.hs │ ├── PureScript.hs │ └── PureScript │ ├── CodeGen.hs │ ├── Internal.hs │ ├── MakeRequests.hs │ └── Subscriber.hs ├── stack-7.10.yaml ├── stack-8.0.nix ├── stack-8.0.yaml ├── stack.nix └── test ├── Spec.hs └── output └── .KEEP /.github/workflows/haskell-ci.yml: -------------------------------------------------------------------------------- 1 | # This GitHub workflow config has been generated by a script via 2 | # 3 | # haskell-ci 'github' 'servant-purescript.cabal' 4 | # 5 | # To regenerate the script (for example after adjusting tested-with) run 6 | # 7 | # haskell-ci regenerate 8 | # 9 | # For more information, see https://github.com/haskell-CI/haskell-ci 10 | # 11 | # version: 0.14.3 12 | # 13 | # REGENDATA ("0.14.3",["github","servant-purescript.cabal"]) 14 | # 15 | name: Haskell-CI 16 | on: 17 | - push 18 | - pull_request 19 | jobs: 20 | linux: 21 | name: Haskell-CI - Linux - ${{ matrix.compiler }} 22 | runs-on: ubuntu-18.04 23 | timeout-minutes: 24 | 60 25 | container: 26 | image: buildpack-deps:bionic 27 | continue-on-error: ${{ matrix.allow-failure }} 28 | strategy: 29 | matrix: 30 | include: 31 | - compiler: ghc-9.0.2 32 | compilerKind: ghc 33 | compilerVersion: 9.0.2 34 | setup-method: ghcup 35 | allow-failure: false 36 | - compiler: ghc-8.10.7 37 | compilerKind: ghc 38 | compilerVersion: 8.10.7 39 | setup-method: ghcup 40 | allow-failure: false 41 | - compiler: ghc-8.8.4 42 | compilerKind: ghc 43 | compilerVersion: 8.8.4 44 | setup-method: hvr-ppa 45 | allow-failure: false 46 | fail-fast: false 47 | steps: 48 | - name: apt 49 | run: | 50 | apt-get update 51 | apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 52 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 53 | mkdir -p "$HOME/.ghcup/bin" 54 | curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup" 55 | chmod a+x "$HOME/.ghcup/bin/ghcup" 56 | "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" 57 | "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 58 | else 59 | apt-add-repository -y 'ppa:hvr/ghc' 60 | apt-get update 61 | apt-get install -y "$HCNAME" 62 | mkdir -p "$HOME/.ghcup/bin" 63 | curl -sL https://downloads.haskell.org/ghcup/0.1.17.5/x86_64-linux-ghcup-0.1.17.5 > "$HOME/.ghcup/bin/ghcup" 64 | chmod a+x "$HOME/.ghcup/bin/ghcup" 65 | "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 66 | fi 67 | env: 68 | HCKIND: ${{ matrix.compilerKind }} 69 | HCNAME: ${{ matrix.compiler }} 70 | HCVER: ${{ matrix.compilerVersion }} 71 | - name: Set PATH and environment variables 72 | run: | 73 | echo "$HOME/.cabal/bin" >> $GITHUB_PATH 74 | echo "LANG=C.UTF-8" >> "$GITHUB_ENV" 75 | echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" 76 | echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" 77 | HCDIR=/opt/$HCKIND/$HCVER 78 | if [ "${{ matrix.setup-method }}" = ghcup ]; then 79 | HC=$HOME/.ghcup/bin/$HCKIND-$HCVER 80 | echo "HC=$HC" >> "$GITHUB_ENV" 81 | echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" 82 | echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" 83 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 84 | else 85 | HC=$HCDIR/bin/$HCKIND 86 | echo "HC=$HC" >> "$GITHUB_ENV" 87 | echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" 88 | echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" 89 | echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" 90 | fi 91 | 92 | HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') 93 | echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" 94 | echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" 95 | echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" 96 | echo "HEADHACKAGE=false" >> "$GITHUB_ENV" 97 | echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" 98 | echo "GHCJSARITH=0" >> "$GITHUB_ENV" 99 | env: 100 | HCKIND: ${{ matrix.compilerKind }} 101 | HCNAME: ${{ matrix.compiler }} 102 | HCVER: ${{ matrix.compilerVersion }} 103 | - name: env 104 | run: | 105 | env 106 | - name: write cabal config 107 | run: | 108 | mkdir -p $CABAL_DIR 109 | cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz 142 | echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - 143 | xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan 144 | rm -f cabal-plan.xz 145 | chmod a+x $HOME/.cabal/bin/cabal-plan 146 | cabal-plan --version 147 | - name: checkout 148 | uses: actions/checkout@v2 149 | with: 150 | path: source 151 | - name: initial cabal.project for sdist 152 | run: | 153 | touch cabal.project 154 | echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project 155 | cat cabal.project 156 | - name: sdist 157 | run: | 158 | mkdir -p sdist 159 | $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist 160 | - name: unpack 161 | run: | 162 | mkdir -p unpacked 163 | find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; 164 | - name: generate cabal.project 165 | run: | 166 | PKGDIR_servant_purescript="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/servant-purescript-[0-9.]*')" 167 | echo "PKGDIR_servant_purescript=${PKGDIR_servant_purescript}" >> "$GITHUB_ENV" 168 | rm -f cabal.project cabal.project.local 169 | touch cabal.project 170 | touch cabal.project.local 171 | echo "packages: ${PKGDIR_servant_purescript}" >> cabal.project 172 | echo "package servant-purescript" >> cabal.project 173 | echo " ghc-options: -Werror=missing-methods" >> cabal.project 174 | cat >> cabal.project <> cabal.project.local 177 | cat cabal.project 178 | cat cabal.project.local 179 | - name: dump install plan 180 | run: | 181 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all 182 | cabal-plan 183 | - name: cache 184 | uses: actions/cache@v2 185 | with: 186 | key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} 187 | path: ~/.cabal/store 188 | restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- 189 | - name: install dependencies 190 | run: | 191 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all 192 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all 193 | - name: build w/o tests 194 | run: | 195 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 196 | - name: build 197 | run: | 198 | $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always 199 | - name: tests 200 | run: | 201 | $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct 202 | - name: cabal check 203 | run: | 204 | cd ${PKGDIR_servant_purescript} || false 205 | ${CABAL} -vnormal check 206 | - name: haddock 207 | run: | 208 | $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all 209 | - name: unconstrained build 210 | run: | 211 | rm -f cabal.project.local 212 | $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all 213 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | *.chi 2 | *.chs.h 3 | *.dyn_hi 4 | *.dyn_o 5 | *.eventlog 6 | *.hi 7 | *.hp 8 | *.o 9 | *.prof 10 | .cabal-sandbox/ 11 | .hpc 12 | .hsenv 13 | .stack-work/ 14 | TAGS 15 | cabal-dev 16 | cabal.project.local 17 | cabal.sandbox.config 18 | dist 19 | dist-* 20 | shell.nix 21 | default.nix 22 | .idea/ 23 | stack.yaml 24 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # vim: nospell 2 | language: minimal 3 | sudo: false 4 | 5 | cache: 6 | directories: 7 | - $HOME/.stack 8 | 9 | matrix: 10 | include: 11 | - env: GHC=7.10.3 CABAL=1.22 12 | compiler: "GHC 7.10" 13 | addons: 14 | apt: 15 | sources: 16 | - hvr-ghc 17 | packages: 18 | - ghc-7.10.3 19 | - cabal-install-1.22 20 | - happy-1.19.5 21 | - alex-3.1.4 22 | 23 | - env: GHC=8.0.1 CABAL=1.24 24 | compiler: "GHC 8.0" 25 | addons: 26 | apt: 27 | sources: 28 | - hvr-ghc 29 | packages: 30 | - ghc-8.0.1 31 | - cabal-install-1.24 32 | - happy-1.19.5 33 | - alex-3.1.4 34 | 35 | - env: GHC=head CABAL=1.24 36 | compiler: "GHC HEAD" 37 | addons: 38 | apt: 39 | sources: 40 | - hvr-ghc 41 | packages: 42 | - ghc-head 43 | - cabal-install-1.24 44 | - happy-1.19.5 45 | - alex-3.1.4 46 | 47 | allow_failures: 48 | - env: GHC=head CABAL=1.24 49 | 50 | fast_finish: true 51 | 52 | 53 | before_install: 54 | - export PATH=/opt/ghc/$GHC/bin:/opt/cabal/$CABAL/bin:/opt/alex/3.1.4/bin:/opt/happy/1.19.5/bin:$PATH 55 | 56 | # cabal 57 | - travis_retry cabal update 58 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config 59 | 60 | # stack 61 | - mkdir -p $HOME/bin 62 | - export PATH=$HOME/bin:$PATH 63 | - travis_retry curl -L "https://www.stackage.org/stack/linux-x86_64" | gunzip | tar -x 64 | - mv stack-*/stack $HOME/bin 65 | - if [ ${GHC} != head ]; then ln -s stack-${GHC%.*}.yaml stack.yaml; fi 66 | - travis_retry stack setup 67 | - #travis_retry stack install hscolour 68 | - pushd .. 69 | - git clone https://github.com/eskimor/servant-subscriber.git 70 | - git clone https://github.com/eskimor/purescript-bridge.git 71 | - popd 72 | 73 | install: 74 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]" 75 | - stack --version 76 | - cabal --version 77 | - opt --version; true 78 | - llc --version; true 79 | - | 80 | if [ ${GHC} != head ]; then 81 | travis_retry stack build --only-dependencies --no-terminal --no-haddock-deps -j2 82 | else 83 | travis_retry cabal install --only-dependencies --allow-newer 84 | fi 85 | script: 86 | - | 87 | if [ ${GHC} != head ]; then 88 | stack build --no-terminal 89 | else 90 | cabal install --allow-newer 91 | fi 92 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Robert Klotzner (c) 2016 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 Robert Klotzner 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. -------------------------------------------------------------------------------- /Readme.md: -------------------------------------------------------------------------------- 1 | Servant Purescript 2 | ================== 3 | 4 | [![Build status](https://github.com/eskimor/servant-purescript/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/eskimor/servant-purescript/actions/workflows/haskell-ci.yml) 5 | 6 | Generate typed PureScript query functions for your servant-api. Find an example, including 7 | the generated code in [examples/central-counter](https://github.com/eskimor/servant-purescript/tree/master/examples/central-counter). 8 | 9 | ## Features 10 | 11 | - Typed serialization/deserialization, taken care of by Haskell's aeson and PureScript's argonaut. 12 | Generic encoding/decoding of both made compatible by 13 | [purescript-argonaut-generic-codecs](https://github.com/eskimor/purescript-argonaut-generic-codecs/blob/purescript-argonaut-generic-codec/src/Data/Argonaut/Generic/Aeson.purs). 14 | - You can put common parameters like Auth tokens and the base URL in a reader monad, so you don't 15 | have to pass them explicitly. This is configurable in the code generator with `readerParams` in `Settings`. 16 | 17 | ## Usage 18 | 19 | Apart from the above basic usage example, the documentation is still lacking. For 20 | the purescript side make sure you have 21 | [purescript-servant-support](https://github.com/eskimor/purescript-servant-support) 22 | and 23 | [purescript-argonaut-generic-codecs](https://github.com/eskimor/purescript-argonaut-generic-codecs) 24 | installed, otherwise the generated code will not compile. 25 | 26 | ## Status 27 | 28 | It works! 29 | 30 | Documentation is yet to come, but there is a usage example in 31 | examples/central-counter which also uses servant-subscriber for counter 32 | live updates. Generated code is only partly tested, especially Query parameters 33 | are still completely untested. 34 | 35 | For type translations purescript-bridge is used. 36 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /devEnv.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | nix-shell ../default.nix --arg project ../servant-purescript --arg packages 'import ./packages.nix' 3 | -------------------------------------------------------------------------------- /examples/central-counter/LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2016, Robert Klotzner 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 Robert Klotzner 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 | -------------------------------------------------------------------------------- /examples/central-counter/README.md: -------------------------------------------------------------------------------- 1 | # How to build 2 | 3 | ## Build the server 4 | 5 | * `stack setup` 6 | * `stack build` 7 | 8 | ## Generate the purescript code for the servant API 9 | 10 | * `stack exec PSGenerator` 11 | 12 | ## Build the frontend 13 | 14 | * `cd frontend` 15 | * Install npm 16 | * Install bower and pulp via npm 17 | * Run `npm install` 18 | * Run `npm run build` 19 | 20 | ## Run the server 21 | 22 | * `stack exec central-counter` 23 | * Visit http://localhost:8081/index.html in multiple browser windows and click `+` and `-`. 24 | * Have fun! 25 | -------------------------------------------------------------------------------- /examples/central-counter/central-counter.cabal: -------------------------------------------------------------------------------- 1 | -- Initial central-counter.cabal generated by cabal init. For further 2 | -- documentation, see http://haskell.org/cabal/users-guide/ 3 | 4 | -- The name of the package. 5 | name: central-counter 6 | 7 | -- The package version. See the Haskell package versioning policy (PVP) 8 | -- for standards guiding when and how versions should be incremented. 9 | -- http://www.haskell.org/haskellwiki/Package_versioning_policy 10 | -- PVP summary: +-+------- breaking API changes 11 | -- | | +----- non-breaking API additions 12 | -- | | | +--- code changes with no API change 13 | version: 0.1.0.0 14 | 15 | -- A short (one-line) description of the package. 16 | synopsis: Example project, putting servant-purescript, servant-subscriber and purescript-bridge to use. 17 | 18 | -- A longer description of the package. 19 | -- description: 20 | 21 | -- URL for the project homepage or repository. 22 | homepage: https://github.com/eskimor/servant-purescript/tree/master/examples/central-counter 23 | 24 | -- The license under which the package is released. 25 | license: BSD3 26 | 27 | -- The file containing the license text. 28 | license-file: LICENSE 29 | 30 | -- The package author(s). 31 | author: Robert Klotzner 32 | 33 | -- An email address to which users can send suggestions, bug reports, and 34 | -- patches. 35 | maintainer: robert.klotzner@gmx.at 36 | 37 | -- A copyright notice. 38 | -- copyright: 39 | 40 | category: Web 41 | 42 | build-type: Simple 43 | 44 | -- Extra files to be distributed with the package, such as examples or a 45 | -- README. 46 | -- extra-source-files: 47 | 48 | -- Constraint on the version of Cabal needed to build this package. 49 | cabal-version: >=1.10 50 | 51 | 52 | executable central-counter 53 | -- .hs or .lhs file containing the Main module. 54 | main-is: Main.hs 55 | 56 | -- Modules included in this executable, other than Main. 57 | other-modules: Counter.WebAPI 58 | 59 | -- LANGUAGE extensions used by modules in this package. 60 | -- other-extensions: 61 | 62 | -- Other library packages from which modules are imported. 63 | build-depends: base >=4.8 && < 6.0 64 | , aeson 65 | , bytestring 66 | , containers 67 | , ghc-mod 68 | , http-api-data 69 | , http-types 70 | , lens 71 | , mainland-pretty 72 | , monad-logger 73 | , mtl 74 | , purescript-bridge 75 | , servant 76 | , servant-server 77 | , servant-purescript 78 | , servant-subscriber 79 | , stm 80 | , text 81 | , transformers 82 | , wai 83 | , warp 84 | 85 | -- Directories containing source files. 86 | hs-source-dirs: src 87 | 88 | -- Base language which the package is written in. 89 | default-language: Haskell2010 90 | 91 | executable psGenerator 92 | -- .hs or .lhs file containing the Main module. 93 | main-is: PSGenerator.hs 94 | 95 | -- Modules included in this executable, other than Main. 96 | other-modules: Counter.WebAPI 97 | 98 | -- LANGUAGE extensions used by modules in this package. 99 | -- other-extensions: 100 | 101 | -- Other library packages from which modules are imported. 102 | build-depends: base >=4.8 && < 6.0 103 | , aeson 104 | , containers 105 | , filepath 106 | , ghc-mod 107 | , http-api-data 108 | , http-types 109 | , lens 110 | , mainland-pretty 111 | , purescript-bridge 112 | , servant 113 | , servant-foreign 114 | , servant-purescript 115 | , servant-subscriber 116 | , text 117 | 118 | -- Directories containing source files. 119 | hs-source-dirs: src 120 | 121 | -- Base language which the package is written in. 122 | default-language: Haskell2010 123 | -------------------------------------------------------------------------------- /examples/central-counter/default.nix: -------------------------------------------------------------------------------- 1 | { mkDerivation, aeson, base, bytestring, containers, filepath 2 | , ghc-mod, http-api-data, http-types, lens, mainland-pretty, mtl 3 | , purescript-bridge, servant, servant-foreign, servant-purescript 4 | , servant-server, servant-subscriber, stdenv, text, transformers 5 | , wai, warp 6 | }: 7 | mkDerivation { 8 | pname = "central-counter"; 9 | version = "0.1.0.0"; 10 | src = ./.; 11 | isLibrary = false; 12 | isExecutable = true; 13 | executableHaskellDepends = [ 14 | aeson base bytestring containers filepath ghc-mod http-api-data 15 | http-types lens mainland-pretty mtl purescript-bridge servant 16 | servant-foreign servant-purescript servant-server 17 | servant-subscriber text transformers wai warp 18 | ]; 19 | homepage = "https://github.com/eskimor/servant-purescript/tree/master/examples/distributed-counter"; 20 | description = "Example project, putting servant-purescript, servant-subscriber and purescript-bridge to use"; 21 | license = stdenv.lib.licenses.bsd3; 22 | } 23 | -------------------------------------------------------------------------------- /examples/central-counter/devEnv.sh: -------------------------------------------------------------------------------- 1 | #!/usr/bin/env bash 2 | nix-shell /home/robert/projects --arg project ../central-counter --arg packages 'import ./packages.nix {}' 3 | -------------------------------------------------------------------------------- /examples/central-counter/frontend/.gitignore: -------------------------------------------------------------------------------- 1 | node_modules 2 | bower_components 3 | **DS_Store 4 | output 5 | .psci_modules 6 | npm-debug.log 7 | src/Counter/* 8 | -------------------------------------------------------------------------------- /examples/central-counter/frontend/bower.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "central-counter", 3 | "homepage": "https://github.com/eskimor/servant-purescript", 4 | "authors": [ 5 | "Robert Klotzner robert.klotzner AT gmx.at" 6 | ], 7 | "description": "Example for showing use of servant-purescript, servant-subscriber & purescript-bridge", 8 | "main": "support/index.js", 9 | "license": "BSD3", 10 | "dependencies": { 11 | "purescript-pux": "^7.0.0", 12 | "purescript-affjax": "^3.0.0", 13 | "purescript-aff": "^2.0.0", 14 | "purescript-argonaut-generic-codecs": "^4.0.0", 15 | "purescript-servant-support": "^6.0.0", 16 | "purescript-subscriber": "^2.0.0", 17 | "purescript-generics": "^1.0.0", 18 | "purescript-partial": "^1.1.2", 19 | "purescript-dom": "^3.0.0", 20 | "purescript-profunctor-lenses": "^2.0.0" 21 | }, 22 | "resolutions": { 23 | "purescript-affjax": "^3.0.0", 24 | "purescript-aff": "^2.0.0", 25 | "purescript-generics": "^3.0.0", 26 | "purescript-profunctor-lenses": "^2.0.0", 27 | "purescript-dom": "^3.0.0", 28 | "purescript-eff": "^2.0.0", 29 | "purescript-maps": "^2.0.0", 30 | "purescript-functions": "^2.0.0", 31 | "purescript-signal": "^8.0.0", 32 | "purescript-lists": "^3.1.0", 33 | "purescript-profunctor": "^2.0.0", 34 | "purescript-globals": "^2.0.0", 35 | "purescript-foreign": "^3.0.0", 36 | "purescript-integers": "^2.0.0", 37 | "purescript-nullable": "^2.0.0", 38 | "purescript-media-types": "^2.0.0", 39 | "purescript-unsafe-coerce": "^2.0.0", 40 | "purescript-console": "^2.0.0", 41 | "purescript-refs": "^2.0.0", 42 | "purescript-prelude": "^2.1.0", 43 | "purescript-either": "^2.0.0", 44 | "purescript-foldable-traversable": "^2.0.0", 45 | "purescript-tuples": "^3.0.0", 46 | "purescript-maybe": "^2.0.0", 47 | "purescript-bifunctors": "^2.0.0", 48 | "purescript-transformers": "^2.0.0", 49 | "purescript-exceptions": "^2.0.0", 50 | "purescript-parallel": "^2.0.0", 51 | "purescript-arrays": "^3.0.0", 52 | "purescript-strings": "^2.0.0", 53 | "purescript-const": "^2.0.0", 54 | "purescript-identity": "^2.0.0", 55 | "purescript-sets": "^2.0.0", 56 | "purescript-enums": "^2.0.0", 57 | "purescript-js-date": "^3.0.0", 58 | "purescript-datetime": "^2.0.0", 59 | "purescript-st": "^2.0.0", 60 | "purescript-lazy": "^2.0.0", 61 | "purescript-unfoldable": "^2.0.0", 62 | "purescript-distributive": "^2.0.0", 63 | "purescript-monoid": "^2.0.0", 64 | "purescript-contravariant": "^2.0.0", 65 | "purescript-invariant": "^2.0.0", 66 | "purescript-control": "^2.0.0", 67 | "purescript-tailrec": "^2.0.0", 68 | "purescript-argonaut-core": "^2.0.1", 69 | "purescript-form-urlencoded": "^2.0.0", 70 | "purescript-http-methods": "^2.0.0", 71 | "purescript-argonaut-generic-codecs": "^4.0.0", 72 | "purescript-var": "^1.0.0", 73 | "purescript-servant-support": "^6.0.0", 74 | "purescript-websocket-simple": "^1.0.0", 75 | "purescript-eff-functions": "^2.0.0" 76 | } 77 | } 78 | -------------------------------------------------------------------------------- /examples/central-counter/frontend/dist/app.css: -------------------------------------------------------------------------------- 1 | body { 2 | font-family: 'Source Sans Pro', 'Trebuchet MS', 'Lucida Grande', 'Helvetica Neue', sans-serif; 3 | text-rendering: optimizeLegibility; 4 | font-size: 14px; 5 | letter-spacing: .2px; 6 | text-size-adjust: 100 7 | } 8 | -------------------------------------------------------------------------------- /examples/central-counter/frontend/dist/index.html: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | Pux Starter App 8 | 9 | 10 | 11 |
12 | 13 | 14 | 15 | -------------------------------------------------------------------------------- /examples/central-counter/frontend/package.json: -------------------------------------------------------------------------------- 1 | { 2 | "name": "pux-starter-app", 3 | "version": "6.0.0", 4 | "description": "Starter Pux application using webpack with hot-reloading.", 5 | "main": "support/index.js", 6 | "keywords": [ 7 | "pux", 8 | "purescript-pux", 9 | "boilerplate", 10 | "starter-app" 11 | ], 12 | "scripts": { 13 | "postinstall": "./node_modules/.bin/bower cache clean && ./node_modules/.bin/bower install", 14 | "build": "pulp browserify --to dist/app.js", 15 | "test": "echo \"Error: no test specified\" && exit 1" 16 | }, 17 | "repository": { 18 | "type": "git", 19 | "url": "git://github.com/alexmingoia/pux-starter-app.git" 20 | }, 21 | "author": "Alexander C. Mingoia", 22 | "license": "BSD3", 23 | "bugs": { 24 | "url": "https://github.com/alexmingoia/pux-starter-app/issues" 25 | }, 26 | "dependencies": { 27 | "react": "^15.0.0", 28 | "react-dom": "^15.0.0" 29 | }, 30 | "devDependencies": { 31 | "bower": "^1.7.9", 32 | "pulp": "^10.0.1", 33 | "purescript": "^0.10.7" 34 | } 35 | } 36 | -------------------------------------------------------------------------------- /examples/central-counter/frontend/src/Main.purs: -------------------------------------------------------------------------------- 1 | -- | TODO: This example could use a rewrite ;-) 2 | module Main where 3 | 4 | import Control.Monad.Aff 5 | import Control.Monad.Except.Trans 6 | import Control.Monad.Reader.Trans 7 | import Counter.ServerTypes 8 | import Counter.WebAPI 9 | import Data.Argonaut.Generic.Aeson 10 | import Data.Either 11 | import Data.Generic 12 | import Data.Maybe 13 | import Prelude 14 | import Servant.PureScript.Affjax 15 | import Servant.PureScript.Settings 16 | import Counter.WebAPI.MakeRequests as MakeReq 17 | import Counter.WebAPI.Subscriber as Sub 18 | import Data.Array as Array 19 | import Servant.Subscriber as Subscriber 20 | import Servant.Subscriber.Connection as C 21 | import Control.Bind ((<=<)) 22 | import Control.Monad.Eff (Eff) 23 | import Control.Monad.Eff.Exception (EXCEPTION) 24 | import Control.Monad.Eff.Ref (REF) 25 | import DOM.Node.Node (baseURI) 26 | import Data.Argonaut.Core (Json) 27 | import Data.Argonaut.Parser (jsonParser) 28 | import Data.Bifunctor (lmap) 29 | import Data.Foldable (foldr, fold) 30 | import Data.List (List(Nil, Cons)) 31 | import Data.Tuple (Tuple(Tuple)) 32 | import Network.HTTP.Affjax (AJAX, get) 33 | import Pux (renderToDOM, fromSimple, start, EffModel, noEffects) 34 | import Pux.Html (Html, text, button, span, div, p) 35 | import Pux.Html.Events (onClick) 36 | import Servant.Subscriber (Subscriber, makeSubscriber, SubscriberEff, Config, makeSubscriptions) 37 | import Servant.Subscriber.Request (HttpRequest(..)) 38 | import Servant.Subscriber.Types (Path(Path)) 39 | import Signal (Signal) 40 | import Signal.Channel (Channel, subscribe, send, channel, CHANNEL) 41 | import Unsafe.Coerce (unsafeCoerce) 42 | import WebSocket (WEBSOCKET) 43 | 44 | 45 | data Action = Increment 46 | | Decrement 47 | | Update Int 48 | | ReportError AjaxError 49 | | SubscriberLog String 50 | | Nop 51 | 52 | type State = { 53 | counter :: Int 54 | , lastError :: Maybe AjaxError 55 | , settings :: MySettings 56 | , subscriberLog :: List String 57 | } 58 | 59 | type MySettings = SPSettings_ SPParams_ 60 | 61 | 62 | 63 | type APIEffect eff = ReaderT MySettings (ExceptT AjaxError (Aff ( ajax :: AJAX, channel :: CHANNEL, err :: EXCEPTION | eff))) 64 | 65 | type ServantModel = 66 | { state :: State 67 | , effects :: Array (APIEffect () Action) 68 | } 69 | 70 | 71 | update :: Action -> State -> EffModel State Action (ajax :: AJAX) 72 | update Increment state = runEffectActions state [Update <$> putCounter (CounterAdd 1)] 73 | update Decrement state = runEffectActions state [Update <$> putCounter (CounterAdd (-1))] 74 | update (Update val) state = { state : state { counter = val }, effects : []} 75 | update (ReportError err ) state = { state : state { lastError = Just err}, effects : []} 76 | update (SubscriberLog msg) state = { state : state { subscriberLog = Cons msg state.subscriberLog}, effects : []} 77 | update Nop state = noEffects state 78 | 79 | view :: State -> Html Action 80 | view state = 81 | div [] 82 | [ div 83 | [] 84 | [ button [ onClick (const Increment) ] [ text "+" ] 85 | , span [] [ text (show state.counter) ] 86 | , button [ onClick (const Decrement) ] [ text "-" ] 87 | ] 88 | , div [] 89 | [ span [] [ text $ "Error: " <> maybe "Nothing" errorToString state.lastError ] 90 | , div [] 91 | [ text $ "Subscriber Log: " 92 | , div [] 93 | (foldr Array.cons [] <<< map (\l -> p [] [ text l ]) $ state.subscriberLog) 94 | ] 95 | ] 96 | ] 97 | 98 | runEffectActions :: State -> Array (APIEffect () Action) -> EffModel State Action (ajax :: AJAX) 99 | runEffectActions state effects = { state : state, effects : map (runEffect state.settings) effects } 100 | 101 | runEffect :: MySettings -> APIEffect () Action -> Aff (channel :: CHANNEL, ajax :: AJAX, err :: EXCEPTION) Action 102 | runEffect settings m = do 103 | er <- runExceptT $ runReaderT m settings 104 | case er of 105 | Left err -> pure $ ReportError err 106 | Right v -> pure v 107 | 108 | type SubscriberData eff = { 109 | subscriber :: Subscriber eff Action 110 | , messages :: Signal Action 111 | } 112 | 113 | 114 | initSubscriber :: forall eff. MySettings -> SubscriberEff (channel :: CHANNEL | eff) (SubscriberData (channel :: CHANNEL | eff)) 115 | initSubscriber settings = do 116 | ch <- channel Nop 117 | let 118 | c :: Config (channel :: CHANNEL | eff) Action 119 | c = { 120 | url : "ws://localhost:8081/subscriber" 121 | , notify : send ch <<< SubscriberLog <<< gShow 122 | , callback : send ch 123 | } 124 | sub <- makeSubscriber c 125 | let sig = subscribe ch 126 | pongReq <- flip runReaderT settings $ MakeReq.putCounter (CounterAdd 1) -- | Let's play a bit! :-) 127 | closeReq <- flip runReaderT settings $ MakeReq.putCounter (CounterSet 100) 128 | subs <- flip runReaderT settings $ Sub.getCounter (maybe Nop Update) 129 | let c = Subscriber.getConnection sub 130 | C.setPongRequest pongReq c -- |< Hihi :-) 131 | C.setCloseRequest closeReq c 132 | Subscriber.deploy subs sub 133 | pure $ { subscriber : sub, messages : sig } 134 | 135 | 136 | -- main :: forall e. Eff (ajax :: AJAX, err :: EXCEPTION, channel :: CHANNEL | e) Unit 137 | main :: forall eff. Eff (ajax :: AJAX, err :: EXCEPTION, channel :: CHANNEL, ref :: REF, ws :: WEBSOCKET | eff) Unit 138 | main = do 139 | let settings = SPSettings_ { 140 | encodeJson : encodeJson 141 | , decodeJson : decodeJson 142 | , toURLPiece : gShow 143 | , params : SPParams_ { 144 | authToken : VerySecret "topsecret" 145 | , baseURL : "http://localhost:8081/" 146 | } 147 | } 148 | let initState = { counter : 0, settings : settings, lastError : Nothing, subscriberLog : Nil } 149 | sub <- initSubscriber settings 150 | app <- coerceEffects <<< start $ 151 | { initialState: initState 152 | , update: update 153 | , view: view 154 | , inputs: [sub.messages] 155 | --, inputs : [] 156 | } 157 | 158 | renderToDOM "#app" app.html 159 | 160 | coerceEffects :: forall eff0 eff1 a. Eff eff0 a -> Eff eff1 a 161 | coerceEffects = unsafeCoerce 162 | -------------------------------------------------------------------------------- /examples/central-counter/packages.nix: -------------------------------------------------------------------------------- 1 | {projectsDir ? ~/projects }: 2 | let 3 | mkPath = f : "${builtins.toString projectsDir}/${f}"; 4 | in 5 | { 6 | servant-subscriber = mkPath "servant-subscriber"; 7 | purescript-bridge = mkPath "purescript-bridge"; 8 | servant-purescript = mkPath "servant-purescript"; 9 | } 10 | -------------------------------------------------------------------------------- /examples/central-counter/src/Counter/WebAPI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AutoDeriveTypeable #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TypeOperators #-} 9 | 10 | module Counter.WebAPI where 11 | 12 | import Control.Applicative 13 | import Control.Lens 14 | import Data.Aeson 15 | import Data.Proxy 16 | import qualified Data.Set as Set 17 | import Data.Text (Text) 18 | import qualified Data.Text.Encoding as T 19 | import qualified Data.Text.IO as T 20 | 21 | import Data.Typeable 22 | import GHC.Generics (Generic) 23 | import Language.PureScript.Bridge 24 | import Language.PureScript.Bridge.PSTypes 25 | import Network.HTTP.Types.URI (urlDecode) 26 | import Servant.API 27 | import Servant.PureScript (jsonParseUrlPiece, jsonParseHeader) 28 | import Servant.Subscriber.Subscribable 29 | import Web.HttpApiData 30 | 31 | 32 | data Hello = Hello { 33 | _message :: Text 34 | } deriving Generic 35 | 36 | instance FromJSON Hello 37 | instance ToJSON Hello 38 | 39 | data AuthToken = VerySecret Text deriving (Generic, Show, Eq, Ord, Read) 40 | 41 | instance FromJSON AuthToken 42 | 43 | instance FromHttpApiData AuthToken where 44 | parseUrlPiece = jsonParseUrlPiece 45 | parseHeader = jsonParseHeader 46 | 47 | 48 | data CounterAction = CounterAdd Int | CounterSet Int deriving (Generic, Show, Eq, Ord) 49 | 50 | instance FromJSON CounterAction 51 | 52 | type FullAPI = AppAPI :<|> Raw 53 | 54 | type AppAPI = Header "AuthToken" AuthToken :> "counter" :> CounterAPI 55 | 56 | 57 | type CounterAPI = Subscribable :> Get '[JSON] Int 58 | :<|> ReqBody '[JSON] CounterAction :> Put '[JSON] Int 59 | 60 | 61 | fullAPI :: Proxy FullAPI 62 | fullAPI = Proxy 63 | 64 | appAPI :: Proxy AppAPI 65 | appAPI = Proxy 66 | -------------------------------------------------------------------------------- /examples/central-counter/src/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | 11 | 12 | 13 | module Main where 14 | 15 | import Control.Applicative 16 | import Control.Concurrent.STM 17 | import Control.Lens 18 | import Control.Monad.IO.Class 19 | import Control.Monad.Logger (runStderrLoggingT) 20 | import Control.Monad.Reader.Class 21 | import Control.Monad.Trans.Reader hiding (ask) 22 | import Counter.WebAPI 23 | import Data.Aeson 24 | import qualified Data.ByteString.Lazy as B 25 | import Data.IORef 26 | import Data.Monoid 27 | import Data.Proxy 28 | import qualified Data.Set as Set 29 | import Data.Text (Text) 30 | import qualified Data.Text.Encoding as T 31 | import qualified Data.Text.IO as T 32 | import Data.Typeable 33 | import GHC.Generics (Generic) 34 | import Language.PureScript.Bridge 35 | import Language.PureScript.Bridge.PSTypes 36 | import Network.Wai 37 | import Network.Wai.Handler.Warp 38 | import Servant 39 | import Servant.API 40 | import Servant.Subscriber 41 | import Servant.Subscriber.Subscribable 42 | import Servant.Subscriber.Types 43 | 44 | 45 | data CounterData = CounterData { 46 | _counter :: IORef Int 47 | , _subscriber :: Subscriber FullAPI 48 | } 49 | 50 | makeLenses ''CounterData 51 | 52 | 53 | type HandlerConstraint m = (MonadIO m, MonadReader CounterData m) 54 | 55 | getCounter :: HandlerConstraint m => m Int 56 | getCounter = liftIO . readIORef =<< view counter 57 | 58 | 59 | putCounter :: HandlerConstraint m => CounterAction -> m Int 60 | putCounter action = do 61 | r <- liftIO . flip atomicModifyIORef' (doAction action) =<< view counter 62 | 63 | subscriber' <- view subscriber 64 | let link :: Proxy ("counter" :> Get '[JSON] Int) 65 | link = Proxy 66 | liftIO . atomically $ notify subscriber' ModifyEvent link id 67 | return r 68 | where 69 | doAction (CounterAdd val) c = (c+val, c+val) 70 | doAction (CounterSet val) _ = (val, val) 71 | 72 | counterHandlers :: ServerT CounterAPI (ReaderT CounterData Handler) 73 | counterHandlers = getCounter :<|> putCounter 74 | 75 | -- | We use servant's `enter` mechanism for handling Authentication ... 76 | -- We throw an error if no secret was provided or if it was invalid - so our 77 | -- handlers don't have to care about it. 78 | toServant' :: CounterData -> Maybe AuthToken -> ReaderT CounterData Handler a -> Handler a 79 | toServant' cVar (Just (VerySecret "topsecret")) m = runReaderT m cVar 80 | toServant' _ (Just (VerySecret secret)) _ = throwError $ err401 { errBody = "Your secret is valid not! - '" <> (B.fromStrict . T.encodeUtf8) secret <> "'!" } 81 | toServant' _ _ _ = throwError $ err401 { errBody = "You have to provide a valid secret, which is topsecret!" } 82 | 83 | toServant :: CounterData -> Maybe AuthToken -> ReaderT CounterData Handler :~> Handler 84 | toServant cVar secret = Nat $ toServant' cVar secret 85 | 86 | counterServer :: CounterData -> Maybe AuthToken -> Server CounterAPI 87 | counterServer cVar secret = enter (toServant cVar secret) counterHandlers 88 | 89 | fullServer :: CounterData -> Server FullAPI 90 | fullServer cVar = counterServer cVar :<|> serveDirectory "frontend/dist/" 91 | 92 | main :: IO () 93 | main = do 94 | cd <- CounterData <$> newIORef 0 <*> atomically (makeSubscriber "subscriber" runStderrLoggingT) 95 | run 8081 $ serveSubscriber (cd ^. subscriber) (fullServer cd) 96 | -------------------------------------------------------------------------------- /examples/central-counter/src/PSGenerator.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AutoDeriveTypeable #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | module Main where 10 | 11 | import Control.Applicative 12 | import Control.Lens 13 | import Data.Aeson 14 | import Data.Monoid 15 | import Data.Proxy 16 | import qualified Data.Set as Set 17 | import Data.Text (Text) 18 | import qualified Data.Text as T 19 | import qualified Data.Text.Encoding as T 20 | import qualified Data.Text.IO as T 21 | import Language.PureScript.Bridge 22 | import Language.PureScript.Bridge.PSTypes 23 | import Servant.API 24 | import Servant.PureScript 25 | import Servant.Subscriber.Subscribable 26 | 27 | import Counter.WebAPI 28 | 29 | -- | We have been lazy and defined our types in the WebAPI module, 30 | -- we use this opportunity to show how to create a custom bridge moving those 31 | -- types to Counter.ServerTypes. 32 | fixTypesModule :: BridgePart 33 | fixTypesModule = do 34 | typeModule ^== "Counter.WebAPI" 35 | t <- view haskType 36 | TypeInfo (_typePackage t) "Counter.ServerTypes" (_typeName t) <$> psTypeParameters 37 | 38 | myBridge :: BridgePart 39 | myBridge = defaultBridge <|> fixTypesModule 40 | 41 | data MyBridge 42 | 43 | myBridgeProxy :: Proxy MyBridge 44 | myBridgeProxy = Proxy 45 | 46 | instance HasBridge MyBridge where 47 | languageBridge _ = buildBridge myBridge 48 | 49 | 50 | myTypes :: [SumType 'Haskell] 51 | myTypes = [ 52 | mkSumType (Proxy :: Proxy AuthToken) 53 | , mkSumType (Proxy :: Proxy CounterAction) 54 | , mkSumType (Proxy :: Proxy Hello) 55 | ] 56 | 57 | mySettings :: Settings 58 | mySettings = (addReaderParam "AuthToken" defaultSettings & apiModuleName .~ "Counter.WebAPI") { 59 | _generateSubscriberAPI = True 60 | } 61 | 62 | 63 | main :: IO () 64 | main = do 65 | let frontEndRoot = "frontend/src" 66 | writeAPIModuleWithSettings mySettings frontEndRoot myBridgeProxy appAPI 67 | writePSTypes frontEndRoot (buildBridge myBridge) myTypes 68 | 69 | -------------------------------------------------------------------------------- /examples/central-counter/stack.yaml: -------------------------------------------------------------------------------- 1 | # This file was automatically generated by stack init 2 | # For more information, see: http://docs.haskellstack.org/en/stable/yaml_configuration/ 3 | 4 | # Specifies the GHC version and set of packages available (e.g., lts-3.5, nightly-2015-09-21, ghc-7.10.2) 5 | resolver: lts-8.0 6 | 7 | # Local packages, usually specified by relative directory name 8 | packages: 9 | - '.' 10 | # Packages to be pulled from upstream that are not in the resolver (e.g., acme-missiles-0.3) 11 | extra-deps: [] 12 | 13 | # Override default flag values for local packages and extra-deps 14 | flags: {} 15 | 16 | # Extra package databases containing global packages 17 | extra-package-dbs: [] 18 | 19 | # Control whether we use the GHC we find on the path 20 | # system-ghc: true 21 | 22 | # Require a specific version of stack, using version ranges 23 | # require-stack-version: -any # Default 24 | # require-stack-version: >= 1.0.0 25 | 26 | # Override the architecture used by stack, especially useful on Windows 27 | # arch: i386 28 | # arch: x86_64 29 | 30 | # Extra directories used by stack for building 31 | # extra-include-dirs: [/path/to/dir] 32 | # extra-lib-dirs: [/path/to/dir] 33 | 34 | # Allow a newer minor version of GHC than the snapshot specifies 35 | # compiler-check: newer-minor 36 | -------------------------------------------------------------------------------- /packages.nix: -------------------------------------------------------------------------------- 1 | { 2 | servant-subscriber = ../servant-subscriber; 3 | aeson = ../aeson; 4 | purescript-bridge = ../purescript-bridge; 5 | } 6 | -------------------------------------------------------------------------------- /servant-purescript.cabal: -------------------------------------------------------------------------------- 1 | name: servant-purescript 2 | version: 0.9.0.4 3 | synopsis: Generate PureScript accessor functions for your Servant API 4 | description: Generate PureScript accessor functions for your Servant API; see README.md 5 | homepage: https://github.com/eskimor/servant-purescript#readme 6 | license: BSD3 7 | license-file: LICENSE 8 | author: Robert Klotzner 9 | maintainer: robert Dot klotzner A T gmx Dot at 10 | copyright: Copyright: (c) 2016 Robert Klotzner 11 | category: Web 12 | build-type: Simple 13 | -- extra-source-files: 14 | cabal-version: >=1.10 15 | 16 | extra-source-files: Readme.md 17 | 18 | tested-with: GHC==9.0.2, GHC==8.10.7, GHC==8.8.4 19 | 20 | library 21 | hs-source-dirs: src 22 | exposed-modules: Servant.PureScript.Internal 23 | , Servant.PureScript.CodeGen 24 | , Servant.PureScript.Subscriber 25 | , Servant.PureScript.MakeRequests 26 | , Servant.PureScript 27 | , Servant.API.BrowserHeader 28 | 29 | -- other-modules: Main 30 | build-depends: base >= 4.7 && < 4.16 31 | , aeson >= 0.11.2 32 | , bytestring 33 | , containers 34 | , directory 35 | , filepath 36 | , http-types 37 | , lens 38 | , mainland-pretty 39 | , purescript-bridge >= 0.6 40 | , servant >= 0.18 41 | , servant-foreign 42 | , servant-server 43 | , servant-subscriber 44 | , text 45 | default-language: Haskell2010 46 | 47 | 48 | test-suite servant-purescript-test 49 | type: exitcode-stdio-1.0 50 | hs-source-dirs: test 51 | main-is: Spec.hs 52 | build-depends: base 53 | , aeson >= 0.11.2 54 | , containers 55 | , mainland-pretty 56 | , lens 57 | , purescript-bridge >= 0.6 58 | , servant 59 | , servant-foreign 60 | , servant-purescript 61 | , servant-subscriber 62 | , text 63 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 64 | default-language: Haskell2010 65 | 66 | source-repository head 67 | type: git 68 | location: https://github.com/eskimor/servant-purescript 69 | -------------------------------------------------------------------------------- /src/Servant/API/BrowserHeader.hs: -------------------------------------------------------------------------------- 1 | -- | A header which gets sent by the browser and is thus of no concern for the client consumer of the API. 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE DeriveDataTypeable #-} 5 | {-# LANGUAGE DeriveFunctor #-} 6 | {-# LANGUAGE ConstraintKinds #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE FunctionalDependencies #-} 9 | {-# LANGUAGE ScopedTypeVariables #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | {-# LANGUAGE TypeApplications #-} 13 | {-# LANGUAGE UndecidableInstances #-} 14 | 15 | module Servant.API.BrowserHeader where 16 | 17 | import Servant.Links 18 | import Servant 19 | import Servant.Foreign 20 | import Servant.Subscriber.Subscribable 21 | import GHC.TypeLits 22 | 23 | data BrowserHeader (sym :: Symbol) a 24 | 25 | 26 | 27 | type instance IsElem' e (BrowserHeader :> s) = IsElem e s 28 | 29 | instance HasLink sub => HasLink (BrowserHeader sym a :> sub) where 30 | #if MIN_VERSION_servant(0,14,0) 31 | type MkLink (BrowserHeader sym a :> sub) b = MkLink (Header sym a :> sub) b 32 | toLink toA Proxy = toLink toA (Proxy :: Proxy (Header sym a :> sub)) 33 | #else 34 | type MkLink (BrowserHeader sym a :> sub) = MkLink (Header sym a :> sub) 35 | toLink _ = toLink (Proxy :: Proxy (Header sym a :> sub)) 36 | #endif 37 | 38 | instance ( KnownSymbol sym 39 | , FromHttpApiData a 40 | , HasServer sublayout context 41 | , HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters 42 | ) 43 | => HasServer (BrowserHeader sym a :> sublayout) context where 44 | 45 | type ServerT (BrowserHeader sym a :> sublayout) m = ServerT (Header sym a :> sublayout) m 46 | 47 | route Proxy = route (Proxy :: Proxy (Header sym a :> sublayout)) 48 | 49 | hoistServerWithContext _ pc nt s = 50 | hoistServerWithContext (Proxy @sublayout) pc nt . s 51 | 52 | 53 | -- Ignore BrowserHeader in HasForeign: 54 | instance (KnownSymbol sym, HasForeign lang ftype sublayout) 55 | => HasForeign lang ftype (BrowserHeader sym a :> sublayout) where 56 | type Foreign ftype (BrowserHeader sym a :> sublayout) = Foreign ftype sublayout 57 | 58 | foreignFor lang p Proxy = foreignFor lang p (Proxy :: Proxy sublayout) 59 | 60 | type instance IsSubscribable' endpoint (BrowserHeader sym a :> sub ) = IsSubscribable endpoint sub 61 | -------------------------------------------------------------------------------- /src/Servant/PureScript.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | module Servant.PureScript ( 10 | HasBridge 11 | , languageBridge 12 | , defaultBridge 13 | , defaultBridgeProxy 14 | , DefaultBridge 15 | , writeAPIModule 16 | , writeAPIModuleWithSettings 17 | , Settings (..) 18 | , apiModuleName 19 | , readerParams 20 | , standardImports 21 | , defaultSettings 22 | , addReaderParam 23 | , jsonParseUrlPiece 24 | , jsonToUrlPiece 25 | , jsonParseHeader 26 | , jsonToHeader 27 | ) where 28 | 29 | 30 | import Control.Lens 31 | import Control.Monad (when) 32 | import Data.Aeson 33 | import Data.Bifunctor 34 | import Data.ByteString (ByteString) 35 | import qualified Data.ByteString.Lazy as BS 36 | import Data.Monoid 37 | import Data.Proxy 38 | import Data.Text (Text) 39 | import qualified Data.Text as T 40 | import qualified Data.Text.Encoding as T 41 | import qualified Data.Text.IO as T 42 | import Language.PureScript.Bridge 43 | import Network.HTTP.Types (urlDecode, urlEncode) 44 | import Servant.Foreign 45 | import Servant.PureScript.CodeGen 46 | import Servant.PureScript.Internal 47 | import qualified Servant.PureScript.Subscriber as SubGen 48 | import qualified Servant.PureScript.MakeRequests as MakeRequests 49 | import System.Directory 50 | import System.FilePath 51 | import System.IO (IOMode (..), withFile) 52 | import Text.PrettyPrint.Mainland (hPutDocLn, Doc) 53 | 54 | -- | Standard entry point - just create a purescript module with default settings 55 | -- for accessing the servant API. 56 | writeAPIModule :: forall bridgeSelector api. 57 | ( HasForeign (PureScript bridgeSelector) PSType api 58 | , GenerateList PSType (Foreign PSType api) 59 | , HasBridge bridgeSelector 60 | ) => FilePath -> Proxy bridgeSelector -> Proxy api -> IO () 61 | writeAPIModule = writeAPIModuleWithSettings defaultSettings 62 | 63 | writeAPIModuleWithSettings :: forall bridgeSelector api. 64 | ( HasForeign (PureScript bridgeSelector) PSType api 65 | , GenerateList PSType (Foreign PSType api) 66 | , HasBridge bridgeSelector 67 | ) => Settings -> FilePath -> Proxy bridgeSelector -> Proxy api -> IO () 68 | writeAPIModuleWithSettings opts root pBr pAPI = do 69 | writeModule (opts ^. apiModuleName) genModule 70 | when (opts ^. generateSubscriberAPI) $ do 71 | writeModule (opts ^. apiModuleName <> ".Subscriber") SubGen.genModule 72 | writeModule (opts ^. apiModuleName <> ".MakeRequests") MakeRequests.genModule 73 | T.putStrLn "\nSuccessfully created your servant API purescript functions!" 74 | T.putStrLn "Please make sure you have purescript-servant-support version 5.0.0 or above installed:\n" 75 | T.putStrLn " bower i --save purescript-servant-support\n" 76 | where 77 | apiList = apiToList pAPI pBr 78 | 79 | writeModule :: Text -> (Settings -> [Req PSType] -> Doc) -> IO () 80 | writeModule mName genModule' = let 81 | fileName = (joinPath . map T.unpack . T.splitOn "." $ mName) <> ".purs" 82 | mPath = root fileName 83 | mDir = takeDirectory mPath 84 | contents = genModule' opts apiList 85 | in do 86 | unlessM (doesDirectoryExist mDir) $ createDirectoryIfMissing True mDir 87 | withFile mPath WriteMode $ flip hPutDocLn contents 88 | 89 | 90 | -- | Use this function for implementing 'parseUrlPiece' in your FromHttpApiData instances 91 | -- in order to be compatible with the generated PS code. 92 | -- 93 | -- > 94 | -- > instance ToHttpApiData MyDataType where 95 | -- > toUrlPiece = jsonToUrlPiece 96 | -- > toHeader = jsonToHeader 97 | -- > 98 | -- > instance FromHttpApiData MyDataType where 99 | -- > parseUrlPiece = jsonParseUrlPiece 100 | -- > parseHeader = jsonParseHeader 101 | -- > 102 | -- 103 | jsonParseUrlPiece :: FromJSON a => Text -> Either Text a 104 | jsonParseUrlPiece = jsonParseHeader . T.encodeUtf8 105 | 106 | -- | Use this function for implementing 'toUrlPiece' in your ToHttpApiData instances 107 | -- in order to be compatible with the generated PS code. 108 | jsonToUrlPiece :: ToJSON a => a -> Text 109 | jsonToUrlPiece = T.decodeUtf8 . jsonToHeader 110 | 111 | -- | Use this function for implementing 'parseHeader' in your FromHttpApiData instances 112 | -- in order to be compatible with the generated PS code. 113 | jsonParseHeader :: FromJSON a => ByteString -> Either Text a 114 | jsonParseHeader = first T.pack . eitherDecodeStrict 115 | 116 | -- | Use this function for implementing 'toHeader' in your ToHttpApiData instances 117 | -- in order to be compatible with the generated PS code. 118 | jsonToHeader :: ToJSON a => a -> ByteString 119 | jsonToHeader = BS.toStrict . encode 120 | -------------------------------------------------------------------------------- /src/Servant/PureScript/CodeGen.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | module Servant.PureScript.CodeGen where 10 | 11 | import Control.Lens hiding (List) 12 | import qualified Data.Map as Map 13 | import Data.Maybe (mapMaybe, maybeToList) 14 | import qualified Data.Set as Set 15 | import Data.Text (Text) 16 | import qualified Data.Text.Encoding as T 17 | import Language.PureScript.Bridge 18 | import Language.PureScript.Bridge.PSTypes (psString) 19 | import Network.HTTP.Types.URI (urlEncode) 20 | import Servant.Foreign 21 | import Servant.PureScript.Internal 22 | import Text.PrettyPrint.Mainland 23 | 24 | genModule :: Settings -> [Req PSType] -> Doc 25 | genModule opts reqs = let 26 | allParams = concatMap reqToParams reqs 27 | rParams = getReaderParams opts allParams 28 | apiImports = reqsToImportLines reqs 29 | imports = mergeImportLines (_standardImports opts) apiImports 30 | in 31 | genModuleHeader (_apiModuleName opts) imports 32 | genParamSettings rParams <> line 33 | (docIntercalate line . map (genFunction rParams)) reqs 34 | 35 | genModuleHeader :: Text -> ImportLines -> Doc 36 | genModuleHeader moduleName imports = let 37 | importLines = map (strictText . importLineToText) . Map.elems $ imports 38 | in 39 | "-- File auto generated by servant-purescript! --" 40 | "module" <+> strictText moduleName <+> "where" <> line 41 | "import Prelude" <> line 42 | docIntercalate line importLines <> line 43 | 44 | getReaderParams :: Settings -> [PSParam] -> [PSParam] 45 | getReaderParams opts allParams = let 46 | isReaderParam = (`Set.member` _readerParams opts) . _pName 47 | rParamsDirty = filter isReaderParam allParams 48 | rParamsMap = Map.fromListWith useOld . map toPair $ rParamsDirty 49 | rParams = map fromPair . Map.toList $ rParamsMap 50 | -- Helpers 51 | toPair (Param n t) = (n, t) 52 | fromPair (n, t) = Param n t 53 | useOld = flip const 54 | in 55 | rParams 56 | 57 | genParamSettings :: [PSParam]-> Doc 58 | genParamSettings rParams = let 59 | genEntry arg = arg ^. pName ^. to psVar <+> "::" <+> arg ^. pType ^. typeName ^. to strictText 60 | genEntries = docIntercalate (line <> ", ") . map genEntry 61 | in 62 | "newtype SPParams_ = SPParams_" <+/> align ( 63 | lbrace 64 | <+> genEntries rParams 65 | rbrace 66 | ) 67 | 68 | genFunction :: [PSParam] -> Req PSType -> Doc 69 | genFunction allRParams req = let 70 | rParamsSet = Set.fromList allRParams 71 | fnName = req ^. reqFuncName ^. jsCamelCaseL 72 | allParamsList = baseURLParam : reqToParams req 73 | allParams = Set.fromList allParamsList 74 | fnParams = filter (not . flip Set.member rParamsSet) allParamsList -- Use list not set, as we don't want to change order of parameters 75 | rParams = Set.toList $ rParamsSet `Set.intersection` allParams 76 | 77 | pTypes = map _pType fnParams 78 | pNames = map _pName fnParams 79 | signature = genSignature fnName pTypes (req ^. reqReturnType) 80 | body = genFnHead fnName pNames <+> genFnBody rParams req 81 | in signature body 82 | 83 | 84 | genGetReaderParams :: [PSParam] -> Doc 85 | genGetReaderParams = stack . map (genGetReaderParam . psVar . _pName) 86 | where 87 | genGetReaderParam pName' = "let" <+> pName' <+> "= spParams_." <> pName' 88 | 89 | 90 | genSignature :: Text -> [PSType] -> Maybe PSType -> Doc 91 | genSignature = genSignatureBuilder $ "forall eff m." <+/> "MonadAsk (SPSettings_ SPParams_) m => MonadError AjaxError m => MonadAff ( ajax :: AJAX | eff) m" <+/> "=>" 92 | 93 | genSignatureBuilder :: Doc -> Text -> [PSType] -> Maybe PSType -> Doc 94 | genSignatureBuilder constraint fnName params mRet = fName <+> "::" <+> align (constraint <+/> parameterString) 95 | where 96 | fName = strictText fnName 97 | retName = maybe "Unit" (strictText . typeInfoToText False) mRet 98 | retString = "m" <+> retName 99 | typeNames = map (strictText . typeInfoToText True) params 100 | parameterString = docIntercalate (softline <> "-> ") (typeNames <> [retString]) 101 | 102 | genFnHead :: Text -> [Text] -> Doc 103 | genFnHead fnName params = fName <+> align (docIntercalate softline docParams <+> "=") 104 | where 105 | docParams = map psVar params 106 | fName = strictText fnName 107 | 108 | genFnBody :: [PSParam] -> Req PSType -> Doc 109 | genFnBody rParams req = "do" 110 | indent 2 ( 111 | "spOpts_' <- ask" 112 | "let spOpts_ = case spOpts_' of SPSettings_ o -> o" 113 | "let spParams_ = case spOpts_.params of SPParams_ ps_ -> ps_" 114 | genGetReaderParams rParams 115 | hang 6 ("let httpMethod =" <+> dquotes (req ^. reqMethod ^. to T.decodeUtf8 ^. to strictText)) 116 | genBuildQueryArgs (req ^. reqUrl ^. queryStr) 117 | hang 6 ("let reqUrl =" <+> genBuildURL (req ^. reqUrl)) 118 | "let reqHeaders =" indent 6 (req ^. reqHeaders ^. to genBuildHeaders) 119 | case req ^. reqBody of 120 | Nothing -> "" 121 | Just _ -> "let encodeJson = case spOpts_.encodeJson of SPSettingsEncodeJson_ e -> e" 122 | "let affReq =" <+> hang 2 ( "defaultRequest" 123 | "{ method =" <+> "httpMethod" 124 | ", url =" <+> "reqUrl" 125 | ", headers =" <+> "defaultRequest.headers <> reqHeaders" 126 | case req ^. reqBody of 127 | Nothing -> "}" 128 | Just _ -> ", content =" <+> "toNullable <<< Just <<< stringify <<< encodeJson $ reqBody" "}" 129 | ) 130 | if shallParseBody (req^.reqReturnType) 131 | then "affResp <- affjax affReq" 132 | "let decodeJson = case spOpts_.decodeJson of SPSettingsDecodeJson_ d -> d" 133 | "getResult affReq decodeJson affResp" 134 | else "_ <- affjax affReq" 135 | "pure unit" 136 | ) <> line 137 | where 138 | shallParseBody Nothing = False 139 | shallParseBody (Just t) = t^.typeName /= "Unit" 140 | 141 | genBuildURL :: Url PSType -> Doc 142 | genBuildURL url = psVar baseURLId <+> "<>" 143 | <+> genBuildPath (url ^. path ) <+> "<>" <+> "queryString" 144 | 145 | ---------- 146 | genBuildPath :: Path PSType -> Doc 147 | genBuildPath = docIntercalate (softline <> "<> \"/\" <> ") . map (genBuildSegment . unSegment) 148 | 149 | genBuildSegment :: SegmentType PSType -> Doc 150 | genBuildSegment (Static (PathSegment seg)) = dquotes $ strictText (textURLEncode False seg) 151 | genBuildSegment (Cap arg) = "encodeURLPiece spOpts_'" <+> arg ^. argName ^. to unPathSegment ^. to psVar 152 | 153 | genBuildQueryArgs :: [QueryArg PSType] -> Doc 154 | genBuildQueryArgs [] = "let queryString = \"\"" 155 | genBuildQueryArgs args = "let queryArgs = catMaybes [" (indent 2 (docIntercalate ("," <> softline) . map genBuildQueryArg $ args)) "]" 156 | "let queryString = if null queryArgs then \"\" else \"?\" <> (joinWith \"&\" queryArgs)" 157 | 158 | ---------- 159 | genBuildQueryArg :: QueryArg PSType -> Doc 160 | genBuildQueryArg arg = case arg ^. queryArgType of 161 | Normal -> genQueryEncoding "encodeQueryItem spOpts_'" "<$>" 162 | Flag -> genQueryEncoding "encodeQueryItem spOpts_'" "<$> Just" 163 | List -> genQueryEncoding "encodeListQuery spOpts_'" "<$> Just" 164 | where 165 | argText = arg ^. queryArgName ^. argName ^. to unPathSegment 166 | encodedArgName = strictText . textURLEncode True $ argText 167 | genQueryEncoding fn op = fn <+> dquotes encodedArgName <+> op <+> psVar argText 168 | 169 | ----------- 170 | 171 | genBuildHeaders :: [HeaderArg PSType] -> Doc 172 | genBuildHeaders = list . map genBuildHeader 173 | 174 | genBuildHeader :: HeaderArg PSType -> Doc 175 | genBuildHeader (HeaderArg arg) = let 176 | argText = arg ^. argName ^. to unPathSegment 177 | encodedArgName = strictText . textURLEncode True $ argText 178 | in 179 | align $ "{ field : " <> dquotes encodedArgName 180 | <+/> comma <+> "value :" 181 | <+> "encodeHeader spOpts_'" <+> psVar argText 182 | "}" 183 | genBuildHeader (ReplaceHeaderArg _ _) = error "ReplaceHeaderArg - not yet implemented!" 184 | 185 | reqsToImportLines :: [Req PSType] -> ImportLines 186 | reqsToImportLines = typesToImportLines Map.empty . Set.fromList . concatMap reqToPSTypes 187 | 188 | reqToPSTypes :: Req PSType -> [PSType] 189 | reqToPSTypes req = map _pType (reqToParams req) ++ maybeToList (req ^. reqReturnType) 190 | 191 | -- | Extract all function parameters from a given Req. 192 | reqToParams :: Req PSType -> [Param PSType] 193 | reqToParams req = Param baseURLId psString 194 | : fmap headerArgToParam (req ^. reqHeaders) 195 | ++ maybeToList (reqBodyToParam (req ^. reqBody)) 196 | ++ urlToParams (req ^. reqUrl) 197 | 198 | urlToParams :: Url PSType -> [Param PSType] 199 | urlToParams url = mapMaybe (segmentToParam . unSegment) (url ^. path) ++ map queryArgToParam (url ^. queryStr) 200 | 201 | segmentToParam :: SegmentType f -> Maybe (Param f) 202 | segmentToParam (Static _) = Nothing 203 | segmentToParam (Cap arg) = Just Param { 204 | _pType = arg ^. argType 205 | , _pName = arg ^. argName ^. to unPathSegment 206 | } 207 | 208 | mkPsMaybe :: PSType -> PSType 209 | mkPsMaybe t = TypeInfo "" "" "Maybe" [t] 210 | 211 | queryArgToParam :: QueryArg PSType -> Param PSType 212 | queryArgToParam arg = Param { 213 | _pType = pType 214 | , _pName = arg ^. queryArgName ^. argName ^. to unPathSegment 215 | } 216 | where 217 | pType = case arg ^. queryArgType of 218 | Normal -> mkPsMaybe (arg ^. queryArgName ^. argType) 219 | _ -> arg ^. queryArgName ^. argType 220 | 221 | headerArgToParam :: HeaderArg f -> Param f 222 | headerArgToParam (HeaderArg arg) = Param { 223 | _pName = arg ^. argName ^. to unPathSegment 224 | , _pType = arg ^. argType 225 | } 226 | headerArgToParam _ = error "We do not support ReplaceHeaderArg - as I have no idea what this is all about." 227 | 228 | reqBodyToParam :: Maybe f -> Maybe (Param f) 229 | reqBodyToParam = fmap (Param "reqBody") 230 | 231 | docIntercalate :: Doc -> [Doc] -> Doc 232 | docIntercalate i = mconcat . punctuate i 233 | 234 | 235 | textURLEncode :: Bool -> Text -> Text 236 | textURLEncode spaceIsPlus = T.decodeUtf8 . urlEncode spaceIsPlus . T.encodeUtf8 237 | 238 | -- | Little helper for generating valid variable names 239 | psVar :: Text -> Doc 240 | psVar = strictText . toPSVarName 241 | -------------------------------------------------------------------------------- /src/Servant/PureScript/Internal.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE ScopedTypeVariables #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TypeOperators #-} 10 | 11 | 12 | module Servant.PureScript.Internal where 13 | 14 | import Control.Lens 15 | 16 | import Data.Bifunctor 17 | import Data.Char 18 | import Data.Monoid 19 | import Data.Proxy 20 | import Data.Set (Set) 21 | import qualified Data.Set as Set 22 | import Data.Text (Text) 23 | import qualified Data.Text as T 24 | import Data.Typeable 25 | 26 | import Language.PureScript.Bridge 27 | import Language.PureScript.Bridge.PSTypes 28 | 29 | 30 | import Servant.Foreign 31 | import Servant.Foreign.Internal 32 | 33 | 34 | -- | Our language type is Paramized, so you can choose a custom 'TypeBridge' for your translation, by 35 | -- providing your own data type and implementing 'HasBridge' for it. 36 | -- 37 | -- > data MyBridge 38 | -- > 39 | -- > myBridge :: TypeBridge 40 | -- > myBridge = defaultBridge <|> customBridge1 <|> customBridge2 41 | -- > 42 | -- > instance HasBridge MyBridge where 43 | -- > languageBridge _ = myBridge 44 | -- 45 | data PureScript bridgeSelector 46 | 47 | instance (Typeable a, HasBridge bridgeSelector) => HasForeignType (PureScript bridgeSelector) PSType a where 48 | typeFor _ _ _ = languageBridge (Proxy :: Proxy bridgeSelector) (mkTypeInfo (Proxy :: Proxy a)) 49 | 50 | class HasBridge a where 51 | languageBridge :: Proxy a -> FullBridge 52 | 53 | -- | Use 'PureScript' 'DefaultBridge' if 'defaultBridge' suffices for your needs. 54 | data DefaultBridge 55 | 56 | -- | 'languageBridge' for 'DefaultBridge' evaluates to 'buildBridge' 'defaultBridge' - no surprise there. 57 | instance HasBridge DefaultBridge where 58 | languageBridge _ = buildBridge defaultBridge 59 | 60 | -- | A proxy for 'DefaultBridge' 61 | defaultBridgeProxy :: Proxy DefaultBridge 62 | defaultBridgeProxy = Proxy 63 | 64 | type ParamName = Text 65 | 66 | data Param f = Param { 67 | _pName :: ParamName 68 | , _pType :: f 69 | } deriving (Eq, Ord, Show) 70 | 71 | type PSParam = Param PSType 72 | 73 | makeLenses ''Param 74 | 75 | 76 | data Settings = Settings { 77 | _apiModuleName :: Text 78 | -- | This function parameters should instead be put in a Reader monad. 79 | -- 80 | -- 'baseUrl' will be put there by default, you can add additional parameters. 81 | -- 82 | -- If your API uses a given parameter name multiple times with different types, 83 | -- only the ones matching the type of the first occurrence 84 | -- will be put in the Reader monad, all others will still be passed as function parameter. 85 | , _readerParams :: Set ParamName 86 | , _standardImports :: ImportLines 87 | -- | If you want codegen for servant-subscriber, set this to True. See the central-counter example 88 | -- for a simple usage case. 89 | , _generateSubscriberAPI :: Bool 90 | } 91 | makeLenses ''Settings 92 | 93 | defaultSettings :: Settings 94 | defaultSettings = Settings { 95 | _apiModuleName = "ServerAPI" 96 | , _readerParams = Set.singleton baseURLId 97 | , _standardImports = importsFromList 98 | [ ImportLine "Control.Monad.Reader.Class" (Set.fromList [ "class MonadAsk", "ask" ]) 99 | , ImportLine "Control.Monad.Error.Class" (Set.fromList [ "class MonadError" ]) 100 | , ImportLine "Control.Monad.Aff.Class" (Set.fromList [ "class MonadAff" ]) 101 | , ImportLine "Network.HTTP.Affjax" (Set.fromList [ "AJAX" ]) 102 | , ImportLine "Data.Nullable" (Set.fromList [ "toNullable" ]) 103 | , ImportLine "Servant.PureScript.Affjax" (Set.fromList [ "AjaxError", "defaultRequest", "affjax" ]) 104 | , ImportLine "Servant.PureScript.Settings" (Set.fromList [ "SPSettings_(..)", "SPSettingsDecodeJson_(..)", "SPSettingsEncodeJson_(..)", "gDefaultToURLPiece" ]) 105 | , ImportLine "Servant.PureScript.Util" (Set.fromList [ "encodeListQuery", "encodeURLPiece", "encodeQueryItem", "getResult", "encodeHeader" ]) 106 | , ImportLine "Prim" (Set.fromList [ "String" ]) -- For baseURL! 107 | , ImportLine "Data.Maybe" (Set.fromList [ "Maybe(..)"]) 108 | , ImportLine "Data.String" (Set.fromList ["joinWith"]) 109 | , ImportLine "Data.Array" (Set.fromList ["catMaybes", "null"]) 110 | , ImportLine "Data.Argonaut.Core" (Set.fromList [ "stringify" ]) 111 | ] 112 | , _generateSubscriberAPI = False 113 | } 114 | 115 | -- | Add a parameter name to be us put in the Reader monad instead of being passed to the 116 | -- generated functions. 117 | addReaderParam :: ParamName -> Settings -> Settings 118 | addReaderParam n opts = opts & over readerParams (Set.insert n) 119 | 120 | baseURLId :: ParamName 121 | baseURLId = "baseURL" 122 | 123 | baseURLParam :: PSParam 124 | baseURLParam = Param baseURLId psString 125 | 126 | subscriberToUserId :: ParamName 127 | subscriberToUserId = "spToUser_" 128 | 129 | makeTypedToUserParam :: PSType -> PSParam 130 | makeTypedToUserParam response = Param subscriberToUserId (psTypedToUser response) 131 | 132 | apiToList :: forall bridgeSelector api. 133 | ( HasForeign (PureScript bridgeSelector) PSType api 134 | , GenerateList PSType (Foreign PSType api) 135 | , HasBridge bridgeSelector 136 | ) => Proxy api -> Proxy bridgeSelector -> [Req PSType] 137 | apiToList _ _ = listFromAPI (Proxy :: Proxy (PureScript bridgeSelector)) (Proxy :: Proxy PSType) (Proxy :: Proxy api) 138 | 139 | 140 | -- | Transform a given identifer to be a valid PureScript variable name (hopefully). 141 | toPSVarName :: Text -> Text 142 | toPSVarName = dropInvalid . unTitle . doPrefix . replaceInvalid 143 | where 144 | unTitle = uncurry mappend . first T.toLower . T.splitAt 1 145 | doPrefix t = let 146 | s = T.head t 147 | cond = isAlpha s || s == '_' 148 | in 149 | if cond then t else "_" <> t 150 | replaceInvalid = T.replace "-" "_" 151 | dropInvalid = let 152 | isValid c = isAlphaNum c || c == '_' 153 | in 154 | T.filter isValid 155 | 156 | psTypedToUser :: PSType -> PSType 157 | psTypedToUser response = TypeInfo { 158 | _typePackage = "purescript-subscriber" 159 | , _typeModule = "Servant.Subscriber.Util" 160 | , _typeName = "TypedToUser" 161 | , _typeParameters = [response, psTypeParameterA] 162 | } 163 | 164 | psSubscriptions :: PSType 165 | psSubscriptions = TypeInfo { 166 | _typePackage = "purescript-subscriber" 167 | , _typeModule = "Servant.Subscriber.Subscriptions" 168 | , _typeName = "Subscriptions" 169 | , _typeParameters = [psTypeParameterA] 170 | } 171 | 172 | psTypeParameterA :: PSType 173 | psTypeParameterA = TypeInfo { 174 | _typePackage = "" 175 | , _typeModule = "" 176 | , _typeName = "a" 177 | , _typeParameters = [] 178 | } 179 | 180 | -- use servant-foreign's camelCaseL legacy version 181 | jsCamelCaseL :: Getter FunctionName Text 182 | jsCamelCaseL = _FunctionName . to (convert . map (T.replace "-" "")) 183 | where 184 | convert [] = "" 185 | convert (p:ps) = mconcat $ p : map capitalize ps 186 | capitalize "" = "" 187 | capitalize name = toUpper (T.head name) `T.cons` T.tail name 188 | -------------------------------------------------------------------------------- /src/Servant/PureScript/MakeRequests.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | -- TODO: This module duplicates quite a lot of code from CodeGen.hs. 10 | module Servant.PureScript.MakeRequests where 11 | 12 | import Control.Lens hiding (List) 13 | import Data.Map (Map) 14 | import Data.Proxy (Proxy (Proxy)) 15 | import qualified Data.Set as Set 16 | import Data.Text (Text) 17 | import qualified Data.Text as T 18 | import qualified Data.Text.Encoding as T 19 | import Language.PureScript.Bridge (ImportLine (..), 20 | PSType, 21 | buildBridge, 22 | defaultBridge, 23 | importsFromList, 24 | mergeImportLines, 25 | mkTypeInfo) 26 | import Servant.Foreign 27 | import Servant.PureScript.CodeGen hiding (genBuildHeader, 28 | genBuildHeaders, 29 | genBuildPath, 30 | genBuildQuery, 31 | genBuildQueryArg, 32 | genBuildSegment, genFnBody, 33 | genFunction, genModule, 34 | genSignature) 35 | import Servant.PureScript.Internal 36 | import Servant.Subscriber.Request (HttpRequest) 37 | import Text.PrettyPrint.Mainland 38 | 39 | subscriberImportLines :: Map Text ImportLine 40 | subscriberImportLines = importsFromList 41 | [ 42 | ImportLine "Servant.Subscriber.Subscriptions" (Set.fromList [ "Subscriptions" 43 | , "makeSubscriptions" 44 | ]) 45 | , ImportLine "Servant.Subscriber.Util" (Set.fromList [ "toUserType" 46 | , "subGenNormalQuery" 47 | , "subGenListQuery" 48 | , "subGenFlagQuery" 49 | , "TypedToUser" 50 | ]) 51 | , ImportLine "Servant.Subscriber" (Set.fromList ["ToUserType"]) 52 | , ImportLine "Servant.Subscriber.Request" (Set.fromList ["HttpRequest(..)"]) 53 | , ImportLine "Servant.Subscriber.Types" (Set.fromList ["Path(..)"]) 54 | , ImportLine "Data.Tuple" (Set.fromList ["Tuple(..)"]) 55 | ] 56 | 57 | genModule :: Settings -> [Req PSType] -> Doc 58 | genModule opts reqs = let 59 | allParams = concatMap reqToParams reqs 60 | rParams = getReaderParams opts allParams 61 | apiImports = reqsToImportLines reqs 62 | webAPIImports = importsFromList [ 63 | ImportLine (opts ^. apiModuleName) (Set.fromList ["SPParams_(..)"]) 64 | ] 65 | imports = _standardImports opts 66 | `mergeImportLines` apiImports 67 | `mergeImportLines` subscriberImportLines 68 | `mergeImportLines` webAPIImports 69 | moduleName = _apiModuleName opts <> ".MakeRequests" 70 | in 71 | genModuleHeader moduleName imports 72 | (docIntercalate line . map (genFunction rParams)) reqs 73 | 74 | genFunction :: [PSParam] -> Req PSType -> Doc 75 | genFunction allRParams req = let 76 | rParamsSet = Set.fromList allRParams 77 | fnName = req ^. reqFuncName ^. jsCamelCaseL 78 | allParamsList = baseURLParam : reqToParams req 79 | allParams = Set.fromList allParamsList 80 | fnParams = filter (not . flip Set.member rParamsSet) allParamsList -- Use list not set, as we don't want to change order of parameters 81 | rParams = Set.toList $ rParamsSet `Set.intersection` allParams 82 | 83 | pTypes = map _pType fnParams 84 | pNames = map _pName fnParams 85 | signature = genSignature fnName pTypes (Just psHttpRequest) 86 | body = genFnHead fnName pNames <+> genFnBody rParams req 87 | in signature body 88 | 89 | 90 | genSignature :: Text -> [PSType] -> Maybe PSType -> Doc 91 | genSignature = genSignatureBuilder $ "forall m." <+/> "MonadAsk (SPSettings_ SPParams_) m" <+/> "=>" 92 | 93 | genFnBody :: [PSParam] -> Req PSType -> Doc 94 | genFnBody rParams req = "do" 95 | indent 2 ( 96 | "spOpts_' <- ask" 97 | "let spOpts_ = case spOpts_' of SPSettings_ o -> o" 98 | "let spParams_ = case spOpts_.params of SPParams_ ps_ -> ps_" 99 | genGetReaderParams rParams 100 | hang 6 ("let httpMethod =" <+> dquotes (req ^. reqMethod ^. to T.decodeUtf8 ^. to strictText)) 101 | hang 6 ("let reqPath =" <+> genBuildPath (req ^. reqUrl . path)) 102 | "let reqHeaders =" indent 6 (req ^. reqHeaders ^. to genBuildHeaders) 103 | "let reqQuery =" indent 6 (req ^. reqUrl ^. queryStr . to genBuildQuery) 104 | "let spReq = " <> hang 2 ("HttpRequest" 105 | "{ httpMethod:" <+> "httpMethod" 106 | ", httpPath:" <+> "reqPath" 107 | ", httpHeaders:" <+> "reqHeaders" 108 | ", httpQuery:" <+> "reqQuery" 109 | ", httpBody:" <+> case req ^. reqBody of 110 | Nothing -> "\"\"" 111 | Just _ -> "stringify <<< encodeJson $ reqBody" 112 | "}") 113 | "pure spReq" 114 | ) <> "\n" 115 | 116 | ---------- 117 | genBuildPath :: Path PSType -> Doc 118 | genBuildPath p = "Path [" 119 | <> (docIntercalate (softline <> ", ") . map (genBuildSegment . unSegment)) p 120 | <> "]" 121 | 122 | genBuildSegment :: SegmentType PSType -> Doc 123 | genBuildSegment (Static (PathSegment seg)) = dquotes $ strictText seg 124 | genBuildSegment (Cap arg) = "gDefaultToURLPiece" <+> arg ^. argName ^. to unPathSegment ^. to psVar 125 | 126 | ---------- 127 | genBuildQuery :: [QueryArg PSType] -> Doc 128 | genBuildQuery [] = "[]" 129 | genBuildQuery args = docIntercalate (softline <> "<> ") . map genBuildQueryArg $ args 130 | 131 | genBuildQueryArg :: QueryArg PSType -> Doc 132 | genBuildQueryArg arg = case arg ^. queryArgType of 133 | Normal -> genQueryEncoding "subGenNormalQuery" 134 | Flag -> genQueryEncoding "subGenFlagQuery" 135 | List -> genQueryEncoding "subGenListQuery" 136 | where 137 | argText = arg ^. queryArgName ^. argName ^. to unPathSegment 138 | argDoc = strictText argText 139 | genQueryEncoding fn = fn <+> dquotes argDoc <+> psVar argText 140 | 141 | ----------- 142 | 143 | genBuildHeaders :: [HeaderArg PSType] -> Doc 144 | genBuildHeaders = list . map genBuildHeader 145 | 146 | genBuildHeader :: HeaderArg PSType -> Doc 147 | genBuildHeader (HeaderArg arg) = let 148 | argText = arg ^. argName ^. to unPathSegment 149 | argDoc = strictText argText 150 | in 151 | align $ "Tuple" <+> dquotes argDoc <+> "(gDefaultToURLPiece" <+> psVar argText <> ")" 152 | genBuildHeader (ReplaceHeaderArg _ _) = error "ReplaceHeaderArg - not yet implemented!" 153 | 154 | 155 | 156 | psHttpRequest :: PSType 157 | psHttpRequest = let 158 | haskType' = mkTypeInfo (Proxy :: Proxy HttpRequest) 159 | bridge = buildBridge defaultBridge 160 | in 161 | bridge haskType' 162 | -------------------------------------------------------------------------------- /src/Servant/PureScript/Subscriber.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | -- TODO: This module duplicates quite a lot of code from MakeRequests.hs. 10 | module Servant.PureScript.Subscriber where 11 | 12 | import Control.Lens hiding (List) 13 | import Data.Map (Map) 14 | import Data.Maybe (mapMaybe, maybeToList) 15 | import qualified Data.Set as Set 16 | import Data.Text (Text) 17 | import qualified Data.Text as T 18 | import qualified Data.Text.Encoding as T 19 | import Language.PureScript.Bridge 20 | import Language.PureScript.Bridge.PSTypes (psString, psUnit) 21 | import Network.HTTP.Types.URI (urlEncode) 22 | import Servant.Foreign 23 | import Servant.PureScript.CodeGen (docIntercalate, genFnHead, 24 | genModuleHeader, 25 | genSignatureBuilder, 26 | getReaderParams, psVar, 27 | reqToParams, 28 | reqsToImportLines) 29 | import Servant.PureScript.Internal 30 | import Servant.PureScript.MakeRequests hiding (genFnBody, 31 | genFunction, genModule, 32 | genSignature) 33 | import Text.PrettyPrint.Mainland 34 | 35 | genModule :: Settings -> [Req PSType] -> Doc 36 | genModule opts allReqs = let 37 | isSubscribable :: Req PSType -> Bool 38 | isSubscribable req = T.empty `elem` req ^.reqFuncName . to unFunctionName 39 | reqs = filter isSubscribable allReqs 40 | allParams = concatMap reqToParams allReqs 41 | rParams = getReaderParams opts allParams 42 | apiImports = reqsToImportLines reqs 43 | webAPIImports = importsFromList [ 44 | ImportLine (opts ^. apiModuleName) (Set.fromList ["SPParams_(..)"]) 45 | ] 46 | imports = _standardImports opts 47 | `mergeImportLines` apiImports 48 | `mergeImportLines` subscriberImportLines 49 | `mergeImportLines` webAPIImports 50 | moduleName = _apiModuleName opts <> ".Subscriber" 51 | in 52 | genModuleHeader moduleName imports 53 | "import" <+> opts ^. apiModuleName . to strictText <> ".MakeRequests as MakeRequests" 54 | "" 55 | (docIntercalate line . map (genFunction rParams)) reqs 56 | 57 | genFunction :: [PSParam] -> Req PSType -> Doc 58 | genFunction allRParams req = let 59 | rParamsSet = Set.fromList allRParams 60 | fnName = req ^. reqFuncName ^. jsCamelCaseL 61 | responseType = case req ^. reqReturnType of 62 | Nothing -> psUnit 63 | Just t -> t 64 | allParamsList = makeTypedToUserParam responseType : baseURLParam : reqToParams req 65 | fnParams = filter (not . flip Set.member rParamsSet) allParamsList -- Use list not set, as we don't want to change order of parameters 66 | 67 | pTypes = map _pType fnParams 68 | pNames = map _pName fnParams 69 | signature = genSignature fnName pTypes (Just psSubscriptions) 70 | -- | Well - if you really want to put the ToUserType parameter into the Reader monad - this will crash: 71 | body = genFnHead fnName pNames <+> genFnBody fnName (tail pNames) 72 | in signature body 73 | 74 | 75 | genSignature :: Text -> [PSType] -> Maybe PSType -> Doc 76 | genSignature = genSignatureBuilder $ "forall m a." <+/> "MonadAsk (SPSettings_ SPParams_) m" <+/> "=>" 77 | 78 | genFnBody :: Text -> [Text] -> Doc 79 | genFnBody fName params = "do" 80 | indent 2 ( 81 | "spReq <- MakeRequests." <> genFnCall fName params 82 | "pure $ makeSubscriptions spReq (toUserType " <> strictText subscriberToUserId <> ")" 83 | ) <> "\n" 84 | 85 | genFnCall :: Text -> [Text] -> Doc 86 | genFnCall fnName params = fName <+> align (docIntercalate softline docParams) 87 | where 88 | docParams = map psVar params 89 | fName = strictText fnName 90 | -------------------------------------------------------------------------------- /stack-7.10.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-6.15 2 | packages: 3 | - '.' 4 | - './examples/central-counter' 5 | # - '../servant-subscriber' 6 | # - '../purescript-bridge' 7 | extra-deps: 8 | - purescript-bridge-0.8.0.0 9 | - servant-subscriber-0.5.0.2 10 | 11 | flags: {} 12 | 13 | extra-package-dbs: [] 14 | 15 | nix: 16 | shell-file: stack.nix 17 | -------------------------------------------------------------------------------- /stack-8.0.nix: -------------------------------------------------------------------------------- 1 | with (import {}); 2 | let 3 | ghc = haskellPackages.ghc; 4 | in 5 | haskell.lib.buildStackProject { 6 | name = "myEnv"; 7 | # buildInputs = [ gcc git zlib pkgconfig ghc glibcLocales ]; 8 | buildInputs = [ zlib haskellPackages.ghc-mod ]; 9 | ghc = ghc; 10 | shellHook = "export SSL_CERT_FILE=/etc/ssl/certs/ca-bundle.crt"; 11 | } 12 | -------------------------------------------------------------------------------- /stack-8.0.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-8.12 2 | packages: 3 | - '.' 4 | - './examples/central-counter' 5 | # - '../servant-subscriber' 6 | # - '../purescript-bridge' 7 | 8 | flags: {} 9 | 10 | extra-package-dbs: [] 11 | 12 | nix: 13 | shell-file: stack-8.0.nix 14 | -------------------------------------------------------------------------------- /stack.nix: -------------------------------------------------------------------------------- 1 | with (import {}); 2 | let 3 | haskellPackages = haskell.packages.lts-6_7; 4 | ghc = haskellPackages.ghc; 5 | in 6 | haskell.lib.buildStackProject { 7 | name = "myEnv"; 8 | # buildInputs = [ gcc git zlib pkgconfig ghc glibcLocales ]; 9 | buildInputs = [ zlib haskellPackages.ghc-mod ]; 10 | ghc = ghc; 11 | shellHook = "export SSL_CERT_FILE=/etc/ssl/certs/ca-bundle.crt"; 12 | } 13 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | 9 | 10 | module Main where 11 | 12 | import Control.Applicative 13 | import Control.Lens 14 | import Data.Aeson 15 | import Data.Proxy 16 | import qualified Data.Set as Set 17 | import Data.Text (Text) 18 | import qualified Data.Text.IO as T 19 | import Data.Typeable 20 | import GHC.Generics 21 | import Language.PureScript.Bridge 22 | import Language.PureScript.Bridge.PSTypes 23 | import Servant.API 24 | import Servant.Foreign 25 | import Servant.PureScript 26 | import Servant.PureScript.CodeGen 27 | import Servant.PureScript.Internal 28 | import Text.PrettyPrint.Mainland (hPutDocLn) 29 | 30 | 31 | data Hello = Hello { 32 | message :: Text 33 | } deriving Generic 34 | 35 | instance FromJSON Hello 36 | instance ToJSON Hello 37 | 38 | newtype TestHeader = TestHeader Text deriving (Generic, Show, Eq) 39 | 40 | instance ToJSON TestHeader 41 | 42 | type MyAPI = Header "TestHeader" TestHeader :> QueryFlag "myFlag" :> QueryParam "myParam" Hello :> QueryParams "myParams" Hello :> "hello" :> ReqBody '[JSON] Hello :> Get '[JSON] Hello 43 | :<|> Header "TestHeader" Hello :> "testHeader" :> Get '[JSON] TestHeader 44 | :<|> Header "TestHeader" TestHeader :> "by" :> Get '[JSON] Int 45 | 46 | 47 | reqs = apiToList (Proxy :: Proxy MyAPI) (Proxy :: Proxy DefaultBridge) 48 | req = head reqs 49 | 50 | mySettings = addReaderParam "TestHeader" defaultSettings 51 | 52 | myTypes :: [SumType 'Haskell] 53 | myTypes = [ 54 | mkSumType (Proxy :: Proxy Hello) 55 | , mkSumType (Proxy :: Proxy TestHeader) 56 | ] 57 | 58 | moduleTranslator :: BridgePart 59 | moduleTranslator = do 60 | typeModule ^== "Main" 61 | t <- view haskType 62 | TypeInfo (_typePackage t) "ServerTypes" (_typeName t) <$> psTypeParameters 63 | 64 | myBridge :: BridgePart 65 | myBridge = defaultBridge <|> moduleTranslator 66 | 67 | data MyBridge 68 | 69 | instance HasBridge MyBridge where 70 | languageBridge _ = buildBridge myBridge 71 | 72 | myBridgeProxy :: Proxy MyBridge 73 | myBridgeProxy = Proxy 74 | 75 | main :: IO () 76 | main = do 77 | writeAPIModuleWithSettings mySettings "test/output" myBridgeProxy (Proxy :: Proxy MyAPI) 78 | writePSTypes "test/output" (buildBridge myBridge) myTypes 79 | -------------------------------------------------------------------------------- /test/output/.KEEP: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/eskimor/servant-purescript/c916e03ae9cf27b6fee59c4cf2a568bf4e8b0cfe/test/output/.KEEP --------------------------------------------------------------------------------