├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── .travis.yml ├── CHANGELOG.md ├── LICENSE ├── README.md ├── Setup.hs ├── example └── greet.hs ├── servant-cli.cabal ├── src └── Servant │ ├── CLI.hs │ └── CLI │ ├── HasCLI.hs │ ├── Internal │ └── PStruct.hs │ └── ParseBody.hs └── test └── Spec.hs /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | # Haskell stack project Github Actions template 2 | # https://gist.github.com/mstksg/11f753d891cee5980326a8ea8c865233 3 | # 4 | # To use, mainly change the list in 'plans' and modify 'include' for 5 | # any OS package manager deps. 6 | # 7 | # Currently not working for cabal-install >= 3 8 | # 9 | # Based on https://raw.githubusercontent.com/commercialhaskell/stack/stable/doc/travis-complex.yml 10 | # 11 | # TODO: 12 | # * cache (https://github.com/actions/cache) 13 | # but this is too small. native cacheing will come soon 14 | # https://github.community/t5/GitHub-Actions/Caching-files-between-GitHub-Action-executions/m-p/30974/highlight/true#M630 15 | # so we can wait for then. 16 | # * support for cabal-install >= 3 17 | 18 | name: Haskell Stack Project CI 19 | 20 | on: 21 | push: 22 | schedule: 23 | - cron: "0 0 * * 1" 24 | 25 | jobs: 26 | build: 27 | strategy: 28 | matrix: 29 | os: [ubuntu-latest, macOS-latest] 30 | # use this to specify what resolvers and ghc to use 31 | plan: 32 | # - { build: stack, resolver: "--resolver lts-9" } # ghc-8.0.2 33 | # - { build: stack, resolver: "--resolver lts-11" } # ghc-8.2.2 34 | # - { build: stack, resolver: "--resolver lts-12" } # ghc-8.4.4 35 | # - { build: stack, resolver: "--resolver lts-13" } redundant because lts-14 checks ghc-8.6 already 36 | - { build: stack, resolver: "--resolver lts-14" } # ghc-8.6.5 37 | - { build: stack, resolver: "--resolver nightly" } 38 | - { build: stack, resolver: "" } 39 | # - { build: cabal, ghc: 8.0.2, cabal-install: "2.0" } 40 | # - { build: cabal, ghc: 8.2.2, cabal-install: "2.0" } 41 | # - { build: cabal, ghc: 8.4.4, cabal-install: "2.2" } 42 | - { build: cabal, ghc: 8.6.5, cabal-install: "2.4" } 43 | - { build: cabal, ghc: 8.8.1, cabal-install: "2.4" } # currently not working for >= 3.0 44 | # use this to include any dependencies from OS package managers 45 | include: 46 | - os: ubuntu-latest 47 | apt-get: happy 48 | 49 | exclude: 50 | - os: macOS-latest 51 | plan: 52 | build: cabal 53 | 54 | runs-on: ${{ matrix.os }} 55 | steps: 56 | - name: Install OS Packages 57 | uses: mstksg/get-package@v1 58 | with: 59 | apt-get: ${{ matrix.apt-get }} 60 | brew: ${{ matrix.brew }} 61 | - uses: actions/checkout@v1 62 | 63 | - name: Setup stack 64 | uses: mstksg/setup-stack@v1 65 | 66 | - name: Setup cabal-install 67 | uses: actions/setup-haskell@v1 68 | with: 69 | ghc-version: ${{ matrix.plan.ghc }} 70 | cabal-version: ${{ matrix.plan.cabal-install }} 71 | if: matrix.plan.build == 'cabal' 72 | 73 | - name: Install dependencies 74 | run: | 75 | set -ex 76 | case "$BUILD" in 77 | stack) 78 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 79 | ;; 80 | cabal) 81 | cabal --version 82 | cabal update 83 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 84 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 85 | ;; 86 | esac 87 | set +ex 88 | env: 89 | ARGS: ${{ matrix.plan.resolver }} 90 | BUILD: ${{ matrix.plan.build }} 91 | 92 | - name: Build 93 | run: | 94 | set -ex 95 | case "$BUILD" in 96 | stack) 97 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 98 | ;; 99 | cabal) 100 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 101 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 102 | 103 | ORIGDIR=$(pwd) 104 | for dir in $PACKAGES 105 | do 106 | cd $dir 107 | cabal check || [ "$CABALVER" == "1.16" ] 108 | cabal sdist 109 | PKGVER=$(cabal info . | awk '{print $2;exit}') 110 | SRC_TGZ=$PKGVER.tar.gz 111 | cd dist 112 | tar zxfv "$SRC_TGZ" 113 | cd "$PKGVER" 114 | cabal configure --enable-tests --ghc-options -O0 115 | cabal build 116 | if [ "$CABALVER" = "1.16" ] || [ "$CABALVER" = "1.18" ]; then 117 | cabal test 118 | else 119 | cabal test --show-details=streaming --log=/dev/stdout 120 | fi 121 | cd $ORIGDIR 122 | done 123 | ;; 124 | esac 125 | set +ex 126 | env: 127 | ARGS: ${{ matrix.plan.resolver }} 128 | BUILD: ${{ matrix.plan.build }} 129 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | .stack-work/ 2 | stack.yaml.lock 3 | example/greet 4 | example/greet.hi 5 | example/greet.o 6 | dist-newstyle 7 | .ghc.environment* 8 | *~ 9 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | script: 2 | - | 3 | set -ex 4 | case "$BUILD" in 5 | stack) 6 | stack --no-terminal $ARGS test --bench --no-run-benchmarks --haddock --no-haddock-deps 7 | ;; 8 | cabal) 9 | cabal install --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 10 | 11 | ORIGDIR=$(pwd) 12 | for dir in $PACKAGES 13 | do 14 | cd $dir 15 | cabal check || [ "$CABALVER" == "1.16" ] 16 | cabal sdist 17 | PKGVER=$(cabal info . | awk '{print $2;exit}') 18 | SRC_TGZ=$PKGVER.tar.gz 19 | cd dist 20 | tar zxfv "$SRC_TGZ" 21 | cd "$PKGVER" 22 | cabal configure --enable-tests --ghc-options -O0 23 | cabal build 24 | if [ "$CABALVER" = "1.16" ] || [ "$CABALVER" = "1.18" ]; then 25 | cabal test 26 | else 27 | cabal test --show-details=streaming --log=/dev/stdout 28 | fi 29 | cd $ORIGDIR 30 | done 31 | ;; 32 | esac 33 | set +ex 34 | matrix: 35 | include: 36 | - env: BUILD=cabal GHCVER=8.6.5 CABALVER=2.4 HAPPYVER=1.19.5 ALEXVER=3.1.7 37 | addons: 38 | apt: 39 | sources: 40 | - hvr-ghc 41 | packages: 42 | - cabal-install-2.4 43 | - ghc-8.6.5 44 | - happy-1.19.5 45 | - alex-3.1.7 46 | compiler: ': #GHC 8.6.5' 47 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 48 | addons: 49 | apt: 50 | sources: 51 | - hvr-ghc 52 | packages: 53 | - cabal-install-head 54 | - ghc-head 55 | - happy-1.19.5 56 | - alex-3.1.7 57 | compiler: ': #GHC HEAD' 58 | - env: BUILD=stack ARGS="" 59 | addons: 60 | apt: 61 | packages: 62 | - libgmp-dev 63 | compiler: ': #stack default' 64 | - env: BUILD=stack ARGS="--resolver lts-13" 65 | addons: 66 | apt: 67 | packages: 68 | - libgmp-dev 69 | compiler: ': #stack 8.6.5' 70 | - env: BUILD=stack ARGS="--resolver nightly" 71 | addons: 72 | apt: 73 | packages: 74 | - libgmp-dev 75 | compiler: ': #stack nightly' 76 | - env: BUILD=stack ARGS="" 77 | os: osx 78 | compiler: ': #stack default osx' 79 | - env: BUILD=stack ARGS="--resolver lts-13" 80 | os: osx 81 | compiler: ': #stack 8.6.5 osx' 82 | - env: BUILD=stack ARGS="--resolver nightly" 83 | os: osx 84 | compiler: ': #stack nightly osx' 85 | allow_failures: 86 | - env: BUILD=cabal GHCVER=head CABALVER=head HAPPYVER=1.19.5 ALEXVER=3.1.7 87 | - env: BUILD=stack ARGS="--resolver nightly" 88 | install: 89 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo 90 | '?')]" 91 | - if [ -f configure.ac ]; then autoreconf -i; fi 92 | - | 93 | set -ex 94 | case "$BUILD" in 95 | stack) 96 | # Add in extra-deps for older snapshots, as necessary 97 | # 98 | # This is disabled by default, as relying on the solver like this can 99 | # make builds unreliable. Instead, if you have this situation, it's 100 | # recommended that you maintain multiple stack-lts-X.yaml files. 101 | 102 | #stack --no-terminal --install-ghc $ARGS test --bench --dry-run || ( \ 103 | # stack --no-terminal $ARGS build cabal-install && \ 104 | # stack --no-terminal $ARGS solver --update-config) 105 | 106 | # Build the dependencies 107 | stack --no-terminal --install-ghc $ARGS test --bench --only-dependencies 108 | ;; 109 | cabal) 110 | cabal --version 111 | travis_retry cabal update 112 | 113 | # Get the list of packages from the stack.yaml file. Note that 114 | # this will also implicitly run hpack as necessary to generate 115 | # the .cabal files needed by cabal-install. 116 | PACKAGES=$(stack --install-ghc query locals | grep '^ *path' | sed 's@^ *path:@@') 117 | 118 | cabal install --only-dependencies --enable-tests --enable-benchmarks --force-reinstalls --ghc-options=-O0 --reorder-goals --max-backjumps=-1 $CABALARGS $PACKAGES 119 | ;; 120 | esac 121 | set +ex 122 | cache: 123 | directories: 124 | - $HOME/.ghc 125 | - $HOME/.cabal 126 | - $HOME/.stack 127 | - $TRAVIS_BUILD_DIR/.stack-work 128 | before_install: 129 | - unset CC 130 | - CABALARGS="" 131 | - if [ "x$GHCVER" = "xhead" ]; then CABALARGS=--allow-newer; fi 132 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$HOME/.local/bin:/opt/alex/$ALEXVER/bin:/opt/happy/$HAPPYVER/bin:$HOME/.cabal/bin:$PATH 133 | - mkdir -p ~/.local/bin 134 | - | 135 | if [ `uname` = "Darwin" ] 136 | then 137 | travis_retry curl --insecure -L https://get.haskellstack.org/stable/osx-x86_64.tar.gz | tar xz --strip-components=1 --include '*/stack' -C ~/.local/bin 138 | else 139 | travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 140 | fi 141 | 142 | # Use the more reliable S3 mirror of Hackage 143 | mkdir -p $HOME/.cabal 144 | echo 'remote-repo: hackage.haskell.org:http://hackage.fpcomplete.com/' > $HOME/.cabal/config 145 | echo 'remote-repo-cache: $HOME/.cabal/packages' >> $HOME/.cabal/config 146 | language: generic 147 | sudo: false 148 | 149 | -------------------------------------------------------------------------------- /CHANGELOG.md: -------------------------------------------------------------------------------- 1 | Changelog 2 | ========= 3 | 4 | Version 0.1.1.0 5 | --------------- 6 | 7 | *January 12, 2024* 8 | 9 | 10 | 11 | * Support for `QueryParams` and `NoContentVerb` 12 | 13 | Version 0.1.0.3 14 | --------------- 15 | 16 | *January 12, 2024* 17 | 18 | 19 | 20 | * Move to servant-client-core >= 0.20, breaks compatibility with previous 21 | versions. 22 | * Compatibility with opt-parse applicative >= 0.18 23 | 24 | Version 0.1.0.2 25 | --------------- 26 | 27 | *November 18, 2019* 28 | 29 | 30 | 31 | * Update to support *functor-combinators-0.2.0.0* 32 | 33 | Version 0.1.0.1 34 | --------------- 35 | 36 | *June 19, 2019* 37 | 38 | 39 | 40 | * Minor rewrite to use *functor-combinators* under the hood. 41 | 42 | Version 0.1.0.0 43 | --------------- 44 | 45 | *May 3, 2019* 46 | 47 | 48 | 49 | * Initial release 50 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Justin Le (c) 2019 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 Justin Le 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 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # servant-cli 2 | 3 | Parse command line arguments into a servant client, from a servant API, using 4 | *optparse-applicative* for parsing, displaying help, and auto-completion. 5 | 6 | Hooks into the annotation system used by *servant-docs* to provide descriptions 7 | for parameters and captures. 8 | 9 | See `example/greet.hs` for a sample program. 10 | 11 | Getting started 12 | --------------- 13 | 14 | We're going to break down the example program in `example/greet.hs`. 15 | 16 | Here's a sample API revolving around greeting and some deep paths, with 17 | authentication. 18 | 19 | ```haskell 20 | type TestApi = 21 | Summary "Send a greeting" 22 | :> "hello" 23 | :> Capture "name" Text 24 | :> QueryParam "capital" Bool 25 | :> Get '[JSON] Text 26 | :<|> Summary "Greet utilities" 27 | :> "greet" 28 | :> ( Get '[JSON] Int 29 | :<|> Post '[JSON] NoContent 30 | ) 31 | :<|> Summary "Deep paths test" 32 | :> "dig" 33 | :> "down" 34 | :> "deep" 35 | :> Summary "Almost there" 36 | :> Capture "name" Text 37 | :> "more" 38 | :> Summary "We made it" 39 | :> Get '[JSON] Text 40 | 41 | testApi :: Proxy TestApi 42 | testApi = Proxy 43 | ``` 44 | 45 | To parse this, we can use `parseClient`, which generates a client action that 46 | we can run: 47 | 48 | ```haskell 49 | main :: IO () 50 | main = do 51 | c <- parseClient testApi (Proxy :: Proxy ClientM) $ 52 | header "greet" 53 | <> progDesc "Greet API" 54 | 55 | manager' <- newManager defaultManagerSettings 56 | res <- runClientM c $ 57 | mkClientEnv manager' (BaseUrl Http "localhost" 8081 "") 58 | 59 | case res of 60 | Left e -> throwIO e 61 | Right r -> putStrLn $ case r of 62 | Left g -> "Greeting: " ++ T.unpack g 63 | Right (Left (Left i)) -> show i ++ " returned" 64 | Right (Left (Right _)) -> "Posted!" 65 | Right (Right s) -> s 66 | ``` 67 | 68 | Note that `parseClient` and other functions all take `InfoMod`s from 69 | *optparse-applicative*, to customize how the top-level `--help` is displayed. 70 | 71 | The result will be a bunch of nested `Either`s for each `:<|>` branch and 72 | endpoint. However, this can be somewhat tedious to handle. 73 | 74 | With Handlers 75 | ------------- 76 | 77 | The library also offers `parseHandleClient`, which accepts nested `:<|>`s with 78 | handlers for each endpoint, mirroring the structure of the API: 79 | 80 | ```haskell 81 | main :: IO () 82 | main = do 83 | c <- parseHandleClient testApi (Proxy :: Proxy ClientM) 84 | (header "greet" <> progDesc "Greet API") $ 85 | (\g -> "Greeting: " ++ T.unpack g) 86 | :<|> ( (\i -> show i ++ " returned") 87 | :<|> (\_ -> "Posted!") 88 | ) 89 | :<|> id 90 | 91 | manager' <- newManager defaultManagerSettings 92 | res <- runClientM c $ 93 | mkClientEnv manager' (BaseUrl Http "localhost" 8081 "") 94 | 95 | case res of 96 | Left e -> throwIO e 97 | Right r -> putStrLn r 98 | ``` 99 | 100 | The handlers essentially let you specify how to sort each potential endpoint's 101 | response into a single output value. 102 | 103 | Clients that need context 104 | ------------------------- 105 | 106 | Things get slightly more complicated when your client requires something that 107 | can't be passed in through the command line, such as authentication information 108 | (username, password). 109 | 110 | ```haskell 111 | type TestApi = 112 | Summary "Send a greeting" 113 | :> "hello" 114 | :> Capture "name" Text 115 | :> QueryParam "capital" Bool 116 | :> Get '[JSON] Text 117 | :<|> Summary "Greet utilities" 118 | :> "greet" 119 | :> ( Get '[JSON] Int 120 | :<|> BasicAuth "login" Int -- ^ Adding 'BasicAuth' 121 | :> Post '[JSON] NoContent 122 | ) 123 | :<|> Summary "Deep paths test" 124 | :> "dig" 125 | :> "down" 126 | :> "deep" 127 | :> Summary "Almost there" 128 | :> Capture "name" Text 129 | :> "more" 130 | :> Summary "We made it" 131 | :> Get '[JSON] Text 132 | ``` 133 | 134 | For this, you can pass in a context, using `parseClientWithContext` or 135 | `parseHandleClientWithContext`: 136 | 137 | ```haskell 138 | main :: IO () 139 | main = do 140 | c <- parseHandleClientWithContext 141 | testApi 142 | (Proxy :: Proxy ClientM) 143 | (getPwd :& RNil) 144 | (header "greet" <> progDesc "Greet API") $ 145 | (\g -> "Greeting: " ++ T.unpack g) 146 | :<|> ( (\i -> show i ++ " returned") 147 | :<|> (\_ -> "Posted!") 148 | ) 149 | :<|> id 150 | 151 | manager' <- newManager defaultManagerSettings 152 | res <- runClientM c $ 153 | mkClientEnv manager' (BaseUrl Http "localhost" 8081 "") 154 | 155 | case res of 156 | Left e -> throwIO e 157 | Right r -> putStrLn r 158 | where 159 | getPwd :: ContextFor ClientM (BasicAuth "login" Int) 160 | getPwd = GenBasicAuthData . liftIO $ do 161 | putStrLn "Authentication needed for this action!" 162 | putStrLn "Enter username:" 163 | n <- BS.getLine 164 | putStrLn "Enter password:" 165 | p <- BS.getLine 166 | pure $ BasicAuthData n p 167 | ``` 168 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /example/greet.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE TypeApplications #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# OPTIONS_GHC -fno-warn-orphans #-} 9 | 10 | import Control.Concurrent 11 | import Control.Exception 12 | import Control.Monad.IO.Class 13 | import Data.Aeson 14 | import Data.Maybe 15 | import Data.Proxy 16 | import Data.Text (Text) 17 | import Data.Vinyl 18 | import GHC.Generics 19 | import Network.HTTP.Client (newManager, defaultManagerSettings) 20 | import Network.Wai.Handler.Warp (run) 21 | import Options.Applicative (header, progDesc) 22 | import Servant.API 23 | import Servant.CLI 24 | import Servant.Client 25 | import Servant.Server 26 | import System.Random 27 | import qualified Data.ByteString as BS 28 | import qualified Data.Map as M 29 | import qualified Data.Text as T 30 | 31 | 32 | -- * Example 33 | 34 | -- | A greet message data type 35 | newtype Greet = Greet Text 36 | deriving (Generic, Show) 37 | 38 | instance ParseBody Greet where 39 | parseBody = Greet <$> parseBody 40 | 41 | -- | We can get JSON support automatically. This will be used to parse 42 | -- and encode a Greeting as 'JSON'. 43 | instance FromJSON Greet 44 | instance ToJSON Greet 45 | 46 | -- We add some useful annotations to our captures, 47 | -- query parameters and request body to make the docs 48 | -- really helpful. 49 | instance ToCapture (Capture "name" Text) where 50 | toCapture _ = DocCapture "name" "name of the person to greet" 51 | 52 | instance ToParam (QueryParam "capital" Bool) where 53 | toParam _ = 54 | DocQueryParam "capital" 55 | ["true", "false"] 56 | "Get the greeting message in uppercase (true) or not (false). Default is false." 57 | Normal 58 | 59 | instance ToAuthInfo (BasicAuth "login" Int) where 60 | toAuthInfo _ = 61 | DocAuthentication "Login credientials" 62 | "Username and password" 63 | 64 | type TestApi = 65 | Summary "Send a greeting" 66 | :> "hello" 67 | :> Capture "name" Text 68 | :> QueryParam "capital" Bool 69 | :> Get '[JSON] Greet 70 | :<|> Summary "Greet utilities" 71 | :> "greet" 72 | :> ReqBody '[JSON] Greet 73 | :> ( Get '[JSON] Int 74 | :<|> BasicAuth "login" Int 75 | :> Post '[JSON] NoContent 76 | ) 77 | :<|> Summary "Deep paths test" 78 | :> "dig" 79 | :> "down" 80 | :> "deep" 81 | :> Summary "Almost there" 82 | :> Capture "name" Text 83 | :> "more" 84 | :> Summary "We made it" 85 | :> Get '[JSON] Text 86 | 87 | 88 | testApi :: Proxy TestApi 89 | testApi = Proxy 90 | 91 | server :: Application 92 | server = serveWithContext testApi (authCheck :. EmptyContext) $ 93 | (\t b -> pure . Greet $ "Hello, " 94 | <> if fromMaybe False b 95 | then T.toUpper t 96 | else t 97 | ) 98 | :<|> (\(Greet g) -> pure (T.length g) 99 | :<|> (\_ -> pure NoContent) 100 | ) 101 | :<|> (pure . T.reverse) 102 | where 103 | -- | Map of valid users and passwords 104 | userMap = M.fromList [("alice", "password"), ("bob", "hunter2")] 105 | authCheck = BasicAuthCheck $ \(BasicAuthData u p) -> 106 | case M.lookup u userMap of 107 | Nothing -> pure NoSuchUser 108 | Just p' 109 | | p == p' -> Authorized <$> randomIO @Int 110 | | otherwise -> pure BadPassword 111 | 112 | -- | Safely shutdown the server when we're done 113 | withServer :: IO () -> IO () 114 | withServer action = 115 | bracket (forkIO $ run 8081 server) 116 | killThread 117 | (const action) 118 | 119 | main :: IO () 120 | main = do 121 | c <- parseHandleClientWithContext 122 | testApi 123 | (Proxy :: Proxy ClientM) 124 | (getPwd :& RNil) 125 | cinfo $ 126 | (\(Greet g) -> "Greeting: " ++ T.unpack g) 127 | :<|> ( (\i -> show i ++ " letters") 128 | :<|> (\_ -> "posted!") 129 | ) 130 | :<|> (\s -> "Reversed: " ++ T.unpack s) 131 | 132 | withServer $ do 133 | 134 | manager' <- newManager defaultManagerSettings 135 | res <- runClientM c (mkClientEnv manager' (BaseUrl Http "localhost" 8081 "")) 136 | 137 | case res of 138 | Left e -> throwIO e 139 | Right rstring -> putStrLn rstring 140 | where 141 | cinfo = header "greet" <> progDesc "Greet API" 142 | getPwd :: ContextFor ClientM (BasicAuth "login" Int) 143 | getPwd = GenBasicAuthData . liftIO $ do 144 | putStrLn "Authentication needed for this action!" 145 | putStrLn "(Hint: try 'bob' and 'hunter2')" 146 | putStrLn "Enter username:" 147 | n <- BS.getLine 148 | putStrLn "Enter password:" 149 | p <- BS.getLine 150 | pure $ BasicAuthData n p 151 | -------------------------------------------------------------------------------- /servant-cli.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 1.12 2 | 3 | -- This file has been generated from package.yaml by hpack version 0.35.2. 4 | -- 5 | -- see: https://github.com/sol/hpack 6 | 7 | name: servant-cli 8 | version: 0.1.1.0 9 | synopsis: Command line interface for Servant API clients 10 | description: Parse command line arguments into a servant client, from a servant API, 11 | using /optparse-applicative/ for parsing, displaying help, and 12 | auto-completion. 13 | . 14 | Hooks into the annotation system used by /servant-docs/ to provide descriptions 15 | for parameters and captures. 16 | . 17 | See @example/greet.hs@ for an example usage, and the 18 | for a tutorial. 19 | category: Web 20 | homepage: https://github.com/mstksg/servant-cli#readme 21 | bug-reports: https://github.com/mstksg/servant-cli/issues 22 | author: Justin Le 23 | maintainer: justin@jle.im 24 | copyright: (c) Justin Le 2019 25 | license: BSD3 26 | license-file: LICENSE 27 | build-type: Simple 28 | tested-with: 29 | GHC >= 8.6 30 | extra-source-files: 31 | README.md 32 | CHANGELOG.md 33 | 34 | source-repository head 35 | type: git 36 | location: https://github.com/mstksg/servant-cli 37 | 38 | library 39 | exposed-modules: 40 | Servant.CLI 41 | Servant.CLI.HasCLI 42 | Servant.CLI.Internal.PStruct 43 | Servant.CLI.ParseBody 44 | other-modules: 45 | Paths_servant_cli 46 | hs-source-dirs: 47 | src 48 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -Werror=incomplete-patterns 49 | build-depends: 50 | base >=4.12 && <5 51 | , bytestring 52 | , case-insensitive 53 | , containers 54 | , filepath 55 | , free 56 | , functor-combinators >=0.2 57 | , http-types 58 | , optparse-applicative 59 | , profunctors 60 | , recursion-schemes 61 | , servant >=0.15 62 | , servant-client-core >= 0.20 63 | , servant-docs 64 | , text 65 | , transformers 66 | , vinyl 67 | default-language: Haskell2010 68 | 69 | executable greet-cli 70 | main-is: greet.hs 71 | other-modules: 72 | Paths_servant_cli 73 | hs-source-dirs: 74 | example 75 | ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -Werror=incomplete-patterns 76 | build-depends: 77 | aeson 78 | , base >=4.12 && <5 79 | , bytestring 80 | , containers 81 | , http-client 82 | , optparse-applicative 83 | , random 84 | , servant >=0.15 85 | , servant-cli 86 | , servant-client 87 | , servant-server 88 | , text 89 | , vinyl 90 | , warp 91 | default-language: Haskell2010 92 | -------------------------------------------------------------------------------- /src/Servant/CLI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE PolyKinds #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE TypeFamilies #-} 9 | {-# LANGUAGE UndecidableInstances #-} 10 | 11 | -- | 12 | -- Module : Servant.CLI 13 | -- Copyright : (c) Justin Le 2019 14 | -- License : BSD3 15 | -- 16 | -- Maintainer : justin@jle.im 17 | -- Stability : experimental 18 | -- Portability : non-portable 19 | -- 20 | -- Parse command line arguments into a servant client, from a servant API. 21 | -- 22 | -- Mainly used through 'parseClient' and 'parseHandleClient'. 23 | -- 'parseClient' returns a servant client action that returns nested 24 | -- 'Either's for every endpoint, but 'parseHandleClient' allows you to 25 | -- conveniently specify how you want to sort each endpoint entry into 26 | -- a single result. 27 | -- 28 | -- See for 29 | -- a tutorial. 30 | module Servant.CLI 31 | ( -- * Parse Client 32 | parseClient, 33 | parseHandleClient, 34 | 35 | -- ** With context 36 | parseClientWithContext, 37 | parseHandleClientWithContext, 38 | 39 | -- * Typeclasses 40 | HasCLI (CLIResult, CLIHandler, cliHandler), 41 | 42 | -- * Context 43 | ContextFor (..), 44 | NamedContext (..), 45 | descendIntoNamedContext, 46 | 47 | -- * Lower-level 48 | cliPStruct, 49 | cliPStructWithContext, 50 | structParser, 51 | 52 | -- ** With context 53 | cliHandlePStruct, 54 | cliHandlePStructWithContext, 55 | 56 | -- * Re-export 57 | ParseBody (..), 58 | defaultParseBody, 59 | ToCapture (..), 60 | DocCapture (..), 61 | ToParam (..), 62 | DocQueryParam (..), 63 | ParamKind (..), 64 | ToAuthInfo (..), 65 | DocAuthentication (..), 66 | ) 67 | where 68 | 69 | import Data.Proxy 70 | import Data.Vinyl 71 | import Options.Applicative 72 | import Servant.CLI.HasCLI 73 | import Servant.CLI.Internal.PStruct 74 | import Servant.CLI.ParseBody 75 | import Servant.Client.Core 76 | import Servant.Docs.Internal 77 | 78 | -- | A version of 'cliPStruct' that can be used if the API requires 79 | -- any external context to generate runtime data. 80 | cliPStructWithContext :: 81 | (HasCLI m api context) => 82 | -- | Client monad 83 | Proxy m -> 84 | -- | API 85 | Proxy api -> 86 | -- | Extra context 87 | Rec (ContextFor m) context -> 88 | PStruct (m (CLIResult m api)) 89 | cliPStructWithContext pm pa = 90 | fmap ($ defaultRequest) 91 | . cliPStructWithContext_ pm pa 92 | 93 | -- | A version of 'cliHandlePStruct' that can be used if the API requires 94 | -- any external context to generate runtime data. 95 | cliHandlePStructWithContext :: 96 | forall m api context r. 97 | (HasCLI m api context, Functor m) => 98 | -- | Client monad 99 | Proxy m -> 100 | -- | API 101 | Proxy api -> 102 | -- | Extra context 103 | Rec (ContextFor m) context -> 104 | -- | Handler 105 | CLIHandler m api r -> 106 | PStruct (m r) 107 | cliHandlePStructWithContext pm pa p h = 108 | fmap (cliHandler pm pa (Proxy @context) h) 109 | <$> cliPStructWithContext pm pa p 110 | 111 | -- | A version of 'parseClient' that can be used if the API requires 112 | -- any external context to generate runtime data. 113 | parseClientWithContext :: 114 | (HasCLI m api context) => 115 | -- | API 116 | Proxy api -> 117 | -- | Client monad 118 | Proxy m -> 119 | -- | Extra context 120 | Rec (ContextFor m) context -> 121 | -- | Options for top-level display 122 | InfoMod (m (CLIResult m api)) -> 123 | IO (m (CLIResult m api)) 124 | parseClientWithContext pa pm p im = 125 | execParser . flip structParser im $ 126 | cliPStructWithContext pm pa p 127 | 128 | -- | A version of 'parseHandleClient' that can be used if the API requires 129 | -- any external context to generate runtime data. 130 | parseHandleClientWithContext :: 131 | forall m api context r. 132 | (HasCLI m api context, Functor m) => 133 | -- | API 134 | Proxy api -> 135 | -- | Client monad 136 | Proxy m -> 137 | -- | Extra context 138 | Rec (ContextFor m) context -> 139 | -- | Options for top-level display 140 | InfoMod (m (CLIResult m api)) -> 141 | -- | Handler 142 | CLIHandler m api r -> 143 | IO (m r) 144 | parseHandleClientWithContext pa pm p im h = 145 | fmap (cliHandler pm pa (Proxy @context) h) 146 | <$> parseClientWithContext pa pm p im 147 | 148 | -- | Create a structure for a command line parser. 149 | -- 150 | -- This can be useful if you are combining functionality with existing 151 | -- /optparse-applicative/ parsers. You can convert a 'PStruct' to 152 | -- a 'Parser' using 'structParser'. 153 | cliPStruct :: 154 | (HasCLI m api '[]) => 155 | -- | Client monad 156 | Proxy m -> 157 | -- | API 158 | Proxy api -> 159 | PStruct (m (CLIResult m api)) 160 | cliPStruct pm pa = cliPStructWithContext pm pa RNil 161 | 162 | -- | Create a structure for a command line parser, producing results 163 | -- according to a 'CLIHandler'. See 'parseHandleClient' for more 164 | -- information. 165 | -- 166 | -- This can be useful if you are combining functionality with existing 167 | -- /optparse-applicative/ parsers. You can convert a 'PStruct' to 168 | -- a 'Parser' using 'structParser'. 169 | cliHandlePStruct :: 170 | (HasCLI m api '[], Functor m) => 171 | -- | Client monad 172 | Proxy m -> 173 | -- | API 174 | Proxy api -> 175 | -- | Handler 176 | CLIHandler m api r -> 177 | PStruct (m r) 178 | cliHandlePStruct pm pa = cliHandlePStructWithContext pm pa RNil 179 | 180 | -- | Parse a servant client; the result can be run. The choice of @m@ 181 | -- gives the backend you are using; for example, the default GHC 182 | -- /servant-client/ backend is 'Servant.Client.ClientM'. 183 | -- 184 | -- Returns the request response, which is usually a layer of 'Either' for 185 | -- every endpoint branch. You can find the response type directly by using 186 | -- typed holes or asking ghci with @:t@ or @:kind! forall m. CLIResult 187 | -- m MyAPI@. Because it might be tedious handling nested 'Either's, see 188 | -- 'parseHandleClient' for a way to handle each potential branch in 189 | -- a convenient way. 190 | -- 191 | -- Takes options on how the top-level prompt is displayed when given 192 | -- @"--help"@; it can be useful for adding a header or program description. 193 | -- Otherwise, just use 'mempty'. 194 | parseClient :: 195 | (HasCLI m api '[]) => 196 | -- | API 197 | Proxy api -> 198 | -- | Client monad 199 | Proxy m -> 200 | -- | Options for top-level display 201 | InfoMod (m (CLIResult m api)) -> 202 | IO (m (CLIResult m api)) 203 | parseClient pa pm = parseClientWithContext pa pm RNil 204 | 205 | -- | Parse a server client, like 'parseClient'. However, instead of that 206 | -- client action returning the request response, instead use a 'CLIHandler' 207 | -- to handle every potential request response. It essentially lets you 208 | -- specify how to sort each potential endpoint's response into a single 209 | -- output value. 210 | -- 211 | -- The handler is usually a 'Servant.API.:<|>' for every endpoint branch. 212 | -- You can find it by using typed holes or asking ghci with @:t@ or @:kind! 213 | -- forall m r. CLIHandler m MyAPI r@. 214 | -- 215 | -- Takes options on how the top-level prompt is displayed when given 216 | -- @"--help"@; it can be useful for adding a header or program description. 217 | -- Otherwise, just use 'mempty'. 218 | parseHandleClient :: 219 | (HasCLI m api '[], Functor m) => 220 | -- | API 221 | Proxy api -> 222 | -- | Client monad 223 | Proxy m -> 224 | -- | Options for top-level display 225 | InfoMod (m (CLIResult m api)) -> 226 | -- | Handler 227 | CLIHandler m api r -> 228 | IO (m r) 229 | parseHandleClient pa pm = parseHandleClientWithContext pa pm RNil 230 | -------------------------------------------------------------------------------- /src/Servant/CLI/HasCLI.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE AllowAmbiguousTypes #-} 2 | {-# LANGUAGE CPP #-} 3 | {-# LANGUAGE DataKinds #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE MultiParamTypeClasses #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE RecordWildCards #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE TypeApplications #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | -- | 17 | -- Module : Servant.CLI.HasCLI 18 | -- Copyright : (c) Justin Le 2019 19 | -- License : BSD3 20 | -- 21 | -- Maintainer : justin@jle.im 22 | -- Stability : experimental 23 | -- Portability : non-portable 24 | -- 25 | -- Main module providing underlying functionality for the command line 26 | -- interface parser for servant API clients. 27 | -- 28 | -- For the most part, you can ignore this module unless you're adding new 29 | -- API combinators. 30 | module Servant.CLI.HasCLI 31 | ( -- * Class 32 | HasCLI (..), 33 | 34 | -- * Context 35 | ContextFor (..), 36 | NamedContext (..), 37 | descendIntoNamedContext, 38 | ) 39 | where 40 | 41 | import Data.Bifunctor 42 | import qualified Data.ByteString.Builder as BSB 43 | import qualified Data.ByteString.Lazy as BSL 44 | import qualified Data.CaseInsensitive as CI 45 | import Data.Char 46 | import Data.Function 47 | import Data.Kind 48 | import Data.List (foldl', intercalate) 49 | import qualified Data.List.NonEmpty as NE 50 | import Data.Profunctor 51 | import Data.Proxy 52 | import qualified Data.Text as T 53 | import qualified Data.Text.Encoding as T 54 | import Data.Vinyl hiding (rmap) 55 | import Data.Void 56 | import GHC.TypeLits hiding (Mod) 57 | import Options.Applicative 58 | import Servant.API hiding (addHeader) 59 | import Servant.API.Modifiers 60 | import Servant.CLI.Internal.PStruct 61 | import Servant.CLI.ParseBody 62 | import Servant.Client.Core 63 | import Servant.Docs.Internal hiding (Endpoint, Response) 64 | import Text.Printf 65 | import Type.Reflection 66 | 67 | -- | Data family associating API combinators with contexts required to run 68 | -- them. These typically will be actions in @m@ that fetch/generate the 69 | -- required data, and will only be "run" if the user selects an endpoint 70 | -- that requires it through the command line interface. 71 | data family ContextFor (m :: Type -> Type) :: Type -> Type 72 | 73 | -- | Typeclass defining how each API combinator influences how a server can 74 | -- be interacted with using command line options. 75 | -- 76 | -- Note that query parameters and captures all require /servant-docs/ 77 | -- annotation instances, to allow for proper help messages. 78 | -- 79 | -- Unless you are adding new combinators to be used with APIs, you can 80 | -- ignore this class. 81 | class HasCLI m api ctx where 82 | -- | The parsed type of the client request response. Usually this will 83 | -- be a bunch of nested 'Either's for every API endpoint, nested 84 | -- according to the ':<|>'s in the API. 85 | type CLIResult (m :: Type -> Type) (api :: Type) :: Type 86 | 87 | -- | The type of a data structure to conveniently handle the results of 88 | -- all pontential endpoints. This is useful because it is often 89 | -- tedious to handle the bunch of nested 'Either's that 'CLIResult' 90 | -- has. 91 | -- 92 | -- It essentially lets you specify how to sort each potential 93 | -- endpoint's response into a single output value. 94 | -- 95 | -- Usually this will be a bunch of nested ':<|>'s which handle each 96 | -- endpoint, according to the ':<|>'s in the API. It mirrors the 97 | -- structure of 'Client' and 'Servant.Server.ServerT'. 98 | -- 99 | -- Used with functions like 'Servant.CLI.parseHandleClient'. 100 | type CLIHandler (m :: Type -> Type) (api :: Type) (r :: Type) :: Type 101 | 102 | -- | Create a structure for a command line parser, which parses how to 103 | -- modify a 'Request' and perform an action, given an API and 104 | -- underlying monad. Only meant for internal use; should be used 105 | -- through 'Servant.CLI.cliPStructWithContext' instead. 106 | -- 107 | -- Takes a 'Rec' of actions to generate required items that cannot be 108 | -- passed via the command line (like authentication). Pass in 'RNil' 109 | -- if no parameters are expected. The actions will only be run if they 110 | -- are needed. 111 | cliPStructWithContext_ :: 112 | Proxy m -> 113 | Proxy api -> 114 | Rec (ContextFor m) ctx -> 115 | PStruct (Request -> m (CLIResult m api)) 116 | 117 | -- | Handle all the possibilities in a 'CLIResult', by giving the 118 | -- appropriate 'CLIHandler'. 119 | cliHandler :: 120 | Proxy m -> 121 | Proxy api -> 122 | Proxy ctx -> 123 | CLIHandler m api r -> 124 | CLIResult m api -> 125 | r 126 | 127 | -- | 'EmptyAPI' will always fail to parse. 128 | -- 129 | -- The branch ending in 'EmptyAPI' will never be return, so if this is 130 | -- combined using ':<|>', the branch will never end up on the side of 131 | -- 'EmptyAPI'. 132 | -- 133 | -- One can use 'absurd' to handle this branch as a part of 'CLIHandler'. 134 | instance HasCLI m EmptyAPI ctx where 135 | type CLIResult m EmptyAPI = Void 136 | type CLIHandler m EmptyAPI r = Void -> r 137 | 138 | cliPStructWithContext_ _ _ _ = mempty 139 | cliHandler _ _ _ = ($) 140 | 141 | -- | Using alternation with ':<|>' provides an 'Either' between the two 142 | -- results. 143 | instance 144 | ( HasCLI m a ctx, 145 | HasCLI m b ctx, 146 | Functor m 147 | ) => 148 | HasCLI m (a :<|> b) ctx 149 | where 150 | type CLIResult m (a :<|> b) = Either (CLIResult m a) (CLIResult m b) 151 | type CLIHandler m (a :<|> b) r = CLIHandler m a r :<|> CLIHandler m b r 152 | 153 | cliPStructWithContext_ pm _ p = 154 | dig Left (cliPStructWithContext_ pm (Proxy @a) p) 155 | <> dig Right (cliPStructWithContext_ pm (Proxy @b) p) 156 | where 157 | dig = fmap . rmap . fmap 158 | 159 | cliHandler pm _ pc (hA :<|> hB) = 160 | either 161 | (cliHandler pm (Proxy @a) pc hA) 162 | (cliHandler pm (Proxy @b) pc hB) 163 | 164 | -- | A path component is interpreted as a "subcommand". 165 | instance (KnownSymbol path, HasCLI m api ctx) => HasCLI m (path :> api) ctx where 166 | type CLIResult m (path :> api) = CLIResult m api 167 | type CLIHandler m (path :> api) r = CLIHandler m api r 168 | 169 | cliPStructWithContext_ pm _ p = 170 | pathstr 171 | $:> (fmap . lmap) 172 | (appendToPath (BSB.byteString $ T.encodeUtf8 $ T.pack pathstr)) 173 | (cliPStructWithContext_ pm (Proxy @api) p) 174 | where 175 | pathstr = symbolVal (Proxy @path) 176 | 177 | cliHandler pm _ = cliHandler pm (Proxy @api) 178 | 179 | -- | A 'Capture' is interpreted as a positional required command line argument. 180 | -- 181 | -- Note that these require 'ToCapture' instances from /servant-docs/, to 182 | -- provide appropriate help messages. 183 | instance 184 | ( FromHttpApiData a, 185 | ToHttpApiData a, 186 | Typeable a, 187 | ToCapture (Capture sym a), 188 | HasCLI m api ctx 189 | ) => 190 | HasCLI m (Capture' mods sym a :> api) ctx 191 | where 192 | type CLIResult m (Capture' mods sym a :> api) = CLIResult m api 193 | type CLIHandler m (Capture' mods sym a :> api) r = CLIHandler m api r 194 | 195 | cliPStructWithContext_ pm _ p = 196 | arg 197 | #:> fmap (.: addCapture) (cliPStructWithContext_ pm (Proxy @api) p) 198 | where 199 | addCapture = appendToPath . BSB.byteString . T.encodeUtf8 . toUrlPiece 200 | arg = 201 | Arg 202 | { argName = _capSymbol, 203 | argDesc = printf "%s (%s)" _capDesc capType, 204 | argMeta = printf "<%s>" _capSymbol, 205 | argRead = eitherReader $ first T.unpack . parseUrlPiece @a . T.pack 206 | } 207 | capType = show $ typeRep @a 208 | DocCapture {..} = toCapture (Proxy @(Capture sym a)) 209 | 210 | cliHandler pm _ = cliHandler pm (Proxy @api) 211 | 212 | -- | A 'CaptureAll' is interpreted as arbitrarily many command line 213 | -- arguments. If there is more than one final endpoint method, the method 214 | -- must be given as a command line option before beginning the arguments. 215 | instance 216 | ( FromHttpApiData a, 217 | ToHttpApiData a, 218 | Typeable a, 219 | ToCapture (CaptureAll sym a), 220 | HasCLI m api ctx 221 | ) => 222 | HasCLI m (CaptureAll sym a :> api) ctx 223 | where 224 | type CLIResult m (CaptureAll sym a :> api) = CLIResult m api 225 | type CLIHandler m (CaptureAll sym a :> api) r = CLIHandler m api r 226 | 227 | cliPStructWithContext_ pm _ p = 228 | arg 229 | ##:> fmap (.: addCapture) (cliPStructWithContext_ pm (Proxy @api) p) 230 | where 231 | addCapture ps req = 232 | foldl' 233 | (flip appendToPath) 234 | req 235 | (map (BSB.byteString . T.encodeUtf8 . toUrlPiece) ps) 236 | arg = 237 | Arg 238 | { argName = _capSymbol, 239 | argDesc = printf "%s (%s)" _capDesc capType, 240 | argMeta = printf "<%s>" _capSymbol, 241 | argRead = eitherReader $ first T.unpack . parseUrlPiece @a . T.pack 242 | } 243 | capType = show $ typeRep @a 244 | DocCapture {..} = toCapture (Proxy @(CaptureAll sym a)) 245 | 246 | cliHandler pm _ = cliHandler pm (Proxy @api) 247 | 248 | -- | Query parameters are interpreted as command line options. 249 | -- 250 | -- 'QueryParam'' arguments are associated with the action at their 251 | -- endpoint. After entering all path components and positional arguments, 252 | -- the parser library will begin asking for arguments. 253 | -- 254 | -- Note that these require 'ToParam' instances from /servant-docs/, to 255 | -- provide appropriate help messages. 256 | instance 257 | ( KnownSymbol sym, 258 | FromHttpApiData a, 259 | ToHttpApiData a, 260 | SBoolI (FoldRequired' 'False mods), 261 | Typeable a, 262 | ToParam (QueryParam' mods sym a), 263 | HasCLI m api ctx 264 | ) => 265 | HasCLI m (QueryParam' mods sym a :> api) ctx 266 | where 267 | type CLIResult m (QueryParam' mods sym a :> api) = CLIResult m api 268 | type CLIHandler m (QueryParam' mods sym a :> api) r = CLIHandler m api r 269 | 270 | cliPStructWithContext_ pm _ p = 271 | opt 272 | ?:> fmap (.: addParam) (cliPStructWithContext_ pm (Proxy @api) p) 273 | where 274 | addParam :: RequiredArgument mods a -> Request -> Request 275 | addParam = foldRequiredArgument (Proxy @mods) add (maybe id add) 276 | add :: a -> Request -> Request 277 | add param = 278 | appendToQueryString 279 | (T.pack pName) 280 | (Just (T.encodeUtf8 $ toQueryParam param)) 281 | opt :: Opt (RequiredArgument mods a) 282 | opt = 283 | Opt 284 | { optName = pName, 285 | optDesc = printf "%s (%s)" _paramDesc valSpec, 286 | optMeta = map toUpper pType, 287 | optVals = NE.nonEmpty _paramValues, 288 | optRead = case sbool @(FoldRequired mods) of 289 | STrue -> orRequired r 290 | SFalse -> orOptional r 291 | } 292 | r = eitherReader $ first T.unpack . parseQueryParam @a . T.pack 293 | pType = show $ typeRep @a 294 | valSpec 295 | | null _paramValues = pType 296 | | otherwise = "options: " ++ intercalate ", " _paramValues 297 | pName = symbolVal (Proxy @sym) 298 | DocQueryParam {..} = toParam (Proxy @(QueryParam' mods sym a)) 299 | 300 | cliHandler pm _ = cliHandler pm (Proxy @api) 301 | 302 | -- | Query flags are interpreted as command line flags/switches. 303 | -- 304 | -- 'QueryFlag' arguments are associated with the action at their endpoint. 305 | -- After entering all path components and positional arguments, the parser 306 | -- library will begin asking for arguments. 307 | -- 308 | -- Note that these require 'ToParam' instances from /servant-docs/, to 309 | -- provide appropriate help messages. 310 | instance 311 | ( KnownSymbol sym, 312 | ToParam (QueryFlag sym), 313 | HasCLI m api ctx 314 | ) => 315 | HasCLI m (QueryFlag sym :> api) ctx 316 | where 317 | type CLIResult m (QueryFlag sym :> api) = CLIResult m api 318 | type CLIHandler m (QueryFlag sym :> api) r = CLIHandler m api r 319 | 320 | cliPStructWithContext_ pm _ p = 321 | opt 322 | ?:> fmap (.: addParam) (cliPStructWithContext_ pm (Proxy @api) p) 323 | where 324 | addParam :: Bool -> Request -> Request 325 | addParam = \case 326 | True -> appendToQueryString (T.pack pName) Nothing 327 | False -> id 328 | opt = 329 | Opt 330 | { optName = pName, 331 | optDesc = _paramDesc, 332 | optMeta = printf "<%s>" pName, 333 | optVals = NE.nonEmpty _paramValues, 334 | optRead = orSwitch 335 | } 336 | pName = symbolVal (Proxy @sym) 337 | DocQueryParam {..} = toParam (Proxy @(QueryFlag sym)) 338 | 339 | cliHandler pm _ = cliHandler pm (Proxy @api) 340 | 341 | -- | Query parameters are interpreted as command line options, and so repeated 342 | -- query parameters are repeated command line options. 343 | -- 344 | -- 'QueryParams' are associated with the action at their endpoint. After 345 | -- entering all path components and positional arguments, the parser library 346 | -- will begin asking for arguments. 347 | -- 348 | -- Note that these require 'ToParam' instances from /servant-docs/, to 349 | -- provide appropriate help messages. 350 | instance 351 | ( ToHttpApiData a, 352 | ToParam (QueryParams sym a), 353 | KnownSymbol sym, 354 | Typeable a, 355 | FromHttpApiData a, 356 | HasCLI m api ctx 357 | ) => 358 | HasCLI m (QueryParams sym a :> api) ctx 359 | where 360 | type CLIResult m (QueryParams sym a :> api) = CLIResult m api 361 | type CLIHandler m (QueryParams sym a :> api) r = CLIHandler m api r 362 | 363 | cliPStructWithContext_ pm _ p = 364 | opt 365 | ?:> fmap (.: addParam) (cliPStructWithContext_ pm (Proxy @api) p) 366 | where 367 | addParam :: [a] -> Request -> Request 368 | addParam ps req = foldl' (flip add) req ps 369 | add :: a -> Request -> Request 370 | add param = 371 | appendToQueryString 372 | (T.pack pName) 373 | (Just (T.encodeUtf8 $ toQueryParam param)) 374 | opt :: Opt [a] 375 | opt = 376 | Opt 377 | { optName = pName, 378 | optDesc = printf "%s (%s)" _paramDesc valSpec, 379 | optMeta = map toUpper pType, 380 | optVals = NE.nonEmpty _paramValues, 381 | optRead = orMany r 382 | } 383 | r = eitherReader $ first T.unpack . parseQueryParam @a . T.pack 384 | pType = show $ typeRep @a 385 | valSpec 386 | | null _paramValues = pType 387 | | otherwise = "options: " ++ intercalate ", " _paramValues 388 | pName = symbolVal (Proxy @sym) 389 | DocQueryParam {..} = toParam (Proxy @(QueryParams sym a)) 390 | 391 | cliHandler pm _ = cliHandler pm (Proxy @api) 392 | 393 | -- | Request body requirements are interpreted using 'ParseBody'. 394 | -- 395 | -- Note if more than one 'ReqBody' is in an API endpoint, both parsers will 396 | -- be "run", but only the final one will be used. This shouldn't be an 397 | -- issue, since multiple 'ReqBody's in a single endpoint should be 398 | -- undefined behavior. 399 | instance 400 | ( MimeRender ct a, 401 | ParseBody a, 402 | HasCLI m api ctx 403 | ) => 404 | HasCLI m (ReqBody' mods (ct ': cts) a :> api) ctx 405 | where 406 | type CLIResult m (ReqBody' mods (ct ': cts) a :> api) = CLIResult m api 407 | type CLIHandler m (ReqBody' mods (ct ': cts) a :> api) r = CLIHandler m api r 408 | 409 | cliPStructWithContext_ pm _ p = 410 | parseBody @a 411 | %:> fmap (.: addBody) (cliPStructWithContext_ pm (Proxy @api) p) 412 | where 413 | addBody b = setRequestBodyLBS (mimeRender ctProxy b) (contentType ctProxy) 414 | ctProxy = Proxy @ct 415 | 416 | cliHandler pm _ = cliHandler pm (Proxy @api) 417 | 418 | -- | Final actions are the result of specifying all necessary command line 419 | -- positional arguments. 420 | -- 421 | -- All command line options are associated with the final action at the end 422 | -- of their endpoint/path. They cannot be entered in "before" you arrive 423 | -- at your final endpoint. 424 | -- 425 | -- If more than one action (under a different method) exists 426 | -- under the same endpoint/path, the method (@GET@, @POST@, etc.) will be 427 | -- treated as an extra final command. After that, you may begin entering 428 | -- in options. 429 | instance 430 | ( HasClient m (Verb method status cts' a), 431 | ReflectMethod method 432 | ) => 433 | HasCLI m (Verb method status cts' a) ctx 434 | where 435 | type CLIResult m (Verb method status cts' a) = a 436 | type CLIHandler m (Verb method status cts' a) r = a -> r 437 | 438 | cliPStructWithContext_ pm pa _ = endpoint (reflectMethod (Proxy @method)) (clientWithRoute pm pa) 439 | cliHandler _ _ _ = ($) 440 | 441 | -- | Final actions are the result of specifying all necessary command line 442 | -- positional arguments. 443 | -- 444 | -- All command line options are associated with the final action at the end 445 | -- of their endpoint/path. They cannot be entered in "before" you arrive 446 | -- at your final endpoint. 447 | -- 448 | -- If more than one action (under a different method) exists 449 | -- under the same endpoint/path, the method (@GET@, @POST@, etc.) will be 450 | -- treated as an extra final command. After that, you may begin entering 451 | -- in options. 452 | instance 453 | ( RunClient m, 454 | ReflectMethod method 455 | ) => 456 | HasCLI m (NoContentVerb method) ctx 457 | where 458 | type CLIResult m (NoContentVerb method) = NoContent 459 | type CLIHandler m (NoContentVerb method) r = r 460 | 461 | cliPStructWithContext_ pm pa _ = endpoint (reflectMethod (Proxy @method)) (clientWithRoute pm pa) 462 | cliHandler _ _ _ = const 463 | 464 | -- | Same semantics in parsing command line options as 'Verb'. 465 | instance 466 | ( RunStreamingClient m, 467 | MimeUnrender ct chunk, 468 | ReflectMethod method, 469 | FramingUnrender framing, 470 | FromSourceIO chunk a 471 | ) => 472 | HasCLI m (Stream method status framing ct a) ctx 473 | where 474 | type CLIResult m (Stream method status framing ct a) = a 475 | type CLIHandler m (Stream method status framing ct a) r = a -> r 476 | cliPStructWithContext_ pm pa _ = endpoint (reflectMethod (Proxy @method)) (clientWithRoute pm pa) 477 | cliHandler _ _ _ = ($) 478 | 479 | newtype instance ContextFor m (StreamBody' mods framing ctype a) = GenStreamBody {genStreamBody :: m a} 480 | 481 | -- | As a part of @ctx@, asks for a streaming source @a@. 482 | instance 483 | ( ToSourceIO chunk a, 484 | MimeRender ctype chunk, 485 | FramingRender framing, 486 | StreamBody' mods framing ctype a ∈ ctx, 487 | HasCLI m api ctx, 488 | Monad m 489 | ) => 490 | HasCLI m (StreamBody' mods framing ctype a :> api) ctx 491 | where 492 | type CLIResult m (StreamBody' mods framing ctype a :> api) = CLIResult m api 493 | type CLIHandler m (StreamBody' mods framing ctype a :> api) r = CLIHandler m api r 494 | 495 | cliPStructWithContext_ pm _ p = 496 | withParamM (addBody <$> genStreamBody mx) 497 | <$> cliPStructWithContext_ pm (Proxy @api) p 498 | where 499 | mx :: ContextFor m (StreamBody' mods framing ctype a) 500 | mx = rget p 501 | addBody :: a -> Request -> Request 502 | addBody x = setRequestBody rbs (contentType ctypeP) 503 | where 504 | ctypeP = Proxy @ctype 505 | framingP = Proxy @framing 506 | rbs = 507 | RequestBodySource $ 508 | framingRender 509 | framingP 510 | (mimeRender ctypeP :: chunk -> BSL.ByteString) 511 | (toSourceIO x) 512 | cliHandler pm _ = cliHandler pm (Proxy @api) 513 | 514 | -- | A 'Header'' in the middle of a path is interpreted as a command line 515 | -- argument, prefixed with "header". For example, 516 | -- @'Servant.API.Header.Header' "foo" 'Int'@ is an option for 517 | -- @--header-foo@. 518 | -- 519 | -- Like for 'QueryParam'', arguments are associated with the action at 520 | -- their endpoint. After entering all path components and positional 521 | -- arguments, the parser library will begin asking for arguments. 522 | instance 523 | ( KnownSymbol sym, 524 | FromHttpApiData a, 525 | ToHttpApiData a, 526 | SBoolI (FoldRequired' 'False mods), 527 | Typeable a, 528 | HasCLI m api ctx 529 | ) => 530 | HasCLI m (Header' mods sym a :> api) ctx 531 | where 532 | type CLIResult m (Header' mods sym a :> api) = CLIResult m api 533 | type CLIHandler m (Header' mods sym a :> api) r = CLIHandler m api r 534 | 535 | cliPStructWithContext_ pm _ p = 536 | opt 537 | ?:> fmap (.: addParam) (cliPStructWithContext_ pm (Proxy @api) p) 538 | where 539 | addParam :: RequiredArgument mods a -> Request -> Request 540 | addParam = foldRequiredArgument (Proxy @mods) add (maybe id add) 541 | add :: a -> Request -> Request 542 | add = addHeader (CI.mk . T.encodeUtf8 . T.pack $ pName) 543 | opt :: Opt (RequiredArgument mods a) 544 | opt = 545 | Opt 546 | { optName = printf "header-%s" pName, 547 | optDesc = printf "Header data %s (%s)" pName pType, 548 | optMeta = map toUpper pType, 549 | optVals = Nothing, 550 | optRead = case sbool @(FoldRequired mods) of 551 | STrue -> orRequired r 552 | SFalse -> orOptional r 553 | } 554 | r :: ReadM a 555 | r = eitherReader $ first T.unpack . parseHeader . T.encodeUtf8 . T.pack 556 | pType = show $ typeRep @a 557 | pName = symbolVal (Proxy @sym) 558 | 559 | cliHandler pm _ = cliHandler pm (Proxy @api) 560 | 561 | -- | Using 'HttpVersion' has no affect on CLI operations. 562 | instance (HasCLI m api ctx) => HasCLI m (HttpVersion :> api) ctx where 563 | type CLIResult m (HttpVersion :> api) = CLIResult m api 564 | type CLIHandler m (HttpVersion :> api) r = CLIHandler m api r 565 | 566 | cliPStructWithContext_ pm _ = cliPStructWithContext_ pm (Proxy @api) 567 | cliHandler pm _ = cliHandler pm (Proxy @api) 568 | 569 | -- | 'Summary' is displayed during @--help@ when it is reached while 570 | -- navigating down subcommands. 571 | instance (KnownSymbol desc, HasCLI m api ctx) => HasCLI m (Summary desc :> api) ctx where 572 | type CLIResult m (Summary desc :> api) = CLIResult m api 573 | type CLIHandler m (Summary desc :> api) r = CLIHandler m api r 574 | 575 | cliPStructWithContext_ pm _ = 576 | note [symbolVal (Proxy @desc)] 577 | . cliPStructWithContext_ pm (Proxy :: Proxy api) 578 | cliHandler pm _ = cliHandler pm (Proxy @api) 579 | 580 | -- | 'Description' is displayed during @--help@ when it is reached while 581 | -- navigating down subcommands. 582 | instance (KnownSymbol desc, HasCLI m api ctx) => HasCLI m (Description desc :> api) ctx where 583 | type CLIResult m (Description desc :> api) = CLIResult m api 584 | type CLIHandler m (Description desc :> api) r = CLIHandler m api r 585 | 586 | cliPStructWithContext_ pm _ = 587 | note [symbolVal (Proxy @desc)] 588 | . cliPStructWithContext_ pm (Proxy :: Proxy api) 589 | cliHandler pm _ = cliHandler pm (Proxy @api) 590 | 591 | -- | Asks for method as a command line argument. If any 'Verb' exists at 592 | -- the same endpoint, it can only be accessed as an extra @RAW@ subcommand 593 | -- (as if it had an extra path component labeled @"RAW"@). 594 | instance (RunClient m) => HasCLI m Raw ctx where 595 | type CLIResult m Raw = Response 596 | type CLIHandler m Raw r = Response -> r 597 | 598 | cliPStructWithContext_ pm pa _ = rawEndpoint . flip $ clientWithRoute pm pa 599 | cliHandler _ _ _ = ($) 600 | 601 | instance (HasCLI m api ctx) => HasCLI m (Vault :> api) ctx where 602 | type CLIResult m (Vault :> api) = CLIResult m api 603 | type CLIHandler m (Vault :> api) r = CLIHandler m api r 604 | 605 | cliPStructWithContext_ pm _ = cliPStructWithContext_ pm (Proxy @api) 606 | cliHandler pm _ = cliHandler pm (Proxy @api) 607 | 608 | instance (HasCLI m api ctx) => HasCLI m (RemoteHost :> api) ctx where 609 | type CLIResult m (RemoteHost :> api) = CLIResult m api 610 | type CLIHandler m (RemoteHost :> api) r = CLIHandler m api r 611 | 612 | cliPStructWithContext_ pm _ = cliPStructWithContext_ pm (Proxy @api) 613 | cliHandler pm _ = cliHandler pm (Proxy @api) 614 | 615 | instance (HasCLI m api ctx) => HasCLI m (IsSecure :> api) ctx where 616 | type CLIResult m (IsSecure :> api) = CLIResult m api 617 | type CLIHandler m (IsSecure :> api) r = CLIHandler m api r 618 | 619 | cliPStructWithContext_ pm _ = cliPStructWithContext_ pm (Proxy @api) 620 | cliHandler pm _ = cliHandler pm (Proxy @api) 621 | 622 | -- | Contains a subcontext that can be descended down into using 623 | -- 'NamedContext'. Mirrors 'Servant.Server.NamedContext'. 624 | -- 625 | -- Useful for when you have multiple items with the same name within 626 | -- a context; this essentially creates a namespace for context items. 627 | newtype NamedContext m (name :: Symbol) (subContext :: [Type]) 628 | = NamedContext (Rec (ContextFor m) subContext) 629 | 630 | newtype instance ContextFor m (NamedContext m name subContext) 631 | = NC (NamedContext m name subContext) 632 | 633 | -- | Allows you to access 'NamedContext's inside a context. 634 | descendIntoNamedContext :: 635 | forall (name :: Symbol) context subContext m. 636 | (NamedContext m name subContext ∈ context) => 637 | Proxy name -> 638 | Rec (ContextFor m) context -> 639 | Rec (ContextFor m) subContext 640 | descendIntoNamedContext _ p = p' 641 | where 642 | NC (NamedContext p' :: NamedContext m name subContext) = rget p 643 | 644 | -- | Descend down a subcontext indexed by a given name. Must be provided 645 | -- when parsing within the context. 646 | -- 647 | -- Useful for when you have multiple items with the same name within 648 | -- a context; this essentially creates a namespace for context items. 649 | instance 650 | ( NamedContext m name subctx ∈ ctx, 651 | HasCLI m subapi subctx 652 | ) => 653 | HasCLI m (WithNamedContext name subctx subapi) ctx 654 | where 655 | type CLIResult m (WithNamedContext name subctx subapi) = CLIResult m subapi 656 | type CLIHandler m (WithNamedContext name subctx subapi) r = CLIHandler m subapi r 657 | 658 | cliPStructWithContext_ pm _ = 659 | cliPStructWithContext_ pm (Proxy @subapi) 660 | . descendIntoNamedContext @_ @ctx @subctx (Proxy @name) 661 | cliHandler pm _ _ = cliHandler pm (Proxy @subapi) (Proxy @subctx) 662 | 663 | newtype instance ContextFor m (AuthProtect tag) = GenAuthReq 664 | { genAuthReq :: m (AuthenticatedRequest (AuthProtect tag)) 665 | } 666 | 667 | -- | Add 'GenAuthReq' to the required context, meaning it must be 668 | -- provided to allow the client to generate authentication data. The 669 | -- action will only be run if the user selects this endpoint via command 670 | -- line arguments. 671 | -- 672 | -- Please use a secure connection! 673 | instance 674 | ( HasCLI m api ctx, 675 | AuthProtect tag ∈ ctx, 676 | Monad m 677 | ) => 678 | HasCLI m (AuthProtect tag :> api) ctx 679 | where 680 | type CLIResult m (AuthProtect tag :> api) = CLIResult m api 681 | type CLIHandler m (AuthProtect tag :> api) r = CLIHandler m api r 682 | 683 | cliPStructWithContext_ pm _ p = 684 | withParamM (uncurry (&) . unAuthReq <$> genAuthReq md) 685 | <$> cliPStructWithContext_ pm (Proxy @api) p 686 | where 687 | md :: ContextFor m (AuthProtect tag) 688 | md = rget p 689 | 690 | cliHandler pm _ = cliHandler pm (Proxy @api) 691 | 692 | newtype instance ContextFor m (BasicAuth realm usr) = GenBasicAuthData 693 | { genBasicAuthData :: m BasicAuthData 694 | } 695 | 696 | -- | Add 'GenBasicAuthData' to the required context, meaning it must be 697 | -- provided to allow the client to generate authentication data. The 698 | -- action will only be run if the user selects this endpoint via command 699 | -- line arguments. 700 | -- 701 | -- Please use a secure connection! 702 | instance 703 | ( ToAuthInfo (BasicAuth realm usr), 704 | HasCLI m api ctx, 705 | BasicAuth realm usr ∈ ctx, 706 | Monad m 707 | ) => 708 | HasCLI m (BasicAuth realm usr :> api) ctx 709 | where 710 | type CLIResult m (BasicAuth realm usr :> api) = CLIResult m api 711 | type CLIHandler m (BasicAuth realm usr :> api) r = CLIHandler m api r 712 | 713 | cliPStructWithContext_ pm _ p = 714 | note [infonote, reqnote] $ 715 | withParamM (basicAuthReq <$> genBasicAuthData md) 716 | <$> cliPStructWithContext_ pm (Proxy @api) p 717 | where 718 | md :: ContextFor m (BasicAuth realm usr) 719 | md = rget p 720 | infonote = "Authentication required: " ++ _authIntro 721 | reqnote = "Required information: " ++ _authDataRequired 722 | 723 | DocAuthentication {..} = toAuthInfo (Proxy @(BasicAuth realm usr)) 724 | 725 | cliHandler pm _ = cliHandler pm (Proxy @api) 726 | 727 | -- | Helper for mapping parameter generators 728 | withParamM :: 729 | (Monad m) => 730 | m (a -> a) -> 731 | (a -> m b) -> 732 | a -> 733 | m b 734 | withParamM mf g x = do 735 | f <- mf 736 | g (f x) 737 | 738 | -- | Two-argument function composition 739 | (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d 740 | (f .: g) x y = f (g x y) 741 | -------------------------------------------------------------------------------- /src/Servant/CLI/Internal/PStruct.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveFunctor #-} 2 | {-# LANGUAGE DeriveTraversable #-} 3 | {-# LANGUAGE FlexibleContexts #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE KindSignatures #-} 6 | {-# LANGUAGE LambdaCase #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE TemplateHaskell #-} 9 | {-# LANGUAGE TupleSections #-} 10 | {-# LANGUAGE TypeApplications #-} 11 | {-# LANGUAGE TypeFamilies #-} 12 | {-# LANGUAGE TypeOperators #-} 13 | 14 | -- | 15 | -- Module : Servant.CLI.PStruct 16 | -- Copyright : (c) Justin Le 2019 17 | -- License : BSD3 18 | -- 19 | -- Maintainer : justin@jle.im 20 | -- Stability : experimental 21 | -- Portability : non-portable 22 | -- 23 | -- Internal module providing a data structure for representing structure of 24 | -- command line parsers that can be manipulated as an ADT, as well as 25 | -- functionality to interpret it as a 'Parser' command line argument 26 | -- parser. 27 | module Servant.CLI.Internal.PStruct 28 | ( OptRead (..), 29 | Opt (..), 30 | Arg (..), 31 | MultiArg (..), 32 | Captures, 33 | Endpoint (..), 34 | EndpointMap (..), 35 | PStruct (..), 36 | PStructF (..), 37 | structParser, 38 | structParser_, 39 | 40 | -- * Creating 41 | branch, 42 | ($:>), 43 | (%:>), 44 | (?:>), 45 | (#:>), 46 | (##:>), 47 | note, 48 | endpoint, 49 | rawEndpoint, 50 | 51 | -- ** Readers 52 | orRequired, 53 | orOptional, 54 | orSwitch, 55 | orMany, 56 | ) 57 | where 58 | 59 | import Control.Applicative.Backwards 60 | import Control.Applicative.Free 61 | import Data.Foldable 62 | import Data.Function 63 | import Data.Functor 64 | import Data.Functor.Combinator 65 | import Data.Functor.Combinator.Unsafe 66 | import Data.Functor.Foldable 67 | import Data.Functor.Foldable.TH 68 | import Data.Kind 69 | import Data.List.NonEmpty (NonEmpty (..)) 70 | import Data.Map (Map) 71 | import qualified Data.Map as M 72 | import Data.Maybe 73 | import Data.Proxy 74 | import qualified Data.Text as T 75 | import qualified Data.Text.Encoding as T 76 | import qualified Network.HTTP.Types as HTTP 77 | import Options.Applicative 78 | import qualified Options.Applicative.Help.Pretty as O 79 | import System.FilePath 80 | 81 | -- | How to "read" an option. 82 | data OptRead :: Type -> Type where 83 | ORRequired :: ReadM a -> OptRead a 84 | OROptional :: ReadM a -> OptRead (Maybe a) 85 | ORSwitch :: OptRead Bool 86 | ORMany :: ReadM a -> OptRead [a] 87 | 88 | -- | Query parameters are interpreted as options 89 | data Opt a = Opt 90 | { optName :: String, 91 | optDesc :: String, 92 | optMeta :: String, 93 | optVals :: Maybe (NonEmpty String), 94 | optRead :: Coyoneda OptRead a 95 | } 96 | deriving (Functor) 97 | 98 | -- | Captures are interpreted as arguments 99 | data Arg a = Arg 100 | { argName :: String, 101 | argDesc :: String, 102 | argMeta :: String, 103 | argRead :: ReadM a 104 | } 105 | deriving (Functor) 106 | 107 | -- | Interpret an 'Arg' as something that can be given repeatedly an 108 | -- arbitrary number of times. 109 | data MultiArg :: Type -> Type where 110 | MultiArg :: Arg a -> MultiArg [a] 111 | 112 | -- | A map of endpoints associated with methods, paired with an optional 113 | -- "raw" endpoint. 114 | data EndpointMap a = EPM 115 | { epmGiven :: Map HTTP.Method (Endpoint a), 116 | epmRaw :: Maybe (Endpoint (HTTP.Method -> a)) 117 | } 118 | deriving (Functor) 119 | 120 | -- | Captures can be a single capture leading to the next level, or 121 | -- a multi-capture leading to an endpoint action. 122 | type Captures = 123 | Day Arg PStruct 124 | :+: Day MultiArg EndpointMap 125 | 126 | -- | Endpoint arguments and body. 127 | newtype Endpoint a = Endpoint 128 | {epStruct :: Day (Ap Opt) Parser a} 129 | deriving (Functor) 130 | 131 | -- | Structure for a parser of a given value that may use items from 132 | -- captures and arguments. 133 | data PStruct a = PStruct 134 | { psInfo :: [String], 135 | -- | path components 136 | psComponents :: Map String (PStruct a), 137 | -- | captures 138 | psCaptures :: Maybe (Captures a), 139 | psEndpoints :: EndpointMap a 140 | } 141 | deriving (Functor) 142 | 143 | -- TODO: Capture vs. Endpoint interplay is a bit weird, when they are at 144 | -- the same level. 145 | 146 | makeBaseFunctor ''PStruct 147 | 148 | -- | Convert a 'PStruct' into a command line argument parser, from the 149 | -- /optparse-applicative/ library. It can be run with 'execParser'. 150 | -- 151 | -- It takes options on how the top-level prompt is displayed when given 152 | -- @"--help"@; it can be useful for adding a header or program description. 153 | -- Otherwise, just use 'mempty'. 154 | structParser :: 155 | -- | The 'PStruct' to convert. 156 | PStruct a -> 157 | -- | Modify how the top-level prompt is displayed. 158 | InfoMod a -> 159 | ParserInfo a 160 | structParser = flip $ \im -> ($ im) . ($ []) . ($ True) . structParser_ 161 | 162 | -- | Low-level implementation of 'structParser'. 163 | structParser_ :: 164 | PStruct a -> 165 | -- | add helper 166 | Bool -> 167 | -- | root path 168 | [String] -> 169 | -- | modify top level 170 | InfoMod a -> 171 | ParserInfo a 172 | structParser_ = cata go 173 | where 174 | go :: 175 | PStructF x (Bool -> [String] -> InfoMod x -> ParserInfo x) -> 176 | Bool -> 177 | [String] -> 178 | InfoMod x -> 179 | ParserInfo x 180 | go PStructF {..} toHelp p im = 181 | info ((subp <|> cap <|> ep) <**> mkHelp) $ 182 | fullDesc 183 | <> header (joinPath p) 184 | <> progDescDoc (Just (O.vcat . map O.pretty $ ns)) 185 | <> im 186 | where 187 | subs = M.foldMapWithKey (mkCmd p) psComponentsF 188 | subp 189 | | M.null psComponentsF = empty 190 | | otherwise = 191 | subparser $ 192 | subs 193 | <> metavar "COMPONENT" 194 | <> commandGroup "Path components:" 195 | cap = 196 | unsafePlus (Proxy @Parser) $ 197 | interpret (mkArg p !*! mkArgs) $ 198 | MaybeF psCapturesF 199 | ep = methodPicker psEndpointsF 200 | ns = psInfoF 201 | mkHelp 202 | | toHelp = helper 203 | | otherwise = pure id 204 | mkCmd :: 205 | [String] -> 206 | String -> 207 | (Bool -> [String] -> InfoMod x -> ParserInfo x) -> 208 | Mod CommandFields x 209 | mkCmd ps c p = command c (p True (ps ++ [c]) mempty) 210 | mkArg :: [String] -> Day Arg PStruct x -> Parser x 211 | mkArg ps (Day a p f) = 212 | f 213 | <$> argParser a 214 | <*> infoParser (structParser_ p False (ps ++ [':' : argName a]) mempty) 215 | mkArgs :: Day MultiArg EndpointMap x -> Parser x 216 | mkArgs = 217 | unsafeApply (Proxy @Parser) $ 218 | forwards 219 | . ( Backwards . (\case MultiArg a -> many (argParser a)) 220 | !*! Backwards . methodPicker 221 | ) 222 | argParser :: Arg x -> Parser x 223 | argParser Arg {..} = 224 | argument argRead $ 225 | help argDesc 226 | <> metavar argMeta 227 | mkOpt :: Opt x -> Parser x 228 | mkOpt Opt {..} = forI optRead $ \case 229 | ORRequired r -> option r mods 230 | OROptional r -> optional $ option r mods 231 | ORSwitch -> switch $ long optName <> help optDesc 232 | ORMany r -> many $ option r mods 233 | where 234 | mods :: Mod OptionFields y 235 | mods = 236 | long optName 237 | <> help optDesc 238 | <> metavar optMeta 239 | <> foldMap (completeWith . toList) optVals 240 | methodPicker :: EndpointMap x -> Parser x 241 | methodPicker (EPM eps rw) = case M.minView epMap of 242 | Nothing -> maybe empty mkRaw rw 243 | Just (m0, ms) 244 | | M.null ms && isNothing rw -> m0 245 | | otherwise -> 246 | subparser $ 247 | M.foldMapWithKey pickMethod epMap 248 | <> foldMap mkRawCommand rw 249 | <> metavar "METHOD" 250 | <> commandGroup "HTTP Methods:" 251 | where 252 | epMap = mkEndpoint <$> eps 253 | mkEndpoint :: Endpoint x -> Parser x 254 | mkEndpoint = 255 | unsafeApply (Proxy @Parser) $ 256 | binterpret (interpret mkOpt) id 257 | . epStruct 258 | pickMethod :: HTTP.Method -> Parser x -> Mod CommandFields x 259 | pickMethod m p = command (T.unpack . T.decodeUtf8 $ m) $ info (p <**> helper) mempty 260 | mkRaw :: Endpoint (HTTP.Method -> x) -> Parser x 261 | mkRaw e = mkEndpoint e <*> o 262 | where 263 | o = 264 | strOption @HTTP.Method $ 265 | long "method" 266 | <> help "method for raw request (GET, POST, etc.)" 267 | <> metavar "METHOD" 268 | <> completeWith (show <$> [HTTP.GET ..]) 269 | mkRawCommand :: Endpoint (HTTP.Method -> x) -> Mod CommandFields x 270 | mkRawCommand d = command "RAW" $ info (mkRaw d <**> helper) mempty 271 | 272 | -- | Combine two 'EndpointMap's, preferring the left hand side for 273 | -- conflicts. If the left hand has a raw endpoint, the right hand's 274 | -- endpoints are ignored. 275 | instance Semigroup (EndpointMap a) where 276 | (<>) = altEPM 277 | 278 | instance Monoid (EndpointMap a) where 279 | mempty = EPM M.empty Nothing 280 | 281 | altEPM :: EndpointMap a -> EndpointMap a -> EndpointMap a 282 | altEPM (EPM e1 r1) (EPM e2 r2) = EPM e3 r3 283 | where 284 | e3 = case r1 of 285 | Just _ -> e1 286 | Nothing -> M.unionWith const e1 e2 287 | r3 = r1 <|> r2 288 | 289 | altPStruct :: PStruct a -> PStruct a -> PStruct a 290 | altPStruct (PStruct ns1 cs1 c1 ep1) (PStruct ns2 cs2 c2 ep2) = 291 | PStruct ns3 cs3 c3 ep3 292 | where 293 | ns3 = ns1 ++ ns2 -- ?? 294 | cs3 = case c1 of 295 | Just _ -> cs1 296 | Nothing -> M.unionWith altPStruct cs1 cs2 297 | c3 = c1 <|> c2 298 | ep3 = ep1 <> ep2 299 | 300 | -- | Combine two 'PStruct's, preferring the left hand side for conflicts. 301 | -- If the left hand has a capture, the right hand's components are ignored. 302 | -- If the left hand has a raw endpoint, the right hand's endpoints are 303 | -- ignored. 304 | instance Semigroup (PStruct a) where 305 | (<>) = altPStruct 306 | 307 | instance Monoid (PStruct a) where 308 | mempty = PStruct [] M.empty Nothing mempty 309 | 310 | -- | Combine two 'PStruct's in an either-or fashion, favoring the left hand 311 | -- side. 312 | branch :: PStruct a -> PStruct b -> PStruct (Either a b) 313 | branch x y = (Left <$> x) `altPStruct` (Right <$> y) 314 | 315 | infixr 3 `branch` 316 | 317 | -- | Shift by a path component. 318 | ($:>) :: String -> PStruct a -> PStruct a 319 | c $:> p = mempty {psComponents = M.singleton c p} 320 | 321 | infixr 4 $:> 322 | 323 | -- | Add a command-line option to all endpoints. 324 | (?:>) :: Opt a -> PStruct (a -> b) -> PStruct b 325 | o ?:> PStruct ns cs c ep = PStruct ns cs' c' ep' 326 | where 327 | cs' = (o ?:>) <$> cs 328 | c' = 329 | c <&> \case 330 | L1 (Day a p f) -> 331 | let f' x y z = f z x y 332 | in L1 $ Day a (o ?:> (f' <$> p)) (&) 333 | R1 (Day a p f) -> 334 | let f' x y z = f z x y 335 | in R1 $ Day a (addEPMOpt o (f' <$> p)) (&) 336 | ep' = addEPMOpt o ep 337 | 338 | infixr 4 ?:> 339 | 340 | addEndpointOpt :: Opt a -> Endpoint (a -> b) -> Endpoint b 341 | addEndpointOpt o (Endpoint (Day eo eb ef)) = 342 | Endpoint (Day ((,) <$> inject o <*> eo) eb $ \(x, y) z -> ef y z x) 343 | 344 | addEPMOpt :: Opt a -> EndpointMap (a -> b) -> EndpointMap b 345 | addEPMOpt o (EPM e r) = EPM e' r' 346 | where 347 | e' = addEndpointOpt o <$> e 348 | r' = addEndpointOpt o . fmap flip <$> r 349 | 350 | -- | Add notes to the beginning of a documentation level. 351 | note :: [String] -> PStruct a -> PStruct a 352 | note ns (PStruct ms cs c ep) = PStruct (ns ++ ms) cs c ep 353 | 354 | infixr 4 `note` 355 | 356 | -- | Add a single argument praser. 357 | (#:>) :: Arg a -> PStruct (a -> b) -> PStruct b 358 | a #:> p = mempty {psCaptures = Just (L1 (Day a p (&)))} 359 | 360 | infixr 4 #:> 361 | 362 | -- | Add a repeating argument parser. 363 | (##:>) :: Arg a -> PStruct ([a] -> b) -> PStruct b 364 | a ##:> p = 365 | mempty 366 | { psCaptures = Just (R1 (Day (MultiArg a) (psEndpoints p) (&))) 367 | } 368 | 369 | infixr 4 ##:> 370 | 371 | -- | Add a request body to all endpoints. 372 | -- 373 | -- If done more than once per endpoint, it runs *both* parsers; however, 374 | -- we can only send one request body, so this is undefined behavior as 375 | -- a client. 376 | (%:>) :: Parser a -> PStruct (a -> b) -> PStruct b 377 | b %:> PStruct ns cs c ep = PStruct ns cs' c' ep' 378 | where 379 | cs' = (b %:>) <$> cs 380 | c' = 381 | c <&> \case 382 | L1 (Day a p f) -> 383 | let f' x y z = f z x y 384 | in L1 $ Day a (b %:> (f' <$> p)) (&) 385 | R1 (Day a p f) -> 386 | let f' x y z = f z x y 387 | in R1 $ Day a (addEPMBody b (f' <$> p)) (&) 388 | ep' = addEPMBody b ep 389 | 390 | infixr 4 %:> 391 | 392 | addEndpointBody :: Parser a -> Endpoint (a -> b) -> Endpoint b 393 | addEndpointBody b (Endpoint d) = 394 | Endpoint (inR b <**> d) 395 | 396 | addEPMBody :: Parser a -> EndpointMap (a -> b) -> EndpointMap b 397 | addEPMBody b (EPM e r) = EPM e' r' 398 | where 399 | e' = addEndpointBody b <$> e 400 | r' = addEndpointBody b . fmap flip <$> r 401 | 402 | -- | Create an endpoint action. 403 | endpoint :: HTTP.Method -> a -> PStruct a 404 | endpoint m x = 405 | mempty 406 | { psEndpoints = EPM (M.singleton m (Endpoint (pure x))) Nothing 407 | } 408 | 409 | -- | Create a raw endpoint. 410 | rawEndpoint :: (HTTP.Method -> a) -> PStruct a 411 | rawEndpoint f = 412 | mempty 413 | { psEndpoints = EPM M.empty (Just (Endpoint (pure f))) 414 | } 415 | 416 | -- | Helper to lift a 'ReadM' into something that can be used with 'optRead'. 417 | orRequired :: ReadM a -> Coyoneda OptRead a 418 | orRequired = inject . ORRequired 419 | 420 | -- | Helper to lift an optional 'ReadM' into something that can be used 421 | -- with 'optRead'. 422 | orOptional :: ReadM a -> Coyoneda OptRead (Maybe a) 423 | orOptional = inject . OROptional 424 | 425 | -- | An 'optRead' that is on-or-off. 426 | orSwitch :: Coyoneda OptRead Bool 427 | orSwitch = inject ORSwitch 428 | 429 | -- | An 'optRead' that is on-or-off. 430 | orMany :: ReadM a -> Coyoneda OptRead [a] 431 | orMany = inject . ORMany 432 | -------------------------------------------------------------------------------- /src/Servant/CLI/ParseBody.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DefaultSignatures #-} 2 | {-# LANGUAGE ScopedTypeVariables #-} 3 | {-# LANGUAGE TypeApplications #-} 4 | 5 | -- | 6 | -- Module : Servant.CLI.ParseBody 7 | -- Copyright : (c) Justin Le 2019 8 | -- License : BSD3 9 | -- 10 | -- Maintainer : justin@jle.im 11 | -- Stability : experimental 12 | -- Portability : non-portable 13 | -- 14 | -- Provides the interface for 'ParseBody', a helper class for defining 15 | -- directly how to parse request bodies. 16 | module Servant.CLI.ParseBody 17 | ( ParseBody (..), 18 | defaultParseBody, 19 | ) 20 | where 21 | 22 | import Data.Char 23 | import qualified Data.Text as T 24 | import qualified Data.Text.Lazy as TL 25 | import Options.Applicative 26 | import Text.Printf 27 | import Type.Reflection 28 | 29 | -- | A helper class for defining directly how to parse request bodies. 30 | -- This allows more complex parsing of bodies. 31 | -- 32 | -- You need an instance of this for every type you use with 33 | -- 'Servant.API.ReqBody'. 34 | class ParseBody a where 35 | parseBody :: Parser a 36 | default parseBody :: (Typeable a, Read a) => Parser a 37 | parseBody = defaultParseBody (show (typeRep @a)) auto 38 | 39 | -- | Default implementation that expects a @--data@ option. 40 | defaultParseBody :: 41 | -- | type specification 42 | String -> 43 | -- | parser 44 | ReadM a -> 45 | Parser a 46 | defaultParseBody mv r = 47 | option 48 | r 49 | ( metavar (printf "<%s>" (map toLower mv)) 50 | <> long "data" 51 | <> short 'd' 52 | <> help (printf "Request body (%s)" mv) 53 | ) 54 | 55 | instance ParseBody T.Text where 56 | parseBody = defaultParseBody "Text" str 57 | 58 | instance ParseBody TL.Text where 59 | parseBody = defaultParseBody "Text" str 60 | 61 | instance ParseBody Int 62 | 63 | instance ParseBody Integer 64 | 65 | instance ParseBody Float 66 | 67 | instance ParseBody Double 68 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | main :: IO () 2 | main = putStrLn "Test suite not yet implemented" 3 | --------------------------------------------------------------------------------