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