{-# language DataKinds         #-}
{-# language KindSignatures    #-}
{-# language OverloadedStrings #-}
{-# language TemplateHaskell   #-}
{-|
Description : Quasi-quoters for gRPC files

Read @.proto@ files as a 'Mu.Schema.Definition.Schema'
and a set of 'Service's. The origin of those @.proto@
files can be local (if using 'grpc') or come
from a Compendium Registry (if using 'compendium').
-}
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

-- | Reads a @.proto@ file and generates:
--   * A 'Mu.Schema.Definition.Schema' with all the message
--     types, using the name given as first argument.
--   * A 'Service' declaration for each service in the file,
--     where the name is obtained by applying the function
--     given as second argument to the name in the file.
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

-- | Obtains a schema and service definition from Compendium,
--   and generates the declarations from 'grpc'.
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