{-# language DataKinds #-}
{-# language KindSignatures #-}
{-# language OverloadedStrings #-}
{-# language TemplateHaskell #-}
module Mu.Quasi.GRpc (
grpc
, compendium
) where
import Control.Monad.IO.Class
import qualified Data.Text as T
import GHC.TypeLits
import Language.Haskell.TH
import Language.ProtocolBuffers.Parser
import qualified Language.ProtocolBuffers.Types as P
import Network.HTTP.Client
import Servant.Client.Core.BaseUrl
import Compendium.Client
import Mu.Quasi.ProtoBuf
import Mu.Rpc
grpc :: String -> (String -> String) -> FilePath -> Q [Dec]
grpc :: String -> (String -> String) -> String -> Q [Dec]
grpc String
schemaName String -> String
servicePrefix String
fp
= do Either (ParseErrorBundle Text Char) ProtoBuf
r <- IO (Either (ParseErrorBundle Text Char) ProtoBuf)
-> Q (Either (ParseErrorBundle Text Char) ProtoBuf)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either (ParseErrorBundle Text Char) ProtoBuf)
-> Q (Either (ParseErrorBundle Text Char) ProtoBuf))
-> IO (Either (ParseErrorBundle Text Char) ProtoBuf)
-> Q (Either (ParseErrorBundle Text Char) ProtoBuf)
forall a b. (a -> b) -> a -> b
$ String -> IO (Either (ParseErrorBundle Text Char) ProtoBuf)
parseProtoBufFile String
fp
case Either (ParseErrorBundle Text Char) ProtoBuf
r of
Left ParseErrorBundle Text Char
e
-> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"could not parse protocol buffers spec: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ParseErrorBundle Text Char -> String
forall a. Show a => a -> String
show ParseErrorBundle Text Char
e)
Right ProtoBuf
p
-> String -> (String -> String) -> ProtoBuf -> Q [Dec]
grpcToDecls String
schemaName String -> String
servicePrefix ProtoBuf
p
compendium :: String -> (String -> String)
-> String -> String -> Q [Dec]
compendium :: String -> (String -> String) -> String -> String -> Q [Dec]
compendium String
schemaTypeName String -> String
servicePrefix String
baseUrl String
identifier
= do Manager
m <- IO Manager -> Q Manager
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> Q Manager) -> IO Manager -> Q Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
defaultManagerSettings
BaseUrl
u <- IO BaseUrl -> Q BaseUrl
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO BaseUrl -> Q BaseUrl) -> IO BaseUrl -> Q BaseUrl
forall a b. (a -> b) -> a -> b
$ String -> IO BaseUrl
forall (m :: * -> *). MonadThrow m => String -> m BaseUrl
parseBaseUrl String
baseUrl
Either ObtainProtoBufError ProtoBuf
r <- IO (Either ObtainProtoBufError ProtoBuf)
-> Q (Either ObtainProtoBufError ProtoBuf)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either ObtainProtoBufError ProtoBuf)
-> Q (Either ObtainProtoBufError ProtoBuf))
-> IO (Either ObtainProtoBufError ProtoBuf)
-> Q (Either ObtainProtoBufError ProtoBuf)
forall a b. (a -> b) -> a -> b
$ Manager
-> BaseUrl -> Text -> IO (Either ObtainProtoBufError ProtoBuf)
obtainProtoBuf Manager
m BaseUrl
u (String -> Text
T.pack String
identifier)
case Either ObtainProtoBufError ProtoBuf
r of
Left ObtainProtoBufError
e
-> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
"could not parse protocol buffers spec: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ ObtainProtoBufError -> String
forall a. Show a => a -> String
show ObtainProtoBufError
e)
Right ProtoBuf
p
-> String -> (String -> String) -> ProtoBuf -> Q [Dec]
grpcToDecls String
schemaTypeName String -> String
servicePrefix ProtoBuf
p
grpcToDecls :: String -> (String -> String) -> P.ProtoBuf -> Q [Dec]
grpcToDecls :: String -> (String -> String) -> ProtoBuf -> Q [Dec]
grpcToDecls String
schemaName String -> String
servicePrefix p :: ProtoBuf
p@P.ProtoBuf { package :: ProtoBuf -> Maybe FullIdentifier
P.package = Maybe FullIdentifier
pkg, services :: ProtoBuf -> [ServiceDeclaration]
P.services = [ServiceDeclaration]
srvs }
= do let schemaName' :: Name
schemaName' = String -> Name
mkName String
schemaName
[Dec]
schemaDec <- String -> ProtoBuf -> Q [Dec]
protobufToDecls String
schemaName ProtoBuf
p
[Dec]
serviceTy <- (ServiceDeclaration -> Q Dec) -> [ServiceDeclaration] -> Q [Dec]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((String -> String)
-> Maybe FullIdentifier -> Name -> ServiceDeclaration -> Q Dec
pbServiceDeclToDec String -> String
servicePrefix Maybe FullIdentifier
pkg Name
schemaName') [ServiceDeclaration]
srvs
[Dec] -> Q [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Dec]
schemaDec [Dec] -> [Dec] -> [Dec]
forall a. [a] -> [a] -> [a]
++ [Dec]
serviceTy)
pbServiceDeclToDec :: (String -> String) -> Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Dec
pbServiceDeclToDec :: (String -> String)
-> Maybe FullIdentifier -> Name -> ServiceDeclaration -> Q Dec
pbServiceDeclToDec String -> String
servicePrefix Maybe FullIdentifier
pkg Name
schema srv :: ServiceDeclaration
srv@(P.Service Text
nm [Option]
_ [Method]
_)
= Name -> [TyVarBndr] -> TypeQ -> Q Dec
tySynD (String -> Name
mkName (String -> Name) -> String -> Name
forall a b. (a -> b) -> a -> b
$ String -> String
servicePrefix (String -> String) -> String -> String
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
nm) []
(Maybe FullIdentifier -> Name -> ServiceDeclaration -> TypeQ
pbServiceDeclToType Maybe FullIdentifier
pkg Name
schema ServiceDeclaration
srv)
pbServiceDeclToType :: Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Type
pbServiceDeclToType :: Maybe FullIdentifier -> Name -> ServiceDeclaration -> TypeQ
pbServiceDeclToType Maybe FullIdentifier
pkg Name
schema (P.Service Text
nm [Option]
_ [Method]
methods)
= [t| 'Package $(pkgType pkg)
'[ 'Service $(textToStrLit nm)
$(typesToList <$> mapM (pbMethodToType schema) methods) ] |]
where
pkgType :: Maybe FullIdentifier -> TypeQ
pkgType Maybe FullIdentifier
Nothing = [t| ('Nothing :: Maybe Symbol) |]
pkgType (Just FullIdentifier
p) = [t| 'Just $(textToStrLit (T.intercalate "." p)) |]
pbMethodToType :: Name -> P.Method -> Q Type
pbMethodToType :: Name -> Method -> TypeQ
pbMethodToType Name
s (P.Method Text
nm Repetition
vr FieldType
v Repetition
rr FieldType
r [Option]
_)
= [t| 'Method $(textToStrLit nm)
$(argToType vr v) $(retToType rr r) |]
where
argToType :: Repetition -> FieldType -> TypeQ
argToType Repetition
P.Single (P.TOther [Text
"google",Text
"protobuf",Text
"Empty"])
= [t| '[ ] |]
argToType Repetition
P.Single (P.TOther FullIdentifier
a)
= [t| '[ 'ArgSingle ('Nothing :: Maybe Symbol) ('SchemaRef $(schemaTy s) $(textToStrLit (T.intercalate "." a))) ] |]
argToType Repetition
P.Stream (P.TOther FullIdentifier
a)
= [t| '[ 'ArgStream ('Nothing :: Maybe Symbol) ('SchemaRef $(schemaTy s) $(textToStrLit (T.intercalate "." a))) ] |]
argToType Repetition
_ FieldType
_
= String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"only message types may be used as arguments"
retToType :: Repetition -> FieldType -> TypeQ
retToType Repetition
P.Single (P.TOther [Text
"google",Text
"protobuf",Text
"Empty"])
= [t| 'RetNothing |]
retToType Repetition
P.Single (P.TOther FullIdentifier
a)
= [t| 'RetSingle ('SchemaRef $(schemaTy s) $(textToStrLit (T.intercalate "." a))) |]
retToType Repetition
P.Stream (P.TOther FullIdentifier
a)
= [t| 'RetStream ('SchemaRef $(schemaTy s) $(textToStrLit (T.intercalate "." a))) |]
retToType Repetition
_ FieldType
_
= String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"only message types may be used as results"
schemaTy :: Name -> Q Type
schemaTy :: Name -> TypeQ
schemaTy Name
schema = Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ Name -> Type
ConT Name
schema
typesToList :: [Type] -> Type
typesToList :: [Type] -> Type
typesToList
= (Type -> Type -> Type) -> Type -> [Type] -> Type
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Type -> Type -> Type
AppT (Type -> Type -> Type) -> (Type -> Type) -> Type -> Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Type -> Type
AppT Type
PromotedConsT) Type
PromotedNilT
textToStrLit :: T.Text -> Q Type
textToStrLit :: Text -> TypeQ
textToStrLit Text
s
= Type -> TypeQ
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> TypeQ) -> Type -> TypeQ
forall a b. (a -> b) -> a -> b
$ TyLit -> Type
LitT (TyLit -> Type) -> TyLit -> Type
forall a b. (a -> b) -> a -> b
$ String -> TyLit
StrTyLit (String -> TyLit) -> String -> TyLit
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s