servant-cli (empty) → 0.1.0.0
raw patch · 10 files changed
+1665/−0 lines, 10 filesdep +aesondep +basedep +bytestringsetup-changed
Dependencies added: aeson, base, bytestring, case-insensitive, containers, filepath, free, http-client, http-types, kan-extensions, optparse-applicative, profunctors, random, recursion-schemes, servant, servant-cli, servant-client, servant-client-core, servant-docs, servant-server, text, vinyl, warp
Files
- CHANGELOG.md +11/−0
- LICENSE +30/−0
- README.md +164/−0
- Setup.hs +2/−0
- example/greet.hs +143/−0
- servant-cli.cabal +90/−0
- src/Servant/CLI.hs +185/−0
- src/Servant/CLI/HasCLI.hs +601/−0
- src/Servant/CLI/Internal/PStruct.hs +379/−0
- src/Servant/CLI/ParseBody.hs +60/−0
+ CHANGELOG.md view
@@ -0,0 +1,11 @@+Changelog+=========++Version 0.1.0.0+---------------++*May 3, 2019*++<https://github.com/mstksg/servant-cli/releases/tag/v0.1.0.0>++* Initial release
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Justin Le (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Justin Le nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,164 @@+# servant-cli++Parse command line arguments into a servant client, from a servant API, using+*optparse-applicative* for parsing, displaying help, and auto-completion.++Hooks into the annotation system used by *servant-docs* to provide descriptions+for parameters and captures.++See `example/greet.hs` for a sample program.++Getting started+---------------++We're going to break down the example program in `example/greet.hs`.++Here's a sample API revolving around greeting and some deep paths, with+authentication.++```haskell+type TestApi =+ Summary "Send a greeting"+ :> "hello"+ :> Capture "name" Text+ :> QueryParam "capital" Bool+ :> Get '[JSON] Text+ :<|> Summary "Greet utilities"+ :> "greet"+ :> ( Get '[JSON] Int+ :<|> Post '[JSON] NoContent+ )+ :<|> Summary "Deep paths test"+ :> "dig"+ :> "down"+ :> "deep"+ :> Summary "Almost there"+ :> Capture "name" Text+ :> "more"+ :> Summary "We made it"+ :> Get '[JSON] Text++testApi :: Proxy TestApi+testApi = Proxy+```++To parse this, we can use `parseClient`, which generates a client action that+we can run:++```haskell+main :: IO ()+ c <- parseClient testApi (Proxy :: Proxy ClientM) $+ header "greet"+ <> progDesc "Greet API"++ manager' <- newManager defaultManagerSettings+ res <- runClientM c $+ mkClientEnv manager' (BaseUrl Http "localhost" 8081 "")++ case res of+ Left e -> throwIO e+ Right r -> putStrLn $ case r of+ Left g -> "Greeting: " ++ T.unpack g+ Right (Left (Left i)) -> show i ++ " returned"+ Right (Left (Right _)) -> "Posted!"+ Right (Right s) -> s+```++Note that `parseClient` and other functions all take `InfoMod`s from+*optparse-applicative*, to customize how the top-level `--help` is displayed.++The result will be a bunch of nested `Either`s for each `:<|>` branch and+endpoint. However, this can be somewhat tedious to handle.++With Handlers+-------------++The library also offers `parseHandleClient`, which accepts nested `:<|>`s with+handlers for each endpoint, mirroring the structure of the API:++```haskell+main :: IO ()+ c <- parseHandleClient testApi (Proxy :: Proxy ClientM)+ (header "greet" <> progDesc "Greet API") $+ (\g -> "Greeting: " ++ T.unpack g)+ :<|> ( (\i -> show i ++ " returned")+ :<|> (\_ -> "Posted!")+ )+ :<|> id++ manager' <- newManager defaultManagerSettings+ res <- runClientM c $+ mkClientEnv manager' (BaseUrl Http "localhost" 8081 "")++ case res of+ Left e -> throwIO e+ Right r -> putStrLn r+```++The handlers essentially let you specify how to sort each potential endpoint's+response into a single output value.++Clients that need context+-------------------------++Things get slightly more complicated when your client requires something that+can't be passed in through the command line, such as authentication information+(username, password).++```haskell+type TestApi =+ Summary "Send a greeting"+ :> "hello"+ :> Capture "name" Text+ :> QueryParam "capital" Bool+ :> Get '[JSON] Text+ :<|> Summary "Greet utilities"+ :> "greet"+ :> ( Get '[JSON] Int+ :<|> BasicAuth "login" Int -- ^ Adding 'BasicAuth'+ :> Post '[JSON] NoContent+ )+ :<|> Summary "Deep paths test"+ :> "dig"+ :> "down"+ :> "deep"+ :> Summary "Almost there"+ :> Capture "name" Text+ :> "more"+ :> Summary "We made it"+ :> Get '[JSON] Text+```++For this, you can pass in a context, using `parseClientWithContext` or+`parseHandleClientWithContext`:++```haskell+main :: IO ()+ c <- parseHandleClientWithContext+ testApi+ (Proxy :: Proxy ClientM)+ (getPwd :& RNil)+ (header "greet" <> progDesc "Greet API") $+ (\g -> "Greeting: " ++ T.unpack g)+ :<|> ( (\i -> show i ++ " returned")+ :<|> (\_ -> "Posted!")+ )+ :<|> id++ manager' <- newManager defaultManagerSettings+ res <- runClientM c $+ mkClientEnv manager' (BaseUrl Http "localhost" 8081 "")++ case res of+ Left e -> throwIO e+ Right r -> putStrLn r+ where+ getPwd :: ContextFor ClientM (BasicAuth "login" Int)+ getPwd = GenBasicAuthData . liftIO $ do+ putStrLn "Authentication needed for this action!"+ putStrLn "Enter username:"+ n <- BS.getLine+ putStrLn "Enter password:"+ p <- BS.getLine+ pure $ BasicAuthData n p+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ example/greet.hs view
@@ -0,0 +1,143 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++import Control.Concurrent+import Control.Exception+import Control.Monad.IO.Class+import Data.Aeson+import Data.Maybe+import Data.Proxy+import Data.Text (Text)+import Data.Vinyl+import GHC.Generics+import Network.HTTP.Client (newManager, defaultManagerSettings)+import Network.Wai.Handler.Warp (run)+import Options.Applicative (header, progDesc)+import Servant.API+import Servant.CLI+import Servant.Client+import Servant.Server+import System.Random+import qualified Data.ByteString as BS+import qualified Data.Map as M+import qualified Data.Text as T+++-- * Example++-- | A greet message data type+newtype Greet = Greet Text+ deriving (Generic, Show)++instance ParseBody Greet where+ parseBody = Greet <$> parseBody++-- | We can get JSON support automatically. This will be used to parse+-- and encode a Greeting as 'JSON'.+instance FromJSON Greet+instance ToJSON Greet++-- We add some useful annotations to our captures,+-- query parameters and request body to make the docs+-- really helpful.+instance ToCapture (Capture "name" Text) where+ toCapture _ = DocCapture "name" "name of the person to greet"++instance ToParam (QueryParam "capital" Bool) where+ toParam _ =+ DocQueryParam "capital"+ ["true", "false"]+ "Get the greeting message in uppercase (true) or not (false). Default is false."+ Normal++instance ToAuthInfo (BasicAuth "login" Int) where+ toAuthInfo _ =+ DocAuthentication "Login credientials"+ "Username and password"++type TestApi =+ Summary "Send a greeting"+ :> "hello"+ :> Capture "name" Text+ :> QueryParam "capital" Bool+ :> Get '[JSON] Greet+ :<|> Summary "Greet utilities"+ :> "greet"+ :> ReqBody '[JSON] Greet+ :> ( Get '[JSON] Int+ :<|> BasicAuth "login" Int+ :> Post '[JSON] NoContent+ )+ :<|> Summary "Deep paths test"+ :> "dig"+ :> "down"+ :> "deep"+ :> Summary "Almost there"+ :> Capture "name" Text+ :> "more"+ :> Summary "We made it"+ :> Get '[JSON] Text+++testApi :: Proxy TestApi+testApi = Proxy++server :: Application+server = serveWithContext testApi (authCheck :. EmptyContext) $+ (\t b -> pure . Greet $ "Hello, "+ <> if fromMaybe False b+ then T.toUpper t+ else t+ )+ :<|> (\(Greet g) -> pure (T.length g)+ :<|> (\_ -> pure NoContent)+ )+ :<|> (pure . T.reverse)+ where+ -- | Map of valid users and passwords+ userMap = M.fromList [("alice", "password"), ("bob", "hunter2")]+ authCheck = BasicAuthCheck $ \(BasicAuthData u p) ->+ case M.lookup u userMap of+ Nothing -> pure NoSuchUser+ Just p'+ | p == p' -> Authorized <$> randomIO @Int+ | otherwise -> pure BadPassword++main :: IO ()+main = do+ c <- parseHandleClientWithContext+ testApi+ (Proxy :: Proxy ClientM)+ (getPwd :& RNil)+ cinfo $+ (\(Greet g) -> "Greeting: " ++ T.unpack g)+ :<|> ( (\i -> show i ++ " letters")+ :<|> (\_ -> "posted!")+ )+ :<|> (\s -> "Reversed: " ++ T.unpack s)++ _ <- forkIO $ run 8081 server++ manager' <- newManager defaultManagerSettings+ res <- runClientM c (mkClientEnv manager' (BaseUrl Http "localhost" 8081 ""))++ case res of+ Left e -> throwIO e+ Right rstring -> putStrLn rstring+ where+ cinfo = header "greet" <> progDesc "Greet API"+ getPwd :: ContextFor ClientM (BasicAuth "login" Int)+ getPwd = GenBasicAuthData . liftIO $ do+ putStrLn "Authentication needed for this action!"+ putStrLn "(Hint: try 'bob' and 'hunter2')"+ putStrLn "Enter username:"+ n <- BS.getLine+ putStrLn "Enter password:"+ p <- BS.getLine+ pure $ BasicAuthData n p
+ servant-cli.cabal view
@@ -0,0 +1,90 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 85f3cb39849fe82dcb28a8a8da108c99ffb6de9a912b6acd59c5a6a8ccf8793a++name: servant-cli+version: 0.1.0.0+synopsis: Command line interface for Servant API clients+description: Parse command line arguments into a servant client, from a servant API,+ using /optparse-applicative/ for parsing, displaying help, and+ auto-completion.+ .+ Hooks into the annotation system used by /servant-docs/ to provide descriptions+ for parameters and captures.+ .+ See @example/greet.hs@ for an example usage, and the+ <https://hackage.haskell.org/package/servant-cli README> for a tutorial.+category: Web+homepage: https://github.com/mstksg/servant-cli#readme+bug-reports: https://github.com/mstksg/servant-cli/issues+author: Justin Le+maintainer: justin@jle.im+copyright: (c) Justin Le 2019+license: BSD3+license-file: LICENSE+build-type: Simple+extra-source-files:+ README.md+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/mstksg/servant-cli++library+ exposed-modules:+ Servant.CLI+ Servant.CLI.HasCLI+ Servant.CLI.Internal.PStruct+ Servant.CLI.ParseBody+ other-modules:+ Paths_servant_cli+ hs-source-dirs:+ src+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -Werror=incomplete-patterns+ build-depends:+ base >=4.7 && <5+ , bytestring+ , case-insensitive+ , containers+ , filepath+ , free+ , http-types+ , kan-extensions+ , optparse-applicative+ , profunctors+ , recursion-schemes+ , servant >=0.15+ , servant-client-core >=0.15+ , servant-docs+ , text+ , vinyl+ default-language: Haskell2010++executable greet-cli+ main-is: greet.hs+ other-modules:+ Paths_servant_cli+ hs-source-dirs:+ example+ ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -Werror=incomplete-patterns+ build-depends:+ aeson+ , base >=4.7 && <5+ , bytestring+ , containers+ , http-client+ , optparse-applicative+ , random+ , servant >=0.15+ , servant-cli+ , servant-client+ , servant-server+ , text+ , vinyl+ , warp+ default-language: Haskell2010
+ src/Servant/CLI.hs view
@@ -0,0 +1,185 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}++-- |+-- Module : Servant.CLI+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- Parse command line arguments into a servant client, from a servant API.+--+-- Mainly used through 'parseClient' and 'parseHandleClient'.+-- 'parseClient' returns a servant client action that returns nested+-- 'Either's for every endpoint, but 'parseHandleClient' allows you to+-- conveniently specify how you want to sort each endpoint entry into+-- a single result.+--+-- See <https://hackage.haskell.org/package/servant-cli README> for+-- a tutorial.+module Servant.CLI (+ -- * Parse Client+ parseClient, parseHandleClient+ -- ** With context+ , parseClientWithContext, parseHandleClientWithContext+ -- * Typeclasses+ , HasCLI (CLIResult, CLIHandler, cliHandler)+ -- * Context+ , ContextFor(..)+ , NamedContext(..)+ , descendIntoNamedContext+ -- * Lower-level+ , cliPStruct, cliPStructWithContext+ , structParser+ -- ** With context+ , cliHandlePStruct, cliHandlePStructWithContext+ -- * Re-export+ , ParseBody(..), defaultParseBody+ , ToCapture(..), DocCapture(..)+ , ToParam(..), DocQueryParam(..), ParamKind(..)+ , ToAuthInfo(..), DocAuthentication(..)+ ) where++import Data.Proxy+import Data.Vinyl+import Options.Applicative+import Servant.CLI.HasCLI+import Servant.CLI.Internal.PStruct+import Servant.CLI.ParseBody+import Servant.Client.Core+import Servant.Docs.Internal++-- | A version of 'cliPStruct' that can be used if the API requires+-- any external context to generate runtime data.+cliPStructWithContext+ :: HasCLI m api context+ => Proxy m -- ^ Client monad+ -> Proxy api -- ^ API+ -> Rec (ContextFor m) context -- ^ Extra context+ -> PStruct (m (CLIResult m api))+cliPStructWithContext pm pa = fmap ($ defaultRequest)+ . cliPStructWithContext_ pm pa++-- | A version of 'cliHandlePStruct' that can be used if the API requires+-- any external context to generate runtime data.+cliHandlePStructWithContext+ :: forall m api context r. (HasCLI m api context, Functor m)+ => Proxy m -- ^ Client monad+ -> Proxy api -- ^ API+ -> Rec (ContextFor m) context -- ^ Extra context+ -> CLIHandler m api r -- ^ Handler+ -> PStruct (m r)+cliHandlePStructWithContext pm pa p h =+ fmap (cliHandler pm pa (Proxy @context) h)+ <$> cliPStructWithContext pm pa p++-- | A version of 'parseClient' that can be used if the API requires+-- any external context to generate runtime data.+parseClientWithContext+ :: HasCLI m api context+ => Proxy api -- ^ API+ -> Proxy m -- ^ Client monad+ -> Rec (ContextFor m) context -- ^ Extra context+ -> InfoMod (m (CLIResult m api)) -- ^ Options for top-level display+ -> IO (m (CLIResult m api))+parseClientWithContext pa pm p im = execParser . flip structParser im+ $ cliPStructWithContext pm pa p++-- | A version of 'parseHandleClient' that can be used if the API requires+-- any external context to generate runtime data.+parseHandleClientWithContext+ :: forall m api context r. (HasCLI m api context, Functor m)+ => Proxy api -- ^ API+ -> Proxy m -- ^ Client monad+ -> Rec (ContextFor m) context -- ^ Extra context+ -> InfoMod (m (CLIResult m api)) -- ^ Options for top-level display+ -> CLIHandler m api r -- ^ Handler+ -> IO (m r)+parseHandleClientWithContext pa pm p im h =+ fmap (cliHandler pm pa (Proxy @context) h)+ <$> parseClientWithContext pa pm p im++-- | Create a structure for a command line parser.+--+-- This can be useful if you are combining functionality with existing+-- /optparse-applicative/ parsers. You can convert a 'PStruct' to+-- a 'Parser' using 'structParser'.+cliPStruct+ :: HasCLI m api '[]+ => Proxy m -- ^ Client monad+ -> Proxy api -- ^ API+ -> PStruct (m (CLIResult m api))+cliPStruct pm pa = cliPStructWithContext pm pa RNil++-- | Create a structure for a command line parser, producing results+-- according to a 'CLIHandler'. See 'parseHandleClient' for more+-- information.+--+-- This can be useful if you are combining functionality with existing+-- /optparse-applicative/ parsers. You can convert a 'PStruct' to+-- a 'Parser' using 'structParser'.+cliHandlePStruct+ :: (HasCLI m api '[], Functor m)+ => Proxy m -- ^ Client monad+ -> Proxy api -- ^ API+ -> CLIHandler m api r -- ^ Handler+ -> PStruct (m r)+cliHandlePStruct pm pa = cliHandlePStructWithContext pm pa RNil++-- | Parse a servant client; the result can be run. The choice of @m@+-- gives the backend you are using; for example, the default GHC+-- /servant-client/ backend is 'Servant.Client.ClientM'.+--+-- Returns the request response, which is usually a layer of 'Either' for+-- every endpoint branch. You can find the response type directly by using+-- typed holes or asking ghci with @:t@ or @:kind! forall m. CLIResult+-- m MyAPI@. Because it might be tedious handling nested 'Either's, see+-- 'parseHandleClient' for a way to handle each potential branch in+-- a convenient way.+--+-- Takes options on how the top-level prompt is displayed when given+-- @"--help"@; it can be useful for adding a header or program description.+-- Otherwise, just use 'mempty'.+parseClient+ :: HasCLI m api '[]+ => Proxy api -- ^ API+ -> Proxy m -- ^ Client monad+ -> InfoMod (m (CLIResult m api)) -- ^ Options for top-level display+ -> IO (m (CLIResult m api))+parseClient pa pm = parseClientWithContext pa pm RNil++-- | Parse a server client, like 'parseClient'. However, instead of that+-- client action returning the request response, instead use a 'CLIHandler'+-- to handle every potential request response. It essentially lets you+-- specify how to sort each potential endpoint's response into a single+-- output value.+--+-- The handler is usually a 'Servant.API.:<|>' for every endpoint branch.+-- You can find it by using typed holes or asking ghci with @:t@ or @:kind!+-- forall m r. CLIHandler m MyAPI r@.+--+-- Takes options on how the top-level prompt is displayed when given+-- @"--help"@; it can be useful for adding a header or program description.+-- Otherwise, just use 'mempty'.+parseHandleClient+ :: (HasCLI m api '[], Functor m)+ => Proxy api -- ^ API+ -> Proxy m -- ^ Client monad+ -> InfoMod (m (CLIResult m api)) -- ^ Options for top-level display+ -> CLIHandler m api r -- ^ Handler+ -> IO (m r)+parseHandleClient pa pm = parseHandleClientWithContext pa pm RNil+
+ src/Servant/CLI/HasCLI.hs view
@@ -0,0 +1,601 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ViewPatterns #-}++-- |+-- Module : Servant.CLI.HasCLI+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- Main module providing underlying functionality for the command line+-- interface parser for servant API clients.+--+-- For the most part, you can ignore this module unless you're adding new+-- API combinators.+module Servant.CLI.HasCLI (+ -- * Class+ HasCLI(..)+ -- * Context+ , ContextFor(..)+ , NamedContext(..)+ , descendIntoNamedContext+ ) where++import Data.Bifunctor+import Data.Char+import Data.Function+import Data.Kind+import Data.List+import Data.Profunctor+import Data.Proxy+import Data.Vinyl hiding (rmap)+import Data.Void+import GHC.TypeLits hiding (Mod)+import Options.Applicative+import Servant.API hiding (addHeader)+import Servant.API.Modifiers+import Servant.CLI.Internal.PStruct+import Servant.CLI.ParseBody+import Servant.Client.Core+import Servant.Docs.Internal hiding (Endpoint, Response)+import Text.Printf+import Type.Reflection+import qualified Data.ByteString.Lazy as BSL+import qualified Data.CaseInsensitive as CI+import qualified Data.List.NonEmpty as NE+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++-- | Data family associating API combinators with contexts required to run+-- them. These typically will be actions in @m@ that fetch/generate the+-- required data, and will only be "run" if the user selects an endpoint+-- that requires it through the command line interface.+data family ContextFor (m :: Type -> Type) :: Type -> Type+++-- | Typeclass defining how each API combinator influences how a server can+-- be interacted with using command line options.+--+-- Note that query parameters and captures all require /servant-docs/+-- annotation instances, to allow for proper help messages.+--+-- Unless you are adding new combinators to be used with APIs, you can+-- ignore this class.+class HasCLI m api ctx where++ -- | The parsed type of the client request response. Usually this will+ -- be a bunch of nested 'Either's for every API endpoint, nested+ -- according to the ':<|>'s in the API.+ type CLIResult (m :: Type -> Type) (api :: Type) :: Type++ -- | The type of a data structure to conveniently handle the results of+ -- all pontential endpoints. This is useful because it is often+ -- tedious to handle the bunch of nested 'Either's that 'CLIResult'+ -- has.+ --+ -- It essentially lets you specify how to sort each potential+ -- endpoint's response into a single output value.+ --+ -- Usually this will be a bunch of nested ':<|>'s which handle each+ -- endpoint, according to the ':<|>'s in the API. It mirrors the+ -- structure of 'Client' and 'Servant.Server.ServerT'.+ --+ -- Used with functions like 'Servant.CLI.parseHandleClient'.+ type CLIHandler (m :: Type -> Type) (api :: Type) (r :: Type) :: Type++ -- | Create a structure for a command line parser, which parses how to+ -- modify a 'Request' and perform an action, given an API and+ -- underlying monad. Only meant for internal use; should be used+ -- through 'Servant.CLI.cliPStructWithContext' instead.+ --+ -- Takes a 'Rec' of actions to generate required items that cannot be+ -- passed via the command line (like authentication). Pass in 'RNil'+ -- if no parameters are expected. The actions will only be run if they+ -- are needed.+ cliPStructWithContext_+ :: Proxy m+ -> Proxy api+ -> Rec (ContextFor m) ctx+ -> PStruct (Request -> m (CLIResult m api))++ -- | Handle all the possibilities in a 'CLIResult', by giving the+ -- appropriate 'CLIHandler'.+ cliHandler+ :: Proxy m+ -> Proxy api+ -> Proxy ctx+ -> CLIHandler m api r+ -> CLIResult m api+ -> r++-- | 'EmptyAPI' will always fail to parse.+--+-- The branch ending in 'EmptyAPI' will never be return, so if this is+-- combined using ':<|>', the branch will never end up on the side of+-- 'EmptyAPI'.+--+-- One can use 'absurd' to handle this branch as a part of 'CLIHandler'.+instance HasCLI m EmptyAPI ctx where+ type CLIResult m EmptyAPI = Void+ type CLIHandler m EmptyAPI r = Void -> r++ cliPStructWithContext_ _ _ _ = mempty+ cliHandler _ _ _ = ($)++-- | Using alternation with ':<|>' provides an 'Either' between the two+-- results.+instance ( HasCLI m a ctx+ , HasCLI m b ctx+ , Functor m+ ) => HasCLI m (a :<|> b) ctx where+ type CLIResult m (a :<|> b) = Either (CLIResult m a) (CLIResult m b)+ type CLIHandler m (a :<|> b) r = CLIHandler m a r :<|> CLIHandler m b r++ cliPStructWithContext_ pm _ p =+ dig Left (cliPStructWithContext_ pm (Proxy @a) p)+ <> dig Right (cliPStructWithContext_ pm (Proxy @b) p)+ where+ dig = fmap . rmap . fmap++ cliHandler pm _ pc (hA :<|> hB) = either (cliHandler pm (Proxy @a) pc hA)+ (cliHandler pm (Proxy @b) pc hB)++-- | A path component is interpreted as a "subcommand".+instance (KnownSymbol path, HasCLI m api ctx) => HasCLI m (path :> api) ctx where+ type CLIResult m (path :> api) = CLIResult m api+ type CLIHandler m (path :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ p = pathstr $:>+ (fmap . lmap) (appendToPath (T.pack pathstr)) (cliPStructWithContext_ pm (Proxy @api) p)+ where+ pathstr = symbolVal (Proxy @path)++ cliHandler pm _ = cliHandler pm (Proxy @api)++-- | A 'Capture' is interpreted as a positional required command line argument.+--+-- Note that these require 'ToCapture' instances from /servant-docs/, to+-- provide appropriate help messages.+instance ( FromHttpApiData a+ , ToHttpApiData a+ , Typeable a+ , ToCapture (Capture sym a)+ , HasCLI m api ctx+ ) => HasCLI m (Capture' mods sym a :> api) ctx where+ type CLIResult m (Capture' mods sym a :> api) = CLIResult m api+ type CLIHandler m (Capture' mods sym a :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ p = arg #:>+ fmap (.: addCapture) (cliPStructWithContext_ pm (Proxy @api) p)+ where+ addCapture = appendToPath . toUrlPiece+ arg = Arg+ { argName = _capSymbol+ , argDesc = printf "%s (%s)" _capDesc capType+ , argMeta = printf "<%s>" _capSymbol+ , argRead = eitherReader $ first T.unpack . parseUrlPiece @a . T.pack+ }+ capType = show $ typeRep @a+ DocCapture{..} = toCapture (Proxy @(Capture sym a))++ cliHandler pm _ = cliHandler pm (Proxy @api)++-- | A 'CaptureAll' is interpreted as arbitrarily many command line+-- arguments. If there is more than one final endpoint method, the method+-- must be given as a command line option before beginning the arguments.+instance ( FromHttpApiData a+ , ToHttpApiData a+ , Typeable a+ , ToCapture (CaptureAll sym a)+ , HasCLI m api ctx+ ) => HasCLI m (CaptureAll sym a :> api) ctx where+ type CLIResult m (CaptureAll sym a :> api) = CLIResult m api+ type CLIHandler m (CaptureAll sym a :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ p = arg ##:>+ fmap (.: addCapture) (cliPStructWithContext_ pm (Proxy @api) p)+ where+ addCapture ps req = foldl' (flip appendToPath) req (map toUrlPiece ps)+ arg = Arg+ { argName = _capSymbol+ , argDesc = printf "%s (%s)" _capDesc capType+ , argMeta = printf "<%s>" _capSymbol+ , argRead = eitherReader $ first T.unpack . parseUrlPiece @a . T.pack+ }+ capType = show $ typeRep @a+ DocCapture{..} = toCapture (Proxy @(CaptureAll sym a))++ cliHandler pm _ = cliHandler pm (Proxy @api)++-- | Query parameters are interpreted as command line options.+--+-- 'QueryParam'' arguments are associated with the action at their+-- endpoint. After entering all path components and positional arguments,+-- the parser library will begin asking for arguments.+--+-- Note that these require 'ToParam' instances from /servant-docs/, to+-- provide appropriate help messages.+instance ( KnownSymbol sym+ , FromHttpApiData a+ , ToHttpApiData a+ , SBoolI (FoldRequired' 'False mods)+ , Typeable a+ , ToParam (QueryParam' mods sym a)+ , HasCLI m api ctx+ ) => HasCLI m (QueryParam' mods sym a :> api) ctx where+ type CLIResult m (QueryParam' mods sym a :> api) = CLIResult m api+ type CLIHandler m (QueryParam' mods sym a :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ p = opt ?:>+ fmap (.: addParam) (cliPStructWithContext_ pm (Proxy @api) p)+ where+ addParam :: RequiredArgument mods a -> Request -> Request+ addParam = foldRequiredArgument (Proxy @mods) add (maybe id add)+ add :: a -> Request -> Request+ add param = appendToQueryString (T.pack pName) (Just (toQueryParam param))+ opt :: Opt (RequiredArgument mods a)+ opt = Opt+ { optName = pName+ , optDesc = printf "%s (%s)" _paramDesc valSpec+ , optMeta = map toUpper pType+ , optVals = NE.nonEmpty _paramValues+ , optRead = case sbool @(FoldRequired mods) of+ STrue -> orRequired r+ SFalse -> orOptional r+ }+ r = eitherReader $ first T.unpack . parseQueryParam @a . T.pack+ pType = show $ typeRep @a+ valSpec+ | null _paramValues = pType+ | otherwise = "options: " ++ intercalate ", " _paramValues+ pName = symbolVal (Proxy @sym)+ DocQueryParam{..} = toParam (Proxy @(QueryParam' mods sym a))++ cliHandler pm _ = cliHandler pm (Proxy @api)++-- | Query flags are interpreted as command line flags/switches.+--+-- 'QueryFlag' arguments are associated with the action at their endpoint.+-- After entering all path components and positional arguments, the parser+-- library will begin asking for arguments.+--+-- Note that these require 'ToParam' instances from /servant-docs/, to+-- provide appropriate help messages.+instance ( KnownSymbol sym+ , ToParam (QueryFlag sym)+ , HasCLI m api ctx+ ) => HasCLI m (QueryFlag sym :> api) ctx where+ type CLIResult m (QueryFlag sym :> api) = CLIResult m api+ type CLIHandler m (QueryFlag sym :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ p = opt ?:>+ fmap (.: addParam) (cliPStructWithContext_ pm (Proxy @api) p)+ where+ addParam :: Bool -> Request -> Request+ addParam = \case+ True -> appendToQueryString (T.pack pName) Nothing+ False -> id+ opt = Opt+ { optName = pName+ , optDesc = _paramDesc+ , optMeta = printf "<%s>" pName+ , optVals = NE.nonEmpty _paramValues+ , optRead = orSwitch+ }+ pName = symbolVal (Proxy @sym)+ DocQueryParam{..} = toParam (Proxy @(QueryFlag sym))++ cliHandler pm _ = cliHandler pm (Proxy @api)++-- | Request body requirements are interpreted using 'ParseBody'.+--+-- Note if more than one 'ReqBody' is in an API endpoint, both parsers will+-- be "run", but only the final one will be used. This shouldn't be an+-- issue, since multiple 'ReqBody's in a single endpoint should be+-- undefined behavior.+instance ( MimeRender ct a+ , ParseBody a+ , HasCLI m api ctx+ ) => HasCLI m (ReqBody' mods (ct ': cts) a :> api) ctx where+ type CLIResult m (ReqBody' mods (ct ': cts) a :> api) = CLIResult m api+ type CLIHandler m (ReqBody' mods (ct ': cts) a :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ p = parseBody @a %:>+ fmap (.: addBody) (cliPStructWithContext_ pm (Proxy @api) p)+ where+ addBody b = setRequestBodyLBS (mimeRender ctProxy b) (contentType ctProxy)+ ctProxy = Proxy @ct++ cliHandler pm _ = cliHandler pm (Proxy @api)++-- | Final actions are the result of specifying all necessary command line+-- positional arguments.+--+-- All command line options are associated with the final action at the end+-- of their endpoint/path. They cannot be entered in "before" you arrive+-- at your final endpoint.+--+-- If more than one action (under a different method) exists+-- under the same endpoint/path, the method (@GET@, @POST@, etc.) will be+-- treated as an extra final command. After that, you may begin entering+-- in options.+instance ( HasClient m (Verb method status cts' a)+ , ReflectMethod method+ ) => HasCLI m (Verb method status cts' a) ctx where+ type CLIResult m (Verb method status cts' a) = a+ type CLIHandler m (Verb method status cts' a) r = a -> r++ cliPStructWithContext_ pm pa _ = endpoint (reflectMethod (Proxy @method)) (clientWithRoute pm pa)+ cliHandler _ _ _ = ($)++-- | Same semantics in parsing command line options as 'Verb'.+instance ( RunStreamingClient m+ , MimeUnrender ct chunk+ , ReflectMethod method+ , FramingUnrender framing+ , FromSourceIO chunk a+ ) => HasCLI m (Stream method status framing ct a) ctx where+ type CLIResult m (Stream method status framing ct a) = a+ type CLIHandler m (Stream method status framing ct a) r = a -> r+ cliPStructWithContext_ pm pa _ = endpoint (reflectMethod (Proxy @method)) (clientWithRoute pm pa)+ cliHandler _ _ _ = ($)++newtype instance ContextFor m (StreamBody' mods framing ctype a) =+ GenStreamBody { genStreamBody :: m a }++-- | As a part of @ctx@, asks for a streaming source @a@.+instance ( ToSourceIO chunk a+ , MimeRender ctype chunk+ , FramingRender framing+ , StreamBody' mods framing ctype a ∈ ctx+ , HasCLI m api ctx+ , Monad m+ ) => HasCLI m (StreamBody' mods framing ctype a :> api) ctx where+ type CLIResult m (StreamBody' mods framing ctype a :> api) = CLIResult m api+ type CLIHandler m (StreamBody' mods framing ctype a :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ p = withParamM (addBody <$> genStreamBody mx)+ <$> cliPStructWithContext_ pm (Proxy @api) p+ where+ mx :: ContextFor m (StreamBody' mods framing ctype a)+ mx = rget p+ addBody :: a -> Request -> Request+ addBody x = setRequestBody rbs (contentType ctypeP)+ where+ ctypeP = Proxy @ctype+ framingP = Proxy @framing+#if MIN_VERSION_servant_client_core(0,16,0)+ rbs = RequestBodySource $+ framingRender framingP+ (mimeRender ctypeP :: chunk -> BSL.ByteString)+ (toSourceIO x)+#else+ rbs = error "HasCLI @StreamBody not supported with servant < 0.16"+#endif++ cliHandler pm _ = cliHandler pm (Proxy @api)++-- | A 'Header'' in the middle of a path is interpreted as a command line+-- argument, prefixed with "header". For example,+-- @'Servant.API.Header.Header' "foo" 'Int'@ is an option for+-- @--header-foo@.+--+-- Like for 'QueryParam'', arguments are associated with the action at+-- their endpoint. After entering all path components and positional+-- arguments, the parser library will begin asking for arguments.+instance ( KnownSymbol sym+ , FromHttpApiData a+ , ToHttpApiData a+ , SBoolI (FoldRequired' 'False mods)+ , Typeable a+ , HasCLI m api ctx+ ) => HasCLI m (Header' mods sym a :> api) ctx where+ type CLIResult m (Header' mods sym a :> api) = CLIResult m api+ type CLIHandler m (Header' mods sym a :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ p = opt ?:>+ fmap (.: addParam) (cliPStructWithContext_ pm (Proxy @api) p)+ where+ addParam :: RequiredArgument mods a -> Request -> Request+ addParam = foldRequiredArgument (Proxy @mods) add (maybe id add)+ add :: a -> Request -> Request+ add v = addHeader (CI.mk . T.encodeUtf8 . T.pack $ pName) v+ opt :: Opt (RequiredArgument mods a)+ opt = Opt+ { optName = printf "header-%s" pName+ , optDesc = printf "Header data %s (%s)" pName pType+ , optMeta = map toUpper pType+ , optVals = Nothing+ , optRead = case sbool @(FoldRequired mods) of+ STrue -> orRequired r+ SFalse -> orOptional r+ }+ r :: ReadM a+ r = eitherReader $ first T.unpack . parseHeader . T.encodeUtf8 . T.pack+ pType = show $ typeRep @a+ pName = symbolVal (Proxy @sym)++ cliHandler pm _ = cliHandler pm (Proxy @api)++-- | Using 'HttpVersion' has no affect on CLI operations.+instance HasCLI m api ctx => HasCLI m (HttpVersion :> api) ctx where+ type CLIResult m (HttpVersion :> api) = CLIResult m api+ type CLIHandler m (HttpVersion :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ = cliPStructWithContext_ pm (Proxy @api)+ cliHandler pm _ = cliHandler pm (Proxy @api)++-- | 'Summary' is displayed during @--help@ when it is reached while+-- navigating down subcommands.+instance (KnownSymbol desc, HasCLI m api ctx) => HasCLI m (Summary desc :> api) ctx where+ type CLIResult m (Summary desc :> api) = CLIResult m api+ type CLIHandler m (Summary desc :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ = note [symbolVal (Proxy @desc)]+ . cliPStructWithContext_ pm (Proxy :: Proxy api)+ cliHandler pm _ = cliHandler pm (Proxy @api)++-- | 'Description' is displayed during @--help@ when it is reached while+-- navigating down subcommands.+instance (KnownSymbol desc, HasCLI m api ctx) => HasCLI m (Description desc :> api) ctx where+ type CLIResult m (Description desc :> api) = CLIResult m api+ type CLIHandler m (Description desc :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ = note [symbolVal (Proxy @desc)]+ . cliPStructWithContext_ pm (Proxy :: Proxy api)+ cliHandler pm _ = cliHandler pm (Proxy @api)+++-- | Asks for method as a command line argument. If any 'Verb' exists at+-- the same endpoint, it can only be accessed as an extra @RAW@ subcommand+-- (as if it had an extra path component labeled @"RAW"@).+instance RunClient m => HasCLI m Raw ctx where+ type CLIResult m Raw = Response+ type CLIHandler m Raw r = Response -> r++ cliPStructWithContext_ pm pa _ = rawEndpoint . flip $ clientWithRoute pm pa+ cliHandler _ _ _ = ($)++instance HasCLI m api ctx => HasCLI m (Vault :> api) ctx where+ type CLIResult m (Vault :> api) = CLIResult m api+ type CLIHandler m (Vault :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ = cliPStructWithContext_ pm (Proxy @api)+ cliHandler pm _ = cliHandler pm (Proxy @api)++instance HasCLI m api ctx => HasCLI m (RemoteHost :> api) ctx where+ type CLIResult m (RemoteHost :> api) = CLIResult m api+ type CLIHandler m (RemoteHost :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ = cliPStructWithContext_ pm (Proxy @api)+ cliHandler pm _ = cliHandler pm (Proxy @api)++instance HasCLI m api ctx => HasCLI m (IsSecure :> api) ctx where+ type CLIResult m (IsSecure :> api) = CLIResult m api+ type CLIHandler m (IsSecure :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ = cliPStructWithContext_ pm (Proxy @api)+ cliHandler pm _ = cliHandler pm (Proxy @api)++-- | Contains a subcontext that can be descended down into using+-- 'NamedContext'. Mirrors 'Servant.Server.NamedContext'.+--+-- Useful for when you have multiple items with the same name within+-- a context; this essentially creates a namespace for context items.+newtype NamedContext m (name :: Symbol) (subContext :: [Type])+ = NamedContext (Rec (ContextFor m) subContext)++newtype instance ContextFor m (NamedContext m name subContext)+ = NC (NamedContext m name subContext)++-- | Allows you to access 'NamedContext's inside a context.+descendIntoNamedContext+ :: forall (name :: Symbol) context subContext m. NamedContext m name subContext ∈ context+ => Proxy name+ -> Rec (ContextFor m) context+ -> Rec (ContextFor m) subContext+descendIntoNamedContext _ p = p'+ where+ NC (NamedContext p' :: NamedContext m name subContext) = rget p++-- | Descend down a subcontext indexed by a given name. Must be provided+-- when parsing within the context.+--+-- Useful for when you have multiple items with the same name within+-- a context; this essentially creates a namespace for context items.+instance ( NamedContext m name subctx ∈ ctx+ , HasCLI m subapi subctx+ ) => HasCLI m (WithNamedContext name subctx subapi) ctx where+ type CLIResult m (WithNamedContext name subctx subapi) = CLIResult m subapi+ type CLIHandler m (WithNamedContext name subctx subapi) r = CLIHandler m subapi r++ cliPStructWithContext_ pm _ = cliPStructWithContext_ pm (Proxy @subapi)+ . descendIntoNamedContext @_ @ctx @subctx (Proxy @name)+ cliHandler pm _ _ = cliHandler pm (Proxy @subapi) (Proxy @subctx)++newtype instance ContextFor m (AuthProtect tag) = GenAuthReq+ { genAuthReq :: m (AuthenticatedRequest (AuthProtect tag))+ }++-- | Add 'GenAuthReq' to the required context, meaning it must be+-- provided to allow the client to generate authentication data. The+-- action will only be run if the user selects this endpoint via command+-- line arguments.+--+-- Please use a secure connection!+instance ( HasCLI m api ctx+ , AuthProtect tag ∈ ctx+ , Monad m+ ) => HasCLI m (AuthProtect tag :> api) ctx where+ type CLIResult m (AuthProtect tag :> api) = CLIResult m api+ type CLIHandler m (AuthProtect tag :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ p = withParamM (uncurry (&) . unAuthReq <$> genAuthReq md)+ <$> cliPStructWithContext_ pm (Proxy @api) p+ where+ md :: ContextFor m (AuthProtect tag)+ md = rget p++ cliHandler pm _ = cliHandler pm (Proxy @api)++newtype instance ContextFor m (BasicAuth realm usr) = GenBasicAuthData+ { genBasicAuthData :: m BasicAuthData+ }++-- | Add 'GenBasicAuthData' to the required context, meaning it must be+-- provided to allow the client to generate authentication data. The+-- action will only be run if the user selects this endpoint via command+-- line arguments.+--+-- Please use a secure connection!+instance ( ToAuthInfo (BasicAuth realm usr)+ , HasCLI m api ctx+ , BasicAuth realm usr ∈ ctx+ , Monad m+ ) => HasCLI m (BasicAuth realm usr :> api) ctx where+ type CLIResult m (BasicAuth realm usr :> api) = CLIResult m api+ type CLIHandler m (BasicAuth realm usr :> api) r = CLIHandler m api r++ cliPStructWithContext_ pm _ p = note [infonote, reqnote]+ $ withParamM (basicAuthReq <$> genBasicAuthData md)+ <$> cliPStructWithContext_ pm (Proxy @api) p+ where+ md :: ContextFor m (BasicAuth realm usr)+ md = rget p+ infonote = "Authentication required: " ++ _authIntro+ reqnote = "Required information: " ++ _authDataRequired++ DocAuthentication{..} = toAuthInfo (Proxy @(BasicAuth realm usr))++ cliHandler pm _ = cliHandler pm (Proxy @api)++-- | Helper for mapping parameter generators+withParamM+ :: Monad m+ => m (a -> a)+ -> (a -> m b)+ -> a+ -> m b+withParamM mf g x = do+ f <- mf+ g (f x)++-- | Two-argument function composition+(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d+(f .: g) x y = f (g x y)
+ src/Servant/CLI/Internal/PStruct.hs view
@@ -0,0 +1,379 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeOperators #-}++-- |+-- Module : Servant.CLI.PStruct+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- Internal module providing a data structure for representing structure of+-- command line parsers that can be manipulated as an ADT, as well as+-- functionality to interpret it as a 'Parser' command line argument+-- parser.+module Servant.CLI.Internal.PStruct (+ OptRead(..)+ , Opt(..)+ , Arg(..)+ , MultiArg(..)+ , Captures+ , Endpoint(..)+ , EndpointMap(..)+ , PStruct(..)+ , PStructF(..)+ , structParser+ , structParser_+ -- * Creating+ , branch+ , ($:>), (%:>), (?:>), (#:>), (##:>), note, endpoint, rawEndpoint+ -- ** Readers+ , orRequired, orOptional, orSwitch+ ) where++import Control.Applicative.Free+import Data.Foldable+import Data.Function+import Data.Functor+import Data.Functor.Coyoneda+import Data.Functor.Day+import Data.Functor.Foldable+import Data.Functor.Foldable.TH+import Data.Kind+import Data.List.NonEmpty (NonEmpty(..))+import Data.Map (Map)+import Data.Maybe+import GHC.Generics+import Options.Applicative+import System.FilePath+import qualified Data.Map as M+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.HTTP.Types as HTTP+import qualified Options.Applicative.Help.Pretty as O+++-- | How to "read" an option.+data OptRead :: Type -> Type where+ ORRequired :: ReadM a -> OptRead a+ OROptional :: ReadM a -> OptRead (Maybe a)+ ORSwitch :: OptRead Bool++-- | Query parameters are interpreted as options+data Opt a = Opt+ { optName :: String+ , optDesc :: String+ , optMeta :: String+ , optVals :: Maybe (NonEmpty String)+ , optRead :: Coyoneda OptRead a+ }+ deriving Functor++-- | Captures are interpreted as arguments+data Arg a = Arg+ { argName :: String+ , argDesc :: String+ , argMeta :: String+ , argRead :: ReadM a+ }+ deriving Functor++-- | Interpret an 'Arg' as something that can be given repeatedly an+-- arbitrary number of times.+data MultiArg :: Type -> Type where+ MultiArg :: Arg a -> MultiArg [a]++-- | A map of endpoints associated with methods, paired with an optional+-- "raw" endpoint.+data EndpointMap a = EPM+ { epmGiven :: Map HTTP.Method (Endpoint a)+ , epmRaw :: Maybe (Endpoint (HTTP.Method -> a))+ }+ deriving Functor++-- | Captures can be a single capture leading to the next level, or+-- a multi-capture leading to an endpoint action.+type Captures = Day Arg PStruct+ :+: Day MultiArg EndpointMap++-- | Endpoint arguments and body.+data Endpoint a = Endpoint+ { epStruct :: Day (Ap Opt) Parser a }+ deriving Functor++-- | Structure for a parser of a given value that may use items from+-- captures and arguments.+data PStruct a = PStruct+ { psInfo :: [String]+ , psComponents :: Map String (PStruct a) -- ^ path components+ , psCaptures :: Maybe (Captures a) -- ^ captures+ , psEndpoints :: EndpointMap a+ }+ deriving Functor+-- TODO: Capture vs. Endpoint interplay is a bit weird, when they are at+-- the same level.++makeBaseFunctor ''PStruct++(|+|) :: (f a -> r) -> (g a -> r) -> (f :+: g) a -> r+f |+| g = \case+ L1 x -> f x+ R1 y -> g y++-- | Convert a 'PStruct' into a command line argument parser, from the+-- /optparse-applicative/ library. It can be run with 'execParser'.+--+-- It takes options on how the top-level prompt is displayed when given+-- @"--help"@; it can be useful for adding a header or program description.+-- Otherwise, just use 'mempty'.+structParser+ :: PStruct a -- ^ The 'PStruct' to convert.+ -> InfoMod a -- ^ Modify how the top-level prompt is displayed.+ -> ParserInfo a+structParser = flip $ \im -> ($ im) . ($ []) . ($ True) . structParser_++-- | Low-level implementation of 'structParser'.+structParser_+ :: PStruct a+ -> Bool -- ^ add helper+ -> [String] -- ^ root path+ -> InfoMod a -- ^ modify top level+ -> ParserInfo a+structParser_ = cata go+ where+ go :: PStructF x (Bool -> [String] -> InfoMod x -> ParserInfo x)+ -> Bool+ -> [String]+ -> InfoMod x+ -> ParserInfo x+ go PStructF{..} toHelp p im = info ((subp <|> cap <|> ep) <**> mkHelp) $+ fullDesc+ <> header (joinPath p)+ <> progDescDoc (Just (O.vcat . map O.string $ ns))+ <> im+ where+ subs = M.foldMapWithKey (mkCmd p) psComponentsF+ subp+ | M.null psComponentsF = empty+ | otherwise = subparser $ subs+ <> metavar "COMPONENT"+ <> commandGroup "Path components:"+ (nsc, cap) = maybe ([], empty) (mkArg p |+| (([],) . mkArgs)) psCapturesF+ ep = methodPicker psEndpointsF+ ns = psInfoF ++ nsc+ mkHelp+ | toHelp = helper+ | otherwise = pure id+ mkCmd+ :: [String]+ -> String+ -> (Bool -> [String] -> InfoMod x -> ParserInfo x)+ -> Mod CommandFields x+ mkCmd ps c p = command c (p True (ps ++ [c]) mempty)+ mkArg :: [String] -> Day Arg PStruct x -> ([String], Parser x)+ mkArg ps (Day a p f) =+ ( []+ , f <$> argParser a+ <*> infoParser (structParser_ p False (ps ++ [':' : argName a]) mempty)+ )+ mkArgs :: Day MultiArg EndpointMap x -> Parser x+ mkArgs (Day (MultiArg a) ps f) =+ flip f <$> methodPicker ps+ <*> many (argParser a)+ argParser :: Arg x -> Parser x+ argParser Arg{..} = argument argRead $ help argDesc+ <> metavar argMeta+ mkOpt :: Opt x -> Parser x+ mkOpt Opt{..} = lowerCoyoneda $ (`hoistCoyoneda` optRead) $ \case+ ORRequired r -> option r mods+ OROptional r -> optional $ option r mods+ ORSwitch -> switch $ long optName <> help optDesc+ where+ mods :: Mod OptionFields y+ mods = long optName+ <> help optDesc+ <> metavar optMeta+ <> foldMap (completeWith . toList) optVals+ methodPicker :: EndpointMap x -> Parser x+ methodPicker (EPM eps rw) = case M.minView epMap of+ Nothing -> maybe empty mkRaw rw+ Just (m0, ms)+ | M.null ms && isNothing rw -> m0+ | otherwise -> subparser $ M.foldMapWithKey pickMethod epMap+ <> foldMap mkRawCommand rw+ <> metavar "METHOD"+ <> commandGroup "HTTP Methods:"+ where+ epMap = mkEndpoint <$> eps+ mkEndpoint :: Endpoint x -> Parser x+ mkEndpoint = dap . trans1 (runAp mkOpt) . epStruct+ pickMethod :: HTTP.Method -> Parser x -> Mod CommandFields x+ pickMethod m p = command (T.unpack . T.decodeUtf8 $ m) $ info (p <**> helper) mempty+ mkRaw :: Endpoint (HTTP.Method -> x) -> Parser x+ mkRaw e = mkEndpoint e <*> o+ where+ o = strOption @HTTP.Method $+ long "method"+ <> help "method for raw request (GET, POST, etc.)"+ <> metavar "METHOD"+ <> completeWith (show <$> [HTTP.GET ..])+ mkRawCommand :: Endpoint (HTTP.Method -> x) -> Mod CommandFields x+ mkRawCommand d = command "RAW" $ info (mkRaw d <**> helper) mempty++-- | Combine two 'EndpointMap's, preferring the left hand side for+-- conflicts. If the left hand has a raw endpoint, the right hand's+-- endpoints are ignored.+instance Semigroup (EndpointMap a) where+ (<>) = altEPM++instance Monoid (EndpointMap a) where+ mempty = EPM M.empty Nothing++altEPM :: EndpointMap a -> EndpointMap a -> EndpointMap a+altEPM (EPM e1 r1) (EPM e2 r2) = EPM e3 r3+ where+ e3 = case r1 of+ Just _ -> e1+ Nothing -> M.unionWith const e1 e2+ r3 = r1 <|> r2++altPStruct :: PStruct a -> PStruct a -> PStruct a+altPStruct (PStruct ns1 cs1 c1 ep1) (PStruct ns2 cs2 c2 ep2) =+ PStruct ns3 cs3 c3 ep3+ where+ ns3 = ns1 ++ ns2 -- ??+ cs3 = case c1 of+ Just _ -> cs1+ Nothing -> M.unionWith altPStruct cs1 cs2+ c3 = c1 <|> c2+ ep3 = ep1 <> ep2++-- | Combine two 'PStruct's, preferring the left hand side for conflicts.+-- If the left hand has a capture, the right hand's components are ignored.+-- If the left hand has a raw endpoint, the right hand's endpoints are+-- ignored.+instance Semigroup (PStruct a) where+ (<>) = altPStruct++instance Monoid (PStruct a) where+ mempty = PStruct [] M.empty Nothing mempty++-- | Combine two 'PStruct's in an either-or fashion, favoring the left hand+-- side.+branch :: PStruct a -> PStruct b -> PStruct (Either a b)+branch x y = (Left <$> x) `altPStruct` (Right <$> y)++infixr 3 `branch`++-- | Shift by a path component.+($:>) :: String -> PStruct a -> PStruct a+c $:> p = mempty { psComponents = M.singleton c p }+infixr 4 $:>++-- | Add a command-line option to all endpoints.+(?:>) :: Opt a -> PStruct (a -> b) -> PStruct b+o ?:> PStruct ns cs c ep = PStruct ns cs' c' ep'+ where+ cs' = (o ?:>) <$> cs+ c' = c <&> \case+ L1 (Day a p f) ->+ let f' x y z = f z x y+ in L1 $ Day a (o ?:> (f' <$> p)) (&)+ R1 (Day a p f) ->+ let f' x y z = f z x y+ in R1 $ Day a (addEPMOpt o (f' <$> p)) (&)+ ep' = addEPMOpt o ep+infixr 4 ?:>++addEndpointOpt :: Opt a -> Endpoint (a -> b) -> Endpoint b+addEndpointOpt o (Endpoint (Day eo eb ef)) =+ Endpoint (Day ((,) <$> liftAp o <*> eo) eb $ \(x, y) z -> ef y z x)++addEPMOpt :: Opt a -> EndpointMap (a -> b) -> EndpointMap b+addEPMOpt o (EPM e r) = EPM e' r'+ where+ e' = addEndpointOpt o <$> e+ r' = addEndpointOpt o . fmap flip <$> r++-- | Add notes to the beginning of a documentation level.+note :: [String] -> PStruct a -> PStruct a+note ns (PStruct ms cs c ep) = PStruct (ns ++ ms) cs c ep+infixr 4 `note`++-- | Add a single argument praser.+(#:>) :: Arg a -> PStruct (a -> b) -> PStruct b+a #:> p = mempty { psCaptures = Just (L1 (Day a p (&))) }+infixr 4 #:>++-- | Add a repeating argument parser.+(##:>) :: Arg a -> PStruct ([a] -> b) -> PStruct b+a ##:> p = mempty+ { psCaptures = Just (R1 (Day (MultiArg a) (psEndpoints p) (&)))+ }+infixr 4 ##:>++-- | Add a request body to all endpoints.+--+-- If done more than once per endpoint, it runs *both* parsers; however,+-- we can only send one request body, so this is undefined behavior as+-- a client.+(%:>) :: Parser a -> PStruct (a -> b) -> PStruct b+b %:> PStruct ns cs c ep = PStruct ns cs' c' ep'+ where+ cs' = (b %:>) <$> cs+ c' = c <&> \case+ L1 (Day a p f) ->+ let f' x y z = f z x y+ in L1 $ Day a (b %:> (f' <$> p)) (&)+ R1 (Day a p f) ->+ let f' x y z = f z x y+ in R1 $ Day a (addEPMBody b (f' <$> p)) (&)+ ep' = addEPMBody b ep+infixr 4 %:>++addEndpointBody :: Parser a -> Endpoint (a -> b) -> Endpoint b+addEndpointBody b (Endpoint (Day eo eb ef)) =+ Endpoint (Day eo (liftA2 (,) b eb) $ \x (y, z) -> ef x z y)++addEPMBody :: Parser a -> EndpointMap (a -> b) -> EndpointMap b+addEPMBody b (EPM e r) = EPM e' r'+ where+ e' = addEndpointBody b <$> e+ r' = addEndpointBody b . fmap flip <$> r++-- | Create an endpoint action.+endpoint :: HTTP.Method -> a -> PStruct a+endpoint m x = mempty+ { psEndpoints = EPM (M.singleton m (Endpoint (pure x))) Nothing+ }++-- | Create a raw endpoint.+rawEndpoint :: (HTTP.Method -> a) -> PStruct a+rawEndpoint f = mempty+ { psEndpoints = EPM M.empty (Just (Endpoint (pure f)))+ }++-- | Helper to lift a 'ReadM' into something that can be used with 'optRead'.+orRequired :: ReadM a -> Coyoneda OptRead a+orRequired = liftCoyoneda . ORRequired++-- | Helper to lift an optional 'ReadM' into something that can be used+-- with 'optRead'.+orOptional :: ReadM a -> Coyoneda OptRead (Maybe a)+orOptional = liftCoyoneda . OROptional++-- | An 'optRead' that is on-or-off.+orSwitch :: Coyoneda OptRead Bool+orSwitch = liftCoyoneda ORSwitch+
+ src/Servant/CLI/ParseBody.hs view
@@ -0,0 +1,60 @@+{-# LANGUAGE DefaultSignatures #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++-- |+-- Module : Servant.CLI.ParseBody+-- Copyright : (c) Justin Le 2019+-- License : BSD3+--+-- Maintainer : justin@jle.im+-- Stability : experimental+-- Portability : non-portable+--+-- Provides the interface for 'ParseBody', a helper class for defining+-- directly how to parse request bodies.+module Servant.CLI.ParseBody (+ ParseBody(..)+ , defaultParseBody+ ) where++import Data.Char+import Options.Applicative+import Text.Printf+import Type.Reflection+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL++-- | A helper class for defining directly how to parse request bodies.+-- This allows more complex parsing of bodies.+--+-- You need an instance of this for every type you use with+-- 'Servant.API.ReqBody'.+class ParseBody a where+ parseBody :: Parser a++ default parseBody :: (Typeable a, Read a) => Parser a+ parseBody = defaultParseBody (show (typeRep @a)) auto++-- | Default implementation that expects a @--data@ option.+defaultParseBody+ :: String -- ^ type specification+ -> ReadM a -- ^ parser+ -> Parser a+defaultParseBody mv r = option r+ ( metavar (printf "<%s>" (map toLower mv))+ <> long "data"+ <> short 'd'+ <> help (printf "Request body (%s)" mv)+ )++instance ParseBody T.Text where+ parseBody = defaultParseBody "Text" str++instance ParseBody TL.Text where+ parseBody = defaultParseBody "Text" str++instance ParseBody Int where+instance ParseBody Integer where+instance ParseBody Float where+instance ParseBody Double where