diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,17 @@ Changelog ========= +Version 0.1.0.3 +--------------- + +*January 12, 2024* + + + +* Move to servant-client-core >= 0.20, breaks compatibility with previous + versions. +* Compatibility with opt-parse applicative >= 0.18 + Version 0.1.0.2 --------------- diff --git a/servant-cli.cabal b/servant-cli.cabal --- a/servant-cli.cabal +++ b/servant-cli.cabal @@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack --- --- hash: 2b3be37a4d1cceed3c1f581c09874aba5568f57a825e12c11bfe52f4034673e4 name: servant-cli -version: 0.1.0.2 +version: 0.1.0.3 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 @@ -26,8 +24,9 @@ copyright: (c) Justin Le 2019 license: BSD3 license-file: LICENSE -tested-with: GHC >= 8.6 build-type: Simple +tested-with: + GHC >= 8.6 extra-source-files: README.md CHANGELOG.md @@ -60,7 +59,7 @@ , profunctors , recursion-schemes , servant >=0.15 - , servant-client-core >=0.15 + , servant-client-core >= 0.20 , servant-docs , text , transformers diff --git a/src/Servant/CLI.hs b/src/Servant/CLI.hs --- a/src/Servant/CLI.hs +++ b/src/Servant/CLI.hs @@ -1,15 +1,12 @@ -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Module : Servant.CLI @@ -30,98 +27,136 @@ -- -- See 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 +module Servant.CLI + ( -- * Parse Client + parseClient, + parseHandleClient, -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 + -- ** 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 +cliPStructWithContext :: + (HasCLI m api context) => + -- | Client monad + Proxy m -> + -- | API + Proxy api -> + -- | Extra context + Rec (ContextFor m) 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 :: + forall m api context r. + (HasCLI m api context, Functor m) => + -- | Client monad + Proxy m -> + -- | API + Proxy api -> + -- | Extra context + Rec (ContextFor m) context -> + -- | Handler + CLIHandler m api r -> + PStruct (m r) cliHandlePStructWithContext pm pa p h = - fmap (cliHandler pm pa (Proxy @context) h) - <$> cliPStructWithContext pm pa p + 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 +parseClientWithContext :: + (HasCLI m api context) => + -- | API + Proxy api -> + -- | Client monad + Proxy m -> + -- | Extra context + Rec (ContextFor m) context -> + -- | Options for top-level display + InfoMod (m (CLIResult m api)) -> + 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 :: + forall m api context r. + (HasCLI m api context, Functor m) => + -- | API + Proxy api -> + -- | Client monad + Proxy m -> + -- | Extra context + Rec (ContextFor m) context -> + -- | Options for top-level display + InfoMod (m (CLIResult m api)) -> + -- | Handler + CLIHandler m api r -> + IO (m r) parseHandleClientWithContext pa pm p im h = - fmap (cliHandler pm pa (Proxy @context) h) - <$> parseClientWithContext pa pm p im + 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 :: + (HasCLI m api '[]) => + -- | Client monad + Proxy m -> + -- | API + Proxy api -> + PStruct (m (CLIResult m api)) cliPStruct pm pa = cliPStructWithContext pm pa RNil -- | Create a structure for a command line parser, producing results @@ -131,12 +166,15 @@ -- 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 :: + (HasCLI m api '[], Functor m) => + -- | Client monad + Proxy m -> + -- | API + Proxy api -> + -- | Handler + CLIHandler m api r -> + PStruct (m r) cliHandlePStruct pm pa = cliHandlePStructWithContext pm pa RNil -- | Parse a servant client; the result can be run. The choice of @m@ @@ -153,12 +191,15 @@ -- 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 :: + (HasCLI m api '[]) => + -- | API + Proxy api -> + -- | Client monad + Proxy m -> + -- | Options for top-level display + InfoMod (m (CLIResult m api)) -> + IO (m (CLIResult m api)) parseClient pa pm = parseClientWithContext pa pm RNil -- | Parse a server client, like 'parseClient'. However, instead of that @@ -174,12 +215,15 @@ -- 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 :: + (HasCLI m api '[], Functor m) => + -- | API + Proxy api -> + -- | Client monad + Proxy m -> + -- | Options for top-level display + InfoMod (m (CLIResult m api)) -> + -- | Handler + CLIHandler m api r -> + IO (m r) parseHandleClient pa pm = parseHandleClientWithContext pa pm RNil - diff --git a/src/Servant/CLI/HasCLI.hs b/src/Servant/CLI/HasCLI.hs --- a/src/Servant/CLI/HasCLI.hs +++ b/src/Servant/CLI/HasCLI.hs @@ -1,18 +1,17 @@ -{-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# 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 #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} -- | -- Module : Servant.CLI.HasCLI @@ -28,47 +27,49 @@ -- -- 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 +module Servant.CLI.HasCLI + ( -- * Class + HasCLI (..), -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 + -- * Context + ContextFor (..), + NamedContext (..), + descendIntoNamedContext, + ) +where +import Data.Bifunctor +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy as BSL +import qualified Data.CaseInsensitive as CI +import Data.Char +import Data.Function +import Data.Kind +import Data.List (foldl', intercalate) +import qualified Data.List.NonEmpty as NE +import Data.Profunctor +import Data.Proxy +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +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 + -- | 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. -- @@ -78,51 +79,50 @@ -- 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 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 + -- | 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)) + -- | 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 + -- | 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. -- @@ -132,96 +132,118 @@ -- -- 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 + type CLIResult m EmptyAPI = Void + type CLIHandler m EmptyAPI r = Void -> r - cliPStructWithContext_ _ _ _ = mempty - cliHandler _ _ _ = ($) + 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 +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 + 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) + 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 + 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) + cliPStructWithContext_ pm _ p = + pathstr + $:> (fmap . lmap) + (appendToPath (BSB.byteString $ T.encodeUtf8 $ T.pack pathstr)) + (cliPStructWithContext_ pm (Proxy @api) p) + where + pathstr = symbolVal (Proxy @path) - cliHandler pm _ = cliHandler pm (Proxy @api) + 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 +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 + cliPStructWithContext_ pm _ p = + arg + #:> fmap (.: addCapture) (cliPStructWithContext_ pm (Proxy @api) p) + where + addCapture = appendToPath . BSB.byteString . T.encodeUtf8 . 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)) + capType = show $ typeRep @a + DocCapture {..} = toCapture (Proxy @(Capture sym a)) - cliHandler pm _ = cliHandler pm (Proxy @api) + 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 +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 + cliPStructWithContext_ pm _ p = + arg + ##:> fmap (.: addCapture) (cliPStructWithContext_ pm (Proxy @api) p) + where + addCapture ps req = + foldl' + (flip appendToPath) + req + (map (BSB.byteString . T.encodeUtf8 . 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)) + capType = show $ typeRep @a + DocCapture {..} = toCapture (Proxy @(CaptureAll sym a)) - cliHandler pm _ = cliHandler pm (Proxy @api) + cliHandler pm _ = cliHandler pm (Proxy @api) -- | Query parameters are interpreted as command line options. -- @@ -231,43 +253,51 @@ -- -- 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 +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 + 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 (T.encodeUtf8 $ 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)) + 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) + cliHandler pm _ = cliHandler pm (Proxy @api) -- | Query flags are interpreted as command line flags/switches. -- @@ -277,31 +307,36 @@ -- -- 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 +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 + 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)) + pName = symbolVal (Proxy @sym) + DocQueryParam {..} = toParam (Proxy @(QueryFlag sym)) - cliHandler pm _ = cliHandler pm (Proxy @api) + cliHandler pm _ = cliHandler pm (Proxy @api) -- | Request body requirements are interpreted using 'ParseBody'. -- @@ -309,20 +344,24 @@ -- 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 +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 + 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) + cliHandler pm _ = cliHandler pm (Proxy @api) -- | Final actions are the result of specifying all necessary command line -- positional arguments. @@ -335,61 +374,67 @@ -- 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 +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 _ _ _ = ($) + 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 _ _ _ = ($) +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 } +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 +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 - cliHandler pm _ = cliHandler pm (Proxy @api) + 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 + rbs = + RequestBodySource $ + framingRender + framingP + (mimeRender ctypeP :: chunk -> BSL.ByteString) + (toSourceIO x) + 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, @@ -399,99 +444,105 @@ -- 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 +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 + 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 = addHeader (CI.mk . T.encodeUtf8 . T.pack $ pName) + 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) + 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) + 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 +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) + 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 + 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) + 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) + 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 +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 _ _ _ = ($) + 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 +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) + 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 +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) + 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 +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) + 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'. @@ -499,17 +550,18 @@ -- 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) + = NamedContext (Rec (ContextFor m) subContext) newtype instance ContextFor m (NamedContext m name subContext) - = NC (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 :: + 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 @@ -519,19 +571,23 @@ -- -- 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 +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) + 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)) - } + { 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 @@ -539,24 +595,28 @@ -- 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 +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 + 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) + cliHandler pm _ = cliHandler pm (Proxy @api) newtype instance ContextFor m (BasicAuth realm usr) = GenBasicAuthData - { genBasicAuthData :: m BasicAuthData - } + { genBasicAuthData :: m BasicAuthData + } -- | Add 'GenBasicAuthData' to the required context, meaning it must be -- provided to allow the client to generate authentication data. The @@ -564,37 +624,41 @@ -- 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 +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 + 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)) + DocAuthentication {..} = toAuthInfo (Proxy @(BasicAuth realm usr)) - cliHandler pm _ = cliHandler pm (Proxy @api) + cliHandler pm _ = cliHandler pm (Proxy @api) -- | Helper for mapping parameter generators -withParamM - :: Monad m - => m (a -> a) - -> (a -> m b) - -> a - -> m b +withParamM :: + (Monad m) => + m (a -> a) -> + (a -> m b) -> + a -> + m b withParamM mf g x = do - f <- mf - g (f x) + f <- mf + g (f x) -- | Two-argument function composition (.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d diff --git a/src/Servant/CLI/Internal/PStruct.hs b/src/Servant/CLI/Internal/PStruct.hs --- a/src/Servant/CLI/Internal/PStruct.hs +++ b/src/Servant/CLI/Internal/PStruct.hs @@ -1,15 +1,15 @@ -{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | -- Module : Servant.CLI.PStruct @@ -24,105 +24,120 @@ -- 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 +module Servant.CLI.Internal.PStruct + ( OptRead (..), + Opt (..), + Arg (..), + MultiArg (..), + Captures, + Endpoint (..), + EndpointMap (..), + PStruct (..), + PStructF (..), + structParser, + structParser_, -import Control.Applicative.Backwards -import Control.Applicative.Free -import Data.Foldable -import Data.Function -import Data.Functor -import Data.Functor.Combinator -import Data.Functor.Combinator.Unsafe -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 Data.Proxy -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 + -- * Creating + branch, + ($:>), + (%:>), + (?:>), + (#:>), + (##:>), + note, + endpoint, + rawEndpoint, + -- ** Readers + orRequired, + orOptional, + orSwitch, + ) +where +import Control.Applicative.Backwards +import Control.Applicative.Free +import Data.Foldable +import Data.Function +import Data.Functor +import Data.Functor.Combinator +import Data.Functor.Combinator.Unsafe +import Data.Functor.Foldable +import Data.Functor.Foldable.TH +import Data.Kind +import Data.List.NonEmpty (NonEmpty (..)) +import Data.Map (Map) +import qualified Data.Map as M +import Data.Maybe +import Data.Proxy +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Network.HTTP.Types as HTTP +import Options.Applicative +import qualified Options.Applicative.Help.Pretty as O +import System.FilePath + -- | How to "read" an option. data OptRead :: Type -> Type where - ORRequired :: ReadM a -> OptRead a - OROptional :: ReadM a -> OptRead (Maybe a) - ORSwitch :: OptRead Bool + 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 + { 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 + { 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] + 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 + { 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 +type Captures = + Day Arg PStruct + :+: Day MultiArg EndpointMap -- | Endpoint arguments and body. newtype Endpoint a = Endpoint - { epStruct :: Day (Ap Opt) Parser a } - deriving Functor + {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 + { psInfo :: [String], + -- | path components + psComponents :: Map String (PStruct a), + -- | captures + psCaptures :: Maybe (Captures a), + psEndpoints :: EndpointMap a + } + deriving (Functor) + -- TODO: Capture vs. Endpoint interplay is a bit weird, when they are at -- the same level. @@ -134,100 +149,120 @@ -- 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 :: + -- | The 'PStruct' to convert. + PStruct a -> + -- | Modify how the top-level prompt is displayed. + InfoMod a -> + 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_ :: + PStruct a -> + -- | add helper + Bool -> + -- | root path + [String] -> + -- | modify top level + InfoMod a -> + 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 + 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.pretty $ ns)) + <> im where subs = M.foldMapWithKey (mkCmd p) psComponentsF subp | M.null psComponentsF = empty - | otherwise = subparser $ subs - <> metavar "COMPONENT" - <> commandGroup "Path components:" - cap = unsafePlus (Proxy @Parser) $ - interpret (mkArg p !*! mkArgs) $ MaybeF psCapturesF - ep = methodPicker psEndpointsF - ns = psInfoF + | otherwise = + subparser $ + subs + <> metavar "COMPONENT" + <> commandGroup "Path components:" + cap = + unsafePlus (Proxy @Parser) $ + interpret (mkArg p !*! mkArgs) $ + MaybeF psCapturesF + ep = methodPicker psEndpointsF + ns = psInfoF mkHelp - | toHelp = helper + | toHelp = helper | otherwise = pure id - mkCmd - :: [String] - -> String - -> (Bool -> [String] -> InfoMod x -> ParserInfo x) - -> Mod CommandFields x + 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 -> Parser x mkArg ps (Day a p f) = - f <$> argParser a - <*> infoParser (structParser_ p False (ps ++ [':' : argName a]) mempty) + f + <$> argParser a + <*> infoParser (structParser_ p False (ps ++ [':' : argName a]) mempty) mkArgs :: Day MultiArg EndpointMap x -> Parser x - mkArgs = unsafeApply (Proxy @Parser) $ - forwards - . ( Backwards . (\case MultiArg a -> many (argParser a)) - !*! Backwards . methodPicker - ) + mkArgs = + unsafeApply (Proxy @Parser) $ + forwards + . ( Backwards . (\case MultiArg a -> many (argParser a)) + !*! Backwards . methodPicker + ) argParser :: Arg x -> Parser x - argParser Arg{..} = argument argRead $ help argDesc - <> metavar argMeta + argParser Arg {..} = + argument argRead $ + help argDesc + <> metavar argMeta mkOpt :: Opt x -> Parser x - mkOpt Opt{..} = forI optRead $ \case - ORRequired r -> option r mods - OROptional r -> optional $ option r mods - ORSwitch -> switch $ long optName <> help optDesc + mkOpt Opt {..} = forI 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 + 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:" + 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 = unsafeApply (Proxy @Parser) $ + mkEndpoint = + unsafeApply (Proxy @Parser) $ binterpret (interpret mkOpt) id - . epStruct + . 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 ..]) + 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 @@ -235,28 +270,28 @@ -- conflicts. If the left hand has a raw endpoint, the right hand's -- endpoints are ignored. instance Semigroup (EndpointMap a) where - (<>) = altEPM + (<>) = altEPM instance Monoid (EndpointMap a) where - mempty = EPM M.empty Nothing + 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 + e3 = case r1 of + Just _ -> e1 Nothing -> M.unionWith const e1 e2 - r3 = r1 <|> r2 + 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 + PStruct ns3 cs3 c3 ep3 where - ns3 = ns1 ++ ns2 -- ?? + ns3 = ns1 ++ ns2 -- ?? cs3 = case c1 of - Just _ -> cs1 + Just _ -> cs1 Nothing -> M.unionWith altPStruct cs1 cs2 - c3 = c1 <|> c2 + c3 = c1 <|> c2 ep3 = ep1 <> ep2 -- | Combine two 'PStruct's, preferring the left hand side for conflicts. @@ -264,10 +299,10 @@ -- If the left hand has a raw endpoint, the right hand's endpoints are -- ignored. instance Semigroup (PStruct a) where - (<>) = altPStruct + (<>) = altPStruct instance Monoid (PStruct a) where - mempty = PStruct [] M.empty Nothing mempty + mempty = PStruct [] M.empty Nothing mempty -- | Combine two 'PStruct's in an either-or fashion, favoring the left hand -- side. @@ -278,7 +313,8 @@ -- | Shift by a path component. ($:>) :: String -> PStruct a -> PStruct a -c $:> p = mempty { psComponents = M.singleton c p } +c $:> p = mempty {psComponents = M.singleton c p} + infixr 4 $:> -- | Add a command-line option to all endpoints. @@ -286,19 +322,21 @@ o ?:> PStruct ns cs c ep = PStruct ns cs' c' ep' where cs' = (o ?:>) <$> cs - c' = c <&> \case + c' = + c <&> \case L1 (Day a p f) -> let f' x y z = f z x y - in L1 $ Day a (o ?:> (f' <$> p)) (&) + 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)) (&) + 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 ((,) <$> inject o <*> eo) eb $ \(x, y) z -> ef y z x) + Endpoint (Day ((,) <$> inject 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' @@ -309,18 +347,22 @@ -- | 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 (&))) } +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 +a ##:> p = + mempty { psCaptures = Just (R1 (Day (MultiArg a) (psEndpoints p) (&))) } + infixr 4 ##:> -- | Add a request body to all endpoints. @@ -332,19 +374,21 @@ b %:> PStruct ns cs c ep = PStruct ns cs' c' ep' where cs' = (b %:>) <$> cs - c' = c <&> \case + c' = + c <&> \case L1 (Day a p f) -> let f' x y z = f z x y - in L1 $ Day a (b %:> (f' <$> p)) (&) + 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)) (&) + 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 d) = - Endpoint (inR b <**> d) + Endpoint (inR b <**> d) addEPMBody :: Parser a -> EndpointMap (a -> b) -> EndpointMap b addEPMBody b (EPM e r) = EPM e' r' @@ -354,13 +398,15 @@ -- | Create an endpoint action. endpoint :: HTTP.Method -> a -> PStruct a -endpoint m x = mempty +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 +rawEndpoint f = + mempty { psEndpoints = EPM M.empty (Just (Endpoint (pure f))) } @@ -376,4 +422,3 @@ -- | An 'optRead' that is on-or-off. orSwitch :: Coyoneda OptRead Bool orSwitch = inject ORSwitch - diff --git a/src/Servant/CLI/ParseBody.hs b/src/Servant/CLI/ParseBody.hs --- a/src/Servant/CLI/ParseBody.hs +++ b/src/Servant/CLI/ParseBody.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Servant.CLI.ParseBody @@ -13,17 +13,18 @@ -- -- Provides the interface for 'ParseBody', a helper class for defining -- directly how to parse request bodies. -module Servant.CLI.ParseBody ( - ParseBody(..) - , defaultParseBody - ) where +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 +import Data.Char +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import Options.Applicative +import Text.Printf +import Type.Reflection -- | A helper class for defining directly how to parse request bodies. -- This allows more complex parsing of bodies. @@ -31,30 +32,36 @@ -- 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 + 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 +defaultParseBody :: + -- | type specification + String -> + -- | parser + ReadM a -> + Parser a +defaultParseBody mv r = + option + r ( metavar (printf "<%s>" (map toLower mv)) - <> long "data" - <> short 'd' - <> help (printf "Request body (%s)" mv) + <> long "data" + <> short 'd' + <> help (printf "Request body (%s)" mv) ) instance ParseBody T.Text where - parseBody = defaultParseBody "Text" str + parseBody = defaultParseBody "Text" str instance ParseBody TL.Text where - parseBody = defaultParseBody "Text" str + parseBody = defaultParseBody "Text" str -instance ParseBody Int where -instance ParseBody Integer where -instance ParseBody Float where -instance ParseBody Double where +instance ParseBody Int + +instance ParseBody Integer + +instance ParseBody Float + +instance ParseBody Double