{-# 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 (
HasCLI(..)
, 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 ContextFor (m :: Type -> Type) :: Type -> Type
class HasCLI m api ctx where
type CLIResult (m :: Type -> Type) (api :: Type) :: Type
type CLIHandler (m :: Type -> Type) (api :: Type) (r :: Type) :: Type
cliPStructWithContext_
:: Proxy m
-> Proxy api
-> Rec (ContextFor m) ctx
-> PStruct (Request -> m (CLIResult m api))
cliHandler
:: Proxy m
-> Proxy api
-> Proxy ctx
-> CLIHandler m api r
-> CLIResult m api
-> r
instance HasCLI m EmptyAPI ctx where
type CLIResult m EmptyAPI = Void
type CLIHandler m EmptyAPI r = Void -> r
cliPStructWithContext_ _ _ _ = mempty
cliHandler _ _ _ = ($)
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)
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)
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)
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)
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)
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)
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)
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 _ _ _ = ($)
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 }
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)
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)
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)
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)
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)
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)
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)
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
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))
}
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
}
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)
withParamM
:: Monad m
=> m (a -> a)
-> (a -> m b)
-> a
-> m b
withParamM mf g x = do
f <- mf
g (f x)
(.:) :: (c -> d) -> (a -> b -> c) -> a -> b -> d
(f .: g) x y = f (g x y)