{-# language DataKinds             #-}
{-# language DeriveAnyClass        #-}
{-# language DeriveGeneric         #-}
{-# language FlexibleContexts      #-}
{-# language FlexibleInstances     #-}
{-# language GADTs                 #-}
{-# language MultiParamTypeClasses #-}
{-# language OverloadedStrings     #-}
{-# language PartialTypeSignatures #-}
{-# language PolyKinds             #-}
{-# language ScopedTypeVariables   #-}
{-# language TypeApplications      #-}
{-# language TypeFamilies          #-}
{-# language TypeOperators         #-}
{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-}
{-|
Description : Examples for service and server definitions

Look at the source code of this module.
-}
module Mu.Rpc.Examples where

import           Data.Conduit
import           Data.Conduit.Combinators as C
import qualified Data.Text                as T
import           GHC.Generics

import           Mu.Rpc
import           Mu.Schema
import           Mu.Server

-- Defines the service from gRPC Quickstart
-- https://grpc.io/docs/quickstart/python/

type QuickstartSchema
  = '[ 'DRecord "HelloRequest"
      '[ 'FieldDef "name" ('TPrimitive T.Text) ]
     , 'DRecord "HelloResponse"
      '[ 'FieldDef "message" ('TPrimitive T.Text) ]
     , 'DRecord "HiRequest"
      '[ 'FieldDef "number" ('TPrimitive Int) ]
     ]

type QuickStartService
  = 'Package ('Just "helloworld")
      '[ 'Service "Greeter" '[]
        '[ 'Method "SayHello" '[]
          '[ 'ArgSingle 'Nothing '[] ('SchemaRef QuickstartSchema "HelloRequest") ]
            ('RetSingle ('SchemaRef QuickstartSchema "HelloResponse"))
        , 'Method "SayHi" '[]
          '[ 'ArgSingle 'Nothing '[] ('SchemaRef QuickstartSchema "HiRequest")]
            ('RetStream ('SchemaRef QuickstartSchema "HelloResponse"))
        , 'Method "SayManyHellos" '[]
          '[ 'ArgStream 'Nothing '[] ('SchemaRef QuickstartSchema "HelloRequest")]
                ('RetStream ('SchemaRef QuickstartSchema "HelloResponse")) ] ]

newtype HelloRequest = HelloRequest { HelloRequest -> Text
name :: T.Text }
  deriving ( Int -> HelloRequest -> ShowS
[HelloRequest] -> ShowS
HelloRequest -> String
(Int -> HelloRequest -> ShowS)
-> (HelloRequest -> String)
-> ([HelloRequest] -> ShowS)
-> Show HelloRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HelloRequest] -> ShowS
$cshowList :: [HelloRequest] -> ShowS
show :: HelloRequest -> String
$cshow :: HelloRequest -> String
showsPrec :: Int -> HelloRequest -> ShowS
$cshowsPrec :: Int -> HelloRequest -> ShowS
Show, HelloRequest -> HelloRequest -> Bool
(HelloRequest -> HelloRequest -> Bool)
-> (HelloRequest -> HelloRequest -> Bool) -> Eq HelloRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HelloRequest -> HelloRequest -> Bool
$c/= :: HelloRequest -> HelloRequest -> Bool
== :: HelloRequest -> HelloRequest -> Bool
$c== :: HelloRequest -> HelloRequest -> Bool
Eq, (forall x. HelloRequest -> Rep HelloRequest x)
-> (forall x. Rep HelloRequest x -> HelloRequest)
-> Generic HelloRequest
forall x. Rep HelloRequest x -> HelloRequest
forall x. HelloRequest -> Rep HelloRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HelloRequest x -> HelloRequest
$cfrom :: forall x. HelloRequest -> Rep HelloRequest x
Generic
           , ToSchema   QuickstartSchema "HelloRequest"
           , FromSchema QuickstartSchema "HelloRequest" )

newtype HelloResponse = HelloResponse { HelloResponse -> Text
message :: T.Text }
  deriving ( Int -> HelloResponse -> ShowS
[HelloResponse] -> ShowS
HelloResponse -> String
(Int -> HelloResponse -> ShowS)
-> (HelloResponse -> String)
-> ([HelloResponse] -> ShowS)
-> Show HelloResponse
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HelloResponse] -> ShowS
$cshowList :: [HelloResponse] -> ShowS
show :: HelloResponse -> String
$cshow :: HelloResponse -> String
showsPrec :: Int -> HelloResponse -> ShowS
$cshowsPrec :: Int -> HelloResponse -> ShowS
Show, HelloResponse -> HelloResponse -> Bool
(HelloResponse -> HelloResponse -> Bool)
-> (HelloResponse -> HelloResponse -> Bool) -> Eq HelloResponse
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HelloResponse -> HelloResponse -> Bool
$c/= :: HelloResponse -> HelloResponse -> Bool
== :: HelloResponse -> HelloResponse -> Bool
$c== :: HelloResponse -> HelloResponse -> Bool
Eq, (forall x. HelloResponse -> Rep HelloResponse x)
-> (forall x. Rep HelloResponse x -> HelloResponse)
-> Generic HelloResponse
forall x. Rep HelloResponse x -> HelloResponse
forall x. HelloResponse -> Rep HelloResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HelloResponse x -> HelloResponse
$cfrom :: forall x. HelloResponse -> Rep HelloResponse x
Generic
           , ToSchema   QuickstartSchema "HelloResponse"
           , FromSchema QuickstartSchema "HelloResponse" )

newtype HiRequest = HiRequest { HiRequest -> Int
number :: Int }
  deriving ( Int -> HiRequest -> ShowS
[HiRequest] -> ShowS
HiRequest -> String
(Int -> HiRequest -> ShowS)
-> (HiRequest -> String)
-> ([HiRequest] -> ShowS)
-> Show HiRequest
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [HiRequest] -> ShowS
$cshowList :: [HiRequest] -> ShowS
show :: HiRequest -> String
$cshow :: HiRequest -> String
showsPrec :: Int -> HiRequest -> ShowS
$cshowsPrec :: Int -> HiRequest -> ShowS
Show, HiRequest -> HiRequest -> Bool
(HiRequest -> HiRequest -> Bool)
-> (HiRequest -> HiRequest -> Bool) -> Eq HiRequest
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HiRequest -> HiRequest -> Bool
$c/= :: HiRequest -> HiRequest -> Bool
== :: HiRequest -> HiRequest -> Bool
$c== :: HiRequest -> HiRequest -> Bool
Eq, (forall x. HiRequest -> Rep HiRequest x)
-> (forall x. Rep HiRequest x -> HiRequest) -> Generic HiRequest
forall x. Rep HiRequest x -> HiRequest
forall x. HiRequest -> Rep HiRequest x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep HiRequest x -> HiRequest
$cfrom :: forall x. HiRequest -> Rep HiRequest x
Generic
           , ToSchema   QuickstartSchema "HiRequest"
           , FromSchema QuickstartSchema "HiRequest" )

quickstartServer :: forall m. (MonadServer m)
                 => ServerT '[] QuickStartService m _
quickstartServer :: ServerT
  '[]
  QuickStartService
  m
  '[ '[HelloRequest -> m HelloResponse,
       HiRequest -> ConduitT HelloResponse Void m () -> m (),
       ConduitT () HelloRequest m ()
       -> ConduitT HelloResponse Void m () -> m ()]]
quickstartServer
  -- = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0)
  = (Named "SayHello" (() -> HelloRequest -> m HelloResponse),
 Named
   "SayManyHellos"
   (()
    -> ConduitT () HelloRequest m ()
    -> ConduitT HelloResponse Void m ()
    -> m ()),
 Named
   "SayHi"
   (() -> HiRequest -> ConduitT HelloResponse Void m () -> m ()))
-> ServerT
     '[]
     QuickStartService
     m
     '[ '[HelloRequest -> m HelloResponse,
          HiRequest -> ConduitT HelloResponse Void m () -> m (),
          ConduitT () HelloRequest m ()
          -> ConduitT HelloResponse Void m () -> m ()]]
forall serviceName mnm anm p (nl :: [(Symbol, *)])
       (chn :: ServiceChain serviceName)
       (methods :: [Method serviceName mnm anm]) (m :: * -> *) (hs :: [*])
       (sname :: serviceName) (pname :: Maybe serviceName) (sanns :: [*]).
(ToNamedList p nl, ToHandlers chn () methods m hs nl,
 MappingRight chn sname ~ ()) =>
p
-> ServerT
     chn ('Package pname '[ 'Service sname sanns methods]) m '[hs]
singleService ( (HelloRequest -> m HelloResponse)
-> Named "SayHello" (() -> HelloRequest -> m HelloResponse)
forall k (n :: k) p. p -> Named n (() -> p)
method @"SayHello" HelloRequest -> m HelloResponse
sayHello
                  , (ConduitT () HelloRequest m ()
 -> ConduitT HelloResponse Void m () -> m ())
-> Named
     "SayManyHellos"
     (()
      -> ConduitT () HelloRequest m ()
      -> ConduitT HelloResponse Void m ()
      -> m ())
forall k (n :: k) p. p -> Named n (() -> p)
method @"SayManyHellos" ConduitT () HelloRequest m ()
-> ConduitT HelloResponse Void m () -> m ()
sayManyHellos
                  , (HiRequest -> ConduitT HelloResponse Void m () -> m ())
-> Named
     "SayHi"
     (() -> HiRequest -> ConduitT HelloResponse Void m () -> m ())
forall k (n :: k) p. p -> Named n (() -> p)
method @"SayHi" HiRequest -> ConduitT HelloResponse Void m () -> m ()
sayHi )
  where
    sayHello :: HelloRequest -> m HelloResponse
    sayHello :: HelloRequest -> m HelloResponse
sayHello (HelloRequest nm :: Text
nm)
      = HelloResponse -> m HelloResponse
forall (f :: * -> *) a. Applicative f => a -> f a
pure (HelloResponse -> m HelloResponse)
-> HelloResponse -> m HelloResponse
forall a b. (a -> b) -> a -> b
$ Text -> HelloResponse
HelloResponse (Text -> HelloResponse) -> Text -> HelloResponse
forall a b. (a -> b) -> a -> b
$ "hi, " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
nm
    sayHi :: HiRequest
          -> ConduitT HelloResponse Void m ()
          -> m ()
    sayHi :: HiRequest -> ConduitT HelloResponse Void m () -> m ()
sayHi (HiRequest n :: Int
n) sink :: ConduitT HelloResponse Void m ()
sink
      = ConduitT () Void m () -> m ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m () -> m ()) -> ConduitT () Void m () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> HelloResponse -> ConduitT () HelloResponse m ()
forall (m :: * -> *) a i. Monad m => Int -> a -> ConduitT i a m ()
C.replicate Int
n (Text -> HelloResponse
HelloResponse "hi!") ConduitT () HelloResponse m ()
-> ConduitT HelloResponse Void m () -> ConduitT () Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT HelloResponse Void m ()
sink
    sayManyHellos :: ConduitT () HelloRequest m ()
                  -> ConduitT HelloResponse Void m ()
                  -> m ()
    sayManyHellos :: ConduitT () HelloRequest m ()
-> ConduitT HelloResponse Void m () -> m ()
sayManyHellos source :: ConduitT () HelloRequest m ()
source sink :: ConduitT HelloResponse Void m ()
sink
      = ConduitT () Void m () -> m ()
forall (m :: * -> *) r. Monad m => ConduitT () Void m r -> m r
runConduit (ConduitT () Void m () -> m ()) -> ConduitT () Void m () -> m ()
forall a b. (a -> b) -> a -> b
$ ConduitT () HelloRequest m ()
source ConduitT () HelloRequest m ()
-> ConduitM HelloRequest Void m () -> ConduitT () Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| (HelloRequest -> m HelloResponse)
-> ConduitT HelloRequest HelloResponse m ()
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> ConduitT a b m ()
C.mapM HelloRequest -> m HelloResponse
sayHello ConduitT HelloRequest HelloResponse m ()
-> ConduitT HelloResponse Void m ()
-> ConduitM HelloRequest Void m ()
forall (m :: * -> *) a b c r.
Monad m =>
ConduitM a b m () -> ConduitM b c m r -> ConduitM a c m r
.| ConduitT HelloResponse Void m ()
sink

-- From https://www.apollographql.com/docs/apollo-server/schema/schema/
type ApolloService
  = 'Package ('Just "apollo")
      '[ Object "Book" '[]
        '[ ObjectField "title"  '[] '[] ('RetSingle ('PrimitiveRef String))
        , ObjectField "author" '[] '[] ('RetSingle ('ObjectRef "Author"))
        ]
      , Object "Author" '[]
        '[ ObjectField "name"  '[] '[] ('RetSingle ('PrimitiveRef String))
        , ObjectField "books" '[] '[] ('RetSingle ('ListRef ('ObjectRef "Book")))
        ]
      ]

type ApolloBookAuthor = '[
    "Book"   ':-> (String, Integer)
  , "Author" ':-> Integer
  ]

apolloServer :: forall m. (MonadServer m) => ServerT ApolloBookAuthor ApolloService m _
apolloServer :: ServerT
  ApolloBookAuthor
  ApolloService
  m
  '[ '[m String, m Integer], '[m String, m [(String, Integer)]]]
apolloServer
  = (Named
   "Author"
   (HandlersT
      ApolloBookAuthor
      Integer
      '[ObjectField "name" '[] '[] ('RetSingle ('PrimitiveRef String)),
        ObjectField
          "books" '[] '[] ('RetSingle ('ListRef ('ObjectRef "Book")))]
      m
      '[m String, m [(String, Integer)]]),
 Named
   "Book"
   (HandlersT
      ApolloBookAuthor
      (String, Integer)
      '[ObjectField "title" '[] '[] ('RetSingle ('PrimitiveRef String)),
        ObjectField "author" '[] '[] ('RetSingle ('ObjectRef "Author"))]
      m
      '[m String, m Integer]))
-> ServerT
     ApolloBookAuthor
     ApolloService
     m
     '[ '[m String, m Integer], '[m String, m [(String, Integer)]]]
forall serviceName mnm anm p (nl :: [(Symbol, *)])
       (chn :: ServiceChain serviceName)
       (ss :: [Service serviceName mnm anm]) (m :: * -> *) (hs :: [[*]])
       (pname :: Maybe serviceName).
(ToNamedList p nl, ToServices chn ss m hs nl) =>
p -> ServerT chn ('Package pname ss) m hs
resolver
      ( (Named "name" (Integer -> m String),
 Named "books" (Integer -> m [(String, Integer)]))
-> Named
     "Author"
     (HandlersT
        ApolloBookAuthor
        (MappingRight ApolloBookAuthor "Author")
        '[ObjectField "name" '[] '[] ('RetSingle ('PrimitiveRef String)),
          ObjectField
            "books" '[] '[] ('RetSingle ('ListRef ('ObjectRef "Book")))]
        m
        '[m String, m [(String, Integer)]])
forall a mnm anm (sname :: a) p (nl :: [(Symbol, *)])
       (chn :: ServiceChain a) (ms :: [Method a mnm anm]) (m :: * -> *)
       (hs :: [*]).
(ToNamedList p nl,
 ToHandlers chn (MappingRight chn sname) ms m hs nl) =>
p -> Named sname (HandlersT chn (MappingRight chn sname) ms m hs)
object @"Author" ( (Integer -> m String) -> Named "name" (Integer -> m String)
forall k (n :: k) h. h -> Named n h
field @"name"   Integer -> m String
authorName
                         , (Integer -> m [(String, Integer)])
-> Named "books" (Integer -> m [(String, Integer)])
forall k (n :: k) h. h -> Named n h
field @"books"  Integer -> m [(String, Integer)]
authorBooks )
      , (Named "author" ((String, Integer) -> m Integer),
 Named "title" ((String, Integer) -> m String))
-> Named
     "Book"
     (HandlersT
        ApolloBookAuthor
        (MappingRight ApolloBookAuthor "Book")
        '[ObjectField "title" '[] '[] ('RetSingle ('PrimitiveRef String)),
          ObjectField "author" '[] '[] ('RetSingle ('ObjectRef "Author"))]
        m
        '[m String, m Integer])
forall a mnm anm (sname :: a) p (nl :: [(Symbol, *)])
       (chn :: ServiceChain a) (ms :: [Method a mnm anm]) (m :: * -> *)
       (hs :: [*]).
(ToNamedList p nl,
 ToHandlers chn (MappingRight chn sname) ms m hs nl) =>
p -> Named sname (HandlersT chn (MappingRight chn sname) ms m hs)
object @"Book"   ( ((String, Integer) -> m Integer)
-> Named "author" ((String, Integer) -> m Integer)
forall k (n :: k) h. h -> Named n h
field @"author" (Integer -> m Integer
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Integer -> m Integer)
-> ((String, Integer) -> Integer) -> (String, Integer) -> m Integer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Integer) -> Integer
forall a b. (a, b) -> b
snd)
                         , ((String, Integer) -> m String)
-> Named "title" ((String, Integer) -> m String)
forall k (n :: k) h. h -> Named n h
field @"title"  (String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure (String -> m String)
-> ((String, Integer) -> String) -> (String, Integer) -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String, Integer) -> String
forall a b. (a, b) -> a
fst) ) )
  where
    authorName :: Integer -> m String
    authorName :: Integer -> m String
authorName _ = String -> m String
forall (f :: * -> *) a. Applicative f => a -> f a
pure "alex"  -- this would run in the DB
    authorBooks :: Integer -> m [(String, Integer)]
    authorBooks :: Integer -> m [(String, Integer)]
authorBooks _ = [(String, Integer)] -> m [(String, Integer)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []