{-# language DataKinds #-}
{-# language OverloadedStrings #-}
{-# language TemplateHaskell #-}
module Mu.Quasi.GRpc (
grpc
, compendium
) where
import Control.Monad.IO.Class
import qualified Data.Text as T
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 schemaName :: String
schemaName servicePrefix :: String -> String
servicePrefix fp :: 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 e :: ParseErrorBundle Text Char
e
-> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("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 p :: 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 schemaTypeName :: String
schemaTypeName servicePrefix :: String -> String
servicePrefix baseUrl :: String
baseUrl identifier :: 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 e :: ObtainProtoBufError
e
-> String -> Q [Dec]
forall (m :: * -> *) a. MonadFail m => String -> m a
fail ("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 p :: 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 schemaName :: String
schemaName servicePrefix :: 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 (m :: * -> *) a. Monad m => a -> m a
return ([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 servicePrefix :: String -> String
servicePrefix pkg :: Maybe FullIdentifier
pkg schema :: Name
schema srv :: ServiceDeclaration
srv@(P.Service nm :: Text
nm _ _)
= 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 pkg :: Maybe FullIdentifier
pkg schema :: Name
schema (P.Service nm :: Text
nm _ methods :: [Method]
methods)
= [t| 'Service $(textToStrLit nm) $(pkgType pkg)
$(typesToList <$> mapM (pbMethodToType schema) methods) |]
where
pkgType :: Maybe FullIdentifier -> TypeQ
pkgType Nothing = [t| '[] |]
pkgType (Just p :: FullIdentifier
p) = [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |]
pbMethodToType :: Name -> P.Method -> Q Type
pbMethodToType :: Name -> Method -> TypeQ
pbMethodToType s :: Name
s (P.Method nm :: Text
nm vr :: Repetition
vr v :: FieldType
v rr :: Repetition
rr r :: FieldType
r _)
= [t| 'Method $(textToStrLit nm) '[]
$(argToType vr v) $(retToType rr r) |]
where
argToType :: Repetition -> FieldType -> TypeQ
argToType P.Single (P.TOther ["google","protobuf","Empty"])
= [t| '[ ] |]
argToType P.Single (P.TOther a :: FullIdentifier
a)
= [t| '[ 'ArgSingle ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |]
argToType P.Stream (P.TOther a :: FullIdentifier
a)
= [t| '[ 'ArgStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |]
argToType _ _
= String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "only message types may be used as arguments"
retToType :: Repetition -> FieldType -> TypeQ
retToType P.Single (P.TOther ["google","protobuf","Empty"])
= [t| 'RetNothing |]
retToType P.Single (P.TOther a :: FullIdentifier
a)
= [t| 'RetSingle ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |]
retToType P.Stream (P.TOther a :: FullIdentifier
a)
= [t| 'RetStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |]
retToType _ _
= String -> TypeQ
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "only message types may be used as results"
schemaTy :: Name -> Q Type
schemaTy :: Name -> TypeQ
schemaTy schema :: Name
schema = Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (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 (\y :: Type
y ys :: Type
ys -> Type -> Type -> Type
AppT (Type -> Type -> Type
AppT Type
PromotedConsT Type
y) Type
ys) Type
PromotedNilT
textToStrLit :: T.Text -> Q Type
textToStrLit :: Text -> TypeQ
textToStrLit s :: Text
s
= Type -> TypeQ
forall (m :: * -> *) a. Monad m => a -> m a
return (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