servant-cli 0.1.0.2 → 0.1.0.3
raw patch · 6 files changed
+864/−694 lines, 6 filesdep ~optparse-applicativedep ~servant-client-core
Dependency ranges changed: optparse-applicative, servant-client-core
Files
- CHANGELOG.md +11/−0
- servant-cli.cabal +5/−6
- src/Servant/CLI.hs +146/−102
- src/Servant/CLI/HasCLI.hs +453/−389
- src/Servant/CLI/Internal/PStruct.hs +212/−167
- src/Servant/CLI/ParseBody.hs +37/−30
CHANGELOG.md view
@@ -1,6 +1,17 @@ Changelog ========= +Version 0.1.0.3+---------------++*January 12, 2024*++<https://github.com/mstksg/servant-cli/releases/tag/v0.1.0.3>++* Move to servant-client-core >= 0.20, breaks compatibility with previous+ versions.+* Compatibility with opt-parse applicative >= 0.18+ Version 0.1.0.2 ---------------
servant-cli.cabal view
@@ -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
src/Servant/CLI.hs view
@@ -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 <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+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-
src/Servant/CLI/HasCLI.hs view
@@ -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
src/Servant/CLI/Internal/PStruct.hs view
@@ -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-
src/Servant/CLI/ParseBody.hs view
@@ -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