From 620dc6464481abbd72fe0625cfb3f0cf359b9596 Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Mon, 18 Nov 2019 09:39:23 +0100 Subject: [PATCH 001/217] Parse Avro Schemas from JSON (#18) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * stylish-haskell 💅🏼 * fix minor typos * prepare avro QuasiQuoter * Implement QuasiQuoter! 🎉 * make travis happy :) * Implement unions and add examples * fix ByteString encoding + [avroFile|example] 🐛 * Handle TOption case ⌥ * Unwrap first union and contemplate other cases! 🙌🏼 * Start work on flattenDeclarations and revert stylistic changes * Handle nested schemas! 🕸 * fix travis 🤦🏼‍♂️ --- rpc/README.md | 4 +- schema/README.md | 6 +- schema/mu-schema.cabal | 66 +++++---- schema/src/Mu/Schema/AvroExample.hs | 39 +++++ schema/src/Mu/Schema/Quasi.hs | 215 ++++++++++++++++++++-------- 5 files changed, 238 insertions(+), 92 deletions(-) create mode 100644 schema/src/Mu/Schema/AvroExample.hs diff --git a/rpc/README.md b/rpc/README.md index 24b7e317..caf42cf3 100644 --- a/rpc/README.md +++ b/rpc/README.md @@ -92,7 +92,7 @@ sayHello :: HelloRequest -> IO HelloResponse sayHello (HelloRequest nm) = return (HelloResponse ("hi, " <> nm)) ``` -Since you can declare more than once method in a service, you need to join then into a `Server`. You do so by using `(:<|>:)` between each handler and ending the sequence with `H0`. In addition to the name of the service, `Server` has an additional parameter which records the types of the handlers. Since that list may become quite long, we can ask GHC to write it for us by using the `PartialTypeSignatures` extension and writing an underscore `_` in that position. One final observation is that in the code below we are using `ServerIO`, which is an instance of `Server` which allows running `IO` operations. +Since you can declare more than one method in a service, you need to join then into a `Server`. You do so by using `(:<|>:)` between each handler and ending the sequence with `H0`. In addition to the name of the service, `Server` has an additional parameter which records the types of the handlers. Since that list may become quite long, we can ask GHC to write it for us by using the `PartialTypeSignatures` extension and writing an underscore `_` in that position. One final observation is that in the code below we are using `ServerIO`, which is an instance of `Server` which allows running `IO` operations. ```haskell {-# language PartialTypeSignatures #-} @@ -143,7 +143,7 @@ quickstartServer = Server (sayHello :<|>: sayManyHellos :<|>: H0) ## Running the server with `mu-grpc` -The combination of the declaration of a service API and a corresponding implementation as a `Server` may may served directly using a concrete wire protocol. One example is gRPC, provided by our sibling library `mu-grpc`. The following line starts a server at port 8080, where the service can be found under the package name `helloworld`: +The combination of the declaration of a service API and a corresponding implementation as a `Server` may served directly using a concrete wire protocol. One example is gRPC, provided by our sibling library `mu-grpc`. The following line starts a server at port `8080`, where the service can be found under the package name `helloworld`: ```haskell main = runGRpcApp 8080 "helloworld" quickstartServer diff --git a/schema/README.md b/schema/README.md index 7313cb0e..f82899bf 100644 --- a/schema/README.md +++ b/schema/README.md @@ -2,7 +2,7 @@ Using `mu-schema` you can describe a schema for your data using type-level techniques. You can then automatically generate: -* conversion between you Haskell data types and the values as expected by the schema, +* conversion between your Haskell data types and the values as expected by the schema, * generalization to [Avro](https://avro.apache.org/), [Protocol Buffers](https://developers.google.com/protocol-buffers/), and [JSON](https://www.json.org/). Since `mu-schema` makes heavy use of type-level techniques, you need to open up the Pandora's box by enabling (at least) the following extensions: `PolyKinds` and `DataKinds`. @@ -38,7 +38,7 @@ As you can see, a *schema* is just a list of schema types. Each of these types h * An *enumeration* defines a set of values that the type can take, * A *record* contains a list of *fields*, each of them with a name and a *field type*. The allowed types for the fields are: - * `TPrimitive` for primitive types such as `Int` and `Bool`. Note that if you want to have a string yoiu should *not* use the `String` from `Prelude`, but rather `Text` from `Data.Text`. + * `TPrimitive` for primitive types such as `Int` and `Bool`. Note that if you want to have a string you should *not* use the `String` from `Prelude`, but rather `Text` from `Data.Text`. * `TSchematic` to reference another type *in the same schema* by name. * `TOption`, `TList`, `TMap`, and `TUnion` are combinators for the field types. @@ -56,7 +56,7 @@ The most common case is that your schema lives in an external file, maybe shared type ExampleSchema = [protobufFile|path/to/file.proto|] ``` -One possibility is to write them in-line. In that case you replace `protobufFile` with `protobuf` and write the schema directly between the `|` symbols. +Another possibility is to write them in-line. In that case you replace `protobufFile` with `protobuf` and write the schema directly between the `|` symbols. ```haskell {-# language QuasiQuotes #-} diff --git a/schema/mu-schema.cabal b/schema/mu-schema.cabal index 58b5c139..82afdb77 100644 --- a/schema/mu-schema.cabal +++ b/schema/mu-schema.cabal @@ -18,44 +18,60 @@ build-type: Simple extra-source-files: README.md, CHANGELOG.md library - exposed-modules: Mu.Schema, - Mu.Schema.Definition, - Mu.Schema.Interpretation, - Mu.Schema.Interpretation.Schemaless, - Mu.Schema.Interpretation.Anonymous, - Mu.Schema.Class, - Mu.Schema.Registry, - Mu.Schema.Adapter.Avro, - Mu.Schema.Adapter.ProtoBuf, - Mu.Schema.Adapter.Json, - Mu.Schema.Quasi, - Mu.Schema.Conversion.TypesToSchema, - Mu.Schema.Conversion.SchemaToTypes, - Mu.Schema.Examples + exposed-modules: Mu.Schema + , Mu.Schema.Definition + , Mu.Schema.Interpretation + , Mu.Schema.Interpretation.Schemaless + , Mu.Schema.Interpretation.Anonymous + , Mu.Schema.Class + , Mu.Schema.Registry + , Mu.Schema.Adapter.Avro + , Mu.Schema.Adapter.ProtoBuf + , Mu.Schema.Adapter.Json + , Mu.Schema.Quasi + , Mu.Schema.Conversion.TypesToSchema + , Mu.Schema.Conversion.SchemaToTypes + , Mu.Schema.Examples + , Mu.Schema.AvroExample -- other-modules: -- other-extensions: - build-depends: base >=4.12 && <5, sop-core, - containers, unordered-containers, vector, - bytestring, text, - avro, tagged, proto3-wire, aeson, - template-haskell >= 2.12, th-abstraction, - language-protobuf + build-depends: base >=4.12 && <5 + , sop-core + , containers + , unordered-containers + , vector + , bytestring + , text + , avro + , tagged + , proto3-wire + , aeson + , template-haskell >= 2.12 + , th-abstraction + , language-protobuf hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall -fprint-potential-instances + ghc-options: -Wall + -fprint-potential-instances executable test-avro main-is: Avro.hs - build-depends: base >=4.12 && <5, sop-core, - mu-schema, avro, bytestring + build-depends: base >=4.12 && <5 + , sop-core + , mu-schema + , avro + , bytestring hs-source-dirs: test default-language: Haskell2010 ghc-options: -Wall executable test-protobuf main-is: ProtoBuf.hs - build-depends: base >=4.12 && <5, sop-core, - mu-schema, proto3-wire, bytestring + build-depends: base >=4.12 && <5 + , sop-core + , mu-schema + , proto3-wire + , bytestring hs-source-dirs: test default-language: Haskell2010 ghc-options: -Wall diff --git a/schema/src/Mu/Schema/AvroExample.hs b/schema/src/Mu/Schema/AvroExample.hs new file mode 100644 index 00000000..2096fc12 --- /dev/null +++ b/schema/src/Mu/Schema/AvroExample.hs @@ -0,0 +1,39 @@ +{-# language DataKinds #-} +{-# language QuasiQuotes #-} +{-# OPTIONS_GHC -ddump-splices #-} + +module Mu.Schema.AvroExample where + +import Mu.Schema.Quasi (avro, avroFile) + +type Example = [avro| +{ + "type": "record", + "name": "person", + "fields": [ + { "name": "firstName", "type": "string" }, + { "name": "lastName", "type": "string" }, + { "name": "age", "type": ["long", "null"] }, + { "name": "gender", "type": [ + { + "type": "enum", + "name": "gender", + "symbols": [ "male", "female", "nb"] + }, + "null" + ] + }, + { "name": "address", "type": { + "type": "record", + "name": "address", + "fields": [ + { "name": "postcode", "type": "string" }, + { "name": "country", "type": "string" } + ] + } + } + ] +} +|] + +type ExampleFromFile = [avroFile|test/avro/example.avsc|] diff --git a/schema/src/Mu/Schema/Quasi.hs b/schema/src/Mu/Schema/Quasi.hs index 9172879f..fce7ad74 100644 --- a/schema/src/Mu/Schema/Quasi.hs +++ b/schema/src/Mu/Schema/Quasi.hs @@ -1,102 +1,193 @@ -{-# language TemplateHaskell, DataKinds #-} +{-# language DataKinds #-} +{-# language LambdaCase #-} +{-# language NamedFieldPuns #-} +{-# language TemplateHaskell #-} +{-# language ViewPatterns #-} + module Mu.Schema.Quasi ( + -- * Quasi-quoters for @.avsc@ files + avro + , avroFile -- * Quasi-quoters for @.proto@ files - protobuf -, protobufFile + , protobuf + , protobufFile -- * Only for internal use -, schemaFromProtoBuf -) where + , schemaFromAvroType + , schemaFromProtoBuf + ) where + +import Data.Aeson (decode) +import qualified Data.Avro.Schema as A +import qualified Data.ByteString as B +import Data.ByteString.Lazy.Char8 (pack) +import Data.Int +import qualified Data.Text as T +import Data.Vector (fromList, toList) +import Language.Haskell.TH +import Language.Haskell.TH.Quote +import Language.ProtocolBuffers.Parser +import qualified Language.ProtocolBuffers.Types as P -import qualified Data.ByteString as B -import Data.Int -import qualified Data.Text as T -import Language.Haskell.TH -import Language.Haskell.TH.Quote -import qualified Language.ProtocolBuffers.Types as P -import Language.ProtocolBuffers.Parser +import Mu.Schema.Adapter.ProtoBuf +import Mu.Schema.Definition -import Mu.Schema.Definition -import Mu.Schema.Adapter.ProtoBuf +-- | Imports an avro definition written in-line as a 'Schema'. +avro :: QuasiQuoter +avro = + QuasiQuoter + (const $ fail "cannot use as expression") + (const $ fail "cannot use as pattern") + schemaFromAvroString + (const $ fail "cannot use as declaration") -- | Imports a protocol buffer definition written -- in-line as a 'Schema'. protobuf :: QuasiQuoter -protobuf = QuasiQuoter (const $ fail "cannot use as expression") - (const $ fail "cannot use as pattern") - schemaFromProtoBufString - (const $ fail "cannot use as declaration") +protobuf = + QuasiQuoter + (const $ fail "cannot use as expression") + (const $ fail "cannot use as pattern") + schemaFromProtoBufString + (const $ fail "cannot use as declaration") + +-- | Imports an avro definition from a file as a 'Schema'. +avroFile :: QuasiQuoter +avroFile = quoteFile avro -- | Imports a protocol buffer definition from a file -- as a 'Schema'. protobufFile :: QuasiQuoter protobufFile = quoteFile protobuf +schemaFromAvroString :: String -> Q Type +schemaFromAvroString s = + case decode (pack s) of + Nothing -> fail "could not parse avro spec!" + Just (A.Union us) -> schemaFromAvro (toList us) + Just t -> schemaFromAvro [t] + where schemaFromAvro = (typesToList <$>) . mapM schemaDecFromAvroType . flattenAvroDecls + +schemaDecFromAvroType :: A.Type -> Q Type +schemaDecFromAvroType (A.Record name _ _ _ fields) = + [t|'DRecord $(textToStrLit $ A.baseName name) '[] $(typesToList <$> mapM avroFieldToType fields)|] + where + avroFieldToType :: A.Field -> Q Type + avroFieldToType field = + [t|'FieldDef $(textToStrLit $ A.fldName field) '[] $(schemaFromAvroType $ A.fldType field)|] +schemaDecFromAvroType (A.Enum name _ _ symbols) = + [t|'DEnum $(textToStrLit $ A.baseName name) '[] $(typesToList <$> mapM avChoiceToType (toList symbols))|] + where + avChoiceToType :: T.Text -> Q Type + avChoiceToType c = [t|'ChoiceDef $(textToStrLit c) '[]|] +schemaDecFromAvroType t = [t| 'DSimple $(schemaFromAvroType t) |] + +schemaFromAvroType :: A.Type -> Q Type +schemaFromAvroType = \case + A.Null -> [t|'TPrimitive 'TNull|] + A.Boolean -> [t|'TPrimitive Bool|] + A.Int -> [t|'TPrimitive Int32|] + A.Long -> [t|'TPrimitive Int64|] + A.Float -> [t|'TPrimitive Float|] + A.Double -> [t|'TPrimitive Double|] + A.Bytes -> [t|'TPrimitive B.ByteString|] + A.String -> [t|'TPrimitive T.Text|] + A.Array item -> [t|'TList $(schemaFromAvroType item)|] + A.Map values -> [t|'TMap T.Text $(schemaFromAvroType values)|] + A.NamedType typeName -> + [t|'TSchematic $(textToStrLit (A.baseName typeName))|] + A.Enum {} -> fail "should never happen, please, file an issue" + A.Record {} -> fail "should never happen, please, file an issue" + A.Union options -> + case toList options of + [A.Null, x] -> toOption x + [x, A.Null] -> toOption x + _ -> [t|'TUnion $(typesToList <$> mapM schemaFromAvroType (toList options))|] + where toOption x = [t|'TOption $(schemaFromAvroType x)|] + A.Fixed {} -> fail "fixed integers are not currently supported" + schemaFromProtoBufString :: String -> Q Type -schemaFromProtoBufString ts - = case parseProtoBuf (T.pack ts) of - Left e - -> fail ("could not parse protocol buffers spec: " ++ show e) - Right p - -> schemaFromProtoBuf p +schemaFromProtoBufString ts = + case parseProtoBuf (T.pack ts) of + Left e -> fail ("could not parse protocol buffers spec: " ++ show e) + Right p -> schemaFromProtoBuf p + +flattenAvroDecls :: [A.Type] -> [A.Type] +flattenAvroDecls = concatMap (uncurry (:) . flattenDecl) + where + flattenDecl :: A.Type -> (A.Type, [A.Type]) + flattenDecl (A.Record name a d o fields) = + let (flds, tts) = unzip (flattenAvroField <$> fields) + in (A.Record name a d o flds, concat tts) + flattenDecl (A.Union _) = error "should never happen, please, file an issue" + flattenDecl t = (t, []) + + flattenAvroType :: A.Type -> (A.Type, [A.Type]) + flattenAvroType (A.Record name a d o fields) = + let (flds, tts) = unzip (flattenAvroField <$> fields) + in (A.NamedType name, A.Record name a d o flds : concat tts) + flattenAvroType (A.Union (toList -> ts)) = + let (us, tts) = unzip (map flattenAvroType ts) + in (A.Union $ fromList us, concat tts) + flattenAvroType e@A.Enum {A.name} = (A.NamedType name, [e]) + flattenAvroType t = (t, []) + + flattenAvroField :: A.Field -> (A.Field, [A.Type]) + flattenAvroField f = + let (t, decs) = flattenAvroType (A.fldType f) + in (f {A.fldType = t}, decs) schemaFromProtoBuf :: P.ProtoBuf -> Q Type -schemaFromProtoBuf P.ProtoBuf { P.types = tys } - = let decls = flattenDecls tys - in typesToList <$> mapM pbTypeDeclToType decls +schemaFromProtoBuf P.ProtoBuf {P.types = tys} = + let decls = flattenDecls tys + in typesToList <$> mapM pbTypeDeclToType decls flattenDecls :: [P.TypeDeclaration] -> [P.TypeDeclaration] flattenDecls = concatMap flattenDecl where flattenDecl d@P.DEnum {} = [d] - flattenDecl (P.DMessage name o r fs decls) - = P.DMessage name o r fs [] : flattenDecls decls + flattenDecl (P.DMessage name o r fs decls) = + P.DMessage name o r fs [] : flattenDecls decls pbTypeDeclToType :: P.TypeDeclaration -> Q Type -pbTypeDeclToType (P.DEnum name _ fields) - = [t| 'DEnum $(textToStrLit name) '[] $(typesToList <$> mapM pbChoiceToType fields) |] +pbTypeDeclToType (P.DEnum name _ fields) = + [t|'DEnum $(textToStrLit name) '[] $(typesToList <$> mapM pbChoiceToType fields)|] where pbChoiceToType :: P.EnumField -> Q Type - pbChoiceToType (P.EnumField nm number _) - = [t| 'ChoiceDef $(textToStrLit nm) '[ ProtoBufId $(intToLit number) ] |] -pbTypeDeclToType (P.DMessage name _ _ fields _) - = [t| 'DRecord $(textToStrLit name) '[] $(typesToList <$> mapM pbMsgFieldToType fields) |] + pbChoiceToType (P.EnumField nm number _) = + [t|'ChoiceDef $(textToStrLit nm) '[ ProtoBufId $(intToLit number)]|] +pbTypeDeclToType (P.DMessage name _ _ fields _) = + [t|'DRecord $(textToStrLit name) '[] $(typesToList <$> mapM pbMsgFieldToType fields)|] where pbMsgFieldToType :: P.MessageField -> Q Type - pbMsgFieldToType (P.NormalField P.Single ty nm n _) - = [t| 'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n) ] - $(pbFieldTypeToType ty) |] - pbMsgFieldToType (P.NormalField P.Repeated ty nm n _) - = [t| 'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n) ] - ('TList $(pbFieldTypeToType ty)) |] - pbMsgFieldToType (P.MapField k v nm n _) - = [t| 'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n) ] - ('TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v)) |] - pbMsgFieldToType P.OneOfField {} - = fail "oneof fields are not currently supported" - + pbMsgFieldToType (P.NormalField P.Single ty nm n _) = + [t|'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n)] $(pbFieldTypeToType ty)|] + pbMsgFieldToType (P.NormalField P.Repeated ty nm n _) = + [t|'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n)] ('TList $(pbFieldTypeToType ty))|] + pbMsgFieldToType (P.MapField k v nm n _) = + [t|'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n)] ('TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v))|] + pbMsgFieldToType P.OneOfField {} = fail "oneof fields are not currently supported" pbFieldTypeToType :: P.FieldType -> Q Type - pbFieldTypeToType P.TInt32 = [t| 'TPrimitive Int32 |] + pbFieldTypeToType P.TInt32 = [t|'TPrimitive Int32|] pbFieldTypeToType P.TUInt32 = fail "unsigned integers are not currently supported" - pbFieldTypeToType P.TSInt32 = [t| 'TPrimitive Int32 |] - pbFieldTypeToType P.TInt64 = [t| 'TPrimitive Int64 |] + pbFieldTypeToType P.TSInt32 = [t|'TPrimitive Int32|] + pbFieldTypeToType P.TInt64 = [t|'TPrimitive Int64|] pbFieldTypeToType P.TUInt64 = fail "unsigned integers are not currently supported" - pbFieldTypeToType P.TSInt64 = [t| 'TPrimitive Int64 |] + pbFieldTypeToType P.TSInt64 = [t|'TPrimitive Int64|] pbFieldTypeToType P.TFixed32 = fail "fixed integers are not currently supported" pbFieldTypeToType P.TFixed64 = fail "fixed integers are not currently supported" pbFieldTypeToType P.TSFixed32 = fail "fixed integers are not currently supported" pbFieldTypeToType P.TSFixed64 = fail "fixed integers are not currently supported" - pbFieldTypeToType P.TDouble = [t| 'TPrimitive Double |] - pbFieldTypeToType P.TBool = [t| 'TPrimitive Bool |] - pbFieldTypeToType P.TString = [t| 'TPrimitive T.Text |] - pbFieldTypeToType P.TBytes = [t| 'TPrimitive B.ByteString |] - pbFieldTypeToType (P.TOther t) = [t| 'TSchematic $(textToStrLit (last t)) |] + pbFieldTypeToType P.TDouble = [t|'TPrimitive Double|] + pbFieldTypeToType P.TBool = [t|'TPrimitive Bool|] + pbFieldTypeToType P.TString = [t|'TPrimitive T.Text|] + pbFieldTypeToType P.TBytes = [t|'TPrimitive B.ByteString|] + pbFieldTypeToType (P.TOther t) = [t|'TSchematic $(textToStrLit (last t))|] typesToList :: [Type] -> Type -typesToList - = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT +typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT + textToStrLit :: T.Text -> Q Type -textToStrLit s - = return $ LitT $ StrTyLit $ T.unpack s +textToStrLit s = return $ LitT $ StrTyLit $ T.unpack s + intToLit :: Int -> Q Type -intToLit n - = return $ LitT $ NumTyLit $ toInteger n \ No newline at end of file +intToLit n = return $ LitT $ NumTyLit $ toInteger n From a688b081c1c06f51345d04cfc557c5dc8071da38 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 18 Nov 2019 09:52:50 +0100 Subject: [PATCH 002/217] Implement unions for Avro and JSON (#20) --- schema/src/Mu/Schema/Adapter/Json.hs | 29 +++++++++++++-- schema/src/Mu/Schema/Adapter/ProtoBuf.hs | 45 ++++++++++++++++++++++-- schema/src/Mu/Schema/Quasi.hs | 40 +++++++++++++++++---- 3 files changed, 101 insertions(+), 13 deletions(-) diff --git a/schema/src/Mu/Schema/Adapter/Json.hs b/schema/src/Mu/Schema/Adapter/Json.hs index 14973b91..5e7987a6 100644 --- a/schema/src/Mu/Schema/Adapter/Json.hs +++ b/schema/src/Mu/Schema/Adapter/Json.hs @@ -7,6 +7,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Mu.Schema.Adapter.Json where +import Control.Applicative ((<|>)) import Data.Aeson import Data.Aeson.Types import Data.Functor.Contravariant @@ -116,11 +117,22 @@ instance ToJSON (FieldValue sch t) instance (ToJSONKey (FieldValue sch k), ToJSON (FieldValue sch v)) => ToJSON (FieldValue sch ('TMap k v)) where toJSON (FMap v) = toJSON v --- TODO: missing unions!! +instance (ToJSONUnion sch us) + => ToJSON (FieldValue sch ('TUnion us)) where + toJSON (FUnion v) = unionToJSON v + +class ToJSONUnion sch us where + unionToJSON :: NS (FieldValue sch) us -> Value +instance ToJSONUnion sch '[] where + unionToJSON = error "this should never happen" +instance (ToJSON (FieldValue sch u), ToJSONUnion sch us) + => ToJSONUnion sch (u ': us) where + unionToJSON (Z v) = toJSON v + unionToJSON (S r) = unionToJSON r instance FromJSON (FieldValue sch 'TNull) where parseJSON Null = return FNull - parseJSON _ = fail "expected nul" + parseJSON _ = fail "expected null" instance FromJSON t => FromJSON (FieldValue sch ('TPrimitive t)) where parseJSON v = FPrimitive <$> parseJSON v instance FromJSONKey t => FromJSONKey (FieldValue sch ('TPrimitive t)) where @@ -138,4 +150,15 @@ instance FromJSON (FieldValue sch t) instance ( FromJSONKey (FieldValue sch k), FromJSON (FieldValue sch v) , Ord (FieldValue sch k) ) => FromJSON (FieldValue sch ('TMap k v)) where - parseJSON v = FMap <$> parseJSON v \ No newline at end of file + parseJSON v = FMap <$> parseJSON v +instance (FromJSONUnion sch us) + => FromJSON (FieldValue sch ('TUnion us)) where + parseJSON v = FUnion <$> unionFromJSON v + +class FromJSONUnion sch us where + unionFromJSON :: Value -> Parser (NS (FieldValue sch) us) +instance FromJSONUnion sch '[] where + unionFromJSON _ = fail "value does not match any of the types of the union" +instance (FromJSON (FieldValue sch u), FromJSONUnion sch us) + => FromJSONUnion sch (u ': us) where + unionFromJSON v = Z <$> parseJSON v <|> S <$> unionFromJSON v \ No newline at end of file diff --git a/schema/src/Mu/Schema/Adapter/ProtoBuf.hs b/schema/src/Mu/Schema/Adapter/ProtoBuf.hs index f1d7ddf9..a6b8b145 100644 --- a/schema/src/Mu/Schema/Adapter/ProtoBuf.hs +++ b/schema/src/Mu/Schema/Adapter/ProtoBuf.hs @@ -10,6 +10,7 @@ module Mu.Schema.Adapter.ProtoBuf ( -- * Custom annotations ProtoBufId +, ProtoBufOneOfIds -- * Conversion using schemas , IsProtoSchema , HasProtoSchema @@ -42,12 +43,19 @@ import qualified Mu.Schema.Registry as R -- ANNOTATION FOR CONVERSION data ProtoBufId (n :: Nat) +data ProtoBufOneOfIds (ns :: [Nat]) type family FindProtoBufId (f :: fn) (xs :: [Type]) :: Nat where FindProtoBufId f '[] = TypeError ('Text "protocol buffers id not available for field " ':<>: 'ShowType f) FindProtoBufId f (ProtoBufId n ': rest) = n - FindProtoBufId f (other ': rest) = FindProtoBufId f rest + FindProtoBufId f (other ': rest) = FindProtoBufId f rest + +type family FindProtoBufOneOfIds (f :: fn) (xs :: [Type]) :: [Nat] where + FindProtoBufOneOfIds f '[] + = TypeError ('Text "protocol buffers ids not available for oneof field " ':<>: 'ShowType f) + FindProtoBufOneOfIds f (ProtoBufOneOfIds n ': rest) = n + FindProtoBufOneOfIds f (other ': rest) = FindProtoBufOneOfIds f rest -- CONVERSION USING SCHEMAS @@ -128,6 +136,10 @@ class ProtoBridgeFieldValue (sch :: Schema tn fn) (t :: FieldType tn) where class ProtoBridgeOneFieldValue (sch :: Schema tn fn) (t :: FieldType tn) where protoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (FieldValue sch t) +class ProtoBridgeUnionFieldValue (ids :: [Nat]) (sch :: Schema tn fn) (ts :: [FieldType tn]) where + unionFieldValueToProto :: NS (FieldValue sch) ts -> PBEnc.MessageBuilder + protoToUnionFieldValue :: PBDec.Parser PBDec.RawMessage (NS (FieldValue sch) ts) + -- -------- -- TERMS -- -- -------- @@ -206,13 +218,20 @@ instance TypeError ('Text "protobuf requires wrapping primitives in a message") -- FIELDS -- -- --------- -instance (ProtoBridgeFieldValue sch t, KnownNat (FindProtoBufId name anns)) +instance {-# OVERLAPPABLE #-} + (ProtoBridgeFieldValue sch t, KnownNat (FindProtoBufId name anns)) => ProtoBridgeField sch ('FieldDef name anns t) where fieldToProto (Field v) = fieldValueToProto fieldId v where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId name anns)) protoToField = Field <$> protoToFieldValue `at` fieldId where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId name anns)) +instance {-# OVERLAPS #-} + (ProtoBridgeUnionFieldValue (FindProtoBufOneOfIds name anns) sch ts) + => ProtoBridgeField sch ('FieldDef name anns ('TUnion ts)) where + fieldToProto (Field (FUnion v)) = unionFieldValueToProto @_ @_ @(FindProtoBufOneOfIds name anns) v + protoToField = Field . FUnion <$> protoToUnionFieldValue @_ @_ @(FindProtoBufOneOfIds name anns) + -- ------------------ -- TYPES OF FIELDS -- -- ------------------ @@ -326,4 +345,24 @@ instance TypeError ('Text "maps are not currently supported") fieldValueToProto = error "maps are not currently supported" protoToFieldValue = error "maps are not currently supported" --- TODO: Missing unions!! \ No newline at end of file +instance TypeError ('Text "nested unions are not currently supported") + => ProtoBridgeFieldValue sch ('TUnion choices) where + fieldValueToProto = error "nested unions are not currently supported" + protoToFieldValue = error "nested unions are not currently supported" + +-- UNIONS +-- ------ + +instance ProtoBridgeUnionFieldValue ids sch '[] where + unionFieldValueToProto = error "empty list of unions" + protoToUnionFieldValue = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "unknown type in an union")) + +instance ( ProtoBridgeFieldValue sch t, KnownNat thisId + , ProtoBridgeUnionFieldValue restIds sch ts ) + => ProtoBridgeUnionFieldValue (thisId ': restIds) sch (t ': ts) where + unionFieldValueToProto (Z v) = fieldValueToProto fieldId v + where fieldId = fromInteger $ natVal (Proxy @thisId) + unionFieldValueToProto (S v) = unionFieldValueToProto @_ @_ @restIds v + protoToUnionFieldValue + = Z <$> protoToFieldValue `at` fieldId <|> S <$> protoToUnionFieldValue @_ @_ @restIds + where fieldId = fromInteger $ natVal (Proxy @thisId) \ No newline at end of file diff --git a/schema/src/Mu/Schema/Quasi.hs b/schema/src/Mu/Schema/Quasi.hs index fce7ad74..2d80ed02 100644 --- a/schema/src/Mu/Schema/Quasi.hs +++ b/schema/src/Mu/Schema/Quasi.hs @@ -159,13 +159,23 @@ pbTypeDeclToType (P.DMessage name _ _ fields _) = [t|'DRecord $(textToStrLit name) '[] $(typesToList <$> mapM pbMsgFieldToType fields)|] where pbMsgFieldToType :: P.MessageField -> Q Type - pbMsgFieldToType (P.NormalField P.Single ty nm n _) = - [t|'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n)] $(pbFieldTypeToType ty)|] - pbMsgFieldToType (P.NormalField P.Repeated ty nm n _) = - [t|'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n)] ('TList $(pbFieldTypeToType ty))|] - pbMsgFieldToType (P.MapField k v nm n _) = - [t|'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n)] ('TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v))|] - pbMsgFieldToType P.OneOfField {} = fail "oneof fields are not currently supported" + pbMsgFieldToType (P.NormalField P.Single ty nm n _) + = [t| 'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n) ] + $(pbFieldTypeToType ty) |] + pbMsgFieldToType (P.NormalField P.Repeated ty nm n _) + = [t| 'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n) ] + ('TList $(pbFieldTypeToType ty)) |] + pbMsgFieldToType (P.MapField k v nm n _) + = [t| 'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n) ] + ('TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v)) |] + pbMsgFieldToType (P.OneOfField nm vs) + | any (not . hasFieldNumber) vs + = fail "nested oneof fields are not supported" + | otherwise + = [t| 'FieldDef $(textToStrLit nm) + '[ ProtoBufOneOfIds $(typesToList <$> mapM (intToLit . getFieldNumber) vs ) ] + $(typesToList <$> mapM pbOneOfFieldToType vs ) |] + pbFieldTypeToType :: P.FieldType -> Q Type pbFieldTypeToType P.TInt32 = [t|'TPrimitive Int32|] pbFieldTypeToType P.TUInt32 = fail "unsigned integers are not currently supported" @@ -183,6 +193,22 @@ pbTypeDeclToType (P.DMessage name _ _ fields _) = pbFieldTypeToType P.TBytes = [t|'TPrimitive B.ByteString|] pbFieldTypeToType (P.TOther t) = [t|'TSchematic $(textToStrLit (last t))|] + hasFieldNumber P.NormalField {} = True + hasFieldNumber P.MapField {} = True + hasFieldNumber _ = False + + getFieldNumber (P.NormalField _ _ _ n _) = n + getFieldNumber (P.MapField _ _ _ n _) = n + getFieldNumber _ = error "this should never happen" + + pbOneOfFieldToType (P.NormalField P.Single ty _ _ _) + = pbFieldTypeToType ty + pbOneOfFieldToType (P.NormalField P.Repeated ty _ _ _) + = [t| 'TList $(pbFieldTypeToType ty) |] + pbOneOfFieldToType (P.MapField k v _ _ _) + = [t| 'TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v) |] + pbOneOfFieldToType _ = error "this should never happen" + typesToList :: [Type] -> Type typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT From 1baa38c3fc0ca8999688d1c71e1f7fd47a21280a Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 18 Nov 2019 09:54:00 +0100 Subject: [PATCH 003/217] Initial implementation of Compendium client (#17) --- compendium-client/LICENSE | 202 +++++++++++++++++++++ compendium-client/compendium-client.cabal | 28 +++ compendium-client/src/Compendium/Client.hs | 61 +++++++ rpc/mu-rpc.cabal | 4 +- rpc/src/Mu/Rpc/Quasi.hs | 32 +++- stack-nightly.yaml | 1 + stack.yaml | 1 + 7 files changed, 323 insertions(+), 6 deletions(-) create mode 100644 compendium-client/LICENSE create mode 100644 compendium-client/compendium-client.cabal create mode 100644 compendium-client/src/Compendium/Client.hs diff --git a/compendium-client/LICENSE b/compendium-client/LICENSE new file mode 100644 index 00000000..d6456956 --- /dev/null +++ b/compendium-client/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/compendium-client/compendium-client.cabal b/compendium-client/compendium-client.cabal new file mode 100644 index 00000000..3677f2c8 --- /dev/null +++ b/compendium-client/compendium-client.cabal @@ -0,0 +1,28 @@ +cabal-version: >=1.10 + +name: compendium-client +version: 0.1.0.0 +synopsis: Client for the compendium schema server +-- description: +-- bug-reports: +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano +maintainer: alejandro.serrano@47deg.com +-- copyright: +category: Network +build-type: Simple +-- extra-source-files: README.md, CHANGELOG.md + +library + exposed-modules: Compendium.Client + -- other-modules: + -- other-extensions: + build-depends: base >=4.12 && <5, + aeson, text, + http-client, + servant, servant-client, + megaparsec, language-protobuf + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances \ No newline at end of file diff --git a/compendium-client/src/Compendium/Client.hs b/compendium-client/src/Compendium/Client.hs new file mode 100644 index 00000000..d26bf4dc --- /dev/null +++ b/compendium-client/src/Compendium/Client.hs @@ -0,0 +1,61 @@ +{-# language DataKinds, TypeOperators, + DeriveGeneric, DeriveAnyClass, + ViewPatterns, TypeApplications #-} +module Compendium.Client where + +import Data.Aeson +import Data.Char +import Data.Proxy +import Data.Text +import Language.ProtocolBuffers.Types +import Language.ProtocolBuffers.Parser +import Network.HTTP.Client (Manager) +import Servant.API +import Servant.Client +import Text.Megaparsec + +import GHC.Generics + +newtype Protocol + = Protocol { raw :: Text } + deriving (Eq, Show, Generic, FromJSON) + +data IdlName + = Avro | Protobuf | Mu | OpenApi | Scala + deriving (Eq, Show, Generic) +instance ToHttpApiData IdlName where + toQueryParam (show -> x:xs) + = pack $ Data.Char.toLower x : xs + toQueryParam _ = error "this should never happen" + +type TransformationAPI + = "protocol" :> Capture "id" Text + :> "transformation" + :> QueryParam' '[ Required ] "target" IdlName + :> Get '[JSON] Protocol + +transformation :: Manager -> BaseUrl + -> Text -> IdlName -> IO (Either ClientError Protocol) +transformation m url ident idl + = runClientM (transformation' ident idl) (mkClientEnv m url) + +transformation' :: Text -> IdlName -> ClientM Protocol +transformation' + = client (Proxy @TransformationAPI) + +data ObtainProtoBufError + = OPEClient ClientError + | OPEParse (ParseErrorBundle Text Char) + deriving (Show) + +obtainProtoBuf :: Manager -> BaseUrl + -> Text -> IO (Either ObtainProtoBufError ProtoBuf) +obtainProtoBuf m url ident + = do r <- transformation m url ident Protobuf + case r of + Left e + -> return $ Left (OPEClient e) + Right (Protocol p) + -> case parseProtoBuf p of + Left e -> return $ Left (OPEParse e) + Right pb -> return $ Right pb \ No newline at end of file diff --git a/rpc/mu-rpc.cabal b/rpc/mu-rpc.cabal index b54053e3..11becb9b 100644 --- a/rpc/mu-rpc.cabal +++ b/rpc/mu-rpc.cabal @@ -26,7 +26,9 @@ library -- other-extensions: build-depends: base >=4.12 && <5, sop-core, mu-schema, conduit, text, - template-haskell, language-protobuf + template-haskell, language-protobuf, + compendium-client, + http-client, servant-client-core hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -fprint-potential-instances \ No newline at end of file diff --git a/rpc/src/Mu/Rpc/Quasi.hs b/rpc/src/Mu/Rpc/Quasi.hs index 90465d70..a5156d86 100644 --- a/rpc/src/Mu/Rpc/Quasi.hs +++ b/rpc/src/Mu/Rpc/Quasi.hs @@ -2,6 +2,7 @@ -- | Read a @.proto@ file as a 'Service' module Mu.Rpc.Quasi ( grpc +, compendium ) where import Control.Monad.IO.Class @@ -9,9 +10,12 @@ import qualified Data.Text as T import Language.Haskell.TH import qualified Language.ProtocolBuffers.Types as P import Language.ProtocolBuffers.Parser +import Network.HTTP.Client +import Servant.Client.Core.BaseUrl import Mu.Schema.Quasi import Mu.Rpc +import Compendium.Client -- | Reads a @.proto@ file and generates: -- * A 'Schema' with all the message types, using the @@ -25,11 +29,29 @@ grpc schemaName servicePrefix fp case r of Left e -> fail ("could not parse protocol buffers spec: " ++ show e) - Right p@P.ProtoBuf { P.package = pkg, P.services = srvs } - -> do let schemaName' = mkName schemaName - schemaDec <- tySynD schemaName' [] (schemaFromProtoBuf p) - serviceTy <- mapM (pbServiceDeclToDec servicePrefix pkg schemaName') srvs - return (schemaDec : serviceTy) + Right p + -> protobufToDecls schemaName servicePrefix p + +-- | Obtains a schema and service definition from Compendium, +-- and generates the declarations from 'grpc'. +compendium :: String -> (String -> String) + -> String -> String -> Q [Dec] +compendium schemaTypeName servicePrefix baseUrl identifier + = do m <- liftIO $ newManager defaultManagerSettings + u <- liftIO $ parseBaseUrl baseUrl + r <- liftIO $ obtainProtoBuf m u (T.pack identifier) + case r of + Left e + -> fail ("could not parse protocol buffers spec: " ++ show e) + Right p + -> protobufToDecls schemaTypeName servicePrefix p + +protobufToDecls :: String -> (String -> String) -> P.ProtoBuf -> Q [Dec] +protobufToDecls schemaName servicePrefix p@P.ProtoBuf { P.package = pkg, P.services = srvs } + = do let schemaName' = mkName schemaName + schemaDec <- tySynD schemaName' [] (schemaFromProtoBuf p) + serviceTy <- mapM (pbServiceDeclToDec servicePrefix pkg schemaName') srvs + return (schemaDec : serviceTy) pbServiceDeclToDec :: (String -> String) -> Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Dec pbServiceDeclToDec servicePrefix pkg schema srv@(P.Service nm _ _) diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 205b63a4..f673b7c2 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -7,6 +7,7 @@ packages: - grpc - examples/health-check - examples/route-guide +- compendium-client extra-deps: - proto3-wire-1.0.0 diff --git a/stack.yaml b/stack.yaml index b3e6c0bf..d5d88f5b 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,6 +6,7 @@ packages: - grpc - examples/health-check - examples/route-guide +- compendium-client extra-deps: - proto3-wire-1.0.0 From bff64939818f6f1fdfb8bf8868d5608e39b87b24 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 18 Nov 2019 12:23:57 +0100 Subject: [PATCH 004/217] Separate packages (#21) * Separate Avro and ProtoBuf things in their own adapter packages * Separate grpc packages in client and server Fixes #19 --- {grpc => adapter/avro}/LICENSE | 0 adapter/avro/mu-avro.cabal | 47 ++++ .../avro/src/Mu}/Adapter/Avro.hs | 2 +- .../avro/src/Mu/Adapter/Avro/Example.hs | 9 +- adapter/avro/src/Mu/Quasi/Avro.hs | 115 ++++++++++ {schema => adapter/avro}/test/Avro.hs | 12 +- {schema => adapter/avro}/test/avro/consume.py | 0 .../avro}/test/avro/example.avsc | 0 .../avro}/test/avro/generate.py | 0 {rpc => adapter/protobuf}/LICENSE | 0 adapter/protobuf/mu-protobuf.cabal | 50 +++++ .../protobuf/src/Mu}/Adapter/ProtoBuf.hs | 16 +- .../src/Mu/Adapter/ProtoBuf/Example.hs | 17 ++ .../protobuf/src/Mu/Adapter/ProtoBuf/Via.hs | 11 +- .../protobuf/src/Mu/Quasi/GRpc.hs | 4 +- .../protobuf/src/Mu/Quasi/ProtoBuf.hs | 98 +-------- {schema => adapter/protobuf}/test/ProtoBuf.hs | 11 +- .../protobuf}/test/protobuf/consume.py | 0 .../protobuf}/test/protobuf/example.proto | 0 .../protobuf}/test/protobuf/example_pb2.py | 0 .../protobuf}/test/protobuf/generate.py | 0 {grpc => core/rpc}/CHANGELOG.md | 0 {schema => core/rpc}/LICENSE | 0 {rpc => core/rpc}/README.md | 0 {grpc => core/rpc}/Setup.hs | 0 {rpc => core/rpc}/mu-rpc.cabal | 5 +- {rpc => core/rpc}/src/Mu/Rpc.hs | 0 {rpc => core/rpc}/src/Mu/Rpc/Examples.hs | 1 - {rpc => core/rpc}/src/Mu/Server.hs | 0 {rpc => core/schema}/CHANGELOG.md | 0 core/schema/LICENSE | 202 ++++++++++++++++++ {schema => core/schema}/README.md | 0 {rpc => core/schema}/Setup.hs | 0 {schema => core/schema}/mu-schema.cabal | 37 +--- .../schema/src/Mu}/Adapter/Json.hs | 2 +- {schema => core/schema}/src/Mu/Schema.hs | 10 +- core/schema/src/Mu/Schema/Annotations.hs | 9 + .../schema}/src/Mu/Schema/Class.hs | 0 .../src/Mu/Schema/Conversion/SchemaToTypes.hs | 0 .../src/Mu/Schema/Conversion/TypesToSchema.hs | 0 .../schema}/src/Mu/Schema/Definition.hs | 0 .../schema}/src/Mu/Schema/Examples.hs | 40 +--- .../schema}/src/Mu/Schema/Interpretation.hs | 0 .../src/Mu/Schema/Interpretation/Anonymous.hs | 0 .../Mu/Schema/Interpretation/Schemaless.hs | 0 .../schema}/src/Mu/Schema/Registry.hs | 0 .../mu-example-health-check.cabal | 13 +- examples/health-check/src/ClientRecord.hs | 2 +- examples/health-check/src/ClientTyApps.hs | 2 +- examples/health-check/src/Definition.hs | 2 +- examples/health-check/src/Server.hs | 2 +- .../route-guide/mu-example-route-guide.cabal | 5 +- examples/route-guide/src/Definition.hs | 4 +- examples/route-guide/src/Server.hs | 2 +- {schema => grpc/client}/CHANGELOG.md | 0 grpc/client/LICENSE | 202 ++++++++++++++++++ {schema => grpc/client}/Setup.hs | 0 grpc/client/mu-grpc-client.cabal | 35 +++ .../src/Mu/GRpc/Client}/Examples.hs | 4 +- .../src/Mu/GRpc/Client}/Internal.hs | 5 +- .../src/Mu/GRpc/Client}/Record.hs | 4 +- .../src/Mu/GRpc/Client}/TyApps.hs | 4 +- grpc/mu-grpc.cabal | 55 ----- grpc/server/CHANGELOG.md | 5 + grpc/server/LICENSE | 202 ++++++++++++++++++ grpc/server/Setup.hs | 2 + grpc/server/mu-grpc-server.cabal | 44 ++++ grpc/{ => server}/src/ExampleServer.hs | 2 +- .../GRpc.hs => server/src/Mu/GRpc/Server.hs} | 5 +- grpc/test/helloworld.proto | 46 ---- stack-nightly.yaml | 11 +- stack.yaml | 11 +- test-schema.sh | 10 +- 73 files changed, 1029 insertions(+), 348 deletions(-) rename {grpc => adapter/avro}/LICENSE (100%) create mode 100644 adapter/avro/mu-avro.cabal rename {schema/src/Mu/Schema => adapter/avro/src/Mu}/Adapter/Avro.hs (99%) rename schema/src/Mu/Schema/AvroExample.hs => adapter/avro/src/Mu/Adapter/Avro/Example.hs (79%) create mode 100644 adapter/avro/src/Mu/Quasi/Avro.hs rename {schema => adapter/avro}/test/Avro.hs (68%) rename {schema => adapter/avro}/test/avro/consume.py (100%) rename {schema => adapter/avro}/test/avro/example.avsc (100%) rename {schema => adapter/avro}/test/avro/generate.py (100%) rename {rpc => adapter/protobuf}/LICENSE (100%) create mode 100644 adapter/protobuf/mu-protobuf.cabal rename {schema/src/Mu/Schema => adapter/protobuf/src/Mu}/Adapter/ProtoBuf.hs (97%) create mode 100644 adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs rename grpc/src/Mu/GRpc/Shared.hs => adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs (84%) rename rpc/src/Mu/Rpc/Quasi.hs => adapter/protobuf/src/Mu/Quasi/GRpc.hs (98%) rename schema/src/Mu/Schema/Quasi.hs => adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs (57%) rename {schema => adapter/protobuf}/test/ProtoBuf.hs (73%) rename {schema => adapter/protobuf}/test/protobuf/consume.py (100%) rename {schema => adapter/protobuf}/test/protobuf/example.proto (100%) rename {schema => adapter/protobuf}/test/protobuf/example_pb2.py (100%) rename {schema => adapter/protobuf}/test/protobuf/generate.py (100%) rename {grpc => core/rpc}/CHANGELOG.md (100%) rename {schema => core/rpc}/LICENSE (100%) rename {rpc => core/rpc}/README.md (100%) rename {grpc => core/rpc}/Setup.hs (100%) rename {rpc => core/rpc}/mu-rpc.cabal (83%) rename {rpc => core/rpc}/src/Mu/Rpc.hs (100%) rename {rpc => core/rpc}/src/Mu/Rpc/Examples.hs (98%) rename {rpc => core/rpc}/src/Mu/Server.hs (100%) rename {rpc => core/schema}/CHANGELOG.md (100%) create mode 100644 core/schema/LICENSE rename {schema => core/schema}/README.md (100%) rename {rpc => core/schema}/Setup.hs (100%) rename {schema => core/schema}/mu-schema.cabal (60%) rename {schema/src/Mu/Schema => core/schema/src/Mu}/Adapter/Json.hs (99%) rename {schema => core/schema}/src/Mu/Schema.hs (82%) create mode 100644 core/schema/src/Mu/Schema/Annotations.hs rename {schema => core/schema}/src/Mu/Schema/Class.hs (100%) rename {schema => core/schema}/src/Mu/Schema/Conversion/SchemaToTypes.hs (100%) rename {schema => core/schema}/src/Mu/Schema/Conversion/TypesToSchema.hs (100%) rename {schema => core/schema}/src/Mu/Schema/Definition.hs (100%) rename {schema => core/schema}/src/Mu/Schema/Examples.hs (76%) rename {schema => core/schema}/src/Mu/Schema/Interpretation.hs (100%) rename {schema => core/schema}/src/Mu/Schema/Interpretation/Anonymous.hs (100%) rename {schema => core/schema}/src/Mu/Schema/Interpretation/Schemaless.hs (100%) rename {schema => core/schema}/src/Mu/Schema/Registry.hs (100%) rename {schema => grpc/client}/CHANGELOG.md (100%) create mode 100644 grpc/client/LICENSE rename {schema => grpc/client}/Setup.hs (100%) create mode 100644 grpc/client/mu-grpc-client.cabal rename grpc/{src/Mu/Client/GRpc => client/src/Mu/GRpc/Client}/Examples.hs (93%) rename grpc/{src/Mu/Client/GRpc => client/src/Mu/GRpc/Client}/Internal.hs (99%) rename grpc/{src/Mu/Client/GRpc => client/src/Mu/GRpc/Client}/Record.hs (99%) rename grpc/{src/Mu/Client/GRpc => client/src/Mu/GRpc/Client}/TyApps.hs (95%) delete mode 100644 grpc/mu-grpc.cabal create mode 100644 grpc/server/CHANGELOG.md create mode 100644 grpc/server/LICENSE create mode 100644 grpc/server/Setup.hs create mode 100644 grpc/server/mu-grpc-server.cabal rename grpc/{ => server}/src/ExampleServer.hs (89%) rename grpc/{src/Mu/Server/GRpc.hs => server/src/Mu/GRpc/Server.hs} (99%) delete mode 100644 grpc/test/helloworld.proto diff --git a/grpc/LICENSE b/adapter/avro/LICENSE similarity index 100% rename from grpc/LICENSE rename to adapter/avro/LICENSE diff --git a/adapter/avro/mu-avro.cabal b/adapter/avro/mu-avro.cabal new file mode 100644 index 00000000..e7481315 --- /dev/null +++ b/adapter/avro/mu-avro.cabal @@ -0,0 +1,47 @@ +cabal-version: >=1.10 +name: mu-avro +version: 0.1.0.0 +synopsis: Avro serialization support for Mu microservices +-- description: +-- bug-reports: +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +-- copyright: +category: Network +build-type: Simple + +library + exposed-modules: Mu.Adapter.Avro + , Mu.Adapter.Avro.Example + , Mu.Quasi.Avro + -- other-modules: + -- other-extensions: + build-depends: base >=4.12 && <5 + , mu-schema + , avro + , tagged + , aeson + , text + , vector + , containers + , unordered-containers + , sop-core + , bytestring + , template-haskell >= 2.12 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + -fprint-potential-instances + +executable test-avro + main-is: Avro.hs + build-depends: base >=4.12 && <5 + , mu-schema + , mu-avro + , avro + , bytestring + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall diff --git a/schema/src/Mu/Schema/Adapter/Avro.hs b/adapter/avro/src/Mu/Adapter/Avro.hs similarity index 99% rename from schema/src/Mu/Schema/Adapter/Avro.hs rename to adapter/avro/src/Mu/Adapter/Avro.hs index 7ea960ce..9b9f0033 100644 --- a/schema/src/Mu/Schema/Adapter/Avro.hs +++ b/adapter/avro/src/Mu/Adapter/Avro.hs @@ -5,7 +5,7 @@ MultiParamTypeClasses, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Mu.Schema.Adapter.Avro where +module Mu.Adapter.Avro where import Control.Arrow ((***)) import qualified Data.Avro as A diff --git a/schema/src/Mu/Schema/AvroExample.hs b/adapter/avro/src/Mu/Adapter/Avro/Example.hs similarity index 79% rename from schema/src/Mu/Schema/AvroExample.hs rename to adapter/avro/src/Mu/Adapter/Avro/Example.hs index 2096fc12..bf016a55 100644 --- a/schema/src/Mu/Schema/AvroExample.hs +++ b/adapter/avro/src/Mu/Adapter/Avro/Example.hs @@ -1,10 +1,9 @@ -{-# language DataKinds #-} -{-# language QuasiQuotes #-} -{-# OPTIONS_GHC -ddump-splices #-} +{-# language DataKinds #-} +{-# language QuasiQuotes #-} -module Mu.Schema.AvroExample where +module Mu.Adapter.Avro.Example where -import Mu.Schema.Quasi (avro, avroFile) +import Mu.Quasi.Avro (avro, avroFile) type Example = [avro| { diff --git a/adapter/avro/src/Mu/Quasi/Avro.hs b/adapter/avro/src/Mu/Quasi/Avro.hs new file mode 100644 index 00000000..b825bd9f --- /dev/null +++ b/adapter/avro/src/Mu/Quasi/Avro.hs @@ -0,0 +1,115 @@ +{-# language DataKinds #-} +{-# language LambdaCase #-} +{-# language NamedFieldPuns #-} +{-# language TemplateHaskell #-} +{-# language ViewPatterns #-} + +module Mu.Quasi.Avro ( + -- * Quasi-quoters for @.avsc@ files + avro + , avroFile + -- * Only for internal use + , schemaFromAvroType + ) where + +import Data.Aeson (decode) +import qualified Data.Avro.Schema as A +import qualified Data.ByteString as B +import Data.ByteString.Lazy.Char8 (pack) +import Data.Int +import qualified Data.Text as T +import Data.Vector (fromList, toList) +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +import Mu.Schema.Definition + +-- | Imports an avro definition written in-line as a 'Schema'. +avro :: QuasiQuoter +avro = + QuasiQuoter + (const $ fail "cannot use as expression") + (const $ fail "cannot use as pattern") + schemaFromAvroString + (const $ fail "cannot use as declaration") + +-- | Imports an avro definition from a file as a 'Schema'. +avroFile :: QuasiQuoter +avroFile = quoteFile avro + +schemaFromAvroString :: String -> Q Type +schemaFromAvroString s = + case decode (pack s) of + Nothing -> fail "could not parse avro spec!" + Just (A.Union us) -> schemaFromAvro (toList us) + Just t -> schemaFromAvro [t] + where schemaFromAvro = (typesToList <$>) . mapM schemaDecFromAvroType . flattenAvroDecls + +schemaDecFromAvroType :: A.Type -> Q Type +schemaDecFromAvroType (A.Record name _ _ _ fields) = + [t|'DRecord $(textToStrLit $ A.baseName name) '[] $(typesToList <$> mapM avroFieldToType fields)|] + where + avroFieldToType :: A.Field -> Q Type + avroFieldToType field = + [t|'FieldDef $(textToStrLit $ A.fldName field) '[] $(schemaFromAvroType $ A.fldType field)|] +schemaDecFromAvroType (A.Enum name _ _ symbols) = + [t|'DEnum $(textToStrLit $ A.baseName name) '[] $(typesToList <$> mapM avChoiceToType (toList symbols))|] + where + avChoiceToType :: T.Text -> Q Type + avChoiceToType c = [t|'ChoiceDef $(textToStrLit c) '[]|] +schemaDecFromAvroType t = [t| 'DSimple $(schemaFromAvroType t) |] + +schemaFromAvroType :: A.Type -> Q Type +schemaFromAvroType = \case + A.Null -> [t|'TPrimitive 'TNull|] + A.Boolean -> [t|'TPrimitive Bool|] + A.Int -> [t|'TPrimitive Int32|] + A.Long -> [t|'TPrimitive Int64|] + A.Float -> [t|'TPrimitive Float|] + A.Double -> [t|'TPrimitive Double|] + A.Bytes -> [t|'TPrimitive B.ByteString|] + A.String -> [t|'TPrimitive T.Text|] + A.Array item -> [t|'TList $(schemaFromAvroType item)|] + A.Map values -> [t|'TMap T.Text $(schemaFromAvroType values)|] + A.NamedType typeName -> + [t|'TSchematic $(textToStrLit (A.baseName typeName))|] + A.Enum {} -> fail "should never happen, please, file an issue" + A.Record {} -> fail "should never happen, please, file an issue" + A.Union options -> + case toList options of + [A.Null, x] -> toOption x + [x, A.Null] -> toOption x + _ -> [t|'TUnion $(typesToList <$> mapM schemaFromAvroType (toList options))|] + where toOption x = [t|'TOption $(schemaFromAvroType x)|] + A.Fixed {} -> fail "fixed integers are not currently supported" + +flattenAvroDecls :: [A.Type] -> [A.Type] +flattenAvroDecls = concatMap (uncurry (:) . flattenDecl) + where + flattenDecl :: A.Type -> (A.Type, [A.Type]) + flattenDecl (A.Record name a d o fields) = + let (flds, tts) = unzip (flattenAvroField <$> fields) + in (A.Record name a d o flds, concat tts) + flattenDecl (A.Union _) = error "should never happen, please, file an issue" + flattenDecl t = (t, []) + + flattenAvroType :: A.Type -> (A.Type, [A.Type]) + flattenAvroType (A.Record name a d o fields) = + let (flds, tts) = unzip (flattenAvroField <$> fields) + in (A.NamedType name, A.Record name a d o flds : concat tts) + flattenAvroType (A.Union (toList -> ts)) = + let (us, tts) = unzip (map flattenAvroType ts) + in (A.Union $ fromList us, concat tts) + flattenAvroType e@A.Enum {A.name} = (A.NamedType name, [e]) + flattenAvroType t = (t, []) + + flattenAvroField :: A.Field -> (A.Field, [A.Type]) + flattenAvroField f = + let (t, decs) = flattenAvroType (A.fldType f) + in (f {A.fldType = t}, decs) + +typesToList :: [Type] -> Type +typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT + +textToStrLit :: T.Text -> Q Type +textToStrLit s = return $ LitT $ StrTyLit $ T.unpack s diff --git a/schema/test/Avro.hs b/adapter/avro/test/Avro.hs similarity index 68% rename from schema/test/Avro.hs rename to adapter/avro/test/Avro.hs index 8bdd047f..c5ee683b 100644 --- a/schema/test/Avro.hs +++ b/adapter/avro/test/Avro.hs @@ -1,13 +1,15 @@ {-# language OverloadedStrings, TypeApplications, - NamedFieldPuns #-} + NamedFieldPuns, DataKinds, + StandaloneDeriving, DerivingVia #-} +{-# options_ghc -fno-warn-orphans #-} module Main where import Data.Avro import qualified Data.ByteString.Lazy as BS import System.Environment -import Mu.Schema () -import Mu.Schema.Adapter.Avro () +import Mu.Schema (WithSchema(..)) +import Mu.Adapter.Avro () import Mu.Schema.Examples exampleAddress :: Address @@ -17,6 +19,10 @@ examplePerson1, examplePerson2 :: Person examplePerson1 = Person "Haskellio" "Gómez" (Just 30) (Just Male) exampleAddress examplePerson2 = Person "Cuarenta" "Siete" Nothing Nothing exampleAddress +deriving via (WithSchema ExampleSchema "person" Person) instance HasAvroSchema Person +deriving via (WithSchema ExampleSchema "person" Person) instance FromAvro Person +deriving via (WithSchema ExampleSchema "person" Person) instance ToAvro Person + main :: IO () main = do -- Obtain the filenames [genFile, conFile] <- getArgs diff --git a/schema/test/avro/consume.py b/adapter/avro/test/avro/consume.py similarity index 100% rename from schema/test/avro/consume.py rename to adapter/avro/test/avro/consume.py diff --git a/schema/test/avro/example.avsc b/adapter/avro/test/avro/example.avsc similarity index 100% rename from schema/test/avro/example.avsc rename to adapter/avro/test/avro/example.avsc diff --git a/schema/test/avro/generate.py b/adapter/avro/test/avro/generate.py similarity index 100% rename from schema/test/avro/generate.py rename to adapter/avro/test/avro/generate.py diff --git a/rpc/LICENSE b/adapter/protobuf/LICENSE similarity index 100% rename from rpc/LICENSE rename to adapter/protobuf/LICENSE diff --git a/adapter/protobuf/mu-protobuf.cabal b/adapter/protobuf/mu-protobuf.cabal new file mode 100644 index 00000000..5f1d82bf --- /dev/null +++ b/adapter/protobuf/mu-protobuf.cabal @@ -0,0 +1,50 @@ +cabal-version: >=1.10 +name: mu-protobuf +version: 0.1.0.0 +synopsis: Protocol Buffers serialization and gRPC schema import for Mu microservices +-- description: +-- bug-reports: +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano +maintainer: alejandro.serrano@47deg.com +-- copyright: +category: Network +build-type: Simple + +library + exposed-modules: Mu.Adapter.ProtoBuf + , Mu.Adapter.ProtoBuf.Via + , Mu.Adapter.ProtoBuf.Example + , Mu.Quasi.ProtoBuf + , Mu.Quasi.GRpc + -- other-modules: + -- other-extensions: + build-depends: base >=4.12 && <5 + , mu-schema + , mu-rpc + , text + , sop-core + , proto3-wire + , bytestring + , template-haskell >= 2.12 + , language-protobuf + , compendium-client + , http-client + , servant-client-core + , http2-grpc-proto3-wire + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + -fprint-potential-instances + +executable test-protobuf + main-is: ProtoBuf.hs + build-depends: base >=4.12 && <5 + , mu-schema + , mu-protobuf + , bytestring + , proto3-wire + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall -fprint-explicit-foralls diff --git a/schema/src/Mu/Schema/Adapter/ProtoBuf.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs similarity index 97% rename from schema/src/Mu/Schema/Adapter/ProtoBuf.hs rename to adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs index a6b8b145..d611ac6b 100644 --- a/schema/src/Mu/Schema/Adapter/ProtoBuf.hs +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs @@ -7,7 +7,7 @@ OverloadedStrings, ConstraintKinds, AllowAmbiguousTypes #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Mu.Schema.Adapter.ProtoBuf ( +module Mu.Adapter.ProtoBuf ( -- * Custom annotations ProtoBufId , ProtoBufOneOfIds @@ -35,16 +35,12 @@ import Proto3.Wire import qualified Proto3.Wire.Encode as PBEnc import qualified Proto3.Wire.Decode as PBDec +import Mu.Schema.Annotations import Mu.Schema.Definition import Mu.Schema.Interpretation import Mu.Schema.Class import qualified Mu.Schema.Registry as R --- ANNOTATION FOR CONVERSION - -data ProtoBufId (n :: Nat) -data ProtoBufOneOfIds (ns :: [Nat]) - type family FindProtoBufId (f :: fn) (xs :: [Type]) :: Nat where FindProtoBufId f '[] = TypeError ('Text "protocol buffers id not available for field " ':<>: 'ShowType f) @@ -64,12 +60,12 @@ instance ProtoBridgeTerm sch (sch :/: sty) => IsProtoSchema sch sty type HasProtoSchema sch sty a = (HasSchema sch sty a, IsProtoSchema sch sty) -toProtoViaSchema :: forall sch a sty. +toProtoViaSchema :: forall t f (sch :: Schema t f) a sty. (HasProtoSchema sch sty a) => a -> PBEnc.MessageBuilder toProtoViaSchema = termToProto . toSchema' @sch -fromProtoViaSchema :: forall sch a sty. +fromProtoViaSchema :: forall t f (sch :: Schema t f) a sty. (HasProtoSchema sch sty a) => PBDec.Parser PBDec.RawMessage a fromProtoViaSchema = fromSchema' @sch <$> protoToTerm @@ -77,7 +73,7 @@ fromProtoViaSchema = fromSchema' @sch <$> protoToTerm parseProtoViaSchema :: forall sch a sty. (HasProtoSchema sch sty a) => BS.ByteString -> Either PBDec.ParseError a -parseProtoViaSchema = PBDec.parse (fromProtoViaSchema @sch) +parseProtoViaSchema = PBDec.parse (fromProtoViaSchema @_ @_ @sch) -- CONVERSION USING REGISTRY @@ -100,7 +96,7 @@ instance FromProtoBufRegistry '[] t where fromProtoBufRegistry' _ = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "no schema found in registry")) instance (HasProtoSchema s sty t, FromProtoBufRegistry ms t) => FromProtoBufRegistry ( (n ':-> s) ': ms) t where - fromProtoBufRegistry' _ = fromProtoViaSchema @s <|> fromProtoBufRegistry' (Proxy @ms) + fromProtoBufRegistry' _ = fromProtoViaSchema @_ @_ @s <|> fromProtoBufRegistry' (Proxy @ms) -- ======================================= diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs new file mode 100644 index 00000000..5ce70b0e --- /dev/null +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs @@ -0,0 +1,17 @@ +{-# language QuasiQuotes, DataKinds #-} +module Mu.Adapter.ProtoBuf.Example where + +import Mu.Quasi.ProtoBuf + +type ExampleProtoBufSchema = [protobuf| +enum gender { + male = 1; + female = 2; + nonbinary = 3; +} +message person { + repeated string names = 1; + int age = 2; + gender gender = 3; +} +|] \ No newline at end of file diff --git a/grpc/src/Mu/GRpc/Shared.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs similarity index 84% rename from grpc/src/Mu/GRpc/Shared.hs rename to adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs index 72063d54..9b1581ac 100644 --- a/grpc/src/Mu/GRpc/Shared.hs +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs @@ -4,7 +4,7 @@ FlexibleInstances, FlexibleContexts, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints -fno-warn-orphans #-} -module Mu.GRpc.Shared where +module Mu.Adapter.ProtoBuf.Via where import Network.GRPC.HTTP2.Proto3Wire import qualified Proto3.Wire.Encode as PBEnc @@ -12,8 +12,7 @@ import qualified Proto3.Wire.Decode as PBDec import Mu.Rpc import Mu.Schema - -import Mu.Schema.Adapter.ProtoBuf +import Mu.Adapter.ProtoBuf newtype ViaProtoBufTypeRef (ref :: TypeRef) t = ViaProtoBufTypeRef { unViaProtoBufTypeRef :: t } @@ -33,11 +32,11 @@ class ProtoBufTypeRef (ref :: TypeRef) t where instance (HasProtoSchema sch sty t) => ProtoBufTypeRef ('FromSchema sch sty) t where - fromProtoBufTypeRef _ = fromProtoViaSchema @sch - toProtoBufTypeRef _ = toProtoViaSchema @sch + fromProtoBufTypeRef _ = fromProtoViaSchema @_ @_ @sch + toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @sch instance ( FromProtoBufRegistry r t , HasProtoSchema (MappingRight r last) sty t) => ProtoBufTypeRef ('FromRegistry r t last) t where fromProtoBufTypeRef _ = fromProtoBufWithRegistry @r - toProtoBufTypeRef _ = toProtoViaSchema @(MappingRight r last) \ No newline at end of file + toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @(MappingRight r last) \ No newline at end of file diff --git a/rpc/src/Mu/Rpc/Quasi.hs b/adapter/protobuf/src/Mu/Quasi/GRpc.hs similarity index 98% rename from rpc/src/Mu/Rpc/Quasi.hs rename to adapter/protobuf/src/Mu/Quasi/GRpc.hs index a5156d86..a4b42928 100644 --- a/rpc/src/Mu/Rpc/Quasi.hs +++ b/adapter/protobuf/src/Mu/Quasi/GRpc.hs @@ -1,6 +1,6 @@ {-# language TemplateHaskell, DataKinds, OverloadedStrings #-} -- | Read a @.proto@ file as a 'Service' -module Mu.Rpc.Quasi ( +module Mu.Quasi.GRpc ( grpc , compendium ) where @@ -13,7 +13,7 @@ import Language.ProtocolBuffers.Parser import Network.HTTP.Client import Servant.Client.Core.BaseUrl -import Mu.Schema.Quasi +import Mu.Quasi.ProtoBuf import Mu.Rpc import Compendium.Client diff --git a/schema/src/Mu/Schema/Quasi.hs b/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs similarity index 57% rename from schema/src/Mu/Schema/Quasi.hs rename to adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs index 2d80ed02..ae35f49f 100644 --- a/schema/src/Mu/Schema/Quasi.hs +++ b/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs @@ -4,42 +4,25 @@ {-# language TemplateHaskell #-} {-# language ViewPatterns #-} -module Mu.Schema.Quasi ( - -- * Quasi-quoters for @.avsc@ files - avro - , avroFile +module Mu.Quasi.ProtoBuf ( -- * Quasi-quoters for @.proto@ files - , protobuf + protobuf , protobufFile -- * Only for internal use - , schemaFromAvroType , schemaFromProtoBuf ) where -import Data.Aeson (decode) -import qualified Data.Avro.Schema as A import qualified Data.ByteString as B -import Data.ByteString.Lazy.Char8 (pack) import Data.Int import qualified Data.Text as T -import Data.Vector (fromList, toList) import Language.Haskell.TH import Language.Haskell.TH.Quote import Language.ProtocolBuffers.Parser import qualified Language.ProtocolBuffers.Types as P -import Mu.Schema.Adapter.ProtoBuf +import Mu.Adapter.ProtoBuf import Mu.Schema.Definition --- | Imports an avro definition written in-line as a 'Schema'. -avro :: QuasiQuoter -avro = - QuasiQuoter - (const $ fail "cannot use as expression") - (const $ fail "cannot use as pattern") - schemaFromAvroString - (const $ fail "cannot use as declaration") - -- | Imports a protocol buffer definition written -- in-line as a 'Schema'. protobuf :: QuasiQuoter @@ -50,92 +33,17 @@ protobuf = schemaFromProtoBufString (const $ fail "cannot use as declaration") --- | Imports an avro definition from a file as a 'Schema'. -avroFile :: QuasiQuoter -avroFile = quoteFile avro - -- | Imports a protocol buffer definition from a file -- as a 'Schema'. protobufFile :: QuasiQuoter protobufFile = quoteFile protobuf -schemaFromAvroString :: String -> Q Type -schemaFromAvroString s = - case decode (pack s) of - Nothing -> fail "could not parse avro spec!" - Just (A.Union us) -> schemaFromAvro (toList us) - Just t -> schemaFromAvro [t] - where schemaFromAvro = (typesToList <$>) . mapM schemaDecFromAvroType . flattenAvroDecls - -schemaDecFromAvroType :: A.Type -> Q Type -schemaDecFromAvroType (A.Record name _ _ _ fields) = - [t|'DRecord $(textToStrLit $ A.baseName name) '[] $(typesToList <$> mapM avroFieldToType fields)|] - where - avroFieldToType :: A.Field -> Q Type - avroFieldToType field = - [t|'FieldDef $(textToStrLit $ A.fldName field) '[] $(schemaFromAvroType $ A.fldType field)|] -schemaDecFromAvroType (A.Enum name _ _ symbols) = - [t|'DEnum $(textToStrLit $ A.baseName name) '[] $(typesToList <$> mapM avChoiceToType (toList symbols))|] - where - avChoiceToType :: T.Text -> Q Type - avChoiceToType c = [t|'ChoiceDef $(textToStrLit c) '[]|] -schemaDecFromAvroType t = [t| 'DSimple $(schemaFromAvroType t) |] - -schemaFromAvroType :: A.Type -> Q Type -schemaFromAvroType = \case - A.Null -> [t|'TPrimitive 'TNull|] - A.Boolean -> [t|'TPrimitive Bool|] - A.Int -> [t|'TPrimitive Int32|] - A.Long -> [t|'TPrimitive Int64|] - A.Float -> [t|'TPrimitive Float|] - A.Double -> [t|'TPrimitive Double|] - A.Bytes -> [t|'TPrimitive B.ByteString|] - A.String -> [t|'TPrimitive T.Text|] - A.Array item -> [t|'TList $(schemaFromAvroType item)|] - A.Map values -> [t|'TMap T.Text $(schemaFromAvroType values)|] - A.NamedType typeName -> - [t|'TSchematic $(textToStrLit (A.baseName typeName))|] - A.Enum {} -> fail "should never happen, please, file an issue" - A.Record {} -> fail "should never happen, please, file an issue" - A.Union options -> - case toList options of - [A.Null, x] -> toOption x - [x, A.Null] -> toOption x - _ -> [t|'TUnion $(typesToList <$> mapM schemaFromAvroType (toList options))|] - where toOption x = [t|'TOption $(schemaFromAvroType x)|] - A.Fixed {} -> fail "fixed integers are not currently supported" - schemaFromProtoBufString :: String -> Q Type schemaFromProtoBufString ts = case parseProtoBuf (T.pack ts) of Left e -> fail ("could not parse protocol buffers spec: " ++ show e) Right p -> schemaFromProtoBuf p -flattenAvroDecls :: [A.Type] -> [A.Type] -flattenAvroDecls = concatMap (uncurry (:) . flattenDecl) - where - flattenDecl :: A.Type -> (A.Type, [A.Type]) - flattenDecl (A.Record name a d o fields) = - let (flds, tts) = unzip (flattenAvroField <$> fields) - in (A.Record name a d o flds, concat tts) - flattenDecl (A.Union _) = error "should never happen, please, file an issue" - flattenDecl t = (t, []) - - flattenAvroType :: A.Type -> (A.Type, [A.Type]) - flattenAvroType (A.Record name a d o fields) = - let (flds, tts) = unzip (flattenAvroField <$> fields) - in (A.NamedType name, A.Record name a d o flds : concat tts) - flattenAvroType (A.Union (toList -> ts)) = - let (us, tts) = unzip (map flattenAvroType ts) - in (A.Union $ fromList us, concat tts) - flattenAvroType e@A.Enum {A.name} = (A.NamedType name, [e]) - flattenAvroType t = (t, []) - - flattenAvroField :: A.Field -> (A.Field, [A.Type]) - flattenAvroField f = - let (t, decs) = flattenAvroType (A.fldType f) - in (f {A.fldType = t}, decs) - schemaFromProtoBuf :: P.ProtoBuf -> Q Type schemaFromProtoBuf P.ProtoBuf {P.types = tys} = let decls = flattenDecls tys diff --git a/schema/test/ProtoBuf.hs b/adapter/protobuf/test/ProtoBuf.hs similarity index 73% rename from schema/test/ProtoBuf.hs rename to adapter/protobuf/test/ProtoBuf.hs index 8e1b7158..254ae6dc 100644 --- a/schema/test/ProtoBuf.hs +++ b/adapter/protobuf/test/ProtoBuf.hs @@ -1,5 +1,4 @@ -{-# language OverloadedStrings, TypeApplications, - NamedFieldPuns #-} +{-# language OverloadedStrings, TypeApplications, ScopedTypeVariables #-} module Main where import qualified Data.ByteString as BS @@ -9,7 +8,7 @@ import qualified Proto3.Wire.Encode as PBEnc import System.Environment import Mu.Schema () -import Mu.Schema.Adapter.ProtoBuf () +import Mu.Adapter.ProtoBuf import Mu.Schema.Examples exampleAddress :: Address @@ -25,10 +24,10 @@ main = do -- Obtain the filenames -- Read the file produced by Python putStrLn "haskell/consume" cbs <- BS.readFile conFile - let Right people = PBDec.parse protoBufToPerson cbs - print people + let Right people = PBDec.parse (fromProtoViaSchema @_ @_ @ExampleSchema) cbs + print (people :: Person) -- Encode a couple of values putStrLn "haskell/generate" print examplePerson1 - let gbs = PBEnc.toLazyByteString (personToProtoBuf examplePerson1) + let gbs = PBEnc.toLazyByteString (toProtoViaSchema @_ @_ @ExampleSchema examplePerson1) LBS.writeFile genFile gbs \ No newline at end of file diff --git a/schema/test/protobuf/consume.py b/adapter/protobuf/test/protobuf/consume.py similarity index 100% rename from schema/test/protobuf/consume.py rename to adapter/protobuf/test/protobuf/consume.py diff --git a/schema/test/protobuf/example.proto b/adapter/protobuf/test/protobuf/example.proto similarity index 100% rename from schema/test/protobuf/example.proto rename to adapter/protobuf/test/protobuf/example.proto diff --git a/schema/test/protobuf/example_pb2.py b/adapter/protobuf/test/protobuf/example_pb2.py similarity index 100% rename from schema/test/protobuf/example_pb2.py rename to adapter/protobuf/test/protobuf/example_pb2.py diff --git a/schema/test/protobuf/generate.py b/adapter/protobuf/test/protobuf/generate.py similarity index 100% rename from schema/test/protobuf/generate.py rename to adapter/protobuf/test/protobuf/generate.py diff --git a/grpc/CHANGELOG.md b/core/rpc/CHANGELOG.md similarity index 100% rename from grpc/CHANGELOG.md rename to core/rpc/CHANGELOG.md diff --git a/schema/LICENSE b/core/rpc/LICENSE similarity index 100% rename from schema/LICENSE rename to core/rpc/LICENSE diff --git a/rpc/README.md b/core/rpc/README.md similarity index 100% rename from rpc/README.md rename to core/rpc/README.md diff --git a/grpc/Setup.hs b/core/rpc/Setup.hs similarity index 100% rename from grpc/Setup.hs rename to core/rpc/Setup.hs diff --git a/rpc/mu-rpc.cabal b/core/rpc/mu-rpc.cabal similarity index 83% rename from rpc/mu-rpc.cabal rename to core/rpc/mu-rpc.cabal index 11becb9b..15556ea7 100644 --- a/rpc/mu-rpc.cabal +++ b/core/rpc/mu-rpc.cabal @@ -19,16 +19,13 @@ extra-source-files: README.md, CHANGELOG.md library exposed-modules: Mu.Rpc, - Mu.Rpc.Quasi, Mu.Server, Mu.Rpc.Examples -- other-modules: -- other-extensions: build-depends: base >=4.12 && <5, sop-core, mu-schema, conduit, text, - template-haskell, language-protobuf, - compendium-client, - http-client, servant-client-core + template-haskell hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -fprint-potential-instances \ No newline at end of file diff --git a/rpc/src/Mu/Rpc.hs b/core/rpc/src/Mu/Rpc.hs similarity index 100% rename from rpc/src/Mu/Rpc.hs rename to core/rpc/src/Mu/Rpc.hs diff --git a/rpc/src/Mu/Rpc/Examples.hs b/core/rpc/src/Mu/Rpc/Examples.hs similarity index 98% rename from rpc/src/Mu/Rpc/Examples.hs rename to core/rpc/src/Mu/Rpc/Examples.hs index 3989001a..0ae69f44 100644 --- a/rpc/src/Mu/Rpc/Examples.hs +++ b/core/rpc/src/Mu/Rpc/Examples.hs @@ -14,7 +14,6 @@ import GHC.Generics import Mu.Schema import Mu.Rpc import Mu.Server -import Mu.Schema.Adapter.ProtoBuf -- Defines the service from gRPC Quickstart -- https://grpc.io/docs/quickstart/python/ diff --git a/rpc/src/Mu/Server.hs b/core/rpc/src/Mu/Server.hs similarity index 100% rename from rpc/src/Mu/Server.hs rename to core/rpc/src/Mu/Server.hs diff --git a/rpc/CHANGELOG.md b/core/schema/CHANGELOG.md similarity index 100% rename from rpc/CHANGELOG.md rename to core/schema/CHANGELOG.md diff --git a/core/schema/LICENSE b/core/schema/LICENSE new file mode 100644 index 00000000..d6456956 --- /dev/null +++ b/core/schema/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/schema/README.md b/core/schema/README.md similarity index 100% rename from schema/README.md rename to core/schema/README.md diff --git a/rpc/Setup.hs b/core/schema/Setup.hs similarity index 100% rename from rpc/Setup.hs rename to core/schema/Setup.hs diff --git a/schema/mu-schema.cabal b/core/schema/mu-schema.cabal similarity index 60% rename from schema/mu-schema.cabal rename to core/schema/mu-schema.cabal index 82afdb77..eb1531a0 100644 --- a/schema/mu-schema.cabal +++ b/core/schema/mu-schema.cabal @@ -25,53 +25,24 @@ library , Mu.Schema.Interpretation.Anonymous , Mu.Schema.Class , Mu.Schema.Registry - , Mu.Schema.Adapter.Avro - , Mu.Schema.Adapter.ProtoBuf - , Mu.Schema.Adapter.Json - , Mu.Schema.Quasi , Mu.Schema.Conversion.TypesToSchema , Mu.Schema.Conversion.SchemaToTypes , Mu.Schema.Examples - , Mu.Schema.AvroExample + , Mu.Schema.Annotations + , Mu.Adapter.Json -- other-modules: -- other-extensions: build-depends: base >=4.12 && <5 , sop-core , containers , unordered-containers - , vector , bytestring + , vector , text - , avro - , tagged - , proto3-wire , aeson , template-haskell >= 2.12 , th-abstraction - , language-protobuf hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall - -fprint-potential-instances - -executable test-avro - main-is: Avro.hs - build-depends: base >=4.12 && <5 - , sop-core - , mu-schema - , avro - , bytestring - hs-source-dirs: test - default-language: Haskell2010 - ghc-options: -Wall - -executable test-protobuf - main-is: ProtoBuf.hs - build-depends: base >=4.12 && <5 - , sop-core - , mu-schema - , proto3-wire - , bytestring - hs-source-dirs: test - default-language: Haskell2010 - ghc-options: -Wall + -fprint-potential-instances \ No newline at end of file diff --git a/schema/src/Mu/Schema/Adapter/Json.hs b/core/schema/src/Mu/Adapter/Json.hs similarity index 99% rename from schema/src/Mu/Schema/Adapter/Json.hs rename to core/schema/src/Mu/Adapter/Json.hs index 5e7987a6..f9b27292 100644 --- a/schema/src/Mu/Schema/Adapter/Json.hs +++ b/core/schema/src/Mu/Adapter/Json.hs @@ -5,7 +5,7 @@ TypeApplications, UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Mu.Schema.Adapter.Json where +module Mu.Adapter.Json where import Control.Applicative ((<|>)) import Data.Aeson diff --git a/schema/src/Mu/Schema.hs b/core/schema/src/Mu/Schema.hs similarity index 82% rename from schema/src/Mu/Schema.hs rename to core/schema/src/Mu/Schema.hs index 18770239..09b96cb0 100644 --- a/schema/src/Mu/Schema.hs +++ b/core/schema/src/Mu/Schema.hs @@ -1,10 +1,8 @@ {-# language DataKinds #-} -- | Schemas for Mu microservices module Mu.Schema ( - -- * Quasi-quoters for schemas - protobuf, protobufFile -- * Schema definition -, Schema, Schema' + Schema, Schema' , Annotation, KnownName(..) , TypeDef, TypeDefB(..) , ChoiceDef(..) @@ -19,9 +17,11 @@ module Mu.Schema ( , WithSchema(..), HasSchema(..), toSchema', fromSchema' -- ** Mappings between fields , Mapping(..), Mappings, MappingRight, MappingLeft + -- ** Field annotations +, ProtoBufId, ProtoBufOneOfIds ) where +import Mu.Schema.Annotations import Mu.Schema.Definition import Mu.Schema.Interpretation -import Mu.Schema.Class -import Mu.Schema.Quasi \ No newline at end of file +import Mu.Schema.Class \ No newline at end of file diff --git a/core/schema/src/Mu/Schema/Annotations.hs b/core/schema/src/Mu/Schema/Annotations.hs new file mode 100644 index 00000000..7b048a36 --- /dev/null +++ b/core/schema/src/Mu/Schema/Annotations.hs @@ -0,0 +1,9 @@ +{-# language DataKinds, KindSignatures #-} +module Mu.Schema.Annotations where + +import GHC.TypeLits + +-- ANNOTATION FOR CONVERSION + +data ProtoBufId (n :: Nat) +data ProtoBufOneOfIds (ns :: [Nat]) \ No newline at end of file diff --git a/schema/src/Mu/Schema/Class.hs b/core/schema/src/Mu/Schema/Class.hs similarity index 100% rename from schema/src/Mu/Schema/Class.hs rename to core/schema/src/Mu/Schema/Class.hs diff --git a/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs b/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs similarity index 100% rename from schema/src/Mu/Schema/Conversion/SchemaToTypes.hs rename to core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs diff --git a/schema/src/Mu/Schema/Conversion/TypesToSchema.hs b/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs similarity index 100% rename from schema/src/Mu/Schema/Conversion/TypesToSchema.hs rename to core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs diff --git a/schema/src/Mu/Schema/Definition.hs b/core/schema/src/Mu/Schema/Definition.hs similarity index 100% rename from schema/src/Mu/Schema/Definition.hs rename to core/schema/src/Mu/Schema/Definition.hs diff --git a/schema/src/Mu/Schema/Examples.hs b/core/schema/src/Mu/Schema/Examples.hs similarity index 76% rename from schema/src/Mu/Schema/Examples.hs rename to core/schema/src/Mu/Schema/Examples.hs index 4520be94..f1008216 100644 --- a/schema/src/Mu/Schema/Examples.hs +++ b/core/schema/src/Mu/Schema/Examples.hs @@ -8,19 +8,12 @@ module Mu.Schema.Examples where import qualified Data.Aeson as J -import qualified Data.Avro as A import qualified Data.Text as T import GHC.Generics import Mu.Schema -import Mu.Schema.Adapter.Avro () -import Mu.Schema.Adapter.ProtoBuf -import Mu.Schema.Adapter.Json () - import Mu.Schema.Conversion.SchemaToTypes - -import qualified Proto3.Wire.Encode as PBEnc -import qualified Proto3.Wire.Decode as PBDec +import Mu.Adapter.Json () data Person = Person { firstName :: T.Text @@ -30,26 +23,20 @@ data Person , address :: Address } deriving (Eq, Show, Generic) deriving (HasSchema ExampleSchema "person") - deriving (A.HasAvroSchema, A.FromAvro, A.ToAvro, J.ToJSON, J.FromJSON) + deriving (J.ToJSON, J.FromJSON) via (WithSchema ExampleSchema "person" Person) -personToProtoBuf :: Person -> PBEnc.MessageBuilder -personToProtoBuf = toProtoViaSchema @ExampleSchema - -protoBufToPerson :: PBDec.Parser PBDec.RawMessage Person -protoBufToPerson = fromProtoViaSchema @ExampleSchema - data Address = Address { postcode :: T.Text , country :: T.Text } deriving (Eq, Show, Generic) deriving (HasSchema ExampleSchema "address") - deriving (A.HasAvroSchema, A.FromAvro, A.ToAvro, J.ToJSON, J.FromJSON) + deriving (J.ToJSON, J.FromJSON) via (WithSchema ExampleSchema "address" Address) data Gender = Male | Female | NonBinary deriving (Eq, Show, Generic) - deriving (A.HasAvroSchema, A.FromAvro, A.ToAvro, J.ToJSON, J.FromJSON) + deriving (J.ToJSON, J.FromJSON) via (WithSchema ExampleSchema "gender" Gender) -- Schema for these data types @@ -57,7 +44,7 @@ type ExampleSchema = '[ 'DEnum "gender" '[] '[ 'ChoiceDef "male" '[ ProtoBufId 1 ] , 'ChoiceDef "female" '[ ProtoBufId 2 ] - , 'ChoiceDef "nb" '[ ProtoBufId 0 ] ] + , 'ChoiceDef "nb" '[ ProtoBufId 3 ] ] , 'DRecord "address" '[] '[ 'FieldDef "postcode" '[ ProtoBufId 1 ] ('TPrimitive T.Text) , 'FieldDef "country" '[ ProtoBufId 2 ] ('TPrimitive T.Text) ] @@ -90,7 +77,7 @@ type ExampleSchema2 = '[ 'DEnum "gender" '[] '[ 'ChoiceDef "Male" '[ ProtoBufId 1 ] , 'ChoiceDef "Female" '[ ProtoBufId 2 ] - , 'ChoiceDef "NonBinary" '[ ProtoBufId 0 ] ] + , 'ChoiceDef "NonBinary" '[ ProtoBufId 3 ] ] , 'DRecord "address" '[] '[ 'FieldDef "postcode" '[ ProtoBufId 1 ] ('TPrimitive T.Text) , 'FieldDef "country" '[ ProtoBufId 2 ] ('TPrimitive T.Text) ] @@ -103,17 +90,4 @@ type ExampleSchema2 ] type ExampleRegistry - = '[ 2 ':-> ExampleSchema2, 1 ':-> ExampleSchema] - -type ExampleSchema3 = [protobuf| -enum gender { - male = 1; - female = 2; - nonbinary = 3; -} -message person { - repeated string names = 1; - int age = 2; - gender gender = 3; -} -|] \ No newline at end of file + = '[ 2 ':-> ExampleSchema2, 1 ':-> ExampleSchema] \ No newline at end of file diff --git a/schema/src/Mu/Schema/Interpretation.hs b/core/schema/src/Mu/Schema/Interpretation.hs similarity index 100% rename from schema/src/Mu/Schema/Interpretation.hs rename to core/schema/src/Mu/Schema/Interpretation.hs diff --git a/schema/src/Mu/Schema/Interpretation/Anonymous.hs b/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs similarity index 100% rename from schema/src/Mu/Schema/Interpretation/Anonymous.hs rename to core/schema/src/Mu/Schema/Interpretation/Anonymous.hs diff --git a/schema/src/Mu/Schema/Interpretation/Schemaless.hs b/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs similarity index 100% rename from schema/src/Mu/Schema/Interpretation/Schemaless.hs rename to core/schema/src/Mu/Schema/Interpretation/Schemaless.hs diff --git a/schema/src/Mu/Schema/Registry.hs b/core/schema/src/Mu/Schema/Registry.hs similarity index 100% rename from schema/src/Mu/Schema/Registry.hs rename to core/schema/src/Mu/Schema/Registry.hs diff --git a/examples/health-check/mu-example-health-check.cabal b/examples/health-check/mu-example-health-check.cabal index c7e026c3..7a3b91b8 100644 --- a/examples/health-check/mu-example-health-check.cabal +++ b/examples/health-check/mu-example-health-check.cabal @@ -19,7 +19,7 @@ build-type: Simple library exposed-modules: Definition build-depends: base >=4.12 && <5, text, - mu-schema, mu-rpc, mu-grpc, + mu-schema, mu-rpc, mu-protobuf, stm, stm-containers, conduit, stm-conduit, deferred-folds @@ -31,7 +31,8 @@ executable health-server main-is: Server.hs other-modules: Definition build-depends: base >=4.12 && <5, text, - mu-schema, mu-rpc, mu-grpc, + mu-schema, mu-rpc, mu-protobuf, + mu-grpc-server, stm, stm-containers, conduit, stm-conduit, deferred-folds @@ -43,8 +44,8 @@ executable health-client-tyapps main-is: ClientTyApps.hs other-modules: Definition build-depends: base >=4.12 && <5, text, - mu-schema, mu-rpc, mu-grpc, - conduit + mu-schema, mu-rpc, mu-protobuf, + mu-grpc-client, conduit hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall @@ -53,8 +54,8 @@ executable health-client-record main-is: ClientRecord.hs other-modules: Definition build-depends: base >=4.12 && <5, text, - mu-schema, mu-rpc, mu-grpc, - conduit + mu-schema, mu-rpc, mu-protobuf, + mu-grpc-client, conduit hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall \ No newline at end of file diff --git a/examples/health-check/src/ClientRecord.hs b/examples/health-check/src/ClientRecord.hs index 6b62de4c..2a74b228 100644 --- a/examples/health-check/src/ClientRecord.hs +++ b/examples/health-check/src/ClientRecord.hs @@ -10,7 +10,7 @@ import qualified Data.Text as T import GHC.Generics (Generic) import System.Environment -import Mu.Client.GRpc.Record +import Mu.GRpc.Client.Record import Definition diff --git a/examples/health-check/src/ClientTyApps.hs b/examples/health-check/src/ClientTyApps.hs index 961f1cf7..7ef6645d 100644 --- a/examples/health-check/src/ClientTyApps.hs +++ b/examples/health-check/src/ClientTyApps.hs @@ -9,7 +9,7 @@ import qualified Data.Conduit.Combinators as C import qualified Data.Text as T import System.Environment -import Mu.Client.GRpc.TyApps +import Mu.GRpc.Client.TyApps import Definition diff --git a/examples/health-check/src/Definition.hs b/examples/health-check/src/Definition.hs index c7917523..7c02647e 100644 --- a/examples/health-check/src/Definition.hs +++ b/examples/health-check/src/Definition.hs @@ -10,7 +10,7 @@ import GHC.Generics import Data.Text as T import Mu.Schema -import Mu.Rpc.Quasi +import Mu.Quasi.GRpc $(grpc "HealthCheckSchema" id "healthcheck.proto") diff --git a/examples/health-check/src/Server.hs b/examples/health-check/src/Server.hs index 3508c48f..d44bb58d 100644 --- a/examples/health-check/src/Server.hs +++ b/examples/health-check/src/Server.hs @@ -11,7 +11,7 @@ import DeferredFolds.UnfoldlM import qualified StmContainers.Map as M import Mu.Server -import Mu.Server.GRpc +import Mu.GRpc.Server import Definition diff --git a/examples/route-guide/mu-example-route-guide.cabal b/examples/route-guide/mu-example-route-guide.cabal index c9991efc..b4e95745 100644 --- a/examples/route-guide/mu-example-route-guide.cabal +++ b/examples/route-guide/mu-example-route-guide.cabal @@ -19,7 +19,7 @@ build-type: Simple library exposed-modules: Definition build-depends: base >=4.12 && <5, text, - mu-schema, mu-rpc, mu-grpc, + mu-schema, mu-rpc, mu-protobuf, hashable hs-source-dirs: src default-language: Haskell2010 @@ -29,7 +29,8 @@ executable route-guide-server main-is: Server.hs other-modules: Definition build-depends: base >=4.12 && <5, text, - mu-schema, mu-rpc, mu-grpc, + mu-schema, mu-rpc, mu-protobuf, + mu-grpc-server, stm, stm-chans, hashable, conduit, AC-Angle, time, async hs-source-dirs: src diff --git a/examples/route-guide/src/Definition.hs b/examples/route-guide/src/Definition.hs index 47b0a726..b0dbd644 100644 --- a/examples/route-guide/src/Definition.hs +++ b/examples/route-guide/src/Definition.hs @@ -11,9 +11,7 @@ import Data.Int import Data.Text as T import Mu.Schema -import Mu.Schema.Adapter.ProtoBuf -import Mu.Rpc -import Mu.Rpc.Quasi +import Mu.Quasi.GRpc $(grpc "RouteGuideSchema" id "routeguide.proto") diff --git a/examples/route-guide/src/Server.hs b/examples/route-guide/src/Server.hs index 8b373a54..562bdd3b 100644 --- a/examples/route-guide/src/Server.hs +++ b/examples/route-guide/src/Server.hs @@ -17,7 +17,7 @@ import Data.Maybe import Data.Time.Clock import Mu.Server -import Mu.Server.GRpc +import Mu.GRpc.Server import Definition diff --git a/schema/CHANGELOG.md b/grpc/client/CHANGELOG.md similarity index 100% rename from schema/CHANGELOG.md rename to grpc/client/CHANGELOG.md diff --git a/grpc/client/LICENSE b/grpc/client/LICENSE new file mode 100644 index 00000000..d6456956 --- /dev/null +++ b/grpc/client/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/schema/Setup.hs b/grpc/client/Setup.hs similarity index 100% rename from schema/Setup.hs rename to grpc/client/Setup.hs diff --git a/grpc/client/mu-grpc-client.cabal b/grpc/client/mu-grpc-client.cabal new file mode 100644 index 00000000..7a08b0d4 --- /dev/null +++ b/grpc/client/mu-grpc-client.cabal @@ -0,0 +1,35 @@ +cabal-version: >=1.10 +-- Initial package description 'mu-haskell.cabal' generated by 'cabal +-- init'. For further documentation, see +-- http://haskell.org/cabal/users-guide/ + +name: mu-grpc-client +version: 0.1.0.0 +synopsis: gRPC clients from Mu definitions +-- description: +-- bug-reports: +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano +maintainer: alejandro.serrano@47deg.com +-- copyright: +category: Network +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: Mu.GRpc.Client.TyApps, + Mu.GRpc.Client.Record, + Mu.GRpc.Client.Examples + other-modules: Mu.GRpc.Client.Internal + -- other-extensions: + build-depends: base >=4.12 && <5, sop-core, + bytestring, async, text, + mu-schema, mu-rpc, mu-protobuf, + http2, http2-client, http2-client-grpc, + http2-grpc-proto3-wire, + conduit, stm, stm-chans, stm-conduit, + template-haskell >= 2.12, th-abstraction + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances \ No newline at end of file diff --git a/grpc/src/Mu/Client/GRpc/Examples.hs b/grpc/client/src/Mu/GRpc/Client/Examples.hs similarity index 93% rename from grpc/src/Mu/Client/GRpc/Examples.hs rename to grpc/client/src/Mu/GRpc/Client/Examples.hs index 6af7d6e9..0c0b9144 100644 --- a/grpc/src/Mu/Client/GRpc/Examples.hs +++ b/grpc/client/src/Mu/GRpc/Client/Examples.hs @@ -1,5 +1,5 @@ {-# language DataKinds, TypeApplications #-} -module Mu.Client.GRpc.Examples where +module Mu.GRpc.Client.Examples where import Data.Conduit import Data.Conduit.Combinators as C @@ -7,7 +7,7 @@ import Data.Conduit.List (consume) import qualified Data.Text as T import Network.HTTP2.Client (HostName, PortNumber) -import Mu.Client.GRpc.TyApps +import Mu.GRpc.Client.TyApps import Mu.Rpc.Examples sayHello' :: HostName -> PortNumber -> T.Text -> IO (GRpcReply T.Text) diff --git a/grpc/src/Mu/Client/GRpc/Internal.hs b/grpc/client/src/Mu/GRpc/Client/Internal.hs similarity index 99% rename from grpc/src/Mu/Client/GRpc/Internal.hs rename to grpc/client/src/Mu/GRpc/Client/Internal.hs index 2c117b0c..1f3e7b3b 100644 --- a/grpc/src/Mu/Client/GRpc/Internal.hs +++ b/grpc/client/src/Mu/GRpc/Client/Internal.hs @@ -6,7 +6,7 @@ AllowAmbiguousTypes, TupleSections, UndecidableInstances #-} -- | Client for gRPC services defined using Mu 'Service' -module Mu.Client.GRpc.Internal where +module Mu.GRpc.Client.Internal where import Control.Monad.IO.Class import Control.Concurrent.Async @@ -27,8 +27,7 @@ import Network.GRPC.Client.Helpers import Mu.Rpc import Mu.Schema - -import Mu.GRpc.Shared +import Mu.Adapter.ProtoBuf.Via setupGrpcClient' :: GrpcClientConfig -> IO (Either ClientError GrpcClient) setupGrpcClient' = runExceptT . setupGrpcClient diff --git a/grpc/src/Mu/Client/GRpc/Record.hs b/grpc/client/src/Mu/GRpc/Client/Record.hs similarity index 99% rename from grpc/src/Mu/Client/GRpc/Record.hs rename to grpc/client/src/Mu/GRpc/Client/Record.hs index 18785f82..c88838df 100644 --- a/grpc/src/Mu/Client/GRpc/Record.hs +++ b/grpc/client/src/Mu/GRpc/Client/Record.hs @@ -6,7 +6,7 @@ TemplateHaskell #-} -- | Client for gRPC services defined using Mu 'Service' -- using plain Haskell records of functions -module Mu.Client.GRpc.Record ( +module Mu.GRpc.Client.Record ( -- * Initialization of the gRPC client GrpcClient , GrpcClientConfig @@ -32,7 +32,7 @@ import Language.Haskell.TH.Datatype import Network.GRPC.Client (CompressMode(..)) import Network.GRPC.Client.Helpers -import Mu.Client.GRpc.Internal +import Mu.GRpc.Client.Internal import Mu.Rpc -- | Fills in a Haskell record of functions with the corresponding diff --git a/grpc/src/Mu/Client/GRpc/TyApps.hs b/grpc/client/src/Mu/GRpc/Client/TyApps.hs similarity index 95% rename from grpc/src/Mu/Client/GRpc/TyApps.hs rename to grpc/client/src/Mu/GRpc/Client/TyApps.hs index d494bbf0..13adcaa7 100644 --- a/grpc/src/Mu/Client/GRpc/TyApps.hs +++ b/grpc/client/src/Mu/GRpc/Client/TyApps.hs @@ -4,7 +4,7 @@ TypeOperators, AllowAmbiguousTypes #-} -- | Client for gRPC services defined using Mu 'Service' -- using 'TypeApplications' -module Mu.Client.GRpc.TyApps ( +module Mu.GRpc.Client.TyApps ( -- * Initialization of the gRPC client GrpcClient , GrpcClientConfig @@ -22,7 +22,7 @@ import Network.GRPC.Client.Helpers import Mu.Rpc import Mu.Schema -import Mu.Client.GRpc.Internal +import Mu.GRpc.Client.Internal -- | Call a method from a Mu definition. -- This method is thought to be used with @TypeApplications@: diff --git a/grpc/mu-grpc.cabal b/grpc/mu-grpc.cabal deleted file mode 100644 index 251bd1b5..00000000 --- a/grpc/mu-grpc.cabal +++ /dev/null @@ -1,55 +0,0 @@ -cabal-version: >=1.10 --- Initial package description 'mu-haskell.cabal' generated by 'cabal --- init'. For further documentation, see --- http://haskell.org/cabal/users-guide/ - -name: mu-grpc -version: 0.1.0.0 -synopsis: gRPC servers and clients for Mu definitions --- description: --- bug-reports: -license: Apache-2.0 -license-file: LICENSE -author: Alejandro Serrano -maintainer: alejandro.serrano@47deg.com --- copyright: -category: Network -build-type: Simple -extra-source-files: CHANGELOG.md - -library - exposed-modules: Mu.Server.GRpc, - Mu.Client.GRpc.Internal, - Mu.Client.GRpc.TyApps, - Mu.Client.GRpc.Record, - Mu.Client.GRpc.Examples - other-modules: Mu.GRpc.Shared - -- other-extensions: - build-depends: base >=4.12 && <5, sop-core, - mu-schema, mu-rpc, warp-grpc, - conduit, bytestring, text, - wai, warp, warp-tls, - async, stm, stm-conduit, stm-chans, - http2, http2-client, - http2-grpc-types, http2-client-grpc, - proto3-wire, http2-grpc-proto3-wire, - template-haskell, th-abstraction - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall -fprint-potential-instances - -executable grpc-example-server - main-is: ExampleServer.hs - build-depends: base >=4.12 && <5, sop-core, - mu-schema, mu-rpc, warp-grpc, - conduit, bytestring, text, - wai, warp, warp-tls, - async, stm, stm-conduit, stm-chans, - http2, http2-client, - http2-grpc-types, http2-client-grpc, - proto3-wire, http2-grpc-proto3-wire, - template-haskell, th-abstraction - other-modules: Mu.GRpc.Shared, Mu.Server.GRpc - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall \ No newline at end of file diff --git a/grpc/server/CHANGELOG.md b/grpc/server/CHANGELOG.md new file mode 100644 index 00000000..e69cc087 --- /dev/null +++ b/grpc/server/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for mu-haskell + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/grpc/server/LICENSE b/grpc/server/LICENSE new file mode 100644 index 00000000..d6456956 --- /dev/null +++ b/grpc/server/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/grpc/server/Setup.hs b/grpc/server/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/grpc/server/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/grpc/server/mu-grpc-server.cabal b/grpc/server/mu-grpc-server.cabal new file mode 100644 index 00000000..17f95f44 --- /dev/null +++ b/grpc/server/mu-grpc-server.cabal @@ -0,0 +1,44 @@ +cabal-version: >=1.10 +-- Initial package description 'mu-haskell.cabal' generated by 'cabal +-- init'. For further documentation, see +-- http://haskell.org/cabal/users-guide/ + +name: mu-grpc-server +version: 0.1.0.0 +synopsis: gRPC servers for Mu definitions +-- description: +-- bug-reports: +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano +maintainer: alejandro.serrano@47deg.com +-- copyright: +category: Network +build-type: Simple +extra-source-files: CHANGELOG.md + +library + exposed-modules: Mu.GRpc.Server + -- other-extensions: + build-depends: base >=4.12 && <5, sop-core, + bytestring, async, + mu-schema, mu-rpc, mu-protobuf, + warp, warp-grpc, wai, warp-tls, + http2-grpc-types, http2-grpc-proto3-wire, + conduit, stm, stm-conduit + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances + +executable grpc-example-server + main-is: ExampleServer.hs + other-modules: Mu.GRpc.Server + build-depends: base >=4.12 && <5, sop-core, + bytestring, async, + mu-schema, mu-rpc, mu-protobuf, + warp, warp-grpc, wai, warp-tls, + http2-grpc-types, http2-grpc-proto3-wire, + conduit, stm, stm-conduit + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall \ No newline at end of file diff --git a/grpc/src/ExampleServer.hs b/grpc/server/src/ExampleServer.hs similarity index 89% rename from grpc/src/ExampleServer.hs rename to grpc/server/src/ExampleServer.hs index d38a2c83..7d76f1d9 100644 --- a/grpc/src/ExampleServer.hs +++ b/grpc/server/src/ExampleServer.hs @@ -1,7 +1,7 @@ {-# language OverloadedStrings #-} module Main where -import Mu.Server.GRpc +import Mu.GRpc.Server import Mu.Rpc.Examples main :: IO () diff --git a/grpc/src/Mu/Server/GRpc.hs b/grpc/server/src/Mu/GRpc/Server.hs similarity index 99% rename from grpc/src/Mu/Server/GRpc.hs rename to grpc/server/src/Mu/GRpc/Server.hs index 164b7007..ed6e9f7d 100644 --- a/grpc/src/Mu/Server/GRpc.hs +++ b/grpc/server/src/Mu/GRpc/Server.hs @@ -5,7 +5,7 @@ TypeApplications, TypeOperators, ScopedTypeVariables #-} -- | Execute a Mu 'Server' using gRPC as transport layer -module Mu.Server.GRpc ( +module Mu.GRpc.Server ( -- * Run a 'Server' directly runGRpcApp , runGRpcAppSettings, Settings @@ -36,8 +36,7 @@ import Network.Wai.Handler.WarpTLS (TLSSettings, runTLS) import Mu.Rpc import Mu.Server import Mu.Schema - -import Mu.GRpc.Shared +import Mu.Adapter.ProtoBuf.Via -- | Run a Mu 'Server' on the given port. runGRpcApp diff --git a/grpc/test/helloworld.proto b/grpc/test/helloworld.proto deleted file mode 100644 index 50aa4cfa..00000000 --- a/grpc/test/helloworld.proto +++ /dev/null @@ -1,46 +0,0 @@ -// Copyright 2015 gRPC authors. -// Modified 2019, by Alejandro Serrano. -// -// Licensed under the Apache License, Version 2.0 (the "License"); -// you may not use this file except in compliance with the License. -// You may obtain a copy of the License at -// -// http://www.apache.org/licenses/LICENSE-2.0 -// -// Unless required by applicable law or agreed to in writing, software -// distributed under the License is distributed on an "AS IS" BASIS, -// WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. -// See the License for the specific language governing permissions and -// limitations under the License. - -syntax = "proto3"; - -option java_multiple_files = true; -option java_package = "io.grpc.examples.helloworld"; -option java_outer_classname = "HelloWorldProto"; -option objc_class_prefix = "HLW"; - -package helloworld; - -// The greeting service definition. -service Greeter { - // Sends a greeting - rpc SayHello (HelloRequest) returns (HelloReply) {} - rpc SayHi (HiRequest) returns (stream HelloReply) {} - rpc SayManyHellos (stream HelloRequest) returns (stream HelloReply) {} -} - -// The request message containing the user's name. -message HelloRequest { - string name = 1; -} - -// The request message containing the amount of greetings. -message HiRequest { - int32 number = 1; -} - -// The response message containing the greetings -message HelloReply { - string message = 1; -} \ No newline at end of file diff --git a/stack-nightly.yaml b/stack-nightly.yaml index f673b7c2..e3eba80a 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -1,10 +1,13 @@ -resolver: nightly-2019-11-04 +resolver: nightly-2019-11-17 allow-newer: true packages: -- schema -- rpc -- grpc +- core/schema +- core/rpc +- adapter/avro +- adapter/protobuf +- grpc/client +- grpc/server - examples/health-check - examples/route-guide - compendium-client diff --git a/stack.yaml b/stack.yaml index d5d88f5b..bbad662f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,12 @@ -resolver: lts-14.13 +resolver: lts-14.14 packages: -- schema -- rpc -- grpc +- core/schema +- core/rpc +- adapter/avro +- adapter/protobuf +- grpc/client +- grpc/server - examples/health-check - examples/route-guide - compendium-client diff --git a/test-schema.sh b/test-schema.sh index ffe8cb8c..feffaece 100755 --- a/test-schema.sh +++ b/test-schema.sh @@ -6,19 +6,19 @@ # follow https://github.com/protocolbuffers/protobuf/tree/master/python echo "BUILDING" -stack build +stack build mu-avro mu-protobuf mkdir -p dist echo "\nAVRO\n====\n" echo "python/generate" -python3 schema/test/avro/generate.py schema/test/avro/example.avsc dist/avro-python.avro +python3 adapter/avro/test/avro/generate.py adapter/avro/test/avro/example.avsc dist/avro-python.avro stack exec test-avro dist/avro-haskell.avro dist/avro-python.avro echo "ptyhon/consume" -python3 schema/test/avro/consume.py schema/test/avro/example.avsc dist/avro-haskell.avro +python3 adapter/avro/test/avro/consume.py adapter/avro/test/avro/example.avsc dist/avro-haskell.avro echo "\nPROTOBUF\n========\n" echo "python/generate" -python schema/test/protobuf/generate.py dist/protobuf-python.pbuf +python adapter/protobuf/test/protobuf/generate.py dist/protobuf-python.pbuf stack exec test-protobuf dist/protobuf-haskell.pbuf dist/protobuf-python.pbuf echo "python/consume" -python schema/test/protobuf/consume.py dist/protobuf-haskell.pbuf \ No newline at end of file +python adapter/protobuf/test/protobuf/consume.py dist/protobuf-haskell.pbuf \ No newline at end of file From 2cd09028a2e25b8ddb191870c058048b3d713a3c Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 18 Nov 2019 12:28:53 +0100 Subject: [PATCH 005/217] Depend on released packages --- stack-nightly.yaml | 13 +++++-------- stack.yaml | 18 ++++++++---------- 2 files changed, 13 insertions(+), 18 deletions(-) diff --git a/stack-nightly.yaml b/stack-nightly.yaml index e3eba80a..ce39b919 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -13,14 +13,11 @@ packages: - compendium-client extra-deps: -- proto3-wire-1.0.0 - http2-client-0.9.0.0 +- http2-grpc-types-0.5.0.0 +- proto3-wire-1.0.0 +- http2-grpc-proto3-wire-0.1.0.0 +- warp-grpc-0.2.0.0 +- http2-client-grpc-0.8.0.0 - avro-0.4.5.4 - language-protobuf-1.0 -- git: https://github.com/haskell-grpc-native/http2-grpc-haskell.git - commit: 15f73333b0146847095aeee6fe26bc8fa8eaf47f - subdirs: - - http2-grpc-types - - http2-grpc-proto3-wire - - warp-grpc - - http2-client-grpc diff --git a/stack.yaml b/stack.yaml index bbad662f..cffa065e 100644 --- a/stack.yaml +++ b/stack.yaml @@ -12,20 +12,18 @@ packages: - compendium-client extra-deps: -- proto3-wire-1.0.0 - http2-client-0.9.0.0 +- http2-grpc-types-0.5.0.0 +- proto3-wire-1.0.0 +- http2-grpc-proto3-wire-0.1.0.0 +- warp-grpc-0.2.0.0 +- http2-client-grpc-0.8.0.0 +- avro-0.4.5.4 +- language-protobuf-1.0 +# missing in the current LTS - primitive-0.7.0.0 - primitive-extras-0.8 - primitive-unlifted-0.1.2.0 - stm-hamt-1.2.0.4 - stm-containers-1.1.0.4 - AC-Angle-1.0 -- avro-0.4.5.4 -- language-protobuf-1.0 -- git: https://github.com/haskell-grpc-native/http2-grpc-haskell.git - commit: 15f73333b0146847095aeee6fe26bc8fa8eaf47f - subdirs: - - http2-grpc-types - - http2-grpc-proto3-wire - - warp-grpc - - http2-client-grpc From e0910afd5f7dc479adaf8a9b0471ad49f7771809 Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Thu, 21 Nov 2019 13:25:53 +0100 Subject: [PATCH 006/217] =?UTF-8?q?Run=20stylish-haskell=20in=20all=20file?= =?UTF-8?q?s!=20=F0=9F=92=85=F0=9F=8F=BC=20(#23)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Run stylish-haskell in all files! 💅🏼 --- .editorconfig | 10 ++ .gitignore | 4 +- .stylish-haskell.yaml | 63 +++++++++ DEVELOPMENT.md | 26 ++++ adapter/avro/src/Mu/Adapter/Avro.hs | 59 +++++---- adapter/avro/src/Mu/Adapter/Avro/Example.hs | 2 +- adapter/avro/src/Mu/Quasi/Avro.hs | 95 ++++++++------ adapter/avro/test/Avro.hs | 44 ++++--- adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs | 66 +++++----- .../src/Mu/Adapter/ProtoBuf/Example.hs | 7 +- .../protobuf/src/Mu/Adapter/ProtoBuf/Via.hs | 29 +++-- adapter/protobuf/src/Mu/Quasi/GRpc.hs | 28 ++-- adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs | 31 +++-- adapter/protobuf/test/ProtoBuf.hs | 40 +++--- compendium-client/compendium-client.cabal | 18 ++- compendium-client/src/Compendium/Client.hs | 53 ++++---- core/rpc/src/Mu/Rpc.hs | 23 ++-- core/rpc/src/Mu/Rpc/Examples.hs | 32 +++-- core/rpc/src/Mu/Server.hs | 30 +++-- core/schema/src/Mu/Adapter/Json.hs | 42 +++--- core/schema/src/Mu/Schema.hs | 10 +- core/schema/src/Mu/Schema/Annotations.hs | 7 +- core/schema/src/Mu/Schema/Class.hs | 50 +++---- .../src/Mu/Schema/Conversion/SchemaToTypes.hs | 33 ++--- .../src/Mu/Schema/Conversion/TypesToSchema.hs | 24 ++-- core/schema/src/Mu/Schema/Definition.hs | 24 ++-- core/schema/src/Mu/Schema/Examples.hs | 35 +++-- core/schema/src/Mu/Schema/Interpretation.hs | 25 ++-- .../src/Mu/Schema/Interpretation/Anonymous.hs | 21 +-- .../Mu/Schema/Interpretation/Schemaless.hs | 44 ++++--- core/schema/src/Mu/Schema/Registry.hs | 32 +++-- examples/deployment/docker/Main.hs | 8 +- examples/health-check/src/ClientRecord.hs | 108 +++++++-------- examples/health-check/src/ClientTyApps.hs | 94 ++++++------- examples/health-check/src/Definition.hs | 28 ++-- examples/health-check/src/Server.hs | 88 ++++++------- examples/route-guide/src/Definition.hs | 30 +++-- examples/route-guide/src/Server.hs | 123 +++++++++--------- grpc/client/src/Mu/GRpc/Client/Examples.hs | 19 +-- grpc/client/src/Mu/GRpc/Client/Internal.hs | 106 ++++++++------- grpc/client/src/Mu/GRpc/Client/Record.hs | 52 ++++---- grpc/client/src/Mu/GRpc/Client/TyApps.hs | 29 +++-- grpc/server/src/ExampleServer.hs | 8 +- grpc/server/src/Mu/GRpc/Server.hs | 75 ++++++----- 44 files changed, 1002 insertions(+), 773 deletions(-) create mode 100644 .editorconfig create mode 100644 .stylish-haskell.yaml create mode 100644 DEVELOPMENT.md diff --git a/.editorconfig b/.editorconfig new file mode 100644 index 00000000..0f099897 --- /dev/null +++ b/.editorconfig @@ -0,0 +1,10 @@ +# editorconfig.org +root = true + +[*] +indent_style = space +indent_size = 2 +end_of_line = lf +charset = utf-8 +trim_trailing_whitespace = true +insert_final_newline = true diff --git a/.gitignore b/.gitignore index cd1d2f1e..a11c47c3 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,5 @@ stack*.yaml.lock -.* +.stack-work *~ dist -*.pyc \ No newline at end of file +*.pyc diff --git a/.stylish-haskell.yaml b/.stylish-haskell.yaml new file mode 100644 index 00000000..ea7fc447 --- /dev/null +++ b/.stylish-haskell.yaml @@ -0,0 +1,63 @@ +steps: + - simple_align: + cases: true + top_level_patterns: true + records: true + + # Import cleanup + - imports: + align: global + list_align: after_alias + pad_module_names: true + long_list_align: inline + empty_list_align: inherit + list_padding: 4 + separate_lists: true + space_surround: false + + # Language pragmas + - language_pragmas: + style: vertical + align: true + remove_redundant: true + language_prefix: language + + # Remove trailing whitespace + - trailing_whitespace: {} + +columns: 100 +newline: native +cabal: true +language_extensions: + - BangPatterns + - ConstraintKinds + - DataKinds + - DefaultSignatures + - DeriveAnyClass + - DeriveDataTypeable + - DeriveGeneric + - DerivingStrategies + - DerivingVia + - ExplicitNamespaces + - FlexibleContexts + - FlexibleInstances + - FunctionalDependencies + - GADTs + - GeneralizedNewtypeDeriving + - InstanceSigs + - KindSignatures + - LambdaCase + - MultiParamTypeClasses + - MultiWayIf + - NamedFieldPuns + - NoImplicitPrelude + - OverloadedStrings + - QuasiQuotes + - RecordWildCards + - ScopedTypeVariables + - StandaloneDeriving + - TemplateHaskell + - TupleSections + - TypeApplications + - TypeFamilies + - ViewPatterns diff --git a/DEVELOPMENT.md b/DEVELOPMENT.md new file mode 100644 index 00000000..041d11f3 --- /dev/null +++ b/DEVELOPMENT.md @@ -0,0 +1,26 @@ +# Development recommendations + +Before continuing, make sure you've read: + +- [Alejandro's post on setting up a Haskell development environment](https://www.47deg.com/blog/setting-up-haskell/). + +## VSCode extensions + +To make our lives easier while developing in Haskell, we use the following extensions: + +- [ghcide](https://marketplace.visualstudio.com/items?itemName=DigitalAssetHoldingsLLC.ghcide), the best thing that happened to Haskell for editors/IDEs! ❤️ +- [hlint](https://marketplace.visualstudio.com/items?itemName=hoovercj.haskell-linter), another great extension to have suggestions and refactors in Haskell 🛠 +- [stylish-haskell](https://marketplace.visualstudio.com/items?itemName=vigoo.stylish-haskell), the formatter we use to prettify the code 💅🏼 +- [editorconfig](https://marketplace.visualstudio.com/items?itemName=EditorConfig.EditorConfig), to have consistency between different editors and envs 🐀 + +## stylish-haskell 💅🏼 + +Regarding the formatter, we use the `master` version of [stylish-haskell](https://github.com/jaspervdj/stylish-haskell) to be able to use language pragmas with lowercase, so you'll need to do this locally: + +```sh +$ git clone https://github.com/jaspervdj/stylish-haskell +$ ... +$ cd stylish-haskell && stack install +``` + +Happy hacking! 👏🏼 diff --git a/adapter/avro/src/Mu/Adapter/Avro.hs b/adapter/avro/src/Mu/Adapter/Avro.hs index 9b9f0033..7849e3a0 100644 --- a/adapter/avro/src/Mu/Adapter/Avro.hs +++ b/adapter/avro/src/Mu/Adapter/Avro.hs @@ -1,30 +1,35 @@ -{-# language PolyKinds, DataKinds, GADTs, - FlexibleInstances, FlexibleContexts, - TypeApplications, TypeOperators, - ScopedTypeVariables, RankNTypes, - MultiParamTypeClasses, - UndecidableInstances #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Mu.Adapter.Avro where -import Control.Arrow ((***)) -import qualified Data.Avro as A -import qualified Data.Avro.Schema as ASch -import qualified Data.Avro.Types.Value as AVal +import Control.Arrow ((***)) +import qualified Data.Avro as A +import qualified Data.Avro.Schema as ASch +import qualified Data.Avro.Types.Value as AVal -- 'Tagged . unTagged' can be replaced by 'coerce' -- eliminating some run-time overhead -import Data.Coerce (coerce) -import qualified Data.HashMap.Strict as HM -import Data.List.NonEmpty (NonEmpty(..)) -import qualified Data.List.NonEmpty as NonEmptyList -import qualified Data.Map as M -import Data.SOP (NP(..), NS(..)) -import Data.Tagged -import qualified Data.Text as T -import qualified Data.Vector as V -import GHC.TypeLits +import Data.Coerce (coerce) +import qualified Data.HashMap.Strict as HM +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.List.NonEmpty as NonEmptyList +import qualified Data.Map as M +import Data.SOP (NP (..), NS (..)) +import Data.Tagged +import qualified Data.Text as T +import qualified Data.Vector as V +import GHC.TypeLits -import Mu.Schema +import Mu.Schema import qualified Mu.Schema.Interpretation.Schemaless as SLess instance SLess.ToSchemalessTerm (AVal.Value t) where @@ -69,7 +74,7 @@ instance HasAvroSchemas sch sch instance (HasSchema sch sty t, HasAvroSchemas sch sch, A.FromAvro (Term sch (sch :/: sty))) => A.FromAvro (WithSchema sch sty t) where fromAvro (AVal.Union _ _ v) = WithSchema . fromSchema' @sch <$> A.fromAvro v - fromAvro v = ASch.badValue v "top-level" + fromAvro v = ASch.badValue v "top-level" instance (HasSchema sch sty t, HasAvroSchemas sch sch, A.ToAvro (Term sch (sch :/: sty))) => A.ToAvro (WithSchema sch sty t) where toAvro (WithSchema v) = AVal.Union (schemas (Proxy @sch) (Proxy @sch)) @@ -164,11 +169,11 @@ instance (KnownName name, HasAvroSchemaEnum fs) instance (KnownName name, HasAvroSchemaFields sch args, FromAvroFields sch args) => A.FromAvro (Term sch ('DRecord name anns args)) where fromAvro (AVal.Record _ fields) = TRecord <$> fromAvroF fields - fromAvro v = A.badValue v "record" + fromAvro v = A.badValue v "record" instance (KnownName name, HasAvroSchemaEnum choices, FromAvroEnum choices) => A.FromAvro (Term sch ('DEnum name anns choices)) where fromAvro v@(AVal.Enum _ n _) = TEnum <$> fromAvroEnum v n - fromAvro v = A.badValue v "enum" + fromAvro v = A.badValue v "enum" instance A.FromAvro (FieldValue sch t) => A.FromAvro (Term sch ('DSimple t)) where fromAvro v = TSimple <$> A.fromAvro v @@ -184,7 +189,7 @@ instance (KnownName t, A.FromAvro (Term sch (sch :/: t))) instance (HasAvroSchemaUnion (FieldValue sch) choices, FromAvroUnion sch choices) => A.FromAvro (FieldValue sch ('TUnion choices)) where fromAvro (AVal.Union _ branch v) = FUnion <$> fromAvroU branch v - fromAvro v = A.badValue v "union" + fromAvro v = A.badValue v "union" instance A.FromAvro (FieldValue sch t) => A.FromAvro (FieldValue sch ('TOption t)) where fromAvro v = FOption <$> A.fromAvro v @@ -258,7 +263,7 @@ instance forall sch choices. toAvro (FUnion v) = AVal.Union wholeSchema' chosenTy chosenVal where wholeSchema = schemaU (Proxy @(FieldValue sch)) (Proxy @choices) wholeSchema' = V.fromList (NonEmptyList.toList wholeSchema) - (chosenTy, chosenVal) = toAvroU v + (chosenTy, chosenVal) = toAvroU v instance A.ToAvro (FieldValue sch t) => A.ToAvro (FieldValue sch ('TOption t)) where toAvro (FOption v) = A.toAvro v @@ -306,4 +311,4 @@ instance (KnownName name, A.ToAvro (FieldValue sch t), ToAvroFields sch fs) nameText :: KnownName s => proxy s -> T.Text nameText = T.pack . nameVal nameTypeName :: KnownName s => proxy s -> ASch.TypeName -nameTypeName = ASch.parseFullname . nameText \ No newline at end of file +nameTypeName = ASch.parseFullname . nameText diff --git a/adapter/avro/src/Mu/Adapter/Avro/Example.hs b/adapter/avro/src/Mu/Adapter/Avro/Example.hs index bf016a55..df3f3f73 100644 --- a/adapter/avro/src/Mu/Adapter/Avro/Example.hs +++ b/adapter/avro/src/Mu/Adapter/Avro/Example.hs @@ -3,7 +3,7 @@ module Mu.Adapter.Avro.Example where -import Mu.Quasi.Avro (avro, avroFile) +import Mu.Quasi.Avro (avro, avroFile) type Example = [avro| { diff --git a/adapter/avro/src/Mu/Quasi/Avro.hs b/adapter/avro/src/Mu/Quasi/Avro.hs index b825bd9f..3ed9b3f6 100644 --- a/adapter/avro/src/Mu/Quasi/Avro.hs +++ b/adapter/avro/src/Mu/Quasi/Avro.hs @@ -12,13 +12,13 @@ module Mu.Quasi.Avro ( , schemaFromAvroType ) where -import Data.Aeson (decode) -import qualified Data.Avro.Schema as A -import qualified Data.ByteString as B -import Data.ByteString.Lazy.Char8 (pack) +import Data.Aeson (decode) +import qualified Data.Avro.Schema as A +import qualified Data.ByteString as B +import Data.ByteString.Lazy.Char8 (pack) import Data.Int -import qualified Data.Text as T -import Data.Vector (fromList, toList) +import qualified Data.Text as T +import Data.Vector (fromList, toList) import Language.Haskell.TH import Language.Haskell.TH.Quote @@ -43,66 +43,75 @@ schemaFromAvroString s = Nothing -> fail "could not parse avro spec!" Just (A.Union us) -> schemaFromAvro (toList us) Just t -> schemaFromAvro [t] - where schemaFromAvro = (typesToList <$>) . mapM schemaDecFromAvroType . flattenAvroDecls + where + schemaFromAvro = + (typesToList <$>) . mapM schemaDecFromAvroType . flattenAvroDecls schemaDecFromAvroType :: A.Type -> Q Type schemaDecFromAvroType (A.Record name _ _ _ fields) = - [t|'DRecord $(textToStrLit $ A.baseName name) '[] $(typesToList <$> mapM avroFieldToType fields)|] - where + [t|'DRecord $(textToStrLit $ A.baseName name) '[] $(typesToList <$> + mapM + avroFieldToType + fields)|] + where avroFieldToType :: A.Field -> Q Type avroFieldToType field = - [t|'FieldDef $(textToStrLit $ A.fldName field) '[] $(schemaFromAvroType $ A.fldType field)|] + [t|'FieldDef $(textToStrLit $ A.fldName field) '[] $(schemaFromAvroType $ + A.fldType field)|] schemaDecFromAvroType (A.Enum name _ _ symbols) = - [t|'DEnum $(textToStrLit $ A.baseName name) '[] $(typesToList <$> mapM avChoiceToType (toList symbols))|] + [t|'DEnum $(textToStrLit $ A.baseName name) '[] $(typesToList <$> + mapM + avChoiceToType + (toList symbols))|] where avChoiceToType :: T.Text -> Q Type avChoiceToType c = [t|'ChoiceDef $(textToStrLit c) '[]|] -schemaDecFromAvroType t = [t| 'DSimple $(schemaFromAvroType t) |] +schemaDecFromAvroType t = [t|'DSimple $(schemaFromAvroType t)|] schemaFromAvroType :: A.Type -> Q Type -schemaFromAvroType = \case - A.Null -> [t|'TPrimitive 'TNull|] - A.Boolean -> [t|'TPrimitive Bool|] - A.Int -> [t|'TPrimitive Int32|] - A.Long -> [t|'TPrimitive Int64|] - A.Float -> [t|'TPrimitive Float|] - A.Double -> [t|'TPrimitive Double|] - A.Bytes -> [t|'TPrimitive B.ByteString|] - A.String -> [t|'TPrimitive T.Text|] - A.Array item -> [t|'TList $(schemaFromAvroType item)|] - A.Map values -> [t|'TMap T.Text $(schemaFromAvroType values)|] - A.NamedType typeName -> - [t|'TSchematic $(textToStrLit (A.baseName typeName))|] - A.Enum {} -> fail "should never happen, please, file an issue" - A.Record {} -> fail "should never happen, please, file an issue" - A.Union options -> - case toList options of - [A.Null, x] -> toOption x - [x, A.Null] -> toOption x - _ -> [t|'TUnion $(typesToList <$> mapM schemaFromAvroType (toList options))|] - where toOption x = [t|'TOption $(schemaFromAvroType x)|] - A.Fixed {} -> fail "fixed integers are not currently supported" +schemaFromAvroType = + \case + A.Null -> [t|'TPrimitive 'TNull|] + A.Boolean -> [t|'TPrimitive Bool|] + A.Int -> [t|'TPrimitive Int32|] + A.Long -> [t|'TPrimitive Int64|] + A.Float -> [t|'TPrimitive Float|] + A.Double -> [t|'TPrimitive Double|] + A.Bytes -> [t|'TPrimitive B.ByteString|] + A.String -> [t|'TPrimitive T.Text|] + A.Array item -> [t|'TList $(schemaFromAvroType item)|] + A.Map values -> [t|'TMap T.Text $(schemaFromAvroType values)|] + A.NamedType typeName -> + [t|'TSchematic $(textToStrLit (A.baseName typeName))|] + A.Enum {} -> fail "should never happen, please, file an issue" + A.Record {} -> fail "should never happen, please, file an issue" + A.Union options -> + case toList options of + [A.Null, x] -> toOption x + [x, A.Null] -> toOption x + _ -> + [t|'TUnion $(typesToList <$> mapM schemaFromAvroType (toList options))|] + where toOption x = [t|'TOption $(schemaFromAvroType x)|] + A.Fixed {} -> fail "fixed integers are not currently supported" flattenAvroDecls :: [A.Type] -> [A.Type] flattenAvroDecls = concatMap (uncurry (:) . flattenDecl) where flattenDecl :: A.Type -> (A.Type, [A.Type]) - flattenDecl (A.Record name a d o fields) = + flattenDecl (A.Record name a d o fields) = let (flds, tts) = unzip (flattenAvroField <$> fields) - in (A.Record name a d o flds, concat tts) - flattenDecl (A.Union _) = error "should never happen, please, file an issue" + in (A.Record name a d o flds, concat tts) + flattenDecl (A.Union _) = error "should never happen, please, file an issue" flattenDecl t = (t, []) - flattenAvroType :: A.Type -> (A.Type, [A.Type]) - flattenAvroType (A.Record name a d o fields) = + flattenAvroType (A.Record name a d o fields) = let (flds, tts) = unzip (flattenAvroField <$> fields) - in (A.NamedType name, A.Record name a d o flds : concat tts) - flattenAvroType (A.Union (toList -> ts)) = + in (A.NamedType name, A.Record name a d o flds : concat tts) + flattenAvroType (A.Union (toList -> ts)) = let (us, tts) = unzip (map flattenAvroType ts) - in (A.Union $ fromList us, concat tts) + in (A.Union $ fromList us, concat tts) flattenAvroType e@A.Enum {A.name} = (A.NamedType name, [e]) flattenAvroType t = (t, []) - flattenAvroField :: A.Field -> (A.Field, [A.Type]) flattenAvroField f = let (t, decs) = flattenAvroType (A.fldType f) diff --git a/adapter/avro/test/Avro.hs b/adapter/avro/test/Avro.hs index c5ee683b..6ec88438 100644 --- a/adapter/avro/test/Avro.hs +++ b/adapter/avro/test/Avro.hs @@ -1,16 +1,18 @@ -{-# language OverloadedStrings, TypeApplications, - NamedFieldPuns, DataKinds, - StandaloneDeriving, DerivingVia #-} +{-# language DataKinds #-} +{-# language DerivingVia #-} +{-# language OverloadedStrings #-} +{-# language StandaloneDeriving #-} +{-# language TypeApplications #-} {-# options_ghc -fno-warn-orphans #-} module Main where -import Data.Avro +import Data.Avro import qualified Data.ByteString.Lazy as BS -import System.Environment +import System.Environment -import Mu.Schema (WithSchema(..)) -import Mu.Adapter.Avro () -import Mu.Schema.Examples +import Mu.Adapter.Avro () +import Mu.Schema (WithSchema (..)) +import Mu.Schema.Examples exampleAddress :: Address exampleAddress = Address "1111BB" "Spain" @@ -20,19 +22,19 @@ examplePerson1 = Person "Haskellio" "Gómez" (Just 30) (Just Male) exampleAddres examplePerson2 = Person "Cuarenta" "Siete" Nothing Nothing exampleAddress deriving via (WithSchema ExampleSchema "person" Person) instance HasAvroSchema Person -deriving via (WithSchema ExampleSchema "person" Person) instance FromAvro Person -deriving via (WithSchema ExampleSchema "person" Person) instance ToAvro Person +deriving via (WithSchema ExampleSchema "person" Person) instance FromAvro Person +deriving via (WithSchema ExampleSchema "person" Person) instance ToAvro Person main :: IO () main = do -- Obtain the filenames - [genFile, conFile] <- getArgs - -- Read the file produced by Python - putStrLn "haskell/consume" - cbs <- BS.readFile conFile - let [people] = decodeContainer @Person cbs - print people - -- Encode a couple of values - putStrLn "haskell/generate" - print [examplePerson1, examplePerson2] - gbs <- encodeContainer [[examplePerson1, examplePerson2]] - BS.writeFile genFile gbs \ No newline at end of file + [genFile, conFile] <- getArgs + -- Read the file produced by Python + putStrLn "haskell/consume" + cbs <- BS.readFile conFile + let [people] = decodeContainer @Person cbs + print people + -- Encode a couple of values + putStrLn "haskell/generate" + print [examplePerson1, examplePerson2] + gbs <- encodeContainer [[examplePerson1, examplePerson2]] + BS.writeFile genFile gbs diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs index d611ac6b..c420d3f3 100644 --- a/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs @@ -1,11 +1,17 @@ -{-# language PolyKinds, DataKinds, GADTs, - TypeFamilies, TypeOperators, - MultiParamTypeClasses, - FlexibleInstances, FlexibleContexts, - ScopedTypeVariables, TypeApplications, - UndecidableInstances, - OverloadedStrings, ConstraintKinds, - AllowAmbiguousTypes #-} +{-# language AllowAmbiguousTypes #-} +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Mu.Adapter.ProtoBuf ( -- * Custom annotations @@ -23,23 +29,23 @@ module Mu.Adapter.ProtoBuf ( , parseProtoBufWithRegistry ) where -import Control.Applicative -import qualified Data.ByteString as BS -import Data.Int -import Data.Kind -import Data.SOP (All) -import qualified Data.Text as T -import qualified Data.Text.Lazy as LT -import GHC.TypeLits -import Proto3.Wire -import qualified Proto3.Wire.Encode as PBEnc -import qualified Proto3.Wire.Decode as PBDec - -import Mu.Schema.Annotations -import Mu.Schema.Definition -import Mu.Schema.Interpretation -import Mu.Schema.Class -import qualified Mu.Schema.Registry as R +import Control.Applicative +import qualified Data.ByteString as BS +import Data.Int +import Data.Kind +import Data.SOP (All) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import GHC.TypeLits +import Proto3.Wire +import qualified Proto3.Wire.Decode as PBDec +import qualified Proto3.Wire.Encode as PBEnc + +import Mu.Schema.Annotations +import Mu.Schema.Class +import Mu.Schema.Definition +import Mu.Schema.Interpretation +import qualified Mu.Schema.Registry as R type family FindProtoBufId (f :: fn) (xs :: [Type]) :: Nat where FindProtoBufId f '[] @@ -51,7 +57,7 @@ type family FindProtoBufOneOfIds (f :: fn) (xs :: [Type]) :: [Nat] where FindProtoBufOneOfIds f '[] = TypeError ('Text "protocol buffers ids not available for oneof field " ':<>: 'ShowType f) FindProtoBufOneOfIds f (ProtoBufOneOfIds n ': rest) = n - FindProtoBufOneOfIds f (other ': rest) = FindProtoBufOneOfIds f rest + FindProtoBufOneOfIds f (other ': rest) = FindProtoBufOneOfIds f rest -- CONVERSION USING SCHEMAS @@ -78,13 +84,13 @@ parseProtoViaSchema = PBDec.parse (fromProtoViaSchema @_ @_ @sch) -- CONVERSION USING REGISTRY fromProtoBufWithRegistry - :: forall (r :: R.Registry) t. + :: forall (r :: R.Registry) t. FromProtoBufRegistry r t => PBDec.Parser PBDec.RawMessage t fromProtoBufWithRegistry = fromProtoBufRegistry' (Proxy @r) parseProtoBufWithRegistry - :: forall (r :: R.Registry) t. + :: forall (r :: R.Registry) t. FromProtoBufRegistry r t => BS.ByteString -> Either PBDec.ParseError t parseProtoBufWithRegistry = PBDec.parse (fromProtoBufWithRegistry @r) @@ -148,7 +154,7 @@ instance (All (ProtoBridgeField sch) args, ProtoBridgeFields sch args) termToProto (TRecord fields) = go fields where go :: forall fs. All (ProtoBridgeField sch) fs => NP (Field sch) fs -> PBEnc.MessageBuilder - go Nil = mempty + go Nil = mempty go (f :* fs) = fieldToProto f <> go fs protoToTerm = TRecord <$> protoToFields @@ -361,4 +367,4 @@ instance ( ProtoBridgeFieldValue sch t, KnownNat thisId unionFieldValueToProto (S v) = unionFieldValueToProto @_ @_ @restIds v protoToUnionFieldValue = Z <$> protoToFieldValue `at` fieldId <|> S <$> protoToUnionFieldValue @_ @_ @restIds - where fieldId = fromInteger $ natVal (Proxy @thisId) \ No newline at end of file + where fieldId = fromInteger $ natVal (Proxy @thisId) diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs index 5ce70b0e..0271ac78 100644 --- a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs @@ -1,7 +1,8 @@ -{-# language QuasiQuotes, DataKinds #-} +{-# language DataKinds #-} +{-# language QuasiQuotes #-} module Mu.Adapter.ProtoBuf.Example where -import Mu.Quasi.ProtoBuf +import Mu.Quasi.ProtoBuf type ExampleProtoBufSchema = [protobuf| enum gender { @@ -14,4 +15,4 @@ message person { int age = 2; gender gender = 3; } -|] \ No newline at end of file +|] diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs index 9b1581ac..e7e94ba8 100644 --- a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs @@ -1,20 +1,23 @@ -{-# language PolyKinds, DataKinds, - MultiParamTypeClasses, - ScopedTypeVariables, TypeApplications, - FlexibleInstances, FlexibleContexts, - UndecidableInstances #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints -fno-warn-orphans #-} module Mu.Adapter.ProtoBuf.Via where -import Network.GRPC.HTTP2.Proto3Wire -import qualified Proto3.Wire.Encode as PBEnc -import qualified Proto3.Wire.Decode as PBDec +import Network.GRPC.HTTP2.Proto3Wire +import qualified Proto3.Wire.Decode as PBDec +import qualified Proto3.Wire.Encode as PBEnc -import Mu.Rpc -import Mu.Schema -import Mu.Adapter.ProtoBuf +import Mu.Adapter.ProtoBuf +import Mu.Rpc +import Mu.Schema -newtype ViaProtoBufTypeRef (ref :: TypeRef) t +newtype ViaProtoBufTypeRef (ref :: TypeRef) t = ViaProtoBufTypeRef { unViaProtoBufTypeRef :: t } instance ProtoBufTypeRef ref t @@ -39,4 +42,4 @@ instance ( FromProtoBufRegistry r t , HasProtoSchema (MappingRight r last) sty t) => ProtoBufTypeRef ('FromRegistry r t last) t where fromProtoBufTypeRef _ = fromProtoBufWithRegistry @r - toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @(MappingRight r last) \ No newline at end of file + toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @(MappingRight r last) diff --git a/adapter/protobuf/src/Mu/Quasi/GRpc.hs b/adapter/protobuf/src/Mu/Quasi/GRpc.hs index a4b42928..924ac752 100644 --- a/adapter/protobuf/src/Mu/Quasi/GRpc.hs +++ b/adapter/protobuf/src/Mu/Quasi/GRpc.hs @@ -1,21 +1,23 @@ -{-# language TemplateHaskell, DataKinds, OverloadedStrings #-} +{-# language DataKinds #-} +{-# language OverloadedStrings #-} +{-# language TemplateHaskell #-} -- | Read a @.proto@ file as a 'Service' module Mu.Quasi.GRpc ( grpc , compendium ) where -import Control.Monad.IO.Class -import qualified Data.Text as T -import Language.Haskell.TH -import qualified Language.ProtocolBuffers.Types as P -import Language.ProtocolBuffers.Parser -import Network.HTTP.Client -import Servant.Client.Core.BaseUrl +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 Mu.Quasi.ProtoBuf -import Mu.Rpc -import Compendium.Client +import Compendium.Client +import Mu.Quasi.ProtoBuf +import Mu.Rpc -- | Reads a @.proto@ file and generates: -- * A 'Schema' with all the message types, using the @@ -88,7 +90,7 @@ pbMethodToType s (P.Method nm vr v rr r _) = [t| 'RetStream ('FromSchema $(schemaTy s) $(textToStrLit (last a))) |] retToType _ _ = fail "only message types may be used as results" - + schemaTy :: Name -> Q Type schemaTy schema = return $ ConT schema @@ -97,4 +99,4 @@ typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT textToStrLit :: T.Text -> Q Type textToStrLit s - = return $ LitT $ StrTyLit $ T.unpack s \ No newline at end of file + = return $ LitT $ StrTyLit $ T.unpack s diff --git a/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs b/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs index ae35f49f..ff31b4c1 100644 --- a/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs +++ b/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs @@ -2,7 +2,6 @@ {-# language LambdaCase #-} {-# language NamedFieldPuns #-} {-# language TemplateHaskell #-} -{-# language ViewPatterns #-} module Mu.Quasi.ProtoBuf ( -- * Quasi-quoters for @.proto@ files @@ -83,22 +82,22 @@ pbTypeDeclToType (P.DMessage name _ _ fields _) = = [t| 'FieldDef $(textToStrLit nm) '[ ProtoBufOneOfIds $(typesToList <$> mapM (intToLit . getFieldNumber) vs ) ] $(typesToList <$> mapM pbOneOfFieldToType vs ) |] - + pbFieldTypeToType :: P.FieldType -> Q Type - pbFieldTypeToType P.TInt32 = [t|'TPrimitive Int32|] - pbFieldTypeToType P.TUInt32 = fail "unsigned integers are not currently supported" - pbFieldTypeToType P.TSInt32 = [t|'TPrimitive Int32|] - pbFieldTypeToType P.TInt64 = [t|'TPrimitive Int64|] - pbFieldTypeToType P.TUInt64 = fail "unsigned integers are not currently supported" - pbFieldTypeToType P.TSInt64 = [t|'TPrimitive Int64|] - pbFieldTypeToType P.TFixed32 = fail "fixed integers are not currently supported" - pbFieldTypeToType P.TFixed64 = fail "fixed integers are not currently supported" - pbFieldTypeToType P.TSFixed32 = fail "fixed integers are not currently supported" - pbFieldTypeToType P.TSFixed64 = fail "fixed integers are not currently supported" - pbFieldTypeToType P.TDouble = [t|'TPrimitive Double|] - pbFieldTypeToType P.TBool = [t|'TPrimitive Bool|] - pbFieldTypeToType P.TString = [t|'TPrimitive T.Text|] - pbFieldTypeToType P.TBytes = [t|'TPrimitive B.ByteString|] + pbFieldTypeToType P.TInt32 = [t|'TPrimitive Int32|] + pbFieldTypeToType P.TUInt32 = fail "unsigned integers are not currently supported" + pbFieldTypeToType P.TSInt32 = [t|'TPrimitive Int32|] + pbFieldTypeToType P.TInt64 = [t|'TPrimitive Int64|] + pbFieldTypeToType P.TUInt64 = fail "unsigned integers are not currently supported" + pbFieldTypeToType P.TSInt64 = [t|'TPrimitive Int64|] + pbFieldTypeToType P.TFixed32 = fail "fixed integers are not currently supported" + pbFieldTypeToType P.TFixed64 = fail "fixed integers are not currently supported" + pbFieldTypeToType P.TSFixed32 = fail "fixed integers are not currently supported" + pbFieldTypeToType P.TSFixed64 = fail "fixed integers are not currently supported" + pbFieldTypeToType P.TDouble = [t|'TPrimitive Double|] + pbFieldTypeToType P.TBool = [t|'TPrimitive Bool|] + pbFieldTypeToType P.TString = [t|'TPrimitive T.Text|] + pbFieldTypeToType P.TBytes = [t|'TPrimitive B.ByteString|] pbFieldTypeToType (P.TOther t) = [t|'TSchematic $(textToStrLit (last t))|] hasFieldNumber P.NormalField {} = True diff --git a/adapter/protobuf/test/ProtoBuf.hs b/adapter/protobuf/test/ProtoBuf.hs index 254ae6dc..6e81c2d2 100644 --- a/adapter/protobuf/test/ProtoBuf.hs +++ b/adapter/protobuf/test/ProtoBuf.hs @@ -1,15 +1,17 @@ -{-# language OverloadedStrings, TypeApplications, ScopedTypeVariables #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} module Main where -import qualified Data.ByteString as BS +import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS -import qualified Proto3.Wire.Decode as PBDec -import qualified Proto3.Wire.Encode as PBEnc -import System.Environment +import qualified Proto3.Wire.Decode as PBDec +import qualified Proto3.Wire.Encode as PBEnc +import System.Environment -import Mu.Schema () -import Mu.Adapter.ProtoBuf -import Mu.Schema.Examples +import Mu.Adapter.ProtoBuf +import Mu.Schema () +import Mu.Schema.Examples exampleAddress :: Address exampleAddress = Address "1111BB" "Spain" @@ -20,14 +22,14 @@ examplePerson2 = Person "Cuarenta" "Siete" Nothing Nothing exampleAddress main :: IO () main = do -- Obtain the filenames - [genFile, conFile] <- getArgs - -- Read the file produced by Python - putStrLn "haskell/consume" - cbs <- BS.readFile conFile - let Right people = PBDec.parse (fromProtoViaSchema @_ @_ @ExampleSchema) cbs - print (people :: Person) - -- Encode a couple of values - putStrLn "haskell/generate" - print examplePerson1 - let gbs = PBEnc.toLazyByteString (toProtoViaSchema @_ @_ @ExampleSchema examplePerson1) - LBS.writeFile genFile gbs \ No newline at end of file + [genFile, conFile] <- getArgs + -- Read the file produced by Python + putStrLn "haskell/consume" + cbs <- BS.readFile conFile + let Right people = PBDec.parse (fromProtoViaSchema @_ @_ @ExampleSchema) cbs + print (people :: Person) + -- Encode a couple of values + putStrLn "haskell/generate" + print examplePerson1 + let gbs = PBEnc.toLazyByteString (toProtoViaSchema @_ @_ @ExampleSchema examplePerson1) + LBS.writeFile genFile gbs diff --git a/compendium-client/compendium-client.cabal b/compendium-client/compendium-client.cabal index 3677f2c8..e623d3f6 100644 --- a/compendium-client/compendium-client.cabal +++ b/compendium-client/compendium-client.cabal @@ -12,17 +12,21 @@ maintainer: alejandro.serrano@47deg.com -- copyright: category: Network build-type: Simple --- extra-source-files: README.md, CHANGELOG.md +extra-source-files: README.md, CHANGELOG.md library exposed-modules: Compendium.Client -- other-modules: -- other-extensions: - build-depends: base >=4.12 && <5, - aeson, text, - http-client, - servant, servant-client, - megaparsec, language-protobuf + build-depends: base >=4.12 && <5 + , aeson + , text + , http-client + , servant + , servant-client + , megaparsec + , language-protobuf hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall -fprint-potential-instances \ No newline at end of file + ghc-options: -Wall + -fprint-potential-instances diff --git a/compendium-client/src/Compendium/Client.hs b/compendium-client/src/Compendium/Client.hs index d26bf4dc..410385bb 100644 --- a/compendium-client/src/Compendium/Client.hs +++ b/compendium-client/src/Compendium/Client.hs @@ -1,30 +1,33 @@ -{-# language DataKinds, TypeOperators, - DeriveGeneric, DeriveAnyClass, - ViewPatterns, TypeApplications #-} +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language ViewPatterns #-} module Compendium.Client where -import Data.Aeson -import Data.Char -import Data.Proxy -import Data.Text -import Language.ProtocolBuffers.Types -import Language.ProtocolBuffers.Parser -import Network.HTTP.Client (Manager) -import Servant.API -import Servant.Client -import Text.Megaparsec +import Data.Aeson +import Data.Char +import Data.Proxy +import Data.Text +import Language.ProtocolBuffers.Parser +import Language.ProtocolBuffers.Types +import Network.HTTP.Client (Manager) +import Servant.API +import Servant.Client +import Text.Megaparsec -import GHC.Generics +import GHC.Generics newtype Protocol = Protocol { raw :: Text } deriving (Eq, Show, Generic, FromJSON) - + data IdlName = Avro | Protobuf | Mu | OpenApi | Scala deriving (Eq, Show, Generic) instance ToHttpApiData IdlName where - toQueryParam (show -> x:xs) + toQueryParam (show -> x:xs) = pack $ Data.Char.toLower x : xs toQueryParam _ = error "this should never happen" @@ -50,12 +53,12 @@ data ObtainProtoBufError obtainProtoBuf :: Manager -> BaseUrl -> Text -> IO (Either ObtainProtoBufError ProtoBuf) -obtainProtoBuf m url ident - = do r <- transformation m url ident Protobuf - case r of - Left e - -> return $ Left (OPEClient e) - Right (Protocol p) - -> case parseProtoBuf p of - Left e -> return $ Left (OPEParse e) - Right pb -> return $ Right pb \ No newline at end of file +obtainProtoBuf m url ident = do + r <- transformation m url ident Protobuf + case r of + Left e + -> return $ Left (OPEClient e) + Right (Protocol p) + -> case parseProtoBuf p of + Left e -> return $ Left (OPEParse e) + Right pb -> return $ Right pb diff --git a/core/rpc/src/Mu/Rpc.hs b/core/rpc/src/Mu/Rpc.hs index 6e0beeb9..6dfa12c7 100644 --- a/core/rpc/src/Mu/Rpc.hs +++ b/core/rpc/src/Mu/Rpc.hs @@ -1,8 +1,11 @@ -{-# language DataKinds, PolyKinds, - GADTs, ExistentialQuantification, - TypeFamilies, ConstraintKinds, - TypeOperators, - UndecidableInstances #-} +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language ExistentialQuantification #-} +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} -- | Protocol-independent declaration of services module Mu.Rpc ( Service', Service(..) @@ -11,12 +14,12 @@ module Mu.Rpc ( , TypeRef(..), Argument(..), Return(..) ) where -import Data.Kind -import GHC.TypeLits +import Data.Kind +import GHC.TypeLits import qualified Language.Haskell.TH as TH -import Mu.Schema -import Mu.Schema.Registry +import Mu.Schema +import Mu.Schema.Registry type Service' = Service Symbol Symbol @@ -74,4 +77,4 @@ data Return where RetThrows :: TypeRef -> TypeRef -> Return -- | Return a stream of values -- (this can be found in gRPC). - RetStream :: TypeRef -> Return \ No newline at end of file + RetStream :: TypeRef -> Return diff --git a/core/rpc/src/Mu/Rpc/Examples.hs b/core/rpc/src/Mu/Rpc/Examples.hs index 0ae69f44..7e1876d2 100644 --- a/core/rpc/src/Mu/Rpc/Examples.hs +++ b/core/rpc/src/Mu/Rpc/Examples.hs @@ -1,19 +1,25 @@ -{-# language PolyKinds, DataKinds, GADTs, - MultiParamTypeClasses, - FlexibleInstances, OverloadedStrings, - DeriveGeneric, DeriveAnyClass, TypeOperators, - PartialTypeSignatures, TypeFamilies #-} +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language PolyKinds #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Mu.Rpc.Examples where -import Data.Conduit -import Data.Conduit.Combinators as C -import qualified Data.Text as T -import GHC.Generics +import Data.Conduit +import Data.Conduit.Combinators as C +import qualified Data.Text as T +import GHC.Generics -import Mu.Schema -import Mu.Rpc -import Mu.Server +import Mu.Rpc +import Mu.Schema +import Mu.Server -- Defines the service from gRPC Quickstart -- https://grpc.io/docs/quickstart/python/ @@ -59,4 +65,4 @@ quickstartServer -> ConduitT HelloResponse Void IO () -> IO () sayManyHellos source sink - = runConduit $ source .| C.mapM sayHello .| sink \ No newline at end of file + = runConduit $ source .| C.mapM sayHello .| sink diff --git a/core/rpc/src/Mu/Server.hs b/core/rpc/src/Mu/Server.hs index 3bd2f870..8e8fbc87 100644 --- a/core/rpc/src/Mu/Server.hs +++ b/core/rpc/src/Mu/Server.hs @@ -1,12 +1,14 @@ -{-# language DataKinds, PolyKinds, - GADTs, TypeFamilies, - ExistentialQuantification, - MultiParamTypeClasses, - FlexibleInstances, - UndecidableInstances, - TypeOperators, - ConstraintKinds, - RankNTypes #-} +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language ExistentialQuantification #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} -- | Protocol-independent declaration of servers. -- -- A server (represented by 'ServerIO' and in general @@ -29,11 +31,11 @@ module Mu.Server ( , HandlersIO, HandlersT(..) ) where -import Data.Conduit -import Data.Kind +import Data.Conduit +import Data.Kind -import Mu.Rpc -import Mu.Schema +import Mu.Rpc +import Mu.Schema data ServerT (s :: Service snm mnm) (m :: Type -> Type) (hs :: [Type]) where Server :: HandlersT methods m hs -> ServerT ('Service sname anns methods) m hs @@ -67,4 +69,4 @@ instance (HandlesRef eref e, HandlesRef vref v, handler ~ m (Either e v)) instance (HandlesRef ref v, handler ~ m v) => Handles '[] ('RetSingle ref) m handler instance (HandlesRef ref v, handler ~ (ConduitT v Void m () -> m ())) - => Handles '[] ('RetStream ref) m handler \ No newline at end of file + => Handles '[] ('RetStream ref) m handler diff --git a/core/schema/src/Mu/Adapter/Json.hs b/core/schema/src/Mu/Adapter/Json.hs index f9b27292..a3be8028 100644 --- a/core/schema/src/Mu/Adapter/Json.hs +++ b/core/schema/src/Mu/Adapter/Json.hs @@ -1,22 +1,26 @@ -{-# language PolyKinds, DataKinds, GADTs, - TypeOperators, ScopedTypeVariables, - MultiParamTypeClasses, - FlexibleInstances, FlexibleContexts, - TypeApplications, - UndecidableInstances #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Mu.Adapter.Json where -import Control.Applicative ((<|>)) -import Data.Aeson -import Data.Aeson.Types -import Data.Functor.Contravariant -import qualified Data.HashMap.Strict as HM -import Data.SOP (NS(..), NP(..)) -import qualified Data.Text as T -import qualified Data.Vector as V +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.Aeson.Types +import Data.Functor.Contravariant +import qualified Data.HashMap.Strict as HM +import Data.SOP (NP (..), NS (..)) +import qualified Data.Text as T +import qualified Data.Vector as V -import Mu.Schema +import Mu.Schema import qualified Mu.Schema.Interpretation.Schemaless as SLess instance SLess.ToSchemalessTerm Value where @@ -46,7 +50,7 @@ instance ToJSONFields sch args => ToJSON (Term sch ('DRecord name anns args)) wh toJSON (TRecord fields) = Object (toJSONFields fields) instance FromJSONFields sch args => FromJSON (Term sch ('DRecord name anns args)) where parseJSON (Object v) = TRecord <$> parseJSONFields v - parseJSON _ = fail "expected object" + parseJSON _ = fail "expected object" class ToJSONFields sch fields where toJSONFields :: NP (Field sch) fields -> Object @@ -71,7 +75,7 @@ instance ToJSONEnum choices => ToJSON (Term sch ('DEnum name anns choices)) wher toJSON (TEnum choice) = String (toJSONEnum choice) instance FromJSONEnum choices => FromJSON (Term sch ('DEnum name anns choices)) where parseJSON (String s) = TEnum <$> parseJSONEnum s - parseJSON _ = fail "expected string" + parseJSON _ = fail "expected string" class ToJSONEnum choices where toJSONEnum :: NS Proxy choices -> T.Text @@ -132,7 +136,7 @@ instance (ToJSON (FieldValue sch u), ToJSONUnion sch us) instance FromJSON (FieldValue sch 'TNull) where parseJSON Null = return FNull - parseJSON _ = fail "expected null" + parseJSON _ = fail "expected null" instance FromJSON t => FromJSON (FieldValue sch ('TPrimitive t)) where parseJSON v = FPrimitive <$> parseJSON v instance FromJSONKey t => FromJSONKey (FieldValue sch ('TPrimitive t)) where @@ -161,4 +165,4 @@ instance FromJSONUnion sch '[] where unionFromJSON _ = fail "value does not match any of the types of the union" instance (FromJSON (FieldValue sch u), FromJSONUnion sch us) => FromJSONUnion sch (u ': us) where - unionFromJSON v = Z <$> parseJSON v <|> S <$> unionFromJSON v \ No newline at end of file + unionFromJSON v = Z <$> parseJSON v <|> S <$> unionFromJSON v diff --git a/core/schema/src/Mu/Schema.hs b/core/schema/src/Mu/Schema.hs index 09b96cb0..190ba0d3 100644 --- a/core/schema/src/Mu/Schema.hs +++ b/core/schema/src/Mu/Schema.hs @@ -1,4 +1,4 @@ -{-# language DataKinds #-} +{-# language DataKinds #-} -- | Schemas for Mu microservices module Mu.Schema ( -- * Schema definition @@ -21,7 +21,7 @@ module Mu.Schema ( , ProtoBufId, ProtoBufOneOfIds ) where -import Mu.Schema.Annotations -import Mu.Schema.Definition -import Mu.Schema.Interpretation -import Mu.Schema.Class \ No newline at end of file +import Mu.Schema.Annotations +import Mu.Schema.Class +import Mu.Schema.Definition +import Mu.Schema.Interpretation diff --git a/core/schema/src/Mu/Schema/Annotations.hs b/core/schema/src/Mu/Schema/Annotations.hs index 7b048a36..d7e9fe75 100644 --- a/core/schema/src/Mu/Schema/Annotations.hs +++ b/core/schema/src/Mu/Schema/Annotations.hs @@ -1,9 +1,10 @@ -{-# language DataKinds, KindSignatures #-} +{-# language DataKinds #-} +{-# language KindSignatures #-} module Mu.Schema.Annotations where -import GHC.TypeLits +import GHC.TypeLits -- ANNOTATION FOR CONVERSION data ProtoBufId (n :: Nat) -data ProtoBufOneOfIds (ns :: [Nat]) \ No newline at end of file +data ProtoBufOneOfIds (ns :: [Nat]) diff --git a/core/schema/src/Mu/Schema/Class.hs b/core/schema/src/Mu/Schema/Class.hs index c4ab1741..510967f9 100644 --- a/core/schema/src/Mu/Schema/Class.hs +++ b/core/schema/src/Mu/Schema/Class.hs @@ -1,24 +1,30 @@ -{-# language PolyKinds, DataKinds, GADTs, - TypeFamilies, TypeOperators, - FunctionalDependencies, - FlexibleInstances, FlexibleContexts, - TypeApplications, ScopedTypeVariables, - UndecidableInstances, - DefaultSignatures #-} +{-# language DataKinds #-} +{-# language DefaultSignatures #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} -- | Conversion from types to schemas module Mu.Schema.Class ( WithSchema(..), HasSchema(..), fromSchema', toSchema' , Mapping(..), Mappings, MappingRight, MappingLeft ) where -import Data.Kind -import Data.Map as M -import Data.SOP -import GHC.Generics -import GHC.TypeLits +import Data.Kind +import Data.Map as M +import Data.SOP +import GHC.Generics +import GHC.TypeLits -import Mu.Schema.Definition -import Mu.Schema.Interpretation +import Mu.Schema.Definition +import Mu.Schema.Interpretation -- | Tags a value with its schema. -- For usage with @deriving via@. @@ -126,7 +132,7 @@ instance {-# OVERLAPPABLE #-} -- This instance removes unneeded metadata from the -- top of the type. instance {-# OVERLAPS #-} - GSchemaTypeDef sch fmap ('DSimple t) f + GSchemaTypeDef sch fmap ('DSimple t) f => GSchemaTypeDef sch fmap ('DSimple t) (D1 meta f) where toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) @@ -160,7 +166,7 @@ instance (GSchemaFieldType sch sk hk, GSchemaFieldType sch sv hv, Ord (FieldValue sch sk), Ord hk) -- Ord is required to build a map => GSchemaFieldType sch ('TMap sk sv) (M.Map hk hv) where toSchemaFieldType x = FMap (M.mapKeys toSchemaFieldType (M.map toSchemaFieldType x)) - fromSchemaFieldType (FMap x) = M.mapKeys fromSchemaFieldType (M.map fromSchemaFieldType x) + fromSchemaFieldType (FMap x) = M.mapKeys fromSchemaFieldType (M.map fromSchemaFieldType x) -- This assumes that a union is represented by -- a value of type 'NS', where types are in -- the same order. @@ -173,7 +179,7 @@ instance AllZip (GSchemaFieldType sch) ts vs go (S n) = S (go n) fromSchemaFieldType (FUnion t) = go t where go :: AllZip (GSchemaFieldType sch) tss vss - => NS (FieldValue sch) tss -> NS I vss + => NS (FieldValue sch) tss -> NS I vss go (Z x) = Z (I (fromSchemaFieldType x)) go (S n) = S (go n) @@ -189,7 +195,7 @@ instance {-# OVERLAPPABLE #-} -- This instance removes unneeded metadata from the -- top of the type. instance {-# OVERLAPS #-} - GSchemaTypeDef sch fmap ('DEnum name anns choices) f + GSchemaTypeDef sch fmap ('DEnum name anns choices) f => GSchemaTypeDef sch fmap ('DEnum name anns choices) (D1 meta f) where toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) @@ -261,12 +267,12 @@ instance {-# OVERLAPPABLE #-} -- This instance removes unneeded metadata from the -- top of the type. instance {-# OVERLAPS #-} - GSchemaTypeDef sch fmap ('DRecord name anns args) f + GSchemaTypeDef sch fmap ('DRecord name anns args) f => GSchemaTypeDef sch fmap ('DRecord name anns args) (D1 meta f) where toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) instance {-# OVERLAPS #-} - GSchemaTypeDef sch fmap ('DRecord name anns args) f + GSchemaTypeDef sch fmap ('DRecord name anns args) f => GSchemaTypeDef sch fmap ('DRecord name anns args) (C1 meta f) where toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) @@ -297,7 +303,7 @@ instance ( GToSchemaRecord sch fmap cs f class GToSchemaRecordSearch (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) (w :: Where) where toSchemaRecordSearch :: Proxy w -> f a -> FieldValue sch t -instance GSchemaFieldType sch t v +instance GSchemaFieldType sch t v => GToSchemaRecordSearch sch t (S1 m (K1 i v)) 'Here where toSchemaRecordSearch _ (M1 (K1 x)) = toSchemaFieldType x instance GSchemaFieldType sch t v @@ -341,4 +347,4 @@ instance GSchemaFieldType sch t v => GFromSchemaRecordSearch sch v ('FieldDef na instance forall sch v other rest n. GFromSchemaRecordSearch sch v rest n => GFromSchemaRecordSearch sch v (other ': rest) ('There n) where - fromSchemaRecordSearch _ (_ :* xs) = fromSchemaRecordSearch (Proxy @n) xs \ No newline at end of file + fromSchemaRecordSearch _ (_ :* xs) = fromSchemaRecordSearch (Proxy @n) xs diff --git a/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs b/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs index ea0b5243..0f50f112 100644 --- a/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs +++ b/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs @@ -1,20 +1,23 @@ -{-# language CPP, TemplateHaskell, TypeOperators, DataKinds #-} +{-# language CPP #-} +{-# language DataKinds #-} +{-# language TemplateHaskell #-} +{-# language TypeOperators #-} -- | Generate a set of Haskell types from a 'Schema'. module Mu.Schema.Conversion.SchemaToTypes ( generateTypesFromSchema , Namer ) where -import Control.Applicative -import Data.Char -import qualified Data.Map as M -import Data.SOP -import GHC.Generics (Generic) -import Language.Haskell.TH -import Language.Haskell.TH.Datatype +import Control.Applicative +import Data.Char +import qualified Data.Map as M +import Data.SOP +import GHC.Generics (Generic) +import Language.Haskell.TH +import Language.Haskell.TH.Datatype -import Mu.Schema.Definition -import Mu.Schema.Class +import Mu.Schema.Class +import Mu.Schema.Definition -- | Generate the name from each new Haskell type -- from the name given in the schema. @@ -141,11 +144,11 @@ fieldName :: String -> String -> String fieldName complete fname = firstLower (complete ++ firstUpper fname) firstUpper :: String -> String -firstUpper [] = error "Empty names are not allowed" +firstUpper [] = error "Empty names are not allowed" firstUpper (x:rest) = toUpper x : rest firstLower :: String -> String -firstLower [] = error "Empty names are not allowed" +firstLower [] = error "Empty names are not allowed" firstLower (x:rest) = toLower x : rest fieldTypeToDecl :: Namer -> FieldTypeB Type String -> Type @@ -180,8 +183,8 @@ typeToSchemaDef toplevelty typeToSchemaDef' expanded = do types <- tyList expanded mapM typeToTypeDef types - - typeToTypeDef, typeToRecordDef, typeToEnumDef, typeToSimpleType + + typeToTypeDef, typeToRecordDef, typeToEnumDef, typeToSimpleType :: Type -> Maybe (TypeDefB Type String String) typeToTypeDef t = typeToRecordDef t <|> typeToEnumDef t <|> typeToSimpleType t @@ -269,4 +272,4 @@ tyD3 name (SigT t _) = tyD3 name t tyD3 name (AppT (AppT (AppT (PromotedT c) x) y) z) | c == name = Just (x, y, z) | otherwise = Nothing -tyD3 _ _ = Nothing \ No newline at end of file +tyD3 _ _ = Nothing diff --git a/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs b/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs index 6740d925..fabb0aa7 100644 --- a/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs +++ b/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs @@ -1,8 +1,10 @@ -{-# language PolyKinds, DataKinds, TypeFamilies, - TypeOperators, - UndecidableInstances #-} +{-# language DataKinds #-} +{-# language PolyKinds #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} -- | Obtains a 'Schema' from a set of Haskell types. --- +-- -- Unfortunately, GHC does not allow type families -- to appear in instances, so you cannot use the -- resulting type directly. Instead, evaluate it @@ -14,13 +16,13 @@ module Mu.Schema.Conversion.TypesToSchema ( , FromTypes, FromType(..) ) where -import Data.Kind -import Data.Map as M -import Data.SOP -import GHC.Generics -import GHC.TypeLits +import Data.Kind +import Data.Map as M +import Data.SOP +import GHC.Generics +import GHC.TypeLits -import Mu.Schema.Definition +import Mu.Schema.Definition type FromTypes = [FromType Symbol Symbol] data FromType tn fn @@ -101,4 +103,4 @@ type family ChoicesFromType (all :: [FromType tn fn]) (mp :: Mappings Symbol fn) ChoicesFromType all mp (C1 ('MetaCons cname p s) f) = TypeError ('Text "constructor " ':<>: 'ShowType cname ':<>: 'Text "has fields and cannot be turned into an enumeration schema") ChoicesFromType all mp v - = TypeError ('Text "unsupported conversion from " ':<>: 'ShowType v ':<>: 'Text " to enumeration schema") \ No newline at end of file + = TypeError ('Text "unsupported conversion from " ':<>: 'ShowType v ':<>: 'Text " to enumeration schema") diff --git a/core/schema/src/Mu/Schema/Definition.hs b/core/schema/src/Mu/Schema/Definition.hs index 53699b49..65d30941 100644 --- a/core/schema/src/Mu/Schema/Definition.hs +++ b/core/schema/src/Mu/Schema/Definition.hs @@ -1,14 +1,18 @@ -{-# language PolyKinds, DataKinds, - TypeFamilies, TypeOperators, - UndecidableInstances, FlexibleInstances, - ScopedTypeVariables, TypeApplications #-} +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} -- | Schema definition module Mu.Schema.Definition where -import Data.Kind -import Data.Proxy -import Data.Typeable -import GHC.TypeLits +import Data.Kind +import Data.Proxy +import Data.Typeable +import GHC.TypeLits -- | A set of type definitions, -- where the names of types and fields are @@ -40,7 +44,7 @@ type SchemaB builtin typeName fieldName = [TypeDefB builtin typeName fieldName] -- | Libraries can define custom annotations --- to indicate additional information. +-- to indicate additional information. type Annotation = Type -- | Defines a type in a schema. @@ -167,4 +171,4 @@ instance ReflectFieldTypes '[] where reflectFieldTypes _ = [] instance (ReflectFieldType t, ReflectFieldTypes ts) => ReflectFieldTypes (t ': ts) where - reflectFieldTypes _ = reflectFieldType (Proxy @t) : reflectFieldTypes (Proxy @ts) \ No newline at end of file + reflectFieldTypes _ = reflectFieldType (Proxy @t) : reflectFieldTypes (Proxy @ts) diff --git a/core/schema/src/Mu/Schema/Examples.hs b/core/schema/src/Mu/Schema/Examples.hs index f1008216..90d2bf3b 100644 --- a/core/schema/src/Mu/Schema/Examples.hs +++ b/core/schema/src/Mu/Schema/Examples.hs @@ -1,23 +1,30 @@ -{-# language PolyKinds, DataKinds, GADTs, - TypeFamilies, TypeOperators, - MultiParamTypeClasses, FlexibleInstances, - TypeApplications, - DeriveGeneric, DerivingVia, DeriveAnyClass, - TemplateHaskell, QuasiQuotes #-} +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingVia #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language QuasiQuotes #-} +{-# language TemplateHaskell #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} -- | Look at my source code! module Mu.Schema.Examples where -import qualified Data.Aeson as J -import qualified Data.Text as T -import GHC.Generics +import qualified Data.Aeson as J +import qualified Data.Text as T +import GHC.Generics -import Mu.Schema -import Mu.Schema.Conversion.SchemaToTypes -import Mu.Adapter.Json () +import Mu.Adapter.Json () +import Mu.Schema +import Mu.Schema.Conversion.SchemaToTypes data Person = Person { firstName :: T.Text - , lastName :: T.Text + , lastName :: T.Text , age :: Maybe Int , gender :: Maybe Gender , address :: Address } @@ -90,4 +97,4 @@ type ExampleSchema2 ] type ExampleRegistry - = '[ 2 ':-> ExampleSchema2, 1 ':-> ExampleSchema] \ No newline at end of file + = '[ 2 ':-> ExampleSchema2, 1 ':-> ExampleSchema] diff --git a/core/schema/src/Mu/Schema/Interpretation.hs b/core/schema/src/Mu/Schema/Interpretation.hs index f4de32f4..c12cd91d 100644 --- a/core/schema/src/Mu/Schema/Interpretation.hs +++ b/core/schema/src/Mu/Schema/Interpretation.hs @@ -1,19 +1,24 @@ -{-# language PolyKinds, DataKinds, GADTs, - TypeFamilies, TypeOperators, - FlexibleInstances, FlexibleContexts, - TypeApplications, ScopedTypeVariables, - UndecidableInstances #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} -- | Interpretation of schemas module Mu.Schema.Interpretation ( Term(..), Field(..), FieldValue(..) , NS(..), NP(..), Proxy(..) ) where -import Data.Map -import Data.Proxy -import Data.SOP - -import Mu.Schema.Definition +import Data.Map +import Data.Proxy +import Data.SOP + +import Mu.Schema.Definition -- | Interpretation of a type in a schema. data Term (sch :: Schema typeName fieldName) (t :: TypeDef typeName fieldName) where diff --git a/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs b/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs index 46258d3e..857017bd 100644 --- a/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs +++ b/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs @@ -1,14 +1,17 @@ -{-# language PolyKinds, DataKinds, GADTs, - TypeOperators, - MultiParamTypeClasses, - FlexibleInstances, FlexibleContexts, - UndecidableInstances, - StandaloneDeriving #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language StandaloneDeriving #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} module Mu.Schema.Interpretation.Anonymous where -import Data.SOP +import Data.SOP -import Mu.Schema +import Mu.Schema data V0 sch sty where V0 :: (sch :/: sty ~ 'DRecord nm anns '[]) @@ -67,4 +70,4 @@ instance (sch :/: sty ~ 'DRecord nm anns '[ 'FieldDef f fanns ('TPrimitive a) , 'FieldDef g ganns ('TPrimitive b) ]) => HasSchema sch sty (V2 sch sty) where toSchema (V2 x y) = TRecord (Field (FPrimitive x) :* Field (FPrimitive y) :* Nil) - fromSchema (TRecord (Field (FPrimitive x) :* Field (FPrimitive y) :* Nil)) = V2 x y \ No newline at end of file + fromSchema (TRecord (Field (FPrimitive x) :* Field (FPrimitive y) :* Nil)) = V2 x y diff --git a/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs b/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs index 6e5ef427..cce37a4c 100644 --- a/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs +++ b/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs @@ -1,9 +1,15 @@ -{-# language PolyKinds, DataKinds, GADTs, - ScopedTypeVariables, - TypeApplications, TypeOperators, - FlexibleContexts, MultiParamTypeClasses, - AllowAmbiguousTypes, StandaloneDeriving, - FlexibleInstances, UndecidableInstances #-} +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneDeriving #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} module Mu.Schema.Interpretation.Schemaless ( -- * Terms without an associated schema Term(..), Field(..), FieldValue(..) @@ -13,16 +19,16 @@ module Mu.Schema.Interpretation.Schemaless ( , ToSchemalessTerm(..), ToSchemalessValue(..) ) where -import Control.Applicative ((<|>)) -import Data.List (find) -import qualified Data.Map as M -import Data.Proxy -import Data.SOP -import qualified Data.Text as T -import Data.Typeable +import Control.Applicative ((<|>)) +import Data.List (find) +import qualified Data.Map as M +import Data.Proxy +import Data.SOP +import qualified Data.Text as T +import Data.Typeable -import Mu.Schema.Class -import Mu.Schema.Definition +import Mu.Schema.Class +import Mu.Schema.Definition import qualified Mu.Schema.Interpretation as S -- | Interpretation of a type in a schema. @@ -77,7 +83,7 @@ class CheckSchemaUnion (s :: Schema tn fn) (ts :: [FieldType tn]) where instance CheckSchemaFields s fields => CheckSchema s ('DRecord nm anns fields) where checkSchema' (TRecord fields) = S.TRecord <$> checkSchemaFields fields - checkSchema' _ = Nothing + checkSchema' _ = Nothing instance CheckSchemaFields s '[] where checkSchemaFields _ = pure Nil instance (KnownName nm, CheckSchemaValue s ty, CheckSchemaFields s rest) @@ -96,7 +102,7 @@ instance CheckSchemaEnum choices => CheckSchema s ('DEnum nm anns choices) where (Just Refl, _, _) -> S.TEnum <$> checkSchemaEnumInt n (_, Just Refl, _) -> S.TEnum <$> checkSchemaEnumText n (_, _, Just Refl) -> S.TEnum <$> checkSchemaEnumText (T.pack n) - _ -> Nothing + _ -> Nothing checkSchema' _ = Nothing instance CheckSchemaEnum '[] where checkSchemaEnumInt _ = Nothing @@ -125,7 +131,7 @@ instance Typeable t => CheckSchemaValue s ('TPrimitive t) where instance (CheckSchema s (s :/: t)) => CheckSchemaValue s ('TSchematic t) where checkSchemaValue (FSchematic t) = S.FSchematic <$> checkSchema' t - checkSchemaValue _ = Nothing + checkSchemaValue _ = Nothing instance CheckSchemaValue s t => CheckSchemaValue s ('TOption t) where checkSchemaValue (FOption x) = S.FOption <$> traverse checkSchemaValue x checkSchemaValue _ = Nothing @@ -184,4 +190,4 @@ instance Ord FieldValue where FMap _ <= FOption _ = False FMap _ <= FList _ = False FMap x <= FMap y = x <= y - -- FMap _ <= _ = True \ No newline at end of file + -- FMap _ <= _ = True diff --git a/core/schema/src/Mu/Schema/Registry.hs b/core/schema/src/Mu/Schema/Registry.hs index c80a7bbc..283c79af 100644 --- a/core/schema/src/Mu/Schema/Registry.hs +++ b/core/schema/src/Mu/Schema/Registry.hs @@ -1,8 +1,14 @@ -{-# language PolyKinds, DataKinds, TypeFamilies, - ScopedTypeVariables, MultiParamTypeClasses, - FlexibleInstances, FlexibleContexts, - TypeOperators, UndecidableInstances, - TypeApplications, AllowAmbiguousTypes #-} +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} module Mu.Schema.Registry ( -- * Registry of schemas Registry, fromRegistry @@ -10,18 +16,18 @@ module Mu.Schema.Registry ( , SLess.Term(..), SLess.Field(..), SLess.FieldValue(..) ) where -import Data.Proxy -import Data.Kind -import Control.Applicative -import GHC.TypeLits +import Control.Applicative +import Data.Kind +import Data.Proxy +import GHC.TypeLits -import Mu.Schema.Definition -import Mu.Schema.Class +import Mu.Schema.Class +import Mu.Schema.Definition import qualified Mu.Schema.Interpretation.Schemaless as SLess type Registry = Mappings Nat Schema' -fromRegistry :: forall r t. +fromRegistry :: forall r t. FromRegistry r t => SLess.Term -> Maybe t fromRegistry = fromRegistry' (Proxy @r) @@ -33,4 +39,4 @@ instance FromRegistry '[] t where fromRegistry' _ _ = Nothing instance (HasSchema s sty t, SLess.CheckSchema s (s :/: sty), FromRegistry ms t) => FromRegistry ( (n ':-> s) ': ms) t where - fromRegistry' _ t = SLess.fromSchemalessTerm @s t <|> fromRegistry' (Proxy @ms) t \ No newline at end of file + fromRegistry' _ t = SLess.fromSchemalessTerm @s t <|> fromRegistry' (Proxy @ms) t diff --git a/examples/deployment/docker/Main.hs b/examples/deployment/docker/Main.hs index d38a2c83..fb01b27a 100644 --- a/examples/deployment/docker/Main.hs +++ b/examples/deployment/docker/Main.hs @@ -1,10 +1,10 @@ {-# language OverloadedStrings #-} module Main where -import Mu.Server.GRpc -import Mu.Rpc.Examples +import Mu.Rpc.Examples +import Mu.Server.GRpc main :: IO () -main = do +main = do putStrLn "running quickstart application" - runGRpcApp 8080 quickstartServer \ No newline at end of file + runGRpcApp 8080 quickstartServer diff --git a/examples/health-check/src/ClientRecord.hs b/examples/health-check/src/ClientRecord.hs index 2a74b228..fd109e3d 100644 --- a/examples/health-check/src/ClientRecord.hs +++ b/examples/health-check/src/ClientRecord.hs @@ -1,70 +1,72 @@ -{-# language DataKinds, ScopedTypeVariables, - TypeOperators, OverloadedStrings, - FlexibleContexts, AllowAmbiguousTypes, - DeriveGeneric, TypeApplications #-} +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language DeriveGeneric #-} +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} module Main where -import Data.Conduit +import Data.Conduit import qualified Data.Conduit.Combinators as C -import qualified Data.Text as T -import GHC.Generics (Generic) -import System.Environment +import qualified Data.Text as T +import GHC.Generics (Generic) +import System.Environment -import Mu.GRpc.Client.Record +import Mu.GRpc.Client.Record -import Definition +import Definition -data HealthCall - = HealthCall - { setStatus :: HealthStatusMsg -> IO (GRpcReply ()) - , check :: HealthCheckMsg -> IO (GRpcReply ServerStatusMsg) - , clearStatus :: HealthCheckMsg -> IO (GRpcReply ()) - , checkAll :: IO (GRpcReply AllStatusMsg) - , cleanAll :: IO (GRpcReply ()) - , watch :: HealthCheckMsg -> IO (ConduitT () (GRpcReply ServerStatusMsg) IO ()) } - deriving (Generic) +data HealthCall = HealthCall + { setStatus :: HealthStatusMsg -> IO (GRpcReply ()) + , check :: HealthCheckMsg -> IO (GRpcReply ServerStatusMsg) + , clearStatus :: HealthCheckMsg -> IO (GRpcReply ()) + , checkAll :: IO (GRpcReply AllStatusMsg) + , cleanAll :: IO (GRpcReply ()) + , watch :: HealthCheckMsg -> IO (ConduitT () (GRpcReply ServerStatusMsg) IO ()) + } deriving (Generic) buildHealthCall :: GrpcClient -> HealthCall buildHealthCall = buildService @HealthCheckService @"" main :: IO () -main - = do -- Setup the client - let config = grpcClientConfigSimple "127.0.0.1" 8080 False - Right grpcClient <- setupGrpcClient' config - let client = buildHealthCall grpcClient - -- Execute command - args <- getArgs - case args of - ["watch" , who] -> watching client who - ["simple", who] -> simple client who - ["update", who] -> update client who "SERVING" - ["update", who, newstatus] -> update client who newstatus - _ -> putStrLn "unknown command" +main = do -- Setup the client + let config = grpcClientConfigSimple "127.0.0.1" 8080 False + Right grpcClient <- setupGrpcClient' config + let client = buildHealthCall grpcClient + -- Execute command + args <- getArgs + case args of + ["watch" , who] -> watching client who + ["simple", who] -> simple client who + ["update", who] -> update client who "SERVING" + ["update", who, newstatus] -> update client who newstatus + _ -> putStrLn "unknown command" simple :: HealthCall -> String -> IO () -simple client who - = do let hcm = HealthCheckMsg (T.pack who) - putStrLn ("UNARY: Is there some server named " <> who <> "?") - rknown <- check client hcm - putStrLn ("UNARY: Actually the status is " <> show rknown) - update client who "SERVING" - r <- clearStatus client hcm - putStrLn ("UNARY: Was clearing successful? " <> show r) - runknown <- check client hcm - putStrLn ("UNARY: Current status of " <> who <> ": " <> show runknown) +simple client who = do + let hcm = HealthCheckMsg (T.pack who) + putStrLn ("UNARY: Is there some server named " <> who <> "?") + rknown <- check client hcm + putStrLn ("UNARY: Actually the status is " <> show rknown) + update client who "SERVING" + r <- clearStatus client hcm + putStrLn ("UNARY: Was clearing successful? " <> show r) + runknown <- check client hcm + putStrLn ("UNARY: Current status of " <> who <> ": " <> show runknown) update :: HealthCall -> String -> String -> IO () -update client who newstatus - = do let hcm = HealthCheckMsg (T.pack who) - putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus) - r <- setStatus client (HealthStatusMsg hcm (ServerStatusMsg (T.pack newstatus))) - putStrLn ("UNARY: Was setting successful? " <> show r) - rstatus <- check client hcm - putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus) +update client who newstatus = do + let hcm = HealthCheckMsg (T.pack who) + putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus) + r <- setStatus client (HealthStatusMsg hcm (ServerStatusMsg (T.pack newstatus))) + putStrLn ("UNARY: Was setting successful? " <> show r) + rstatus <- check client hcm + putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus) watching :: HealthCall -> String -> IO () -watching client who - = do let hcm = HealthCheckMsg (T.pack who) - stream <- watch client hcm - runConduit $ stream .| C.mapM_ print \ No newline at end of file +watching client who = do + let hcm = HealthCheckMsg (T.pack who) + stream <- watch client hcm + runConduit $ stream .| C.mapM_ print diff --git a/examples/health-check/src/ClientTyApps.hs b/examples/health-check/src/ClientTyApps.hs index 7ef6645d..de7b0a13 100644 --- a/examples/health-check/src/ClientTyApps.hs +++ b/examples/health-check/src/ClientTyApps.hs @@ -1,59 +1,61 @@ -{-# language DataKinds, ScopedTypeVariables, - TypeApplications, TypeOperators, - FlexibleContexts, AllowAmbiguousTypes, - OverloadedStrings #-} +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} module Main where -import Data.Conduit +import Data.Conduit import qualified Data.Conduit.Combinators as C -import qualified Data.Text as T -import System.Environment +import qualified Data.Text as T +import System.Environment -import Mu.GRpc.Client.TyApps +import Mu.GRpc.Client.TyApps -import Definition +import Definition main :: IO () -main - = do -- Setup the client - let config = grpcClientConfigSimple "127.0.0.1" 8080 False - Right client <- setupGrpcClient' config - -- Execute command - args <- getArgs - case args of - ["watch" , who] -> watching client who - ["simple", who] -> simple client who - ["update", who] -> update client who "SERVING" - ["update", who, newstatus] -> update client who newstatus - _ -> putStrLn "unknown command" +main = do -- Setup the client + let config = grpcClientConfigSimple "127.0.0.1" 8080 False + Right client <- setupGrpcClient' config + -- Execute command + args <- getArgs + case args of + ["watch" , who] -> watching client who + ["simple", who] -> simple client who + ["update", who] -> update client who "SERVING" + ["update", who, newstatus] -> update client who newstatus + _ -> putStrLn "unknown command" simple :: GrpcClient -> String -> IO () -simple client who - = do let hcm = HealthCheckMsg (T.pack who) - putStrLn ("UNARY: Is there some server named " <> who <> "?") - rknown :: GRpcReply ServerStatusMsg - <- gRpcCall @HealthCheckService @"check" client hcm - putStrLn ("UNARY: Actually the status is " <> show rknown) - update client who "SERVING" - r <- gRpcCall @HealthCheckService @"clearStatus" client hcm - putStrLn ("UNARY: Was clearing successful? " <> show r) - runknown :: GRpcReply ServerStatusMsg - <- gRpcCall @HealthCheckService @"check" client hcm - putStrLn ("UNARY: Current status of " <> who <> ": " <> show runknown) +simple client who = do + let hcm = HealthCheckMsg (T.pack who) + putStrLn ("UNARY: Is there some server named " <> who <> "?") + rknown :: GRpcReply ServerStatusMsg + <- gRpcCall @HealthCheckService @"check" client hcm + putStrLn ("UNARY: Actually the status is " <> show rknown) + update client who "SERVING" + r <- gRpcCall @HealthCheckService @"clearStatus" client hcm + putStrLn ("UNARY: Was clearing successful? " <> show r) + runknown :: GRpcReply ServerStatusMsg + <- gRpcCall @HealthCheckService @"check" client hcm + putStrLn ("UNARY: Current status of " <> who <> ": " <> show runknown) update :: GrpcClient -> String -> String -> IO () -update client who newstatus - = do let hcm = HealthCheckMsg (T.pack who) - putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus) - r <- gRpcCall @HealthCheckService @"setStatus" client - (HealthStatusMsg hcm (ServerStatusMsg (T.pack newstatus))) - putStrLn ("UNARY: Was setting successful? " <> show r) - rstatus :: GRpcReply ServerStatusMsg - <- gRpcCall @HealthCheckService @"check" client hcm - putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus) +update client who newstatus = do + let hcm = HealthCheckMsg (T.pack who) + putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus) + r <- gRpcCall @HealthCheckService @"setStatus" client + (HealthStatusMsg hcm (ServerStatusMsg (T.pack newstatus))) + putStrLn ("UNARY: Was setting successful? " <> show r) + rstatus :: GRpcReply ServerStatusMsg + <- gRpcCall @HealthCheckService @"check" client hcm + putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus) watching :: GrpcClient -> String -> IO () -watching client who - = do let hcm = HealthCheckMsg (T.pack who) - replies <- gRpcCall @HealthCheckService @"watch" client hcm - runConduit $ replies .| C.mapM_ (print :: GRpcReply ServerStatusMsg -> IO ()) \ No newline at end of file +watching client who = do + let hcm = HealthCheckMsg (T.pack who) + replies <- gRpcCall @HealthCheckService @"watch" client hcm + runConduit $ replies .| C.mapM_ (print :: GRpcReply ServerStatusMsg -> IO ()) diff --git a/examples/health-check/src/Definition.hs b/examples/health-check/src/Definition.hs index 7c02647e..59487b51 100644 --- a/examples/health-check/src/Definition.hs +++ b/examples/health-check/src/Definition.hs @@ -1,16 +1,22 @@ -{-# language PolyKinds, DataKinds, TypeOperators, - MultiParamTypeClasses, TypeFamilies, - FlexibleInstances, FlexibleContexts, - DeriveGeneric, DeriveAnyClass, - DuplicateRecordFields, OverloadedLabels, - TemplateHaskell #-} +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DuplicateRecordFields #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedLabels #-} +{-# language PolyKinds #-} +{-# language TemplateHaskell #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} module Definition where -import GHC.Generics -import Data.Text as T +import Data.Text as T +import GHC.Generics -import Mu.Schema -import Mu.Quasi.GRpc +import Mu.Quasi.GRpc +import Mu.Schema $(grpc "HealthCheckSchema" id "healthcheck.proto") @@ -53,4 +59,4 @@ type HealthCheckService , 'Method "cleanAll" '[] '[ ] 'RetNothing , 'Method "watch" '[] '[ 'ArgSingle (HS "HealthCheck") ] ('RetStream (HS "ServerStatus")) ] --} \ No newline at end of file +-} diff --git a/examples/health-check/src/Server.hs b/examples/health-check/src/Server.hs index d44bb58d..dc52f794 100644 --- a/examples/health-check/src/Server.hs +++ b/examples/health-check/src/Server.hs @@ -1,22 +1,23 @@ -{-# language OverloadedStrings, PartialTypeSignatures #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} module Main where -import Control.Concurrent.STM -import Data.Conduit +import Control.Concurrent.STM +import Data.Conduit import qualified Data.Conduit.Combinators as C -import Data.Conduit.TMChan -import Data.Maybe -import qualified Data.Text as T -import DeferredFolds.UnfoldlM -import qualified StmContainers.Map as M +import Data.Conduit.TMChan +import Data.Maybe +import qualified Data.Text as T +import DeferredFolds.UnfoldlM +import qualified StmContainers.Map as M -import Mu.Server -import Mu.GRpc.Server +import Mu.GRpc.Server +import Mu.Server -import Definition +import Definition main :: IO () -main = do +main = do m <- M.newIO upd <- newTBMChanIO 100 putStrLn "running health check application" @@ -29,48 +30,45 @@ type StatusMap = M.Map T.Text T.Text type StatusUpdates = TBMChan HealthStatusMsg server :: StatusMap -> StatusUpdates -> ServerIO HealthCheckService _ -server m upd - = Server (setStatus_ m upd :<|>: - checkH_ m :<|>: - clearStatus_ m :<|>: - checkAll_ m :<|>: - cleanAll_ m :<|>: - watch_ upd :<|>: H0) +server m upd = Server (setStatus_ m upd :<|>: checkH_ m :<|>: clearStatus_ m :<|>: + checkAll_ m :<|>: cleanAll_ m :<|>: watch_ upd :<|>: H0) setStatus_ :: StatusMap -> StatusUpdates -> HealthStatusMsg -> IO () -setStatus_ m upd s@(HealthStatusMsg (HealthCheckMsg nm) (ServerStatusMsg ss)) - = do putStr "setStatus: " >> print (nm, ss) - atomically $ do M.insert ss nm m - writeTBMChan upd s +setStatus_ m upd s@(HealthStatusMsg (HealthCheckMsg nm) (ServerStatusMsg ss)) = do + putStr "setStatus: " >> print (nm, ss) + atomically $ do + M.insert ss nm m + writeTBMChan upd s checkH_ :: StatusMap -> HealthCheckMsg -> IO ServerStatusMsg -checkH_ m (HealthCheckMsg nm) - = do putStr "check: " >> print nm - ss <- atomically $ M.lookup nm m - return $ ServerStatusMsg (fromMaybe "UNKNOWN" ss) +checkH_ m (HealthCheckMsg nm) = do + putStr "check: " >> print nm + ss <- atomically $ M.lookup nm m + return $ ServerStatusMsg (fromMaybe "UNKNOWN" ss) clearStatus_ :: StatusMap -> HealthCheckMsg -> IO () -clearStatus_ m (HealthCheckMsg nm) - = do putStr "clearStatus: " >> print nm - atomically $ M.delete nm m +clearStatus_ m (HealthCheckMsg nm) = do + putStr "clearStatus: " >> print nm + atomically $ M.delete nm m checkAll_ :: StatusMap -> IO AllStatusMsg -checkAll_ m - = do putStrLn "checkAll" - AllStatusMsg <$> atomically (consumeValues kvToStatus (M.unfoldlM m)) - where consumeValues :: Monad m => (k -> v -> a) -> UnfoldlM m (k,v) -> m [a] - consumeValues f = foldlM' (\xs (x,y) -> pure (f x y:xs)) [] - kvToStatus k v = HealthStatusMsg (HealthCheckMsg k) (ServerStatusMsg v) +checkAll_ m = do + putStrLn "checkAll" + AllStatusMsg <$> atomically (consumeValues kvToStatus (M.unfoldlM m)) + where + consumeValues :: Monad m => (k -> v -> a) -> UnfoldlM m (k,v) -> m [a] + consumeValues f = foldlM' (\xs (x,y) -> pure (f x y:xs)) [] + kvToStatus k v = HealthStatusMsg (HealthCheckMsg k) (ServerStatusMsg v) cleanAll_ :: StatusMap -> IO () -cleanAll_ m - = do putStrLn "cleanAll" - atomically $ M.reset m +cleanAll_ m = do + putStrLn "cleanAll" + atomically $ M.reset m watch_ :: StatusUpdates -> HealthCheckMsg -> ConduitT ServerStatusMsg Void IO () -> IO () -watch_ upd hcm@(HealthCheckMsg nm) sink - = do putStr "watch: " >> print nm - runConduit $ sourceTBMChan upd - .| C.filter (\(HealthStatusMsg c _) -> hcm == c) - .| C.map (\(HealthStatusMsg _ s) -> s) - .| sink \ No newline at end of file +watch_ upd hcm@(HealthCheckMsg nm) sink = do + putStr "watch: " >> print nm + runConduit $ sourceTBMChan upd + .| C.filter (\(HealthStatusMsg c _) -> hcm == c) + .| C.map (\(HealthStatusMsg _ s) -> s) + .| sink diff --git a/examples/route-guide/src/Definition.hs b/examples/route-guide/src/Definition.hs index b0dbd644..ba1be268 100644 --- a/examples/route-guide/src/Definition.hs +++ b/examples/route-guide/src/Definition.hs @@ -1,17 +1,23 @@ -{-# language PolyKinds, DataKinds, TypeOperators, - MultiParamTypeClasses, TypeFamilies, - FlexibleInstances, FlexibleContexts, - DeriveGeneric, DeriveAnyClass, - DuplicateRecordFields, TemplateHaskell #-} +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DuplicateRecordFields #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language TemplateHaskell #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} module Definition where -import GHC.Generics -import Data.Hashable -import Data.Int -import Data.Text as T +import Data.Hashable +import Data.Int +import Data.Text as T +import GHC.Generics -import Mu.Schema -import Mu.Quasi.GRpc +import Mu.Quasi.GRpc +import Mu.Schema $(grpc "RouteGuideSchema" id "routeguide.proto") @@ -66,4 +72,4 @@ type RouteGuideSchema , 'FieldDef "distance" '[ProtoBufId 3] ('TPrimitive Int32) , 'FieldDef "elapsed_time" '[ProtoBufId 4] ('TPrimitive Int32) ] ] --} \ No newline at end of file +-} diff --git a/examples/route-guide/src/Server.hs b/examples/route-guide/src/Server.hs index 562bdd3b..a88e82c3 100644 --- a/examples/route-guide/src/Server.hs +++ b/examples/route-guide/src/Server.hs @@ -1,28 +1,30 @@ -{-# language OverloadedStrings, PartialTypeSignatures, - DuplicateRecordFields, ScopedTypeVariables #-} +{-# language DuplicateRecordFields #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language ScopedTypeVariables #-} module Main where -import Control.Concurrent.Async -import Control.Concurrent.STM -import Control.Concurrent.STM.TBMChan -import Control.Monad.IO.Class (liftIO) -import Data.Angle -import Data.Conduit -import qualified Data.Conduit.Combinators as C -import Data.Conduit.List (sourceList) -import Data.Function ((&)) -import Data.Int -import Data.List (find) -import Data.Maybe -import Data.Time.Clock - -import Mu.Server -import Mu.GRpc.Server - -import Definition +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Concurrent.STM.TBMChan +import Control.Monad.IO.Class (liftIO) +import Data.Angle +import Data.Conduit +import qualified Data.Conduit.Combinators as C +import Data.Conduit.List (sourceList) +import Data.Function ((&)) +import Data.Int +import Data.List (find) +import Data.Maybe +import Data.Time.Clock + +import Mu.GRpc.Server +import Mu.Server + +import Definition main :: IO () -main = do +main = do putStrLn "running route guide application" let features = [] routeNotes <- newTBMChanIO 100 @@ -34,16 +36,14 @@ main = do type Features = [Feature] findFeatureIn :: Features -> Point -> Maybe Feature -findFeatureIn features p - = find (\(Feature _ loc) -> loc == p) features +findFeatureIn features p = find (\(Feature _ loc) -> loc == p) features withinBounds :: Rectangle -> Point -> Bool withinBounds (Rectangle (Point lox loy) (Point hix hiy)) (Point x y) = x >= lox && x <= hix && y >= loy && y <= hiy featuresWithinBounds :: Features -> Rectangle -> Features -featuresWithinBounds fs rect - = filter (\(Feature _ loc) -> withinBounds rect loc) fs +featuresWithinBounds fs rect = filter (\(Feature _ loc) -> withinBounds rect loc) fs calcDistance :: Point -> Point -> Int32 calcDistance (Point lat1 lon1) (Point lat2 lon2) @@ -54,7 +54,7 @@ calcDistance (Point lat1 lon1) (Point lat2 lon2) Radians (deltaLambda :: Double) = radians (Degrees (int32ToDouble $ lon2 - lon1)) a = sin (deltaPhi / 2) * sin (deltaPhi / 2) + cos phi1 * cos phi2 * sin (deltaLambda / 2) * sin (deltaLambda / 2) - c = 2 * atan2 (sqrt a) (sqrt (1 - a)) + c = 2 * atan2 (sqrt a) (sqrt (1 - a)) in fromInteger $ r * ceiling c where int32ToDouble :: Int32 -> Double int32ToDouble = fromInteger . toInteger @@ -63,49 +63,48 @@ calcDistance (Point lat1 lon1) (Point lat2 lon2) -- https://github.com/higherkindness/mu/blob/master/modules/examples/routeguide/server/src/main/scala/handlers/RouteGuideServiceHandler.scala server :: Features -> TBMChan RouteNote -> ServerIO RouteGuideService _ -server f m - = Server (getFeature f :<|>: listFeatures f - :<|>: recordRoute f :<|>: routeChat m :<|>: H0) +server f m = Server + (getFeature f :<|>: listFeatures f :<|>: recordRoute f :<|>: routeChat m :<|>: H0) getFeature :: Features -> Point -> IO Feature -getFeature fs p - = return $ fromMaybe (Feature "" (Point 0 0)) (findFeatureIn fs p) +getFeature fs p = return $ fromMaybe (Feature "" (Point 0 0)) (findFeatureIn fs p) listFeatures :: Features -> Rectangle -> ConduitT Feature Void IO () -> IO () -listFeatures fs rect result - = runConduit $ sourceList (featuresWithinBounds fs rect) .| result +listFeatures fs rect result = runConduit $ sourceList (featuresWithinBounds fs rect) .| result recordRoute :: Features -> ConduitT () Point IO () -> IO RouteSummary -recordRoute fs ps - = do initialTime <- getCurrentTime - (rs, _, _) <- runConduit $ ps .| C.foldM step (RouteSummary 0 0 0 0, Nothing, initialTime) - return rs - where step :: (RouteSummary, Maybe Point, UTCTime) -> Point -> IO (RouteSummary, Maybe Point, UTCTime) - step (summary, previous, startTime) point - = do currentTime <- getCurrentTime - let feature = findFeatureIn fs point - new_distance = fmap (`calcDistance` point) previous & fromMaybe 0 - new_elapsed = diffUTCTime currentTime startTime - new_summary = RouteSummary (point_count summary + 1) - (feature_count summary + if isJust feature then 1 else 0) - (distance summary + new_distance) - (floor new_elapsed) - return (new_summary, Just point, startTime) +recordRoute fs ps = do + initialTime <- getCurrentTime + (rs, _, _) <- runConduit $ ps .| C.foldM step (RouteSummary 0 0 0 0, Nothing, initialTime) + return rs + where + step :: (RouteSummary, Maybe Point, UTCTime) -> Point -> IO (RouteSummary, Maybe Point, UTCTime) + step (summary, previous, startTime) point = do + currentTime <- getCurrentTime + let feature = findFeatureIn fs point + new_distance = fmap (`calcDistance` point) previous & fromMaybe 0 + new_elapsed = diffUTCTime currentTime startTime + new_summary = RouteSummary (point_count summary + 1) + (feature_count summary + if isJust feature then 1 else 0) + (distance summary + new_distance) + (floor new_elapsed) + return (new_summary, Just point, startTime) routeChat :: TBMChan RouteNote -> ConduitT () RouteNote IO () -> ConduitT RouteNote Void IO () -> IO () -routeChat notesMap inS outS - = do toWatch <- newEmptyTMVarIO - -- Start two threads, one to listen, one to send - inA <- async $ runConduit $ inS .| C.mapM_ (addNoteToMap toWatch) - outA <- async $ runConduit $ readStmMap (\l1 (RouteNote _ l2)-> l1 == l2) toWatch notesMap .| outS - wait inA - wait outA - where addNoteToMap :: TMVar Point -> RouteNote -> IO () - addNoteToMap toWatch newNote@(RouteNote _ loc) - = atomically $ do _ <- tryTakeTMVar toWatch - putTMVar toWatch loc - writeTBMChan notesMap newNote +routeChat notesMap inS outS = do + toWatch <- newEmptyTMVarIO + -- Start two threads, one to listen, one to send + inA <- async $ runConduit $ inS .| C.mapM_ (addNoteToMap toWatch) + outA <- async $ runConduit $ readStmMap (\l1 (RouteNote _ l2)-> l1 == l2) toWatch notesMap .| outS + wait inA + wait outA + where + addNoteToMap :: TMVar Point -> RouteNote -> IO () + addNoteToMap toWatch newNote@(RouteNote _ loc) = atomically $ do + _ <- tryTakeTMVar toWatch + putTMVar toWatch loc + writeTBMChan notesMap newNote readStmMap :: Show b => (a -> b -> Bool) -> TMVar a -> TBMChan b -> ConduitT () b IO () readStmMap p toWatch m = go @@ -113,6 +112,6 @@ readStmMap p toWatch m = go go = do v <- liftIO $ atomically $ (,) <$> readTBMChan m <*> tryReadTMVar toWatch case v of - (Nothing, _) -> return () + (Nothing, _) -> return () (Just v', Just e') | p e' v' -> liftIO (print v') >> yield v' >> go - _ -> go \ No newline at end of file + _ -> go diff --git a/grpc/client/src/Mu/GRpc/Client/Examples.hs b/grpc/client/src/Mu/GRpc/Client/Examples.hs index 0c0b9144..bf11bf59 100644 --- a/grpc/client/src/Mu/GRpc/Client/Examples.hs +++ b/grpc/client/src/Mu/GRpc/Client/Examples.hs @@ -1,14 +1,15 @@ -{-# language DataKinds, TypeApplications #-} +{-# language DataKinds #-} +{-# language TypeApplications #-} module Mu.GRpc.Client.Examples where -import Data.Conduit -import Data.Conduit.Combinators as C -import Data.Conduit.List (consume) -import qualified Data.Text as T -import Network.HTTP2.Client (HostName, PortNumber) +import Data.Conduit +import Data.Conduit.Combinators as C +import Data.Conduit.List (consume) +import qualified Data.Text as T +import Network.HTTP2.Client (HostName, PortNumber) -import Mu.GRpc.Client.TyApps -import Mu.Rpc.Examples +import Mu.GRpc.Client.TyApps +import Mu.Rpc.Examples sayHello' :: HostName -> PortNumber -> T.Text -> IO (GRpcReply T.Text) sayHello' host port req @@ -25,4 +26,4 @@ sayHi' host port n runConduit $ cndt .| C.map (fmap (\(HelloResponse r) -> r)) .| consume sayHi :: GrpcClient -> HiRequest -> IO (ConduitT () (GRpcReply HelloResponse) IO ()) -sayHi = gRpcCall @QuickStartService @"SayHi" \ No newline at end of file +sayHi = gRpcCall @QuickStartService @"SayHi" diff --git a/grpc/client/src/Mu/GRpc/Client/Internal.hs b/grpc/client/src/Mu/GRpc/Client/Internal.hs index 1f3e7b3b..f551a340 100644 --- a/grpc/client/src/Mu/GRpc/Client/Internal.hs +++ b/grpc/client/src/Mu/GRpc/Client/Internal.hs @@ -1,33 +1,39 @@ -{-# language PolyKinds, DataKinds, GADTs, - MultiParamTypeClasses, - FlexibleInstances, FlexibleContexts, - ScopedTypeVariables, TypeApplications, - TypeOperators, DeriveFunctor, - AllowAmbiguousTypes, - TupleSections, UndecidableInstances #-} +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language DeriveFunctor #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} -- | Client for gRPC services defined using Mu 'Service' module Mu.GRpc.Client.Internal where -import Control.Monad.IO.Class -import Control.Concurrent.Async -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TMChan -import Control.Concurrent.STM.TMVar -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS -import Data.Conduit -import qualified Data.Conduit.Combinators as C -import Data.Conduit.TMChan -import Network.HTTP2 (ErrorCode) -import Network.HTTP2.Client (ClientIO, TooMuchConcurrency, ClientError, runExceptT) -import Network.GRPC.HTTP2.Proto3Wire -import Network.GRPC.Client (RawReply, CompressMode(..), StreamDone(..), - IncomingEvent(..),OutgoingEvent(..)) -import Network.GRPC.Client.Helpers - -import Mu.Rpc -import Mu.Schema -import Mu.Adapter.ProtoBuf.Via +import Control.Concurrent.Async +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TMChan +import Control.Concurrent.STM.TMVar +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Conduit +import qualified Data.Conduit.Combinators as C +import Data.Conduit.TMChan +import Network.GRPC.Client (CompressMode (..), IncomingEvent (..), + OutgoingEvent (..), RawReply, StreamDone (..)) +import Network.GRPC.Client.Helpers +import Network.GRPC.HTTP2.Proto3Wire +import Network.HTTP2 (ErrorCode) +import Network.HTTP2.Client (ClientError, ClientIO, TooMuchConcurrency, + runExceptT) + +import Mu.Adapter.ProtoBuf.Via +import Mu.Rpc +import Mu.Schema setupGrpcClient' :: GrpcClientConfig -> IO (Either ClientError GrpcClient) setupGrpcClient' = runExceptT . setupGrpcClient @@ -49,16 +55,16 @@ data GRpcReply a deriving (Show, Functor) buildGRpcReply1 :: Either TooMuchConcurrency (RawReply a) -> GRpcReply a -buildGRpcReply1 (Left tmc) = GRpcTooMuchConcurrency tmc -buildGRpcReply1 (Right (Left ec)) = GRpcErrorCode ec +buildGRpcReply1 (Left tmc) = GRpcTooMuchConcurrency tmc +buildGRpcReply1 (Right (Left ec)) = GRpcErrorCode ec buildGRpcReply1 (Right (Right (_, _, Left es))) = GRpcErrorString es buildGRpcReply1 (Right (Right (_, _, Right r))) = GRpcOk r -buildGRpcReply2 :: Either TooMuchConcurrency (r, (RawReply a)) -> GRpcReply a -buildGRpcReply2 (Left tmc) = GRpcTooMuchConcurrency tmc -buildGRpcReply2 (Right (_, (Left ec))) = GRpcErrorCode ec -buildGRpcReply2 (Right (_, (Right (_, _, Left es)))) = GRpcErrorString es -buildGRpcReply2 (Right (_, (Right (_, _, Right r)))) = GRpcOk r +buildGRpcReply2 :: Either TooMuchConcurrency (r, RawReply a) -> GRpcReply a +buildGRpcReply2 (Left tmc) = GRpcTooMuchConcurrency tmc +buildGRpcReply2 (Right (_, Left ec)) = GRpcErrorCode ec +buildGRpcReply2 (Right (_, Right (_, _, Left es))) = GRpcErrorString es +buildGRpcReply2 (Right (_, Right (_, _, Right r))) = GRpcOk r buildGRpcReply3 :: Either TooMuchConcurrency v -> GRpcReply () buildGRpcReply3 (Left tmc) = GRpcTooMuchConcurrency tmc @@ -77,7 +83,7 @@ class GRpcMethodCall method h where instance (KnownName name, handler ~ IO (GRpcReply ())) => GRpcMethodCall ('Method name anns '[ ] 'RetNothing) handler where gRpcMethodCall pkgName srvName _ client - = simplifyResponse $ + = simplifyResponse $ buildGRpcReply1 <$> rawUnary rpc client () where methodName = BS.pack (nameVal (Proxy @name)) @@ -88,7 +94,7 @@ instance ( KnownName name, ProtoBufTypeRef rref r => GRpcMethodCall ('Method name anns '[ ] ('RetSingle rref)) handler where gRpcMethodCall pkgName srvName _ client = fmap (fmap unViaProtoBufTypeRef) $ - simplifyResponse $ + simplifyResponse $ buildGRpcReply1 <$> rawUnary @_ @_ @(ViaProtoBufTypeRef rref _)rpc client () where methodName = BS.pack (nameVal (Proxy @name)) @@ -98,7 +104,7 @@ instance ( KnownName name, ProtoBufTypeRef vref v , handler ~ (v -> IO (GRpcReply ())) ) => GRpcMethodCall ('Method name anns '[ 'ArgSingle vref ] 'RetNothing) handler where gRpcMethodCall pkgName srvName _ client x - = simplifyResponse $ + = simplifyResponse $ buildGRpcReply1 <$> rawUnary @_ @(ViaProtoBufTypeRef vref _) rpc client (ViaProtoBufTypeRef x) where methodName = BS.pack (nameVal (Proxy @name)) @@ -109,7 +115,7 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r => GRpcMethodCall ('Method name anns '[ 'ArgSingle vref ] ('RetSingle rref)) handler where gRpcMethodCall pkgName srvName _ client x = fmap (fmap unViaProtoBufTypeRef) $ - simplifyResponse $ + simplifyResponse $ buildGRpcReply1 <$> rawUnary @_ @(ViaProtoBufTypeRef vref _) @(ViaProtoBufTypeRef rref _) rpc client (ViaProtoBufTypeRef x) @@ -123,9 +129,9 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r = do -- Create a new TMChan chan <- newTMChanIO :: IO (TMChan v) -- Start executing the client in another thread - promise <- async $ + promise <- async $ fmap (fmap unViaProtoBufTypeRef) $ - simplifyResponse $ + simplifyResponse $ buildGRpcReply2 <$> rawStreamClient @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) rpc client () (\_ -> do nextVal <- liftIO $ atomically $ readTMChan chan @@ -139,7 +145,7 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r go Nothing -> do liftIO $ atomically $ closeTMChan chan liftIO $ wait promise - return go + return go where methodName = BS.pack (nameVal (Proxy @name)) rpc = RPC pkgName srvName methodName @@ -152,16 +158,16 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r var <- newEmptyTMVarIO -- if full, this means an error -- Start executing the client in another thread _ <- async $ do - v <- simplifyResponse $ + v <- simplifyResponse $ buildGRpcReply3 <$> rawStreamServer @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) rpc client () (ViaProtoBufTypeRef x) - (\_ _ (ViaProtoBufTypeRef newVal) -> liftIO $ atomically $ + (\_ _ (ViaProtoBufTypeRef newVal) -> liftIO $ atomically $ -- on the first iteration, say that everything is OK tryPutTMVar var (GRpcOk ()) >> writeTMChan chan newVal) case v of GRpcOk () -> liftIO $ atomically $ closeTMChan chan - _ -> liftIO $ atomically $ putTMVar var v + _ -> liftIO $ atomically $ putTMVar var v -- This conduit feeds information to the other thread let go = do firstResult <- liftIO $ atomically $ takeTMVar var case firstResult of @@ -182,7 +188,7 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r var <- newEmptyTMVarIO -- if full, this means an error -- Start executing the client in another thread _ <- async $ do - v <- simplifyResponse $ + v <- simplifyResponse $ buildGRpcReply3 <$> rawGeneralStream @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) @@ -200,21 +206,21 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r Just v -> return ((), SendMessage compress (ViaProtoBufTypeRef v))) case v of GRpcOk () -> liftIO $ atomically $ closeTMChan inchan - _ -> liftIO $ atomically $ putTMVar var v + _ -> liftIO $ atomically $ putTMVar var v -- This conduit feeds information to the other thread let go = do err <- liftIO $ atomically $ takeTMVar var case err of GRpcOk _ -> go2 - e -> yield $ (\_ -> error "this should never happen") <$> e + e -> yield $ (\_ -> error "this should never happen") <$> e go2 = do nextOut <- await case nextOut of Just v -> do liftIO $ atomically $ writeTMChan outchan v go2 Nothing -> do r <- liftIO $ atomically $ tryReadTMChan inchan case r of - Nothing -> return () -- both are empty, end - Just Nothing -> go2 + Nothing -> return () -- both are empty, end + Just Nothing -> go2 Just (Just nextIn) -> yield nextIn >> go2 return go where methodName = BS.pack (nameVal (Proxy @name)) - rpc = RPC pkgName srvName methodName \ No newline at end of file + rpc = RPC pkgName srvName methodName diff --git a/grpc/client/src/Mu/GRpc/Client/Record.hs b/grpc/client/src/Mu/GRpc/Client/Record.hs index c88838df..285b636f 100644 --- a/grpc/client/src/Mu/GRpc/Client/Record.hs +++ b/grpc/client/src/Mu/GRpc/Client/Record.hs @@ -1,9 +1,15 @@ -{-# language PolyKinds, DataKinds, TypeOperators, - MultiParamTypeClasses, TypeFamilies, - FlexibleInstances, FlexibleContexts, - UndecidableInstances, TypeApplications, - ScopedTypeVariables, AllowAmbiguousTypes, - TemplateHaskell #-} +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TemplateHaskell #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} -- | Client for gRPC services defined using Mu 'Service' -- using plain Haskell records of functions module Mu.GRpc.Client.Record ( @@ -19,21 +25,21 @@ module Mu.GRpc.Client.Record ( , generateRecordFromService ) where -import Control.Applicative -import Data.Char -import Data.Conduit (ConduitT) -import Data.Proxy -import Data.Void -import GHC.Generics hiding (NoSourceUnpackedness, NoSourceStrictness) -import GHC.TypeLits -import Language.Haskell.TH hiding (ppr) -import Language.Haskell.TH.Datatype +import Control.Applicative +import Data.Char +import Data.Conduit (ConduitT) +import Data.Proxy +import Data.Void +import GHC.Generics hiding (NoSourceStrictness, NoSourceUnpackedness) +import GHC.TypeLits +import Language.Haskell.TH hiding (ppr) +import Language.Haskell.TH.Datatype -import Network.GRPC.Client (CompressMode(..)) -import Network.GRPC.Client.Helpers +import Network.GRPC.Client (CompressMode (..)) +import Network.GRPC.Client.Helpers -import Mu.GRpc.Client.Internal -import Mu.Rpc +import Mu.GRpc.Client.Internal +import Mu.Rpc -- | Fills in a Haskell record of functions with the corresponding -- calls to gRPC services from a Mu 'Service' declaration. @@ -132,11 +138,11 @@ completeName :: Namer -> String -> String completeName namer name = firstUpper (namer (firstUpper name)) firstUpper :: String -> String -firstUpper [] = error "Empty names are not allowed" +firstUpper [] = error "Empty names are not allowed" firstUpper (x:rest) = toUpper x : rest firstLower :: String -> String -firstLower [] = error "Empty names are not allowed" +firstLower [] = error "Empty names are not allowed" firstLower (x:rest) = toLower x : rest -- Parsing @@ -153,7 +159,7 @@ typeToServiceDef toplevelty Service <$> tyString sn <*> pure [] <*> mapM typeToMethodDef methods' - + typeToMethodDef :: Type -> Maybe (Method String) typeToMethodDef ty = do (mn, _, args, ret) <- tyD4 'Method ty @@ -233,4 +239,4 @@ tyD4 name (SigT t _) = tyD4 name t tyD4 name (AppT (AppT (AppT (AppT (PromotedT c) x) y) z) u) | c == name = Just (x, y, z, u) | otherwise = Nothing -tyD4 _ _ = Nothing \ No newline at end of file +tyD4 _ _ = Nothing diff --git a/grpc/client/src/Mu/GRpc/Client/TyApps.hs b/grpc/client/src/Mu/GRpc/Client/TyApps.hs index 13adcaa7..e90c1ebb 100644 --- a/grpc/client/src/Mu/GRpc/Client/TyApps.hs +++ b/grpc/client/src/Mu/GRpc/Client/TyApps.hs @@ -1,7 +1,12 @@ -{-# language PolyKinds, DataKinds, GADTs, - MultiParamTypeClasses, FlexibleContexts, - ScopedTypeVariables, TypeApplications, - TypeOperators, AllowAmbiguousTypes #-} +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} -- | Client for gRPC services defined using Mu 'Service' -- using 'TypeApplications' module Mu.GRpc.Client.TyApps ( @@ -16,18 +21,18 @@ module Mu.GRpc.Client.TyApps ( , GRpcReply(..) ) where -import Network.GRPC.Client (CompressMode(..)) -import Network.GRPC.Client.Helpers +import Network.GRPC.Client (CompressMode (..)) +import Network.GRPC.Client.Helpers -import Mu.Rpc -import Mu.Schema +import Mu.Rpc +import Mu.Schema -import Mu.GRpc.Client.Internal +import Mu.GRpc.Client.Internal -- | Call a method from a Mu definition. -- This method is thought to be used with @TypeApplications@: --- > gRpcCall @"packageName" @ServiceDeclaration @"method" --- +-- > gRpcCall @"packageName" @ServiceDeclaration @"method" +-- -- The additional arguments you must provide to 'grpcCall' -- depend on the signature of the method itself: -- * The resulting value is always wrapped in 'GRpcReply'. @@ -36,4 +41,4 @@ import Mu.GRpc.Client.Internal gRpcCall :: forall s methodName h. (GRpcServiceMethodCall s (s :-->: methodName) h) => GrpcClient -> h -gRpcCall = gRpcServiceMethodCall (Proxy @s) (Proxy @(s :-->: methodName)) \ No newline at end of file +gRpcCall = gRpcServiceMethodCall (Proxy @s) (Proxy @(s :-->: methodName)) diff --git a/grpc/server/src/ExampleServer.hs b/grpc/server/src/ExampleServer.hs index 7d76f1d9..e4e4def4 100644 --- a/grpc/server/src/ExampleServer.hs +++ b/grpc/server/src/ExampleServer.hs @@ -1,10 +1,10 @@ {-# language OverloadedStrings #-} module Main where -import Mu.GRpc.Server -import Mu.Rpc.Examples +import Mu.GRpc.Server +import Mu.Rpc.Examples main :: IO () -main = do +main = do putStrLn "running quickstart application" - runGRpcApp 8080 quickstartServer \ No newline at end of file + runGRpcApp 8080 quickstartServer diff --git a/grpc/server/src/Mu/GRpc/Server.hs b/grpc/server/src/Mu/GRpc/Server.hs index ed6e9f7d..7fc740dd 100644 --- a/grpc/server/src/Mu/GRpc/Server.hs +++ b/grpc/server/src/Mu/GRpc/Server.hs @@ -1,9 +1,13 @@ -{-# language PolyKinds, DataKinds, GADTs, - MultiParamTypeClasses, - FlexibleInstances, FlexibleContexts, - UndecidableInstances, - TypeApplications, TypeOperators, - ScopedTypeVariables #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} -- | Execute a Mu 'Server' using gRPC as transport layer module Mu.GRpc.Server ( -- * Run a 'Server' directly @@ -14,29 +18,29 @@ module Mu.GRpc.Server ( , gRpcApp ) where -import Data.ByteString (ByteString) -import qualified Data.ByteString.Char8 as BS -import Control.Concurrent.Async -import Control.Concurrent.STM (atomically) -import Control.Concurrent.STM.TMVar -import Control.Monad.IO.Class -import Data.Conduit -import Data.Conduit.TMChan -import Data.Kind -import Data.Proxy -import Network.GRPC.HTTP2.Encoding (uncompressed, gzip) -import Network.GRPC.HTTP2.Proto3Wire -import Network.GRPC.Server.Wai (ServiceHandler) -import Network.GRPC.Server.Handlers -import Network.GRPC.Server.Wai as Wai -import Network.Wai (Application) -import Network.Wai.Handler.Warp (Port, Settings, run, runSettings) -import Network.Wai.Handler.WarpTLS (TLSSettings, runTLS) - -import Mu.Rpc -import Mu.Server -import Mu.Schema -import Mu.Adapter.ProtoBuf.Via +import Control.Concurrent.Async +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TMVar +import Control.Monad.IO.Class +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as BS +import Data.Conduit +import Data.Conduit.TMChan +import Data.Kind +import Data.Proxy +import Network.GRPC.HTTP2.Encoding (gzip, uncompressed) +import Network.GRPC.HTTP2.Proto3Wire +import Network.GRPC.Server.Handlers +import Network.GRPC.Server.Wai (ServiceHandler) +import Network.GRPC.Server.Wai as Wai +import Network.Wai (Application) +import Network.Wai.Handler.Warp (Port, Settings, run, runSettings) +import Network.Wai.Handler.WarpTLS (TLSSettings, runTLS) + +import Mu.Adapter.ProtoBuf.Via +import Mu.Rpc +import Mu.Schema +import Mu.Server -- | Run a Mu 'Server' on the given port. runGRpcApp @@ -47,8 +51,8 @@ runGRpcApp runGRpcApp port svr = run port (gRpcApp svr) -- | Run a Mu 'Server' using the given 'Settings'. --- --- Go to 'Network.Wai.Handler.Warp' to declare 'Settings'. +-- +-- Go to 'Network.Wai.Handler.Warp' to declare 'Settings'. runGRpcAppSettings :: ( KnownName name, KnownName (FindPackageName anns) , GRpcMethodHandlers methods handlers ) @@ -88,7 +92,7 @@ gRpcServiceHandlers gRpcServiceHandlers (Server svr) = gRpcMethodHandlers packageName serviceName svr where packageName = BS.pack (nameVal (Proxy @(FindPackageName anns))) serviceName = BS.pack (nameVal (Proxy @name)) - + class GRpcMethodHandlers (ms :: [Method mnm]) (hs :: [Type]) where gRpcMethodHandlers :: ByteString -> ByteString -> HandlersIO ms hs -> [ServiceHandler] @@ -204,6 +208,7 @@ instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) return ((), IncomingStream cstreamHandler cstreamFinalizer, (), OutgoingStream readNext) toTMVarConduit :: TMVar (Maybe r) -> ConduitT r Void IO () -toTMVarConduit var = do x <- await - liftIO $ atomically $ putTMVar var x - toTMVarConduit var \ No newline at end of file +toTMVarConduit var = do + x <- await + liftIO $ atomically $ putTMVar var x + toTMVarConduit var From 142a6982a1959050b5b5491059643a075efe9ae0 Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Mon, 25 Nov 2019 10:17:22 +0000 Subject: [PATCH 007/217] =?UTF-8?q?Add=20example=20todolist=20=E2=9C=85=20?= =?UTF-8?q?(#24)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Start work on todolist example ✅ * Fix .proto and implement Definition! 📚 * start work on server * Implement server! 🚀 * Finish server! 💻 * apply feedback! 🧼 * prevent t to change between calls 🐛 * cleanup --- compendium-client/compendium-client.cabal | 2 +- examples/README.md | 4 +- examples/health-check/healthcheck.proto | 2 +- .../mu-example-health-check.cabal | 4 +- .../route-guide/mu-example-route-guide.cabal | 4 +- examples/todolist/LICENSE | 202 ++++++++++++++++++ examples/todolist/README.md | 18 ++ examples/todolist/mu-example-todolist.cabal | 43 ++++ examples/todolist/src/Definition.hs | 45 ++++ examples/todolist/src/Server.hs | 86 ++++++++ examples/todolist/todolist.proto | 20 ++ stack-nightly.yaml | 1 + stack.yaml | 1 + 13 files changed, 425 insertions(+), 7 deletions(-) create mode 100644 examples/todolist/LICENSE create mode 100644 examples/todolist/README.md create mode 100644 examples/todolist/mu-example-todolist.cabal create mode 100644 examples/todolist/src/Definition.hs create mode 100644 examples/todolist/src/Server.hs create mode 100644 examples/todolist/todolist.proto diff --git a/compendium-client/compendium-client.cabal b/compendium-client/compendium-client.cabal index e623d3f6..05e86194 100644 --- a/compendium-client/compendium-client.cabal +++ b/compendium-client/compendium-client.cabal @@ -12,7 +12,7 @@ maintainer: alejandro.serrano@47deg.com -- copyright: category: Network build-type: Simple -extra-source-files: README.md, CHANGELOG.md +-- extra-source-files: README.md, CHANGELOG.md library exposed-modules: Compendium.Client diff --git a/examples/README.md b/examples/README.md index 7a11f53f..7514b8ae 100644 --- a/examples/README.md +++ b/examples/README.md @@ -2,4 +2,6 @@ Those examples are ports of those in [Mu Scala](https://github.com/higherkindness/mu/tree/master/modules/examples). -* Health check \ No newline at end of file +* Health check +* Route guide +* TODO list diff --git a/examples/health-check/healthcheck.proto b/examples/health-check/healthcheck.proto index de3a1a9e..3c6d5762 100644 --- a/examples/health-check/healthcheck.proto +++ b/examples/health-check/healthcheck.proto @@ -16,4 +16,4 @@ service HealthCheckService { message HealthCheck { string nameService = 1; } message ServerStatus { string status = 1; } message HealthStatus { HealthCheck hc = 1; ServerStatus status = 2; } -message AllStatus { repeated HealthStatus all = 1; } \ No newline at end of file +message AllStatus { repeated HealthStatus all = 1; } diff --git a/examples/health-check/mu-example-health-check.cabal b/examples/health-check/mu-example-health-check.cabal index 7a3b91b8..db762828 100644 --- a/examples/health-check/mu-example-health-check.cabal +++ b/examples/health-check/mu-example-health-check.cabal @@ -12,7 +12,7 @@ license: Apache-2.0 license-file: LICENSE author: Alejandro Serrano maintainer: alejandro.serrano@47deg.com --- copyright: +copyright: Copyright © 2019-2020 47 Degrees. category: Network build-type: Simple @@ -58,4 +58,4 @@ executable health-client-record mu-grpc-client, conduit hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall \ No newline at end of file + ghc-options: -Wall diff --git a/examples/route-guide/mu-example-route-guide.cabal b/examples/route-guide/mu-example-route-guide.cabal index b4e95745..a05ebc06 100644 --- a/examples/route-guide/mu-example-route-guide.cabal +++ b/examples/route-guide/mu-example-route-guide.cabal @@ -12,7 +12,7 @@ license: Apache-2.0 license-file: LICENSE author: Alejandro Serrano maintainer: alejandro.serrano@47deg.com --- copyright: +copyright: Copyright © 2019-2020 47 Degrees. category: Network build-type: Simple @@ -35,4 +35,4 @@ executable route-guide-server conduit, AC-Angle, time, async hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall \ No newline at end of file + ghc-options: -Wall diff --git a/examples/todolist/LICENSE b/examples/todolist/LICENSE new file mode 100644 index 00000000..d6456956 --- /dev/null +++ b/examples/todolist/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/examples/todolist/README.md b/examples/todolist/README.md new file mode 100644 index 00000000..92bc7e43 --- /dev/null +++ b/examples/todolist/README.md @@ -0,0 +1,18 @@ +# TodoList RPC example + +## Execution + +Running the server: + +```bash +stack run todolist-server +``` + +[comment]: # (Start Copyright) +# Copyright + +Mu is designed and developed by 47 Degrees + +Copyright (C) 2019-2020 47 Degrees. + +[comment]: # (End Copyright) diff --git a/examples/todolist/mu-example-todolist.cabal b/examples/todolist/mu-example-todolist.cabal new file mode 100644 index 00000000..9bcde71f --- /dev/null +++ b/examples/todolist/mu-example-todolist.cabal @@ -0,0 +1,43 @@ +cabal-version: >=1.10 +-- Initial package description 'mu-haskell.cabal' generated by 'cabal +-- init'. For further documentation, see +-- http://haskell.org/cabal/users-guide/ + +name: mu-example-todolist +version: 0.1.0.0 +-- synopsis: +-- description: +-- bug-reports: +license: Apache-2.0 +license-file: LICENSE +author: Flavio Corpa +maintainer: flavio.corpa@47deg.com +copyright: Copyright © 2019-2020 47 Degrees. +category: Network +build-type: Simple + +library + exposed-modules: Definition + build-depends: base >=4.12 && <5 + , text + , mu-schema + , mu-rpc + , mu-protobuf + , hashable + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +executable todolist-server + main-is: Server.hs + other-modules: Definition + build-depends: base >=4.12 && <5 + , mu-schema + , mu-rpc + , mu-protobuf + , mu-grpc-server + , stm + , text + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/examples/todolist/src/Definition.hs b/examples/todolist/src/Definition.hs new file mode 100644 index 00000000..dc197238 --- /dev/null +++ b/examples/todolist/src/Definition.hs @@ -0,0 +1,45 @@ +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DuplicateRecordFields #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language TemplateHaskell #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} + +module Definition where + +import Data.Int +import Data.Text (Text) +import GHC.Generics + +import Mu.Quasi.GRpc +import Mu.Schema + +grpc "TodoListSchema" id "todolist.proto" + +newtype MessageId = MessageId + { value :: Int32 + } deriving (Eq, Show, Ord, Generic, HasSchema TodoListSchema "MessageId") + +data TodoListMessage = TodoListMessage + { id, tagId :: Int32 + , title :: Text + , completed :: Bool + } deriving (Eq, Show, Ord, Generic, HasSchema TodoListSchema "TodoListMessage") + +data TodoListRequest = TodoListRequest + { title :: Text + , tagId :: Int32 + } deriving (Eq, Show, Ord, Generic, HasSchema TodoListSchema "TodoListRequest") + +newtype TodoListList = TodoListList + { list :: [TodoListMessage] + } deriving (Eq, Show, Ord, Generic, HasSchema TodoListSchema "TodoListList") + +newtype TodoListResponse = TodoListResponse + { msg :: TodoListMessage + } deriving (Eq, Show, Ord, Generic, HasSchema TodoListSchema "TodoListResponse") diff --git a/examples/todolist/src/Server.hs b/examples/todolist/src/Server.hs new file mode 100644 index 00000000..add39aba --- /dev/null +++ b/examples/todolist/src/Server.hs @@ -0,0 +1,86 @@ +{-# language DataKinds #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} + +module Main where + +import Control.Concurrent.STM +import Data.Int +import Data.List (find) +import Data.Maybe (fromMaybe) + +import Mu.GRpc.Server +import Mu.Server + +import Definition +import Prelude hiding (id) + +main :: IO () +main = do + putStrLn "running todolist application" + todoId <- newTVarIO 0 + todolist <- newTVarIO [] + runGRpcApp 8080 (server todoId todolist) + +-- Server implementation +-- https://github.com/frees-io/freestyle/blob/master/modules/examples/todolist-lib/src/main/scala/todo/service/TodoListService.scala + +type Id = TVar Int32 +type TodoList = TVar [TodoListMessage] + +server :: Id -> TodoList -> ServerIO TodoListService _ +server i t = Server + (reset i t :<|>: insert i t :<|>: retrieve t :<|>: list_ t :<|>: update t :<|>: destroy t :<|>: H0) + +reset :: Id -> TodoList -> IO MessageId +reset i t = do + putStrLn "reset" + atomically $ do + writeTVar i 0 + writeTVar t [] + pure $ MessageId 0 -- returns nothing + +insert :: Id -> TodoList -> TodoListRequest -> IO TodoListResponse +insert oldId t (TodoListRequest titl tgId) = do + putStr "insert: " >> print (titl, tgId) + atomically $ do + modifyTVar oldId (+1) + newId <- readTVar oldId + let newTodo = TodoListMessage newId tgId titl False + modifyTVar t (newTodo:) + pure $ TodoListResponse newTodo + +getMsg :: Int32 -> TodoListMessage -> Bool +getMsg x TodoListMessage {id} = id == x + +retrieve :: TodoList -> MessageId -> IO TodoListResponse +retrieve t (MessageId idMsg) = do + putStr "retrieve: " >> print idMsg + todos <- readTVarIO t + let todo = fromMaybe (TodoListMessage 0 0 "I don't know" False) (find (getMsg idMsg) todos) + pure $ TodoListResponse todo -- FIXME: what if it's not found? + +list_ :: TodoList -> IO TodoListList +list_ t = do + putStrLn "list" + atomically $ do + todos <- readTVar t + pure $ TodoListList todos + +update :: TodoList -> TodoListMessage -> IO TodoListResponse +update t mg@(TodoListMessage idM titM tgM compl) = do + putStr "update: " >> print (idM, titM, tgM, compl) + atomically $ modifyTVar t $ fmap (\m -> if getMsg idM m then mg else m) + pure $ TodoListResponse mg + +destroy :: TodoList -> MessageId -> IO MessageId +destroy t (MessageId idMsg) = do + putStr "destroy: " >> print idMsg + atomically $ do + todos <- readTVar t + case find (getMsg idMsg) todos of + Just todo -> do + modifyTVar t $ filter (/=todo) + pure $ MessageId idMsg -- OK ✅ + Nothing -> pure $ MessageId 0 -- did nothing diff --git a/examples/todolist/todolist.proto b/examples/todolist/todolist.proto new file mode 100644 index 00000000..276147d1 --- /dev/null +++ b/examples/todolist/todolist.proto @@ -0,0 +1,20 @@ +syntax = "proto3"; + +import "google/protobuf/empty.proto"; + +package todolist; + +service TodoListService { + rpc reset(google.protobuf.Empty) returns (MessageId); + rpc insert(TodoListRequest) returns (TodoListResponse); + rpc retrieve(MessageId) returns (TodoListResponse); + rpc list(google.protobuf.Empty) returns (TodoListList); + rpc update(TodoListMessage) returns (TodoListResponse); + rpc destroy(MessageId) returns (MessageId); +} + +message MessageId { int32 value = 1; } +message TodoListMessage { int32 id = 1; string title = 2; int32 tagId = 3; bool completed = 4; } +message TodoListRequest { string title = 1; int32 tagId = 2; } +message TodoListList { repeated TodoListMessage list = 1; } +message TodoListResponse { TodoListMessage msg = 1; } diff --git a/stack-nightly.yaml b/stack-nightly.yaml index ce39b919..3a5f39bc 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -10,6 +10,7 @@ packages: - grpc/server - examples/health-check - examples/route-guide +- examples/todolist - compendium-client extra-deps: diff --git a/stack.yaml b/stack.yaml index cffa065e..682288b3 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,6 +9,7 @@ packages: - grpc/server - examples/health-check - examples/route-guide +- examples/todolist - compendium-client extra-deps: From 7674ef092208a95c8c263f14f8f8f9abdd81729c Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 25 Nov 2019 14:12:30 +0100 Subject: [PATCH 008/217] Add API for exceptional error conditions (#25) --- core/rpc/mu-rpc.cabal | 7 +-- core/rpc/src/Mu/Rpc/Examples.hs | 12 ++-- core/rpc/src/Mu/Server.hs | 45 +++++++++++--- examples/health-check/src/Server.hs | 27 ++++---- .../route-guide/mu-example-route-guide.cabal | 3 +- examples/route-guide/src/Server.hs | 53 +++++++++------- examples/todolist/mu-example-todolist.cabal | 1 + examples/todolist/src/Server.hs | 33 +++++----- grpc/server/mu-grpc-server.cabal | 6 +- grpc/server/src/Mu/GRpc/Server.hs | 61 +++++++++++++------ 10 files changed, 159 insertions(+), 89 deletions(-) diff --git a/core/rpc/mu-rpc.cabal b/core/rpc/mu-rpc.cabal index 15556ea7..b1e67a1a 100644 --- a/core/rpc/mu-rpc.cabal +++ b/core/rpc/mu-rpc.cabal @@ -23,9 +23,8 @@ library Mu.Rpc.Examples -- other-modules: -- other-extensions: - build-depends: base >=4.12 && <5, sop-core, - mu-schema, conduit, text, - template-haskell + build-depends: base >=4.12 && <5, mtl, sop-core, + mu-schema, conduit, text, template-haskell hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall -fprint-potential-instances \ No newline at end of file + ghc-options: -Wall -fprint-potential-instances diff --git a/core/rpc/src/Mu/Rpc/Examples.hs b/core/rpc/src/Mu/Rpc/Examples.hs index 7e1876d2..efeee43f 100644 --- a/core/rpc/src/Mu/Rpc/Examples.hs +++ b/core/rpc/src/Mu/Rpc/Examples.hs @@ -55,14 +55,16 @@ newtype HiRequest = HiRequest { number :: Int } quickstartServer :: ServerIO QuickStartService _ quickstartServer = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0) - where sayHello :: HelloRequest -> IO HelloResponse + where sayHello :: HelloRequest -> ServerErrorIO HelloResponse sayHello (HelloRequest nm) = return (HelloResponse ("hi, " <> nm)) - sayHi :: HiRequest -> ConduitT HelloResponse Void IO () -> IO () + sayHi :: HiRequest + -> ConduitT HelloResponse Void ServerErrorIO () + -> ServerErrorIO () sayHi (HiRequest n) sink = runConduit $ C.replicate n (HelloResponse "hi!") .| sink - sayManyHellos :: ConduitT () HelloRequest IO () - -> ConduitT HelloResponse Void IO () - -> IO () + sayManyHellos :: ConduitT () HelloRequest ServerErrorIO () + -> ConduitT HelloResponse Void ServerErrorIO () + -> ServerErrorIO () sayManyHellos source sink = runConduit $ source .| C.mapM sayHello .| sink diff --git a/core/rpc/src/Mu/Server.hs b/core/rpc/src/Mu/Server.hs index 8e8fbc87..50a370df 100644 --- a/core/rpc/src/Mu/Server.hs +++ b/core/rpc/src/Mu/Server.hs @@ -29,24 +29,50 @@ module Mu.Server ( -- * Servers and handlers ServerIO, ServerT(..) , HandlersIO, HandlersT(..) + -- * Errors which might be raised +, serverError, ServerErrorIO, ServerError(..), ServerErrorCode(..) + -- ** Useful when you do not want to deal with errors +, alwaysOk ) where +import Control.Monad.Except import Data.Conduit import Data.Kind import Mu.Rpc import Mu.Schema +serverError :: ServerError -> ServerErrorIO a +serverError = throwError + +alwaysOk :: IO a -> ServerErrorIO a +alwaysOk = liftIO + +data ServerError + = ServerError ServerErrorCode String + +data ServerErrorCode + = Unknown + | Unavailable + | Unimplemented + | Unauthenticated + | Internal + | Invalid + | NotFound + deriving (Eq, Show) + +type ServerErrorIO = ExceptT ServerError IO + data ServerT (s :: Service snm mnm) (m :: Type -> Type) (hs :: [Type]) where Server :: HandlersT methods m hs -> ServerT ('Service sname anns methods) m hs -type ServerIO service = ServerT service IO +type ServerIO service = ServerT service ServerErrorIO infixr 5 :<|>: data HandlersT (methods :: [Method mnm]) (m :: Type -> Type) (hs :: [Type]) where H0 :: HandlersT '[] m '[] (:<|>:) :: Handles args ret m h => h -> HandlersT ms m hs -> HandlersT ('Method name anns args ret ': ms) m (h ': hs) -type HandlersIO methods = HandlersT methods IO +type HandlersIO methods = HandlersT methods ServerErrorIO -- Define a relation for handling class Handles (args :: [Argument]) (ret :: Return) @@ -58,15 +84,18 @@ instance HasSchema sch sty t => HandlesRef ('FromSchema sch sty) t instance HandlesRef ('FromRegistry subject t last) t -- Arguments -instance (HandlesRef ref t, Handles args ret m h, handler ~ (t -> h)) +instance (HandlesRef ref t, Handles args ret m h, + handler ~ (t -> h)) => Handles ('ArgSingle ref ': args) ret m handler -instance (HandlesRef ref t, Handles args ret m h, handler ~ (ConduitT () t IO () -> h)) +instance (MonadError ServerError m, HandlesRef ref t, Handles args ret m h, + handler ~ (ConduitT () t m () -> h)) => Handles ('ArgStream ref ': args) ret m handler -- Result with exception -instance handler ~ m () => Handles '[] 'RetNothing m handler -instance (HandlesRef eref e, HandlesRef vref v, handler ~ m (Either e v)) +instance (MonadError ServerError m, handler ~ m ()) + => Handles '[] 'RetNothing m handler +instance (MonadError ServerError m, HandlesRef eref e, HandlesRef vref v, handler ~ m (Either e v)) => Handles '[] ('RetThrows eref vref) m handler -instance (HandlesRef ref v, handler ~ m v) +instance (MonadError ServerError m, HandlesRef ref v, handler ~ m v) => Handles '[] ('RetSingle ref) m handler -instance (HandlesRef ref v, handler ~ (ConduitT v Void m () -> m ())) +instance (MonadError ServerError m, HandlesRef ref v, handler ~ (ConduitT v Void m () -> m ())) => Handles '[] ('RetStream ref) m handler diff --git a/examples/health-check/src/Server.hs b/examples/health-check/src/Server.hs index dc52f794..17987a40 100644 --- a/examples/health-check/src/Server.hs +++ b/examples/health-check/src/Server.hs @@ -33,26 +33,26 @@ server :: StatusMap -> StatusUpdates -> ServerIO HealthCheckService _ server m upd = Server (setStatus_ m upd :<|>: checkH_ m :<|>: clearStatus_ m :<|>: checkAll_ m :<|>: cleanAll_ m :<|>: watch_ upd :<|>: H0) -setStatus_ :: StatusMap -> StatusUpdates -> HealthStatusMsg -> IO () -setStatus_ m upd s@(HealthStatusMsg (HealthCheckMsg nm) (ServerStatusMsg ss)) = do +setStatus_ :: StatusMap -> StatusUpdates -> HealthStatusMsg -> ServerErrorIO () +setStatus_ m upd s@(HealthStatusMsg (HealthCheckMsg nm) (ServerStatusMsg ss)) = alwaysOk $ do putStr "setStatus: " >> print (nm, ss) atomically $ do M.insert ss nm m writeTBMChan upd s -checkH_ :: StatusMap -> HealthCheckMsg -> IO ServerStatusMsg -checkH_ m (HealthCheckMsg nm) = do +checkH_ :: StatusMap -> HealthCheckMsg -> ServerErrorIO ServerStatusMsg +checkH_ m (HealthCheckMsg nm) = alwaysOk $ do putStr "check: " >> print nm ss <- atomically $ M.lookup nm m return $ ServerStatusMsg (fromMaybe "UNKNOWN" ss) -clearStatus_ :: StatusMap -> HealthCheckMsg -> IO () -clearStatus_ m (HealthCheckMsg nm) = do +clearStatus_ :: StatusMap -> HealthCheckMsg -> ServerErrorIO () +clearStatus_ m (HealthCheckMsg nm) = alwaysOk $ do putStr "clearStatus: " >> print nm atomically $ M.delete nm m -checkAll_ :: StatusMap -> IO AllStatusMsg -checkAll_ m = do +checkAll_ :: StatusMap -> ServerErrorIO AllStatusMsg +checkAll_ m = alwaysOk $ do putStrLn "checkAll" AllStatusMsg <$> atomically (consumeValues kvToStatus (M.unfoldlM m)) where @@ -60,14 +60,17 @@ checkAll_ m = do consumeValues f = foldlM' (\xs (x,y) -> pure (f x y:xs)) [] kvToStatus k v = HealthStatusMsg (HealthCheckMsg k) (ServerStatusMsg v) -cleanAll_ :: StatusMap -> IO () -cleanAll_ m = do +cleanAll_ :: StatusMap -> ServerErrorIO () +cleanAll_ m = alwaysOk $ do putStrLn "cleanAll" atomically $ M.reset m -watch_ :: StatusUpdates -> HealthCheckMsg -> ConduitT ServerStatusMsg Void IO () -> IO () +watch_ :: StatusUpdates + -> HealthCheckMsg + -> ConduitT ServerStatusMsg Void ServerErrorIO () + -> ServerErrorIO () watch_ upd hcm@(HealthCheckMsg nm) sink = do - putStr "watch: " >> print nm + alwaysOk (putStr "watch: " >> print nm) runConduit $ sourceTBMChan upd .| C.filter (\(HealthStatusMsg c _) -> hcm == c) .| C.map (\(HealthStatusMsg _ s) -> s) diff --git a/examples/route-guide/mu-example-route-guide.cabal b/examples/route-guide/mu-example-route-guide.cabal index a05ebc06..a4c4dd61 100644 --- a/examples/route-guide/mu-example-route-guide.cabal +++ b/examples/route-guide/mu-example-route-guide.cabal @@ -32,7 +32,8 @@ executable route-guide-server mu-schema, mu-rpc, mu-protobuf, mu-grpc-server, stm, stm-chans, hashable, - conduit, AC-Angle, time, async + conduit, AC-Angle, time, async, + transformers hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/examples/route-guide/src/Server.hs b/examples/route-guide/src/Server.hs index a88e82c3..57a74f3c 100644 --- a/examples/route-guide/src/Server.hs +++ b/examples/route-guide/src/Server.hs @@ -7,10 +7,11 @@ module Main where import Control.Concurrent.Async import Control.Concurrent.STM import Control.Concurrent.STM.TBMChan -import Control.Monad.IO.Class (liftIO) +import Control.Monad.IO.Class (MonadIO, liftIO) import Data.Angle import Data.Conduit import qualified Data.Conduit.Combinators as C +import Data.Conduit.Lift (runExceptC) import Data.Conduit.List (sourceList) import Data.Function ((&)) import Data.Int @@ -66,47 +67,57 @@ server :: Features -> TBMChan RouteNote -> ServerIO RouteGuideService _ server f m = Server (getFeature f :<|>: listFeatures f :<|>: recordRoute f :<|>: routeChat m :<|>: H0) -getFeature :: Features -> Point -> IO Feature +getFeature :: Features -> Point -> ServerErrorIO Feature getFeature fs p = return $ fromMaybe (Feature "" (Point 0 0)) (findFeatureIn fs p) -listFeatures :: Features -> Rectangle -> ConduitT Feature Void IO () -> IO () +listFeatures :: Features -> Rectangle + -> ConduitT Feature Void ServerErrorIO () + -> ServerErrorIO () listFeatures fs rect result = runConduit $ sourceList (featuresWithinBounds fs rect) .| result -recordRoute :: Features -> ConduitT () Point IO () -> IO RouteSummary +recordRoute :: Features + -> ConduitT () Point ServerErrorIO () + -> ServerErrorIO RouteSummary recordRoute fs ps = do - initialTime <- getCurrentTime - (rs, _, _) <- runConduit $ ps .| C.foldM step (RouteSummary 0 0 0 0, Nothing, initialTime) - return rs + initialTime <- liftIO getCurrentTime + (\(rs, _, _) -> rs) <$> runConduit (ps .| C.foldM step (RouteSummary 0 0 0 0, Nothing, initialTime)) where - step :: (RouteSummary, Maybe Point, UTCTime) -> Point -> IO (RouteSummary, Maybe Point, UTCTime) + step :: (RouteSummary, Maybe Point, UTCTime) -> Point + -> ServerErrorIO (RouteSummary, Maybe Point, UTCTime) step (summary, previous, startTime) point = do - currentTime <- getCurrentTime + currentTime <- liftIO getCurrentTime let feature = findFeatureIn fs point new_distance = fmap (`calcDistance` point) previous & fromMaybe 0 new_elapsed = diffUTCTime currentTime startTime new_summary = RouteSummary (point_count summary + 1) - (feature_count summary + if isJust feature then 1 else 0) - (distance summary + new_distance) - (floor new_elapsed) + (feature_count summary + if isJust feature then 1 else 0) + (distance summary + new_distance) + (floor new_elapsed) return (new_summary, Just point, startTime) routeChat :: TBMChan RouteNote - -> ConduitT () RouteNote IO () -> ConduitT RouteNote Void IO () -> IO () + -> ConduitT () RouteNote ServerErrorIO () + -> ConduitT RouteNote Void ServerErrorIO () + -> ServerErrorIO () routeChat notesMap inS outS = do - toWatch <- newEmptyTMVarIO + toWatch <- liftIO newEmptyTMVarIO -- Start two threads, one to listen, one to send - inA <- async $ runConduit $ inS .| C.mapM_ (addNoteToMap toWatch) - outA <- async $ runConduit $ readStmMap (\l1 (RouteNote _ l2)-> l1 == l2) toWatch notesMap .| outS - wait inA - wait outA + let inA = runConduit $ runExceptC $ inS .| C.mapM_ (addNoteToMap toWatch) + outA = runConduit $ runExceptC $ + readStmMap (\l1 (RouteNote _ l2)-> l1 == l2) toWatch notesMap .| outS + res <- liftIO $ concurrently inA outA + case res of + (Right _, Right _) -> return () + (Left e, _) -> serverError e + (_, Left e) -> serverError e where - addNoteToMap :: TMVar Point -> RouteNote -> IO () - addNoteToMap toWatch newNote@(RouteNote _ loc) = atomically $ do + addNoteToMap :: TMVar Point -> RouteNote -> ServerErrorIO () + addNoteToMap toWatch newNote@(RouteNote _ loc) = liftIO $ atomically $ do _ <- tryTakeTMVar toWatch putTMVar toWatch loc writeTBMChan notesMap newNote -readStmMap :: Show b => (a -> b -> Bool) -> TMVar a -> TBMChan b -> ConduitT () b IO () +readStmMap :: (MonadIO m, Show b) => (a -> b -> Bool) -> TMVar a -> TBMChan b -> ConduitT () b m () readStmMap p toWatch m = go where go = do diff --git a/examples/todolist/mu-example-todolist.cabal b/examples/todolist/mu-example-todolist.cabal index 9bcde71f..7adf61f9 100644 --- a/examples/todolist/mu-example-todolist.cabal +++ b/examples/todolist/mu-example-todolist.cabal @@ -38,6 +38,7 @@ executable todolist-server , mu-grpc-server , stm , text + , transformers hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall diff --git a/examples/todolist/src/Server.hs b/examples/todolist/src/Server.hs index add39aba..cf2c4d26 100644 --- a/examples/todolist/src/Server.hs +++ b/examples/todolist/src/Server.hs @@ -6,9 +6,9 @@ module Main where import Control.Concurrent.STM +import Control.Monad.IO.Class (liftIO) import Data.Int import Data.List (find) -import Data.Maybe (fromMaybe) import Mu.GRpc.Server import Mu.Server @@ -33,16 +33,16 @@ server :: Id -> TodoList -> ServerIO TodoListService _ server i t = Server (reset i t :<|>: insert i t :<|>: retrieve t :<|>: list_ t :<|>: update t :<|>: destroy t :<|>: H0) -reset :: Id -> TodoList -> IO MessageId -reset i t = do +reset :: Id -> TodoList -> ServerErrorIO MessageId +reset i t = alwaysOk $ do putStrLn "reset" atomically $ do writeTVar i 0 writeTVar t [] pure $ MessageId 0 -- returns nothing -insert :: Id -> TodoList -> TodoListRequest -> IO TodoListResponse -insert oldId t (TodoListRequest titl tgId) = do +insert :: Id -> TodoList -> TodoListRequest -> ServerErrorIO TodoListResponse +insert oldId t (TodoListRequest titl tgId) = alwaysOk $ do putStr "insert: " >> print (titl, tgId) atomically $ do modifyTVar oldId (+1) @@ -54,28 +54,29 @@ insert oldId t (TodoListRequest titl tgId) = do getMsg :: Int32 -> TodoListMessage -> Bool getMsg x TodoListMessage {id} = id == x -retrieve :: TodoList -> MessageId -> IO TodoListResponse +retrieve :: TodoList -> MessageId -> ServerErrorIO TodoListResponse retrieve t (MessageId idMsg) = do - putStr "retrieve: " >> print idMsg - todos <- readTVarIO t - let todo = fromMaybe (TodoListMessage 0 0 "I don't know" False) (find (getMsg idMsg) todos) - pure $ TodoListResponse todo -- FIXME: what if it's not found? + liftIO (putStr "retrieve: " >> print idMsg) + todos <- liftIO $ readTVarIO t + case find (getMsg idMsg) todos of + Just todo -> pure $ TodoListResponse todo + Nothing -> serverError $ ServerError NotFound "unknown todolist id" -list_ :: TodoList -> IO TodoListList -list_ t = do +list_ :: TodoList -> ServerErrorIO TodoListList +list_ t = alwaysOk $ do putStrLn "list" atomically $ do todos <- readTVar t pure $ TodoListList todos -update :: TodoList -> TodoListMessage -> IO TodoListResponse -update t mg@(TodoListMessage idM titM tgM compl) = do +update :: TodoList -> TodoListMessage -> ServerErrorIO TodoListResponse +update t mg@(TodoListMessage idM titM tgM compl) = alwaysOk $ do putStr "update: " >> print (idM, titM, tgM, compl) atomically $ modifyTVar t $ fmap (\m -> if getMsg idM m then mg else m) pure $ TodoListResponse mg -destroy :: TodoList -> MessageId -> IO MessageId -destroy t (MessageId idMsg) = do +destroy :: TodoList -> MessageId -> ServerErrorIO MessageId +destroy t (MessageId idMsg) = alwaysOk $ do putStr "destroy: " >> print idMsg atomically $ do todos <- readTVar t diff --git a/grpc/server/mu-grpc-server.cabal b/grpc/server/mu-grpc-server.cabal index 17f95f44..3481061b 100644 --- a/grpc/server/mu-grpc-server.cabal +++ b/grpc/server/mu-grpc-server.cabal @@ -21,7 +21,7 @@ library exposed-modules: Mu.GRpc.Server -- other-extensions: build-depends: base >=4.12 && <5, sop-core, - bytestring, async, + bytestring, async, mtl, mu-schema, mu-rpc, mu-protobuf, warp, warp-grpc, wai, warp-tls, http2-grpc-types, http2-grpc-proto3-wire, @@ -34,11 +34,11 @@ executable grpc-example-server main-is: ExampleServer.hs other-modules: Mu.GRpc.Server build-depends: base >=4.12 && <5, sop-core, - bytestring, async, + bytestring, async, mtl, mu-schema, mu-rpc, mu-protobuf, warp, warp-grpc, wai, warp-tls, http2-grpc-types, http2-grpc-proto3-wire, conduit, stm, stm-conduit hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall \ No newline at end of file + ghc-options: -Wall diff --git a/grpc/server/src/Mu/GRpc/Server.hs b/grpc/server/src/Mu/GRpc/Server.hs index 7fc740dd..8a032e2d 100644 --- a/grpc/server/src/Mu/GRpc/Server.hs +++ b/grpc/server/src/Mu/GRpc/Server.hs @@ -21,7 +21,7 @@ module Mu.GRpc.Server ( import Control.Concurrent.Async import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TMVar -import Control.Monad.IO.Class +import Control.Monad.Except import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS import Data.Conduit @@ -30,6 +30,7 @@ import Data.Kind import Data.Proxy import Network.GRPC.HTTP2.Encoding (gzip, uncompressed) import Network.GRPC.HTTP2.Proto3Wire +import Network.GRPC.HTTP2.Types (GRPCStatus(..), GRPCStatusCode (..)) import Network.GRPC.Server.Handlers import Network.GRPC.Server.Wai (ServiceHandler) import Network.GRPC.Server.Wai as Wai @@ -109,42 +110,62 @@ instance (KnownName name, GRpcMethodHandler args r h, GRpcMethodHandlers rest hs class GRpcMethodHandler args r h where gRpcMethodHandler :: Proxy args -> Proxy r -> RPC -> h -> ServiceHandler -instance GRpcMethodHandler '[ ] 'RetNothing (IO ()) where +raiseErrors :: ServerErrorIO a -> IO a +raiseErrors h + = do h' <- runExceptT h + case h' of + Right r -> return r + Left (ServerError code msg) + -> closeEarly $ GRPCStatus (serverErrorToGRpcError code) + (BS.pack msg) + where + serverErrorToGRpcError :: ServerErrorCode -> GRPCStatusCode + serverErrorToGRpcError Unknown = UNKNOWN + serverErrorToGRpcError Unavailable = UNAVAILABLE + serverErrorToGRpcError Unimplemented = UNIMPLEMENTED + serverErrorToGRpcError Unauthenticated = UNAUTHENTICATED + serverErrorToGRpcError Internal = INTERNAL + serverErrorToGRpcError NotFound = NOT_FOUND + serverErrorToGRpcError Invalid = INVALID_ARGUMENT + +instance GRpcMethodHandler '[ ] 'RetNothing (ServerErrorIO ()) where gRpcMethodHandler _ _ rpc h - = unary @_ @() @() rpc (\_ _ -> h) + = unary @_ @() @() rpc (\_ _ -> raiseErrors h) instance (ProtoBufTypeRef rref r) - => GRpcMethodHandler '[ ] ('RetSingle rref) (IO r) where + => GRpcMethodHandler '[ ] ('RetSingle rref) (ServerErrorIO r) where gRpcMethodHandler _ _ rpc h = unary @_ @() @(ViaProtoBufTypeRef rref r) - rpc (\_ _ -> ViaProtoBufTypeRef <$> h) + rpc (\_ _ -> ViaProtoBufTypeRef <$> raiseErrors h) instance (ProtoBufTypeRef vref v) - => GRpcMethodHandler '[ 'ArgSingle vref ] 'RetNothing (v -> IO ()) where + => GRpcMethodHandler '[ 'ArgSingle vref ] 'RetNothing (v -> ServerErrorIO ()) where gRpcMethodHandler _ _ rpc h = unary @_ @(ViaProtoBufTypeRef vref v) @() - rpc (\_ -> h . unViaProtoBufTypeRef) + rpc (\_ -> raiseErrors . h . unViaProtoBufTypeRef) instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) => GRpcMethodHandler '[ 'ArgSingle vref ] ('RetSingle rref) - (v -> IO r) where + (v -> ServerErrorIO r) where gRpcMethodHandler _ _ rpc h = unary @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) - rpc (\_ -> (ViaProtoBufTypeRef <$>) . h . unViaProtoBufTypeRef) + rpc (\_ -> (ViaProtoBufTypeRef <$>) . raiseErrors . h . unViaProtoBufTypeRef) instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) => GRpcMethodHandler '[ 'ArgStream vref ] ('RetSingle rref) - (ConduitT () v IO () -> IO r) where + (ConduitT () v ServerErrorIO () -> ServerErrorIO r) where gRpcMethodHandler _ _ rpc h = clientStream @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) rpc cstream - where cstream :: req -> IO ((), ClientStream (ViaProtoBufTypeRef vref v) (ViaProtoBufTypeRef rref r) ()) + where cstream :: req + -> IO ((), ClientStream (ViaProtoBufTypeRef vref v) + (ViaProtoBufTypeRef rref r) ()) cstream _ = do -- Create a new TMChan chan <- newTMChanIO :: IO (TMChan v) - let producer = sourceTMChan @IO chan + let producer = sourceTMChan @ServerErrorIO chan -- Start executing the handler in another thread - promise <- async (ViaProtoBufTypeRef <$> h producer) + promise <- async (raiseErrors $ ViaProtoBufTypeRef <$> h producer) -- Build the actual handler let cstreamHandler _ (ViaProtoBufTypeRef newInput) = atomically (writeTMChan chan newInput) @@ -155,7 +176,7 @@ instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) => GRpcMethodHandler '[ 'ArgSingle vref ] ('RetStream rref) - (v -> ConduitT r Void IO () -> IO ()) where + (v -> ConduitT r Void ServerErrorIO () -> ServerErrorIO ()) where gRpcMethodHandler _ _ rpc h = serverStream @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) rpc sstream @@ -165,7 +186,7 @@ instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) -- Variable to connect input and output var <- newEmptyTMVarIO :: IO (TMVar (Maybe r)) -- Start executing the handler - promise <- async (ViaProtoBufTypeRef <$> h v (toTMVarConduit var)) + promise <- async (raiseErrors $ ViaProtoBufTypeRef <$> h v (toTMVarConduit var)) -- Return the information let readNext _ = do nextOutput <- atomically $ takeTMVar var @@ -177,7 +198,9 @@ instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) => GRpcMethodHandler '[ 'ArgStream vref ] ('RetStream rref) - (ConduitT () v IO () -> ConduitT r Void IO () -> IO ()) where + (ConduitT () v ServerErrorIO () + -> ConduitT r Void ServerErrorIO () + -> ServerErrorIO ()) where gRpcMethodHandler _ _ rpc h = generalStream @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) rpc bdstream @@ -186,10 +209,10 @@ instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) bdstream _ = do -- Create a new TMChan and a new variable chan <- newTMChanIO :: IO (TMChan v) - let producer = sourceTMChan @IO chan + let producer = sourceTMChan @ServerErrorIO chan var <- newEmptyTMVarIO :: IO (TMVar (Maybe r)) -- Start executing the handler - promise <- async (h producer (toTMVarConduit var)) + promise <- async (raiseErrors $ h producer (toTMVarConduit var)) -- Build the actual handler let cstreamHandler _ (ViaProtoBufTypeRef newInput) = atomically (writeTMChan chan newInput) @@ -207,7 +230,7 @@ instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) readNext () return ((), IncomingStream cstreamHandler cstreamFinalizer, (), OutgoingStream readNext) -toTMVarConduit :: TMVar (Maybe r) -> ConduitT r Void IO () +toTMVarConduit :: MonadIO m => TMVar (Maybe r) -> ConduitT r Void m () toTMVarConduit var = do x <- await liftIO $ atomically $ putTMVar var x From 5a7b55f4def032009ab8a587400a54174af602e4 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 2 Dec 2019 15:16:48 +0100 Subject: [PATCH 009/217] Allow a wider range of types to stand for unions --- core/schema/src/Mu/Schema/Class.hs | 45 ++++++++++++++++++++++++++++-- 1 file changed, 43 insertions(+), 2 deletions(-) diff --git a/core/schema/src/Mu/Schema/Class.hs b/core/schema/src/Mu/Schema/Class.hs index 510967f9..8523e7d6 100644 --- a/core/schema/src/Mu/Schema/Class.hs +++ b/core/schema/src/Mu/Schema/Class.hs @@ -4,7 +4,6 @@ {-# language FlexibleInstances #-} {-# language FunctionalDependencies #-} {-# language GADTs #-} -{-# language MultiParamTypeClasses #-} {-# language PolyKinds #-} {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} @@ -141,6 +140,10 @@ class GSchemaFieldType (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where toSchemaFieldType :: f -> FieldValue sch t fromSchemaFieldType :: FieldValue sch t -> f +class GSchemaFieldTypeUnion (sch :: Schema ts fs) (t :: [FieldType ts]) (f :: * -> *) where + toSchemaFieldTypeUnion :: f a -> NS (FieldValue sch) t + fromSchemaFieldTypeUnion :: NS (FieldValue sch) t -> f a + -- These instances are straightforward, -- just turn the "real types" into their -- schema correspondants. @@ -170,7 +173,8 @@ instance (GSchemaFieldType sch sk hk, GSchemaFieldType sch sv hv, -- This assumes that a union is represented by -- a value of type 'NS', where types are in -- the same order. -instance AllZip (GSchemaFieldType sch) ts vs +instance {-# OVERLAPS #-} + AllZip (GSchemaFieldType sch) ts vs => GSchemaFieldType sch ('TUnion ts) (NS I vs) where toSchemaFieldType t = FUnion (go t) where go :: AllZip (GSchemaFieldType sch) tss vss @@ -182,6 +186,43 @@ instance AllZip (GSchemaFieldType sch) ts vs => NS (FieldValue sch) tss -> NS I vss go (Z x) = Z (I (fromSchemaFieldType x)) go (S n) = S (go n) +-- But we can also use any other if it has +-- the right structure +instance {-# OVERLAPPABLE #-} + (Generic f, GSchemaFieldTypeUnion sch ts (Rep f)) + => GSchemaFieldType sch ('TUnion ts) f where + toSchemaFieldType x = FUnion (toSchemaFieldTypeUnion (from x)) + fromSchemaFieldType (FUnion x) = to (fromSchemaFieldTypeUnion x) + +-- This is not 100% correct, we could have +-- GSchemaFieldTypeUnion sch '[] U1 +-- But we would need overlappable instances for that matter +-- and also: who is going to define an empty union? +instance TypeError ('Text "the type does not match the union") + => GSchemaFieldTypeUnion sch '[] f where + toSchemaFieldTypeUnion = error "this should never happen" + fromSchemaFieldTypeUnion = error "this should never happen" + +instance (GSchemaFieldType sch t v) + => GSchemaFieldTypeUnion sch '[t] (K1 i v) where + toSchemaFieldTypeUnion (K1 x) = Z (toSchemaFieldType x) + fromSchemaFieldTypeUnion (Z x) = K1 (fromSchemaFieldType x) +instance (GSchemaFieldType sch t v, GSchemaFieldTypeUnion sch ts vs) + => GSchemaFieldTypeUnion sch (t ': ts) (K1 i v :+: vs) where + toSchemaFieldTypeUnion (L1 (K1 x)) = Z (toSchemaFieldType x) + toSchemaFieldTypeUnion (R1 r) = S (toSchemaFieldTypeUnion r) + fromSchemaFieldTypeUnion (Z x) = L1 (K1 (fromSchemaFieldType x)) + fromSchemaFieldTypeUnion (S r) = R1 (fromSchemaFieldTypeUnion r) +-- Weird nested instance produced by GHC +instance (GSchemaFieldType sch t1 v1, GSchemaFieldType sch t2 v2, GSchemaFieldTypeUnion sch ts vs) + => GSchemaFieldTypeUnion sch (t1 ': t2 ': ts) ((K1 i v1 :+: K1 i v2) :+: vs) where + toSchemaFieldTypeUnion (L1 (L1 (K1 x))) = Z (toSchemaFieldType x) + toSchemaFieldTypeUnion (L1 (R1 (K1 x))) = S (Z (toSchemaFieldType x)) + toSchemaFieldTypeUnion (R1 r) = S (S (toSchemaFieldTypeUnion r)) + fromSchemaFieldTypeUnion (Z x) = L1 (L1 (K1 (fromSchemaFieldType x))) + fromSchemaFieldTypeUnion (S (Z x)) = L1 (R1 (K1 (fromSchemaFieldType x))) + fromSchemaFieldTypeUnion (S (S r)) = R1 (fromSchemaFieldTypeUnion r) + -- --------------- -- ENUMERATIONS -- From 152648a564ba049528d4107c9b3b2ce8b5ba8ee6 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Tue, 3 Dec 2019 14:45:21 +0100 Subject: [PATCH 010/217] Documentation refactor and improvements (#26) --- README.md | 17 ++-- core/rpc/mu-rpc.cabal | 2 +- core/schema/mu-schema.cabal | 4 +- docs/README.md | 11 +++ docs/grpc.md | 17 ++++ docs/intro.md | 94 +++++++++++++++++++++ docs/middleware.md | 1 + docs/registry.md | 22 +++++ core/rpc/README.md => docs/rpc.md | 75 +---------------- core/schema/README.md => docs/schema.md | 26 ++---- docs/stream.md | 40 +++++++++ examples/todolist/src/Definition.hs | 1 - templates/grpc-server.hsfiles | 104 ++++++++++++++++++++++++ 13 files changed, 312 insertions(+), 102 deletions(-) create mode 100644 docs/README.md create mode 100644 docs/grpc.md create mode 100644 docs/intro.md create mode 100644 docs/middleware.md create mode 100644 docs/registry.md rename core/rpc/README.md => docs/rpc.md (61%) rename core/schema/README.md => docs/schema.md (85%) create mode 100644 docs/stream.md create mode 100644 templates/grpc-server.hsfiles diff --git a/README.md b/README.md index 832a7319..89e1056f 100644 --- a/README.md +++ b/README.md @@ -1,16 +1,15 @@ # Mu for Haskell -This repo defines a set of libraries which implement a similar functionality to [Mu for Scala](http://higherkindness.io/mu/), but in Haskell. +[![Build Status](https://travis-ci.com/higherkindness/mu-haskell.svg?branch=master)](https://travis-ci.com/higherkindness/mu-haskell) -* [`mu-schema`](https://github.com/higherkindness/mu-haskell/tree/master/schema) defines schemas for messages and conversion from and to Avro, Protocol Buffers, and JSON. -* [`mu-rpc`](https://github.com/higherkindness/mu-haskell/tree/master/rpc) defines schemas for service APIs, and the notion of a server for one such API. -* [`mu-grpc`](https://github.com/higherkindness/mu-haskell/tree/master/grpc) serves a `mu-rpc` server using gRPC. +This repo defines a set of libraries to write microservices in a format- and protocol-independent way. It shares the same goals as [Mu for Scala](http://higherkindness.io/mu/), but using idiomatic Haskell and more type-level techniques. -Each library contains a brief tutorial on how to use it. But if you want to see some examples, here they are: - -* [Haskell definition](https://github.com/higherkindness/mu-haskell/blob/master/schema/src/Mu/Schema/Examples.hs) of schemas corresponding to this [Avro](https://github.com/higherkindness/mu-haskell/blob/master/schema/test/avro/example.avsc) and [Protocol Buffers](https://github.com/higherkindness/mu-haskell/blob/master/schema/test/protobuf/example.proto) files. -* [Haskell definition and implementation](https://github.com/higherkindness/mu-haskell/blob/master/rpc/src/Mu/Rpc/Examples.hs) of a server corresponding to this [gRPC API](https://github.com/higherkindness/mu-haskell/blob/master/grpc/test/helloworld.proto). +## [Documentation](docs) ## Building -This set of libraries are thought to be built using [Stack](https://docs.haskellstack.org). Just jump into the folder and run `stack build`! The top-level `stack.yaml` defines a common resolver and set of dependencies for all the packages. \ No newline at end of file +This set of libraries are thought to be built using [Stack](https://docs.haskellstack.org). Just jump into the folder and run `stack build`! The top-level `stack.yaml` defines a common resolver and set of dependencies for all the packages. + +## Contributing + +If you want to contribute, please be sure to read the [development guidelines](DEVELOPMENT.md) first. diff --git a/core/rpc/mu-rpc.cabal b/core/rpc/mu-rpc.cabal index b1e67a1a..62891ecb 100644 --- a/core/rpc/mu-rpc.cabal +++ b/core/rpc/mu-rpc.cabal @@ -15,7 +15,7 @@ maintainer: alejandro.serrano@47deg.com -- copyright: category: Network build-type: Simple -extra-source-files: README.md, CHANGELOG.md +extra-source-files: CHANGELOG.md library exposed-modules: Mu.Rpc, diff --git a/core/schema/mu-schema.cabal b/core/schema/mu-schema.cabal index eb1531a0..d4eca225 100644 --- a/core/schema/mu-schema.cabal +++ b/core/schema/mu-schema.cabal @@ -15,7 +15,7 @@ maintainer: alejandro.serrano@47deg.com -- copyright: category: Network build-type: Simple -extra-source-files: README.md, CHANGELOG.md +extra-source-files: CHANGELOG.md library exposed-modules: Mu.Schema @@ -45,4 +45,4 @@ library hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall - -fprint-potential-instances \ No newline at end of file + -fprint-potential-instances diff --git a/docs/README.md b/docs/README.md new file mode 100644 index 00000000..41e5a88f --- /dev/null +++ b/docs/README.md @@ -0,0 +1,11 @@ +# Docs for Mu-Haskell + +Mu-Haskell is a set of packages that help you build both servers and clients for (micro)services. The main goal of Mu-Haskell is to make you focus on your domain logic, instead of worrying about format and protocol issues. + +* [Introduction](intro.md) +* [Schemas](schema.md) +* [Services and servers](rpc.md) + * [gRPC servers and clients](grpc.md) + * [Streams](stream.md) + * [WAI Middleware](middleware.md) +* [Registry](registry.md) diff --git a/docs/grpc.md b/docs/grpc.md new file mode 100644 index 00000000..6863378e --- /dev/null +++ b/docs/grpc.md @@ -0,0 +1,17 @@ +# gRPC servers and clients + +Mu-Haskell defines a generic notion of service and server that implements it. This generic server can then be used by `mu-grpc-server`, to provide a concrete implementation using a specific wire format. Or you can use `mu-grpc-client` to build a client. + +## Running the server with `mu-grpc` + +The combination of the declaration of a service API and a corresponding implementation as a `Server` may served directly using a concrete wire protocol. One example is gRPC, provided by our sibling library `mu-grpc`. The following line starts a server at port `8080`, where the service can be found under the package name `helloworld`: + +```haskell +main = runGRpcApp 8080 "helloworld" quickstartServer +``` + +## Building a client + +### Using records + +### Using `TypeApplications` diff --git a/docs/intro.md b/docs/intro.md new file mode 100644 index 00000000..331d6e1e --- /dev/null +++ b/docs/intro.md @@ -0,0 +1,94 @@ +# Introduction to Mu-Haskell + +## What is Mu-Haskell? + +The main goal of Mu-Haskell is to make you focus on your domain logic, instead of worrying about format and protocol issues. To achieve this goal, Mu-Haskell provides two sets of packages: + +* `mu-schema` and `mu-rpc` define schemas for data and services, in a format- and protocol-independent way. These schemas are checked at compile-time, so you also gain an additional layer of type-safety. +* `mu-avro`, `mu-protobuf`, `mu-grpc` (and other to come) implement each concrete format and protocol, following the interfaces laid out by the former two. In addition, most of those packages can turn a schema in the corresponding format into the corresponding one in `mu-schema` and `mu-rpc` terms, alleviating you from the need of duplicating definitions. + +## Quickstart + +### Super-quick summary + +1. Create a new project with `stack new my-project url-to-hsfile`. +2. Define your schema and your services in the `.proto` file. +3. Write your Haskell data types in `src/Schema.hs`. +4. Implement the server in `src/Main.hs`. + +### Step by step + +As an appetizer we are going to develop the same service as in the [gRPC Quickstart Guide](https://grpc.io/docs/quickstart/). The service is defined as a `.proto` file, which includes the schema for the messages and the signature for the methods in the service: + +```java +service Service { + rpc SayHello (HelloRequest) returns (HelloReply) {} +} + +message HelloRequest { string name = 1; } +message HelloReply { string message = 1; } +``` + +To get started with the project, we provide a [Stack](https://docs.haskellstack.org) template (in fact, we recommend that you use Stack as your build tool, although Cabal should also work perfectly fine). You should run: + +``` +stack new my-project url-to-hsfile +``` + +This command creates a new folder called `my-project`, with a few files. The most important from those are the `.proto` file, in which you shall declare your service; `src/Schema.hs`, which loads the service definition at compile-time; and `src/Main.hs`, which contains the code of the server. + +The first step to get your project running is defining the right schema and service. In this case, you can just copy the definition above after the `package` declaration. + +#### Data type definition + +The second step is to define some Haskell data type corresponding to the message types in the gRPC definition. Although in some cases those data types can be inferred from the schema itself, we have made the design choice of having to write them explicitly, but check for compatibility at compile-time. The main goal is to discourage from making your domain types simple copies of the protocol types. + +The aforementioned `.proto` file defines two messages. The corresponding data types are as follows: + +```haskell +data HelloRequestMessage + = HelloRequestMessage { name :: T.Text } + deriving (Eq, Show, Generic, HasSchema Schema "HelloRequest") + +data HelloReplyMessage + = HelloReplyMessage { message :: T.Text } + deriving (Eq, Show, Generic, HasSchema Schema "HelloReply") +``` + +You can give those data types and their constructors any name you like. However, keep in mind that: + +* The names of the fields must correspond with those in the `.proto` files. Otherwise you have to use a *custom mapping*, which is fully supported by `mu-schema` but requires more code. +* The name between quotes in each `deriving` clause defines the message type in the `.proto` file each data type corresponds to. +* To use the automatic-mapping functionality, it is required to also derive `Generic`, don't forget it! + +#### Server implementation + +If you try to compile the project right now by means of `stack build`, you will receive an error about `server` not having the right type. This is because you haven't defined yet any implementation for your service. This is one of the advantages of making the compiler aware of your service definitions: if the `.proto` file changes, you need to adapt your code correspondingly, or otherwise the project doesn't even compile! + +Open the `src/Main.hs` file. The contents are quite small right now: a `main` function asks to run the gRPC service defined by `server`. The `server` function, on the other hand, declares that it implements the `Service` service in its signature, but contains no implementations. + +```haskell +main :: IO () +main = runGRpcApp 8080 server + +server :: ServerIO Service _ +server = Server H0 +``` + +The simplest way to provide an implementation for a service is to define one function for each method. You define those functions completely in terms of Haskell data types; in our case `HelloRequestMessage` and `HelloReplyMessage`. Here is a simple definition: + +```haskell +sayHello :: HelloRequestMessage -> ServerErrorIO HelloReplyMessage +sayHello (HelloRequestMessage nm) + = return $ HelloReplyMessage ("hello, " ++ nm) +``` + +The `ServerErrorIO` portion in the type is mandated by `mu-grpc-server`; it tells us that in a method we can perform any `IO` actions and additionally throw server errors (for conditions such as *not found*). We do not make use of any of those here, so we simply use `return` with a value. + +How does `server` know that `sayHello` is part of the implementation of the service? We have to tell it, by adding `sayHello` to the list of methods. Unfortunately, we cannot use a simple lists, so we use `(:<|>:)` to join them, and `H0` to finish it. + +```haskell +server = Server (sayHello :<|>: H0) +``` + +At this point you can build the project using `stack build`, and then execute via `stack run`. This spawns a gRPC server at port 8080, which you can test using applications such as [BloomRPC](https://github.com/uw-labs/bloomrpc). diff --git a/docs/middleware.md b/docs/middleware.md new file mode 100644 index 00000000..4d305966 --- /dev/null +++ b/docs/middleware.md @@ -0,0 +1 @@ +# Integration with WAI middleware diff --git a/docs/registry.md b/docs/registry.md new file mode 100644 index 00000000..72403d50 --- /dev/null +++ b/docs/registry.md @@ -0,0 +1,22 @@ +# Registry + +Schemas evolve over time. It is a good practice to keep an inventory of all the schemas you can work with, in the form of a *registry*. Using `mu-schema` you can declare one such registry as simply a mapping from versions to schemas: + +```haskell +type ExampleRegistry + = '[ 2 ':-> ExampleSchemaV2, 1 ':-> ExampleSchema ] +``` + +Once we have done that you can use functions like `fromRegistry` to try to parse a term into a Haskell type by trying each of the schemas. + +## Using the Registry + +By default, [service definition](rpc.md) talks about concrete schemas and types. If you define a registry, you can also use it to accomodate different schemas. In this case, apart from the registry itself, we need to specify the *Haskell* type to use during (de)serialization, and the *version number* to use for serialization. + +```haskell +type QuickstartService + = 'Service "Greeter" + '[ 'Method "SayHello" + '[ 'ArgSingle ('FromRegistry ExampleRegistry HelloRequest 2) ] + ('RetSingle ('FromRegistry ExampleRegistry HelloResponse 1)) ] +``` diff --git a/core/rpc/README.md b/docs/rpc.md similarity index 61% rename from core/rpc/README.md rename to docs/rpc.md index caf42cf3..b596eab0 100644 --- a/core/rpc/README.md +++ b/docs/rpc.md @@ -1,8 +1,6 @@ -# `mu-rpc`: protocol-independent declaration of services and servers +# Services and servers -There are several formats in the wild used to declare service APIs, including [Avro IDL](https://avro.apache.org/docs/current/idl.html), [gRPC](https://grpc.io/), and [OpenAPI](https://swagger.io/specification/). `mu-rpc` abstract the commonalities into a single type-level format for declaring these services, building on the format-independent schema facilities of `mu-schema`. - -In addition, this package provides a generic notion of *server* of a service. One such server defines one behavior for each method in the service, but does not bother with (de)serialization mechanisms. This generic server can then be used by other packages, such as `mu-grpc`, to provide a concrete implementation using a specific wire format. +There are several formats in the wild used to declare service APIs, including [Avro IDL](https://avro.apache.org/docs/current/idl.html), [gRPC](https://grpc.io/), and [OpenAPI](https://swagger.io/specification/). `mu-rpc` abstract the commonalities into a single type-level format for declaring these services, building on the format-independent schema facilities of `mu-schema`. In addition, this package provides a generic notion of *server* of a service. One such server defines one behavior for each method in the service, but does not bother with (de)serialization mechanisms. ## Importing the schema and the service @@ -88,7 +86,7 @@ Note that depending on the concrete implementation you use to run the server, on In order to implement the service, you have to define the behavior of each method by means of a *handler*. You can use Haskell types for your handlers, given that you had previously declared that they can be mapped back and forth the schema types using `HasSchema`. For example, the following is a handler for the `SayHello` method in `Greeter`: ```haskell -sayHello :: HelloRequest -> IO HelloResponse +sayHello :: HelloRequest -> ServerErrorIO HelloResponse sayHello (HelloRequest nm) = return (HelloResponse ("hi, " <> nm)) ``` @@ -100,70 +98,3 @@ Since you can declare more than one method in a service, you need to join then i quickstartServer :: ServerIO QuickstartService _ quickstartServer = Server (sayHello :<|>: H0) ``` - -## Streaming methods - -The `SayHello` method above has a straightforward signature: it takes one value and produces one value. However, we can also declare methods which perform streaming, such as: - -```java -service Greeter { - rpc SayManyHellos (stream HelloRequest) returns (stream HelloReply) {} -} -``` - -Adding this method to the service definition should be easy, we just need to use `ArgStream` and `RetStream` to declare that behavior (of course, this is done automatically if you import the service from a file): - -```haskell -type QuickstartService - = 'Service "Greeter" - '[ 'Method "SayHello" ... - , 'Method "SayManyHellos" - '[ 'ArgStream ('FromSchema QuickstartSchema "HelloRequest")] - ('RetStream ('FromSchema QuickstartSchema "HelloResponse")) ] -``` - -To define the implementation of this method we build upon the great [Conduit](https://github.com/snoyberg/conduit) library. Your input is now a producer of values, as defined by that library, and you must write the results to the provided sink. Better said with an example: - -```haskell -sayManyHellos - :: ConduitT () HelloRequest IO () - -> ConduitT HelloResponse Void IO () - -> IO () -sayManyHellos source sink - = runConduit $ source .| C.mapM sayHello .| sink -``` - -In this case we are connecting the `source` to the `sink`, transforming in between each value using the `sayHello` function. More complicated pipelines can be built in this form. - -Since now the service has more than one method, we need to update our server declaration to bring together this new handler: - -```haskell -quickstartServer = Server (sayHello :<|>: sayManyHellos :<|>: H0) -``` - -## Running the server with `mu-grpc` - -The combination of the declaration of a service API and a corresponding implementation as a `Server` may served directly using a concrete wire protocol. One example is gRPC, provided by our sibling library `mu-grpc`. The following line starts a server at port `8080`, where the service can be found under the package name `helloworld`: - -```haskell -main = runGRpcApp 8080 "helloworld" quickstartServer -``` - -## Using the Registry - -In this example we have used `FromSchema` to declare a specific schema the arguments must adhere to. However, schemas evolve over time, and you might want to handle all those versions. To do so, you first need to register your schemas using `mu-rpc`'s registry: - -```haskell -type instance Registry "helloworld" - = '[ 2 ':-> QuickstartSchemaV2, 1 ':-> QuickstartSchema ] -``` - -Now you can use the name of the subject in the registry to accomodate for different schemas. In this case, apart from that name, we need to specify the *Haskell* type to use during (de)serialization, and the *version number* to use for serialization. - -```haskell -type QuickstartService - = 'Service "Greeter" - '[ 'Method "SayHello" - '[ 'ArgSingle ('FromRegistry "helloworld" HelloRequest 2) ] - ('RetSingle ('FromRegistry "helloworld" HelloResponse 1)) ] -``` \ No newline at end of file diff --git a/core/schema/README.md b/docs/schema.md similarity index 85% rename from core/schema/README.md rename to docs/schema.md index f82899bf..70e361d0 100644 --- a/core/schema/README.md +++ b/docs/schema.md @@ -1,9 +1,9 @@ -# `mu-schema`: format-independent schemas for serialization +# Schemas Using `mu-schema` you can describe a schema for your data using type-level techniques. You can then automatically generate: * conversion between your Haskell data types and the values as expected by the schema, -* generalization to [Avro](https://avro.apache.org/), [Protocol Buffers](https://developers.google.com/protocol-buffers/), and [JSON](https://www.json.org/). +* serialization to [Avro](https://avro.apache.org/), [Protocol Buffers](https://developers.google.com/protocol-buffers/), and [JSON](https://www.json.org/). Since `mu-schema` makes heavy use of type-level techniques, you need to open up the Pandora's box by enabling (at least) the following extensions: `PolyKinds` and `DataKinds`. @@ -81,6 +81,13 @@ message person { |] ``` +### Schemas part of services + +If you use the `grpc` function to import a gRPC `.proto` file in the type-level, that function already takes care of creating an appropiate schema for *all* the messages. If you prefer to have different schemas for different subsets of messages (for example, aggregated by services), you can either: + +* Write the schemas by hand, +* Split the definition file into several ones, and import each of them in its own `[protobufFile||]` block. + ## Mapping Haskell types These schemas become more useful once you can map your Haskell types to them. `mu-schema` uses the generics mechanism built in GHC to automatically derive these mappings, asuming that you declare your data types using field names. @@ -125,8 +132,6 @@ instance HasSchema ExampleSchema "gender" Gender where If you want to use (de)serialization to Protocol Buffers, you need to declare one more piece of information. A Protocol Buffer record or enumeration assigns both names and *numeric identifiers* to each field or value, respectively. This is done via an *annotation* in each field: ```haskell -import Mu.Schema.Adapter.ProtoBuf - type ExampleSchema = '[ ... , 'DRecord "address" @@ -136,16 +141,3 @@ type ExampleSchema ``` If you use the `protobuf` or `protobufFile` quasi-quoters to import your Protocol Buffers schemas, this is done automatically for you. - -## Registry - -Schemas evolve over time. It is a good practice to keep an inventory of all the schemas you can work with, in the form of a *registry*. Using `mu-schema` you can declare one such registry by giving an instance of the `Registry` type family: - -```haskell -{-# language TypeFamilies #-} - -type instance Registry "example" - = '[ 2 ':-> ExampleSchemaV2, 1 ':-> ExampleSchema ] -``` - -The argument to registry is a tag which identifies that set of schemas. Here we use a type-level string, but you can use any other kind. We then indicate to which type-level schema each version corresponds to. Once we have done that you can use functions like `fromRegistry` to try to parse a term into a Haskell type by trying each of the schemas. \ No newline at end of file diff --git a/docs/stream.md b/docs/stream.md new file mode 100644 index 00000000..5e05d4a7 --- /dev/null +++ b/docs/stream.md @@ -0,0 +1,40 @@ +# Streams + +In the docs about [service definition](rpc.md) we had one single `SayHello` method which takes one value and produces one value. However, we can also declare methods which perform streaming, such as: + +```java +service Greeter { + rpc SayHello (HelloRequest) returns (HelloReply) {} + rpc SayManyHellos (stream HelloRequest) returns (stream HelloReply) {} +} +``` + +Adding this method to the service definition should be easy, we just need to use `ArgStream` and `RetStream` to declare that behavior (of course, this is done automatically if you import the service from a file): + +```haskell +type QuickstartService + = 'Service "Greeter" + '[ 'Method "SayHello" ... + , 'Method "SayManyHellos" + '[ 'ArgStream ('FromSchema QuickstartSchema "HelloRequest")] + ('RetStream ('FromSchema QuickstartSchema "HelloResponse")) ] +``` + +To define the implementation of this method we build upon the great [Conduit](https://github.com/snoyberg/conduit) library. Your input is now a producer of values, as defined by that library, and you must write the results to the provided sink. Better said with an example: + +```haskell +sayManyHellos + :: ConduitT () HelloRequest ServerErrorIO () + -> ConduitT HelloResponse ServerErrorVoid IO () + -> IO () +sayManyHellos source sink + = runConduit $ source .| C.mapM sayHello .| sink +``` + +In this case we are connecting the `source` to the `sink`, transforming in between each value using the `sayHello` function. More complicated pipelines can be built in this form. + +Since now the service has more than one method, we need to update our server declaration to bring together this new handler: + +```haskell +quickstartServer = Server (sayHello :<|>: sayManyHellos :<|>: H0) +``` diff --git a/examples/todolist/src/Definition.hs b/examples/todolist/src/Definition.hs index dc197238..30844e26 100644 --- a/examples/todolist/src/Definition.hs +++ b/examples/todolist/src/Definition.hs @@ -7,7 +7,6 @@ {-# language MultiParamTypeClasses #-} {-# language PolyKinds #-} {-# language TemplateHaskell #-} -{-# language TypeFamilies #-} {-# language TypeOperators #-} module Definition where diff --git a/templates/grpc-server.hsfiles b/templates/grpc-server.hsfiles new file mode 100644 index 00000000..0bd1864d --- /dev/null +++ b/templates/grpc-server.hsfiles @@ -0,0 +1,104 @@ +{-# START_FILE {{name}}.cabal #-} +name: {{name}} +version: 0.1.0.0 +-- synopsis: +-- description: +homepage: https://github.com/{{github-username}}{{^github-username}}githubuser{{/github-username}}/{{name}}#readme +author: {{author-name}}{{^author-name}}Author name here{{/author-name}} +maintainer: {{author-email}}{{^author-email}}example@example.com{{/author-email}} +copyright: {{copyright}}{{^copyright}}{{year}}{{^year}}2019{{/year}} {{author-name}}{{^author-name}}Author name here{{/author-name}}{{/copyright}} +category: {{category}}{{^category}}Web{{/category}} +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md + +executable {{name}} + hs-source-dirs: src + main-is: Main.hs + other-modules: Schema + default-language: Haskell2010 + build-depends: base >= 4.12 && < 5, + text, + mu-schema, + mu-rpc, + mu-protobuf, + mu-grpc-server + +{-# START_FILE stack.yaml #-} +resolver: lts-14.16 +extra-deps: +# mu +- mu-schema-0.1 +- mu-rpc-0.1 +- mu-protobuf-0.1 +- mu-grpc-server-0.1 +# dependencies of mu +- http2-client-0.9.0.0 +- http2-grpc-types-0.5.0.0 +- http2-grpc-proto3-wire-0.1.0.0 +- warp-grpc-0.2.0.0 +- proto3-wire-1.0.0 +- language-protobuf-1.0 + +{-# START_FILE Setup.hs #-} +import Distribution.Simple +main = defaultMain + +{-# START_FILE .gitignore #-} +.stack-work/ +stack*.yaml.lock +*~ + +{-# START_FILE README.md #-} +# {{name}} + +{-# START_FILE {{name}}.proto #-} +syntax = "proto3"; + +import "google/protobuf/empty.proto"; + +package {{name}}; + +service Service { + +} + +{-# START_FILE src/Schema.hs #-} +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DuplicateRecordFields #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language TemplateHaskell #-} +{-# language TypeOperators #-} +module Schema where + +import Data.Text as T +import GHC.Generics + +import Mu.Schema +import Mu.Quasi.GRpc + +grpc "Schema" id "{{name}}.proto" + +-- data Message +-- = Message { ... } +-- deriving (Eq, Show, Generic, HasSchema Schema "Message") + +{-# START_FILE src/Main.hs #-} +{-# language PartialTypeSignatures #-} +module Main where + +import Mu.GRpc.Server +import Mu.Server + +import Schema + +main :: IO () +main = runGRpcApp 8080 server + +server :: ServerIO Service _ +server = Server H0 From 7e699cd78be6699afb529c45cba6daf530200c00 Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Wed, 4 Dec 2019 08:31:11 +0100 Subject: [PATCH 011/217] =?UTF-8?q?Add=20Seed=20example=20=F0=9F=8C=B1=20(?= =?UTF-8?q?#27)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- README.md | 2 - examples/seed/.gitignore | 3 + examples/seed/LICENSE | 202 ++++++++++++++++++++++++++++ examples/seed/README.md | 18 +++ examples/seed/Setup.hs | 2 + examples/seed/mu-example-seed.cabal | 28 ++++ examples/seed/seed.proto | 14 ++ examples/seed/src/Main.hs | 38 ++++++ examples/seed/src/Schema.hs | 34 +++++ stack-nightly.yaml | 1 + stack.yaml | 1 + templates/grpc-server.hsfiles | 2 +- 12 files changed, 342 insertions(+), 3 deletions(-) create mode 100644 examples/seed/.gitignore create mode 100644 examples/seed/LICENSE create mode 100644 examples/seed/README.md create mode 100644 examples/seed/Setup.hs create mode 100644 examples/seed/mu-example-seed.cabal create mode 100644 examples/seed/seed.proto create mode 100644 examples/seed/src/Main.hs create mode 100644 examples/seed/src/Schema.hs diff --git a/README.md b/README.md index 89e1056f..c9663b63 100644 --- a/README.md +++ b/README.md @@ -6,8 +6,6 @@ This repo defines a set of libraries to write microservices in a format- and pro ## [Documentation](docs) -## Building - This set of libraries are thought to be built using [Stack](https://docs.haskellstack.org). Just jump into the folder and run `stack build`! The top-level `stack.yaml` defines a common resolver and set of dependencies for all the packages. ## Contributing diff --git a/examples/seed/.gitignore b/examples/seed/.gitignore new file mode 100644 index 00000000..1f4b9c88 --- /dev/null +++ b/examples/seed/.gitignore @@ -0,0 +1,3 @@ +.stack-work/ +stack*.yaml.lock +*~ diff --git a/examples/seed/LICENSE b/examples/seed/LICENSE new file mode 100644 index 00000000..d6456956 --- /dev/null +++ b/examples/seed/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/examples/seed/README.md b/examples/seed/README.md new file mode 100644 index 00000000..73ad6620 --- /dev/null +++ b/examples/seed/README.md @@ -0,0 +1,18 @@ +# Seed RPC example + +## Execution + +Running the server: + +```bash +stack run seed-server +``` + +[comment]: # (Start Copyright) +# Copyright + +Mu is designed and developed by 47 Degrees + +Copyright (C) 2019-2020 47 Degrees. + +[comment]: # (End Copyright) diff --git a/examples/seed/Setup.hs b/examples/seed/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/examples/seed/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/seed/mu-example-seed.cabal b/examples/seed/mu-example-seed.cabal new file mode 100644 index 00000000..f342cb56 --- /dev/null +++ b/examples/seed/mu-example-seed.cabal @@ -0,0 +1,28 @@ +name: mu-example-seed +version: 0.1.0.0 +-- synopsis: +-- description: +homepage: https://github.com/higherkindness/mu-haskell/examples/seed#readme +license: Apache-2.0 +license-file: LICENSE +author: Flavio Corpa +maintainer: flavio.corpa@47deg.com +copyright: Copyright © 2019-2020 47 Degrees. +category: Network +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md + +executable seed-server + hs-source-dirs: src + main-is: Main.hs + other-modules: Schema + default-language: Haskell2010 + build-depends: base >= 4.12 && < 5 + , conduit + , mu-schema + , mu-rpc + , mu-protobuf + , mu-grpc-server + , text + , stm diff --git a/examples/seed/seed.proto b/examples/seed/seed.proto new file mode 100644 index 00000000..b2ceb875 --- /dev/null +++ b/examples/seed/seed.proto @@ -0,0 +1,14 @@ +syntax = "proto3"; + +import "google/protobuf/empty.proto"; + +package seed; + +message Person { string name = 1; int32 age = 2; } +message PeopleRequest { string name = 1; } +message PeopleResponse { Person person = 1; } + +service PeopleService { + rpc getPerson (PeopleRequest) returns (PeopleResponse); + rpc getPersonStream (stream PeopleRequest) returns (stream PeopleResponse); +} diff --git a/examples/seed/src/Main.hs b/examples/seed/src/Main.hs new file mode 100644 index 00000000..7786474d --- /dev/null +++ b/examples/seed/src/Main.hs @@ -0,0 +1,38 @@ +{-# language PartialTypeSignatures #-} + +module Main where + +import Control.Concurrent (threadDelay) +import Control.Monad.IO.Class (liftIO) +import Data.Conduit +import Data.Conduit.Combinators as C +import Mu.GRpc.Server +import Mu.Server + +import Schema + +main :: IO () +main = do + putStrLn "running seed application" + runGRpcApp 8080 server + +-- Server implementation +-- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala + +server :: ServerIO PeopleService _ +server = Server (getPerson :<|>: getPersonStream :<|>: H0) + +evolvePerson :: PeopleRequest -> PeopleResponse +evolvePerson (PeopleRequest n) = PeopleResponse $ Person n 18 + +getPerson :: PeopleRequest -> ServerErrorIO PeopleResponse +getPerson = return . evolvePerson + +getPersonStream :: ConduitT () PeopleRequest ServerErrorIO () + -> ConduitT PeopleResponse Void ServerErrorIO () + -> ServerErrorIO () +getPersonStream source sink = runConduit $ source .| C.mapM reStream .| sink + where + reStream req = do + liftIO $ threadDelay (2 * 1000 * 1000) -- 2 sec + return $ evolvePerson req diff --git a/examples/seed/src/Schema.hs b/examples/seed/src/Schema.hs new file mode 100644 index 00000000..3f69767c --- /dev/null +++ b/examples/seed/src/Schema.hs @@ -0,0 +1,34 @@ +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DuplicateRecordFields #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language TemplateHaskell #-} +{-# language TypeOperators #-} + +module Schema where + +import Data.Int (Int32) +import Data.Text as T +import GHC.Generics + +import Mu.Quasi.GRpc +import Mu.Schema + +grpc "SeedSchema" id "seed.proto" + +data Person = Person + { name :: T.Text + , age :: Int32 + } deriving (Eq, Show, Ord, Generic, HasSchema SeedSchema "Person") + +newtype PeopleRequest = PeopleRequest + { name :: T.Text + } deriving (Eq, Show, Ord, Generic, HasSchema SeedSchema "PeopleRequest") + +newtype PeopleResponse = PeopleResponse + { person :: Person + } deriving (Eq, Show, Ord, Generic, HasSchema SeedSchema "PeopleResponse") diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 3a5f39bc..35fe4447 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -10,6 +10,7 @@ packages: - grpc/server - examples/health-check - examples/route-guide +- examples/seed - examples/todolist - compendium-client diff --git a/stack.yaml b/stack.yaml index 682288b3..36a26c10 100644 --- a/stack.yaml +++ b/stack.yaml @@ -9,6 +9,7 @@ packages: - grpc/server - examples/health-check - examples/route-guide +- examples/seed - examples/todolist - compendium-client diff --git a/templates/grpc-server.hsfiles b/templates/grpc-server.hsfiles index 0bd1864d..2da98573 100644 --- a/templates/grpc-server.hsfiles +++ b/templates/grpc-server.hsfiles @@ -79,8 +79,8 @@ module Schema where import Data.Text as T import GHC.Generics -import Mu.Schema import Mu.Quasi.GRpc +import Mu.Schema grpc "Schema" id "{{name}}.proto" From 1a96bcf40621c8149b73a6bcc674944413db111a Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Wed, 4 Dec 2019 12:35:05 +0100 Subject: [PATCH 012/217] =?UTF-8?q?Separate=20annotations=20from=20core=20?= =?UTF-8?q?schema=20type=20=F0=9F=96=8B=20(#29)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- adapter/avro/src/Mu/Adapter/Avro.hs | 26 ++--- adapter/avro/src/Mu/Quasi/Avro.hs | 18 ++- adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs | 110 ++++++++++-------- .../src/Mu/Adapter/ProtoBuf/Example.hs | 19 +-- adapter/protobuf/src/Mu/Quasi/GRpc.hs | 12 +- adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs | 103 ++++++++-------- adapter/protobuf/test/ProtoBuf.hs | 16 ++- adapter/protobuf/test/protobuf/example2.proto | 12 ++ core/rpc/src/Mu/Rpc.hs | 9 +- core/rpc/src/Mu/Rpc/Examples.hs | 12 +- core/schema/src/Mu/Adapter/Json.hs | 16 +-- core/schema/src/Mu/Schema.hs | 4 +- core/schema/src/Mu/Schema/Annotations.hs | 49 +++++++- core/schema/src/Mu/Schema/Class.hs | 31 ++--- .../src/Mu/Schema/Conversion/SchemaToTypes.hs | 29 +++-- .../src/Mu/Schema/Conversion/TypesToSchema.hs | 8 +- core/schema/src/Mu/Schema/Definition.hs | 36 +++--- core/schema/src/Mu/Schema/Examples.hs | 52 ++++----- core/schema/src/Mu/Schema/Interpretation.hs | 18 +-- .../src/Mu/Schema/Interpretation/Anonymous.hs | 34 +++--- .../Mu/Schema/Interpretation/Schemaless.hs | 8 +- examples/seed/src/Schema.hs | 1 + examples/todolist/src/Definition.hs | 1 + grpc/client/src/Mu/GRpc/Client/Examples.hs | 8 ++ grpc/client/src/Mu/GRpc/Client/Record.hs | 2 +- grpc/server/src/ExampleServer.hs | 9 ++ stack-nightly.yaml | 2 +- templates/grpc-server.hsfiles | 1 + 28 files changed, 368 insertions(+), 278 deletions(-) create mode 100644 adapter/protobuf/test/protobuf/example2.proto diff --git a/adapter/avro/src/Mu/Adapter/Avro.hs b/adapter/avro/src/Mu/Adapter/Avro.hs index 7849e3a0..907fd86b 100644 --- a/adapter/avro/src/Mu/Adapter/Avro.hs +++ b/adapter/avro/src/Mu/Adapter/Avro.hs @@ -94,12 +94,12 @@ instance forall r d ds. -- HasAvroSchema instances instance (KnownName name, HasAvroSchemaFields sch args) - => A.HasAvroSchema (Term sch ('DRecord name anns args)) where + => A.HasAvroSchema (Term sch ('DRecord name args)) where schema = Tagged $ ASch.Record recordName [] Nothing Nothing fields where recordName = nameTypeName (Proxy @name) fields = schemaF (Proxy @sch) (Proxy @args) instance (KnownName name, HasAvroSchemaEnum choices) - => A.HasAvroSchema (Term sch ('DEnum name anns choices)) where + => A.HasAvroSchema (Term sch ('DEnum name choices)) where schema = Tagged $ ASch.mkEnum enumName [] Nothing choicesNames where enumName = nameTypeName (Proxy @name) choicesNames = schemaE (Proxy @choices) @@ -150,7 +150,7 @@ class HasAvroSchemaFields sch (fs :: [FieldDef tn fn]) where instance HasAvroSchemaFields sch '[] where schemaF _ _ = [] instance (KnownName name, A.HasAvroSchema (FieldValue sch t), HasAvroSchemaFields sch fs) - => HasAvroSchemaFields sch ('FieldDef name anns t ': fs) where + => HasAvroSchemaFields sch ('FieldDef name t ': fs) where schemaF psch _ = schemaThis : schemaF psch (Proxy @fs) where fieldName = nameText (Proxy @name) schemaT = unTagged $ A.schema @(FieldValue sch t) @@ -161,17 +161,17 @@ class HasAvroSchemaEnum (fs :: [ChoiceDef fn]) where instance HasAvroSchemaEnum '[] where schemaE _ = [] instance (KnownName name, HasAvroSchemaEnum fs) - => HasAvroSchemaEnum ('ChoiceDef name anns ': fs) where + => HasAvroSchemaEnum ('ChoiceDef name ': fs) where schemaE _ = nameText (Proxy @name) : schemaE (Proxy @fs) -- FromAvro instances instance (KnownName name, HasAvroSchemaFields sch args, FromAvroFields sch args) - => A.FromAvro (Term sch ('DRecord name anns args)) where + => A.FromAvro (Term sch ('DRecord name args)) where fromAvro (AVal.Record _ fields) = TRecord <$> fromAvroF fields fromAvro v = A.badValue v "record" instance (KnownName name, HasAvroSchemaEnum choices, FromAvroEnum choices) - => A.FromAvro (Term sch ('DEnum name anns choices)) where + => A.FromAvro (Term sch ('DEnum name choices)) where fromAvro v@(AVal.Enum _ n _) = TEnum <$> fromAvroEnum v n fromAvro v = A.badValue v "enum" instance A.FromAvro (FieldValue sch t) @@ -229,7 +229,7 @@ class FromAvroFields sch (fs :: [FieldDef Symbol Symbol]) where instance FromAvroFields sch '[] where fromAvroF _ = return Nil instance (KnownName name, A.FromAvro (FieldValue sch t), FromAvroFields sch fs) - => FromAvroFields sch ('FieldDef name anns t ': fs) where + => FromAvroFields sch ('FieldDef name t ': fs) where fromAvroF v = case HM.lookup fieldName v of Nothing -> A.badValue v "field not found" Just f -> (:*) <$> (Field <$> A.fromAvro f) <*> fromAvroF v @@ -238,13 +238,13 @@ instance (KnownName name, A.FromAvro (FieldValue sch t), FromAvroFields sch fs) -- ToAvro instances instance (KnownName name, HasAvroSchemaFields sch args, ToAvroFields sch args) - => A.ToAvro (Term sch ('DRecord name anns args)) where + => A.ToAvro (Term sch ('DRecord name args)) where toAvro (TRecord fields) = AVal.Record wholeSchema (toAvroF fields) - where wholeSchema = unTagged (A.schema @(Term sch ('DRecord name anns args))) + where wholeSchema = unTagged (A.schema @(Term sch ('DRecord name args))) instance (KnownName name, HasAvroSchemaEnum choices, ToAvroEnum choices) - => A.ToAvro (Term sch ('DEnum name anns choices)) where + => A.ToAvro (Term sch ('DEnum name choices)) where toAvro (TEnum n) = AVal.Enum wholeSchema choice text - where wholeSchema = unTagged (A.schema @(Term sch ('DEnum name anns choices))) + where wholeSchema = unTagged (A.schema @(Term sch ('DEnum name choices))) (choice, text) = toAvroE n instance A.ToAvro (FieldValue sch t) => A.ToAvro (Term sch ('DSimple t)) where @@ -293,7 +293,7 @@ class ToAvroEnum choices where instance ToAvroEnum '[] where toAvroE = error "ToAvro in an empty enum" instance (KnownName u, ToAvroEnum us) - => ToAvroEnum ('ChoiceDef u anns ': us) where + => ToAvroEnum ('ChoiceDef u ': us) where toAvroE (Z _) = (0, nameText (Proxy @u)) toAvroE (S v) = let (n, t) = toAvroE v in (n + 1, t) @@ -302,7 +302,7 @@ class ToAvroFields sch (fs :: [FieldDef Symbol Symbol]) where instance ToAvroFields sch '[] where toAvroF _ = HM.empty instance (KnownName name, A.ToAvro (FieldValue sch t), ToAvroFields sch fs) - => ToAvroFields sch ('FieldDef name anns t ': fs) where + => ToAvroFields sch ('FieldDef name t ': fs) where toAvroF (Field v :* rest) = HM.insert fieldName fieldValue (toAvroF rest) where fieldName = nameText (Proxy @name) fieldValue = A.toAvro v diff --git a/adapter/avro/src/Mu/Quasi/Avro.hs b/adapter/avro/src/Mu/Quasi/Avro.hs index 3ed9b3f6..02dac5da 100644 --- a/adapter/avro/src/Mu/Quasi/Avro.hs +++ b/adapter/avro/src/Mu/Quasi/Avro.hs @@ -49,23 +49,19 @@ schemaFromAvroString s = schemaDecFromAvroType :: A.Type -> Q Type schemaDecFromAvroType (A.Record name _ _ _ fields) = - [t|'DRecord $(textToStrLit $ A.baseName name) '[] $(typesToList <$> - mapM - avroFieldToType - fields)|] + [t|'DRecord $(textToStrLit $ A.baseName name) + $(typesToList <$> mapM avroFieldToType fields)|] where avroFieldToType :: A.Field -> Q Type avroFieldToType field = - [t|'FieldDef $(textToStrLit $ A.fldName field) '[] $(schemaFromAvroType $ - A.fldType field)|] + [t|'FieldDef $(textToStrLit $ A.fldName field) + $(schemaFromAvroType $ A.fldType field)|] schemaDecFromAvroType (A.Enum name _ _ symbols) = - [t|'DEnum $(textToStrLit $ A.baseName name) '[] $(typesToList <$> - mapM - avChoiceToType - (toList symbols))|] + [t|'DEnum $(textToStrLit $ A.baseName name) + $(typesToList <$> mapM avChoiceToType (toList symbols))|] where avChoiceToType :: T.Text -> Q Type - avChoiceToType c = [t|'ChoiceDef $(textToStrLit c) '[]|] + avChoiceToType c = [t|'ChoiceDef $(textToStrLit c)|] schemaDecFromAvroType t = [t|'DSimple $(schemaFromAvroType t)|] schemaFromAvroType :: A.Type -> Q Type diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs index c420d3f3..36e8c229 100644 --- a/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs @@ -15,8 +15,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} module Mu.Adapter.ProtoBuf ( -- * Custom annotations - ProtoBufId -, ProtoBufOneOfIds + ProtoBufAnnotation(..) -- * Conversion using schemas , IsProtoSchema , HasProtoSchema @@ -32,7 +31,6 @@ module Mu.Adapter.ProtoBuf ( import Control.Applicative import qualified Data.ByteString as BS import Data.Int -import Data.Kind import Data.SOP (All) import qualified Data.Text as T import qualified Data.Text.Lazy as LT @@ -47,17 +45,29 @@ import Mu.Schema.Definition import Mu.Schema.Interpretation import qualified Mu.Schema.Registry as R -type family FindProtoBufId (f :: fn) (xs :: [Type]) :: Nat where - FindProtoBufId f '[] - = TypeError ('Text "protocol buffers id not available for field " ':<>: 'ShowType f) - FindProtoBufId f (ProtoBufId n ': rest) = n - FindProtoBufId f (other ': rest) = FindProtoBufId f rest +data ProtoBufAnnotation + = ProtoBufId Nat + | ProtoBufOneOfIds [Nat] -type family FindProtoBufOneOfIds (f :: fn) (xs :: [Type]) :: [Nat] where - FindProtoBufOneOfIds f '[] - = TypeError ('Text "protocol buffers ids not available for oneof field " ':<>: 'ShowType f) - FindProtoBufOneOfIds f (ProtoBufOneOfIds n ': rest) = n - FindProtoBufOneOfIds f (other ': rest) = FindProtoBufOneOfIds f rest +type family FindProtoBufId (sch :: Schema tn fn) (t :: tn) (f :: fn) where + FindProtoBufId sch t f + = FindProtoBufId' t f (GetFieldAnnotation (AnnotatedSchema ProtoBufAnnotation sch) t f) + +type family FindProtoBufId' (t :: tn) (f :: fn) (p :: ProtoBufAnnotation) :: Nat where + FindProtoBufId' t f ('ProtoBufId n) = n + FindProtoBufId' t f other + = TypeError ('Text "protocol buffers id not available for field " + ':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f) + +type family FindProtoBufOneOfIds (sch :: Schema tn fn) (t :: tn) (f :: fn) where + FindProtoBufOneOfIds sch t f + = FindProtoBufOneOfIds' t f (GetFieldAnnotation (AnnotatedSchema ProtoBufAnnotation sch) t f) + +type family FindProtoBufOneOfIds' (t :: tn) (f :: fn) (p :: ProtoBufAnnotation) :: [Nat] where + FindProtoBufOneOfIds' t f ('ProtoBufOneOfIds ns) = ns + FindProtoBufOneOfIds' t f other + = TypeError ('Text "protocol buffers id not available for oneof field " + ':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f) -- CONVERSION USING SCHEMAS @@ -127,7 +137,7 @@ class ProtoBridgeEmbedTerm (sch :: Schema tn fn) (t :: TypeDef tn fn) where embedProtoToFieldValue :: PBDec.Parser PBDec.RawField (Term sch t) embedProtoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (Term sch t) -class ProtoBridgeField (sch :: Schema tn fn) (f :: FieldDef tn fn) where +class ProtoBridgeField (sch :: Schema tn fn) (ty :: tn) (f :: FieldDef tn fn) where fieldToProto :: Field sch f -> PBEnc.MessageBuilder protoToField :: PBDec.Parser PBDec.RawMessage (Field sch f) @@ -149,64 +159,64 @@ class ProtoBridgeUnionFieldValue (ids :: [Nat]) (sch :: Schema tn fn) (ts :: [Fi -- RECORDS -- ------- -instance (All (ProtoBridgeField sch) args, ProtoBridgeFields sch args) - => ProtoBridgeTerm sch ('DRecord name anns args) where +instance (All (ProtoBridgeField sch name) args, ProtoBridgeFields sch name args) + => ProtoBridgeTerm sch ('DRecord name args) where termToProto (TRecord fields) = go fields - where go :: forall fs. All (ProtoBridgeField sch) fs + where go :: forall fs. All (ProtoBridgeField sch name) fs => NP (Field sch) fs -> PBEnc.MessageBuilder go Nil = mempty - go (f :* fs) = fieldToProto f <> go fs - protoToTerm = TRecord <$> protoToFields + go (f :* fs) = fieldToProto @_ @_ @sch @name f <> go fs + protoToTerm = TRecord <$> protoToFields @_ @_ @sch @name -class ProtoBridgeFields sch fields where +class ProtoBridgeFields (sch :: Schema tn fn) (ty :: tn) (fields :: [FieldDef tn fn]) where protoToFields :: PBDec.Parser PBDec.RawMessage (NP (Field sch) fields) -instance ProtoBridgeFields sch '[] where +instance ProtoBridgeFields sch ty '[] where protoToFields = pure Nil -instance (ProtoBridgeField sch f, ProtoBridgeFields sch fs) - => ProtoBridgeFields sch (f ': fs) where - protoToFields = (:*) <$> protoToField <*> protoToFields +instance (ProtoBridgeField sch ty f, ProtoBridgeFields sch ty fs) + => ProtoBridgeFields sch ty (f ': fs) where + protoToFields = (:*) <$> protoToField @_ @_ @sch @ty <*> protoToFields @_ @_ @sch @ty -instance ProtoBridgeTerm sch ('DRecord name anns args) - => ProtoBridgeEmbedTerm sch ('DRecord name anns args) where +instance ProtoBridgeTerm sch ('DRecord name args) + => ProtoBridgeEmbedTerm sch ('DRecord name args) where termToEmbedProto fid v = PBEnc.embedded fid (termToProto v) embedProtoToFieldValue = do - t <- PBDec.embedded (protoToTerm @_ @_ @sch @('DRecord name anns args)) + t <- PBDec.embedded (protoToTerm @_ @_ @sch @('DRecord name args)) case t of Nothing -> PBDec.Parser (\_ -> Left (PBDec.WireTypeError "expected message")) Just v -> return v - embedProtoToOneFieldValue = PBDec.embedded' (protoToTerm @_ @_ @sch @('DRecord name anns args)) + embedProtoToOneFieldValue = PBDec.embedded' (protoToTerm @_ @_ @sch @('DRecord name args)) -- ENUMERATIONS -- ------------ instance TypeError ('Text "protobuf requires wrapping enums in a message") - => ProtoBridgeTerm sch ('DEnum name anns choices) where + => ProtoBridgeTerm sch ('DEnum name choices) where termToProto = error "protobuf requires wrapping enums in a message" protoToTerm = error "protobuf requires wrapping enums in a message" -instance ProtoBridgeEnum choices - => ProtoBridgeEmbedTerm sch ('DEnum name anns choices) where - termToEmbedProto fid (TEnum v) = enumToProto fid v +instance ProtoBridgeEnum sch name choices + => ProtoBridgeEmbedTerm sch ('DEnum name choices) where + termToEmbedProto fid (TEnum v) = enumToProto @_ @_ @sch @name fid v embedProtoToFieldValue = do n <- PBDec.one PBDec.int32 0 - TEnum <$> protoToEnum n + TEnum <$> protoToEnum @_ @_ @sch @name n embedProtoToOneFieldValue = do n <- PBDec.int32 - TEnum <$> protoToEnum n + TEnum <$> protoToEnum @_ @_ @sch @name n -class ProtoBridgeEnum (choices :: [ChoiceDef fn]) where +class ProtoBridgeEnum (sch :: Schema tn fn) (ty :: tn) (choices :: [ChoiceDef fn]) where enumToProto :: FieldNumber -> NS Proxy choices -> PBEnc.MessageBuilder protoToEnum :: Int32 -> PBDec.Parser a (NS Proxy choices) -instance ProtoBridgeEnum '[] where +instance ProtoBridgeEnum sch ty '[] where enumToProto = error "empty enum" protoToEnum _ = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "unknown enum type")) -instance (KnownNat (FindProtoBufId c anns), ProtoBridgeEnum cs) - => ProtoBridgeEnum ('ChoiceDef c anns ': cs) where +instance (KnownNat (FindProtoBufId sch ty c), ProtoBridgeEnum sch ty cs) + => ProtoBridgeEnum sch ty ('ChoiceDef c ': cs) where enumToProto fid (Z _) = PBEnc.int32 fid enumValue - where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId c anns))) - enumToProto fid (S v) = enumToProto fid v + where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c))) + enumToProto fid (S v) = enumToProto @_ @_ @sch @ty fid v protoToEnum n | n == enumValue = return (Z Proxy) - | otherwise = S <$> protoToEnum n - where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId c anns))) + | otherwise = S <$> protoToEnum @_ @_ @sch @ty n + where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c))) -- SIMPLE -- ------ @@ -221,18 +231,18 @@ instance TypeError ('Text "protobuf requires wrapping primitives in a message") -- --------- instance {-# OVERLAPPABLE #-} - (ProtoBridgeFieldValue sch t, KnownNat (FindProtoBufId name anns)) - => ProtoBridgeField sch ('FieldDef name anns t) where + (ProtoBridgeFieldValue sch t, KnownNat (FindProtoBufId sch ty name)) + => ProtoBridgeField sch ty ('FieldDef name t) where fieldToProto (Field v) = fieldValueToProto fieldId v - where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId name anns)) + where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name)) protoToField = Field <$> protoToFieldValue `at` fieldId - where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId name anns)) + where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name)) instance {-# OVERLAPS #-} - (ProtoBridgeUnionFieldValue (FindProtoBufOneOfIds name anns) sch ts) - => ProtoBridgeField sch ('FieldDef name anns ('TUnion ts)) where - fieldToProto (Field (FUnion v)) = unionFieldValueToProto @_ @_ @(FindProtoBufOneOfIds name anns) v - protoToField = Field . FUnion <$> protoToUnionFieldValue @_ @_ @(FindProtoBufOneOfIds name anns) + (ProtoBridgeUnionFieldValue (FindProtoBufOneOfIds sch ty name) sch ts) + => ProtoBridgeField sch ty ('FieldDef name ('TUnion ts)) where + fieldToProto (Field (FUnion v)) = unionFieldValueToProto @_ @_ @(FindProtoBufOneOfIds sch ty name) v + protoToField = Field . FUnion <$> protoToUnionFieldValue @_ @_ @(FindProtoBufOneOfIds sch ty name) -- ------------------ -- TYPES OF FIELDS -- diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs index 0271ac78..057e58fa 100644 --- a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs @@ -1,18 +1,9 @@ -{-# language DataKinds #-} -{-# language QuasiQuotes #-} +{-# language DataKinds #-} +{-# language TemplateHaskell #-} +{-# language TypeFamilies #-} module Mu.Adapter.ProtoBuf.Example where import Mu.Quasi.ProtoBuf -type ExampleProtoBufSchema = [protobuf| -enum gender { - male = 1; - female = 2; - nonbinary = 3; -} -message person { - repeated string names = 1; - int age = 2; - gender gender = 3; -} -|] +protobuf "ExampleProtoBufSchema" "test/protobuf/example.proto" +protobuf "Example2ProtoBufSchema" "test/protobuf/example2.proto" diff --git a/adapter/protobuf/src/Mu/Quasi/GRpc.hs b/adapter/protobuf/src/Mu/Quasi/GRpc.hs index 924ac752..109ab7c5 100644 --- a/adapter/protobuf/src/Mu/Quasi/GRpc.hs +++ b/adapter/protobuf/src/Mu/Quasi/GRpc.hs @@ -32,7 +32,7 @@ grpc schemaName servicePrefix fp Left e -> fail ("could not parse protocol buffers spec: " ++ show e) Right p - -> protobufToDecls schemaName servicePrefix p + -> grpcToDecls schemaName servicePrefix p -- | Obtains a schema and service definition from Compendium, -- and generates the declarations from 'grpc'. @@ -46,14 +46,14 @@ compendium schemaTypeName servicePrefix baseUrl identifier Left e -> fail ("could not parse protocol buffers spec: " ++ show e) Right p - -> protobufToDecls schemaTypeName servicePrefix p + -> grpcToDecls schemaTypeName servicePrefix p -protobufToDecls :: String -> (String -> String) -> P.ProtoBuf -> Q [Dec] -protobufToDecls schemaName servicePrefix p@P.ProtoBuf { P.package = pkg, P.services = srvs } +grpcToDecls :: String -> (String -> String) -> P.ProtoBuf -> Q [Dec] +grpcToDecls schemaName servicePrefix p@P.ProtoBuf { P.package = pkg, P.services = srvs } = do let schemaName' = mkName schemaName - schemaDec <- tySynD schemaName' [] (schemaFromProtoBuf p) + schemaDec <- protobufToDecls schemaName p serviceTy <- mapM (pbServiceDeclToDec servicePrefix pkg schemaName') srvs - return (schemaDec : serviceTy) + return (schemaDec ++ serviceTy) pbServiceDeclToDec :: (String -> String) -> Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Dec pbServiceDeclToDec servicePrefix pkg schema srv@(P.Service nm _ _) diff --git a/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs b/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs index ff31b4c1..9c74632c 100644 --- a/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs +++ b/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs @@ -1,3 +1,4 @@ +{-# language CPP #-} {-# language DataKinds #-} {-# language LambdaCase #-} {-# language NamedFieldPuns #-} @@ -6,47 +7,54 @@ module Mu.Quasi.ProtoBuf ( -- * Quasi-quoters for @.proto@ files protobuf - , protobufFile -- * Only for internal use - , schemaFromProtoBuf + , protobufToDecls ) where +import Control.Monad.IO.Class import qualified Data.ByteString as B import Data.Int import qualified Data.Text as T import Language.Haskell.TH -import Language.Haskell.TH.Quote import Language.ProtocolBuffers.Parser import qualified Language.ProtocolBuffers.Types as P import Mu.Adapter.ProtoBuf import Mu.Schema.Definition - --- | Imports a protocol buffer definition written --- in-line as a 'Schema'. -protobuf :: QuasiQuoter -protobuf = - QuasiQuoter - (const $ fail "cannot use as expression") - (const $ fail "cannot use as pattern") - schemaFromProtoBufString - (const $ fail "cannot use as declaration") - --- | Imports a protocol buffer definition from a file --- as a 'Schema'. -protobufFile :: QuasiQuoter -protobufFile = quoteFile protobuf - -schemaFromProtoBufString :: String -> Q Type -schemaFromProtoBufString ts = - case parseProtoBuf (T.pack ts) of - Left e -> fail ("could not parse protocol buffers spec: " ++ show e) - Right p -> schemaFromProtoBuf p - -schemaFromProtoBuf :: P.ProtoBuf -> Q Type -schemaFromProtoBuf P.ProtoBuf {P.types = tys} = +import Mu.Schema.Annotations + +-- | Reads a @.proto@ file and generates a 'Schema' +-- with all the message types, using the name given +-- as first argument. +protobuf :: String -> FilePath -> Q [Dec] +protobuf schemaName fp + = do r <- liftIO $ parseProtoBufFile fp + case r of + Left e + -> fail ("could not parse protocol buffers spec: " ++ show e) + Right p + -> protobufToDecls schemaName p + +protobufToDecls :: String -> P.ProtoBuf -> Q [Dec] +protobufToDecls schemaName p + = do let schemaName' = mkName schemaName + (schTy, annTy) <- schemaFromProtoBuf p + schemaDec <- tySynD schemaName' [] (return schTy) +#if MIN_VERSION_template_haskell(2,15,0) + annDec <- tySynInstD (tySynEqn Nothing + [t| AnnotatedSchema ProtoBufAnnotation $(conT schemaName') |] + (return annTy)) +#else + annDec <- tySynInstD ''AnnotatedSchema + (tySynEqn [ [t| ProtoBufAnnotation |], conT schemaName' ] (return annTy)) +#endif + return [schemaDec, annDec] + +schemaFromProtoBuf :: P.ProtoBuf -> Q (Type, Type) +schemaFromProtoBuf P.ProtoBuf {P.types = tys} = do let decls = flattenDecls tys - in typesToList <$> mapM pbTypeDeclToType decls + (schTys, anns) <- unzip <$> mapM pbTypeDeclToType decls + return (typesToList schTys, typesToList (concat anns)) flattenDecls :: [P.TypeDeclaration] -> [P.TypeDeclaration] flattenDecls = concatMap flattenDecl @@ -55,33 +63,36 @@ flattenDecls = concatMap flattenDecl flattenDecl (P.DMessage name o r fs decls) = P.DMessage name o r fs [] : flattenDecls decls -pbTypeDeclToType :: P.TypeDeclaration -> Q Type -pbTypeDeclToType (P.DEnum name _ fields) = - [t|'DEnum $(textToStrLit name) '[] $(typesToList <$> mapM pbChoiceToType fields)|] +pbTypeDeclToType :: P.TypeDeclaration -> Q (Type, [Type]) +pbTypeDeclToType (P.DEnum name _ fields) = do + (tys, anns) <- unzip <$> mapM pbChoiceToType fields + (,) <$> [t|'DEnum $(textToStrLit name) $(return $ typesToList tys)|] <*> pure anns where - pbChoiceToType :: P.EnumField -> Q Type - pbChoiceToType (P.EnumField nm number _) = - [t|'ChoiceDef $(textToStrLit nm) '[ ProtoBufId $(intToLit number)]|] -pbTypeDeclToType (P.DMessage name _ _ fields _) = - [t|'DRecord $(textToStrLit name) '[] $(typesToList <$> mapM pbMsgFieldToType fields)|] + pbChoiceToType :: P.EnumField -> Q (Type, Type) + pbChoiceToType (P.EnumField nm number _) + = (,) <$> [t|'ChoiceDef $(textToStrLit nm) |] + <*> [t|'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit number)) |] +pbTypeDeclToType (P.DMessage name _ _ fields _) = do + (tys, anns) <- unzip <$> mapM pbMsgFieldToType fields + (,) <$> [t|'DRecord $(textToStrLit name) $(pure $ typesToList tys)|] <*> pure anns where - pbMsgFieldToType :: P.MessageField -> Q Type + pbMsgFieldToType :: P.MessageField -> Q (Type, Type) pbMsgFieldToType (P.NormalField P.Single ty nm n _) - = [t| 'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n) ] - $(pbFieldTypeToType ty) |] + = (,) <$> [t| 'FieldDef $(textToStrLit nm) $(pbFieldTypeToType ty) |] + <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n)) |] pbMsgFieldToType (P.NormalField P.Repeated ty nm n _) - = [t| 'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n) ] - ('TList $(pbFieldTypeToType ty)) |] + = (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TList $(pbFieldTypeToType ty)) |] + <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n)) |] pbMsgFieldToType (P.MapField k v nm n _) - = [t| 'FieldDef $(textToStrLit nm) '[ ProtoBufId $(intToLit n) ] - ('TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v)) |] + = (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v)) |] + <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n)) |] pbMsgFieldToType (P.OneOfField nm vs) | any (not . hasFieldNumber) vs = fail "nested oneof fields are not supported" | otherwise - = [t| 'FieldDef $(textToStrLit nm) - '[ ProtoBufOneOfIds $(typesToList <$> mapM (intToLit . getFieldNumber) vs ) ] - $(typesToList <$> mapM pbOneOfFieldToType vs ) |] + = (,) <$> [t| 'FieldDef $(textToStrLit nm) $(typesToList <$> mapM pbOneOfFieldToType vs ) |] + <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) + ('ProtoBufOneOfIds $(typesToList <$> mapM (intToLit . getFieldNumber) vs )) |] pbFieldTypeToType :: P.FieldType -> Q Type pbFieldTypeToType P.TInt32 = [t|'TPrimitive Int32|] diff --git a/adapter/protobuf/test/ProtoBuf.hs b/adapter/protobuf/test/ProtoBuf.hs index 6e81c2d2..6dea6201 100644 --- a/adapter/protobuf/test/ProtoBuf.hs +++ b/adapter/protobuf/test/ProtoBuf.hs @@ -1,6 +1,8 @@ +{-# language DataKinds #-} {-# language OverloadedStrings #-} {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} +{-# language TypeFamilies #-} module Main where import qualified Data.ByteString as BS @@ -10,9 +12,21 @@ import qualified Proto3.Wire.Encode as PBEnc import System.Environment import Mu.Adapter.ProtoBuf -import Mu.Schema () +import Mu.Schema import Mu.Schema.Examples +type instance AnnotatedSchema ProtoBufAnnotation ExampleSchema + = '[ 'AnnField "gender" "male" ('ProtoBufId 1) + , 'AnnField "gender" "female" ('ProtoBufId 2) + , 'AnnField "gender" "nb" ('ProtoBufId 3) + , 'AnnField "address" "postcode" ('ProtoBufId 1) + , 'AnnField "address" "country" ('ProtoBufId 2) + , 'AnnField "person" "firstName" ('ProtoBufId 1) + , 'AnnField "person" "lastName" ('ProtoBufId 2) + , 'AnnField "person" "age" ('ProtoBufId 3) + , 'AnnField "person" "gender" ('ProtoBufId 4) + , 'AnnField "person" "address" ('ProtoBufId 5) ] + exampleAddress :: Address exampleAddress = Address "1111BB" "Spain" diff --git a/adapter/protobuf/test/protobuf/example2.proto b/adapter/protobuf/test/protobuf/example2.proto new file mode 100644 index 00000000..45bcdf4a --- /dev/null +++ b/adapter/protobuf/test/protobuf/example2.proto @@ -0,0 +1,12 @@ +syntax = "proto3"; + +enum gender { + male = 1; + female = 2; + nonbinary = 3; +} +message person { + repeated string names = 1; + int32 age = 2; + gender gender = 3; +} diff --git a/core/rpc/src/Mu/Rpc.hs b/core/rpc/src/Mu/Rpc.hs index 6dfa12c7..a300f19d 100644 --- a/core/rpc/src/Mu/Rpc.hs +++ b/core/rpc/src/Mu/Rpc.hs @@ -9,7 +9,7 @@ -- | Protocol-independent declaration of services module Mu.Rpc ( Service', Service(..) -, Annotation, Package, FindPackageName +, ServiceAnnotation, Package, FindPackageName , Method(..), (:-->:) , TypeRef(..), Argument(..), Return(..) ) where @@ -22,23 +22,24 @@ import Mu.Schema import Mu.Schema.Registry type Service' = Service Symbol Symbol +type ServiceAnnotation = Type -- | A service is a set of methods. data Service serviceName methodName - = Service serviceName [Annotation] [Method methodName] + = Service serviceName [ServiceAnnotation] [Method methodName] -- | An annotation to define a package name. -- This is used by some handlers, like gRPC. data Package (s :: Symbol) -type family FindPackageName (anns :: [Annotation]) :: Symbol where +type family FindPackageName (anns :: [ServiceAnnotation]) :: Symbol where FindPackageName '[] = TypeError ('Text "Cannot find package name for the service") FindPackageName (Package s ': rest) = s FindPackageName (other ': rest) = FindPackageName rest -- | A method is defined by its name, arguments, and return type. data Method methodName - = Method methodName [Annotation] [Argument] Return + = Method methodName [ServiceAnnotation] [Argument] Return -- | Look up a method in a service definition using its name. -- Useful to declare handlers like @HandlerIO (MyService :-->: "MyMethod")@. diff --git a/core/rpc/src/Mu/Rpc/Examples.hs b/core/rpc/src/Mu/Rpc/Examples.hs index efeee43f..fb54ab6b 100644 --- a/core/rpc/src/Mu/Rpc/Examples.hs +++ b/core/rpc/src/Mu/Rpc/Examples.hs @@ -25,12 +25,12 @@ import Mu.Server -- https://grpc.io/docs/quickstart/python/ type QuickstartSchema - = '[ 'DRecord "HelloRequest" '[] - '[ 'FieldDef "name" '[ ProtoBufId 1 ] ('TPrimitive T.Text) ] - , 'DRecord "HelloResponse" '[] - '[ 'FieldDef "message" '[ ProtoBufId 1 ] ('TPrimitive T.Text) ] - , 'DRecord "HiRequest" '[] - '[ 'FieldDef "number" '[ ProtoBufId 1 ] ('TPrimitive Int) ] + = '[ 'DRecord "HelloRequest" + '[ 'FieldDef "name" ('TPrimitive T.Text) ] + , 'DRecord "HelloResponse" + '[ 'FieldDef "message" ('TPrimitive T.Text) ] + , 'DRecord "HiRequest" + '[ 'FieldDef "number" ('TPrimitive Int) ] ] type QuickStartService diff --git a/core/schema/src/Mu/Adapter/Json.hs b/core/schema/src/Mu/Adapter/Json.hs index a3be8028..876b6083 100644 --- a/core/schema/src/Mu/Adapter/Json.hs +++ b/core/schema/src/Mu/Adapter/Json.hs @@ -46,9 +46,9 @@ instance (HasSchema sch sty a, FromJSON (Term sch (sch :/: sty))) => FromJSON (WithSchema sch sty a) where parseJSON v = WithSchema . fromSchema' @sch <$> parseJSON v -instance ToJSONFields sch args => ToJSON (Term sch ('DRecord name anns args)) where +instance ToJSONFields sch args => ToJSON (Term sch ('DRecord name args)) where toJSON (TRecord fields) = Object (toJSONFields fields) -instance FromJSONFields sch args => FromJSON (Term sch ('DRecord name anns args)) where +instance FromJSONFields sch args => FromJSON (Term sch ('DRecord name args)) where parseJSON (Object v) = TRecord <$> parseJSONFields v parseJSON _ = fail "expected object" @@ -57,7 +57,7 @@ class ToJSONFields sch fields where instance ToJSONFields sch '[] where toJSONFields _ = HM.empty instance (KnownName name, ToJSON (FieldValue sch t), ToJSONFields sch fs) - => ToJSONFields sch ('FieldDef name anns t ': fs) where + => ToJSONFields sch ('FieldDef name t ': fs) where toJSONFields (Field v :* rest) = HM.insert key value (toJSONFields rest) where key = T.pack (nameVal (Proxy @name)) value = toJSON v @@ -67,13 +67,13 @@ class FromJSONFields sch fields where instance FromJSONFields sch '[] where parseJSONFields _ = return Nil instance (KnownName name, FromJSON (FieldValue sch t), FromJSONFields sch fs) - => FromJSONFields sch ('FieldDef name anns t ': fs) where + => FromJSONFields sch ('FieldDef name t ': fs) where parseJSONFields v = (:*) <$> (Field <$> v .: key) <*> parseJSONFields v where key = T.pack (nameVal (Proxy @name)) -instance ToJSONEnum choices => ToJSON (Term sch ('DEnum name anns choices)) where +instance ToJSONEnum choices => ToJSON (Term sch ('DEnum name choices)) where toJSON (TEnum choice) = String (toJSONEnum choice) -instance FromJSONEnum choices => FromJSON (Term sch ('DEnum name anns choices)) where +instance FromJSONEnum choices => FromJSON (Term sch ('DEnum name choices)) where parseJSON (String s) = TEnum <$> parseJSONEnum s parseJSON _ = fail "expected string" @@ -82,7 +82,7 @@ class ToJSONEnum choices where instance ToJSONEnum '[] where toJSONEnum = error "empty enum" instance (KnownName c, ToJSONEnum cs) - => ToJSONEnum ('ChoiceDef c anns ': cs) where + => ToJSONEnum ('ChoiceDef c ': cs) where toJSONEnum (Z _) = T.pack (nameVal (Proxy @c)) toJSONEnum (S v) = toJSONEnum v @@ -91,7 +91,7 @@ class FromJSONEnum choices where instance FromJSONEnum '[] where parseJSONEnum _ = fail "unknown enum value" instance (KnownName c, FromJSONEnum cs) - => FromJSONEnum ('ChoiceDef c anns ': cs) where + => FromJSONEnum ('ChoiceDef c ': cs) where parseJSONEnum v | v == key = return (Z Proxy) | otherwise = S <$> parseJSONEnum v diff --git a/core/schema/src/Mu/Schema.hs b/core/schema/src/Mu/Schema.hs index 190ba0d3..87926d11 100644 --- a/core/schema/src/Mu/Schema.hs +++ b/core/schema/src/Mu/Schema.hs @@ -3,7 +3,7 @@ module Mu.Schema ( -- * Schema definition Schema, Schema' -, Annotation, KnownName(..) +, KnownName(..) , TypeDef, TypeDefB(..) , ChoiceDef(..) , FieldDef, FieldDefB(..) @@ -18,7 +18,7 @@ module Mu.Schema ( -- ** Mappings between fields , Mapping(..), Mappings, MappingRight, MappingLeft -- ** Field annotations -, ProtoBufId, ProtoBufOneOfIds +, AnnotatedSchema, AnnotationDomain, Annotation(..) ) where import Mu.Schema.Annotations diff --git a/core/schema/src/Mu/Schema/Annotations.hs b/core/schema/src/Mu/Schema/Annotations.hs index d7e9fe75..b534df19 100644 --- a/core/schema/src/Mu/Schema/Annotations.hs +++ b/core/schema/src/Mu/Schema/Annotations.hs @@ -1,10 +1,49 @@ -{-# language DataKinds #-} -{-# language KindSignatures #-} +{-# language DataKinds #-} +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} module Mu.Schema.Annotations where +import Data.Kind import GHC.TypeLits --- ANNOTATION FOR CONVERSION +import Mu.Schema.Definition -data ProtoBufId (n :: Nat) -data ProtoBufOneOfIds (ns :: [Nat]) +-- | Libraries can define custom annotations. +-- Each annotation belongs to a domain. +type AnnotationDomain = Type + +-- | Libraries can define custom annotations +-- to indicate additional information. +data Annotation domain typeName fieldName where + AnnSchema :: domain + -> Annotation domain typeName fieldName + AnnType :: typeName -> domain + -> Annotation domain typeName fieldName + AnnField :: typeName -> fieldName -> domain + -> Annotation domain typeName fieldName + +-- | This type family links each schema to +-- its corresponding annotations from one domain. +type family AnnotatedSchema domain (sch :: Schema typeName fieldName) + :: [Annotation domain typeName fieldName] + +type family GetSchemaAnnotation (anns :: [Annotation domain t f]) :: domain where + GetSchemaAnnotation '[] + = TypeError ('Text "cannot find schema annotation") + GetSchemaAnnotation ('AnnSchema d ': rs) = d + GetSchemaAnnotation (r ': rs) = GetSchemaAnnotation rs + +type family GetTypeAnnotation (anns :: [Annotation domain t f]) (ty :: t) :: domain where + GetTypeAnnotation '[] ty + = TypeError ('Text "cannot find annotation for " ':<>: 'ShowType ty) + GetTypeAnnotation ('AnnType ty d ': rs) ty = d + GetTypeAnnotation (r ': rs) ty = GetTypeAnnotation rs ty + +type family GetFieldAnnotation (anns :: [Annotation domain t f]) (ty :: t) (fl :: f) :: domain where + GetFieldAnnotation '[] ty fl + = TypeError ('Text "cannot find annotation for " ':<>: 'ShowType ty ':<>: 'Text "/" ':<>: 'ShowType fl) + GetFieldAnnotation ('AnnField ty fl d ': rs) ty fl = d + GetFieldAnnotation (r ': rs) ty fl = GetFieldAnnotation rs ty fl diff --git a/core/schema/src/Mu/Schema/Class.hs b/core/schema/src/Mu/Schema/Class.hs index 8523e7d6..f323755b 100644 --- a/core/schema/src/Mu/Schema/Class.hs +++ b/core/schema/src/Mu/Schema/Class.hs @@ -105,13 +105,13 @@ type family FindSel (xs :: * -> *) (x :: Symbol) :: Where where type family FindEnumChoice (xs :: [ChoiceDef fs]) (x :: fs) :: Where where FindEnumChoice '[] x = TypeError ('Text "Could not find enum choice " ':<>: 'ShowType x) - FindEnumChoice ('ChoiceDef name anns ': xs) name = 'Here - FindEnumChoice (other ': xs) name = 'There (FindEnumChoice xs name) + FindEnumChoice ('ChoiceDef name ': xs) name = 'Here + FindEnumChoice (other ': xs) name = 'There (FindEnumChoice xs name) type family FindField (xs :: [FieldDef ts fs]) (x :: fs) :: Where where FindField '[] x = TypeError ('Text "Could not find field " ':<>: 'ShowType x) - FindField ('FieldDef name anns t ': xs) name = 'Here - FindField (other ': xs) name = 'There (FindField xs name) + FindField ('FieldDef name t ': xs) name = 'Here + FindField (other ': xs) name = 'There (FindField xs name) -- Generic type definitions class GSchemaTypeDef (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) @@ -207,6 +207,7 @@ instance (GSchemaFieldType sch t v) => GSchemaFieldTypeUnion sch '[t] (K1 i v) where toSchemaFieldTypeUnion (K1 x) = Z (toSchemaFieldType x) fromSchemaFieldTypeUnion (Z x) = K1 (fromSchemaFieldType x) + fromSchemaFieldTypeUnion (S _) = error "this should never happen" instance (GSchemaFieldType sch t v, GSchemaFieldTypeUnion sch ts vs) => GSchemaFieldTypeUnion sch (t ': ts) (K1 i v :+: vs) where toSchemaFieldTypeUnion (L1 (K1 x)) = Z (toSchemaFieldType x) @@ -230,14 +231,14 @@ instance (GSchemaFieldType sch t1 v1, GSchemaFieldType sch t2 v2, GSchemaFieldTy instance {-# OVERLAPPABLE #-} (GToSchemaEnumDecompose fmap choices f, GFromSchemaEnumDecompose fmap choices f) - => GSchemaTypeDef sch fmap ('DEnum name anns choices) f where + => GSchemaTypeDef sch fmap ('DEnum name choices) f where toSchemaTypeDef p x = TEnum (toSchemaEnumDecomp p x) fromSchemaTypeDef p (TEnum x) = fromSchemaEnumDecomp p x -- This instance removes unneeded metadata from the -- top of the type. instance {-# OVERLAPS #-} - GSchemaTypeDef sch fmap ('DEnum name anns choices) f - => GSchemaTypeDef sch fmap ('DEnum name anns choices) (D1 meta f) where + GSchemaTypeDef sch fmap ('DEnum name choices) f + => GSchemaTypeDef sch fmap ('DEnum name choices) (D1 meta f) where toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) @@ -282,7 +283,7 @@ class GFromSchemaEnumDecompose (fmap :: Mappings Symbol fs) (choices :: [ChoiceD instance GFromSchemaEnumDecompose fmap '[] f where fromSchemaEnumDecomp _ _ = error "This should never happen" instance (GFromSchemaEnumU1 f (FindCon f (MappingLeft fmap c)), GFromSchemaEnumDecompose fmap cs f) - => GFromSchemaEnumDecompose fmap ('ChoiceDef c anns ': cs) f where + => GFromSchemaEnumDecompose fmap ('ChoiceDef c ': cs) f where fromSchemaEnumDecomp _ (Z _) = fromSchemaEnumU1 (Proxy @f) (Proxy @(FindCon f (MappingLeft fmap c))) fromSchemaEnumDecomp p (S x) = fromSchemaEnumDecomp p x @@ -302,19 +303,19 @@ instance forall other rest w. GFromSchemaEnumU1 rest w instance {-# OVERLAPPABLE #-} (GToSchemaRecord sch fmap args f, GFromSchemaRecord sch fmap args f) - => GSchemaTypeDef sch fmap ('DRecord name anns args) f where + => GSchemaTypeDef sch fmap ('DRecord name args) f where toSchemaTypeDef p x = TRecord (toSchemaRecord p x) fromSchemaTypeDef p (TRecord x) = fromSchemaRecord p x -- This instance removes unneeded metadata from the -- top of the type. instance {-# OVERLAPS #-} - GSchemaTypeDef sch fmap ('DRecord name anns args) f - => GSchemaTypeDef sch fmap ('DRecord name anns args) (D1 meta f) where + GSchemaTypeDef sch fmap ('DRecord name args) f + => GSchemaTypeDef sch fmap ('DRecord name args) (D1 meta f) where toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) instance {-# OVERLAPS #-} - GSchemaTypeDef sch fmap ('DRecord name anns args) f - => GSchemaTypeDef sch fmap ('DRecord name anns args) (C1 meta f) where + GSchemaTypeDef sch fmap ('DRecord name args) f + => GSchemaTypeDef sch fmap ('DRecord name args) (C1 meta f) where toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) @@ -338,7 +339,7 @@ instance GToSchemaRecord sch fmap '[] f where toSchemaRecord _ _ = Nil instance ( GToSchemaRecord sch fmap cs f , GToSchemaRecordSearch sch t f (FindSel f (MappingLeft fmap name)) ) - => GToSchemaRecord sch fmap ('FieldDef name anns t ': cs) f where + => GToSchemaRecord sch fmap ('FieldDef name t ': cs) f where toSchemaRecord p x = this :* toSchemaRecord p x where this = Field (toSchemaRecordSearch (Proxy @(FindSel f (MappingLeft fmap name))) x) @@ -383,7 +384,7 @@ instance GFromSchemaRecord sch fmap args U1 where class GFromSchemaRecordSearch (sch :: Schema ts fs) (v :: *) (args :: [FieldDef ts fs]) (w :: Where) where fromSchemaRecordSearch :: Proxy w -> NP (Field sch) args -> v -instance GSchemaFieldType sch t v => GFromSchemaRecordSearch sch v ('FieldDef name anns t ': rest) 'Here where +instance GSchemaFieldType sch t v => GFromSchemaRecordSearch sch v ('FieldDef name t ': rest) 'Here where fromSchemaRecordSearch _ (Field x :* _) = fromSchemaFieldType x instance forall sch v other rest n. GFromSchemaRecordSearch sch v rest n diff --git a/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs b/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs index 0f50f112..b274b1ce 100644 --- a/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs +++ b/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs @@ -43,7 +43,7 @@ generateTypesFromSchema namer schemaTyName typeDefToDecl :: Type -> Namer -> TypeDefB Type String String -> Q [Dec] -- Records with one field -typeDefToDecl schemaTy namer (DRecord name _ [f]) +typeDefToDecl schemaTy namer (DRecord name [f]) = do let complete = completeName namer name d <- newtypeD (pure []) (mkName complete) @@ -54,7 +54,7 @@ typeDefToDecl schemaTy namer (DRecord name _ [f]) let hsi = generateHasSchemaInstance schemaTy name complete (fieldMapping complete [f]) return [d, hsi] -- Records with more than one field -typeDefToDecl schemaTy namer (DRecord name _ fields) +typeDefToDecl schemaTy namer (DRecord name fields) = do let complete = completeName namer name d <- dataD (pure []) (mkName complete) @@ -65,14 +65,14 @@ typeDefToDecl schemaTy namer (DRecord name _ fields) let hsi = generateHasSchemaInstance schemaTy name complete (fieldMapping complete fields) return [d, hsi] -- Enumerations -typeDefToDecl schemaTy namer (DEnum name _ choices) +typeDefToDecl schemaTy namer (DEnum name choices) = do let complete = completeName namer name d <- dataD (pure []) (mkName complete) [] Nothing [ pure (RecC (mkName (choiceName complete choicename)) []) - | ChoiceDef choicename _ <- choices] + | ChoiceDef choicename <- choices] deriveClauses let hsi = generateHasSchemaInstance schemaTy name complete (choiceMapping complete choices) return [d, hsi] @@ -89,7 +89,7 @@ deriveClauses -} fieldDefToDecl :: Namer -> String -> FieldDefB Type String String -> (Name, Bang, Type) -fieldDefToDecl namer complete (FieldDef name _ ty) +fieldDefToDecl namer complete (FieldDef name ty) = ( mkName (fieldName complete name) , Bang NoSourceUnpackedness NoSourceStrictness , fieldTypeToDecl namer ty ) @@ -115,7 +115,7 @@ generateHasSchemaInstance schemaTy schemaName complete mapping fieldMapping :: String -> [FieldDefB Type String String] -> Type fieldMapping _complete [] = PromotedNilT -fieldMapping complete (FieldDef name _ _ : rest) +fieldMapping complete (FieldDef name _ : rest) = AppT (AppT PromotedConsT thisMapping) (fieldMapping complete rest) where thisMapping = AppT (AppT (PromotedT '(:->)) @@ -124,7 +124,7 @@ fieldMapping complete (FieldDef name _ _ : rest) choiceMapping :: String -> [ChoiceDef String] -> Type choiceMapping _complete [] = PromotedNilT -choiceMapping complete (ChoiceDef name _ : rest) +choiceMapping complete (ChoiceDef name : rest) = AppT (AppT PromotedConsT thisMapping) (choiceMapping complete rest) where thisMapping = AppT (AppT (PromotedT '(:->)) @@ -189,14 +189,12 @@ typeToSchemaDef toplevelty typeToTypeDef t = typeToRecordDef t <|> typeToEnumDef t <|> typeToSimpleType t typeToRecordDef t - = do (nm, _anns, fields) <- tyD3 'DRecord t + = do (nm, fields) <- tyD2 'DRecord t DRecord <$> tyString nm - <*> pure [] <*> (mapM typeToFieldDef =<< tyList fields) typeToEnumDef t - = do (nm, _anns, choices) <- tyD3 'DEnum t + = do (nm, choices) <- tyD2 'DEnum t DEnum <$> tyString nm - <*> pure [] <*> (mapM typeToChoiceDef =<< tyList choices) typeToSimpleType t = do innerT <- tyD1 'DSimple t @@ -204,15 +202,14 @@ typeToSchemaDef toplevelty typeToFieldDef :: Type -> Maybe (FieldDefB Type String String) typeToFieldDef t - = do (nm, _anns, innerTy) <- tyD3 'FieldDef t + = do (nm, innerTy) <- tyD2 'FieldDef t FieldDef <$> tyString nm - <*> pure [] <*> typeToFieldType innerTy typeToChoiceDef :: Type -> Maybe (ChoiceDef String) typeToChoiceDef t - = do (nm, _anns) <- tyD2 'ChoiceDef t - ChoiceDef <$> tyString nm <*> pure [] + = do nm <- tyD1 'ChoiceDef t + ChoiceDef <$> tyString nm typeToFieldType :: Type -> Maybe (FieldTypeB Type String) typeToFieldType t @@ -267,9 +264,11 @@ tyD2 name (AppT (AppT (PromotedT c) x) y) | otherwise = Nothing tyD2 _ _ = Nothing +{- tyD3 :: Name -> Type -> Maybe (Type, Type, Type) tyD3 name (SigT t _) = tyD3 name t tyD3 name (AppT (AppT (AppT (PromotedT c) x) y) z) | c == name = Just (x, y, z) | otherwise = Nothing tyD3 _ _ = Nothing +-} diff --git a/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs b/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs index fabb0aa7..ef5b0e59 100644 --- a/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs +++ b/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs @@ -44,8 +44,8 @@ type family SchemaFromTypes' (all :: [FromType tn fn]) (f :: [FromType tn fn]) : type family TypeDefFromType (all :: [FromType tn fn]) (info :: FromType tn fn) :: TypeDef tn fn where - TypeDefFromType all ('AsRecord' t name mp) = 'DRecord name '[] (FieldsFromType all mp (Rep t)) - TypeDefFromType all ('AsEnum' t name mp) = 'DEnum name '[] (ChoicesFromType all mp (Rep t)) + TypeDefFromType all ('AsRecord' t name mp) = 'DRecord name (FieldsFromType all mp (Rep t)) + TypeDefFromType all ('AsEnum' t name mp) = 'DEnum name (ChoicesFromType all mp (Rep t)) type family FieldsFromType (all :: [FromType tn fn]) (mp :: Mappings Symbol fn) (f :: * -> *) :: [FieldDef tn fn] where @@ -58,7 +58,7 @@ type family FieldsFromType (all :: [FromType tn fn]) (mp :: Mappings Symbol fn) FieldsFromType all mp (x :*: y) = ConcatList (FieldsFromType all mp x) (FieldsFromType all mp y) FieldsFromType all mp (S1 ('MetaSel ('Just x) u ss ds) (K1 i t)) - = '[ 'FieldDef (MappingRight mp x) '[] (ChooseFieldType all t) ] + = '[ 'FieldDef (MappingRight mp x) (ChooseFieldType all t) ] FieldsFromType all mp v = TypeError ('Text "unsupported conversion from " ':<>: 'ShowType v ':<>: 'Text " to record schema") @@ -99,7 +99,7 @@ type family ChoicesFromType (all :: [FromType tn fn]) (mp :: Mappings Symbol fn) ChoicesFromType all mp (x :+: y) = ConcatList (ChoicesFromType all mp x) (ChoicesFromType all mp y) ChoicesFromType all mp (C1 ('MetaCons cname p s) U1) - = '[ 'ChoiceDef (MappingRight mp cname) '[] ] -- go through constructor info + = '[ 'ChoiceDef (MappingRight mp cname) ] -- go through constructor info ChoicesFromType all mp (C1 ('MetaCons cname p s) f) = TypeError ('Text "constructor " ':<>: 'ShowType cname ':<>: 'Text "has fields and cannot be turned into an enumeration schema") ChoicesFromType all mp v diff --git a/core/schema/src/Mu/Schema/Definition.hs b/core/schema/src/Mu/Schema/Definition.hs index 65d30941..9ae6af11 100644 --- a/core/schema/src/Mu/Schema/Definition.hs +++ b/core/schema/src/Mu/Schema/Definition.hs @@ -43,10 +43,6 @@ type Schema typeName fieldName type SchemaB builtin typeName fieldName = [TypeDefB builtin typeName fieldName] --- | Libraries can define custom annotations --- to indicate additional information. -type Annotation = Type - -- | Defines a type in a schema. -- Each type can be: -- * a record: a list of key-value pairs, @@ -54,19 +50,19 @@ type Annotation = Type -- * a reference to a primitive type. type TypeDef = TypeDefB Type data TypeDefB builtin typeName fieldName - = DRecord typeName [Annotation] [FieldDefB builtin typeName fieldName] - | DEnum typeName [Annotation] [ChoiceDef fieldName] + = DRecord typeName [FieldDefB builtin typeName fieldName] + | DEnum typeName [ChoiceDef fieldName] | DSimple (FieldTypeB builtin typeName) -- | Defines each of the choices in an enumeration. -data ChoiceDef fieldName - = ChoiceDef fieldName [Annotation] +newtype ChoiceDef fieldName + = ChoiceDef fieldName -- | Defines a field in a record -- by a name and the corresponding type. type FieldDef = FieldDefB Type data FieldDefB builtin typeName fieldName - = FieldDef fieldName [Annotation] (FieldTypeB builtin typeName) + = FieldDef fieldName (FieldTypeB builtin typeName) -- | Types of fields of a record. -- References to other types in the same schema @@ -84,9 +80,9 @@ data FieldTypeB builtin typeName -- | Lookup a type in a schema by its name. type family (sch :: Schema t f) :/: (name :: t) :: TypeDef t f where '[] :/: name = TypeError ('Text "Cannot find type " ':<>: 'ShowType name ':<>: 'Text " in the schema") - ('DRecord name ann fields ': rest) :/: name = 'DRecord name ann fields - ('DEnum name ann choices ': rest) :/: name = 'DEnum name ann choices - (other ': rest) :/: name = rest :/: name + ('DRecord name fields ': rest) :/: name = 'DRecord name fields + ('DEnum name choices ': rest) :/: name = 'DEnum name choices + (other ': rest) :/: name = rest :/: name -- | Defines a mapping between two elements. data Mapping a b = a :-> b @@ -117,12 +113,12 @@ class ReflectSchema (s :: Schema tn fn) where instance ReflectSchema '[] where reflectSchema _ = [] instance (ReflectFields fields, KnownName name, ReflectSchema s) - => ReflectSchema ('DRecord name anns fields ': s) where - reflectSchema _ = DRecord (nameVal (Proxy @name)) [] (reflectFields (Proxy @fields)) + => ReflectSchema ('DRecord name fields ': s) where + reflectSchema _ = DRecord (nameVal (Proxy @name)) (reflectFields (Proxy @fields)) : reflectSchema (Proxy @s) instance (ReflectChoices choices, KnownName name, ReflectSchema s) - => ReflectSchema ('DEnum name anns choices ': s) where - reflectSchema _ = DEnum (nameVal (Proxy @name)) [] (reflectChoices (Proxy @choices)) + => ReflectSchema ('DEnum name choices ': s) where + reflectSchema _ = DEnum (nameVal (Proxy @name)) (reflectChoices (Proxy @choices)) : reflectSchema (Proxy @s) instance (ReflectFieldType ty, ReflectSchema s) => ReflectSchema ('DSimple ty ': s) where @@ -134,8 +130,8 @@ class ReflectFields (fs :: [FieldDef tn fn]) where instance ReflectFields '[] where reflectFields _ = [] instance (KnownName name, ReflectFieldType ty, ReflectFields fs) - => ReflectFields ('FieldDef name anns ty ': fs) where - reflectFields _ = FieldDef (nameVal (Proxy @name)) [] (reflectFieldType (Proxy @ty)) + => ReflectFields ('FieldDef name ty ': fs) where + reflectFields _ = FieldDef (nameVal (Proxy @name)) (reflectFieldType (Proxy @ty)) : reflectFields (Proxy @fs) class ReflectChoices (cs :: [ChoiceDef fn]) where @@ -143,8 +139,8 @@ class ReflectChoices (cs :: [ChoiceDef fn]) where instance ReflectChoices '[] where reflectChoices _ = [] instance (KnownName name, ReflectChoices cs) - => ReflectChoices ('ChoiceDef name anns ': cs) where - reflectChoices _ = ChoiceDef (nameVal (Proxy @name)) [] + => ReflectChoices ('ChoiceDef name ': cs) where + reflectChoices _ = ChoiceDef (nameVal (Proxy @name)) : reflectChoices (Proxy @cs) class ReflectFieldType (ty :: FieldType tn) where diff --git a/core/schema/src/Mu/Schema/Examples.hs b/core/schema/src/Mu/Schema/Examples.hs index 90d2bf3b..8d4e1348 100644 --- a/core/schema/src/Mu/Schema/Examples.hs +++ b/core/schema/src/Mu/Schema/Examples.hs @@ -48,19 +48,19 @@ data Gender = Male | Female | NonBinary -- Schema for these data types type ExampleSchema - = '[ 'DEnum "gender" '[] - '[ 'ChoiceDef "male" '[ ProtoBufId 1 ] - , 'ChoiceDef "female" '[ ProtoBufId 2 ] - , 'ChoiceDef "nb" '[ ProtoBufId 3 ] ] - , 'DRecord "address" '[] - '[ 'FieldDef "postcode" '[ ProtoBufId 1 ] ('TPrimitive T.Text) - , 'FieldDef "country" '[ ProtoBufId 2 ] ('TPrimitive T.Text) ] - , 'DRecord "person" '[] - '[ 'FieldDef "firstName" '[ ProtoBufId 1 ] ('TPrimitive T.Text) - , 'FieldDef "lastName" '[ ProtoBufId 2 ] ('TPrimitive T.Text) - , 'FieldDef "age" '[ ProtoBufId 3 ] ('TOption ('TPrimitive Int)) - , 'FieldDef "gender" '[ ProtoBufId 4 ] ('TOption ('TSchematic "gender")) - , 'FieldDef "address" '[ ProtoBufId 5 ] ('TSchematic "address") ] + = '[ 'DEnum "gender" + '[ 'ChoiceDef "male" + , 'ChoiceDef "female" + , 'ChoiceDef "nb" ] + , 'DRecord "address" + '[ 'FieldDef "postcode" ('TPrimitive T.Text) + , 'FieldDef "country" ('TPrimitive T.Text) ] + , 'DRecord "person" + '[ 'FieldDef "firstName" ('TPrimitive T.Text) + , 'FieldDef "lastName" ('TPrimitive T.Text) + , 'FieldDef "age" ('TOption ('TPrimitive Int)) + , 'FieldDef "gender" ('TOption ('TSchematic "gender")) + , 'FieldDef "address" ('TSchematic "address") ] ] type GenderFieldMapping @@ -81,19 +81,19 @@ type ExampleSchema2 , AsEnum Gender "gender" ] -} type ExampleSchema2 - = '[ 'DEnum "gender" '[] - '[ 'ChoiceDef "Male" '[ ProtoBufId 1 ] - , 'ChoiceDef "Female" '[ ProtoBufId 2 ] - , 'ChoiceDef "NonBinary" '[ ProtoBufId 3 ] ] - , 'DRecord "address" '[] - '[ 'FieldDef "postcode" '[ ProtoBufId 1 ] ('TPrimitive T.Text) - , 'FieldDef "country" '[ ProtoBufId 2 ] ('TPrimitive T.Text) ] - , 'DRecord "person" '[] - '[ 'FieldDef "firstName" '[ ProtoBufId 1 ] ('TPrimitive T.Text) - , 'FieldDef "lastName" '[ ProtoBufId 2 ] ('TPrimitive T.Text) - , 'FieldDef "age" '[ ProtoBufId 3 ] ('TOption ('TPrimitive Int)) - , 'FieldDef "gender" '[ ProtoBufId 4 ] ('TOption ('TSchematic "gender")) - , 'FieldDef "address" '[ ProtoBufId 5 ] ('TSchematic "address") ] + = '[ 'DEnum "gender" + '[ 'ChoiceDef "Male" + , 'ChoiceDef "Female" + , 'ChoiceDef "NonBinary" ] + , 'DRecord "address" + '[ 'FieldDef "postcode" ('TPrimitive T.Text) + , 'FieldDef "country" ('TPrimitive T.Text) ] + , 'DRecord "person" + '[ 'FieldDef "firstName" ('TPrimitive T.Text) + , 'FieldDef "lastName" ('TPrimitive T.Text) + , 'FieldDef "age" ('TOption ('TPrimitive Int)) + , 'FieldDef "gender" ('TOption ('TSchematic "gender")) + , 'FieldDef "address" ('TSchematic "address") ] ] type ExampleRegistry diff --git a/core/schema/src/Mu/Schema/Interpretation.hs b/core/schema/src/Mu/Schema/Interpretation.hs index c12cd91d..f7aa0fed 100644 --- a/core/schema/src/Mu/Schema/Interpretation.hs +++ b/core/schema/src/Mu/Schema/Interpretation.hs @@ -22,13 +22,13 @@ import Mu.Schema.Definition -- | Interpretation of a type in a schema. data Term (sch :: Schema typeName fieldName) (t :: TypeDef typeName fieldName) where - TRecord :: NP (Field sch) args -> Term sch ('DRecord name anns args) - TEnum :: NS Proxy choices -> Term sch ('DEnum name anns choices) + TRecord :: NP (Field sch) args -> Term sch ('DRecord name args) + TEnum :: NS Proxy choices -> Term sch ('DEnum name choices) TSimple :: FieldValue sch t -> Term sch ('DSimple t) -- | Interpretation of a field. data Field (sch :: Schema typeName fieldName) (f :: FieldDef typeName fieldName) where - Field :: FieldValue sch t -> Field sch ('FieldDef name anns t) + Field :: FieldValue sch t -> Field sch ('FieldDef name t) -- | Interpretation of a field type, by giving a value of that type. data FieldValue (sch :: Schema typeName fieldName) (t :: FieldType typeName) where @@ -50,20 +50,20 @@ data FieldValue (sch :: Schema typeName fieldName) (t :: FieldType typeName) whe -- =========================== instance All (Eq `Compose` Field sch) args - => Eq (Term sch ('DRecord name anns args)) where + => Eq (Term sch ('DRecord name args)) where TRecord xs == TRecord ys = xs == ys instance (KnownName name, All (Show `Compose` Field sch) args) - => Show (Term sch ('DRecord name anns args)) where + => Show (Term sch ('DRecord name args)) where show (TRecord xs) = "record " ++ nameVal (Proxy @name) ++ " { " ++ printFields xs ++ " }" where printFields :: forall fs. All (Show `Compose` Field sch) fs => NP (Field sch) fs -> String printFields Nil = "" printFields (x :* Nil) = show x printFields (x :* rest) = show x ++ ", " ++ printFields rest -instance All (Eq `Compose` Proxy) choices => Eq (Term sch ('DEnum name anns choices)) where +instance All (Eq `Compose` Proxy) choices => Eq (Term sch ('DEnum name choices)) where TEnum x == TEnum y = x == y instance (KnownName name, All KnownName choices, All (Show `Compose` Proxy) choices) - => Show (Term sch ('DEnum name anns choices)) where + => Show (Term sch ('DEnum name choices)) where show (TEnum choice) = "enum " ++ nameVal (Proxy @name) ++ " { " ++ printChoice choice ++ " }" where printChoice :: forall cs. All KnownName cs => NS Proxy cs -> String printChoice (Z p) = nameVal p @@ -73,10 +73,10 @@ instance Eq (FieldValue sch t) => Eq (Term sch ('DSimple t)) where instance Show (FieldValue sch t) => Show (Term sch ('DSimple t)) where show (TSimple x) = show x -instance Eq (FieldValue sch t) => Eq (Field sch ('FieldDef name anns t)) where +instance Eq (FieldValue sch t) => Eq (Field sch ('FieldDef name t)) where Field x == Field y = x == y instance (KnownName name, Show (FieldValue sch t)) - => Show (Field sch ('FieldDef name anns t)) where + => Show (Field sch ('FieldDef name t)) where show (Field x) = nameVal (Proxy @name) ++ ": " ++ show x instance Eq (FieldValue sch 'TNull) where diff --git a/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs b/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs index 857017bd..4d8641c5 100644 --- a/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs +++ b/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs @@ -14,60 +14,60 @@ import Data.SOP import Mu.Schema data V0 sch sty where - V0 :: (sch :/: sty ~ 'DRecord nm anns '[]) + V0 :: (sch :/: sty ~ 'DRecord nm '[]) => V0 sch sty deriving instance Show (V0 sch sty) deriving instance Eq (V0 sch sty) deriving instance Ord (V0 sch sty) -instance (sch :/: sty ~ 'DRecord nm anns '[]) +instance (sch :/: sty ~ 'DRecord nm '[]) => HasSchema sch sty (V0 sch sty) where toSchema V0 = TRecord Nil fromSchema (TRecord Nil) = V0 data V1 sch sty where V1 :: (sch :/: sty - ~ 'DRecord nm anns '[ 'FieldDef f fanns ('TPrimitive a) ]) + ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) => a -> V1 sch sty deriving instance (Show a, sch :/: sty - ~ 'DRecord anns nm '[ 'FieldDef f fanns ('TPrimitive a) ]) + ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) => Show (V1 sch sty) deriving instance (Eq a, sch :/: sty - ~ 'DRecord nm anns '[ 'FieldDef f fanns ('TPrimitive a) ]) + ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) => Eq (V1 sch sty) deriving instance (Ord a, sch :/: sty - ~ 'DRecord nm anns '[ 'FieldDef f fanns ('TPrimitive a) ]) + ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) => Ord (V1 sch sty) instance (sch :/: sty - ~ 'DRecord nm anns '[ 'FieldDef f fanns ('TPrimitive a) ]) + ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) => HasSchema sch sty (V1 sch sty) where toSchema (V1 x) = TRecord (Field (FPrimitive x) :* Nil) fromSchema (TRecord (Field (FPrimitive x) :* Nil)) = V1 x data V2 sch sty where V2 :: (sch :/: sty - ~ 'DRecord nm anns '[ 'FieldDef f fanns ('TPrimitive a) - , 'FieldDef g ganns ('TPrimitive b) ]) + ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) + , 'FieldDef g ('TPrimitive b) ]) => a -> b -> V2 sch sty deriving instance (Show a, Show b, - sch :/: sty ~ 'DRecord nm anns '[ 'FieldDef f fanns ('TPrimitive a) - , 'FieldDef g ganns ('TPrimitive b) ]) + sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) + , 'FieldDef g ('TPrimitive b) ]) => Show (V2 sch sty) deriving instance (Eq a, Eq b, - sch :/: sty ~ 'DRecord nm anns '[ 'FieldDef f fanns ('TPrimitive a) - , 'FieldDef g ganns ('TPrimitive b) ]) + sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) + , 'FieldDef g ('TPrimitive b) ]) => Eq (V2 sch sty) deriving instance (Ord a, Ord b, - sch :/: sty ~ 'DRecord nm anns '[ 'FieldDef f fanns ('TPrimitive a) - , 'FieldDef g ganns ('TPrimitive b) ]) + sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) + , 'FieldDef g ('TPrimitive b) ]) => Ord (V2 sch sty) -instance (sch :/: sty ~ 'DRecord nm anns '[ 'FieldDef f fanns ('TPrimitive a) - , 'FieldDef g ganns ('TPrimitive b) ]) +instance (sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) + , 'FieldDef g ('TPrimitive b) ]) => HasSchema sch sty (V2 sch sty) where toSchema (V2 x y) = TRecord (Field (FPrimitive x) :* Field (FPrimitive y) :* Nil) fromSchema (TRecord (Field (FPrimitive x) :* Field (FPrimitive y) :* Nil)) = V2 x y diff --git a/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs b/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs index cce37a4c..1225f8e5 100644 --- a/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs +++ b/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs @@ -81,13 +81,13 @@ class CheckSchemaValue (s :: Schema tn fn) (field :: FieldType tn) where class CheckSchemaUnion (s :: Schema tn fn) (ts :: [FieldType tn]) where checkSchemaUnion :: FieldValue -> Maybe (NS (S.FieldValue s) ts) -instance CheckSchemaFields s fields => CheckSchema s ('DRecord nm anns fields) where +instance CheckSchemaFields s fields => CheckSchema s ('DRecord nm fields) where checkSchema' (TRecord fields) = S.TRecord <$> checkSchemaFields fields checkSchema' _ = Nothing instance CheckSchemaFields s '[] where checkSchemaFields _ = pure Nil instance (KnownName nm, CheckSchemaValue s ty, CheckSchemaFields s rest) - => CheckSchemaFields s ('FieldDef nm anns ty ': rest) where + => CheckSchemaFields s ('FieldDef nm ty ': rest) where checkSchemaFields fs = do let name = T.pack (nameVal (Proxy @nm)) Field _ v <- find (\(Field fieldName _) -> fieldName == name) fs @@ -95,7 +95,7 @@ instance (KnownName nm, CheckSchemaValue s ty, CheckSchemaFields s rest) r' <- checkSchemaFields @_ @_ @s @rest fs return (S.Field v' :* r') -instance CheckSchemaEnum choices => CheckSchema s ('DEnum nm anns choices) where +instance CheckSchemaEnum choices => CheckSchema s ('DEnum nm choices) where checkSchema' (TEnum n) = S.TEnum <$> checkSchemaEnumInt n checkSchema' (TSimple (FPrimitive (n :: a))) = case (eqT @a @Int, eqT @a @T.Text, eqT @a @String) of @@ -108,7 +108,7 @@ instance CheckSchemaEnum '[] where checkSchemaEnumInt _ = Nothing checkSchemaEnumText _ = Nothing instance (KnownName c, CheckSchemaEnum cs) - => CheckSchemaEnum ('ChoiceDef c anns ': cs) where + => CheckSchemaEnum ('ChoiceDef c ': cs) where checkSchemaEnumInt 0 = Just (Z Proxy) checkSchemaEnumInt n = S <$> checkSchemaEnumInt (n-1) checkSchemaEnumText t diff --git a/examples/seed/src/Schema.hs b/examples/seed/src/Schema.hs index 3f69767c..7e3b721d 100644 --- a/examples/seed/src/Schema.hs +++ b/examples/seed/src/Schema.hs @@ -7,6 +7,7 @@ {-# language MultiParamTypeClasses #-} {-# language PolyKinds #-} {-# language TemplateHaskell #-} +{-# language TypeFamilies #-} {-# language TypeOperators #-} module Schema where diff --git a/examples/todolist/src/Definition.hs b/examples/todolist/src/Definition.hs index 30844e26..dc197238 100644 --- a/examples/todolist/src/Definition.hs +++ b/examples/todolist/src/Definition.hs @@ -7,6 +7,7 @@ {-# language MultiParamTypeClasses #-} {-# language PolyKinds #-} {-# language TemplateHaskell #-} +{-# language TypeFamilies #-} {-# language TypeOperators #-} module Definition where diff --git a/grpc/client/src/Mu/GRpc/Client/Examples.hs b/grpc/client/src/Mu/GRpc/Client/Examples.hs index bf11bf59..8c19833b 100644 --- a/grpc/client/src/Mu/GRpc/Client/Examples.hs +++ b/grpc/client/src/Mu/GRpc/Client/Examples.hs @@ -1,5 +1,6 @@ {-# language DataKinds #-} {-# language TypeApplications #-} +{-# language TypeFamilies #-} module Mu.GRpc.Client.Examples where import Data.Conduit @@ -8,8 +9,15 @@ import Data.Conduit.List (consume) import qualified Data.Text as T import Network.HTTP2.Client (HostName, PortNumber) +import Mu.Adapter.ProtoBuf import Mu.GRpc.Client.TyApps import Mu.Rpc.Examples +import Mu.Schema + +type instance AnnotatedSchema ProtoBufAnnotation QuickstartSchema + = '[ 'AnnField "HelloRequest" "name" ('ProtoBufId 1) + , 'AnnField "HelloResponse" "message" ('ProtoBufId 1) + , 'AnnField "HiRequest" "number" ('ProtoBufId 1) ] sayHello' :: HostName -> PortNumber -> T.Text -> IO (GRpcReply T.Text) sayHello' host port req diff --git a/grpc/client/src/Mu/GRpc/Client/Record.hs b/grpc/client/src/Mu/GRpc/Client/Record.hs index 285b636f..4e776e15 100644 --- a/grpc/client/src/Mu/GRpc/Client/Record.hs +++ b/grpc/client/src/Mu/GRpc/Client/Record.hs @@ -44,7 +44,7 @@ import Mu.Rpc -- | Fills in a Haskell record of functions with the corresponding -- calls to gRPC services from a Mu 'Service' declaration. buildService :: forall (s :: Service') (p :: Symbol) t - (nm :: Symbol) (anns :: [Annotation]) (ms :: [Method Symbol]). + (nm :: Symbol) (anns :: [ServiceAnnotation]) (ms :: [Method Symbol]). (s ~ 'Service nm anns ms, Generic t, BuildService s p ms (Rep t)) => GrpcClient -> t buildService client = to (buildService' (Proxy @s) (Proxy @p) (Proxy @ms) client) diff --git a/grpc/server/src/ExampleServer.hs b/grpc/server/src/ExampleServer.hs index e4e4def4..2fac34a8 100644 --- a/grpc/server/src/ExampleServer.hs +++ b/grpc/server/src/ExampleServer.hs @@ -1,8 +1,17 @@ +{-# language DataKinds #-} {-# language OverloadedStrings #-} +{-# language TypeFamilies #-} module Main where +import Mu.Adapter.ProtoBuf import Mu.GRpc.Server import Mu.Rpc.Examples +import Mu.Schema + +type instance AnnotatedSchema ProtoBufAnnotation QuickstartSchema + = '[ 'AnnField "HelloRequest" "name" ('ProtoBufId 1) + , 'AnnField "HelloResponse" "message" ('ProtoBufId 1) + , 'AnnField "HiRequest" "number" ('ProtoBufId 1) ] main :: IO () main = do diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 35fe4447..a45dac03 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2019-11-17 +resolver: nightly-2019-11-29 allow-newer: true packages: diff --git a/templates/grpc-server.hsfiles b/templates/grpc-server.hsfiles index 2da98573..2e8b30e3 100644 --- a/templates/grpc-server.hsfiles +++ b/templates/grpc-server.hsfiles @@ -73,6 +73,7 @@ service Service { {-# language MultiParamTypeClasses #-} {-# language PolyKinds #-} {-# language TemplateHaskell #-} +{-# language TypeFamilies #-} {-# language TypeOperators #-} module Schema where From 80f6dcfb47198fde94f4df98a897960115a87c91 Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Thu, 5 Dec 2019 09:23:36 +0100 Subject: [PATCH 013/217] =?UTF-8?q?Add=20recommended=20vscode=20extensions?= =?UTF-8?q?!=20=F0=9F=92=BB=20(#34)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .vscode/extensions.json | 10 ++++++++++ DEVELOPMENT.md | 11 +++++++++++ 2 files changed, 21 insertions(+) create mode 100644 .vscode/extensions.json diff --git a/.vscode/extensions.json b/.vscode/extensions.json new file mode 100644 index 00000000..145b9349 --- /dev/null +++ b/.vscode/extensions.json @@ -0,0 +1,10 @@ +{ + // See http://go.microsoft.com/fwlink/?LinkId=827846 + // for the documentation about the extensions.json format + "recommendations": [ + "DigitalAssetHoldingsLLC.ghcide", + "hoovercj.haskell-linter", + "vigoo.stylish-haskell", + "EditorConfig.EditorConfig" + ] +} diff --git a/DEVELOPMENT.md b/DEVELOPMENT.md index 041d11f3..4c8aa994 100644 --- a/DEVELOPMENT.md +++ b/DEVELOPMENT.md @@ -3,6 +3,7 @@ Before continuing, make sure you've read: - [Alejandro's post on setting up a Haskell development environment](https://www.47deg.com/blog/setting-up-haskell/). +- [Kowainik's Haskell Style Guide](https://kowainik.github.io/posts/2019-02-06-style-guide). ## VSCode extensions @@ -23,4 +24,14 @@ $ ... $ cd stylish-haskell && stack install ``` +We don't provide any git hook or tool that enforces our style. However, before you propose any PR please make sure to run `stylish-haskell` yourself, and to follow our style guide mentioned above to the extent possible. 😊 + +If you wan't to automate this for your VSCode, add the following to your `.vscode/settings.json`: + +```json +{ + "editor.formatOnSave": true +} +``` + Happy hacking! 👏🏼 From 427af367bc5a69d02baa005b828ac4c4e19dbaee Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Thu, 5 Dec 2019 09:32:18 +0100 Subject: [PATCH 014/217] Take metadata into account for GSchemaFieldTypeUnion (fixes #28) (#33) --- core/schema/src/Mu/Schema/Class.hs | 72 ++++++++++++++++-------------- 1 file changed, 38 insertions(+), 34 deletions(-) diff --git a/core/schema/src/Mu/Schema/Class.hs b/core/schema/src/Mu/Schema/Class.hs index f323755b..6a42676d 100644 --- a/core/schema/src/Mu/Schema/Class.hs +++ b/core/schema/src/Mu/Schema/Class.hs @@ -123,18 +123,21 @@ class GSchemaTypeDef (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) -- TYPES OF FIELDS -- -- ------------------ -instance {-# OVERLAPPABLE #-} - GSchemaFieldType sch t f - => GSchemaTypeDef sch fmap ('DSimple t) (K1 i f) where - toSchemaTypeDef _ (K1 x) = TSimple (toSchemaFieldType x) - fromSchemaTypeDef _ (TSimple x) = K1 (fromSchemaFieldType x) --- This instance removes unneeded metadata from the --- top of the type. -instance {-# OVERLAPS #-} - GSchemaTypeDef sch fmap ('DSimple t) f - => GSchemaTypeDef sch fmap ('DSimple t) (D1 meta f) where - toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x - fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) +instance GSchemaFieldTypeWrap sch t f + => GSchemaTypeDef sch fmap ('DSimple t) f where + toSchemaTypeDef _ x = TSimple (toSchemaFieldTypeW x) + fromSchemaTypeDef _ (TSimple x) = fromSchemaFieldTypeW x + +class GSchemaFieldTypeWrap (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where + toSchemaFieldTypeW :: f a -> FieldValue sch t + fromSchemaFieldTypeW :: FieldValue sch t -> f a + +instance GSchemaFieldType sch t f => GSchemaFieldTypeWrap sch t (K1 i f) where + toSchemaFieldTypeW (K1 x) = toSchemaFieldType x + fromSchemaFieldTypeW x = K1 (fromSchemaFieldType x) +instance GSchemaFieldTypeWrap sch t f => GSchemaFieldTypeWrap sch t (M1 s m f) where + toSchemaFieldTypeW (M1 x) = toSchemaFieldTypeW x + fromSchemaFieldTypeW x = M1 (fromSchemaFieldTypeW x) class GSchemaFieldType (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where toSchemaFieldType :: f -> FieldValue sch t @@ -194,34 +197,35 @@ instance {-# OVERLAPPABLE #-} toSchemaFieldType x = FUnion (toSchemaFieldTypeUnion (from x)) fromSchemaFieldType (FUnion x) = to (fromSchemaFieldTypeUnion x) --- This is not 100% correct, we could have --- GSchemaFieldTypeUnion sch '[] U1 --- But we would need overlappable instances for that matter --- and also: who is going to define an empty union? -instance TypeError ('Text "the type does not match the union") +instance {-# OVERLAPS #-} GSchemaFieldTypeUnion sch '[] U1 where + toSchemaFieldTypeUnion U1 = error "this should never happen" + fromSchemaFieldTypeUnion _ = U1 +instance {-# OVERLAPPABLE #-} + TypeError ('Text "the type does not match the union") => GSchemaFieldTypeUnion sch '[] f where toSchemaFieldTypeUnion = error "this should never happen" fromSchemaFieldTypeUnion = error "this should never happen" -instance (GSchemaFieldType sch t v) - => GSchemaFieldTypeUnion sch '[t] (K1 i v) where - toSchemaFieldTypeUnion (K1 x) = Z (toSchemaFieldType x) - fromSchemaFieldTypeUnion (Z x) = K1 (fromSchemaFieldType x) - fromSchemaFieldTypeUnion (S _) = error "this should never happen" -instance (GSchemaFieldType sch t v, GSchemaFieldTypeUnion sch ts vs) - => GSchemaFieldTypeUnion sch (t ': ts) (K1 i v :+: vs) where - toSchemaFieldTypeUnion (L1 (K1 x)) = Z (toSchemaFieldType x) - toSchemaFieldTypeUnion (R1 r) = S (toSchemaFieldTypeUnion r) - fromSchemaFieldTypeUnion (Z x) = L1 (K1 (fromSchemaFieldType x)) +instance (GSchemaFieldTypeWrap sch t v) + => GSchemaFieldTypeUnion sch '[t] v where + toSchemaFieldTypeUnion x = Z (toSchemaFieldTypeW x) + fromSchemaFieldTypeUnion (Z x) = fromSchemaFieldTypeW x + fromSchemaFieldTypeUnion (S _) = error "this should never happen" +instance (GSchemaFieldTypeWrap sch t v, GSchemaFieldTypeUnion sch ts vs) + => GSchemaFieldTypeUnion sch (t ': ts) (v :+: vs) where + toSchemaFieldTypeUnion (L1 x) = Z (toSchemaFieldTypeW x) + toSchemaFieldTypeUnion (R1 r) = S (toSchemaFieldTypeUnion r) + fromSchemaFieldTypeUnion (Z x) = L1 (fromSchemaFieldTypeW x) fromSchemaFieldTypeUnion (S r) = R1 (fromSchemaFieldTypeUnion r) -- Weird nested instance produced by GHC -instance (GSchemaFieldType sch t1 v1, GSchemaFieldType sch t2 v2, GSchemaFieldTypeUnion sch ts vs) - => GSchemaFieldTypeUnion sch (t1 ': t2 ': ts) ((K1 i v1 :+: K1 i v2) :+: vs) where - toSchemaFieldTypeUnion (L1 (L1 (K1 x))) = Z (toSchemaFieldType x) - toSchemaFieldTypeUnion (L1 (R1 (K1 x))) = S (Z (toSchemaFieldType x)) - toSchemaFieldTypeUnion (R1 r) = S (S (toSchemaFieldTypeUnion r)) - fromSchemaFieldTypeUnion (Z x) = L1 (L1 (K1 (fromSchemaFieldType x))) - fromSchemaFieldTypeUnion (S (Z x)) = L1 (R1 (K1 (fromSchemaFieldType x))) +instance ( GSchemaFieldTypeWrap sch t1 v1, GSchemaFieldTypeWrap sch t2 v2 + , GSchemaFieldTypeUnion sch ts vs ) + => GSchemaFieldTypeUnion sch (t1 ': t2 ': ts) ((v1 :+: v2) :+: vs) where + toSchemaFieldTypeUnion (L1 (L1 x)) = Z (toSchemaFieldTypeW x) + toSchemaFieldTypeUnion (L1 (R1 x)) = S (Z (toSchemaFieldTypeW x)) + toSchemaFieldTypeUnion (R1 r) = S (S (toSchemaFieldTypeUnion r)) + fromSchemaFieldTypeUnion (Z x) = L1 (L1 (fromSchemaFieldTypeW x)) + fromSchemaFieldTypeUnion (S (Z x)) = L1 (R1 (fromSchemaFieldTypeW x)) fromSchemaFieldTypeUnion (S (S r)) = R1 (fromSchemaFieldTypeUnion r) From c3c9c1d9ae897e7b046e6f6174b3259250dc7b52 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Thu, 5 Dec 2019 14:03:10 +0100 Subject: [PATCH 015/217] Add support for logging and other transformers (#35) Fixes #32 --- core/rpc/src/Mu/Rpc/Examples.hs | 21 ++-- core/rpc/src/Mu/Server.hs | 23 +++-- examples/health-check/src/Server.hs | 2 + examples/route-guide/src/Server.hs | 2 + examples/seed/mu-example-seed.cabal | 1 + examples/seed/src/Main.hs | 23 +++-- grpc/server/src/Mu/GRpc/Server.hs | 148 +++++++++++++++------------- 7 files changed, 128 insertions(+), 92 deletions(-) diff --git a/core/rpc/src/Mu/Rpc/Examples.hs b/core/rpc/src/Mu/Rpc/Examples.hs index fb54ab6b..4aeedc88 100644 --- a/core/rpc/src/Mu/Rpc/Examples.hs +++ b/core/rpc/src/Mu/Rpc/Examples.hs @@ -1,6 +1,7 @@ {-# language DataKinds #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-} +{-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language GADTs #-} {-# language MultiParamTypeClasses #-} @@ -9,7 +10,7 @@ {-# language PolyKinds #-} {-# language TypeFamilies #-} {-# language TypeOperators #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Mu.Rpc.Examples where import Data.Conduit @@ -52,19 +53,21 @@ newtype HelloResponse = HelloResponse { message :: T.Text } newtype HiRequest = HiRequest { number :: Int } deriving (Generic, HasSchema QuickstartSchema "HiRequest") -quickstartServer :: ServerIO QuickStartService _ +quickstartServer :: (MonadServer m) => ServerT QuickStartService m _ quickstartServer = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0) - where sayHello :: HelloRequest -> ServerErrorIO HelloResponse + where sayHello :: (Monad m) => HelloRequest -> m HelloResponse sayHello (HelloRequest nm) = return (HelloResponse ("hi, " <> nm)) - sayHi :: HiRequest - -> ConduitT HelloResponse Void ServerErrorIO () - -> ServerErrorIO () + sayHi :: (MonadServer m) + => HiRequest + -> ConduitT HelloResponse Void m () + -> m () sayHi (HiRequest n) sink = runConduit $ C.replicate n (HelloResponse "hi!") .| sink - sayManyHellos :: ConduitT () HelloRequest ServerErrorIO () - -> ConduitT HelloResponse Void ServerErrorIO () - -> ServerErrorIO () + sayManyHellos :: (MonadServer m) + => ConduitT () HelloRequest m () + -> ConduitT HelloResponse Void m () + -> m () sayManyHellos source sink = runConduit $ source .| C.mapM sayHello .| sink diff --git a/core/rpc/src/Mu/Server.hs b/core/rpc/src/Mu/Server.hs index 50a370df..76181d49 100644 --- a/core/rpc/src/Mu/Server.hs +++ b/core/rpc/src/Mu/Server.hs @@ -1,6 +1,7 @@ {-# language ConstraintKinds #-} {-# language DataKinds #-} {-# language ExistentialQuantification #-} +{-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language GADTs #-} {-# language MultiParamTypeClasses #-} @@ -27,10 +28,11 @@ -- and long type you would need to write there otherwise. module Mu.Server ( -- * Servers and handlers - ServerIO, ServerT(..) -, HandlersIO, HandlersT(..) + MonadServer, ServerT(..), HandlersT(..) + -- ** Simple servers using only IO +, ServerErrorIO, ServerIO -- * Errors which might be raised -, serverError, ServerErrorIO, ServerError(..), ServerErrorCode(..) +, serverError, ServerError(..), ServerErrorCode(..) -- ** Useful when you do not want to deal with errors , alwaysOk ) where @@ -42,10 +44,17 @@ import Data.Kind import Mu.Rpc import Mu.Schema -serverError :: ServerError -> ServerErrorIO a +-- | Constraint for monads that can be used as servers +type MonadServer m = (MonadError ServerError m, MonadIO m) +type ServerErrorIO = ExceptT ServerError IO +type ServerIO srv = ServerT srv ServerErrorIO + +serverError :: (MonadError ServerError m) + => ServerError -> m a serverError = throwError -alwaysOk :: IO a -> ServerErrorIO a +alwaysOk :: (MonadIO m) + => IO a -> m a alwaysOk = liftIO data ServerError @@ -61,18 +70,14 @@ data ServerErrorCode | NotFound deriving (Eq, Show) -type ServerErrorIO = ExceptT ServerError IO - data ServerT (s :: Service snm mnm) (m :: Type -> Type) (hs :: [Type]) where Server :: HandlersT methods m hs -> ServerT ('Service sname anns methods) m hs -type ServerIO service = ServerT service ServerErrorIO infixr 5 :<|>: data HandlersT (methods :: [Method mnm]) (m :: Type -> Type) (hs :: [Type]) where H0 :: HandlersT '[] m '[] (:<|>:) :: Handles args ret m h => h -> HandlersT ms m hs -> HandlersT ('Method name anns args ret ': ms) m (h ': hs) -type HandlersIO methods = HandlersT methods ServerErrorIO -- Define a relation for handling class Handles (args :: [Argument]) (ret :: Return) diff --git a/examples/health-check/src/Server.hs b/examples/health-check/src/Server.hs index 17987a40..634bfb00 100644 --- a/examples/health-check/src/Server.hs +++ b/examples/health-check/src/Server.hs @@ -1,5 +1,7 @@ {-# language OverloadedStrings #-} {-# language PartialTypeSignatures #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + module Main where import Control.Concurrent.STM diff --git a/examples/route-guide/src/Server.hs b/examples/route-guide/src/Server.hs index 57a74f3c..5ce3ec0d 100644 --- a/examples/route-guide/src/Server.hs +++ b/examples/route-guide/src/Server.hs @@ -2,6 +2,8 @@ {-# language OverloadedStrings #-} {-# language PartialTypeSignatures #-} {-# language ScopedTypeVariables #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + module Main where import Control.Concurrent.Async diff --git a/examples/seed/mu-example-seed.cabal b/examples/seed/mu-example-seed.cabal index f342cb56..512f6322 100644 --- a/examples/seed/mu-example-seed.cabal +++ b/examples/seed/mu-example-seed.cabal @@ -20,6 +20,7 @@ executable seed-server default-language: Haskell2010 build-depends: base >= 4.12 && < 5 , conduit + , monad-logger , mu-schema , mu-rpc , mu-protobuf diff --git a/examples/seed/src/Main.hs b/examples/seed/src/Main.hs index 7786474d..1f695a71 100644 --- a/examples/seed/src/Main.hs +++ b/examples/seed/src/Main.hs @@ -1,11 +1,16 @@ +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} {-# language PartialTypeSignatures #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Main where import Control.Concurrent (threadDelay) import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger import Data.Conduit import Data.Conduit.Combinators as C +import Data.Text as T import Mu.GRpc.Server import Mu.Server @@ -14,25 +19,27 @@ import Schema main :: IO () main = do putStrLn "running seed application" - runGRpcApp 8080 server + runGRpcAppTrans 8080 runStderrLoggingT server -- Server implementation -- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala -server :: ServerIO PeopleService _ +server :: (MonadServer m, MonadLogger m) => ServerT PeopleService m _ server = Server (getPerson :<|>: getPersonStream :<|>: H0) evolvePerson :: PeopleRequest -> PeopleResponse evolvePerson (PeopleRequest n) = PeopleResponse $ Person n 18 -getPerson :: PeopleRequest -> ServerErrorIO PeopleResponse -getPerson = return . evolvePerson +getPerson :: Monad m => PeopleRequest -> m PeopleResponse +getPerson = pure . evolvePerson -getPersonStream :: ConduitT () PeopleRequest ServerErrorIO () - -> ConduitT PeopleResponse Void ServerErrorIO () - -> ServerErrorIO () +getPersonStream :: (MonadServer m, MonadLogger m) + => ConduitT () PeopleRequest m () + -> ConduitT PeopleResponse Void m () + -> m () getPersonStream source sink = runConduit $ source .| C.mapM reStream .| sink where reStream req = do liftIO $ threadDelay (2 * 1000 * 1000) -- 2 sec - return $ evolvePerson req + logDebugN $ T.pack $ "stream request: " ++ show req + pure $ evolvePerson req diff --git a/grpc/server/src/Mu/GRpc/Server.hs b/grpc/server/src/Mu/GRpc/Server.hs index 8a032e2d..4218c6cb 100644 --- a/grpc/server/src/Mu/GRpc/Server.hs +++ b/grpc/server/src/Mu/GRpc/Server.hs @@ -4,14 +4,15 @@ {-# language GADTs #-} {-# language MultiParamTypeClasses #-} {-# language PolyKinds #-} +{-# language RankNTypes #-} {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} -- | Execute a Mu 'Server' using gRPC as transport layer -module Mu.GRpc.Server ( - -- * Run a 'Server' directly - runGRpcApp +module Mu.GRpc.Server +( -- * Run a 'Server' directly + runGRpcApp, runGRpcAppTrans , runGRpcAppSettings, Settings , runGRpcAppTLS, TLSSettings -- * Convert a 'Server' into a WAI application @@ -30,7 +31,7 @@ import Data.Kind import Data.Proxy import Network.GRPC.HTTP2.Encoding (gzip, uncompressed) import Network.GRPC.HTTP2.Proto3Wire -import Network.GRPC.HTTP2.Types (GRPCStatus(..), GRPCStatusCode (..)) +import Network.GRPC.HTTP2.Types (GRPCStatus (..), GRPCStatusCode (..)) import Network.GRPC.Server.Handlers import Network.GRPC.Server.Wai (ServiceHandler) import Network.GRPC.Server.Wai as Wai @@ -46,20 +47,33 @@ import Mu.Server -- | Run a Mu 'Server' on the given port. runGRpcApp :: ( KnownName name, KnownName (FindPackageName anns) - , GRpcMethodHandlers methods handlers ) - => Port -> ServerIO ('Service name anns methods) handlers + , GRpcMethodHandlers ServerErrorIO methods handlers ) + => Port + -> ServerT ('Service name anns methods) ServerErrorIO handlers -> IO () -runGRpcApp port svr = run port (gRpcApp svr) +runGRpcApp port = runGRpcAppTrans port id + +-- | Run a Mu 'Server' on the given port. +runGRpcAppTrans + :: ( KnownName name, KnownName (FindPackageName anns) + , GRpcMethodHandlers m methods handlers ) + => Port + -> (forall a. m a -> ServerErrorIO a) + -> ServerT ('Service name anns methods) m handlers + -> IO () +runGRpcAppTrans port f svr = run port (gRpcApp f svr) -- | Run a Mu 'Server' using the given 'Settings'. -- -- Go to 'Network.Wai.Handler.Warp' to declare 'Settings'. runGRpcAppSettings :: ( KnownName name, KnownName (FindPackageName anns) - , GRpcMethodHandlers methods handlers ) - => Settings -> ServerIO ('Service name anns methods) handlers + , GRpcMethodHandlers m methods handlers ) + => Settings + -> (forall a. m a -> ServerErrorIO a) + -> ServerT ('Service name anns methods) m handlers -> IO () -runGRpcAppSettings st svr = runSettings st (gRpcApp svr) +runGRpcAppSettings st f svr = runSettings st (gRpcApp f svr) -- | Run a Mu 'Server' using the given 'TLSSettings' and 'Settings'. -- @@ -67,11 +81,12 @@ runGRpcAppSettings st svr = runSettings st (gRpcApp svr) -- and to 'Network.Wai.Handler.Warp' to declare 'Settings'. runGRpcAppTLS :: ( KnownName name, KnownName (FindPackageName anns) - , GRpcMethodHandlers methods handlers ) + , GRpcMethodHandlers m methods handlers ) => TLSSettings -> Settings - -> ServerIO ('Service name anns methods) handlers + -> (forall a. m a -> ServerErrorIO a) + -> ServerT ('Service name anns methods) m handlers -> IO () -runGRpcAppTLS tls st svr = runTLS tls st (gRpcApp svr) +runGRpcAppTLS tls st f svr = runTLS tls st (gRpcApp f svr) -- | Turn a Mu 'Server' into a WAI 'Application'. -- @@ -79,36 +94,40 @@ runGRpcAppTLS tls st svr = runTLS tls st (gRpcApp svr) -- for example, @wai-routes@, or you can add middleware -- from @wai-extra@, among others. gRpcApp - :: (KnownName name, KnownName (FindPackageName anns), GRpcMethodHandlers methods handlers) - => ServerIO ('Service name anns methods) handlers + :: (KnownName name, KnownName (FindPackageName anns), GRpcMethodHandlers m methods handlers) + => (forall a. m a -> ServerErrorIO a) + -> ServerT ('Service name anns methods) m handlers -> Application -gRpcApp svr = Wai.grpcApp [uncompressed, gzip] - (gRpcServiceHandlers svr) +gRpcApp f svr = Wai.grpcApp [uncompressed, gzip] + (gRpcServiceHandlers f svr) gRpcServiceHandlers - :: forall name anns methods handlers. - (KnownName name, KnownName (FindPackageName anns), GRpcMethodHandlers methods handlers) - => ServerIO ('Service name anns methods) handlers + :: forall name anns methods handlers m. + (KnownName name, KnownName (FindPackageName anns), GRpcMethodHandlers m methods handlers) + => (forall a. m a -> ServerErrorIO a) + -> ServerT ('Service name anns methods) m handlers -> [ServiceHandler] -gRpcServiceHandlers (Server svr) = gRpcMethodHandlers packageName serviceName svr +gRpcServiceHandlers f (Server svr) = gRpcMethodHandlers f packageName serviceName svr where packageName = BS.pack (nameVal (Proxy @(FindPackageName anns))) serviceName = BS.pack (nameVal (Proxy @name)) -class GRpcMethodHandlers (ms :: [Method mnm]) (hs :: [Type]) where - gRpcMethodHandlers :: ByteString -> ByteString - -> HandlersIO ms hs -> [ServiceHandler] - -instance GRpcMethodHandlers '[] '[] where - gRpcMethodHandlers _ _ H0 = [] -instance (KnownName name, GRpcMethodHandler args r h, GRpcMethodHandlers rest hs) - => GRpcMethodHandlers ('Method name anns args r ': rest) (h ': hs) where - gRpcMethodHandlers p s (h :<|>: rest) - = gRpcMethodHandler (Proxy @args) (Proxy @r) (RPC p s methodName) h - : gRpcMethodHandlers p s rest +class GRpcMethodHandlers (m :: Type -> Type) (ms :: [Method mnm]) (hs :: [Type]) where + gRpcMethodHandlers :: (forall a. m a -> ServerErrorIO a) + -> ByteString -> ByteString + -> HandlersT ms m hs -> [ServiceHandler] + +instance GRpcMethodHandlers m '[] '[] where + gRpcMethodHandlers _ _ _ H0 = [] +instance (KnownName name, GRpcMethodHandler m args r h, GRpcMethodHandlers m rest hs) + => GRpcMethodHandlers m ('Method name anns args r ': rest) (h ': hs) where + gRpcMethodHandlers f p s (h :<|>: rest) + = gRpcMethodHandler f (Proxy @args) (Proxy @r) (RPC p s methodName) h + : gRpcMethodHandlers f p s rest where methodName = BS.pack (nameVal (Proxy @name)) -class GRpcMethodHandler args r h where - gRpcMethodHandler :: Proxy args -> Proxy r -> RPC -> h -> ServiceHandler +class GRpcMethodHandler m args r h where + gRpcMethodHandler :: (forall a. m a -> ServerErrorIO a) + -> Proxy args -> Proxy r -> RPC -> h -> ServiceHandler raiseErrors :: ServerErrorIO a -> IO a raiseErrors h @@ -128,33 +147,32 @@ raiseErrors h serverErrorToGRpcError NotFound = NOT_FOUND serverErrorToGRpcError Invalid = INVALID_ARGUMENT -instance GRpcMethodHandler '[ ] 'RetNothing (ServerErrorIO ()) where - gRpcMethodHandler _ _ rpc h - = unary @_ @() @() rpc (\_ _ -> raiseErrors h) +instance GRpcMethodHandler m '[ ] 'RetNothing (m ()) where + gRpcMethodHandler f _ _ rpc h + = unary @_ @() @() rpc (\_ _ -> raiseErrors (f h)) instance (ProtoBufTypeRef rref r) - => GRpcMethodHandler '[ ] ('RetSingle rref) (ServerErrorIO r) where - gRpcMethodHandler _ _ rpc h + => GRpcMethodHandler m '[ ] ('RetSingle rref) (m r) where + gRpcMethodHandler f _ _ rpc h = unary @_ @() @(ViaProtoBufTypeRef rref r) - rpc (\_ _ -> ViaProtoBufTypeRef <$> raiseErrors h) + rpc (\_ _ -> ViaProtoBufTypeRef <$> raiseErrors (f h)) instance (ProtoBufTypeRef vref v) - => GRpcMethodHandler '[ 'ArgSingle vref ] 'RetNothing (v -> ServerErrorIO ()) where - gRpcMethodHandler _ _ rpc h + => GRpcMethodHandler m '[ 'ArgSingle vref ] 'RetNothing (v -> m ()) where + gRpcMethodHandler f _ _ rpc h = unary @_ @(ViaProtoBufTypeRef vref v) @() - rpc (\_ -> raiseErrors . h . unViaProtoBufTypeRef) + rpc (\_ -> raiseErrors . f . h . unViaProtoBufTypeRef) instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) - => GRpcMethodHandler '[ 'ArgSingle vref ] ('RetSingle rref) - (v -> ServerErrorIO r) where - gRpcMethodHandler _ _ rpc h + => GRpcMethodHandler m '[ 'ArgSingle vref ] ('RetSingle rref) (v -> m r) where + gRpcMethodHandler f _ _ rpc h = unary @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) - rpc (\_ -> (ViaProtoBufTypeRef <$>) . raiseErrors . h . unViaProtoBufTypeRef) + rpc (\_ -> (ViaProtoBufTypeRef <$>) . raiseErrors . f . h . unViaProtoBufTypeRef) -instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) - => GRpcMethodHandler '[ 'ArgStream vref ] ('RetSingle rref) - (ConduitT () v ServerErrorIO () -> ServerErrorIO r) where - gRpcMethodHandler _ _ rpc h +instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r, MonadIO m) + => GRpcMethodHandler m '[ 'ArgStream vref ] ('RetSingle rref) + (ConduitT () v m () -> m r) where + gRpcMethodHandler f _ _ rpc h = clientStream @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) rpc cstream where cstream :: req @@ -163,9 +181,9 @@ instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) cstream _ = do -- Create a new TMChan chan <- newTMChanIO :: IO (TMChan v) - let producer = sourceTMChan @ServerErrorIO chan + let producer = sourceTMChan @m chan -- Start executing the handler in another thread - promise <- async (raiseErrors $ ViaProtoBufTypeRef <$> h producer) + promise <- async (raiseErrors $ ViaProtoBufTypeRef <$> f (h producer)) -- Build the actual handler let cstreamHandler _ (ViaProtoBufTypeRef newInput) = atomically (writeTMChan chan newInput) @@ -174,10 +192,10 @@ instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) -- Return the information return ((), ClientStream cstreamHandler cstreamFinalizer) -instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) - => GRpcMethodHandler '[ 'ArgSingle vref ] ('RetStream rref) - (v -> ConduitT r Void ServerErrorIO () -> ServerErrorIO ()) where - gRpcMethodHandler _ _ rpc h +instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r, MonadIO m) + => GRpcMethodHandler m '[ 'ArgSingle vref ] ('RetStream rref) + (v -> ConduitT r Void m () -> m ()) where + gRpcMethodHandler f _ _ rpc h = serverStream @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) rpc sstream where sstream :: req -> ViaProtoBufTypeRef vref v @@ -186,7 +204,7 @@ instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) -- Variable to connect input and output var <- newEmptyTMVarIO :: IO (TMVar (Maybe r)) -- Start executing the handler - promise <- async (raiseErrors $ ViaProtoBufTypeRef <$> h v (toTMVarConduit var)) + promise <- async (raiseErrors $ ViaProtoBufTypeRef <$> f (h v (toTMVarConduit var))) -- Return the information let readNext _ = do nextOutput <- atomically $ takeTMVar var @@ -196,12 +214,10 @@ instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) return Nothing return ((), ServerStream readNext) -instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) - => GRpcMethodHandler '[ 'ArgStream vref ] ('RetStream rref) - (ConduitT () v ServerErrorIO () - -> ConduitT r Void ServerErrorIO () - -> ServerErrorIO ()) where - gRpcMethodHandler _ _ rpc h +instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r, MonadIO m) + => GRpcMethodHandler m '[ 'ArgStream vref ] ('RetStream rref) + (ConduitT () v m () -> ConduitT r Void m () -> m ()) where + gRpcMethodHandler f _ _ rpc h = generalStream @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) rpc bdstream where bdstream :: req -> IO ( (), IncomingStream (ViaProtoBufTypeRef vref v) () @@ -209,10 +225,10 @@ instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) bdstream _ = do -- Create a new TMChan and a new variable chan <- newTMChanIO :: IO (TMChan v) - let producer = sourceTMChan @ServerErrorIO chan + let producer = sourceTMChan @m chan var <- newEmptyTMVarIO :: IO (TMVar (Maybe r)) -- Start executing the handler - promise <- async (raiseErrors $ h producer (toTMVarConduit var)) + promise <- async (raiseErrors $ f $ h producer (toTMVarConduit var)) -- Build the actual handler let cstreamHandler _ (ViaProtoBufTypeRef newInput) = atomically (writeTMChan chan newInput) From 701d33488aceb1c8442ae2513f3e19376f5426b4 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Tue, 10 Dec 2019 17:06:36 +0100 Subject: [PATCH 016/217] Work on docs (#37) Fixes #31 Fixes #36 Co-Authored-By: Flavio Corpa --- docs/README.md | 7 ++- docs/db.md | 4 ++ docs/intro.md | 10 ++-- docs/middleware.md | 67 ++++++++++++++++++++++++ docs/rpc.md | 32 ++++++++---- docs/schema.md | 74 +++++++++++---------------- docs/stream.md | 7 +-- docs/transformer.md | 84 +++++++++++++++++++++++++++++++ grpc/server/src/Mu/GRpc/Server.hs | 25 ++++++--- templates/grpc-server.hsfiles | 2 +- 10 files changed, 242 insertions(+), 70 deletions(-) create mode 100644 docs/db.md create mode 100644 docs/transformer.md diff --git a/docs/README.md b/docs/README.md index 41e5a88f..ca109cb0 100644 --- a/docs/README.md +++ b/docs/README.md @@ -4,8 +4,11 @@ Mu-Haskell is a set of packages that help you build both servers and clients for * [Introduction](intro.md) * [Schemas](schema.md) + * [Registry](registry.md) * [Services and servers](rpc.md) * [gRPC servers and clients](grpc.md) * [Streams](stream.md) - * [WAI Middleware](middleware.md) -* [Registry](registry.md) + * [Databases](db.md), including resource pools +* Integration with other libraries + * [Using transformers](transformer.md): look here for logging + * [WAI Middleware](middleware.md): look here for metrics diff --git a/docs/db.md b/docs/db.md new file mode 100644 index 00000000..3d05749b --- /dev/null +++ b/docs/db.md @@ -0,0 +1,4 @@ +# Databases + +Explain how to integrate with Persistent. +Explain also how to run a pool of database connections. diff --git a/docs/intro.md b/docs/intro.md index 331d6e1e..f4366eeb 100644 --- a/docs/intro.md +++ b/docs/intro.md @@ -1,5 +1,9 @@ # Introduction to Mu-Haskell +Many companies have embraced microservices architectures as the best way to scale up their internal software systems, separate work across different company divisions and development teams. Microservices architectures also allow teams to turn an idea or bug report into a working feature of fix in production more quickly, in accordance to the agile principles. + +However, microservices are not without costs. Every connection between microservices becomes now a boundary that requires one to act as a server, and the other to act as the client. Each part implementation needs to add the protocol, the codification of the data for transmission, etc. Also, business logic of the application starts to spread around several code bases, making it difficult to maintain. + ## What is Mu-Haskell? The main goal of Mu-Haskell is to make you focus on your domain logic, instead of worrying about format and protocol issues. To achieve this goal, Mu-Haskell provides two sets of packages: @@ -71,19 +75,19 @@ Open the `src/Main.hs` file. The contents are quite small right now: a `main` fu main :: IO () main = runGRpcApp 8080 server -server :: ServerIO Service _ +server :: (MonadServer m) => ServerT Service m _ server = Server H0 ``` The simplest way to provide an implementation for a service is to define one function for each method. You define those functions completely in terms of Haskell data types; in our case `HelloRequestMessage` and `HelloReplyMessage`. Here is a simple definition: ```haskell -sayHello :: HelloRequestMessage -> ServerErrorIO HelloReplyMessage +sayHello :: (MonadServer m) => HelloRequestMessage -> m HelloReplyMessage sayHello (HelloRequestMessage nm) = return $ HelloReplyMessage ("hello, " ++ nm) ``` -The `ServerErrorIO` portion in the type is mandated by `mu-grpc-server`; it tells us that in a method we can perform any `IO` actions and additionally throw server errors (for conditions such as *not found*). We do not make use of any of those here, so we simply use `return` with a value. +The `MonadServer` portion in the type is mandated by `mu-rpc`; it tells us that in a method we can perform any `IO` actions and additionally throw server errors (for conditions such as *not found*). We do not make use of any of those here, so we simply use `return` with a value. We could even make the definition a bit more polymorphic by replacing `MonadServer` by `Monad`. How does `server` know that `sayHello` is part of the implementation of the service? We have to tell it, by adding `sayHello` to the list of methods. Unfortunately, we cannot use a simple lists, so we use `(:<|>:)` to join them, and `H0` to finish it. diff --git a/docs/middleware.md b/docs/middleware.md index 4d305966..7f49211f 100644 --- a/docs/middleware.md +++ b/docs/middleware.md @@ -1 +1,68 @@ # Integration with WAI middleware + +Although you usually run a `mu-rpc` server directly using a function like `runGRpcApp`, this is just a convenience function to make it simpler to run the server. Under the hood, the library generates a so-called WAI application, which is then fed to an actual server. + +WAI stands for [*Web Application Interface*](https://www.yesodweb.com/book/web-application-interface). WAI defines a common set of APIs against which web application can be developed. Web servers, like [Warp](http://www.aosabook.org/en/posa/warp.html), take an application which uses that API and serves it against the actual network. The main benefit of this separation is that applications and servers can evolve separately, without a tight coupling between them. + +One of the features that WAI provides is the definition of *middleware* components. *Middlewares* are not complete applications; instead they wrap another application to provide additional capabilities. There is a whole ecosystem of WAI middleware, as one can notice by [searching `wai middleware` in Hackage](http://hackage.haskell.org/packages/search?terms=wai+middleware). + +## Serving static files + +It's a common task in web servers to send some static content for a subset of URLs (think of resources such as images or JavaScript code). `wai-middleware-static` automates that task, and also serves as the simplest example of WAI middleware. + +Remember that in our [original code](intro.md) our `main` function looked as follows: + +```haskell +main = runGRpcApp 8080 server +``` + +We can split this single line into two phases: first creating the WAI application by means of `gRpcApp`, and then running it using Warp's `run` function. + +```haskell +import Network.Wai.Handler.Warp (run) + +main = run 8080 $ gRpcApp server +``` + +Right in the middle of the two steps we can inject any middleware we want. + +```haskell +import Network.Wai.Handler.Warp (run) +import Network.Wai.Middleware.Static + +main = run 8080 $ static (gRpcApp server) +``` + +With that simple change, our web server now first checks whether a file with the requested name exists in the directory from which the application is running. If that is the case, it's cached and served, otherwise the underlying gRPC application is run. Needless to say, this behavior might not be the desired one, so the library provides [`staticPolicy`](http://hackage.haskell.org/package/wai-middleware-static/docs/Network-Wai-Middleware-Static.html#v:staticPolicy) to customize it. + +## Metrics + +Another interesting use of middleware is obtaining metrics for your application. Within the Haskell world, [EKG](https://github.com/tibbe/ekg) is a common solution for monitoring any kind of running process. EKG provides [customizable counters](https://ocharles.org.uk/blog/posts/2012-12-11-24-day-of-hackage-ekg.html), so you are not tied to one specific set of variables. This is the idea behind the [`wai-middleware-metrics`](https://github.com/Helkafen/wai-middleware-metrics) package: provide counters for the specific needs of HTTP servers. + +```haskell +import System.Remote.Monitoring (serverMetricStore, forkServer) +import Network.Wai.Handler.Warp (run) +import Network.Wai.Metrics + +main = do + -- Taken from the official documentation + store <- serverMetricStore <$> forkServer "localhost" 8000 + waiMetrics <- registerWaiMetrics store + -- Wrap the application and run it + run 8080 $ metrics waiMetrics (gRpcApp server) +``` + +Another possibility is to expose [Prometheus](https://prometheus.io/) metrics. In this case, a specific monitoring process scrapes your servers from time to time. The gathered data can later be analyzed and visualized. Luckily, there's some [middleware](https://github.com/fimad/prometheus-haskell) exposing the require endpoints automatically. + +```haskell +import Network.Wai.Handler.Warp (run) +import Network.Wai.Middleware.Prometheus + +main = run 8080 $ prometheus def (gRpcApp server) +``` + +The usage of `def` indicates that we want the default options: providing the metrics under the route `/metrics`. + +## Compression, header manipulation, and more! + +These docs only scrape the surface of WAI middleware. We encourage you to check the [`wai-extra` package](http://hackage.haskell.org/package/wai-extra), which includes many self-contained middlewares. For example, you may wish to have GZip compression, or to canonicalize routes before passing them to the actual application. Following the Haskell philosophy, the idea is to provide small components which can be easily composed to target your needs. diff --git a/docs/rpc.md b/docs/rpc.md index b596eab0..99aa35f4 100644 --- a/docs/rpc.md +++ b/docs/rpc.md @@ -22,7 +22,9 @@ As with our sibling `mu-schema` library, we use type-level techniques to represe ```haskell {-# language TemplateHaskell #-} -$(grpc "QuickstartSchema" (const "QuickstartService") "quickstart.proto") +import Mu.Quasi.GRpc + +grpc "QuickstartSchema" (const "QuickstartService") "quickstart.proto" ``` The `grpc` function takes three arguments: @@ -38,21 +40,24 @@ This is everything you need to start using gRPC services and clients in Haskell! In order to use the library proficiently, we should look a bit at the code generated in the previous code. A type-level description of the messages is put into the type `QuickstartSchema`. However, there is some code you still have to write by hand, namely the Haskell type which correspond to that schema. Using `mu-schema` facilities, this amounts to declaring a bunch of data types and including `deriving (Generic, HasSchema Schema "type")` at the end of each of them. ```haskell -{-# language PolyKinds, DataKinds #-} +{-# language PolyKinds, DataKinds, TypeFamilies #-} {-# language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} {-# language DeriveGeneric, DeriveAnyClass #-} import qualified Data.Text as T import GHC.Generics + +import Mu.Adapter.ProtoBuf import Mu.Schema -- GENERATED type QuickstartSchema - = '[ 'DRecord "HelloRequest" '[] - '[ 'FieldDef "name" '[ ProtoBufId 1 ] ('TPrimitive T.Text) ] - , 'DRecord "HelloResponse" '[] - '[ 'FieldDef "message" '[ ProtoBufId 1 ] ('TPrimitive T.Text) ] - ] + = '[ 'DRecord "HelloRequest" '[ 'FieldDef "name" ('TPrimitive T.Text) ] + , 'DRecord "HelloResponse" '[ 'FieldDef "message" ('TPrimitive T.Text) ] ] + +type instance AnnotatedSchema ProtoBufAnnotation QuickstartSchema + = '[ 'AnnField "HelloRequest" "name" ('ProtoBufId 1) + , 'AnnField "HelloResponse" "message" ('ProtoBufId 1) ] -- TO BE WRITTEN newtype HelloRequest = HelloRequest { name :: T.Text } @@ -86,15 +91,22 @@ Note that depending on the concrete implementation you use to run the server, on In order to implement the service, you have to define the behavior of each method by means of a *handler*. You can use Haskell types for your handlers, given that you had previously declared that they can be mapped back and forth the schema types using `HasSchema`. For example, the following is a handler for the `SayHello` method in `Greeter`: ```haskell -sayHello :: HelloRequest -> ServerErrorIO HelloResponse +sayHello :: (MonadServer m) => HelloRequest -> m HelloResponse sayHello (HelloRequest nm) = return (HelloResponse ("hi, " <> nm)) ``` -Since you can declare more than one method in a service, you need to join then into a `Server`. You do so by using `(:<|>:)` between each handler and ending the sequence with `H0`. In addition to the name of the service, `Server` has an additional parameter which records the types of the handlers. Since that list may become quite long, we can ask GHC to write it for us by using the `PartialTypeSignatures` extension and writing an underscore `_` in that position. One final observation is that in the code below we are using `ServerIO`, which is an instance of `Server` which allows running `IO` operations. +Notice the use of `MonadServer` in this case. This gives us the ability to: + +* Run arbitrary `IO` actions by using `liftIO`, +* Return an error code by calling `serverError`. + +Being polymorphic here allows us to run the same server in multiple back-ends. Furthermore, by enlarging the set of abilities required for our monad `m`, we can [integrate with other libraries](transformer.md), including logging and resource pools. + +Since you can declare more than one method in a service, you need to join them into a `Server`. You do so by using `(:<|>:)` between each handler and ending the sequence with `H0`. In addition to the name of the service, `Server` has an additional parameter which records the types of the handlers. Since that list may become quite long, we can ask GHC to write it for us by using the `PartialTypeSignatures` extension and writing an underscore `_` in that position. ```haskell {-# language PartialTypeSignatures #-} -quickstartServer :: ServerIO QuickstartService _ +quickstartServer :: (MonadServer m) => ServerT QuickstartService m _ quickstartServer = Server (sayHello :<|>: H0) ``` diff --git a/docs/schema.md b/docs/schema.md index 70e361d0..0c1be938 100644 --- a/docs/schema.md +++ b/docs/schema.md @@ -18,19 +18,19 @@ import Mu.Schema import qualified Data.Text as T type ExampleSchema - = '[ 'DEnum "gender" '[] - '[ 'ChoiceDef "male" '[] - , 'ChoiceDef "female" '[] - , 'ChoiceDef "nb" '[] ] + = '[ 'DEnum "gender" + '[ 'ChoiceDef "male" + , 'ChoiceDef "female" + , 'ChoiceDef "nb" ] , 'DRecord "address" - '[ 'FieldDef "postcode" '[] ('TPrimitive T.Text) - , 'FieldDef "country" '[] ('TPrimitive T.Text) ] + '[ 'FieldDef "postcode" ('TPrimitive T.Text) + , 'FieldDef "country" ('TPrimitive T.Text) ] , 'DRecord "person" - '[ 'FieldDef "firstName" '[] ('TPrimitive T.Text) - , 'FieldDef "lastName" '[] ('TPrimitive T.Text) - , 'FieldDef "age" '[] ('TOption ('TPrimitive Int)) - , 'FieldDef "gender" '[] ('TOption ('TSchematic "gender")) - , 'FieldDef "address" '[] ('TSchematic "address") ] + '[ 'FieldDef "firstName" ('TPrimitive T.Text) + , 'FieldDef "lastName" ('TPrimitive T.Text) + , 'FieldDef "age" ('TOption ('TPrimitive Int)) + , 'FieldDef "gender" ('TOption ('TSchematic "gender")) + , 'FieldDef "address" ('TSchematic "address") ] ] ``` @@ -48,45 +48,26 @@ Note that GHC requires all of `DEnum`, `DRecord`, `FieldDef`, and so forth to be As discussed in the introduction, `mu-schema` has been developed with some common schema formats in mind. Instead of writing the type-level schemas by hand, you can also import your [Protocol Buffers](https://developers.google.com/protocol-buffers/) schemas. -The most common case is that your schema lives in an external file, maybe shared with other components of your system. To declare that we want the file to be pre-processed before compilation, we use a GHC feature called a *quasi-quote*. Be careful with the ending of the quasi-quote, which is a weird combination `|]`. +The idea is that your schema lives in an external file, so you can share it with other components of your system. To declare that we want the file to be pre-processed before compilation, we use a GHC feature called `TemplateHaskell`, hence the initial line starting with `language`. ```haskell -{-# language QuasiQuotes #-} +{-# language TemplateHaskell #-} -type ExampleSchema = [protobufFile|path/to/file.proto|] +import Mu.Quasi.ProtoBuf + +protobuf "ExampleSchema" "path/to/file.proto" ``` -Another possibility is to write them in-line. In that case you replace `protobufFile` with `protobuf` and write the schema directly between the `|` symbols. +That single line asks the compiler to generate a `ExampleSchema` type which represents the schema from the given file. In addition, it also generates a mapping from fields to identifiers, as described below. -```haskell -{-# language QuasiQuotes #-} - -type ExampleSchema = [protobuf| -enum gender { - male = 1; - female = 2; - nb = 3; -} -message address { - string postcode = 1; - string country = 2; -} -message person { - string firstName = 1; - string lastName = 2; - int age = 3; - gender gender = 4; - address address = 5; -} -|] -``` +One word of warning: GHC reads the contents of the file *in order*, resolving `TemplateHaskell` blocks when found. Only then the results are visible to the rest of the file. In particular, the `protobuf` line should appear *before* any other code mentioning the `ExampleSchema` type. ### Schemas part of services If you use the `grpc` function to import a gRPC `.proto` file in the type-level, that function already takes care of creating an appropiate schema for *all* the messages. If you prefer to have different schemas for different subsets of messages (for example, aggregated by services), you can either: * Write the schemas by hand, -* Split the definition file into several ones, and import each of them in its own `[protobufFile||]` block. +* Split the definition file into several ones, and import each of them in its own `protobuf` block. ## Mapping Haskell types @@ -129,15 +110,18 @@ instance HasSchema ExampleSchema "gender" Gender where ### Protocol Buffers field identifiers -If you want to use (de)serialization to Protocol Buffers, you need to declare one more piece of information. A Protocol Buffer record or enumeration assigns both names and *numeric identifiers* to each field or value, respectively. This is done via an *annotation* in each field: +If you want to use (de)serialization to Protocol Buffers, you need to declare one more piece of information. A Protocol Buffer record or enumeration assigns both names and *numeric identifiers* to each field or value, respectively. If you use `protobuf` or `grpc` to import your Protocol Buffers schemas, this is done automatically for you. + +`mu-schema` supports extending the information of a schema by means of *annotations*. Annotations are linked to both a certain format (`ProtoBufAnnotation` in this case) and a certain schema. Furthermore, annotations may range over the whole schema, a specific record or enumeration, or a specific field or choice. In the case of Protocol Buffers, we only need the latter: ```haskell -type ExampleSchema +{-# language TypeFamilies #-} + +import Mu.Adapter.ProtoBuf + +type instance AnnotatedSchema ProtoBufAnnotation ExampleSchema = '[ ... - , 'DRecord "address" - '[ 'FieldDef "postcode" '[ ProtoBufId 1 ] ('TPrimitive T.Text) - , 'FieldDef "country" '[ ProtoBufId 2 ] ('TPrimitive T.Text) ] + , 'AnnField "address" "postcode" ('ProtoBufId 1) + , 'AnnField "address" "country " ('ProtoBufId 2) , ... ] ``` - -If you use the `protobuf` or `protobufFile` quasi-quoters to import your Protocol Buffers schemas, this is done automatically for you. diff --git a/docs/stream.md b/docs/stream.md index 5e05d4a7..8ce61907 100644 --- a/docs/stream.md +++ b/docs/stream.md @@ -24,9 +24,10 @@ To define the implementation of this method we build upon the great [Conduit](ht ```haskell sayManyHellos - :: ConduitT () HelloRequest ServerErrorIO () - -> ConduitT HelloResponse ServerErrorVoid IO () - -> IO () + :: (MonadServer m) + => ConduitT () HelloRequest m () + -> ConduitT HelloResponse Void m () + -> m () sayManyHellos source sink = runConduit $ source .| C.mapM sayHello .| sink ``` diff --git a/docs/transformer.md b/docs/transformer.md new file mode 100644 index 00000000..1ec49895 --- /dev/null +++ b/docs/transformer.md @@ -0,0 +1,84 @@ +# Integration using transformers + +You might be wondering: how can I integrate my favorite logging library with `mu-grpc-server`? Our [explanation of services](rpc.md) introduced `MonadServer` as the simplest set of capabilities required for a server: + +* Finish successfully by `return`ing, +* Finish with an error code via `serverError`, +* Executing arbitrary `IO` actions via `liftIO`. + +But you are not tied to that simple set! You can create servers which need more capabilities if you later define how to run those. + +## Reader + +One simple example of a capability is having one single piece of information you can access. This is useful to thread configuration data, or if you use a transactional variable as information, as a way to share data between concurrent threads. This is traditionally done using a `Reader` monad. + +Let us extend our [`sayHello` example](rpc.md) with a piece of configuration which states the word to use when greeting: + +```haskell +import Control.Monad.Reader + +sayHello :: (MonadServer m, MonadReader T.Text m) + => HelloRequest -> m HelloResponse +sayHello (HelloRequest nm) = do + greeting <- ask + return (HelloResponse (greeting <> ", " <> nm)) +``` + +Unfortunately, the simple way to run a gRPC application no longer works: + +```haskell +main = runGRpcApp 8080 "helloworld" quickstartServer +``` + +Furthermore, how does the server know which is the actual value? In other words, how do we inject the value for `greeting`? We need to declare how to *handle* that capability. This is traditionally done with a `run` function; this additional argument is used by `runGRpcAppTrans`. + +```haskell +main = runGRpcAppTrans 8080 (flip runReaderT "hi") quickstartServer +``` + +## Logging + +There are quite a number of libraries which provide logging support. Let's begin with [`monad-logger`](https://github.com/snoyberg/monad-logger#readme). In this case, an additional [set of functions](http://hackage.haskell.org/package/monad-logger/docs/Control-Monad-Logger.html#g:8) is available when you implement the `MonadLogger` class. For example, we could log a message every time we say hi: + +```haskell +import Control.Monad.Logger + +sayHello :: (MonadServer m, MonadLogger m) + => HelloRequest -> m HelloResponse +sayHello (HelloRequest nm) = do + logInfoN "running hi" + return (HelloResponse ("hi, " <> nm)) +``` + +The most important addition with respect to the [original code](rpc.md) is in the signature. Before we only had `MonadServer m`, now we have an additional `MonadLogger m` there. + +As we have done with the Reader example, we need to define how to handle `MonadLogger`. `monad-logger` provides [three different monad transformers](http://hackage.haskell.org/package/monad-logger-0.3.31/docs/Control-Monad-Logger.html#g:3), so you can choose whether your logging will be completely ignored, will become a Haskell value, or would fire some `IO` action like printing in the console. Each of these monad transformers comes with a `run` action which declares how to handle it; the extended function `runGRpcAppTrans` takes that handler as argument. + +```haskell +main = runGRpcAppTrans 8080 runStderrLoggingT quickstartServer +``` + +If you prefer other logging library, this is fine with us! Replacing `monad-logger` by [`co-log`](https://github.com/kowainik/co-log) means asking for a different capability in the server. In this case we have to declare the type of the log items as part of the `WithLog` constraint: + +```haskell +import Colog.Monad + +sayHello :: (MonadServer m, WithLog env String m) + => HelloRequest -> m HelloResponse +sayHello (HelloRequest nm) = do + logInfoN "running hi" + return (HelloResponse ("hi, " <> nm)) +``` + +In this case, the top-level handler is called [`usingLoggerT`](http://hackage.haskell.org/package/co-log/docs/Colog-Monad.html#v:usingLoggerT). Its definition is slightly more involved because `co-log` gives you maximum customization power on your logging, instead of defining a set of predefined logging mechanisms. + +```haskell +main = runGRpcAppTrans 8080 logger quickstartServer + where logger = usingLoggerT (LogAction $ liftIO putStrLn) +``` + +## Warning + +The `run` function you provide to `runGRpcAppTrans` may be called more than once! This is fine for readers and logging, but not for `StateT`, for example. In particular, you must ensure that your `run` function is *idempotent*, that is, that the result of calling it more than once is the same as calling it just once. + +In the particular case of `StateT`, we suggest using a [transactional variable](http://hackage.haskell.org/package/stm/docs/Control-Concurrent-STM-TVar.html), passed as either an argument or using `ReaderT`. This has the additional benefit that concurrent access to the variable - which is fairly possible in a gRPC server -- are automatically protected for data races and deadlocks. diff --git a/grpc/server/src/Mu/GRpc/Server.hs b/grpc/server/src/Mu/GRpc/Server.hs index 4218c6cb..888dcae2 100644 --- a/grpc/server/src/Mu/GRpc/Server.hs +++ b/grpc/server/src/Mu/GRpc/Server.hs @@ -61,7 +61,7 @@ runGRpcAppTrans -> (forall a. m a -> ServerErrorIO a) -> ServerT ('Service name anns methods) m handlers -> IO () -runGRpcAppTrans port f svr = run port (gRpcApp f svr) +runGRpcAppTrans port f svr = run port (gRpcAppTrans f svr) -- | Run a Mu 'Server' using the given 'Settings'. -- @@ -73,7 +73,7 @@ runGRpcAppSettings -> (forall a. m a -> ServerErrorIO a) -> ServerT ('Service name anns methods) m handlers -> IO () -runGRpcAppSettings st f svr = runSettings st (gRpcApp f svr) +runGRpcAppSettings st f svr = runSettings st (gRpcAppTrans f svr) -- | Run a Mu 'Server' using the given 'TLSSettings' and 'Settings'. -- @@ -86,7 +86,7 @@ runGRpcAppTLS -> (forall a. m a -> ServerErrorIO a) -> ServerT ('Service name anns methods) m handlers -> IO () -runGRpcAppTLS tls st f svr = runTLS tls st (gRpcApp f svr) +runGRpcAppTLS tls st f svr = runTLS tls st (gRpcAppTrans f svr) -- | Turn a Mu 'Server' into a WAI 'Application'. -- @@ -94,12 +94,25 @@ runGRpcAppTLS tls st f svr = runTLS tls st (gRpcApp f svr) -- for example, @wai-routes@, or you can add middleware -- from @wai-extra@, among others. gRpcApp - :: (KnownName name, KnownName (FindPackageName anns), GRpcMethodHandlers m methods handlers) + :: ( KnownName name, KnownName (FindPackageName anns) + , GRpcMethodHandlers ServerErrorIO methods handlers ) + => ServerT ('Service name anns methods) ServerErrorIO handlers + -> Application +gRpcApp = gRpcAppTrans id + +-- | Turn a Mu 'Server' into a WAI 'Application'. +-- +-- These 'Application's can be later combined using, +-- for example, @wai-routes@, or you can add middleware +-- from @wai-extra@, among others. +gRpcAppTrans + :: ( KnownName name, KnownName (FindPackageName anns) + , GRpcMethodHandlers m methods handlers ) => (forall a. m a -> ServerErrorIO a) -> ServerT ('Service name anns methods) m handlers -> Application -gRpcApp f svr = Wai.grpcApp [uncompressed, gzip] - (gRpcServiceHandlers f svr) +gRpcAppTrans f svr = Wai.grpcApp [uncompressed, gzip] + (gRpcServiceHandlers f svr) gRpcServiceHandlers :: forall name anns methods handlers m. diff --git a/templates/grpc-server.hsfiles b/templates/grpc-server.hsfiles index 2e8b30e3..9b71f095 100644 --- a/templates/grpc-server.hsfiles +++ b/templates/grpc-server.hsfiles @@ -101,5 +101,5 @@ import Schema main :: IO () main = runGRpcApp 8080 server -server :: ServerIO Service _ +server :: (MonadServer m) => ServerT Service m _ server = Server H0 From a2116bee1d7498b139d5caa28dd2d505f510c9ce Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Fri, 13 Dec 2019 13:15:18 +0100 Subject: [PATCH 017/217] =?UTF-8?q?Implement=20Persistent=20example=20?= =?UTF-8?q?=F0=9F=92=BE=20(#40)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- examples/README.md | 4 +- examples/seed/seed.proto | 2 - examples/with-persistent/.gitignore | 3 ++ examples/with-persistent/README.md | 18 +++++++ examples/with-persistent/Setup.hs | 2 + .../mu-example-with-persistent.cabal | 29 +++++++++++ examples/with-persistent/src/Schema.hs | 49 +++++++++++++++++++ examples/with-persistent/src/Server.hs | 49 +++++++++++++++++++ .../with-persistent/with-persistent.proto | 14 ++++++ grpc/server/src/Mu/GRpc/Server.hs | 43 +++++++++++++--- stack-nightly.yaml | 1 + stack.yaml | 1 + 12 files changed, 205 insertions(+), 10 deletions(-) create mode 100644 examples/with-persistent/.gitignore create mode 100644 examples/with-persistent/README.md create mode 100644 examples/with-persistent/Setup.hs create mode 100644 examples/with-persistent/mu-example-with-persistent.cabal create mode 100644 examples/with-persistent/src/Schema.hs create mode 100644 examples/with-persistent/src/Server.hs create mode 100644 examples/with-persistent/with-persistent.proto diff --git a/examples/README.md b/examples/README.md index 7514b8ae..f27e5082 100644 --- a/examples/README.md +++ b/examples/README.md @@ -4,4 +4,6 @@ Those examples are ports of those in [Mu Scala](https://github.com/higherkindnes * Health check * Route guide -* TODO list +* Simple TODO list +* Seed example +* Integration with Persistent (db access) diff --git a/examples/seed/seed.proto b/examples/seed/seed.proto index b2ceb875..2ab39752 100644 --- a/examples/seed/seed.proto +++ b/examples/seed/seed.proto @@ -1,7 +1,5 @@ syntax = "proto3"; -import "google/protobuf/empty.proto"; - package seed; message Person { string name = 1; int32 age = 2; } diff --git a/examples/with-persistent/.gitignore b/examples/with-persistent/.gitignore new file mode 100644 index 00000000..1f4b9c88 --- /dev/null +++ b/examples/with-persistent/.gitignore @@ -0,0 +1,3 @@ +.stack-work/ +stack*.yaml.lock +*~ diff --git a/examples/with-persistent/README.md b/examples/with-persistent/README.md new file mode 100644 index 00000000..7f88ce43 --- /dev/null +++ b/examples/with-persistent/README.md @@ -0,0 +1,18 @@ +# with-persistent + +## Execution + +Running the server: + +```bash +stack run persistent-server +``` + +[comment]: # (Start Copyright) +# Copyright + +Mu is designed and developed by 47 Degrees + +Copyright (C) 2019-2020 47 Degrees. + +[comment]: # (End Copyright) diff --git a/examples/with-persistent/Setup.hs b/examples/with-persistent/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/examples/with-persistent/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/with-persistent/mu-example-with-persistent.cabal b/examples/with-persistent/mu-example-with-persistent.cabal new file mode 100644 index 00000000..b7f75acb --- /dev/null +++ b/examples/with-persistent/mu-example-with-persistent.cabal @@ -0,0 +1,29 @@ +name: mu-example-with-persistent +version: 0.1.0.0 +-- synopsis: +-- description: +homepage: https://github.com/higherkindness/mu-haskell/examples/with-persistent#readme +author: Flavio Corpa +maintainer: flavio.corpa@47deg.com +copyright: Copyright © 2019-2020 47 Degrees. +category: Network +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md + +executable persistent-server + hs-source-dirs: src + main-is: Server.hs + other-modules: Schema + default-language: Haskell2010 + build-depends: base >= 4.12 && < 5 + , conduit + , monad-logger + , mu-schema + , mu-rpc + , mu-protobuf + , mu-grpc-server + , persistent + , persistent-sqlite + , persistent-template + , text diff --git a/examples/with-persistent/src/Schema.hs b/examples/with-persistent/src/Schema.hs new file mode 100644 index 00000000..0dae7829 --- /dev/null +++ b/examples/with-persistent/src/Schema.hs @@ -0,0 +1,49 @@ +{-# language DataKinds #-} +{-# language DeriveGeneric #-} +{-# language DuplicateRecordFields #-} +{-# language EmptyDataDecls #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language PolyKinds #-} +{-# language QuasiQuotes #-} +{-# language StandaloneDeriving #-} +{-# language TemplateHaskell #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} + +module Schema where + +import Data.Int (Int32, Int64) +import qualified Data.Text as T +import Database.Persist.Sqlite +import Database.Persist.TH +import GHC.Generics + +import Mu.Quasi.GRpc +import Mu.Schema + +grpc "PersistentSchema" id "with-persistent.proto" + +newtype PersonRequest = PersonRequest + { identifier :: Int64 + } deriving (Eq, Show, Ord, Generic) + +instance HasSchema PersistentSchema "PersonRequest" PersonRequest + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +Person json + name T.Text + age Int32 + deriving Show +|] + +deriving instance Generic Person + +-- Unfortunately we need to write this instance by hand 😔 (for now!) +instance HasSchema PersistentSchema "Person" (Entity Person) where + fromSchema (TRecord (Field (FSchematic (TRecord (Field (FPrimitive pid) :* Nil))) :* Field (FPrimitive name) :* Field (FPrimitive age) :* Nil)) = Entity (PersonKey (SqlBackendKey pid)) (Person name age) + toSchema (Entity (PersonKey (SqlBackendKey pid)) (Person name age)) = TRecord $ Field (FSchematic (TRecord (Field (FPrimitive pid) :* Nil))) :* Field (FPrimitive name) :* Field (FPrimitive age) :* Nil diff --git a/examples/with-persistent/src/Server.hs b/examples/with-persistent/src/Server.hs new file mode 100644 index 00000000..e0e5f10d --- /dev/null +++ b/examples/with-persistent/src/Server.hs @@ -0,0 +1,49 @@ +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} + +module Main where + +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger +import Data.Conduit +import qualified Data.Text as T +import Database.Persist.Sqlite +import Mu.GRpc.Server +import Mu.Server + +import Schema + +main :: IO () +main = do + putStrLn "running app with persistent" + runStderrLoggingT $ + withSqliteConn @(LoggingT IO) ":memory:" $ \conn -> do + liftIO $ flip runSqlPersistM conn $ runMigration migrateAll + liftIO $ runGRpcApp 1234 (server conn) + +server :: SqlBackend -> ServerT PersistentService ServerErrorIO _ +server p = Server (getPerson p :<|>: newPerson p :<|>: allPeople p :<|>: H0) + +runDb = (liftIO .) . flip runSqlPersistM + +getPerson :: SqlBackend -> PersonRequest -> ServerErrorIO (Entity Person) +getPerson conn (PersonRequest idf) = do + r <- runDb conn $ do + let pId = PersonKey $ SqlBackendKey idf + maybePerson <- get pId + pure $ Entity pId <$> maybePerson + case r of + Just p -> pure p + Nothing -> serverError $ ServerError NotFound "unknown person" + +newPerson :: SqlBackend -> Entity Person -> ServerErrorIO PersonRequest +newPerson conn (Entity _ p@(Person name _)) = runDb conn $ do + PersonKey (SqlBackendKey nId) <- insert p + pure $ PersonRequest nId + +allPeople :: SqlBackend -> ConduitT (Entity Person) Void ServerErrorIO () -> ServerErrorIO () +allPeople conn sink = runDb conn $ + runConduit $ selectSource [] [] .| liftServerConduit sink diff --git a/examples/with-persistent/with-persistent.proto b/examples/with-persistent/with-persistent.proto new file mode 100644 index 00000000..d846bee5 --- /dev/null +++ b/examples/with-persistent/with-persistent.proto @@ -0,0 +1,14 @@ +syntax = "proto3"; + +import "google/protobuf/empty.proto"; + +package withpersistent; + +message PersonRequest { int64 identifier = 1; } +message Person { PersonRequest pid = 1; string name = 2; int32 age = 3; } + +service PersistentService { + rpc getPerson (PersonRequest) returns (Person); + rpc newPerson (Person) returns (PersonRequest); + rpc allPeople (google.protobuf.Empty) returns (stream Person); +} diff --git a/grpc/server/src/Mu/GRpc/Server.hs b/grpc/server/src/Mu/GRpc/Server.hs index 888dcae2..5ce90c01 100644 --- a/grpc/server/src/Mu/GRpc/Server.hs +++ b/grpc/server/src/Mu/GRpc/Server.hs @@ -17,6 +17,8 @@ module Mu.GRpc.Server , runGRpcAppTLS, TLSSettings -- * Convert a 'Server' into a WAI application , gRpcApp + -- * Raise errors as exceptions in IO +, raiseErrors, liftServerConduit ) where import Control.Concurrent.Async @@ -142,14 +144,20 @@ class GRpcMethodHandler m args r h where gRpcMethodHandler :: (forall a. m a -> ServerErrorIO a) -> Proxy args -> Proxy r -> RPC -> h -> ServiceHandler -raiseErrors :: ServerErrorIO a -> IO a +liftServerConduit + :: MonadIO m + => ConduitT a b ServerErrorIO r -> ConduitT a b m r +liftServerConduit = transPipe raiseErrors + +raiseErrors :: MonadIO m => ServerErrorIO a -> m a raiseErrors h - = do h' <- runExceptT h - case h' of - Right r -> return r - Left (ServerError code msg) - -> closeEarly $ GRPCStatus (serverErrorToGRpcError code) - (BS.pack msg) + = liftIO $ do + h' <- runExceptT h + case h' of + Right r -> return r + Left (ServerError code msg) + -> closeEarly $ GRPCStatus (serverErrorToGRpcError code) + (BS.pack msg) where serverErrorToGRpcError :: ServerErrorCode -> GRPCStatusCode serverErrorToGRpcError Unknown = UNKNOWN @@ -170,6 +178,27 @@ instance (ProtoBufTypeRef rref r) = unary @_ @() @(ViaProtoBufTypeRef rref r) rpc (\_ _ -> ViaProtoBufTypeRef <$> raiseErrors (f h)) +instance (ProtoBufTypeRef rref r, MonadIO m) + => GRpcMethodHandler m '[ ] ('RetStream rref) + (ConduitT r Void m () -> m ()) where + gRpcMethodHandler f _ _ rpc h + = serverStream @_ @() @(ViaProtoBufTypeRef rref r) rpc sstream + where sstream :: req -> () + -> IO ((), ServerStream (ViaProtoBufTypeRef rref r) ()) + sstream _ _ = do + -- Variable to connect input and output + var <- newEmptyTMVarIO :: IO (TMVar (Maybe r)) + -- Start executing the handler + promise <- async (raiseErrors $ ViaProtoBufTypeRef <$> f (h (toTMVarConduit var))) + -- Return the information + let readNext _ + = do nextOutput <- atomically $ takeTMVar var + case nextOutput of + Just o -> return $ Just ((), ViaProtoBufTypeRef o) + Nothing -> do cancel promise + return Nothing + return ((), ServerStream readNext) + instance (ProtoBufTypeRef vref v) => GRpcMethodHandler m '[ 'ArgSingle vref ] 'RetNothing (v -> m ()) where gRpcMethodHandler f _ _ rpc h diff --git a/stack-nightly.yaml b/stack-nightly.yaml index a45dac03..18c40f16 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -12,6 +12,7 @@ packages: - examples/route-guide - examples/seed - examples/todolist +- examples/with-persistent - compendium-client extra-deps: diff --git a/stack.yaml b/stack.yaml index 36a26c10..005bbbf0 100644 --- a/stack.yaml +++ b/stack.yaml @@ -11,6 +11,7 @@ packages: - examples/route-guide - examples/seed - examples/todolist +- examples/with-persistent - compendium-client extra-deps: From 61ae8be215c0d77d9ece2bf6774bbe168fa598db Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Fri, 13 Dec 2019 13:24:33 +0100 Subject: [PATCH 018/217] Update dependencies (#42) --- adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs | 5 +++++ stack-nightly.yaml | 4 ++-- stack.yaml | 5 +++-- 3 files changed, 10 insertions(+), 4 deletions(-) diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs index 36e8c229..c5e506f9 100644 --- a/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs @@ -1,4 +1,5 @@ {-# language AllowAmbiguousTypes #-} +{-# language CPP #-} {-# language ConstraintKinds #-} {-# language DataKinds #-} {-# language FlexibleContexts #-} @@ -45,6 +46,10 @@ import Mu.Schema.Definition import Mu.Schema.Interpretation import qualified Mu.Schema.Registry as R +#if MIN_VERSION_proto3_wire(1,1,0) +instance ProtoEnum Bool +#endif + data ProtoBufAnnotation = ProtoBufId Nat | ProtoBufOneOfIds [Nat] diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 18c40f16..3219036b 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2019-11-29 +resolver: nightly-2019-12-12 allow-newer: true packages: @@ -18,7 +18,7 @@ packages: extra-deps: - http2-client-0.9.0.0 - http2-grpc-types-0.5.0.0 -- proto3-wire-1.0.0 +- proto3-wire-1.1.0 - http2-grpc-proto3-wire-0.1.0.0 - warp-grpc-0.2.0.0 - http2-client-grpc-0.8.0.0 diff --git a/stack.yaml b/stack.yaml index 005bbbf0..18a23acb 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,5 @@ -resolver: lts-14.14 +resolver: lts-14.17 +allow-newer: true packages: - core/schema @@ -17,7 +18,7 @@ packages: extra-deps: - http2-client-0.9.0.0 - http2-grpc-types-0.5.0.0 -- proto3-wire-1.0.0 +- proto3-wire-1.1.0 - http2-grpc-proto3-wire-0.1.0.0 - warp-grpc-0.2.0.0 - http2-client-grpc-0.8.0.0 From 4e438ed0c65777dc6e48a3c02f4dfe6442b9e7d6 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Fri, 13 Dec 2019 13:25:19 +0100 Subject: [PATCH 019/217] Do not run Haddock on CI (#43) --- .travis.yml | 5 ----- 1 file changed, 5 deletions(-) diff --git a/.travis.yml b/.travis.yml index 4816f5c3..bb8bf49e 100644 --- a/.travis.yml +++ b/.travis.yml @@ -25,8 +25,3 @@ install: # Build dependencies - stack --no-terminal --install-ghc test --only-dependencies - stack --no-terminal --install-ghc test --only-dependencies --stack-yaml stack-nightly.yaml - -script: -# Build the package, its tests, and its docs and run the tests -- stack --no-terminal test --haddock --no-haddock-deps -- stack --no-terminal test --haddock --no-haddock-deps --stack-yaml stack-nightly.yaml From 5072c0142039254f777837c1102a2fba9d3e9c8f Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Mon, 16 Dec 2019 12:29:13 +0100 Subject: [PATCH 020/217] =?UTF-8?q?Add=20persistent=20client=20to=20exampl?= =?UTF-8?q?e=20=F0=9F=91=A8=F0=9F=8F=BC=E2=80=8D=F0=9F=92=BB=20(#44)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- LICENSE | 202 ++++++++++++++++++ adapter/avro/LICENSE | 2 +- adapter/protobuf/LICENSE | 2 +- compendium-client/LICENSE | 2 +- core/rpc/LICENSE | 2 +- core/schema/LICENSE | 2 +- examples/deployment/docker/LICENSE | 2 +- examples/health-check/LICENSE | 2 +- examples/route-guide/LICENSE | 2 +- examples/seed/LICENSE | 2 +- examples/todolist/LICENSE | 2 +- examples/with-persistent/README.md | 6 + .../mu-example-with-persistent.cabal | 17 ++ examples/with-persistent/src/Client.hs | 52 +++++ grpc/client/LICENSE | 2 +- grpc/client/src/Mu/GRpc/Client/Internal.hs | 29 +++ grpc/server/LICENSE | 2 +- 17 files changed, 318 insertions(+), 12 deletions(-) create mode 100644 LICENSE create mode 100644 examples/with-persistent/src/Client.hs diff --git a/LICENSE b/LICENSE new file mode 100644 index 00000000..ffeb95d1 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright © 2019-2020 47 Degrees. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/adapter/avro/LICENSE b/adapter/avro/LICENSE index d6456956..ffeb95d1 100644 --- a/adapter/avro/LICENSE +++ b/adapter/avro/LICENSE @@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright [yyyy] [name of copyright owner] + Copyright © 2019-2020 47 Degrees. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/adapter/protobuf/LICENSE b/adapter/protobuf/LICENSE index d6456956..ffeb95d1 100644 --- a/adapter/protobuf/LICENSE +++ b/adapter/protobuf/LICENSE @@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright [yyyy] [name of copyright owner] + Copyright © 2019-2020 47 Degrees. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/compendium-client/LICENSE b/compendium-client/LICENSE index d6456956..ffeb95d1 100644 --- a/compendium-client/LICENSE +++ b/compendium-client/LICENSE @@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright [yyyy] [name of copyright owner] + Copyright © 2019-2020 47 Degrees. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/core/rpc/LICENSE b/core/rpc/LICENSE index d6456956..ffeb95d1 100644 --- a/core/rpc/LICENSE +++ b/core/rpc/LICENSE @@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright [yyyy] [name of copyright owner] + Copyright © 2019-2020 47 Degrees. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/core/schema/LICENSE b/core/schema/LICENSE index d6456956..ffeb95d1 100644 --- a/core/schema/LICENSE +++ b/core/schema/LICENSE @@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright [yyyy] [name of copyright owner] + Copyright © 2019-2020 47 Degrees. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/examples/deployment/docker/LICENSE b/examples/deployment/docker/LICENSE index d6456956..ffeb95d1 100644 --- a/examples/deployment/docker/LICENSE +++ b/examples/deployment/docker/LICENSE @@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright [yyyy] [name of copyright owner] + Copyright © 2019-2020 47 Degrees. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/examples/health-check/LICENSE b/examples/health-check/LICENSE index d6456956..ffeb95d1 100644 --- a/examples/health-check/LICENSE +++ b/examples/health-check/LICENSE @@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright [yyyy] [name of copyright owner] + Copyright © 2019-2020 47 Degrees. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/examples/route-guide/LICENSE b/examples/route-guide/LICENSE index d6456956..ffeb95d1 100644 --- a/examples/route-guide/LICENSE +++ b/examples/route-guide/LICENSE @@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright [yyyy] [name of copyright owner] + Copyright © 2019-2020 47 Degrees. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/examples/seed/LICENSE b/examples/seed/LICENSE index d6456956..ffeb95d1 100644 --- a/examples/seed/LICENSE +++ b/examples/seed/LICENSE @@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright [yyyy] [name of copyright owner] + Copyright © 2019-2020 47 Degrees. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/examples/todolist/LICENSE b/examples/todolist/LICENSE index d6456956..ffeb95d1 100644 --- a/examples/todolist/LICENSE +++ b/examples/todolist/LICENSE @@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright [yyyy] [name of copyright owner] + Copyright © 2019-2020 47 Degrees. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/examples/with-persistent/README.md b/examples/with-persistent/README.md index 7f88ce43..dd3fd785 100644 --- a/examples/with-persistent/README.md +++ b/examples/with-persistent/README.md @@ -8,6 +8,12 @@ Running the server: stack run persistent-server ``` +In another terminal, run the client: + +```bash +stack run persistent-client +``` + [comment]: # (Start Copyright) # Copyright diff --git a/examples/with-persistent/mu-example-with-persistent.cabal b/examples/with-persistent/mu-example-with-persistent.cabal index b7f75acb..cd0de8fb 100644 --- a/examples/with-persistent/mu-example-with-persistent.cabal +++ b/examples/with-persistent/mu-example-with-persistent.cabal @@ -27,3 +27,20 @@ executable persistent-server , persistent-sqlite , persistent-template , text + +executable persistent-client + main-is: Client.hs + other-modules: Schema + build-depends: base >=4.12 && <5 + , conduit + , mu-schema + , mu-rpc + , mu-protobuf + , mu-grpc-client + , persistent + , persistent-sqlite + , persistent-template + , text + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/examples/with-persistent/src/Client.hs b/examples/with-persistent/src/Client.hs new file mode 100644 index 00000000..3359ed85 --- /dev/null +++ b/examples/with-persistent/src/Client.hs @@ -0,0 +1,52 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} + +module Main where + +import Data.Conduit +import qualified Data.Conduit.Combinators as C +import qualified Data.Text as T +import Database.Persist.Sql (toSqlKey) +import Database.Persist.Types (Entity(..)) +import System.Environment + +import Mu.GRpc.Client.TyApps + +import Schema + +main :: IO () +main = do + let config = grpcClientConfigSimple "127.0.0.1" 1234 False + Right client <- setupGrpcClient' config + args <- getArgs + case args of + ["watch"] -> watching client + ["get", idp] -> get client idp + ["add", name, age] -> add client name age + _ -> putStrLn "unknown command" + +get :: GrpcClient -> String -> IO () +get client idPerson = do + let req = PersonRequest $ read idPerson + putStrLn ("GET: Is there some person with id: " ++ idPerson ++ "?") + rknown :: GRpcReply (Entity Person) + <- gRpcCall @PersistentService @"getPerson" client req + putStrLn ("GET: response was: " ++ show rknown) + +add :: GrpcClient -> String -> String -> IO () +add client name age = do + let p = Entity (toSqlKey 1) (Person (T.pack name) (read age)) + putStrLn ("ADD: Creating new person " <> name <> " with age " <> age) + response :: GRpcReply PersonRequest + <- gRpcCall @PersistentService @"newPerson" client p + putStrLn ("ADD: Was creating successful? " <> show response) + +watching :: GrpcClient -> IO () +watching client = do + replies <- gRpcCall @PersistentService @"allPeople" client + runConduit $ replies .| C.mapM_ (print :: GRpcReply (Entity Person) -> IO ()) diff --git a/grpc/client/LICENSE b/grpc/client/LICENSE index d6456956..ffeb95d1 100644 --- a/grpc/client/LICENSE +++ b/grpc/client/LICENSE @@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright [yyyy] [name of copyright owner] + Copyright © 2019-2020 47 Degrees. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. diff --git a/grpc/client/src/Mu/GRpc/Client/Internal.hs b/grpc/client/src/Mu/GRpc/Client/Internal.hs index f551a340..d59952bc 100644 --- a/grpc/client/src/Mu/GRpc/Client/Internal.hs +++ b/grpc/client/src/Mu/GRpc/Client/Internal.hs @@ -100,6 +100,35 @@ instance ( KnownName name, ProtoBufTypeRef rref r where methodName = BS.pack (nameVal (Proxy @name)) rpc = RPC pkgName srvName methodName +instance ( KnownName name, ProtoBufTypeRef rref r + , handler ~ (IO (ConduitT () (GRpcReply r) IO ())) ) + => GRpcMethodCall ('Method name anns '[ ] ('RetStream rref)) handler where + gRpcMethodCall pkgName srvName _ client + = do -- Create a new TMChan + chan <- newTMChanIO :: IO (TMChan r) + var <- newEmptyTMVarIO -- if full, this means an error + -- Start executing the client in another thread + _ <- async $ do + v <- simplifyResponse $ + buildGRpcReply3 <$> + rawStreamServer @_ @() @(ViaProtoBufTypeRef rref r) + rpc client () () + (\_ _ (ViaProtoBufTypeRef newVal) -> liftIO $ atomically $ + -- on the first iteration, say that everything is OK + tryPutTMVar var (GRpcOk ()) >> writeTMChan chan newVal) + case v of + GRpcOk () -> liftIO $ atomically $ closeTMChan chan + _ -> liftIO $ atomically $ putTMVar var v + -- This conduit feeds information to the other thread + let go = do firstResult <- liftIO $ atomically $ takeTMVar var + case firstResult of + GRpcOk _ -> -- no error, everything is fine + sourceTMChan chan .| C.map GRpcOk + e -> yield $ (\_ -> error "this should never happen") <$> e + return go + where methodName = BS.pack (nameVal (Proxy @name)) + rpc = RPC pkgName srvName methodName + instance ( KnownName name, ProtoBufTypeRef vref v , handler ~ (v -> IO (GRpcReply ())) ) => GRpcMethodCall ('Method name anns '[ 'ArgSingle vref ] 'RetNothing) handler where diff --git a/grpc/server/LICENSE b/grpc/server/LICENSE index d6456956..ffeb95d1 100644 --- a/grpc/server/LICENSE +++ b/grpc/server/LICENSE @@ -187,7 +187,7 @@ same "printed page" as the copyright notice for easier identification within third-party archives. - Copyright [yyyy] [name of copyright owner] + Copyright © 2019-2020 47 Degrees. Licensed under the Apache License, Version 2.0 (the "License"); you may not use this file except in compliance with the License. From cfd52d951d2607d9a484cc92b03927d908e7733a Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 16 Dec 2019 13:46:43 +0100 Subject: [PATCH 021/217] Higher-kinded data and To/FromSchema separation (#41) Closes #39 --- adapter/avro/src/Mu/Adapter/Avro.hs | 198 +++++----- adapter/avro/test/Avro.hs | 7 +- adapter/protobuf/mu-protobuf.cabal | 1 + adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs | 196 +++++----- .../protobuf/src/Mu/Adapter/ProtoBuf/Via.hs | 38 +- adapter/protobuf/src/Mu/Quasi/GRpc.hs | 8 +- adapter/protobuf/test/ProtoBuf.hs | 38 +- core/rpc/src/Mu/Rpc.hs | 6 +- core/rpc/src/Mu/Rpc/Examples.hs | 57 +-- core/rpc/src/Mu/Server.hs | 47 +-- core/schema/mu-schema.cabal | 1 + core/schema/src/Data/Functor/MaybeLike.hs | 14 + core/schema/src/Mu/Adapter/Json.hs | 124 +++--- core/schema/src/Mu/Schema.hs | 5 +- core/schema/src/Mu/Schema/Class.hs | 353 ++++++++++++------ .../src/Mu/Schema/Conversion/SchemaToTypes.hs | 125 ++++--- core/schema/src/Mu/Schema/Examples.hs | 29 +- core/schema/src/Mu/Schema/Interpretation.hs | 217 +++++++---- .../src/Mu/Schema/Interpretation/Anonymous.hs | 84 +++-- .../Mu/Schema/Interpretation/Schemaless.hs | 74 ++-- core/schema/src/Mu/Schema/Registry.hs | 18 +- examples/health-check/src/ClientRecord.hs | 8 +- examples/health-check/src/ClientTyApps.hs | 8 +- examples/health-check/src/Definition.hs | 52 +-- examples/health-check/src/Server.hs | 37 +- examples/route-guide/src/Definition.hs | 30 +- examples/route-guide/src/Server.hs | 43 ++- examples/seed/src/Main.hs | 4 +- examples/seed/src/Schema.hs | 20 +- examples/todolist/src/Definition.hs | 37 +- examples/todolist/src/Server.hs | 44 ++- examples/with-persistent/src/Client.hs | 15 +- examples/with-persistent/src/Schema.hs | 74 +++- examples/with-persistent/src/Server.hs | 17 +- grpc/client/src/Mu/GRpc/Client/Examples.hs | 14 +- grpc/client/src/Mu/GRpc/Client/Internal.hs | 48 +-- grpc/client/src/Mu/GRpc/Client/Record.hs | 12 +- grpc/server/src/Mu/GRpc/Server.hs | 83 ++-- templates/grpc-server.hsfiles | 7 +- 39 files changed, 1299 insertions(+), 894 deletions(-) create mode 100644 core/schema/src/Data/Functor/MaybeLike.hs diff --git a/adapter/avro/src/Mu/Adapter/Avro.hs b/adapter/avro/src/Mu/Adapter/Avro.hs index 907fd86b..af84fc5a 100644 --- a/adapter/avro/src/Mu/Adapter/Avro.hs +++ b/adapter/avro/src/Mu/Adapter/Avro.hs @@ -19,11 +19,11 @@ import qualified Data.Avro.Types.Value as AVal -- 'Tagged . unTagged' can be replaced by 'coerce' -- eliminating some run-time overhead import Data.Coerce (coerce) +import Data.Functor.Identity import qualified Data.HashMap.Strict as HM import Data.List.NonEmpty (NonEmpty (..)) import qualified Data.List.NonEmpty as NonEmptyList import qualified Data.Map as M -import Data.SOP (NP (..), NS (..)) import Data.Tagged import qualified Data.Text as T import qualified Data.Vector as V @@ -32,9 +32,9 @@ import GHC.TypeLits import Mu.Schema import qualified Mu.Schema.Interpretation.Schemaless as SLess -instance SLess.ToSchemalessTerm (AVal.Value t) where +instance SLess.ToSchemalessTerm (AVal.Value t) Identity where toSchemalessTerm (AVal.Record _ r) - = SLess.TRecord $ map (\(k,v) -> SLess.Field k (SLess.toSchemalessValue v)) + = SLess.TRecord $ map (\(k,v) -> SLess.Field k (Identity $ SLess.toSchemalessValue v)) $ HM.toList r toSchemalessTerm (AVal.Enum _ i _) = SLess.TEnum i @@ -42,7 +42,7 @@ instance SLess.ToSchemalessTerm (AVal.Value t) where = SLess.toSchemalessTerm v toSchemalessTerm v = SLess.TSimple (SLess.toSchemalessValue v) -instance SLess.ToSchemalessValue (AVal.Value t) where +instance SLess.ToSchemalessValue (AVal.Value t) Identity where toSchemalessValue AVal.Null = SLess.FNull toSchemalessValue (AVal.Boolean b) = SLess.FPrimitive b toSchemalessValue (AVal.Int b) = SLess.FPrimitive b @@ -66,73 +66,75 @@ instance SLess.ToSchemalessValue (AVal.Value t) where = SLess.FSchematic (SLess.toSchemalessTerm e) instance HasAvroSchemas sch sch - => A.HasAvroSchema (WithSchema sch sty t) where + => A.HasAvroSchema (WithSchema f sch sty t) where -- the previous iteration added only the schema of the type -- schema = coerce $ A.schema @(Term sch (sch :/: sty)) -- but now we prefer to have all of them schema = Tagged $ ASch.Union (schemas (Proxy @sch) (Proxy @sch)) -instance (HasSchema sch sty t, HasAvroSchemas sch sch, A.FromAvro (Term sch (sch :/: sty))) - => A.FromAvro (WithSchema sch sty t) where - fromAvro (AVal.Union _ _ v) = WithSchema . fromSchema' @sch <$> A.fromAvro v +instance ( FromSchema f sch sty t, HasAvroSchemas sch sch + , A.FromAvro (Term f sch (sch :/: sty)) ) + => A.FromAvro (WithSchema f sch sty t) where + fromAvro (AVal.Union _ _ v) = WithSchema . fromSchema' @_ @_ @sch @f <$> A.fromAvro v fromAvro v = ASch.badValue v "top-level" -instance (HasSchema sch sty t, HasAvroSchemas sch sch, A.ToAvro (Term sch (sch :/: sty))) - => A.ToAvro (WithSchema sch sty t) where +instance ( ToSchema Identity sch sty t, HasAvroSchemas sch sch + , A.ToAvro (Term Identity sch (sch :/: sty)) ) + => A.ToAvro (WithSchema Identity sch sty t) where toAvro (WithSchema v) = AVal.Union (schemas (Proxy @sch) (Proxy @sch)) - (unTagged $ A.schema @(Term sch (sch :/: sty))) - (A.toAvro (toSchema' @sch v)) + (unTagged $ A.schema @(Term Identity sch (sch :/: sty))) + (A.toAvro (toSchema' @_ @_ @sch @Identity v)) class HasAvroSchemas (r :: Schema tn fn) (sch :: Schema tn fn) where schemas :: Proxy r -> Proxy sch -> V.Vector ASch.Type instance HasAvroSchemas r '[] where schemas _ _ = V.empty instance forall r d ds. - (A.HasAvroSchema (Term r d), HasAvroSchemas r ds) + (A.HasAvroSchema (Term Identity r d), HasAvroSchemas r ds) => HasAvroSchemas r (d ': ds) where schemas pr _ = V.cons thisSchema (schemas pr (Proxy @ds)) - where thisSchema = unTagged $ A.schema @(Term r d) + where thisSchema = unTagged $ A.schema @(Term Identity r d) -- HasAvroSchema instances instance (KnownName name, HasAvroSchemaFields sch args) - => A.HasAvroSchema (Term sch ('DRecord name args)) where + => A.HasAvroSchema (Term f sch ('DRecord name args)) where schema = Tagged $ ASch.Record recordName [] Nothing Nothing fields where recordName = nameTypeName (Proxy @name) fields = schemaF (Proxy @sch) (Proxy @args) instance (KnownName name, HasAvroSchemaEnum choices) - => A.HasAvroSchema (Term sch ('DEnum name choices)) where + => A.HasAvroSchema (Term f sch ('DEnum name choices)) where schema = Tagged $ ASch.mkEnum enumName [] Nothing choicesNames where enumName = nameTypeName (Proxy @name) choicesNames = schemaE (Proxy @choices) -instance A.HasAvroSchema (FieldValue sch t) - => A.HasAvroSchema (Term sch ('DSimple t)) where - schema = coerce $ A.schema @(FieldValue sch t) +instance A.HasAvroSchema (FieldValue f sch t) + => A.HasAvroSchema (Term f sch ('DSimple t)) where + schema = coerce $ A.schema @(FieldValue f sch t) -instance A.HasAvroSchema (FieldValue sch 'TNull) where +instance A.HasAvroSchema (FieldValue f sch 'TNull) where schema = Tagged ASch.Null instance A.HasAvroSchema t - => A.HasAvroSchema (FieldValue sch ('TPrimitive t)) where + => A.HasAvroSchema (FieldValue f sch ('TPrimitive t)) where schema = coerce $ A.schema @t instance KnownName t - => A.HasAvroSchema (FieldValue sch ('TSchematic t)) where + => A.HasAvroSchema (FieldValue f sch ('TSchematic t)) where -- schema = coerce $ A.schema @(Term sch (sch :/: t)) schema = Tagged $ ASch.NamedType (nameTypeName (Proxy @t)) -instance forall sch choices. - HasAvroSchemaUnion (FieldValue sch) choices - => A.HasAvroSchema (FieldValue sch ('TUnion choices)) where - schema = Tagged $ ASch.mkUnion $ schemaU (Proxy @(FieldValue sch)) (Proxy @choices) -instance A.HasAvroSchema (FieldValue sch t) - => A.HasAvroSchema (FieldValue sch ('TOption t)) where - schema = coerce $ A.schema @(Maybe (FieldValue sch t)) -instance A.HasAvroSchema (FieldValue sch t) - => A.HasAvroSchema (FieldValue sch ('TList t)) where - schema = coerce $ A.schema @[FieldValue sch t] +instance forall sch f choices. + HasAvroSchemaUnion (FieldValue f sch) choices + => A.HasAvroSchema (FieldValue f sch ('TUnion choices)) where + schema = Tagged $ ASch.mkUnion $ schemaU (Proxy @(FieldValue f sch)) (Proxy @choices) +instance A.HasAvroSchema (FieldValue f sch t) + => A.HasAvroSchema (FieldValue f sch ('TOption t)) where + schema = coerce $ A.schema @(Maybe (FieldValue f sch t)) +instance A.HasAvroSchema (FieldValue f sch t) + => A.HasAvroSchema (FieldValue f sch ('TList t)) where + schema = coerce $ A.schema @[FieldValue f sch t] -- These are the only two versions of Map supported by the library -instance A.HasAvroSchema (FieldValue sch v) - => A.HasAvroSchema (FieldValue sch ('TMap ('TPrimitive T.Text) v)) where - schema = coerce $ A.schema @(M.Map T.Text (FieldValue sch v)) -instance A.HasAvroSchema (FieldValue sch v) - => A.HasAvroSchema (FieldValue sch ('TMap ('TPrimitive String) v)) where - schema = coerce $ A.schema @(M.Map String (FieldValue sch v)) +instance A.HasAvroSchema (FieldValue f sch v) + => A.HasAvroSchema (FieldValue f sch ('TMap ('TPrimitive T.Text) v)) where + schema = coerce $ A.schema @(M.Map T.Text (FieldValue f sch v)) +instance A.HasAvroSchema (FieldValue f sch v) + => A.HasAvroSchema (FieldValue f sch ('TMap ('TPrimitive String) v)) where + schema = coerce $ A.schema @(M.Map String (FieldValue f sch v)) class HasAvroSchemaUnion (f :: k -> *) (xs :: [k]) where schemaU :: Proxy f -> Proxy xs -> NonEmpty ASch.Type @@ -149,11 +151,11 @@ class HasAvroSchemaFields sch (fs :: [FieldDef tn fn]) where schemaF :: Proxy sch -> Proxy fs -> [ASch.Field] instance HasAvroSchemaFields sch '[] where schemaF _ _ = [] -instance (KnownName name, A.HasAvroSchema (FieldValue sch t), HasAvroSchemaFields sch fs) +instance (KnownName name, A.HasAvroSchema (FieldValue Identity sch t), HasAvroSchemaFields sch fs) => HasAvroSchemaFields sch ('FieldDef name t ': fs) where schemaF psch _ = schemaThis : schemaF psch (Proxy @fs) where fieldName = nameText (Proxy @name) - schemaT = unTagged $ A.schema @(FieldValue sch t) + schemaT = unTagged $ A.schema @(FieldValue Identity sch t) schemaThis = ASch.Field fieldName [] Nothing Nothing schemaT Nothing class HasAvroSchemaEnum (fs :: [ChoiceDef fn]) where @@ -166,42 +168,42 @@ instance (KnownName name, HasAvroSchemaEnum fs) -- FromAvro instances -instance (KnownName name, HasAvroSchemaFields sch args, FromAvroFields sch args) - => A.FromAvro (Term sch ('DRecord name args)) where +instance (KnownName name, HasAvroSchemaFields sch args, FromAvroFields f sch args) + => A.FromAvro (Term f sch ('DRecord name args)) where fromAvro (AVal.Record _ fields) = TRecord <$> fromAvroF fields fromAvro v = A.badValue v "record" instance (KnownName name, HasAvroSchemaEnum choices, FromAvroEnum choices) - => A.FromAvro (Term sch ('DEnum name choices)) where + => A.FromAvro (Term f sch ('DEnum name choices)) where fromAvro v@(AVal.Enum _ n _) = TEnum <$> fromAvroEnum v n fromAvro v = A.badValue v "enum" -instance A.FromAvro (FieldValue sch t) - => A.FromAvro (Term sch ('DSimple t)) where +instance A.FromAvro (FieldValue f sch t) + => A.FromAvro (Term f sch ('DSimple t)) where fromAvro v = TSimple <$> A.fromAvro v -instance A.FromAvro (FieldValue sch 'TNull) where +instance A.FromAvro (FieldValue f sch 'TNull) where fromAvro AVal.Null = return FNull fromAvro v = A.badValue v "null" -instance A.FromAvro t => A.FromAvro (FieldValue sch ('TPrimitive t)) where +instance A.FromAvro t => A.FromAvro (FieldValue f sch ('TPrimitive t)) where fromAvro v = FPrimitive <$> A.fromAvro v -instance (KnownName t, A.FromAvro (Term sch (sch :/: t))) - => A.FromAvro (FieldValue sch ('TSchematic t)) where +instance (KnownName t, A.FromAvro (Term f sch (sch :/: t))) + => A.FromAvro (FieldValue f sch ('TSchematic t)) where fromAvro v = FSchematic <$> A.fromAvro v -instance (HasAvroSchemaUnion (FieldValue sch) choices, FromAvroUnion sch choices) - => A.FromAvro (FieldValue sch ('TUnion choices)) where +instance (HasAvroSchemaUnion (FieldValue f sch) choices, FromAvroUnion f sch choices) + => A.FromAvro (FieldValue f sch ('TUnion choices)) where fromAvro (AVal.Union _ branch v) = FUnion <$> fromAvroU branch v fromAvro v = A.badValue v "union" -instance A.FromAvro (FieldValue sch t) - => A.FromAvro (FieldValue sch ('TOption t)) where +instance A.FromAvro (FieldValue f sch t) + => A.FromAvro (FieldValue f sch ('TOption t)) where fromAvro v = FOption <$> A.fromAvro v -instance A.FromAvro (FieldValue sch t) - => A.FromAvro (FieldValue sch ('TList t)) where +instance A.FromAvro (FieldValue f sch t) + => A.FromAvro (FieldValue f sch ('TList t)) where fromAvro v = FList <$> A.fromAvro v -- These are the only two versions of Map supported by the library -instance A.FromAvro (FieldValue sch v) - => A.FromAvro (FieldValue sch ('TMap ('TPrimitive T.Text) v)) where +instance A.FromAvro (FieldValue f sch v) + => A.FromAvro (FieldValue f sch ('TMap ('TPrimitive T.Text) v)) where fromAvro v = FMap . M.mapKeys FPrimitive <$> A.fromAvro v -instance A.FromAvro (FieldValue sch v) - => A.FromAvro (FieldValue sch ('TMap ('TPrimitive String) v)) where +instance A.FromAvro (FieldValue f sch v) + => A.FromAvro (FieldValue f sch ('TMap ('TPrimitive String) v)) where fromAvro v = FMap . M.mapKeys (FPrimitive . T.unpack) <$> A.fromAvro v class FromAvroEnum (vs :: [ChoiceDef fn]) where @@ -212,80 +214,80 @@ instance FromAvroEnum vs => FromAvroEnum (v ': vs) where fromAvroEnum _ 0 = return (Z Proxy) fromAvroEnum v n = S <$> fromAvroEnum v (n-1) -class FromAvroUnion sch choices where - fromAvroU :: ASch.Type -> AVal.Value ASch.Type -> ASch.Result (NS (FieldValue sch) choices) -instance FromAvroUnion sch '[] where +class FromAvroUnion f sch choices where + fromAvroU :: ASch.Type -> AVal.Value ASch.Type -> ASch.Result (NS (FieldValue f sch) choices) +instance FromAvroUnion f sch '[] where fromAvroU _ v = A.badValue v "union choice not found" -instance (A.FromAvro (FieldValue sch u), FromAvroUnion sch us) - => FromAvroUnion sch (u ': us) where +instance (A.FromAvro (FieldValue f sch u), FromAvroUnion f sch us) + => FromAvroUnion f sch (u ': us) where fromAvroU branch v - | ASch.matches branch (unTagged (A.schema @(FieldValue sch u))) + | ASch.matches branch (unTagged (A.schema @(FieldValue f sch u))) = Z <$> A.fromAvro v | otherwise = S <$> fromAvroU branch v -class FromAvroFields sch (fs :: [FieldDef Symbol Symbol]) where - fromAvroF :: HM.HashMap T.Text (AVal.Value ASch.Type) -> A.Result (NP (Field sch) fs) -instance FromAvroFields sch '[] where +class FromAvroFields f sch (fs :: [FieldDef Symbol Symbol]) where + fromAvroF :: HM.HashMap T.Text (AVal.Value ASch.Type) -> A.Result (NP (Field f sch) fs) +instance FromAvroFields f sch '[] where fromAvroF _ = return Nil -instance (KnownName name, A.FromAvro (FieldValue sch t), FromAvroFields sch fs) - => FromAvroFields sch ('FieldDef name t ': fs) where +instance (Applicative f, KnownName name, A.FromAvro (FieldValue f sch t), FromAvroFields f sch fs) + => FromAvroFields f sch ('FieldDef name t ': fs) where fromAvroF v = case HM.lookup fieldName v of Nothing -> A.badValue v "field not found" - Just f -> (:*) <$> (Field <$> A.fromAvro f) <*> fromAvroF v + Just f -> (:*) <$> (Field . pure <$> A.fromAvro f) <*> fromAvroF v where fieldName = nameText (Proxy @name) -- ToAvro instances instance (KnownName name, HasAvroSchemaFields sch args, ToAvroFields sch args) - => A.ToAvro (Term sch ('DRecord name args)) where + => A.ToAvro (Term Identity sch ('DRecord name args)) where toAvro (TRecord fields) = AVal.Record wholeSchema (toAvroF fields) - where wholeSchema = unTagged (A.schema @(Term sch ('DRecord name args))) + where wholeSchema = unTagged (A.schema @(Term Identity sch ('DRecord name args))) instance (KnownName name, HasAvroSchemaEnum choices, ToAvroEnum choices) - => A.ToAvro (Term sch ('DEnum name choices)) where + => A.ToAvro (Term Identity sch ('DEnum name choices)) where toAvro (TEnum n) = AVal.Enum wholeSchema choice text - where wholeSchema = unTagged (A.schema @(Term sch ('DEnum name choices))) + where wholeSchema = unTagged (A.schema @(Term Identity sch ('DEnum name choices))) (choice, text) = toAvroE n -instance A.ToAvro (FieldValue sch t) - => A.ToAvro (Term sch ('DSimple t)) where +instance A.ToAvro (FieldValue Identity sch t) + => A.ToAvro (Term Identity sch ('DSimple t)) where toAvro (TSimple v) = A.toAvro v -instance A.ToAvro (FieldValue sch 'TNull) where +instance A.ToAvro (FieldValue Identity sch 'TNull) where toAvro FNull = AVal.Null -instance A.ToAvro t => A.ToAvro (FieldValue sch ('TPrimitive t)) where +instance A.ToAvro t => A.ToAvro (FieldValue Identity sch ('TPrimitive t)) where toAvro (FPrimitive v) = A.toAvro v -instance (KnownName t, A.ToAvro (Term sch (sch :/: t))) - => A.ToAvro (FieldValue sch ('TSchematic t)) where +instance (KnownName t, A.ToAvro (Term Identity sch (sch :/: t))) + => A.ToAvro (FieldValue Identity sch ('TSchematic t)) where toAvro (FSchematic v) = A.toAvro v instance forall sch choices. - (HasAvroSchemaUnion (FieldValue sch) choices, ToAvroUnion sch choices) - => A.ToAvro (FieldValue sch ('TUnion choices)) where + (HasAvroSchemaUnion (FieldValue Identity sch) choices, ToAvroUnion sch choices) + => A.ToAvro (FieldValue Identity sch ('TUnion choices)) where toAvro (FUnion v) = AVal.Union wholeSchema' chosenTy chosenVal - where wholeSchema = schemaU (Proxy @(FieldValue sch)) (Proxy @choices) + where wholeSchema = schemaU (Proxy @(FieldValue Identity sch)) (Proxy @choices) wholeSchema' = V.fromList (NonEmptyList.toList wholeSchema) (chosenTy, chosenVal) = toAvroU v -instance A.ToAvro (FieldValue sch t) - => A.ToAvro (FieldValue sch ('TOption t)) where +instance A.ToAvro (FieldValue Identity sch t) + => A.ToAvro (FieldValue Identity sch ('TOption t)) where toAvro (FOption v) = A.toAvro v -instance A.ToAvro (FieldValue sch t) - => A.ToAvro (FieldValue sch ('TList t)) where +instance A.ToAvro (FieldValue Identity sch t) + => A.ToAvro (FieldValue Identity sch ('TList t)) where toAvro (FList v) = AVal.Array $ V.fromList $ A.toAvro <$> v -- These are the only two versions of Map supported by the library -instance A.ToAvro (FieldValue sch v) - => A.ToAvro (FieldValue sch ('TMap ('TPrimitive T.Text) v)) where +instance A.ToAvro (FieldValue Identity sch v) + => A.ToAvro (FieldValue Identity sch ('TMap ('TPrimitive T.Text) v)) where toAvro (FMap v) = A.toAvro $ M.mapKeys (\(FPrimitive k) -> k) v -instance A.ToAvro (FieldValue sch v) - => A.ToAvro (FieldValue sch ('TMap ('TPrimitive String) v)) where +instance A.ToAvro (FieldValue Identity sch v) + => A.ToAvro (FieldValue Identity sch ('TMap ('TPrimitive String) v)) where toAvro (FMap v) = A.toAvro $ M.mapKeys (\(FPrimitive k) -> k) v class ToAvroUnion sch choices where - toAvroU :: NS (FieldValue sch) choices -> (ASch.Type, AVal.Value ASch.Type) + toAvroU :: NS (FieldValue Identity sch) choices -> (ASch.Type, AVal.Value ASch.Type) instance ToAvroUnion sch '[] where toAvroU _ = error "ToAvro in an empty union" instance forall sch u us. - (A.ToAvro (FieldValue sch u), ToAvroUnion sch us) + (A.ToAvro (FieldValue Identity sch u), ToAvroUnion sch us) => ToAvroUnion sch (u ': us) where - toAvroU (Z v) = (unTagged (A.schema @(FieldValue sch u)), A.toAvro v) + toAvroU (Z v) = (unTagged (A.schema @(FieldValue Identity sch u)), A.toAvro v) toAvroU (S n) = toAvroU n class ToAvroEnum choices where @@ -298,12 +300,12 @@ instance (KnownName u, ToAvroEnum us) toAvroE (S v) = let (n, t) = toAvroE v in (n + 1, t) class ToAvroFields sch (fs :: [FieldDef Symbol Symbol]) where - toAvroF :: NP (Field sch) fs -> HM.HashMap T.Text (AVal.Value ASch.Type) + toAvroF :: NP (Field Identity sch) fs -> HM.HashMap T.Text (AVal.Value ASch.Type) instance ToAvroFields sch '[] where toAvroF _ = HM.empty -instance (KnownName name, A.ToAvro (FieldValue sch t), ToAvroFields sch fs) +instance (KnownName name, A.ToAvro (FieldValue Identity sch t), ToAvroFields sch fs) => ToAvroFields sch ('FieldDef name t ': fs) where - toAvroF (Field v :* rest) = HM.insert fieldName fieldValue (toAvroF rest) + toAvroF (Field (Identity v) :* rest) = HM.insert fieldName fieldValue (toAvroF rest) where fieldName = nameText (Proxy @name) fieldValue = A.toAvro v diff --git a/adapter/avro/test/Avro.hs b/adapter/avro/test/Avro.hs index 6ec88438..008250eb 100644 --- a/adapter/avro/test/Avro.hs +++ b/adapter/avro/test/Avro.hs @@ -8,6 +8,7 @@ module Main where import Data.Avro import qualified Data.ByteString.Lazy as BS +import Data.Functor.Identity import System.Environment import Mu.Adapter.Avro () @@ -21,9 +22,9 @@ examplePerson1, examplePerson2 :: Person examplePerson1 = Person "Haskellio" "Gómez" (Just 30) (Just Male) exampleAddress examplePerson2 = Person "Cuarenta" "Siete" Nothing Nothing exampleAddress -deriving via (WithSchema ExampleSchema "person" Person) instance HasAvroSchema Person -deriving via (WithSchema ExampleSchema "person" Person) instance FromAvro Person -deriving via (WithSchema ExampleSchema "person" Person) instance ToAvro Person +deriving via (WithSchema Identity ExampleSchema "person" Person) instance HasAvroSchema Person +deriving via (WithSchema Identity ExampleSchema "person" Person) instance FromAvro Person +deriving via (WithSchema Identity ExampleSchema "person" Person) instance ToAvro Person main :: IO () main = do -- Obtain the filenames diff --git a/adapter/protobuf/mu-protobuf.cabal b/adapter/protobuf/mu-protobuf.cabal index 5f1d82bf..e5970f63 100644 --- a/adapter/protobuf/mu-protobuf.cabal +++ b/adapter/protobuf/mu-protobuf.cabal @@ -44,6 +44,7 @@ executable test-protobuf , mu-schema , mu-protobuf , bytestring + , text , proto3-wire hs-source-dirs: test default-language: Haskell2010 diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs index c5e506f9..e2341b79 100644 --- a/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs @@ -13,13 +13,13 @@ {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} +{-# language ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Mu.Adapter.ProtoBuf ( -- * Custom annotations ProtoBufAnnotation(..) -- * Conversion using schemas , IsProtoSchema -, HasProtoSchema , toProtoViaSchema , fromProtoViaSchema , parseProtoViaSchema @@ -31,6 +31,7 @@ module Mu.Adapter.ProtoBuf ( import Control.Applicative import qualified Data.ByteString as BS +import Data.Functor.MaybeLike import Data.Int import Data.SOP (All) import qualified Data.Text as T @@ -76,23 +77,23 @@ type family FindProtoBufOneOfIds' (t :: tn) (f :: fn) (p :: ProtoBufAnnotation) -- CONVERSION USING SCHEMAS -class ProtoBridgeTerm sch (sch :/: sty) => IsProtoSchema sch sty -instance ProtoBridgeTerm sch (sch :/: sty) => IsProtoSchema sch sty +class ProtoBridgeTerm w sch (sch :/: sty) => IsProtoSchema w sch sty +instance ProtoBridgeTerm w sch (sch :/: sty) => IsProtoSchema w sch sty -type HasProtoSchema sch sty a = (HasSchema sch sty a, IsProtoSchema sch sty) +-- type HasProtoSchema w sch sty a = (HasSchema w sch sty a, IsProtoSchema w sch sty) toProtoViaSchema :: forall t f (sch :: Schema t f) a sty. - (HasProtoSchema sch sty a) + (IsProtoSchema Maybe sch sty, ToSchema Maybe sch sty a) => a -> PBEnc.MessageBuilder -toProtoViaSchema = termToProto . toSchema' @sch +toProtoViaSchema = termToProto . toSchema' @_ @_ @sch @Maybe fromProtoViaSchema :: forall t f (sch :: Schema t f) a sty. - (HasProtoSchema sch sty a) + (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty a) => PBDec.Parser PBDec.RawMessage a -fromProtoViaSchema = fromSchema' @sch <$> protoToTerm +fromProtoViaSchema = fromSchema' @_ @_ @sch @Maybe <$> protoToTerm parseProtoViaSchema :: forall sch a sty. - (HasProtoSchema sch sty a) + (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty a) => BS.ByteString -> Either PBDec.ParseError a parseProtoViaSchema = PBDec.parse (fromProtoViaSchema @_ @_ @sch) @@ -115,7 +116,7 @@ class FromProtoBufRegistry (ms :: Mappings Nat Schema') t where instance FromProtoBufRegistry '[] t where fromProtoBufRegistry' _ = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "no schema found in registry")) -instance (HasProtoSchema s sty t, FromProtoBufRegistry ms t) +instance (IsProtoSchema Maybe s sty, FromSchema Maybe s sty t, FromProtoBufRegistry ms t) => FromProtoBufRegistry ( (n ':-> s) ': ms) t where fromProtoBufRegistry' _ = fromProtoViaSchema @_ @_ @s <|> fromProtoBufRegistry' (Proxy @ms) @@ -132,30 +133,30 @@ instance Alternative (PBDec.Parser i) where r@(Right _) -> r -- Top-level terms -class ProtoBridgeTerm (sch :: Schema tn fn) (t :: TypeDef tn fn) where - termToProto :: Term sch t -> PBEnc.MessageBuilder - protoToTerm :: PBDec.Parser PBDec.RawMessage (Term sch t) +class ProtoBridgeTerm (w :: * -> *) (sch :: Schema tn fn) (t :: TypeDef tn fn) where + termToProto :: Term w sch t -> PBEnc.MessageBuilder + protoToTerm :: PBDec.Parser PBDec.RawMessage (Term w sch t) -- Embedded terms -class ProtoBridgeEmbedTerm (sch :: Schema tn fn) (t :: TypeDef tn fn) where - termToEmbedProto :: FieldNumber -> Term sch t -> PBEnc.MessageBuilder - embedProtoToFieldValue :: PBDec.Parser PBDec.RawField (Term sch t) - embedProtoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (Term sch t) +class ProtoBridgeEmbedTerm (w :: * -> *) (sch :: Schema tn fn) (t :: TypeDef tn fn) where + termToEmbedProto :: FieldNumber -> Term w sch t -> PBEnc.MessageBuilder + embedProtoToFieldValue :: PBDec.Parser PBDec.RawField (Term w sch t) + embedProtoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (Term w sch t) -class ProtoBridgeField (sch :: Schema tn fn) (ty :: tn) (f :: FieldDef tn fn) where - fieldToProto :: Field sch f -> PBEnc.MessageBuilder - protoToField :: PBDec.Parser PBDec.RawMessage (Field sch f) +class ProtoBridgeField (w :: * -> *) (sch :: Schema tn fn) (ty :: tn) (f :: FieldDef tn fn) where + fieldToProto :: Field w sch f -> PBEnc.MessageBuilder + protoToField :: PBDec.Parser PBDec.RawMessage (Field w sch f) -class ProtoBridgeFieldValue (sch :: Schema tn fn) (t :: FieldType tn) where - fieldValueToProto :: FieldNumber -> FieldValue sch t -> PBEnc.MessageBuilder - protoToFieldValue :: PBDec.Parser PBDec.RawField (FieldValue sch t) +class ProtoBridgeFieldValue (w :: * -> *) (sch :: Schema tn fn) (t :: FieldType tn) where + fieldValueToProto :: FieldNumber -> FieldValue w sch t -> PBEnc.MessageBuilder + protoToFieldValue :: PBDec.Parser PBDec.RawField (FieldValue w sch t) -class ProtoBridgeOneFieldValue (sch :: Schema tn fn) (t :: FieldType tn) where - protoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (FieldValue sch t) +class ProtoBridgeOneFieldValue (w :: * -> *) (sch :: Schema tn fn) (t :: FieldType tn) where + protoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (FieldValue w sch t) -class ProtoBridgeUnionFieldValue (ids :: [Nat]) (sch :: Schema tn fn) (ts :: [FieldType tn]) where - unionFieldValueToProto :: NS (FieldValue sch) ts -> PBEnc.MessageBuilder - protoToUnionFieldValue :: PBDec.Parser PBDec.RawMessage (NS (FieldValue sch) ts) +class ProtoBridgeUnionFieldValue (w :: * -> *) (ids :: [Nat]) (sch :: Schema tn fn) (ts :: [FieldType tn]) where + unionFieldValueToProto :: NS (FieldValue w sch) ts -> PBEnc.MessageBuilder + protoToUnionFieldValue :: PBDec.Parser PBDec.RawMessage (NS (FieldValue w sch) ts) -- -------- -- TERMS -- @@ -164,43 +165,43 @@ class ProtoBridgeUnionFieldValue (ids :: [Nat]) (sch :: Schema tn fn) (ts :: [Fi -- RECORDS -- ------- -instance (All (ProtoBridgeField sch name) args, ProtoBridgeFields sch name args) - => ProtoBridgeTerm sch ('DRecord name args) where +instance (All (ProtoBridgeField w sch name) args, ProtoBridgeFields w sch name args) + => ProtoBridgeTerm w sch ('DRecord name args) where termToProto (TRecord fields) = go fields - where go :: forall fs. All (ProtoBridgeField sch name) fs - => NP (Field sch) fs -> PBEnc.MessageBuilder + where go :: forall fs. All (ProtoBridgeField w sch name) fs + => NP (Field w sch) fs -> PBEnc.MessageBuilder go Nil = mempty - go (f :* fs) = fieldToProto @_ @_ @sch @name f <> go fs - protoToTerm = TRecord <$> protoToFields @_ @_ @sch @name + go (f :* fs) = fieldToProto @_ @_ @w @sch @name f <> go fs + protoToTerm = TRecord <$> protoToFields @_ @_ @w @sch @name -class ProtoBridgeFields (sch :: Schema tn fn) (ty :: tn) (fields :: [FieldDef tn fn]) where - protoToFields :: PBDec.Parser PBDec.RawMessage (NP (Field sch) fields) -instance ProtoBridgeFields sch ty '[] where +class ProtoBridgeFields (w :: * -> *) (sch :: Schema tn fn) (ty :: tn) (fields :: [FieldDef tn fn]) where + protoToFields :: PBDec.Parser PBDec.RawMessage (NP (Field w sch) fields) +instance ProtoBridgeFields w sch ty '[] where protoToFields = pure Nil -instance (ProtoBridgeField sch ty f, ProtoBridgeFields sch ty fs) - => ProtoBridgeFields sch ty (f ': fs) where - protoToFields = (:*) <$> protoToField @_ @_ @sch @ty <*> protoToFields @_ @_ @sch @ty +instance (ProtoBridgeField w sch ty f, ProtoBridgeFields w sch ty fs) + => ProtoBridgeFields w sch ty (f ': fs) where + protoToFields = (:*) <$> protoToField @_ @_ @w @sch @ty <*> protoToFields @_ @_ @w @sch @ty -instance ProtoBridgeTerm sch ('DRecord name args) - => ProtoBridgeEmbedTerm sch ('DRecord name args) where +instance ProtoBridgeTerm w sch ('DRecord name args) + => ProtoBridgeEmbedTerm w sch ('DRecord name args) where termToEmbedProto fid v = PBEnc.embedded fid (termToProto v) embedProtoToFieldValue = do - t <- PBDec.embedded (protoToTerm @_ @_ @sch @('DRecord name args)) + t <- PBDec.embedded (protoToTerm @_ @_ @w @sch @('DRecord name args)) case t of Nothing -> PBDec.Parser (\_ -> Left (PBDec.WireTypeError "expected message")) Just v -> return v - embedProtoToOneFieldValue = PBDec.embedded' (protoToTerm @_ @_ @sch @('DRecord name args)) + embedProtoToOneFieldValue = PBDec.embedded' (protoToTerm @_ @_ @w @sch @('DRecord name args)) -- ENUMERATIONS -- ------------ instance TypeError ('Text "protobuf requires wrapping enums in a message") - => ProtoBridgeTerm sch ('DEnum name choices) where + => ProtoBridgeTerm w sch ('DEnum name choices) where termToProto = error "protobuf requires wrapping enums in a message" protoToTerm = error "protobuf requires wrapping enums in a message" instance ProtoBridgeEnum sch name choices - => ProtoBridgeEmbedTerm sch ('DEnum name choices) where + => ProtoBridgeEmbedTerm w sch ('DEnum name choices) where termToEmbedProto fid (TEnum v) = enumToProto @_ @_ @sch @name fid v embedProtoToFieldValue = do n <- PBDec.one PBDec.int32 0 TEnum <$> protoToEnum @_ @_ @sch @name n @@ -227,7 +228,7 @@ instance (KnownNat (FindProtoBufId sch ty c), ProtoBridgeEnum sch ty cs) -- ------ instance TypeError ('Text "protobuf requires wrapping primitives in a message") - => ProtoBridgeTerm sch ('DSimple t) where + => ProtoBridgeTerm w sch ('DSimple t) where termToProto = error "protobuf requires wrapping primitives in a message" protoToTerm = error "protobuf requires wrapping primitives in a message" @@ -236,18 +237,23 @@ instance TypeError ('Text "protobuf requires wrapping primitives in a message") -- --------- instance {-# OVERLAPPABLE #-} - (ProtoBridgeFieldValue sch t, KnownNat (FindProtoBufId sch ty name)) - => ProtoBridgeField sch ty ('FieldDef name t) where - fieldToProto (Field v) = fieldValueToProto fieldId v + (MaybeLike w, Alternative w, ProtoBridgeFieldValue w sch t, KnownNat (FindProtoBufId sch ty name)) + => ProtoBridgeField w sch ty ('FieldDef name t) where + fieldToProto (Field (likeMaybe -> Just v)) = fieldValueToProto fieldId v where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name)) - protoToField = Field <$> protoToFieldValue `at` fieldId + fieldToProto (Field _) = mempty + protoToField = Field <$> ((pure <$> protoToFieldValue `at` fieldId) <|> pure empty) where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name)) instance {-# OVERLAPS #-} - (ProtoBridgeUnionFieldValue (FindProtoBufOneOfIds sch ty name) sch ts) - => ProtoBridgeField sch ty ('FieldDef name ('TUnion ts)) where - fieldToProto (Field (FUnion v)) = unionFieldValueToProto @_ @_ @(FindProtoBufOneOfIds sch ty name) v - protoToField = Field . FUnion <$> protoToUnionFieldValue @_ @_ @(FindProtoBufOneOfIds sch ty name) + (MaybeLike w, Alternative w, ProtoBridgeUnionFieldValue w (FindProtoBufOneOfIds sch ty name) sch ts) + => ProtoBridgeField w sch ty ('FieldDef name ('TUnion ts)) where + fieldToProto (Field (likeMaybe -> Just (FUnion v))) + = unionFieldValueToProto @_ @_ @w @(FindProtoBufOneOfIds sch ty name) v + fieldToProto (Field _) = mempty + protoToField + = Field . pure . FUnion <$> protoToUnionFieldValue @_ @_ @w @(FindProtoBufOneOfIds sch ty name) + <|> pure (Field empty) -- ------------------ -- TYPES OF FIELDS -- @@ -256,130 +262,130 @@ instance {-# OVERLAPS #-} -- SCHEMATIC -- --------- -instance ProtoBridgeEmbedTerm sch (sch :/: t) - => ProtoBridgeFieldValue sch ('TSchematic t) where +instance ProtoBridgeEmbedTerm w sch (sch :/: t) + => ProtoBridgeFieldValue w sch ('TSchematic t) where fieldValueToProto fid (FSchematic v) = termToEmbedProto fid v protoToFieldValue = FSchematic <$> embedProtoToFieldValue -instance ProtoBridgeEmbedTerm sch (sch :/: t) - => ProtoBridgeOneFieldValue sch ('TSchematic t) where +instance ProtoBridgeEmbedTerm w sch (sch :/: t) + => ProtoBridgeOneFieldValue w sch ('TSchematic t) where protoToOneFieldValue = FSchematic <$> embedProtoToOneFieldValue -- PRIMITIVE TYPES -- --------------- instance TypeError ('Text "null cannot be converted to protobuf") - => ProtoBridgeFieldValue sch 'TNull where + => ProtoBridgeFieldValue w sch 'TNull where fieldValueToProto = error "null cannot be converted to protobuf" protoToFieldValue = error "null cannot be converted to protobuf" instance TypeError ('Text "null cannot be converted to protobuf") - => ProtoBridgeOneFieldValue sch 'TNull where + => ProtoBridgeOneFieldValue w sch 'TNull where protoToOneFieldValue = error "null cannot be converted to protobuf" -instance ProtoBridgeFieldValue sch ('TPrimitive Int) where +instance ProtoBridgeFieldValue w sch ('TPrimitive Int) where fieldValueToProto fid (FPrimitive n) = PBEnc.int32 fid (fromIntegral n) protoToFieldValue = FPrimitive . fromIntegral <$> PBDec.one PBDec.int32 0 -instance ProtoBridgeOneFieldValue sch ('TPrimitive Int) where +instance ProtoBridgeOneFieldValue w sch ('TPrimitive Int) where protoToOneFieldValue = FPrimitive . fromIntegral <$> PBDec.int32 -instance ProtoBridgeFieldValue sch ('TPrimitive Int32) where +instance ProtoBridgeFieldValue w sch ('TPrimitive Int32) where fieldValueToProto fid (FPrimitive n) = PBEnc.int32 fid n protoToFieldValue = FPrimitive <$> PBDec.one PBDec.int32 0 -instance ProtoBridgeOneFieldValue sch ('TPrimitive Int32) where +instance ProtoBridgeOneFieldValue w sch ('TPrimitive Int32) where protoToOneFieldValue = FPrimitive <$> PBDec.int32 -instance ProtoBridgeFieldValue sch ('TPrimitive Int64) where +instance ProtoBridgeFieldValue w sch ('TPrimitive Int64) where fieldValueToProto fid (FPrimitive n) = PBEnc.int64 fid n protoToFieldValue = FPrimitive <$> PBDec.one PBDec.int64 0 -instance ProtoBridgeOneFieldValue sch ('TPrimitive Int64) where +instance ProtoBridgeOneFieldValue w sch ('TPrimitive Int64) where protoToOneFieldValue = FPrimitive <$> PBDec.int64 -- WARNING! These instances may go out of bounds -instance ProtoBridgeFieldValue sch ('TPrimitive Integer) where +instance ProtoBridgeFieldValue w sch ('TPrimitive Integer) where fieldValueToProto fid (FPrimitive n) = PBEnc.int64 fid (fromInteger n) protoToFieldValue = FPrimitive . fromIntegral <$> PBDec.one PBDec.int64 0 -instance ProtoBridgeOneFieldValue sch ('TPrimitive Integer) where +instance ProtoBridgeOneFieldValue w sch ('TPrimitive Integer) where protoToOneFieldValue = FPrimitive . fromIntegral <$> PBDec.int64 -instance ProtoBridgeFieldValue sch ('TPrimitive Float) where +instance ProtoBridgeFieldValue w sch ('TPrimitive Float) where fieldValueToProto fid (FPrimitive n) = PBEnc.float fid n protoToFieldValue = FPrimitive <$> PBDec.one PBDec.float 0 -instance ProtoBridgeOneFieldValue sch ('TPrimitive Float) where +instance ProtoBridgeOneFieldValue w sch ('TPrimitive Float) where protoToOneFieldValue = FPrimitive <$> PBDec.float -instance ProtoBridgeFieldValue sch ('TPrimitive Double) where +instance ProtoBridgeFieldValue w sch ('TPrimitive Double) where fieldValueToProto fid (FPrimitive n) = PBEnc.double fid n protoToFieldValue = FPrimitive <$> PBDec.one PBDec.double 0 -instance ProtoBridgeOneFieldValue sch ('TPrimitive Double) where +instance ProtoBridgeOneFieldValue w sch ('TPrimitive Double) where protoToOneFieldValue = FPrimitive <$> PBDec.double -instance ProtoBridgeFieldValue sch ('TPrimitive Bool) where +instance ProtoBridgeFieldValue w sch ('TPrimitive Bool) where fieldValueToProto fid (FPrimitive n) = PBEnc.enum fid n protoToFieldValue = FPrimitive <$> PBDec.one PBDec.bool False -instance ProtoBridgeOneFieldValue sch ('TPrimitive Bool) where +instance ProtoBridgeOneFieldValue w sch ('TPrimitive Bool) where protoToOneFieldValue = FPrimitive <$> PBDec.bool -instance ProtoBridgeFieldValue sch ('TPrimitive T.Text) where +instance ProtoBridgeFieldValue w sch ('TPrimitive T.Text) where fieldValueToProto fid (FPrimitive n) = PBEnc.text fid (LT.fromStrict n) protoToFieldValue = FPrimitive . LT.toStrict <$> PBDec.one PBDec.text "" -instance ProtoBridgeOneFieldValue sch ('TPrimitive T.Text) where +instance ProtoBridgeOneFieldValue w sch ('TPrimitive T.Text) where protoToOneFieldValue = FPrimitive . LT.toStrict <$> PBDec.text -instance ProtoBridgeFieldValue sch ('TPrimitive LT.Text) where +instance ProtoBridgeFieldValue w sch ('TPrimitive LT.Text) where fieldValueToProto fid (FPrimitive n) = PBEnc.text fid n protoToFieldValue = FPrimitive <$> PBDec.one PBDec.text "" -instance ProtoBridgeOneFieldValue sch ('TPrimitive LT.Text) where +instance ProtoBridgeOneFieldValue w sch ('TPrimitive LT.Text) where protoToOneFieldValue = FPrimitive <$> PBDec.text -instance ProtoBridgeFieldValue sch ('TPrimitive BS.ByteString) where +instance ProtoBridgeFieldValue w sch ('TPrimitive BS.ByteString) where fieldValueToProto fid (FPrimitive n) = PBEnc.byteString fid n protoToFieldValue = FPrimitive <$> PBDec.one PBDec.byteString "" -instance ProtoBridgeOneFieldValue sch ('TPrimitive BS.ByteString) where +instance ProtoBridgeOneFieldValue w sch ('TPrimitive BS.ByteString) where protoToOneFieldValue = FPrimitive <$> PBDec.byteString -- Note that Maybes and Lists require that we recur on the OneFieldValue class -instance (ProtoBridgeFieldValue sch t, ProtoBridgeOneFieldValue sch t) - => ProtoBridgeFieldValue sch ('TOption t) where +instance (ProtoBridgeFieldValue w sch t, ProtoBridgeOneFieldValue w sch t) + => ProtoBridgeFieldValue w sch ('TOption t) where fieldValueToProto _ (FOption Nothing) = mempty fieldValueToProto fid (FOption (Just v)) = fieldValueToProto fid v protoToFieldValue = FOption <$> PBDec.one (Just <$> protoToOneFieldValue) Nothing instance TypeError ('Text "optionals cannot be nested in protobuf") - => ProtoBridgeOneFieldValue sch ('TOption t) where + => ProtoBridgeOneFieldValue w sch ('TOption t) where protoToOneFieldValue = error "optionals cannot be nested in protobuf" -instance (ProtoBridgeFieldValue sch t, ProtoBridgeOneFieldValue sch t) - => ProtoBridgeFieldValue sch ('TList t) where +instance (ProtoBridgeFieldValue w sch t, ProtoBridgeOneFieldValue w sch t) + => ProtoBridgeFieldValue w sch ('TList t) where fieldValueToProto fid (FList xs) = foldMap (fieldValueToProto fid) xs protoToFieldValue = FList <$> PBDec.repeated protoToOneFieldValue instance TypeError ('Text "lists cannot be nested in protobuf") - => ProtoBridgeOneFieldValue sch ('TList t) where + => ProtoBridgeOneFieldValue w sch ('TList t) where protoToOneFieldValue = error "lists cannot be nested in protobuf" instance TypeError ('Text "maps are not currently supported") - => ProtoBridgeFieldValue sch ('TMap k v) where + => ProtoBridgeFieldValue w sch ('TMap k v) where fieldValueToProto = error "maps are not currently supported" protoToFieldValue = error "maps are not currently supported" instance TypeError ('Text "nested unions are not currently supported") - => ProtoBridgeFieldValue sch ('TUnion choices) where + => ProtoBridgeFieldValue w sch ('TUnion choices) where fieldValueToProto = error "nested unions are not currently supported" protoToFieldValue = error "nested unions are not currently supported" -- UNIONS -- ------ -instance ProtoBridgeUnionFieldValue ids sch '[] where +instance ProtoBridgeUnionFieldValue w ids sch '[] where unionFieldValueToProto = error "empty list of unions" protoToUnionFieldValue = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "unknown type in an union")) -instance ( ProtoBridgeFieldValue sch t, KnownNat thisId - , ProtoBridgeUnionFieldValue restIds sch ts ) - => ProtoBridgeUnionFieldValue (thisId ': restIds) sch (t ': ts) where +instance ( ProtoBridgeFieldValue w sch t, KnownNat thisId + , ProtoBridgeUnionFieldValue w restIds sch ts ) + => ProtoBridgeUnionFieldValue w (thisId ': restIds) sch (t ': ts) where unionFieldValueToProto (Z v) = fieldValueToProto fieldId v where fieldId = fromInteger $ natVal (Proxy @thisId) - unionFieldValueToProto (S v) = unionFieldValueToProto @_ @_ @restIds v + unionFieldValueToProto (S v) = unionFieldValueToProto @_ @_ @w @restIds v protoToUnionFieldValue - = Z <$> protoToFieldValue `at` fieldId <|> S <$> protoToUnionFieldValue @_ @_ @restIds + = Z <$> protoToFieldValue `at` fieldId <|> S <$> protoToUnionFieldValue @_ @_ @w @restIds where fieldId = fromInteger $ natVal (Proxy @thisId) diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs index e7e94ba8..b9f1ccd2 100644 --- a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs @@ -17,29 +17,43 @@ import Mu.Adapter.ProtoBuf import Mu.Rpc import Mu.Schema -newtype ViaProtoBufTypeRef (ref :: TypeRef) t - = ViaProtoBufTypeRef { unViaProtoBufTypeRef :: t } - -instance ProtoBufTypeRef ref t - => Proto3WireEncoder (ViaProtoBufTypeRef ref t) where - proto3WireEncode = toProtoBufTypeRef (Proxy @ref) . unViaProtoBufTypeRef - proto3WireDecode = ViaProtoBufTypeRef <$> fromProtoBufTypeRef (Proxy @ref) +newtype ViaToProtoBufTypeRef (ref :: TypeRef) t + = ViaToProtoBufTypeRef { unViaToProtoBufTypeRef :: t } +newtype ViaFromProtoBufTypeRef (ref :: TypeRef) t + = ViaFromProtoBufTypeRef { unViaFromProtoBufTypeRef :: t } + +instance ToProtoBufTypeRef ref t + => Proto3WireEncoder (ViaToProtoBufTypeRef ref t) where + proto3WireEncode = toProtoBufTypeRef (Proxy @ref) . unViaToProtoBufTypeRef + proto3WireDecode = error "this should never be called, use FromProtoBufTypeRef" +instance FromProtoBufTypeRef ref t + => Proto3WireEncoder (ViaFromProtoBufTypeRef ref t) where + proto3WireEncode = error "this should never be called, use ToProtoBufTypeRef" + proto3WireDecode = ViaFromProtoBufTypeRef <$> fromProtoBufTypeRef (Proxy @ref) instance Proto3WireEncoder () where proto3WireEncode _ = mempty proto3WireDecode = return () -class ProtoBufTypeRef (ref :: TypeRef) t where +class FromProtoBufTypeRef (ref :: TypeRef) t where fromProtoBufTypeRef :: Proxy ref -> PBDec.Parser PBDec.RawMessage t +class ToProtoBufTypeRef (ref :: TypeRef) t where toProtoBufTypeRef :: Proxy ref -> t -> PBEnc.MessageBuilder -instance (HasProtoSchema sch sty t) - => ProtoBufTypeRef ('FromSchema sch sty) t where +instance (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty t) + => FromProtoBufTypeRef ('ViaSchema sch sty) t where fromProtoBufTypeRef _ = fromProtoViaSchema @_ @_ @sch +instance (IsProtoSchema Maybe sch sty, ToSchema Maybe sch sty t) + => ToProtoBufTypeRef ('ViaSchema sch sty) t where toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @sch instance ( FromProtoBufRegistry r t - , HasProtoSchema (MappingRight r last) sty t) - => ProtoBufTypeRef ('FromRegistry r t last) t where + , IsProtoSchema Maybe (MappingRight r last) sty + , FromSchema Maybe (MappingRight r last) sty t ) + => FromProtoBufTypeRef ('ViaRegistry r t last) t where fromProtoBufTypeRef _ = fromProtoBufWithRegistry @r +instance ( FromProtoBufRegistry r t + , IsProtoSchema Maybe (MappingRight r last) sty + , ToSchema Maybe (MappingRight r last) sty t ) + => ToProtoBufTypeRef ('ViaRegistry r t last) t where toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @(MappingRight r last) diff --git a/adapter/protobuf/src/Mu/Quasi/GRpc.hs b/adapter/protobuf/src/Mu/Quasi/GRpc.hs index 109ab7c5..7991b8b2 100644 --- a/adapter/protobuf/src/Mu/Quasi/GRpc.hs +++ b/adapter/protobuf/src/Mu/Quasi/GRpc.hs @@ -76,18 +76,18 @@ pbMethodToType s (P.Method nm vr v rr r _) argToType P.Single (P.TOther ["google","protobuf","Empty"]) = [t| '[ ] |] argToType P.Single (P.TOther a) - = [t| '[ 'ArgSingle ('FromSchema $(schemaTy s) $(textToStrLit (last a))) ] |] + = [t| '[ 'ArgSingle ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |] argToType P.Stream (P.TOther a) - = [t| '[ 'ArgStream ('FromSchema $(schemaTy s) $(textToStrLit (last a))) ] |] + = [t| '[ 'ArgStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |] argToType _ _ = fail "only message types may be used as arguments" retToType P.Single (P.TOther ["google","protobuf","Empty"]) = [t| 'RetNothing |] retToType P.Single (P.TOther a) - = [t| 'RetSingle ('FromSchema $(schemaTy s) $(textToStrLit (last a))) |] + = [t| 'RetSingle ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |] retToType P.Stream (P.TOther a) - = [t| 'RetStream ('FromSchema $(schemaTy s) $(textToStrLit (last a))) |] + = [t| 'RetStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |] retToType _ _ = fail "only message types may be used as results" diff --git a/adapter/protobuf/test/ProtoBuf.hs b/adapter/protobuf/test/ProtoBuf.hs index 6dea6201..843fec6c 100644 --- a/adapter/protobuf/test/ProtoBuf.hs +++ b/adapter/protobuf/test/ProtoBuf.hs @@ -1,4 +1,7 @@ {-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingStrategies #-} {-# language OverloadedStrings #-} {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} @@ -7,6 +10,8 @@ module Main where import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS +import qualified Data.Text as T +import GHC.Generics import qualified Proto3.Wire.Decode as PBDec import qualified Proto3.Wire.Encode as PBEnc import System.Environment @@ -15,6 +20,23 @@ import Mu.Adapter.ProtoBuf import Mu.Schema import Mu.Schema.Examples +data MPerson + = MPerson { firstName :: Maybe T.Text + , lastName :: Maybe T.Text + , age :: Maybe (Maybe Int) + , gender :: Maybe (Maybe Gender) + , address :: Maybe MAddress } + deriving (Eq, Show, Generic) + deriving (ToSchema Maybe ExampleSchema "person") + deriving (FromSchema Maybe ExampleSchema "person") + +data MAddress + = MAddress { postcode :: Maybe T.Text + , country :: Maybe T.Text } + deriving (Eq, Show, Generic) + deriving (ToSchema Maybe ExampleSchema "address") + deriving (FromSchema Maybe ExampleSchema "address") + type instance AnnotatedSchema ProtoBufAnnotation ExampleSchema = '[ 'AnnField "gender" "male" ('ProtoBufId 1) , 'AnnField "gender" "female" ('ProtoBufId 2) @@ -27,12 +49,16 @@ type instance AnnotatedSchema ProtoBufAnnotation ExampleSchema , 'AnnField "person" "gender" ('ProtoBufId 4) , 'AnnField "person" "address" ('ProtoBufId 5) ] -exampleAddress :: Address -exampleAddress = Address "1111BB" "Spain" +exampleAddress :: MAddress +exampleAddress = MAddress (Just "1111BB") (Just "Spain") -examplePerson1, examplePerson2 :: Person -examplePerson1 = Person "Haskellio" "Gómez" (Just 30) (Just Male) exampleAddress -examplePerson2 = Person "Cuarenta" "Siete" Nothing Nothing exampleAddress +examplePerson1, examplePerson2 :: MPerson +examplePerson1 = MPerson (Just "Haskellio") (Just "Gómez") + (Just $ Just 30) (Just $ Just Male) + (Just exampleAddress) +examplePerson2 = MPerson (Just "Cuarenta") (Just "Siete") + (Just Nothing) (Just Nothing) + (Just exampleAddress) main :: IO () main = do -- Obtain the filenames @@ -41,7 +67,7 @@ main = do -- Obtain the filenames putStrLn "haskell/consume" cbs <- BS.readFile conFile let Right people = PBDec.parse (fromProtoViaSchema @_ @_ @ExampleSchema) cbs - print (people :: Person) + print (people :: MPerson) -- Encode a couple of values putStrLn "haskell/generate" print examplePerson1 diff --git a/core/rpc/src/Mu/Rpc.hs b/core/rpc/src/Mu/Rpc.hs index a300f19d..c8679252 100644 --- a/core/rpc/src/Mu/Rpc.hs +++ b/core/rpc/src/Mu/Rpc.hs @@ -53,11 +53,11 @@ type family LookupMethod (s :: [Method mnm]) (m :: snm) :: Method snm where -- | Defines how to handle the type data TypeRef where - FromSchema :: Schema typeName fieldName -> typeName -> TypeRef + ViaSchema :: Schema typeName fieldName -> typeName -> TypeRef -- | Registry subject, type to convert to, and preferred serialization version - FromRegistry :: Registry -> Type -> Nat -> TypeRef + ViaRegistry :: Registry -> Type -> Nat -> TypeRef -- | To be used only during TH generation! - FromTH :: TH.Type -> TypeRef + ViaTH :: TH.Type -> TypeRef -- | Defines the way in which arguments are handled. data Argument where diff --git a/core/rpc/src/Mu/Rpc/Examples.hs b/core/rpc/src/Mu/Rpc/Examples.hs index 4aeedc88..2cb1aab6 100644 --- a/core/rpc/src/Mu/Rpc/Examples.hs +++ b/core/rpc/src/Mu/Rpc/Examples.hs @@ -8,13 +8,17 @@ {-# language OverloadedStrings #-} {-# language PartialTypeSignatures #-} {-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneDeriving #-} {-# language TypeFamilies #-} {-# language TypeOperators #-} +{-# language ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Mu.Rpc.Examples where import Data.Conduit import Data.Conduit.Combinators as C +import Data.Functor.MaybeLike import qualified Data.Text as T import GHC.Generics @@ -37,37 +41,44 @@ type QuickstartSchema type QuickStartService = 'Service "Greeter" '[Package "helloworld"] '[ 'Method "SayHello" '[] - '[ 'ArgSingle ('FromSchema QuickstartSchema "HelloRequest") ] - ('RetSingle ('FromSchema QuickstartSchema "HelloResponse")) + '[ 'ArgSingle ('ViaSchema QuickstartSchema "HelloRequest") ] + ('RetSingle ('ViaSchema QuickstartSchema "HelloResponse")) , 'Method "SayHi" '[] - '[ 'ArgSingle ('FromSchema QuickstartSchema "HiRequest")] - ('RetStream ('FromSchema QuickstartSchema "HelloResponse")) + '[ 'ArgSingle ('ViaSchema QuickstartSchema "HiRequest")] + ('RetStream ('ViaSchema QuickstartSchema "HelloResponse")) , 'Method "SayManyHellos" '[] - '[ 'ArgStream ('FromSchema QuickstartSchema "HelloRequest")] - ('RetStream ('FromSchema QuickstartSchema "HelloResponse")) ] + '[ 'ArgStream ('ViaSchema QuickstartSchema "HelloRequest")] + ('RetStream ('ViaSchema QuickstartSchema "HelloResponse")) ] -newtype HelloRequest = HelloRequest { name :: T.Text } - deriving (Generic, HasSchema QuickstartSchema "HelloRequest") -newtype HelloResponse = HelloResponse { message :: T.Text } - deriving (Generic, HasSchema QuickstartSchema "HelloResponse") -newtype HiRequest = HiRequest { number :: Int } - deriving (Generic, HasSchema QuickstartSchema "HiRequest") +newtype HelloRequest f = HelloRequest { name :: f T.Text } deriving (Generic) +deriving instance Functor f => ToSchema f QuickstartSchema "HelloRequest" (HelloRequest f) +deriving instance Functor f => FromSchema f QuickstartSchema "HelloRequest" (HelloRequest f) -quickstartServer :: (MonadServer m) => ServerT QuickStartService m _ +newtype HelloResponse f = HelloResponse { message :: f T.Text } deriving (Generic) +deriving instance Functor f => ToSchema f QuickstartSchema "HelloResponse" (HelloResponse f) +deriving instance Functor f => FromSchema f QuickstartSchema "HelloResponse" (HelloResponse f) + +newtype HiRequest f = HiRequest { number :: f Int } deriving (Generic) +deriving instance Functor f => ToSchema f QuickstartSchema "HiRequest" (HiRequest f) +deriving instance Functor f => FromSchema f QuickstartSchema "HiRequest" (HiRequest f) + +quickstartServer :: forall m f. + (MonadServer m, Applicative f, MaybeLike f) + => ServerT f QuickStartService m _ quickstartServer = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0) - where sayHello :: (Monad m) => HelloRequest -> m HelloResponse + where sayHello :: HelloRequest f -> m (HelloResponse f) sayHello (HelloRequest nm) - = return (HelloResponse ("hi, " <> nm)) - sayHi :: (MonadServer m) - => HiRequest - -> ConduitT HelloResponse Void m () + = return (HelloResponse (("hi, " <>) <$> nm)) + sayHi :: HiRequest f + -> ConduitT (HelloResponse f) Void m () -> m () - sayHi (HiRequest n) sink - = runConduit $ C.replicate n (HelloResponse "hi!") .| sink - sayManyHellos :: (MonadServer m) - => ConduitT () HelloRequest m () - -> ConduitT HelloResponse Void m () + sayHi (HiRequest (likeMaybe -> Just n)) sink + = runConduit $ C.replicate n (HelloResponse $ pure "hi!") .| sink + sayHi (HiRequest _) sink + = runConduit $ return () .| sink + sayManyHellos :: ConduitT () (HelloRequest f) m () + -> ConduitT (HelloResponse f) Void m () -> m () sayManyHellos source sink = runConduit $ source .| C.mapM sayHello .| sink diff --git a/core/rpc/src/Mu/Server.hs b/core/rpc/src/Mu/Server.hs index 76181d49..d0646486 100644 --- a/core/rpc/src/Mu/Server.hs +++ b/core/rpc/src/Mu/Server.hs @@ -47,7 +47,7 @@ import Mu.Schema -- | Constraint for monads that can be used as servers type MonadServer m = (MonadError ServerError m, MonadIO m) type ServerErrorIO = ExceptT ServerError IO -type ServerIO srv = ServerT srv ServerErrorIO +type ServerIO w srv = ServerT w srv ServerErrorIO serverError :: (MonadError ServerError m) => ServerError -> m a @@ -70,37 +70,40 @@ data ServerErrorCode | NotFound deriving (Eq, Show) -data ServerT (s :: Service snm mnm) (m :: Type -> Type) (hs :: [Type]) where - Server :: HandlersT methods m hs -> ServerT ('Service sname anns methods) m hs +data ServerT (w :: Type -> Type) (s :: Service snm mnm) (m :: Type -> Type) (hs :: [Type]) where + Server :: HandlersT w methods m hs -> ServerT w ('Service sname anns methods) m hs infixr 5 :<|>: -data HandlersT (methods :: [Method mnm]) (m :: Type -> Type) (hs :: [Type]) where - H0 :: HandlersT '[] m '[] - (:<|>:) :: Handles args ret m h => h -> HandlersT ms m hs - -> HandlersT ('Method name anns args ret ': ms) m (h ': hs) +data HandlersT (w :: Type -> Type) (methods :: [Method mnm]) (m :: Type -> Type) (hs :: [Type]) where + H0 :: HandlersT w '[] m '[] + (:<|>:) :: Handles w args ret m h => h -> HandlersT w ms m hs + -> HandlersT w ('Method name anns args ret ': ms) m (h ': hs) -- Define a relation for handling -class Handles (args :: [Argument]) (ret :: Return) +class Handles (w :: Type -> Type) (args :: [Argument]) (ret :: Return) (m :: Type -> Type) (h :: Type) -class HandlesRef (ref :: TypeRef) (t :: Type) +class ToRef (w :: Type -> Type) (ref :: TypeRef) (t :: Type) +class FromRef (w :: Type -> Type) (ref :: TypeRef) (t :: Type) -- Type references -instance HasSchema sch sty t => HandlesRef ('FromSchema sch sty) t -instance HandlesRef ('FromRegistry subject t last) t +instance ToSchema w sch sty t => ToRef w ('ViaSchema sch sty) t +instance ToRef w ('ViaRegistry subject t last) t +instance FromSchema w sch sty t => FromRef w ('ViaSchema sch sty) t +instance FromRef w ('ViaRegistry subject t last) t -- Arguments -instance (HandlesRef ref t, Handles args ret m h, +instance (FromRef w ref t, Handles w args ret m h, handler ~ (t -> h)) - => Handles ('ArgSingle ref ': args) ret m handler -instance (MonadError ServerError m, HandlesRef ref t, Handles args ret m h, + => Handles w ('ArgSingle ref ': args) ret m handler +instance (MonadError ServerError m, FromRef w ref t, Handles w args ret m h, handler ~ (ConduitT () t m () -> h)) - => Handles ('ArgStream ref ': args) ret m handler + => Handles w ('ArgStream ref ': args) ret m handler -- Result with exception instance (MonadError ServerError m, handler ~ m ()) - => Handles '[] 'RetNothing m handler -instance (MonadError ServerError m, HandlesRef eref e, HandlesRef vref v, handler ~ m (Either e v)) - => Handles '[] ('RetThrows eref vref) m handler -instance (MonadError ServerError m, HandlesRef ref v, handler ~ m v) - => Handles '[] ('RetSingle ref) m handler -instance (MonadError ServerError m, HandlesRef ref v, handler ~ (ConduitT v Void m () -> m ())) - => Handles '[] ('RetStream ref) m handler + => Handles w '[] 'RetNothing m handler +instance (MonadError ServerError m, ToRef w eref e, ToRef w vref v, handler ~ m (Either e v)) + => Handles w '[] ('RetThrows eref vref) m handler +instance (MonadError ServerError m, ToRef w ref v, handler ~ m v) + => Handles w '[] ('RetSingle ref) m handler +instance (MonadError ServerError m, ToRef w ref v, handler ~ (ConduitT v Void m () -> m ())) + => Handles w '[] ('RetStream ref) m handler diff --git a/core/schema/mu-schema.cabal b/core/schema/mu-schema.cabal index d4eca225..112d516f 100644 --- a/core/schema/mu-schema.cabal +++ b/core/schema/mu-schema.cabal @@ -30,6 +30,7 @@ library , Mu.Schema.Examples , Mu.Schema.Annotations , Mu.Adapter.Json + , Data.Functor.MaybeLike -- other-modules: -- other-extensions: build-depends: base >=4.12 && <5 diff --git a/core/schema/src/Data/Functor/MaybeLike.hs b/core/schema/src/Data/Functor/MaybeLike.hs new file mode 100644 index 00000000..9ce749ce --- /dev/null +++ b/core/schema/src/Data/Functor/MaybeLike.hs @@ -0,0 +1,14 @@ +module Data.Functor.MaybeLike where + +import Data.Functor.Identity + +class MaybeLike f where + likeMaybe :: f a -> Maybe a + +instance MaybeLike Identity where + likeMaybe = Just . runIdentity +instance MaybeLike Maybe where + likeMaybe = id +instance MaybeLike (Either a) where + likeMaybe (Left _) = Nothing + likeMaybe (Right y) = Just y diff --git a/core/schema/src/Mu/Adapter/Json.hs b/core/schema/src/Mu/Adapter/Json.hs index 876b6083..df3134b6 100644 --- a/core/schema/src/Mu/Adapter/Json.hs +++ b/core/schema/src/Mu/Adapter/Json.hs @@ -15,21 +15,21 @@ import Control.Applicative ((<|>)) import Data.Aeson import Data.Aeson.Types import Data.Functor.Contravariant +import Data.Functor.Identity import qualified Data.HashMap.Strict as HM -import Data.SOP (NP (..), NS (..)) import qualified Data.Text as T import qualified Data.Vector as V import Mu.Schema import qualified Mu.Schema.Interpretation.Schemaless as SLess -instance SLess.ToSchemalessTerm Value where +instance Applicative w => SLess.ToSchemalessTerm Value w where toSchemalessTerm (Object o) - = SLess.TRecord $ map (\(k,v) -> SLess.Field k (SLess.toSchemalessValue v)) + = SLess.TRecord $ map (\(k,v) -> SLess.Field k (pure $ SLess.toSchemalessValue v)) $ HM.toList o toSchemalessTerm v = SLess.TSimple (SLess.toSchemalessValue v) -instance SLess.ToSchemalessValue Value where +instance Applicative w => SLess.ToSchemalessValue Value w where toSchemalessValue r@(Object _) = SLess.FSchematic (SLess.toSchemalessTerm r) toSchemalessValue Null = SLess.FNull @@ -39,41 +39,41 @@ instance SLess.ToSchemalessValue Value where toSchemalessValue (Array xs) = SLess.FList $ map SLess.toSchemalessValue $ V.toList xs -instance (HasSchema sch sty a, ToJSON (Term sch (sch :/: sty))) - => ToJSON (WithSchema sch sty a) where - toJSON (WithSchema x) = toJSON (toSchema' @sch x) -instance (HasSchema sch sty a, FromJSON (Term sch (sch :/: sty))) - => FromJSON (WithSchema sch sty a) where - parseJSON v = WithSchema . fromSchema' @sch <$> parseJSON v +instance (ToSchema w sch sty a, ToJSON (Term w sch (sch :/: sty))) + => ToJSON (WithSchema w sch sty a) where + toJSON (WithSchema x) = toJSON (toSchema' @_ @_ @sch @w x) +instance (FromSchema w sch sty a, FromJSON (Term w sch (sch :/: sty))) + => FromJSON (WithSchema w sch sty a) where + parseJSON v = WithSchema . fromSchema' @_ @_ @sch @w <$> parseJSON v -instance ToJSONFields sch args => ToJSON (Term sch ('DRecord name args)) where +instance ToJSONFields sch args => ToJSON (Term Identity sch ('DRecord name args)) where toJSON (TRecord fields) = Object (toJSONFields fields) -instance FromJSONFields sch args => FromJSON (Term sch ('DRecord name args)) where +instance FromJSONFields w sch args => FromJSON (Term w sch ('DRecord name args)) where parseJSON (Object v) = TRecord <$> parseJSONFields v parseJSON _ = fail "expected object" class ToJSONFields sch fields where - toJSONFields :: NP (Field sch) fields -> Object + toJSONFields :: NP (Field Identity sch) fields -> Object instance ToJSONFields sch '[] where toJSONFields _ = HM.empty -instance (KnownName name, ToJSON (FieldValue sch t), ToJSONFields sch fs) +instance (KnownName name, ToJSON (FieldValue Identity sch t), ToJSONFields sch fs) => ToJSONFields sch ('FieldDef name t ': fs) where - toJSONFields (Field v :* rest) = HM.insert key value (toJSONFields rest) + toJSONFields (Field (Identity v) :* rest) = HM.insert key value $ toJSONFields rest where key = T.pack (nameVal (Proxy @name)) value = toJSON v -class FromJSONFields sch fields where - parseJSONFields :: Object -> Parser (NP (Field sch) fields) -instance FromJSONFields sch '[] where +class FromJSONFields w sch fields where + parseJSONFields :: Object -> Parser (NP (Field w sch) fields) +instance FromJSONFields w sch '[] where parseJSONFields _ = return Nil -instance (KnownName name, FromJSON (FieldValue sch t), FromJSONFields sch fs) - => FromJSONFields sch ('FieldDef name t ': fs) where - parseJSONFields v = (:*) <$> (Field <$> v .: key) <*> parseJSONFields v +instance (Applicative w, KnownName name, FromJSON (FieldValue w sch t), FromJSONFields w sch fs) + => FromJSONFields w sch ('FieldDef name t ': fs) where + parseJSONFields v = (:*) <$> (Field <$> (pure <$> v .: key)) <*> parseJSONFields v where key = T.pack (nameVal (Proxy @name)) -instance ToJSONEnum choices => ToJSON (Term sch ('DEnum name choices)) where +instance ToJSONEnum choices => ToJSON (Term w sch ('DEnum name choices)) where toJSON (TEnum choice) = String (toJSONEnum choice) -instance FromJSONEnum choices => FromJSON (Term sch ('DEnum name choices)) where +instance FromJSONEnum choices => FromJSON (Term w sch ('DEnum name choices)) where parseJSON (String s) = TEnum <$> parseJSONEnum s parseJSON _ = fail "expected string" @@ -97,72 +97,72 @@ instance (KnownName c, FromJSONEnum cs) | otherwise = S <$> parseJSONEnum v where key = T.pack (nameVal (Proxy @c)) -instance ToJSON (FieldValue sch t) => ToJSON (Term sch ('DSimple t)) where +instance ToJSON (FieldValue w sch t) => ToJSON (Term w sch ('DSimple t)) where toJSON (TSimple x) = toJSON x -instance FromJSON (FieldValue sch t) => FromJSON (Term sch ('DSimple t)) where +instance FromJSON (FieldValue w sch t) => FromJSON (Term w sch ('DSimple t)) where parseJSON v = TSimple <$> parseJSON v -instance ToJSON (FieldValue sch 'TNull) where +instance ToJSON (FieldValue w sch 'TNull) where toJSON FNull = Null -instance ToJSON t => ToJSON (FieldValue sch ('TPrimitive t)) where +instance ToJSON t => ToJSON (FieldValue w sch ('TPrimitive t)) where toJSON (FPrimitive v) = toJSON v -instance ToJSONKey t => ToJSONKey (FieldValue sch ('TPrimitive t)) where +instance ToJSONKey t => ToJSONKey (FieldValue w sch ('TPrimitive t)) where toJSONKey = contramap FPrimitive toJSONKey toJSONKeyList = contramap (map FPrimitive) toJSONKeyList -instance ToJSON (Term sch (sch :/: t)) - => ToJSON (FieldValue sch ('TSchematic t)) where +instance ToJSON (Term w sch (sch :/: t)) + => ToJSON (FieldValue w sch ('TSchematic t)) where toJSON (FSchematic v) = toJSON v -instance ToJSON (FieldValue sch t) - => ToJSON (FieldValue sch ('TOption t)) where +instance ToJSON (FieldValue w sch t) + => ToJSON (FieldValue w sch ('TOption t)) where toJSON (FOption v) = toJSON v -instance ToJSON (FieldValue sch t) - => ToJSON (FieldValue sch ('TList t)) where +instance ToJSON (FieldValue w sch t) + => ToJSON (FieldValue w sch ('TList t)) where toJSON (FList v) = toJSON v -instance (ToJSONKey (FieldValue sch k), ToJSON (FieldValue sch v)) - => ToJSON (FieldValue sch ('TMap k v)) where +instance (ToJSONKey (FieldValue w sch k), ToJSON (FieldValue w sch v)) + => ToJSON (FieldValue w sch ('TMap k v)) where toJSON (FMap v) = toJSON v -instance (ToJSONUnion sch us) - => ToJSON (FieldValue sch ('TUnion us)) where +instance (ToJSONUnion w sch us) + => ToJSON (FieldValue w sch ('TUnion us)) where toJSON (FUnion v) = unionToJSON v -class ToJSONUnion sch us where - unionToJSON :: NS (FieldValue sch) us -> Value -instance ToJSONUnion sch '[] where +class ToJSONUnion w sch us where + unionToJSON :: NS (FieldValue w sch) us -> Value +instance ToJSONUnion w sch '[] where unionToJSON = error "this should never happen" -instance (ToJSON (FieldValue sch u), ToJSONUnion sch us) - => ToJSONUnion sch (u ': us) where +instance (ToJSON (FieldValue w sch u), ToJSONUnion w sch us) + => ToJSONUnion w sch (u ': us) where unionToJSON (Z v) = toJSON v unionToJSON (S r) = unionToJSON r -instance FromJSON (FieldValue sch 'TNull) where +instance FromJSON (FieldValue w sch 'TNull) where parseJSON Null = return FNull parseJSON _ = fail "expected null" -instance FromJSON t => FromJSON (FieldValue sch ('TPrimitive t)) where +instance FromJSON t => FromJSON (FieldValue w sch ('TPrimitive t)) where parseJSON v = FPrimitive <$> parseJSON v -instance FromJSONKey t => FromJSONKey (FieldValue sch ('TPrimitive t)) where +instance FromJSONKey t => FromJSONKey (FieldValue w sch ('TPrimitive t)) where fromJSONKey = fmap FPrimitive fromJSONKey fromJSONKeyList = fmap (map FPrimitive) fromJSONKeyList -instance FromJSON (Term sch (sch :/: t)) - => FromJSON (FieldValue sch ('TSchematic t)) where +instance FromJSON (Term w sch (sch :/: t)) + => FromJSON (FieldValue w sch ('TSchematic t)) where parseJSON v = FSchematic <$> parseJSON v -instance FromJSON (FieldValue sch t) - => FromJSON (FieldValue sch ('TOption t)) where +instance FromJSON (FieldValue w sch t) + => FromJSON (FieldValue w sch ('TOption t)) where parseJSON v = FOption <$> parseJSON v -instance FromJSON (FieldValue sch t) - => FromJSON (FieldValue sch ('TList t)) where +instance FromJSON (FieldValue w sch t) + => FromJSON (FieldValue w sch ('TList t)) where parseJSON v = FList <$> parseJSON v -instance ( FromJSONKey (FieldValue sch k), FromJSON (FieldValue sch v) - , Ord (FieldValue sch k) ) - => FromJSON (FieldValue sch ('TMap k v)) where +instance ( FromJSONKey (FieldValue w sch k), FromJSON (FieldValue w sch v) + , Ord (FieldValue w sch k) ) + => FromJSON (FieldValue w sch ('TMap k v)) where parseJSON v = FMap <$> parseJSON v -instance (FromJSONUnion sch us) - => FromJSON (FieldValue sch ('TUnion us)) where +instance (FromJSONUnion w sch us) + => FromJSON (FieldValue w sch ('TUnion us)) where parseJSON v = FUnion <$> unionFromJSON v -class FromJSONUnion sch us where - unionFromJSON :: Value -> Parser (NS (FieldValue sch) us) -instance FromJSONUnion sch '[] where +class FromJSONUnion w sch us where + unionFromJSON :: Value -> Parser (NS (FieldValue w sch) us) +instance FromJSONUnion w sch '[] where unionFromJSON _ = fail "value does not match any of the types of the union" -instance (FromJSON (FieldValue sch u), FromJSONUnion sch us) - => FromJSONUnion sch (u ': us) where +instance (FromJSON (FieldValue w sch u), FromJSONUnion w sch us) + => FromJSONUnion w sch (u ': us) where unionFromJSON v = Z <$> parseJSON v <|> S <$> unionFromJSON v diff --git a/core/schema/src/Mu/Schema.hs b/core/schema/src/Mu/Schema.hs index 87926d11..44dbd2a7 100644 --- a/core/schema/src/Mu/Schema.hs +++ b/core/schema/src/Mu/Schema.hs @@ -14,7 +14,10 @@ module Mu.Schema ( , Term(..), Field(..), FieldValue(..) , NS(..), NP(..), Proxy(..) -- * Conversion from types to schemas -, WithSchema(..), HasSchema(..), toSchema', fromSchema' +, WithSchema(..) +, FromSchema(..), fromSchema' +, ToSchema(..), toSchema' +, CustomFieldMapping(..) -- ** Mappings between fields , Mapping(..), Mappings, MappingRight, MappingLeft -- ** Field annotations diff --git a/core/schema/src/Mu/Schema/Class.hs b/core/schema/src/Mu/Schema/Class.hs index 6a42676d..3afe9623 100644 --- a/core/schema/src/Mu/Schema/Class.hs +++ b/core/schema/src/Mu/Schema/Class.hs @@ -5,6 +5,8 @@ {-# language FunctionalDependencies #-} {-# language GADTs #-} {-# language PolyKinds #-} +{-# language QuantifiedConstraints #-} +{-# language RankNTypes #-} {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} {-# language TypeFamilies #-} @@ -12,10 +14,17 @@ {-# language UndecidableInstances #-} -- | Conversion from types to schemas module Mu.Schema.Class ( - WithSchema(..), HasSchema(..), fromSchema', toSchema' + WithSchema(..) +, FromSchema(..), fromSchema' +, ToSchema(..), toSchema' +, CustomFieldMapping(..) , Mapping(..), Mappings, MappingRight, MappingLeft +, transSchema + -- * Internal use only +, GToSchemaRecord(..) ) where +import Data.Functor.Identity import Data.Kind import Data.Map as M import Data.SOP @@ -27,51 +36,69 @@ import Mu.Schema.Interpretation -- | Tags a value with its schema. -- For usage with @deriving via@. -newtype WithSchema (sch :: Schema tn fn) (sty :: tn) a = WithSchema a +newtype WithSchema (w :: Type -> Type) (sch :: Schema tn fn) (sty :: tn) a = WithSchema a -- | Defines the conversion of a type @t@ into a 'Term' -- which follows the schema @sch@. --- The corresponding type is given by 'SchemaType', --- and you can give an optional mapping between the +-- You can give an optional mapping between the -- field names of @t@ and that of 'SchemaType' -- by means of 'FieldMapping'. -class HasSchema (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type) +class ToSchema (w :: Type -> Type) (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type) | sch t -> sty where - -- | Specifies the type of the schema to map. - -- type SchemaType sch t :: typeName - -- | Defines custom mapping between field names in - -- the Haskell type and the schema. Otherwise, - -- these names must coincide. - type FieldMapping sch sty t :: [Mapping Symbol fieldName] - type FieldMapping sch sty t = '[] -- | Conversion from Haskell type to schema term. - toSchema :: t -> Term sch (sch :/: sty) - -- | Conversion from schema term to Haskell type. - fromSchema :: Term sch (sch :/: sty) -> t + toSchema :: t -> Term w sch (sch :/: sty) default - toSchema :: ( Generic t - , GSchemaTypeDef sch (FieldMapping sch sty t) (sch :/: sty) (Rep t) ) - => t -> Term sch (sch :/: sty) - toSchema x = toSchemaTypeDef (Proxy @(FieldMapping sch sty t)) (from x) + toSchema :: (Generic t, GToSchemaTypeDef w sch '[] (sch :/: sty) (Rep t)) + => t -> Term w sch (sch :/: sty) + toSchema x = toSchemaTypeDef (Proxy @'[]) (from x) + +-- | Defines the conversion from a 'Term' +-- which follows the schema @sch@ into a type @t@. +-- You can give an optional mapping between the +-- field names of @t@ and that of 'SchemaType' +-- by means of 'FieldMapping'. +class FromSchema (w :: Type -> Type) (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type) + | sch t -> sty where + -- | Conversion from schema term to Haskell type. + fromSchema :: Term w sch (sch :/: sty) -> t default - fromSchema :: ( Generic t - , GSchemaTypeDef sch (FieldMapping sch sty t) (sch :/: sty) (Rep t) ) - => Term sch (sch :/: sty) -> t - fromSchema x = to (fromSchemaTypeDef (Proxy @(FieldMapping sch sty t)) x) + fromSchema :: (Generic t, GFromSchemaTypeDef w sch '[] (sch :/: sty) (Rep t) ) + => Term w sch (sch :/: sty) -> t + fromSchema x = to (fromSchemaTypeDef (Proxy @'[]) x) -- | Conversion from Haskell type to schema term. -- This version is intended for usage with @TypeApplications@: -- > toSchema' @MySchema myValue -toSchema' :: forall sch t sty. HasSchema sch sty t => t -> Term sch (sch :/: sty) +toSchema' :: forall fn tn (sch :: Schema tn fn) w t sty. + ToSchema w sch sty t => t -> Term w sch (sch :/: sty) toSchema' = toSchema -- | Conversion from schema term to Haskell type. -- This version is intended for usage with @TypeApplications@: -- > fromSchema' @MySchema mySchemaTerm -fromSchema' :: forall sch t sty. HasSchema sch sty t => Term sch (sch :/: sty) -> t +fromSchema' :: forall fn tn (sch :: Schema tn fn) w t sty. + FromSchema w sch sty t => Term w sch (sch :/: sty) -> t fromSchema' = fromSchema +newtype CustomFieldMapping (sty :: typeName) (fmap :: [Mapping Symbol fieldName]) a + = CustomFieldMapping a + +instance (Generic t, GToSchemaTypeDef w sch fmap (sch :/: sty) (Rep t)) + => ToSchema w sch sty (CustomFieldMapping sty fmap t) where + toSchema (CustomFieldMapping x) = toSchemaTypeDef (Proxy @fmap) (from x) + +instance (Generic t, GFromSchemaTypeDef w sch fmap (sch :/: sty) (Rep t)) + => FromSchema w sch sty (CustomFieldMapping sty fmap t) where + fromSchema x = CustomFieldMapping $ to (fromSchemaTypeDef (Proxy @fmap) x) + +transSchema + :: forall fn tn (sch :: Schema tn fn) sty u v a b. + ( ToSchema u sch sty a, FromSchema v sch sty b + , Functor u, forall k. Ord (FieldValue u sch k) => Ord (FieldValue v sch k) ) + => (forall x. u x -> v x) -> Proxy sch -> a -> b +transSchema f _ = fromSchema @_ @_ @v @sch @sty . transWrap f . toSchema @_ @_ @u @sch @sty + -- ====================== -- CRAZY GENERICS SECTION -- ====================== @@ -114,116 +141,169 @@ type family FindField (xs :: [FieldDef ts fs]) (x :: fs) :: Where where FindField (other ': xs) name = 'There (FindField xs name) -- Generic type definitions -class GSchemaTypeDef (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) - (t :: TypeDef ts fs) (f :: * -> *) where - toSchemaTypeDef :: Proxy fmap -> f a -> Term sch t - fromSchemaTypeDef :: Proxy fmap -> Term sch t -> f a +class GToSchemaTypeDef + (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) + (t :: TypeDef ts fs) (f :: * -> *) where + toSchemaTypeDef :: Proxy fmap -> f a -> Term w sch t +class GFromSchemaTypeDef + (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) + (t :: TypeDef ts fs) (f :: * -> *) where + fromSchemaTypeDef :: Proxy fmap -> Term w sch t -> f a -- ------------------ -- TYPES OF FIELDS -- -- ------------------ -instance GSchemaFieldTypeWrap sch t f - => GSchemaTypeDef sch fmap ('DSimple t) f where +instance GToSchemaFieldTypeWrap w sch t f + => GToSchemaTypeDef w sch fmap ('DSimple t) f where toSchemaTypeDef _ x = TSimple (toSchemaFieldTypeW x) +instance GFromSchemaFieldTypeWrap w sch t f + => GFromSchemaTypeDef w sch fmap ('DSimple t) f where fromSchemaTypeDef _ (TSimple x) = fromSchemaFieldTypeW x -class GSchemaFieldTypeWrap (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where - toSchemaFieldTypeW :: f a -> FieldValue sch t - fromSchemaFieldTypeW :: FieldValue sch t -> f a +class GToSchemaFieldTypeWrap + (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where + toSchemaFieldTypeW :: f a -> FieldValue w sch t +class GFromSchemaFieldTypeWrap + (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where + fromSchemaFieldTypeW :: FieldValue w sch t -> f a -instance GSchemaFieldType sch t f => GSchemaFieldTypeWrap sch t (K1 i f) where +instance GToSchemaFieldType w sch t f + => GToSchemaFieldTypeWrap w sch t (K1 i f) where toSchemaFieldTypeW (K1 x) = toSchemaFieldType x +instance GFromSchemaFieldType w sch t f + => GFromSchemaFieldTypeWrap w sch t (K1 i f) where fromSchemaFieldTypeW x = K1 (fromSchemaFieldType x) -instance GSchemaFieldTypeWrap sch t f => GSchemaFieldTypeWrap sch t (M1 s m f) where +instance GToSchemaFieldTypeWrap w sch t f + => GToSchemaFieldTypeWrap w sch t (M1 s m f) where toSchemaFieldTypeW (M1 x) = toSchemaFieldTypeW x +instance GFromSchemaFieldTypeWrap w sch t f + => GFromSchemaFieldTypeWrap w sch t (M1 s m f) where fromSchemaFieldTypeW x = M1 (fromSchemaFieldTypeW x) -class GSchemaFieldType (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where - toSchemaFieldType :: f -> FieldValue sch t - fromSchemaFieldType :: FieldValue sch t -> f +class GToSchemaFieldType + (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where + toSchemaFieldType :: f -> FieldValue w sch t +class GFromSchemaFieldType + (w :: * -> *) (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where + fromSchemaFieldType :: FieldValue w sch t -> f -class GSchemaFieldTypeUnion (sch :: Schema ts fs) (t :: [FieldType ts]) (f :: * -> *) where - toSchemaFieldTypeUnion :: f a -> NS (FieldValue sch) t - fromSchemaFieldTypeUnion :: NS (FieldValue sch) t -> f a +class GToSchemaFieldTypeUnion + (w :: * -> *) (sch :: Schema ts fs) (t :: [FieldType ts]) (f :: * -> *) where + toSchemaFieldTypeUnion :: f a -> NS (FieldValue w sch) t +class GFromSchemaFieldTypeUnion + (w :: * -> *) (sch :: Schema ts fs) (t :: [FieldType ts]) (f :: * -> *) where + fromSchemaFieldTypeUnion :: NS (FieldValue w sch) t -> f a -- These instances are straightforward, -- just turn the "real types" into their -- schema correspondants. -instance GSchemaFieldType sch 'TNull () where +instance GToSchemaFieldType w sch 'TNull () where toSchemaFieldType _ = FNull +instance GFromSchemaFieldType w sch 'TNull () where fromSchemaFieldType _ = () -instance GSchemaFieldType sch ('TPrimitive t) t where +instance GToSchemaFieldType w sch ('TPrimitive t) t where toSchemaFieldType = FPrimitive +instance GFromSchemaFieldType w sch ('TPrimitive t) t where fromSchemaFieldType (FPrimitive x) = x --- This instance "ties the loop" with the whole schema, --- and it the reason why we need to thread the @sch@ +-- These instances "tie the loop" with the whole schema, +-- and they are the reason why we need to thread the @sch@ -- type throghout the whole implementation. -instance HasSchema sch t v => GSchemaFieldType sch ('TSchematic t) v where +instance ToSchema w sch t v + => GToSchemaFieldType w sch ('TSchematic t) v where toSchemaFieldType x = FSchematic $ toSchema x +instance FromSchema w sch t v + => GFromSchemaFieldType w sch ('TSchematic t) v where fromSchemaFieldType (FSchematic x) = fromSchema x -instance GSchemaFieldType sch t v => GSchemaFieldType sch ('TOption t) (Maybe v) where +instance GToSchemaFieldType w sch t v + => GToSchemaFieldType w sch ('TOption t) (Maybe v) where toSchemaFieldType x = FOption (toSchemaFieldType <$> x) +instance GFromSchemaFieldType w sch t v + => GFromSchemaFieldType w sch ('TOption t) (Maybe v) where fromSchemaFieldType (FOption x) = fromSchemaFieldType <$> x -instance GSchemaFieldType sch t v => GSchemaFieldType sch ('TList t) [v] where +instance GToSchemaFieldType w sch t v + => GToSchemaFieldType w sch ('TList t) [v] where toSchemaFieldType x = FList (toSchemaFieldType <$> x) +instance GFromSchemaFieldType w sch t v + => GFromSchemaFieldType w sch ('TList t) [v] where fromSchemaFieldType (FList x) = fromSchemaFieldType <$> x -instance (GSchemaFieldType sch sk hk, GSchemaFieldType sch sv hv, - Ord (FieldValue sch sk), Ord hk) -- Ord is required to build a map - => GSchemaFieldType sch ('TMap sk sv) (M.Map hk hv) where +instance (GToSchemaFieldType w sch sk hk, GToSchemaFieldType w sch sv hv, + Ord (FieldValue w sch sk)) -- Ord is required to build a map + => GToSchemaFieldType w sch ('TMap sk sv) (M.Map hk hv) where toSchemaFieldType x = FMap (M.mapKeys toSchemaFieldType (M.map toSchemaFieldType x)) +instance (GFromSchemaFieldType w sch sk hk, GFromSchemaFieldType w sch sv hv, Ord hk) + => GFromSchemaFieldType w sch ('TMap sk sv) (M.Map hk hv) where fromSchemaFieldType (FMap x) = M.mapKeys fromSchemaFieldType (M.map fromSchemaFieldType x) -- This assumes that a union is represented by -- a value of type 'NS', where types are in -- the same order. instance {-# OVERLAPS #-} - AllZip (GSchemaFieldType sch) ts vs - => GSchemaFieldType sch ('TUnion ts) (NS I vs) where + AllZip (GToSchemaFieldType w sch) ts vs + => GToSchemaFieldType w sch ('TUnion ts) (NS I vs) where toSchemaFieldType t = FUnion (go t) - where go :: AllZip (GSchemaFieldType sch) tss vss - => NS I vss -> NS (FieldValue sch) tss + where go :: AllZip (GToSchemaFieldType w sch) tss vss + => NS I vss -> NS (FieldValue w sch) tss go (Z (I x)) = Z (toSchemaFieldType x) go (S n) = S (go n) +instance {-# OVERLAPS #-} + AllZip (GFromSchemaFieldType w sch) ts vs + => GFromSchemaFieldType w sch ('TUnion ts) (NS I vs) where fromSchemaFieldType (FUnion t) = go t - where go :: AllZip (GSchemaFieldType sch) tss vss - => NS (FieldValue sch) tss -> NS I vss + where go :: AllZip (GFromSchemaFieldType w sch) tss vss + => NS (FieldValue w sch) tss -> NS I vss go (Z x) = Z (I (fromSchemaFieldType x)) go (S n) = S (go n) -- But we can also use any other if it has -- the right structure instance {-# OVERLAPPABLE #-} - (Generic f, GSchemaFieldTypeUnion sch ts (Rep f)) - => GSchemaFieldType sch ('TUnion ts) f where + (Generic f, GToSchemaFieldTypeUnion w sch ts (Rep f)) + => GToSchemaFieldType w sch ('TUnion ts) f where toSchemaFieldType x = FUnion (toSchemaFieldTypeUnion (from x)) +instance {-# OVERLAPPABLE #-} + (Generic f, GFromSchemaFieldTypeUnion w sch ts (Rep f)) + => GFromSchemaFieldType w sch ('TUnion ts) f where fromSchemaFieldType (FUnion x) = to (fromSchemaFieldTypeUnion x) -instance {-# OVERLAPS #-} GSchemaFieldTypeUnion sch '[] U1 where +instance {-# OVERLAPS #-} GToSchemaFieldTypeUnion w sch '[] U1 where toSchemaFieldTypeUnion U1 = error "this should never happen" +instance {-# OVERLAPS #-} GFromSchemaFieldTypeUnion w sch '[] U1 where fromSchemaFieldTypeUnion _ = U1 instance {-# OVERLAPPABLE #-} TypeError ('Text "the type does not match the union") - => GSchemaFieldTypeUnion sch '[] f where + => GToSchemaFieldTypeUnion w sch '[] f where toSchemaFieldTypeUnion = error "this should never happen" +instance {-# OVERLAPPABLE #-} + TypeError ('Text "the type does not match the union") + => GFromSchemaFieldTypeUnion w sch '[] f where fromSchemaFieldTypeUnion = error "this should never happen" -instance (GSchemaFieldTypeWrap sch t v) - => GSchemaFieldTypeUnion sch '[t] v where +instance (GToSchemaFieldTypeWrap w sch t v) + => GToSchemaFieldTypeUnion w sch '[t] v where toSchemaFieldTypeUnion x = Z (toSchemaFieldTypeW x) +instance (GFromSchemaFieldTypeWrap w sch t v) + => GFromSchemaFieldTypeUnion w sch '[t] v where fromSchemaFieldTypeUnion (Z x) = fromSchemaFieldTypeW x fromSchemaFieldTypeUnion (S _) = error "this should never happen" -instance (GSchemaFieldTypeWrap sch t v, GSchemaFieldTypeUnion sch ts vs) - => GSchemaFieldTypeUnion sch (t ': ts) (v :+: vs) where +instance (GToSchemaFieldTypeWrap w sch t v, GToSchemaFieldTypeUnion w sch ts vs) + => GToSchemaFieldTypeUnion w sch (t ': ts) (v :+: vs) where toSchemaFieldTypeUnion (L1 x) = Z (toSchemaFieldTypeW x) toSchemaFieldTypeUnion (R1 r) = S (toSchemaFieldTypeUnion r) +instance (GFromSchemaFieldTypeWrap w sch t v, GFromSchemaFieldTypeUnion w sch ts vs) + => GFromSchemaFieldTypeUnion w sch (t ': ts) (v :+: vs) where fromSchemaFieldTypeUnion (Z x) = L1 (fromSchemaFieldTypeW x) fromSchemaFieldTypeUnion (S r) = R1 (fromSchemaFieldTypeUnion r) -- Weird nested instance produced by GHC -instance ( GSchemaFieldTypeWrap sch t1 v1, GSchemaFieldTypeWrap sch t2 v2 - , GSchemaFieldTypeUnion sch ts vs ) - => GSchemaFieldTypeUnion sch (t1 ': t2 ': ts) ((v1 :+: v2) :+: vs) where +instance ( GToSchemaFieldTypeWrap w sch t1 v1 + , GToSchemaFieldTypeWrap w sch t2 v2 + , GToSchemaFieldTypeUnion w sch ts vs ) + => GToSchemaFieldTypeUnion w sch (t1 ': t2 ': ts) ((v1 :+: v2) :+: vs) where toSchemaFieldTypeUnion (L1 (L1 x)) = Z (toSchemaFieldTypeW x) toSchemaFieldTypeUnion (L1 (R1 x)) = S (Z (toSchemaFieldTypeW x)) toSchemaFieldTypeUnion (R1 r) = S (S (toSchemaFieldTypeUnion r)) +instance ( GFromSchemaFieldTypeWrap w sch t1 v1 + , GFromSchemaFieldTypeWrap w sch t2 v2 + , GFromSchemaFieldTypeUnion w sch ts vs ) + => GFromSchemaFieldTypeUnion w sch (t1 ': t2 ': ts) ((v1 :+: v2) :+: vs) where fromSchemaFieldTypeUnion (Z x) = L1 (L1 (fromSchemaFieldTypeW x)) fromSchemaFieldTypeUnion (S (Z x)) = L1 (R1 (fromSchemaFieldTypeW x)) fromSchemaFieldTypeUnion (S (S r)) = R1 (fromSchemaFieldTypeUnion r) @@ -234,16 +314,22 @@ instance ( GSchemaFieldTypeWrap sch t1 v1, GSchemaFieldTypeWrap sch t2 v2 ------------------ instance {-# OVERLAPPABLE #-} - (GToSchemaEnumDecompose fmap choices f, GFromSchemaEnumDecompose fmap choices f) - => GSchemaTypeDef sch fmap ('DEnum name choices) f where + (GToSchemaEnumDecompose fmap choices f) + => GToSchemaTypeDef w sch fmap ('DEnum name choices) f where toSchemaTypeDef p x = TEnum (toSchemaEnumDecomp p x) +instance {-# OVERLAPPABLE #-} + (GFromSchemaEnumDecompose fmap choices f) + => GFromSchemaTypeDef w sch fmap ('DEnum name choices) f where fromSchemaTypeDef p (TEnum x) = fromSchemaEnumDecomp p x -- This instance removes unneeded metadata from the -- top of the type. instance {-# OVERLAPS #-} - GSchemaTypeDef sch fmap ('DEnum name choices) f - => GSchemaTypeDef sch fmap ('DEnum name choices) (D1 meta f) where + GToSchemaTypeDef w sch fmap ('DEnum name choices) f + => GToSchemaTypeDef w sch fmap ('DEnum name choices) (D1 meta f) where toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x +instance {-# OVERLAPS #-} + GFromSchemaTypeDef w sch fmap ('DEnum name choices) f + => GFromSchemaTypeDef w sch fmap ('DEnum name choices) (D1 meta f) where fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) -- 'toSchema' for enumerations: @@ -254,7 +340,8 @@ instance {-# OVERLAPS #-} -- this is done by 'MappingRight' and 'Find' -- 3. from that location, build a 'Proxy' value -- this is done by 'GToSchemaEnumProxy' -class GToSchemaEnumDecompose (fmap :: Mappings Symbol fs) (choices :: [ChoiceDef fs]) (f :: * -> *) where +class GToSchemaEnumDecompose (fmap :: Mappings Symbol fs) + (choices :: [ChoiceDef fs]) (f :: * -> *) where toSchemaEnumDecomp :: Proxy fmap -> f a -> NS Proxy choices instance (GToSchemaEnumDecompose fmap choices oneway, GToSchemaEnumDecompose fmap choices oranother) => GToSchemaEnumDecompose fmap choices (oneway :+: oranother) where @@ -306,21 +393,30 @@ instance forall other rest w. GFromSchemaEnumU1 rest w ------------- instance {-# OVERLAPPABLE #-} - (GToSchemaRecord sch fmap args f, GFromSchemaRecord sch fmap args f) - => GSchemaTypeDef sch fmap ('DRecord name args) f where + (GToSchemaRecord w sch fmap args f) + => GToSchemaTypeDef w sch fmap ('DRecord name args) f where toSchemaTypeDef p x = TRecord (toSchemaRecord p x) +instance {-# OVERLAPPABLE #-} + (GFromSchemaRecord w sch fmap args f) + => GFromSchemaTypeDef w sch fmap ('DRecord name args) f where fromSchemaTypeDef p (TRecord x) = fromSchemaRecord p x -- This instance removes unneeded metadata from the -- top of the type. instance {-# OVERLAPS #-} - GSchemaTypeDef sch fmap ('DRecord name args) f - => GSchemaTypeDef sch fmap ('DRecord name args) (D1 meta f) where + GToSchemaTypeDef w sch fmap ('DRecord name args) f + => GToSchemaTypeDef w sch fmap ('DRecord name args) (D1 meta f) where toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x +instance {-# OVERLAPS #-} + GFromSchemaTypeDef w sch fmap ('DRecord name args) f + => GFromSchemaTypeDef w sch fmap ('DRecord name args) (D1 meta f) where fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) instance {-# OVERLAPS #-} - GSchemaTypeDef sch fmap ('DRecord name args) f - => GSchemaTypeDef sch fmap ('DRecord name args) (C1 meta f) where + GToSchemaTypeDef w sch fmap ('DRecord name args) f + => GToSchemaTypeDef w sch fmap ('DRecord name args) (C1 meta f) where toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x +instance {-# OVERLAPS #-} + GFromSchemaTypeDef w sch fmap ('DRecord name args) f + => GFromSchemaTypeDef w sch fmap ('DRecord name args) (C1 meta f) where fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) -- 'toSchema' for records: @@ -336,34 +432,47 @@ instance {-# OVERLAPS #-} -- are not represented by a linear sequence of ':*:', -- so we need to handle some cases in a special way -- (see 'HereLeft' and 'HereRight' instances) -class GToSchemaRecord (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) +class GToSchemaRecord (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) (args :: [FieldDef ts fs]) (f :: * -> *) where - toSchemaRecord :: Proxy fmap -> f a -> NP (Field sch) args -instance GToSchemaRecord sch fmap '[] f where + toSchemaRecord :: Proxy fmap -> f a -> NP (Field w sch) args +instance GToSchemaRecord w sch fmap '[] f where toSchemaRecord _ _ = Nil -instance ( GToSchemaRecord sch fmap cs f - , GToSchemaRecordSearch sch t f (FindSel f (MappingLeft fmap name)) ) - => GToSchemaRecord sch fmap ('FieldDef name t ': cs) f where +instance ( GToSchemaRecord w sch fmap cs f + , GToSchemaRecordSearch w sch t f (FindSel f (MappingLeft fmap name)) ) + => GToSchemaRecord w sch fmap ('FieldDef name t ': cs) f where toSchemaRecord p x = this :* toSchemaRecord p x where this = Field (toSchemaRecordSearch (Proxy @(FindSel f (MappingLeft fmap name))) x) -class GToSchemaRecordSearch (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) (w :: Where) where - toSchemaRecordSearch :: Proxy w -> f a -> FieldValue sch t -instance GSchemaFieldType sch t v - => GToSchemaRecordSearch sch t (S1 m (K1 i v)) 'Here where - toSchemaRecordSearch _ (M1 (K1 x)) = toSchemaFieldType x -instance GSchemaFieldType sch t v - => GToSchemaRecordSearch sch t (S1 m (K1 i v) :*: rest) 'Here where - toSchemaRecordSearch _ (M1 (K1 x) :*: _) = toSchemaFieldType x -instance GSchemaFieldType sch t v - => GToSchemaRecordSearch sch t ((S1 m (K1 i v) :*: other) :*: rest) 'HereLeft where - toSchemaRecordSearch _ ((M1 (K1 x) :*: _) :*: _) = toSchemaFieldType x -instance GSchemaFieldType sch t v - => GToSchemaRecordSearch sch t ((other :*: S1 m (K1 i v)) :*: rest) 'HereRight where - toSchemaRecordSearch _ ((_ :*: M1 (K1 x)) :*: _) = toSchemaFieldType x -instance forall sch t other rest n. - GToSchemaRecordSearch sch t rest n - => GToSchemaRecordSearch sch t (other :*: rest) ('There n) where +class GToSchemaRecordSearch (w :: * -> *) (sch :: Schema ts fs) + (t :: FieldType ts) (f :: * -> *) (wh :: Where) where + toSchemaRecordSearch :: Proxy wh -> f a -> w (FieldValue w sch t) +instance {-# OVERLAPS #-} GToSchemaFieldType Identity sch t v + => GToSchemaRecordSearch Identity sch t (S1 m (K1 i v)) 'Here where + toSchemaRecordSearch _ (M1 (K1 x)) = Identity (toSchemaFieldType x) +instance {-# OVERLAPPABLE #-} (Functor w, GToSchemaFieldType w sch t v) + => GToSchemaRecordSearch w sch t (S1 m (K1 i (w v))) 'Here where + toSchemaRecordSearch _ (M1 (K1 x)) = toSchemaFieldType <$> x +instance {-# OVERLAPS #-} GToSchemaFieldType Identity sch t v + => GToSchemaRecordSearch Identity sch t (S1 m (K1 i v) :*: rest) 'Here where + toSchemaRecordSearch _ (M1 (K1 x) :*: _) = Identity (toSchemaFieldType x) +instance {-# OVERLAPPABLE #-} (Functor w, GToSchemaFieldType w sch t v) + => GToSchemaRecordSearch w sch t (S1 m (K1 i (w v)) :*: rest) 'Here where + toSchemaRecordSearch _ (M1 (K1 x) :*: _) = toSchemaFieldType <$> x +instance {-# OVERLAPS #-} GToSchemaFieldType Identity sch t v + => GToSchemaRecordSearch Identity sch t ((S1 m (K1 i v) :*: other) :*: rest) 'HereLeft where + toSchemaRecordSearch _ ((M1 (K1 x) :*: _) :*: _) = Identity (toSchemaFieldType x) +instance {-# OVERLAPPABLE #-} (Functor w, GToSchemaFieldType w sch t v) + => GToSchemaRecordSearch w sch t ((S1 m (K1 i (w v)) :*: other) :*: rest) 'HereLeft where + toSchemaRecordSearch _ ((M1 (K1 x) :*: _) :*: _) = toSchemaFieldType <$> x +instance {-# OVERLAPS #-} GToSchemaFieldType Identity sch t v + => GToSchemaRecordSearch Identity sch t ((other :*: S1 m (K1 i v)) :*: rest) 'HereRight where + toSchemaRecordSearch _ ((_ :*: M1 (K1 x)) :*: _) = Identity (toSchemaFieldType x) +instance {-# OVERLAPPABLE #-} (Functor w, GToSchemaFieldType w sch t v) + => GToSchemaRecordSearch w sch t ((other :*: S1 m (K1 i (w v))) :*: rest) 'HereRight where + toSchemaRecordSearch _ ((_ :*: M1 (K1 x)) :*: _) = toSchemaFieldType <$> x +instance forall sch t other rest n w. + GToSchemaRecordSearch w sch t rest n + => GToSchemaRecordSearch w sch t (other :*: rest) ('There n) where toSchemaRecordSearch _ (_ :*: xs) = toSchemaRecordSearch (Proxy @n) xs -- 'fromSchema' for records @@ -374,23 +483,31 @@ instance forall sch t other rest n. -- this is done by 'MappingRight' and 'FindField' -- 3. using that location, obtain the value of the field -- this is done by 'GFromSchemaRecordSearch' -class GFromSchemaRecord (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) +class GFromSchemaRecord (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) (args :: [FieldDef ts fs]) (f :: * -> *) where - fromSchemaRecord :: Proxy fmap -> NP (Field sch) args -> f a -instance GFromSchemaRecordSearch sch v args (FindField args (MappingRight fmap name)) - => GFromSchemaRecord sch fmap args (S1 ('MetaSel ('Just name) u ss ds) (K1 i v)) where + fromSchemaRecord :: Proxy fmap -> NP (Field w sch) args -> f a +instance {-# OVERLAPS #-} + (GFromSchemaRecordSearch Identity sch v args (FindField args (MappingRight fmap name))) + => GFromSchemaRecord Identity sch fmap args (S1 ('MetaSel ('Just name) u ss ds) (K1 i v)) where + fromSchemaRecord _ x = M1 $ K1 $ runIdentity $ fromSchemaRecordSearch (Proxy @(FindField args (MappingRight fmap name))) x +instance {-# OVERLAPPABLE #-} + (GFromSchemaRecordSearch w sch v args (FindField args (MappingRight fmap name))) + => GFromSchemaRecord w sch fmap args (S1 ('MetaSel ('Just name) u ss ds) (K1 i (w v))) where fromSchemaRecord _ x = M1 $ K1 $ fromSchemaRecordSearch (Proxy @(FindField args (MappingRight fmap name))) x -instance (GFromSchemaRecord sch fmap args oneway, GFromSchemaRecord sch fmap args oranother) - => GFromSchemaRecord sch fmap args (oneway :*: oranother) where - fromSchemaRecord p x = fromSchemaRecord p x :*: fromSchemaRecord p x -instance GFromSchemaRecord sch fmap args U1 where +instance ( GFromSchemaRecord w sch fmap args oneway + , GFromSchemaRecord w sch fmap args oranother ) + => GFromSchemaRecord w sch fmap args (oneway :*: oranother) where + fromSchemaRecord p x = fromSchemaRecord p x :*: fromSchemaRecord p x +instance GFromSchemaRecord w sch fmap args U1 where fromSchemaRecord _ _ = U1 -class GFromSchemaRecordSearch (sch :: Schema ts fs) (v :: *) (args :: [FieldDef ts fs]) (w :: Where) where - fromSchemaRecordSearch :: Proxy w -> NP (Field sch) args -> v -instance GSchemaFieldType sch t v => GFromSchemaRecordSearch sch v ('FieldDef name t ': rest) 'Here where - fromSchemaRecordSearch _ (Field x :* _) = fromSchemaFieldType x -instance forall sch v other rest n. - GFromSchemaRecordSearch sch v rest n - => GFromSchemaRecordSearch sch v (other ': rest) ('There n) where +class GFromSchemaRecordSearch (w :: * -> *) (sch :: Schema ts fs) + (v :: *) (args :: [FieldDef ts fs]) (wh :: Where) where + fromSchemaRecordSearch :: Proxy wh -> NP (Field w sch) args -> w v +instance (Functor w, GFromSchemaFieldType w sch t v) + => GFromSchemaRecordSearch w sch v ('FieldDef name t ': rest) 'Here where + fromSchemaRecordSearch _ (Field x :* _) = fromSchemaFieldType <$> x +instance forall sch v other rest n w. + GFromSchemaRecordSearch w sch v rest n + => GFromSchemaRecordSearch w sch v (other ': rest) ('There n) where fromSchemaRecordSearch _ (_ :* xs) = fromSchemaRecordSearch (Proxy @n) xs diff --git a/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs b/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs index b274b1ce..266287c8 100644 --- a/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs +++ b/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs @@ -45,73 +45,92 @@ typeDefToDecl :: Type -> Namer -> TypeDefB Type String String -> Q [Dec] -- Records with one field typeDefToDecl schemaTy namer (DRecord name [f]) = do let complete = completeName namer name + fVar <- newName "f" d <- newtypeD (pure []) (mkName complete) - [] + [PlainTV fVar] Nothing - (pure (RecC (mkName complete) [fieldDefToDecl namer complete f])) - deriveClauses - let hsi = generateHasSchemaInstance schemaTy name complete (fieldMapping complete [f]) - return [d, hsi] + (pure (RecC (mkName complete) [fieldDefToDecl namer complete fVar f])) + [pure (DerivClause Nothing [ConT ''Generic])] + wTy <- VarT <$> newName "w" + -- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete [f]) + return [d] -- , hsi] -- Records with more than one field typeDefToDecl schemaTy namer (DRecord name fields) = do let complete = completeName namer name + fVar <- newName "f" d <- dataD (pure []) (mkName complete) - [] + [PlainTV fVar] Nothing - [pure (RecC (mkName complete) (map (fieldDefToDecl namer complete) fields))] - deriveClauses - let hsi = generateHasSchemaInstance schemaTy name complete (fieldMapping complete fields) - return [d, hsi] + [pure (RecC (mkName complete) (map (fieldDefToDecl namer complete fVar) fields))] + [pure (DerivClause Nothing [ConT ''Generic])] + wTy <- VarT <$> newName "w" + -- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete fields) + return [d] -- , hsi] -- Enumerations typeDefToDecl schemaTy namer (DEnum name choices) = do let complete = completeName namer name + fVar <- newName "f" d <- dataD (pure []) (mkName complete) - [] + [PlainTV fVar] Nothing [ pure (RecC (mkName (choiceName complete choicename)) []) | ChoiceDef choicename <- choices] - deriveClauses - let hsi = generateHasSchemaInstance schemaTy name complete (choiceMapping complete choices) - return [d, hsi] + [pure (DerivClause Nothing [ConT ''Eq, ConT ''Ord, ConT ''Show, ConT ''Generic])] + wTy <- VarT <$> newName "w" + -- let hsi = generateHasSchemaInstance wTy schemaTy name complete (choiceMapping complete choices) + return [d] --, hsi] -- Simple things typeDefToDecl _ _ (DSimple _) = fail "DSimple is not supported" -deriveClauses :: [Q DerivClause] -deriveClauses - = [ pure (DerivClause Nothing [ConT ''Eq, ConT ''Ord, ConT ''Show, ConT ''Generic]) ] -{- we need to add a field mapping - , pure (DerivClause (Just AnyclassStrategy) - [AppT (AppT (ConT ''HasSchema) schemaTy) (LitT (StrTyLit name))]) ] --} - -fieldDefToDecl :: Namer -> String -> FieldDefB Type String String -> (Name, Bang, Type) -fieldDefToDecl namer complete (FieldDef name ty) +fieldDefToDecl :: Namer -> String -> Name -> FieldDefB Type String String -> (Name, Bang, Type) +fieldDefToDecl namer complete fVar (FieldDef name ty) = ( mkName (fieldName complete name) , Bang NoSourceUnpackedness NoSourceStrictness - , fieldTypeToDecl namer ty ) - -generateHasSchemaInstance :: Type -> String -> String -> Type -> Dec -generateHasSchemaInstance schemaTy schemaName complete mapping - = InstanceD Nothing [] - (AppT (AppT (AppT (ConT ''HasSchema) schemaTy) - (LitT (StrTyLit schemaName))) - (ConT (mkName complete))) + , AppT (VarT fVar) (fieldTypeToDecl namer fVar ty) ) + +{- broken for now +generateBuiltinInstance :: Bool -> Type -> String -> Name -> Dec +generateBuiltinInstance withPrereq wTy complete className +#if MIN_VERSION_template_haskell(2,12,0) + = StandaloneDerivD Nothing ctx ty +#else + = StandaloneDerivD ctx ty + +#endif + where + me = ConT (mkName complete) + ctx = [AppT (ConT className) (AppT wTy (AppT me wTy)) | withPrereq] + ty = AppT (ConT className) (AppT me wTy) +-} + +{- +generateHasSchemaInstance :: Type -> Type -> String -> String -> Type -> Dec +generateHasSchemaInstance wTy schemaTy schemaName complete mapping + = InstanceD Nothing [AppT (ConT ''Applicative) wTy] + (AppT (AppT (AppT (AppT (ConT ''HasSchema) + wTy ) + schemaTy ) + (LitT (StrTyLit schemaName))) + (AppT (ConT (mkName complete)) wTy) ) #if MIN_VERSION_template_haskell(2,15,0) [TySynInstD (TySynEqn Nothing - (AppT (AppT (AppT (ConT ''FieldMapping) + (AppT (AppT (AppT (AppT (ConT ''FieldMapping) + wTy ) schemaTy ) (LitT (StrTyLit schemaName)) ) - (ConT (mkName complete)) ) + (AppT (ConT (mkName complete)) wTy)) mapping) ] #else [TySynInstD ''FieldMapping - (TySynEqn [schemaTy, LitT (StrTyLit schemaName), ConT (mkName complete)] + (TySynEqn [ wTy, schemaTy, LitT (StrTyLit schemaName) + , AppT (ConT (mkName complete)) wTy ] mapping) ] #endif +-} fieldMapping :: String -> [FieldDefB Type String String] -> Type fieldMapping _complete [] = PromotedNilT @@ -151,26 +170,26 @@ firstLower :: String -> String firstLower [] = error "Empty names are not allowed" firstLower (x:rest) = toLower x : rest -fieldTypeToDecl :: Namer -> FieldTypeB Type String -> Type -fieldTypeToDecl _namer TNull +fieldTypeToDecl :: Namer -> Name -> FieldTypeB Type String -> Type +fieldTypeToDecl _namer _fVar TNull = ConT ''() -fieldTypeToDecl _namer (TPrimitive t) +fieldTypeToDecl _namer _fVar (TPrimitive t) = t -fieldTypeToDecl namer (TSchematic nm) - = ConT (mkName $ completeName namer nm) -fieldTypeToDecl namer (TOption t) - = AppT (ConT ''Maybe) (fieldTypeToDecl namer t) -fieldTypeToDecl namer (TList t) - = AppT ListT (fieldTypeToDecl namer t) -fieldTypeToDecl namer (TMap k v) - = AppT (AppT (ConT ''M.Map) (fieldTypeToDecl namer k)) (fieldTypeToDecl namer v) -fieldTypeToDecl namer (TUnion ts) - = AppT (AppT (ConT ''NS) (ConT ''I)) (fieldTypeUnion namer ts) - -fieldTypeUnion :: Namer -> [FieldTypeB Type String] -> Type -fieldTypeUnion _ [] = PromotedNilT -fieldTypeUnion namer (t:ts) - = AppT (AppT PromotedConsT (fieldTypeToDecl namer t)) (fieldTypeUnion namer ts) +fieldTypeToDecl namer fVar (TSchematic nm) + = AppT (ConT (mkName $ completeName namer nm)) (VarT fVar) +fieldTypeToDecl namer fVar (TOption t) + = AppT (ConT ''Maybe) (fieldTypeToDecl namer fVar t) +fieldTypeToDecl namer fVar (TList t) + = AppT ListT (fieldTypeToDecl namer fVar t) +fieldTypeToDecl namer fVar (TMap k v) + = AppT (AppT (ConT ''M.Map) (fieldTypeToDecl namer fVar k)) (fieldTypeToDecl namer fVar v) +fieldTypeToDecl namer fVar (TUnion ts) + = AppT (AppT (ConT ''NS) (ConT ''I)) (fieldTypeUnion namer fVar ts) + +fieldTypeUnion :: Namer -> Name -> [FieldTypeB Type String] -> Type +fieldTypeUnion _ _fVar [] = PromotedNilT +fieldTypeUnion namer fVar (t:ts) + = AppT (AppT PromotedConsT (fieldTypeToDecl namer fVar t)) (fieldTypeUnion namer fVar ts) -- Parsing -- ======= diff --git a/core/schema/src/Mu/Schema/Examples.hs b/core/schema/src/Mu/Schema/Examples.hs index 8d4e1348..c4b0a310 100644 --- a/core/schema/src/Mu/Schema/Examples.hs +++ b/core/schema/src/Mu/Schema/Examples.hs @@ -7,14 +7,17 @@ {-# language MultiParamTypeClasses #-} {-# language PolyKinds #-} {-# language QuasiQuotes #-} +{-# language StandaloneDeriving #-} {-# language TemplateHaskell #-} {-# language TypeApplications #-} {-# language TypeFamilies #-} {-# language TypeOperators #-} +{-# language UndecidableInstances #-} -- | Look at my source code! module Mu.Schema.Examples where import qualified Data.Aeson as J +import Data.Functor.Identity import qualified Data.Text as T import GHC.Generics @@ -29,22 +32,29 @@ data Person , gender :: Maybe Gender , address :: Address } deriving (Eq, Show, Generic) - deriving (HasSchema ExampleSchema "person") + deriving (ToSchema Identity ExampleSchema "person", FromSchema Identity ExampleSchema "person") deriving (J.ToJSON, J.FromJSON) - via (WithSchema ExampleSchema "person" Person) + via (WithSchema Identity ExampleSchema "person" Person) data Address = Address { postcode :: T.Text , country :: T.Text } deriving (Eq, Show, Generic) - deriving (HasSchema ExampleSchema "address") + deriving (ToSchema Identity ExampleSchema "address", FromSchema Identity ExampleSchema "address") deriving (J.ToJSON, J.FromJSON) - via (WithSchema ExampleSchema "address" Address) + via (WithSchema Identity ExampleSchema "address" Address) + +type GenderFieldMapping + = '[ "Male" ':-> "male" + , "Female" ':-> "female" + , "NonBinary" ':-> "nb" ] data Gender = Male | Female | NonBinary deriving (Eq, Show, Generic) + deriving (ToSchema f ExampleSchema "gender", FromSchema f ExampleSchema "gender") + via (CustomFieldMapping "gender" GenderFieldMapping Gender) deriving (J.ToJSON, J.FromJSON) - via (WithSchema ExampleSchema "gender" Gender) + via (WithSchema Identity ExampleSchema "gender" Gender) -- Schema for these data types type ExampleSchema @@ -63,15 +73,6 @@ type ExampleSchema , 'FieldDef "address" ('TSchematic "address") ] ] -type GenderFieldMapping - = '[ "Male" ':-> "male" - , "Female" ':-> "female" - , "NonBinary" ':-> "nb" ] - --- we can give a custom field mapping via a custom instance -instance HasSchema ExampleSchema "gender" Gender where - type FieldMapping ExampleSchema "gender" Gender = GenderFieldMapping - $(generateTypesFromSchema (++"Msg") ''ExampleSchema) {- diff --git a/core/schema/src/Mu/Schema/Interpretation.hs b/core/schema/src/Mu/Schema/Interpretation.hs index f7aa0fed..546e22a1 100644 --- a/core/schema/src/Mu/Schema/Interpretation.hs +++ b/core/schema/src/Mu/Schema/Interpretation.hs @@ -1,17 +1,21 @@ -{-# language DataKinds #-} -{-# language FlexibleContexts #-} -{-# language FlexibleInstances #-} -{-# language GADTs #-} -{-# language PolyKinds #-} -{-# language ScopedTypeVariables #-} -{-# language TypeApplications #-} -{-# language TypeFamilies #-} -{-# language TypeOperators #-} -{-# language UndecidableInstances #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language QuantifiedConstraints #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} -- | Interpretation of schemas module Mu.Schema.Interpretation ( Term(..), Field(..), FieldValue(..) , NS(..), NP(..), Proxy(..) +, transWrap, transFields, transValue +, transWrapNoMaps, transFieldsNoMaps, transValueNoMaps ) where import Data.Map @@ -21,113 +25,186 @@ import Data.SOP import Mu.Schema.Definition -- | Interpretation of a type in a schema. -data Term (sch :: Schema typeName fieldName) (t :: TypeDef typeName fieldName) where - TRecord :: NP (Field sch) args -> Term sch ('DRecord name args) - TEnum :: NS Proxy choices -> Term sch ('DEnum name choices) - TSimple :: FieldValue sch t -> Term sch ('DSimple t) +data Term w (sch :: Schema typeName fieldName) (t :: TypeDef typeName fieldName) where + TRecord :: NP (Field w sch) args -> Term w sch ('DRecord name args) + TEnum :: NS Proxy choices -> Term w sch ('DEnum name choices) + TSimple :: FieldValue w sch t -> Term w sch ('DSimple t) -- | Interpretation of a field. -data Field (sch :: Schema typeName fieldName) (f :: FieldDef typeName fieldName) where - Field :: FieldValue sch t -> Field sch ('FieldDef name t) +data Field w (sch :: Schema typeName fieldName) (f :: FieldDef typeName fieldName) where + Field :: w (FieldValue w sch t) -> Field w sch ('FieldDef name t) -- | Interpretation of a field type, by giving a value of that type. -data FieldValue (sch :: Schema typeName fieldName) (t :: FieldType typeName) where - FNull :: FieldValue sch 'TNull - FPrimitive :: t -> FieldValue sch ('TPrimitive t) - FSchematic :: Term sch (sch :/: t) - -> FieldValue sch ('TSchematic t) - FOption :: Maybe (FieldValue sch t) - -> FieldValue sch ('TOption t) - FList :: [FieldValue sch t] - -> FieldValue sch ('TList t) - FMap :: Map (FieldValue sch k) (FieldValue sch v) - -> FieldValue sch ('TMap k v) - FUnion :: NS (FieldValue sch) choices - -> FieldValue sch ('TUnion choices) +data FieldValue w (sch :: Schema typeName fieldName) (t :: FieldType typeName) where + FNull :: FieldValue w sch 'TNull + FPrimitive :: t -> FieldValue w sch ('TPrimitive t) + FSchematic :: Term w sch (sch :/: t) + -> FieldValue w sch ('TSchematic t) + FOption :: Maybe (FieldValue w sch t) + -> FieldValue w sch ('TOption t) + FList :: [FieldValue w sch t] + -> FieldValue w sch ('TList t) + FMap :: Ord (FieldValue w sch k) + => Map (FieldValue w sch k) (FieldValue w sch v) + -> FieldValue w sch ('TMap k v) + FUnion :: NS (FieldValue w sch) choices + -> FieldValue w sch ('TUnion choices) + +transWrap + :: forall tn fn (sch :: Schema tn fn) t u v. + (Functor u, forall k. Ord (FieldValue u sch k) => Ord (FieldValue v sch k)) + => (forall a. u a -> v a) + -> Term u sch t -> Term v sch t +transWrap n x = case x of + TRecord f -> TRecord (transFields n f) + TEnum c -> TEnum c + TSimple v -> TSimple (transValue n v) + +transWrapNoMaps + :: forall tn fn (sch :: Schema tn fn) t u v. + (Functor u) + => (forall a. u a -> v a) + -> Term u sch t -> Term v sch t +transWrapNoMaps n x = case x of + TRecord f -> TRecord (transFieldsNoMaps n f) + TEnum c -> TEnum c + TSimple v -> TSimple (transValueNoMaps n v) + +transFields + :: forall tn fn (sch :: Schema tn fn) args u v. + (Functor u, forall k. Ord (FieldValue u sch k) => Ord (FieldValue v sch k)) + => (forall a. u a -> v a) + -> NP (Field u sch) args -> NP (Field v sch) args +transFields _ Nil = Nil +transFields n (Field v :* rest) + = Field (n (fmap (transValue n) v)) :* transFields n rest + +transFieldsNoMaps + :: forall tn fn (sch :: Schema tn fn) args u v. + (Functor u) + => (forall a. u a -> v a) + -> NP (Field u sch) args -> NP (Field v sch) args +transFieldsNoMaps _ Nil = Nil +transFieldsNoMaps n (Field v :* rest) + = Field (n (fmap (transValueNoMaps n) v)) :* transFieldsNoMaps n rest + +transValue + :: forall tn fn (sch :: Schema tn fn) l u v. + (Functor u, forall k. Ord (FieldValue u sch k) => Ord (FieldValue v sch k)) + => (forall a. u a -> v a) + -> FieldValue u sch l -> FieldValue v sch l +transValue _ FNull = FNull +transValue _ (FPrimitive y) = FPrimitive y +transValue n (FSchematic t) = FSchematic (transWrap n t) +transValue n (FOption o) = FOption (transValue n <$> o) +transValue n (FList l) = FList (transValue n <$> l) +transValue n (FMap m) = FMap (mapKeys (transValue n) (transValue n <$> m)) +transValue n (FUnion u) = FUnion (transUnion u) + where + transUnion :: NS (FieldValue u sch) us -> NS (FieldValue v sch) us + transUnion (Z z) = Z (transValue n z) + transUnion (S s) = S (transUnion s) + +transValueNoMaps + :: forall tn fn (sch :: Schema tn fn) l u v. + (Functor u) + => (forall a. u a -> v a) + -> FieldValue u sch l -> FieldValue v sch l +transValueNoMaps _ FNull = FNull +transValueNoMaps _ (FPrimitive y) = FPrimitive y +transValueNoMaps n (FSchematic t) = FSchematic (transWrapNoMaps n t) +transValueNoMaps n (FOption o) = FOption (transValueNoMaps n <$> o) +transValueNoMaps n (FList l) = FList (transValueNoMaps n <$> l) +transValueNoMaps _ (FMap _) = error "this should never happen" +transValueNoMaps n (FUnion u) = FUnion (transUnion u) + where + transUnion :: NS (FieldValue u sch) us -> NS (FieldValue v sch) us + transUnion (Z z) = Z (transValueNoMaps n z) + transUnion (S s) = S (transUnion s) -- =========================== -- CRAZY EQ AND SHOW INSTANCES -- =========================== -instance All (Eq `Compose` Field sch) args - => Eq (Term sch ('DRecord name args)) where +instance All (Eq `Compose` Field w sch) args + => Eq (Term w sch ('DRecord name args)) where TRecord xs == TRecord ys = xs == ys -instance (KnownName name, All (Show `Compose` Field sch) args) - => Show (Term sch ('DRecord name args)) where +instance (KnownName name, All (Show `Compose` Field w sch) args) + => Show (Term w sch ('DRecord name args)) where show (TRecord xs) = "record " ++ nameVal (Proxy @name) ++ " { " ++ printFields xs ++ " }" - where printFields :: forall fs. All (Show `Compose` Field sch) fs - => NP (Field sch) fs -> String + where printFields :: forall fs. All (Show `Compose` Field w sch) fs + => NP (Field w sch) fs -> String printFields Nil = "" printFields (x :* Nil) = show x printFields (x :* rest) = show x ++ ", " ++ printFields rest -instance All (Eq `Compose` Proxy) choices => Eq (Term sch ('DEnum name choices)) where +instance All (Eq `Compose` Proxy) choices => Eq (Term w sch ('DEnum name choices)) where TEnum x == TEnum y = x == y instance (KnownName name, All KnownName choices, All (Show `Compose` Proxy) choices) - => Show (Term sch ('DEnum name choices)) where + => Show (Term w sch ('DEnum name choices)) where show (TEnum choice) = "enum " ++ nameVal (Proxy @name) ++ " { " ++ printChoice choice ++ " }" where printChoice :: forall cs. All KnownName cs => NS Proxy cs -> String printChoice (Z p) = nameVal p printChoice (S n) = printChoice n -instance Eq (FieldValue sch t) => Eq (Term sch ('DSimple t)) where +instance Eq (FieldValue w sch t) => Eq (Term w sch ('DSimple t)) where TSimple x == TSimple y = x == y -instance Show (FieldValue sch t) => Show (Term sch ('DSimple t)) where +instance Show (FieldValue w sch t) => Show (Term w sch ('DSimple t)) where show (TSimple x) = show x -instance Eq (FieldValue sch t) => Eq (Field sch ('FieldDef name t)) where +instance (Eq (w (FieldValue w sch t))) => Eq (Field w sch ('FieldDef name t)) where Field x == Field y = x == y -instance (KnownName name, Show (FieldValue sch t)) - => Show (Field sch ('FieldDef name t)) where +instance (KnownName name, Show (w (FieldValue w sch t))) + => Show (Field w sch ('FieldDef name t)) where show (Field x) = nameVal (Proxy @name) ++ ": " ++ show x -instance Eq (FieldValue sch 'TNull) where +instance Eq (FieldValue w sch 'TNull) where _ == _ = True -instance Eq t => Eq (FieldValue sch ('TPrimitive t)) where +instance Eq t => Eq (FieldValue w sch ('TPrimitive t)) where FPrimitive x == FPrimitive y = x == y -instance Eq (Term sch (sch :/: t)) => Eq (FieldValue sch ('TSchematic t)) where +instance Eq (Term w sch (sch :/: t)) => Eq (FieldValue w sch ('TSchematic t)) where FSchematic x == FSchematic y = x == y -instance Eq (FieldValue sch t) => Eq (FieldValue sch ('TOption t)) where +instance Eq (FieldValue w sch t) => Eq (FieldValue w sch ('TOption t)) where FOption x == FOption y = x == y -instance Eq (FieldValue sch t) => Eq (FieldValue sch ('TList t)) where +instance Eq (FieldValue w sch t) => Eq (FieldValue w sch ('TList t)) where FList x == FList y = x == y -instance (Eq (FieldValue sch k), Eq (FieldValue sch v)) - => Eq (FieldValue sch ('TMap k v)) where +instance (Eq (FieldValue w sch k), Eq (FieldValue w sch v)) + => Eq (FieldValue w sch ('TMap k v)) where FMap x == FMap y = x == y -instance All (Eq `Compose` FieldValue sch) choices - => Eq (FieldValue sch ('TUnion choices)) where +instance All (Eq `Compose` FieldValue w sch) choices + => Eq (FieldValue w sch ('TUnion choices)) where FUnion x == FUnion y = x == y -instance Ord (FieldValue sch 'TNull) where +instance Ord (FieldValue w sch 'TNull) where compare _ _ = EQ -instance Ord t => Ord (FieldValue sch ('TPrimitive t)) where +instance Ord t => Ord (FieldValue w sch ('TPrimitive t)) where compare (FPrimitive x) (FPrimitive y) = compare x y -instance Ord (Term sch (sch :/: t)) => Ord (FieldValue sch ('TSchematic t)) where +instance Ord (Term w sch (sch :/: t)) => Ord (FieldValue w sch ('TSchematic t)) where compare (FSchematic x) (FSchematic y) = compare x y -instance Ord (FieldValue sch t) => Ord (FieldValue sch ('TOption t)) where +instance Ord (FieldValue w sch t) => Ord (FieldValue w sch ('TOption t)) where compare (FOption x) (FOption y) = compare x y -instance Ord (FieldValue sch t) => Ord (FieldValue sch ('TList t)) where +instance Ord (FieldValue w sch t) => Ord (FieldValue w sch ('TList t)) where compare (FList x) (FList y) = compare x y -instance (Ord (FieldValue sch k), Ord (FieldValue sch v)) - => Ord (FieldValue sch ('TMap k v)) where +instance (Ord (FieldValue w sch k), Ord (FieldValue w sch v)) + => Ord (FieldValue w sch ('TMap k v)) where compare (FMap x) (FMap y) = compare x y -instance ( All (Ord `Compose` FieldValue sch) choices - , All (Eq `Compose` FieldValue sch) choices ) - => Ord (FieldValue sch ('TUnion choices)) where +instance ( All (Ord `Compose` FieldValue w sch) choices + , All (Eq `Compose` FieldValue w sch) choices ) + => Ord (FieldValue w sch ('TUnion choices)) where compare (FUnion x) (FUnion y) = compare x y -instance Show (FieldValue sch 'TNull) where +instance Show (FieldValue w sch 'TNull) where show _ = "null" -instance Show t => Show (FieldValue sch ('TPrimitive t)) where +instance Show t => Show (FieldValue w sch ('TPrimitive t)) where show (FPrimitive x) = show x -instance Show (Term sch (sch :/: t)) => Show (FieldValue sch ('TSchematic t)) where +instance Show (Term w sch (sch :/: t)) => Show (FieldValue w sch ('TSchematic t)) where show (FSchematic x) = show x -instance Show (FieldValue sch t) => Show (FieldValue sch ('TOption t)) where +instance Show (FieldValue w sch t) => Show (FieldValue w sch ('TOption t)) where show (FOption Nothing) = "none" show (FOption (Just x)) = "some(" ++ show x ++ ")" -instance Show (FieldValue sch t) => Show (FieldValue sch ('TList t)) where +instance Show (FieldValue w sch t) => Show (FieldValue w sch ('TList t)) where show (FList xs) = show xs -instance (Show (FieldValue sch k), Show (FieldValue sch v)) - => Show (FieldValue sch ('TMap k v)) where +instance (Show (FieldValue w sch k), Show (FieldValue w sch v)) + => Show (FieldValue w sch ('TMap k v)) where show (FMap x) = show x -instance All (Show `Compose` FieldValue sch) choices - => Show (FieldValue sch ('TUnion choices)) where +instance All (Show `Compose` FieldValue w sch) choices + => Show (FieldValue w sch ('TUnion choices)) where show (FUnion x) = show x diff --git a/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs b/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs index 4d8641c5..f85d6261 100644 --- a/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs +++ b/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs @@ -13,61 +13,75 @@ import Data.SOP import Mu.Schema -data V0 sch sty where +data V0 w sch sty where V0 :: (sch :/: sty ~ 'DRecord nm '[]) - => V0 sch sty + => V0 w sch sty -deriving instance Show (V0 sch sty) -deriving instance Eq (V0 sch sty) -deriving instance Ord (V0 sch sty) +deriving instance Show (V0 w sch sty) +deriving instance Eq (V0 w sch sty) +deriving instance Ord (V0 w sch sty) instance (sch :/: sty ~ 'DRecord nm '[]) - => HasSchema sch sty (V0 sch sty) where + => ToSchema w sch sty (V0 w sch sty) where toSchema V0 = TRecord Nil +instance (sch :/: sty ~ 'DRecord nm '[]) + => FromSchema w sch sty (V0 w sch sty) where fromSchema (TRecord Nil) = V0 -data V1 sch sty where +data V1 w sch sty where V1 :: (sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) - => a -> V1 sch sty + => w a -> V1 w sch sty -deriving instance (Show a, sch :/: sty - ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) - => Show (V1 sch sty) -deriving instance (Eq a, sch :/: sty - ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) - => Eq (V1 sch sty) -deriving instance (Ord a, sch :/: sty - ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) - => Ord (V1 sch sty) +deriving instance (Show (w a), sch :/: sty + ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) + => Show (V1 w sch sty) +deriving instance (Eq (w a), sch :/: sty + ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) + => Eq (V1 w sch sty) +deriving instance (Ord (w a), sch :/: sty + ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) + => Ord (V1 w sch sty) -instance (sch :/: sty - ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) - => HasSchema sch sty (V1 sch sty) where - toSchema (V1 x) = TRecord (Field (FPrimitive x) :* Nil) - fromSchema (TRecord (Field (FPrimitive x) :* Nil)) = V1 x +instance ( Functor w + , sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ] ) + => ToSchema w sch sty (V1 w sch sty) where + toSchema (V1 x) = TRecord (Field (FPrimitive <$> x) :* Nil) +instance ( Functor w + , sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ] ) + => FromSchema w sch sty (V1 w sch sty) where + fromSchema (TRecord (Field x :* Nil)) = V1 (unPrimitive <$> x) + where unPrimitive :: FieldValue w sch ('TPrimitive t) -> t + unPrimitive (FPrimitive l) = l -data V2 sch sty where +data V2 w sch sty where V2 :: (sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) , 'FieldDef g ('TPrimitive b) ]) - => a -> b -> V2 sch sty + => w a -> w b -> V2 w sch sty -deriving instance (Show a, Show b, +deriving instance (Show (w a), Show (w b), sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) , 'FieldDef g ('TPrimitive b) ]) - => Show (V2 sch sty) -deriving instance (Eq a, Eq b, + => Show (V2 w sch sty) +deriving instance (Eq (w a), Eq (w b), sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) , 'FieldDef g ('TPrimitive b) ]) - => Eq (V2 sch sty) -deriving instance (Ord a, Ord b, + => Eq (V2 w sch sty) +deriving instance (Ord (w a), Ord (w b), sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) , 'FieldDef g ('TPrimitive b) ]) - => Ord (V2 sch sty) + => Ord (V2 w sch sty) -instance (sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) - , 'FieldDef g ('TPrimitive b) ]) - => HasSchema sch sty (V2 sch sty) where - toSchema (V2 x y) = TRecord (Field (FPrimitive x) :* Field (FPrimitive y) :* Nil) - fromSchema (TRecord (Field (FPrimitive x) :* Field (FPrimitive y) :* Nil)) = V2 x y +instance ( Functor w + , sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) + , 'FieldDef g ('TPrimitive b) ] ) + => ToSchema w sch sty (V2 w sch sty) where + toSchema (V2 x y) = TRecord (Field (FPrimitive <$> x) :* Field (FPrimitive <$> y) :* Nil) +instance ( Functor w + , sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) + , 'FieldDef g ('TPrimitive b) ] ) + => FromSchema w sch sty (V2 w sch sty) where + fromSchema (TRecord (Field x :* Field y :* Nil)) = V2 (unPrimitive <$> x) (unPrimitive <$> y) + where unPrimitive :: FieldValue w sch ('TPrimitive t) -> t + unPrimitive (FPrimitive l) = l diff --git a/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs b/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs index 1225f8e5..037bdcb9 100644 --- a/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs +++ b/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs @@ -32,54 +32,60 @@ import Mu.Schema.Definition import qualified Mu.Schema.Interpretation as S -- | Interpretation of a type in a schema. -data Term where - TRecord :: [Field] -> Term - TEnum :: Int -> Term - TSimple :: FieldValue -> Term - deriving (Eq, Ord, Show) +data Term (w :: * -> *) where + TRecord :: [Field w] -> Term w + TEnum :: Int -> Term w + TSimple :: FieldValue w -> Term w + +deriving instance Eq (w (FieldValue w)) => Eq (Term w) +deriving instance Ord (w (FieldValue w)) => Ord (Term w) +deriving instance Show (w (FieldValue w)) => Show (Term w) -- | Interpretation of a field. -data Field where - Field :: T.Text -> FieldValue -> Field - deriving (Eq, Ord, Show) +data Field (w :: * -> *) where + Field :: T.Text -> w (FieldValue w) -> Field w + +deriving instance Eq (w (FieldValue w)) => Eq (Field w) +deriving instance Ord (w (FieldValue w)) => Ord (Field w) +deriving instance Show (w (FieldValue w)) => Show (Field w) -- | Interpretation of a field type, by giving a value of that type. -data FieldValue where - FNull :: FieldValue - FPrimitive :: (Typeable t, Eq t, Ord t, Show t) => t -> FieldValue - FSchematic :: Term -> FieldValue - FOption :: Maybe FieldValue -> FieldValue - FList :: [FieldValue] -> FieldValue - FMap :: M.Map FieldValue FieldValue -> FieldValue +data FieldValue (w :: * -> *) where + FNull :: FieldValue w + FPrimitive :: (Typeable t, Eq t, Ord t, Show t) => t -> FieldValue w + FSchematic :: Term w -> FieldValue w + FOption :: Maybe (FieldValue w) -> FieldValue w + FList :: [FieldValue w] -> FieldValue w + FMap :: M.Map (FieldValue w) (FieldValue w) -> FieldValue w checkSchema - :: forall (s :: Schema tn fn) (t :: tn). - CheckSchema s (s :/: t) - => Proxy t -> Term -> Maybe (S.Term s (s :/: t)) + :: forall (s :: Schema tn fn) (t :: tn) (w :: * -> *). + (Traversable w, CheckSchema s (s :/: t)) + => Proxy t -> Term w -> Maybe (S.Term w s (s :/: t)) checkSchema _ = checkSchema' fromSchemalessTerm - :: forall sch t sty. - (HasSchema sch sty t, CheckSchema sch (sch :/: sty)) - => Term -> Maybe t -fromSchemalessTerm t = fromSchema @_ @_ @sch <$> checkSchema (Proxy @sty) t + :: forall sch w t sty. + (Traversable w, FromSchema w sch sty t, CheckSchema sch (sch :/: sty)) + => Term w -> Maybe t +fromSchemalessTerm t = fromSchema @_ @_ @w @sch <$> checkSchema (Proxy @sty) t -class ToSchemalessTerm t where - toSchemalessTerm :: t -> Term -class ToSchemalessValue t where - toSchemalessValue :: t -> FieldValue +class ToSchemalessTerm t w where + toSchemalessTerm :: t -> Term w +class ToSchemalessValue t w where + toSchemalessValue :: t -> FieldValue w class CheckSchema (s :: Schema tn fn) (t :: TypeDef tn fn) where - checkSchema' :: Term -> Maybe (S.Term s t) + checkSchema' :: Traversable w => Term w -> Maybe (S.Term w s t) class CheckSchemaFields (s :: Schema tn fn) (fields :: [FieldDef tn fn]) where - checkSchemaFields :: [Field] -> Maybe (NP (S.Field s) fields) + checkSchemaFields :: Traversable w => [Field w] -> Maybe (NP (S.Field w s) fields) class CheckSchemaEnum (choices :: [ChoiceDef fn]) where checkSchemaEnumInt :: Int -> Maybe (NS Proxy choices) checkSchemaEnumText :: T.Text -> Maybe (NS Proxy choices) class CheckSchemaValue (s :: Schema tn fn) (field :: FieldType tn) where - checkSchemaValue :: FieldValue -> Maybe (S.FieldValue s field) + checkSchemaValue :: Traversable w => FieldValue w -> Maybe (S.FieldValue w s field) class CheckSchemaUnion (s :: Schema tn fn) (ts :: [FieldType tn]) where - checkSchemaUnion :: FieldValue -> Maybe (NS (S.FieldValue s) ts) + checkSchemaUnion :: Traversable w => FieldValue w -> Maybe (NS (S.FieldValue w s) ts) instance CheckSchemaFields s fields => CheckSchema s ('DRecord nm fields) where checkSchema' (TRecord fields) = S.TRecord <$> checkSchemaFields fields @@ -91,7 +97,7 @@ instance (KnownName nm, CheckSchemaValue s ty, CheckSchemaFields s rest) checkSchemaFields fs = do let name = T.pack (nameVal (Proxy @nm)) Field _ v <- find (\(Field fieldName _) -> fieldName == name) fs - v' <- checkSchemaValue v + v' <- traverse checkSchemaValue v r' <- checkSchemaFields @_ @_ @s @rest fs return (S.Field v' :* r') @@ -149,8 +155,8 @@ instance (CheckSchemaValue s t, CheckSchemaUnion s ts) checkSchemaUnion x = Z <$> checkSchemaValue @_ @_ @s @t x <|> S <$> checkSchemaUnion x -- Boring instances -deriving instance Show FieldValue -instance Eq FieldValue where +deriving instance (Show (w (FieldValue w))) => Show (FieldValue w) +instance (Eq (w (FieldValue w))) => Eq (FieldValue w) where FNull == FNull = True FPrimitive (x :: a) == FPrimitive (y :: b) = case eqT @a @b of @@ -161,7 +167,7 @@ instance Eq FieldValue where FList x == FList y = x == y FMap x == FMap y = x == y _ == _ = False -instance Ord FieldValue where +instance (Ord (w (FieldValue w))) => Ord (FieldValue w) where FNull <= _ = True FPrimitive _ <= FNull = False FPrimitive (x :: a) <= FPrimitive (y :: b) diff --git a/core/schema/src/Mu/Schema/Registry.hs b/core/schema/src/Mu/Schema/Registry.hs index 283c79af..ee083b00 100644 --- a/core/schema/src/Mu/Schema/Registry.hs +++ b/core/schema/src/Mu/Schema/Registry.hs @@ -27,16 +27,16 @@ import qualified Mu.Schema.Interpretation.Schemaless as SLess type Registry = Mappings Nat Schema' -fromRegistry :: forall r t. - FromRegistry r t - => SLess.Term -> Maybe t +fromRegistry :: forall r t w. FromRegistry w r t + => SLess.Term w -> Maybe t fromRegistry = fromRegistry' (Proxy @r) -class FromRegistry (ms :: Registry) (t :: Type) where - fromRegistry' :: Proxy ms -> SLess.Term -> Maybe t +class FromRegistry (w :: * -> *) (ms :: Registry) (t :: Type) where + fromRegistry' :: Proxy ms -> SLess.Term w -> Maybe t -instance FromRegistry '[] t where +instance FromRegistry w '[] t where fromRegistry' _ _ = Nothing -instance (HasSchema s sty t, SLess.CheckSchema s (s :/: sty), FromRegistry ms t) - => FromRegistry ( (n ':-> s) ': ms) t where - fromRegistry' _ t = SLess.fromSchemalessTerm @s t <|> fromRegistry' (Proxy @ms) t +instance ( Traversable w, FromSchema w s sty t + , SLess.CheckSchema s (s :/: sty), FromRegistry w ms t ) + => FromRegistry w ((n ':-> s) ': ms) t where + fromRegistry' _ t = SLess.fromSchemalessTerm @s @w t <|> fromRegistry' (Proxy @ms) t diff --git a/examples/health-check/src/ClientRecord.hs b/examples/health-check/src/ClientRecord.hs index fd109e3d..6cdb5aed 100644 --- a/examples/health-check/src/ClientRecord.hs +++ b/examples/health-check/src/ClientRecord.hs @@ -46,7 +46,7 @@ main = do -- Setup the client simple :: HealthCall -> String -> IO () simple client who = do - let hcm = HealthCheckMsg (T.pack who) + let hcm = HealthCheckMsg (Just $ T.pack who) putStrLn ("UNARY: Is there some server named " <> who <> "?") rknown <- check client hcm putStrLn ("UNARY: Actually the status is " <> show rknown) @@ -58,15 +58,15 @@ simple client who = do update :: HealthCall -> String -> String -> IO () update client who newstatus = do - let hcm = HealthCheckMsg (T.pack who) + let hcm = HealthCheckMsg (Just $ T.pack who) putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus) - r <- setStatus client (HealthStatusMsg hcm (ServerStatusMsg (T.pack newstatus))) + r <- setStatus client (HealthStatusMsg (Just hcm) (Just $ ServerStatusMsg (Just $ T.pack newstatus))) putStrLn ("UNARY: Was setting successful? " <> show r) rstatus <- check client hcm putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus) watching :: HealthCall -> String -> IO () watching client who = do - let hcm = HealthCheckMsg (T.pack who) + let hcm = HealthCheckMsg (Just $ T.pack who) stream <- watch client hcm runConduit $ stream .| C.mapM_ print diff --git a/examples/health-check/src/ClientTyApps.hs b/examples/health-check/src/ClientTyApps.hs index de7b0a13..9a4c377b 100644 --- a/examples/health-check/src/ClientTyApps.hs +++ b/examples/health-check/src/ClientTyApps.hs @@ -31,7 +31,7 @@ main = do -- Setup the client simple :: GrpcClient -> String -> IO () simple client who = do - let hcm = HealthCheckMsg (T.pack who) + let hcm = HealthCheckMsg $ Just (T.pack who) putStrLn ("UNARY: Is there some server named " <> who <> "?") rknown :: GRpcReply ServerStatusMsg <- gRpcCall @HealthCheckService @"check" client hcm @@ -45,10 +45,10 @@ simple client who = do update :: GrpcClient -> String -> String -> IO () update client who newstatus = do - let hcm = HealthCheckMsg (T.pack who) + let hcm = HealthCheckMsg $ Just (T.pack who) putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus) r <- gRpcCall @HealthCheckService @"setStatus" client - (HealthStatusMsg hcm (ServerStatusMsg (T.pack newstatus))) + (HealthStatusMsg (Just hcm) (Just $ ServerStatusMsg (Just $ T.pack newstatus))) putStrLn ("UNARY: Was setting successful? " <> show r) rstatus :: GRpcReply ServerStatusMsg <- gRpcCall @HealthCheckService @"check" client hcm @@ -56,6 +56,6 @@ update client who newstatus = do watching :: GrpcClient -> String -> IO () watching client who = do - let hcm = HealthCheckMsg (T.pack who) + let hcm = HealthCheckMsg $ Just (T.pack who) replies <- gRpcCall @HealthCheckService @"watch" client hcm runConduit $ replies .| C.mapM_ (print :: GRpcReply ServerStatusMsg -> IO ()) diff --git a/examples/health-check/src/Definition.hs b/examples/health-check/src/Definition.hs index 59487b51..46b6d3b5 100644 --- a/examples/health-check/src/Definition.hs +++ b/examples/health-check/src/Definition.hs @@ -21,42 +21,22 @@ import Mu.Schema $(grpc "HealthCheckSchema" id "healthcheck.proto") newtype HealthCheckMsg - = HealthCheckMsg { nameService :: T.Text } - deriving (Eq, Show, Ord, Generic, HasSchema HealthCheckSchema "HealthCheck") + = HealthCheckMsg { nameService :: Maybe T.Text } + deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe HealthCheckSchema "HealthCheck" + , FromSchema Maybe HealthCheckSchema "HealthCheck" ) newtype ServerStatusMsg - = ServerStatusMsg { status :: T.Text } - deriving (Eq, Show, Ord, Generic, HasSchema HealthCheckSchema "ServerStatus") + = ServerStatusMsg { status :: Maybe T.Text } + deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe HealthCheckSchema "ServerStatus" + , FromSchema Maybe HealthCheckSchema "ServerStatus" ) data HealthStatusMsg - = HealthStatusMsg { hc :: HealthCheckMsg, status :: ServerStatusMsg } - deriving (Eq, Show, Ord, Generic, HasSchema HealthCheckSchema "HealthStatus") + = HealthStatusMsg { hc :: Maybe HealthCheckMsg, status :: Maybe ServerStatusMsg } + deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe HealthCheckSchema "HealthStatus" + , FromSchema Maybe HealthCheckSchema "HealthStatus" ) newtype AllStatusMsg - = AllStatusMsg { all :: [HealthStatusMsg] } - deriving (Eq, Show, Ord, Generic, HasSchema HealthCheckSchema "AllStatus") - -{- --- Schema for data serialization -type HealthCheckSchema - = '[ 'DRecord "HealthCheck" '[] - '[ 'FieldDef "nameService" '[ ProtoBufId 1] ('TPrimitive T.Text) ] - , 'DRecord "ServerStatus" '[] - '[ 'FieldDef "status" '[ ProtoBufId 1 ] ('TPrimitive T.Text) ] - , 'DRecord "HealthStatus" '[] - '[ 'FieldDef "hc" '[ ProtoBufId 1 ] ('TSchematic "HealthCheck") - , 'FieldDef "status" '[ ProtoBufId 2 ] ('TSchematic "ServerStatus") ] - , 'DRecord "AllStatus" '[] - '[ 'FieldDef "all" '[ ProtoBufId 1 ] ('TList ('TSchematic "HealthStatus")) ] - ] - --- Service definition --- https://github.com/higherkindness/mu/blob/master/modules/health-check-unary/src/main/scala/higherkindness/mu/rpc/healthcheck/unary/service.scala -type HS = 'FromSchema HealthCheckSchema -type HealthCheckService - = 'Service "HealthCheckService" '[Package "healthcheck"] - '[ 'Method "setStatus" '[] '[ 'ArgSingle (HS "HealthStatus") ] 'RetNothing - , 'Method "check" '[] '[ 'ArgSingle (HS "HealthCheck") ] ('RetSingle (HS "ServerStatus")) - , 'Method "clearStatus" '[] '[ 'ArgSingle (HS "HealthCheck") ] 'RetNothing - , 'Method "checkAll" '[] '[ ] ('RetSingle (HS "AllStatus")) - , 'Method "cleanAll" '[] '[ ] 'RetNothing - , 'Method "watch" '[] '[ 'ArgSingle (HS "HealthCheck") ] ('RetStream (HS "ServerStatus")) - ] --} + = AllStatusMsg { all :: Maybe [HealthStatusMsg] } + deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe HealthCheckSchema "AllStatus" + , FromSchema Maybe HealthCheckSchema "AllStatus" ) diff --git a/examples/health-check/src/Server.hs b/examples/health-check/src/Server.hs index 634bfb00..5eda482f 100644 --- a/examples/health-check/src/Server.hs +++ b/examples/health-check/src/Server.hs @@ -8,7 +8,6 @@ import Control.Concurrent.STM import Data.Conduit import qualified Data.Conduit.Combinators as C import Data.Conduit.TMChan -import Data.Maybe import qualified Data.Text as T import DeferredFolds.UnfoldlM import qualified StmContainers.Map as M @@ -31,36 +30,41 @@ main = do type StatusMap = M.Map T.Text T.Text type StatusUpdates = TBMChan HealthStatusMsg -server :: StatusMap -> StatusUpdates -> ServerIO HealthCheckService _ +server :: StatusMap -> StatusUpdates -> ServerIO Maybe HealthCheckService _ server m upd = Server (setStatus_ m upd :<|>: checkH_ m :<|>: clearStatus_ m :<|>: checkAll_ m :<|>: cleanAll_ m :<|>: watch_ upd :<|>: H0) setStatus_ :: StatusMap -> StatusUpdates -> HealthStatusMsg -> ServerErrorIO () -setStatus_ m upd s@(HealthStatusMsg (HealthCheckMsg nm) (ServerStatusMsg ss)) = alwaysOk $ do - putStr "setStatus: " >> print (nm, ss) - atomically $ do - M.insert ss nm m - writeTBMChan upd s +setStatus_ m upd + s@(HealthStatusMsg (Just (HealthCheckMsg (Just nm))) (Just (ServerStatusMsg (Just ss)))) + = alwaysOk $ do + putStr "setStatus: " >> print (nm, ss) + atomically $ do + M.insert ss nm m + writeTBMChan upd s +setStatus_ _ _ _ = serverError (ServerError Invalid "name or status missing") checkH_ :: StatusMap -> HealthCheckMsg -> ServerErrorIO ServerStatusMsg -checkH_ m (HealthCheckMsg nm) = alwaysOk $ do +checkH_ m (HealthCheckMsg (Just nm)) = alwaysOk $ do putStr "check: " >> print nm ss <- atomically $ M.lookup nm m - return $ ServerStatusMsg (fromMaybe "UNKNOWN" ss) + return $ ServerStatusMsg ss +checkH_ _ _ = serverError (ServerError Invalid "no server name given") clearStatus_ :: StatusMap -> HealthCheckMsg -> ServerErrorIO () -clearStatus_ m (HealthCheckMsg nm) = alwaysOk $ do +clearStatus_ m (HealthCheckMsg (Just nm)) = alwaysOk $ do putStr "clearStatus: " >> print nm atomically $ M.delete nm m +clearStatus_ _ _ = return () checkAll_ :: StatusMap -> ServerErrorIO AllStatusMsg checkAll_ m = alwaysOk $ do putStrLn "checkAll" - AllStatusMsg <$> atomically (consumeValues kvToStatus (M.unfoldlM m)) + AllStatusMsg . Just <$> atomically (consumeValues kvToStatus (M.unfoldlM m)) where consumeValues :: Monad m => (k -> v -> a) -> UnfoldlM m (k,v) -> m [a] consumeValues f = foldlM' (\xs (x,y) -> pure (f x y:xs)) [] - kvToStatus k v = HealthStatusMsg (HealthCheckMsg k) (ServerStatusMsg v) + kvToStatus k v = HealthStatusMsg (Just (HealthCheckMsg (Just k))) (Just (ServerStatusMsg (Just v))) cleanAll_ :: StatusMap -> ServerErrorIO () cleanAll_ m = alwaysOk $ do @@ -74,6 +78,13 @@ watch_ :: StatusUpdates watch_ upd hcm@(HealthCheckMsg nm) sink = do alwaysOk (putStr "watch: " >> print nm) runConduit $ sourceTBMChan upd - .| C.filter (\(HealthStatusMsg c _) -> hcm == c) + .| C.filter (\(HealthStatusMsg c _) -> Just hcm == c) .| C.map (\(HealthStatusMsg _ s) -> s) + .| catMaybesC .| sink + where + catMaybesC = do x <- await + case x of + Just (Just y) -> yield y >> catMaybesC + Just Nothing -> catMaybesC + Nothing -> return () diff --git a/examples/route-guide/src/Definition.hs b/examples/route-guide/src/Definition.hs index ba1be268..079142d6 100644 --- a/examples/route-guide/src/Definition.hs +++ b/examples/route-guide/src/Definition.hs @@ -22,24 +22,34 @@ import Mu.Schema $(grpc "RouteGuideSchema" id "routeguide.proto") data Point - = Point { latitude, longitude :: Int32 } - deriving (Eq, Show, Ord, Generic, Hashable, HasSchema RouteGuideSchema "Point") + = Point { latitude, longitude :: Maybe Int32 } + deriving ( Eq, Show, Ord, Generic, Hashable + , ToSchema Maybe RouteGuideSchema "Point" + , FromSchema Maybe RouteGuideSchema "Point" ) data Rectangle - = Rectangle { lo, hi :: Point } - deriving (Eq, Show, Ord, Generic, HasSchema RouteGuideSchema "Rectangle") + = Rectangle { lo, hi :: Maybe Point } + deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe RouteGuideSchema "Rectangle" + , FromSchema Maybe RouteGuideSchema "Rectangle" ) data Feature - = Feature { name :: T.Text, location :: Point } - deriving (Eq, Show, Ord, Generic, HasSchema RouteGuideSchema "Feature") + = Feature { name :: Maybe T.Text, location :: Maybe Point } + deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe RouteGuideSchema "Feature" + , FromSchema Maybe RouteGuideSchema "Feature" ) -- Not used in the service -- newtype FeatureDb -- = FeatureDb { feature :: [Feature] } -- deriving (Eq, Show, Ord, Generic, HasSchema RouteGuideSchema "FeatureDatabase") data RouteNote - = RouteNote { message :: T.Text, location :: Point } - deriving (Eq, Show, Ord, Generic, HasSchema RouteGuideSchema "RouteNote") + = RouteNote { message :: Maybe T.Text, location :: Maybe Point } + deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe RouteGuideSchema "RouteNote" + , FromSchema Maybe RouteGuideSchema "RouteNote" ) data RouteSummary - = RouteSummary { point_count, feature_count, distance, elapsed_time :: Int32 } - deriving (Eq, Show, Ord, Generic, HasSchema RouteGuideSchema "RouteSummary") + = RouteSummary { point_count, feature_count, distance, elapsed_time :: Maybe Int32 } + deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe RouteGuideSchema "RouteSummary" + , FromSchema Maybe RouteGuideSchema "RouteSummary" ) {- type RG = 'FromSchema RouteGuideSchema diff --git a/examples/route-guide/src/Server.hs b/examples/route-guide/src/Server.hs index 5ce3ec0d..088618a1 100644 --- a/examples/route-guide/src/Server.hs +++ b/examples/route-guide/src/Server.hs @@ -15,7 +15,6 @@ import Data.Conduit import qualified Data.Conduit.Combinators as C import Data.Conduit.Lift (runExceptC) import Data.Conduit.List (sourceList) -import Data.Function ((&)) import Data.Int import Data.List (find) import Data.Maybe @@ -39,17 +38,20 @@ main = do type Features = [Feature] findFeatureIn :: Features -> Point -> Maybe Feature -findFeatureIn features p = find (\(Feature _ loc) -> loc == p) features +findFeatureIn features p = find (\(Feature _ loc) -> loc == Just p) features withinBounds :: Rectangle -> Point -> Bool -withinBounds (Rectangle (Point lox loy) (Point hix hiy)) (Point x y) +withinBounds (Rectangle (Just (Point (Just lox) (Just loy))) (Just (Point (Just hix) (Just hiy)))) + (Point (Just x) (Just y)) = x >= lox && x <= hix && y >= loy && y <= hiy +withinBounds _ _ + = False featuresWithinBounds :: Features -> Rectangle -> Features -featuresWithinBounds fs rect = filter (\(Feature _ loc) -> withinBounds rect loc) fs +featuresWithinBounds fs rect = filter (\(Feature _ loc) -> maybe False (withinBounds rect) loc) fs -calcDistance :: Point -> Point -> Int32 -calcDistance (Point lat1 lon1) (Point lat2 lon2) +calcDistance :: Point -> Point -> Maybe Int32 +calcDistance (Point (Just lat1) (Just lon1)) (Point (Just lat2) (Just lon2)) = let r = 6371000 Radians (phi1 :: Double) = radians (Degrees (int32ToDouble lat1)) Radians (phi2 :: Double) = radians (Degrees (int32ToDouble lat2)) @@ -58,19 +60,21 @@ calcDistance (Point lat1 lon1) (Point lat2 lon2) a = sin (deltaPhi / 2) * sin (deltaPhi / 2) + cos phi1 * cos phi2 * sin (deltaLambda / 2) * sin (deltaLambda / 2) c = 2 * atan2 (sqrt a) (sqrt (1 - a)) - in fromInteger $ r * ceiling c + in Just (fromInteger $ r * ceiling c) where int32ToDouble :: Int32 -> Double int32ToDouble = fromInteger . toInteger +calcDistance _ _ = Nothing -- Server implementation -- https://github.com/higherkindness/mu/blob/master/modules/examples/routeguide/server/src/main/scala/handlers/RouteGuideServiceHandler.scala -server :: Features -> TBMChan RouteNote -> ServerIO RouteGuideService _ +server :: Features -> TBMChan RouteNote -> ServerIO Maybe RouteGuideService _ server f m = Server (getFeature f :<|>: listFeatures f :<|>: recordRoute f :<|>: routeChat m :<|>: H0) getFeature :: Features -> Point -> ServerErrorIO Feature -getFeature fs p = return $ fromMaybe (Feature "" (Point 0 0)) (findFeatureIn fs p) +getFeature fs p = return $ fromMaybe nilFeature (findFeatureIn fs p) + where nilFeature = Feature (Just "") (Just (Point (Just 0) (Just 0))) listFeatures :: Features -> Rectangle -> ConduitT Feature Void ServerErrorIO () @@ -82,19 +86,23 @@ recordRoute :: Features -> ServerErrorIO RouteSummary recordRoute fs ps = do initialTime <- liftIO getCurrentTime - (\(rs, _, _) -> rs) <$> runConduit (ps .| C.foldM step (RouteSummary 0 0 0 0, Nothing, initialTime)) + (\(rs, _, _) -> rs) <$> runConduit (ps .| C.foldM step (initial, Nothing, initialTime)) where + initial = RouteSummary (Just 0) (Just 0) (Just 0) (Just 0) step :: (RouteSummary, Maybe Point, UTCTime) -> Point -> ServerErrorIO (RouteSummary, Maybe Point, UTCTime) step (summary, previous, startTime) point = do currentTime <- liftIO getCurrentTime let feature = findFeatureIn fs point - new_distance = fmap (`calcDistance` point) previous & fromMaybe 0 + new_distance = case previous of + Nothing -> Just 0 + Just d -> d `calcDistance` point new_elapsed = diffUTCTime currentTime startTime - new_summary = RouteSummary (point_count summary + 1) - (feature_count summary + if isJust feature then 1 else 0) - (distance summary + new_distance) - (floor new_elapsed) + update_feature_count = if isJust feature then 1 else 0 + new_summary = RouteSummary ((1 +) <$> point_count summary) + ((update_feature_count +) <$> feature_count summary) + ((+) <$> distance summary <*> new_distance) + (Just $ floor new_elapsed) return (new_summary, Just point, startTime) routeChat :: TBMChan RouteNote @@ -106,7 +114,7 @@ routeChat notesMap inS outS = do -- Start two threads, one to listen, one to send let inA = runConduit $ runExceptC $ inS .| C.mapM_ (addNoteToMap toWatch) outA = runConduit $ runExceptC $ - readStmMap (\l1 (RouteNote _ l2)-> l1 == l2) toWatch notesMap .| outS + readStmMap (\l1 (RouteNote _ l2)-> Just l1 == l2) toWatch notesMap .| outS res <- liftIO $ concurrently inA outA case res of (Right _, Right _) -> return () @@ -114,10 +122,11 @@ routeChat notesMap inS outS = do (_, Left e) -> serverError e where addNoteToMap :: TMVar Point -> RouteNote -> ServerErrorIO () - addNoteToMap toWatch newNote@(RouteNote _ loc) = liftIO $ atomically $ do + addNoteToMap toWatch newNote@(RouteNote _ (Just loc)) = liftIO $ atomically $ do _ <- tryTakeTMVar toWatch putTMVar toWatch loc writeTBMChan notesMap newNote + addNoteToMap _toWatch _ = return () readStmMap :: (MonadIO m, Show b) => (a -> b -> Bool) -> TMVar a -> TBMChan b -> ConduitT () b m () readStmMap p toWatch m = go diff --git a/examples/seed/src/Main.hs b/examples/seed/src/Main.hs index 1f695a71..8f9d1db7 100644 --- a/examples/seed/src/Main.hs +++ b/examples/seed/src/Main.hs @@ -24,11 +24,11 @@ main = do -- Server implementation -- https://github.com/higherkindness/mu/blob/master/modules/examples/seed/server/modules/process/src/main/scala/example/seed/server/process/ProtoPeopleServiceHandler.scala -server :: (MonadServer m, MonadLogger m) => ServerT PeopleService m _ +server :: (MonadServer m, MonadLogger m) => ServerT Maybe PeopleService m _ server = Server (getPerson :<|>: getPersonStream :<|>: H0) evolvePerson :: PeopleRequest -> PeopleResponse -evolvePerson (PeopleRequest n) = PeopleResponse $ Person n 18 +evolvePerson (PeopleRequest n) = PeopleResponse $ Just $ Person n (Just 18) getPerson :: Monad m => PeopleRequest -> m PeopleResponse getPerson = pure . evolvePerson diff --git a/examples/seed/src/Schema.hs b/examples/seed/src/Schema.hs index 7e3b721d..80ef7eed 100644 --- a/examples/seed/src/Schema.hs +++ b/examples/seed/src/Schema.hs @@ -22,14 +22,20 @@ import Mu.Schema grpc "SeedSchema" id "seed.proto" data Person = Person - { name :: T.Text - , age :: Int32 - } deriving (Eq, Show, Ord, Generic, HasSchema SeedSchema "Person") + { name :: Maybe T.Text + , age :: Maybe Int32 + } deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe SeedSchema "Person" + , FromSchema Maybe SeedSchema "Person" ) newtype PeopleRequest = PeopleRequest - { name :: T.Text - } deriving (Eq, Show, Ord, Generic, HasSchema SeedSchema "PeopleRequest") + { name :: Maybe T.Text + } deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe SeedSchema "PeopleRequest" + , FromSchema Maybe SeedSchema "PeopleRequest" ) newtype PeopleResponse = PeopleResponse - { person :: Person - } deriving (Eq, Show, Ord, Generic, HasSchema SeedSchema "PeopleResponse") + { person :: Maybe Person + } deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe SeedSchema "PeopleResponse" + , FromSchema Maybe SeedSchema "PeopleResponse" ) diff --git a/examples/todolist/src/Definition.hs b/examples/todolist/src/Definition.hs index dc197238..2f90b672 100644 --- a/examples/todolist/src/Definition.hs +++ b/examples/todolist/src/Definition.hs @@ -9,7 +9,6 @@ {-# language TemplateHaskell #-} {-# language TypeFamilies #-} {-# language TypeOperators #-} - module Definition where import Data.Int @@ -22,24 +21,34 @@ import Mu.Schema grpc "TodoListSchema" id "todolist.proto" newtype MessageId = MessageId - { value :: Int32 - } deriving (Eq, Show, Ord, Generic, HasSchema TodoListSchema "MessageId") + { value :: Maybe Int32 + } deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe TodoListSchema "MessageId" + , FromSchema Maybe TodoListSchema "MessageId" ) data TodoListMessage = TodoListMessage - { id, tagId :: Int32 - , title :: Text - , completed :: Bool - } deriving (Eq, Show, Ord, Generic, HasSchema TodoListSchema "TodoListMessage") + { id, tagId :: Maybe Int32 + , title :: Maybe Text + , completed :: Maybe Bool + } deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe TodoListSchema "TodoListMessage" + , FromSchema Maybe TodoListSchema "TodoListMessage" ) data TodoListRequest = TodoListRequest - { title :: Text - , tagId :: Int32 - } deriving (Eq, Show, Ord, Generic, HasSchema TodoListSchema "TodoListRequest") + { title :: Maybe Text + , tagId :: Maybe Int32 + } deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe TodoListSchema "TodoListRequest" + , FromSchema Maybe TodoListSchema "TodoListRequest" ) newtype TodoListList = TodoListList - { list :: [TodoListMessage] - } deriving (Eq, Show, Ord, Generic, HasSchema TodoListSchema "TodoListList") + { list :: Maybe [TodoListMessage] + } deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe TodoListSchema "TodoListList" + , FromSchema Maybe TodoListSchema "TodoListList" ) newtype TodoListResponse = TodoListResponse - { msg :: TodoListMessage - } deriving (Eq, Show, Ord, Generic, HasSchema TodoListSchema "TodoListResponse") + { msg :: Maybe TodoListMessage + } deriving ( Eq, Show, Ord, Generic + , ToSchema Maybe TodoListSchema "TodoListResponse" + , FromSchema Maybe TodoListSchema "TodoListResponse" ) diff --git a/examples/todolist/src/Server.hs b/examples/todolist/src/Server.hs index cf2c4d26..7105871a 100644 --- a/examples/todolist/src/Server.hs +++ b/examples/todolist/src/Server.hs @@ -2,6 +2,7 @@ {-# language NamedFieldPuns #-} {-# language OverloadedStrings #-} {-# language PartialTypeSignatures #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Main where @@ -9,6 +10,7 @@ import Control.Concurrent.STM import Control.Monad.IO.Class (liftIO) import Data.Int import Data.List (find) +import Data.Maybe (maybe) import Mu.GRpc.Server import Mu.Server @@ -29,7 +31,7 @@ main = do type Id = TVar Int32 type TodoList = TVar [TodoListMessage] -server :: Id -> TodoList -> ServerIO TodoListService _ +server :: Id -> TodoList -> ServerIO Maybe TodoListService _ server i t = Server (reset i t :<|>: insert i t :<|>: retrieve t :<|>: list_ t :<|>: update t :<|>: destroy t :<|>: H0) @@ -39,7 +41,7 @@ reset i t = alwaysOk $ do atomically $ do writeTVar i 0 writeTVar t [] - pure $ MessageId 0 -- returns nothing + pure $ MessageId Nothing -- returns nothing insert :: Id -> TodoList -> TodoListRequest -> ServerErrorIO TodoListResponse insert oldId t (TodoListRequest titl tgId) = alwaysOk $ do @@ -47,41 +49,45 @@ insert oldId t (TodoListRequest titl tgId) = alwaysOk $ do atomically $ do modifyTVar oldId (+1) newId <- readTVar oldId - let newTodo = TodoListMessage newId tgId titl False + let newTodo = TodoListMessage (Just newId) tgId titl (Just False) modifyTVar t (newTodo:) - pure $ TodoListResponse newTodo + pure $ TodoListResponse (Just newTodo) getMsg :: Int32 -> TodoListMessage -> Bool -getMsg x TodoListMessage {id} = id == x +getMsg x TodoListMessage {id} = id == Just x retrieve :: TodoList -> MessageId -> ServerErrorIO TodoListResponse -retrieve t (MessageId idMsg) = do +retrieve t (MessageId (Just idMsg)) = do liftIO (putStr "retrieve: " >> print idMsg) todos <- liftIO $ readTVarIO t case find (getMsg idMsg) todos of - Just todo -> pure $ TodoListResponse todo + Just todo -> pure $ TodoListResponse (Just todo) Nothing -> serverError $ ServerError NotFound "unknown todolist id" +retrieve _ _ = serverError $ ServerError Invalid "missing todolist id" list_ :: TodoList -> ServerErrorIO TodoListList list_ t = alwaysOk $ do putStrLn "list" atomically $ do todos <- readTVar t - pure $ TodoListList todos + pure $ TodoListList (Just todos) update :: TodoList -> TodoListMessage -> ServerErrorIO TodoListResponse -update t mg@(TodoListMessage idM titM tgM compl) = alwaysOk $ do +update t mg@(TodoListMessage (Just idM) titM tgM compl) = alwaysOk $ do putStr "update: " >> print (idM, titM, tgM, compl) atomically $ modifyTVar t $ fmap (\m -> if getMsg idM m then mg else m) - pure $ TodoListResponse mg + pure $ TodoListResponse (Just mg) +update _ _ = serverError $ ServerError Invalid "missing todolist message id" destroy :: TodoList -> MessageId -> ServerErrorIO MessageId -destroy t (MessageId idMsg) = alwaysOk $ do - putStr "destroy: " >> print idMsg - atomically $ do - todos <- readTVar t - case find (getMsg idMsg) todos of - Just todo -> do - modifyTVar t $ filter (/=todo) - pure $ MessageId idMsg -- OK ✅ - Nothing -> pure $ MessageId 0 -- did nothing +destroy t (MessageId (Just idMsg)) = do + liftIO (putStr "destroy: ") >> liftIO (print idMsg) + r <- liftIO $ atomically $ do + todos <- readTVar t + case find (getMsg idMsg) todos of + Just todo -> do + modifyTVar t $ filter (/=todo) + pure $ Just (MessageId (Just idMsg)) -- OK ✅ + Nothing -> pure Nothing -- did nothing + maybe (serverError $ ServerError NotFound "unknown message id") return r +destroy _ _ = serverError $ ServerError Invalid "missing message id" diff --git a/examples/with-persistent/src/Client.hs b/examples/with-persistent/src/Client.hs index 3359ed85..b36f9688 100644 --- a/examples/with-persistent/src/Client.hs +++ b/examples/with-persistent/src/Client.hs @@ -5,15 +5,14 @@ {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} {-# language TypeOperators #-} - +{-# options_ghc -fno-warn-name-shadowing #-} module Main where import Data.Conduit import qualified Data.Conduit.Combinators as C import qualified Data.Text as T -import Database.Persist.Sql (toSqlKey) -import Database.Persist.Types (Entity(..)) import System.Environment +import Text.Read (readMaybe) import Mu.GRpc.Client.TyApps @@ -32,21 +31,21 @@ main = do get :: GrpcClient -> String -> IO () get client idPerson = do - let req = PersonRequest $ read idPerson + let req = MPersonRequest $ readMaybe idPerson putStrLn ("GET: Is there some person with id: " ++ idPerson ++ "?") - rknown :: GRpcReply (Entity Person) + rknown :: GRpcReply MPerson <- gRpcCall @PersistentService @"getPerson" client req putStrLn ("GET: response was: " ++ show rknown) add :: GrpcClient -> String -> String -> IO () add client name age = do - let p = Entity (toSqlKey 1) (Person (T.pack name) (read age)) + let p = MPerson Nothing (Just $ T.pack name) (readMaybe age) putStrLn ("ADD: Creating new person " <> name <> " with age " <> age) - response :: GRpcReply PersonRequest + response :: GRpcReply MPersonRequest <- gRpcCall @PersistentService @"newPerson" client p putStrLn ("ADD: Was creating successful? " <> show response) watching :: GrpcClient -> IO () watching client = do replies <- gRpcCall @PersistentService @"allPeople" client - runConduit $ replies .| C.mapM_ (print :: GRpcReply (Entity Person) -> IO ()) + runConduit $ replies .| C.mapM_ (print :: GRpcReply MPerson -> IO ()) diff --git a/examples/with-persistent/src/Schema.hs b/examples/with-persistent/src/Schema.hs index 0dae7829..4d586dc4 100644 --- a/examples/with-persistent/src/Schema.hs +++ b/examples/with-persistent/src/Schema.hs @@ -1,5 +1,6 @@ {-# language DataKinds #-} {-# language DeriveGeneric #-} +{-# language DerivingVia #-} {-# language DuplicateRecordFields #-} {-# language EmptyDataDecls #-} {-# language FlexibleContexts #-} @@ -10,40 +11,91 @@ {-# language OverloadedStrings #-} {-# language PolyKinds #-} {-# language QuasiQuotes #-} +{-# language ScopedTypeVariables #-} {-# language StandaloneDeriving #-} {-# language TemplateHaskell #-} +{-# language TypeApplications #-} {-# language TypeFamilies #-} +{-# language TypeOperators #-} {-# language UndecidableInstances #-} module Schema where -import Data.Int (Int32, Int64) -import qualified Data.Text as T +import Data.Functor.Identity +import Data.Int (Int32, Int64) +import qualified Data.Text as T import Database.Persist.Sqlite import Database.Persist.TH import GHC.Generics +import GHC.TypeLits import Mu.Quasi.GRpc import Mu.Schema +import Mu.Schema.Class +import Mu.Schema.Interpretation grpc "PersistentSchema" id "with-persistent.proto" -newtype PersonRequest = PersonRequest - { identifier :: Int64 +newtype MPersonRequest = MPersonRequest + { identifier :: Maybe Int64 } deriving (Eq, Show, Ord, Generic) -instance HasSchema PersistentSchema "PersonRequest" PersonRequest +instance ToSchema Maybe PersistentSchema "PersonRequest" MPersonRequest +instance FromSchema Maybe PersistentSchema "PersonRequest" MPersonRequest share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| Person json name T.Text age Int32 - deriving Show + deriving Show Generic |] -deriving instance Generic Person +data MPerson = MPerson + { pid :: Maybe MPersonRequest + , name :: Maybe T.Text + , age :: Maybe Int32 } + deriving (Eq, Ord, Show, Generic) --- Unfortunately we need to write this instance by hand 😔 (for now!) -instance HasSchema PersistentSchema "Person" (Entity Person) where - fromSchema (TRecord (Field (FSchematic (TRecord (Field (FPrimitive pid) :* Nil))) :* Field (FPrimitive name) :* Field (FPrimitive age) :* Nil)) = Entity (PersonKey (SqlBackendKey pid)) (Person name age) - toSchema (Entity (PersonKey (SqlBackendKey pid)) (Person name age)) = TRecord $ Field (FSchematic (TRecord (Field (FPrimitive pid) :* Nil))) :* Field (FPrimitive name) :* Field (FPrimitive age) :* Nil +instance ToSchema Maybe PersistentSchema "Person" MPerson +instance FromSchema Maybe PersistentSchema "Person" MPerson + +newtype WithEntityPlainId (ty :: Symbol) (fmap :: Mappings Symbol Symbol) a + = WithEntityPlainId { unWithEntityPlainId :: a } +newtype WithEntityNestedId (ty :: Symbol) (fmap :: Mappings Symbol Symbol) a + = WithEntityNestedId { unWithEntityNestedId :: a } + +instance ( Generic t, Applicative w + , (sch :/: sty) ~ 'DRecord name (idArg ': args) + , idArg ~ 'Mu.Schema.FieldDef idArgName ('TPrimitive Int64) + , Rep t ~ D1 dInfo (C1 cInfo f) + , GToSchemaRecord Identity sch fmap args f + , ToBackendKey (PersistEntityBackend t) t + , PersistEntityBackend t ~ SqlBackend ) + => ToSchema w sch sty (WithEntityPlainId sty fmap (Entity t)) where + toSchema (WithEntityPlainId (Entity key x)) + = TRecord $ Field (pure $ FPrimitive (unSqlBackendKey $ toBackendKey key)) + :* transFieldsNoMaps up (toSchemaRecord (Proxy @fmap) (unM1 $ unM1 $ from x)) + where up :: Identity a -> w a + up (Identity i) = pure i + +instance ( Generic t, Applicative w + , (sch :/: sty) ~ 'DRecord name (nestedIdArg ': args) + , nestedIdArg ~ 'Mu.Schema.FieldDef fname ('TSchematic idTy) + , (sch :/: idTy) ~ 'DRecord idName '[idArg] + , idArg ~ 'Mu.Schema.FieldDef idArgName ('TPrimitive Int64) + , Rep t ~ D1 dInfo (C1 cInfo f) + , GToSchemaRecord Identity sch fmap args f + , ToBackendKey (PersistEntityBackend t) t + , PersistEntityBackend t ~ SqlBackend ) + => ToSchema w sch sty (WithEntityNestedId sty fmap (Entity t)) where + toSchema (WithEntityNestedId (Entity key x)) + = TRecord $ Field (pure $ FSchematic $ TRecord (Field (pure $ FPrimitive key') :* Nil)) + :* transFieldsNoMaps up (toSchemaRecord (Proxy @fmap) (unM1 $ unM1 $ from x)) + where key' = unSqlBackendKey $ toBackendKey key + up :: Identity a -> w a + up (Identity i) = pure i + +type PersonFieldMapping + = '[ "personAge" ':-> "age", "personName" ':-> "name" ] +deriving via (WithEntityNestedId "Person" PersonFieldMapping (Entity Person)) + instance ToSchema Maybe PersistentSchema "Person" (Entity Person) diff --git a/examples/with-persistent/src/Server.hs b/examples/with-persistent/src/Server.hs index e0e5f10d..a0bb837d 100644 --- a/examples/with-persistent/src/Server.hs +++ b/examples/with-persistent/src/Server.hs @@ -3,6 +3,7 @@ {-# language PartialTypeSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Main where @@ -24,13 +25,13 @@ main = do liftIO $ flip runSqlPersistM conn $ runMigration migrateAll liftIO $ runGRpcApp 1234 (server conn) -server :: SqlBackend -> ServerT PersistentService ServerErrorIO _ +server :: SqlBackend -> ServerT Maybe PersistentService ServerErrorIO _ server p = Server (getPerson p :<|>: newPerson p :<|>: allPeople p :<|>: H0) runDb = (liftIO .) . flip runSqlPersistM -getPerson :: SqlBackend -> PersonRequest -> ServerErrorIO (Entity Person) -getPerson conn (PersonRequest idf) = do +getPerson :: SqlBackend -> MPersonRequest -> ServerErrorIO (Entity Person) +getPerson conn (MPersonRequest (Just idf)) = do r <- runDb conn $ do let pId = PersonKey $ SqlBackendKey idf maybePerson <- get pId @@ -38,11 +39,13 @@ getPerson conn (PersonRequest idf) = do case r of Just p -> pure p Nothing -> serverError $ ServerError NotFound "unknown person" +getPerson _ _ = serverError $ ServerError Invalid "missing person id" -newPerson :: SqlBackend -> Entity Person -> ServerErrorIO PersonRequest -newPerson conn (Entity _ p@(Person name _)) = runDb conn $ do - PersonKey (SqlBackendKey nId) <- insert p - pure $ PersonRequest nId +newPerson :: SqlBackend -> MPerson -> ServerErrorIO MPersonRequest +newPerson conn (MPerson _ (Just name) (Just age)) = runDb conn $ do + PersonKey (SqlBackendKey nId) <- insert (Person name age) + pure $ MPersonRequest (Just nId) +newPerson _ _ = serverError $ ServerError Invalid "missing person data" allPeople :: SqlBackend -> ConduitT (Entity Person) Void ServerErrorIO () -> ServerErrorIO () allPeople conn sink = runDb conn $ diff --git a/grpc/client/src/Mu/GRpc/Client/Examples.hs b/grpc/client/src/Mu/GRpc/Client/Examples.hs index 8c19833b..57f3e923 100644 --- a/grpc/client/src/Mu/GRpc/Client/Examples.hs +++ b/grpc/client/src/Mu/GRpc/Client/Examples.hs @@ -19,19 +19,21 @@ type instance AnnotatedSchema ProtoBufAnnotation QuickstartSchema , 'AnnField "HelloResponse" "message" ('ProtoBufId 1) , 'AnnField "HiRequest" "number" ('ProtoBufId 1) ] -sayHello' :: HostName -> PortNumber -> T.Text -> IO (GRpcReply T.Text) +type M a = a Maybe + +sayHello' :: HostName -> PortNumber -> T.Text -> IO (GRpcReply (Maybe T.Text)) sayHello' host port req = do Right c <- setupGrpcClient' (grpcClientConfigSimple host port False) - fmap (\(HelloResponse r) -> r) <$> sayHello c (HelloRequest req) + fmap (\(HelloResponse r) -> r) <$> sayHello c (HelloRequest (Just req)) -sayHello :: GrpcClient -> HelloRequest -> IO (GRpcReply HelloResponse) +sayHello :: GrpcClient -> M HelloRequest -> IO (GRpcReply (M HelloResponse)) sayHello = gRpcCall @QuickStartService @"SayHello" -sayHi' :: HostName -> PortNumber -> Int -> IO [GRpcReply T.Text] +sayHi' :: HostName -> PortNumber -> Int -> IO [GRpcReply (Maybe T.Text)] sayHi' host port n = do Right c <- setupGrpcClient' (grpcClientConfigSimple host port False) - cndt <- sayHi c (HiRequest n) + cndt <- sayHi c (HiRequest (Just n)) runConduit $ cndt .| C.map (fmap (\(HelloResponse r) -> r)) .| consume -sayHi :: GrpcClient -> HiRequest -> IO (ConduitT () (GRpcReply HelloResponse) IO ()) +sayHi :: GrpcClient -> M HiRequest -> IO (ConduitT () (GRpcReply (M HelloResponse)) IO ()) sayHi = gRpcCall @QuickStartService @"SayHi" diff --git a/grpc/client/src/Mu/GRpc/Client/Internal.hs b/grpc/client/src/Mu/GRpc/Client/Internal.hs index d59952bc..ea858412 100644 --- a/grpc/client/src/Mu/GRpc/Client/Internal.hs +++ b/grpc/client/src/Mu/GRpc/Client/Internal.hs @@ -89,18 +89,18 @@ instance (KnownName name, handler ~ IO (GRpcReply ())) where methodName = BS.pack (nameVal (Proxy @name)) rpc = RPC pkgName srvName methodName -instance ( KnownName name, ProtoBufTypeRef rref r +instance ( KnownName name, FromProtoBufTypeRef rref r , handler ~ IO (GRpcReply r) ) => GRpcMethodCall ('Method name anns '[ ] ('RetSingle rref)) handler where gRpcMethodCall pkgName srvName _ client - = fmap (fmap unViaProtoBufTypeRef) $ + = fmap (fmap unViaFromProtoBufTypeRef) $ simplifyResponse $ buildGRpcReply1 <$> - rawUnary @_ @_ @(ViaProtoBufTypeRef rref _)rpc client () + rawUnary @_ @_ @(ViaFromProtoBufTypeRef rref _) rpc client () where methodName = BS.pack (nameVal (Proxy @name)) rpc = RPC pkgName srvName methodName -instance ( KnownName name, ProtoBufTypeRef rref r +instance ( KnownName name, FromProtoBufTypeRef rref r , handler ~ (IO (ConduitT () (GRpcReply r) IO ())) ) => GRpcMethodCall ('Method name anns '[ ] ('RetStream rref)) handler where gRpcMethodCall pkgName srvName _ client @@ -111,9 +111,9 @@ instance ( KnownName name, ProtoBufTypeRef rref r _ <- async $ do v <- simplifyResponse $ buildGRpcReply3 <$> - rawStreamServer @_ @() @(ViaProtoBufTypeRef rref r) + rawStreamServer @_ @() @(ViaFromProtoBufTypeRef rref r) rpc client () () - (\_ _ (ViaProtoBufTypeRef newVal) -> liftIO $ atomically $ + (\_ _ (ViaFromProtoBufTypeRef newVal) -> liftIO $ atomically $ -- on the first iteration, say that everything is OK tryPutTMVar var (GRpcOk ()) >> writeTMChan chan newVal) case v of @@ -129,29 +129,29 @@ instance ( KnownName name, ProtoBufTypeRef rref r where methodName = BS.pack (nameVal (Proxy @name)) rpc = RPC pkgName srvName methodName -instance ( KnownName name, ProtoBufTypeRef vref v +instance ( KnownName name, ToProtoBufTypeRef vref v , handler ~ (v -> IO (GRpcReply ())) ) => GRpcMethodCall ('Method name anns '[ 'ArgSingle vref ] 'RetNothing) handler where gRpcMethodCall pkgName srvName _ client x = simplifyResponse $ buildGRpcReply1 <$> - rawUnary @_ @(ViaProtoBufTypeRef vref _) rpc client (ViaProtoBufTypeRef x) + rawUnary @_ @(ViaToProtoBufTypeRef vref _) rpc client (ViaToProtoBufTypeRef x) where methodName = BS.pack (nameVal (Proxy @name)) rpc = RPC pkgName srvName methodName -instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r +instance ( KnownName name, ToProtoBufTypeRef vref v, FromProtoBufTypeRef rref r , handler ~ (v -> IO (GRpcReply r)) ) => GRpcMethodCall ('Method name anns '[ 'ArgSingle vref ] ('RetSingle rref)) handler where gRpcMethodCall pkgName srvName _ client x - = fmap (fmap unViaProtoBufTypeRef) $ + = fmap (fmap unViaFromProtoBufTypeRef) $ simplifyResponse $ buildGRpcReply1 <$> - rawUnary @_ @(ViaProtoBufTypeRef vref _) @(ViaProtoBufTypeRef rref _) - rpc client (ViaProtoBufTypeRef x) + rawUnary @_ @(ViaToProtoBufTypeRef vref _) @(ViaFromProtoBufTypeRef rref _) + rpc client (ViaToProtoBufTypeRef x) where methodName = BS.pack (nameVal (Proxy @name)) rpc = RPC pkgName srvName methodName -instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r +instance ( KnownName name, ToProtoBufTypeRef vref v, FromProtoBufTypeRef rref r , handler ~ (CompressMode -> IO (ConduitT v Void IO (GRpcReply r))) ) => GRpcMethodCall ('Method name anns '[ 'ArgStream vref ] ('RetSingle rref)) handler where gRpcMethodCall pkgName srvName _ client compress @@ -159,14 +159,14 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r chan <- newTMChanIO :: IO (TMChan v) -- Start executing the client in another thread promise <- async $ - fmap (fmap unViaProtoBufTypeRef) $ + fmap (fmap unViaFromProtoBufTypeRef) $ simplifyResponse $ buildGRpcReply2 <$> - rawStreamClient @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) rpc client () + rawStreamClient @_ @(ViaToProtoBufTypeRef vref v) @(ViaFromProtoBufTypeRef rref r) rpc client () (\_ -> do nextVal <- liftIO $ atomically $ readTMChan chan case nextVal of Nothing -> return ((), Left StreamDone) - Just v -> return ((), Right (compress, ViaProtoBufTypeRef v))) + Just v -> return ((), Right (compress, ViaToProtoBufTypeRef v))) -- This conduit feeds information to the other thread let go = do x <- await case x of @@ -178,7 +178,7 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r where methodName = BS.pack (nameVal (Proxy @name)) rpc = RPC pkgName srvName methodName -instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r +instance ( KnownName name, ToProtoBufTypeRef vref v, FromProtoBufTypeRef rref r , handler ~ (v -> IO (ConduitT () (GRpcReply r) IO ())) ) => GRpcMethodCall ('Method name anns '[ 'ArgSingle vref ] ('RetStream rref)) handler where gRpcMethodCall pkgName srvName _ client x @@ -189,9 +189,9 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r _ <- async $ do v <- simplifyResponse $ buildGRpcReply3 <$> - rawStreamServer @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) - rpc client () (ViaProtoBufTypeRef x) - (\_ _ (ViaProtoBufTypeRef newVal) -> liftIO $ atomically $ + rawStreamServer @_ @(ViaToProtoBufTypeRef vref v) @(ViaFromProtoBufTypeRef rref r) + rpc client () (ViaToProtoBufTypeRef x) + (\_ _ (ViaFromProtoBufTypeRef newVal) -> liftIO $ atomically $ -- on the first iteration, say that everything is OK tryPutTMVar var (GRpcOk ()) >> writeTMChan chan newVal) case v of @@ -207,7 +207,7 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r where methodName = BS.pack (nameVal (Proxy @name)) rpc = RPC pkgName srvName methodName -instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r +instance ( KnownName name, ToProtoBufTypeRef vref v, FromProtoBufTypeRef rref r , handler ~ (CompressMode -> IO (ConduitT v (GRpcReply r) IO ())) ) => GRpcMethodCall ('Method name anns '[ 'ArgStream vref ] ('RetStream rref)) handler where gRpcMethodCall pkgName srvName _ client compress @@ -220,19 +220,19 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r v <- simplifyResponse $ buildGRpcReply3 <$> rawGeneralStream - @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) + @_ @(ViaToProtoBufTypeRef vref v) @(ViaFromProtoBufTypeRef rref r) rpc client () (\_ ievent -> do -- on the first iteration, say that everything is OK _ <- liftIO $ atomically $ tryPutTMVar var (GRpcOk ()) case ievent of - RecvMessage o -> liftIO $ atomically $ writeTMChan inchan (GRpcOk $ unViaProtoBufTypeRef o) + RecvMessage o -> liftIO $ atomically $ writeTMChan inchan (GRpcOk $ unViaFromProtoBufTypeRef o) Invalid e -> liftIO $ atomically $ writeTMChan inchan (GRpcErrorString (show e)) _ -> return () ) () (\_ -> do nextVal <- liftIO $ atomically $ readTMChan outchan case nextVal of Nothing -> return ((), Finalize) - Just v -> return ((), SendMessage compress (ViaProtoBufTypeRef v))) + Just v -> return ((), SendMessage compress (ViaToProtoBufTypeRef v))) case v of GRpcOk () -> liftIO $ atomically $ closeTMChan inchan _ -> liftIO $ atomically $ putTMVar var v diff --git a/grpc/client/src/Mu/GRpc/Client/Record.hs b/grpc/client/src/Mu/GRpc/Client/Record.hs index 4e776e15..c0321192 100644 --- a/grpc/client/src/Mu/GRpc/Client/Record.hs +++ b/grpc/client/src/Mu/GRpc/Client/Record.hs @@ -128,9 +128,9 @@ computeMethodType n [ArgStream v] (RetStream r) computeMethodType _ _ _ = fail "method signature not supported" typeRefToType :: Namer -> TypeRef -> Q Type -typeRefToType tNamer (FromTH (LitT (StrTyLit s))) +typeRefToType tNamer (ViaTH (LitT (StrTyLit s))) = return $ ConT (mkName $ completeName tNamer s) -typeRefToType _tNamer (FromTH ty) +typeRefToType _tNamer (ViaTH ty) = return ty typeRefToType _ _ = error "this should never happen" @@ -184,10 +184,10 @@ typeToServiceDef toplevelty typeToTypeRef :: Type -> Maybe TypeRef typeToTypeRef ty - = (do (_,innerTy) <- tyD2 'FromSchema ty - return (FromTH innerTy)) - <|> (do (_,innerTy,_) <- tyD3 'FromRegistry ty - return (FromTH innerTy)) + = (do (_,innerTy) <- tyD2 'ViaSchema ty + return (ViaTH innerTy)) + <|> (do (_,innerTy,_) <- tyD3 'ViaRegistry ty + return (ViaTH innerTy)) tyString :: Type -> Maybe String tyString (SigT t _) diff --git a/grpc/server/src/Mu/GRpc/Server.hs b/grpc/server/src/Mu/GRpc/Server.hs index 5ce90c01..caaf8437 100644 --- a/grpc/server/src/Mu/GRpc/Server.hs +++ b/grpc/server/src/Mu/GRpc/Server.hs @@ -35,7 +35,6 @@ import Network.GRPC.HTTP2.Encoding (gzip, uncompressed) import Network.GRPC.HTTP2.Proto3Wire import Network.GRPC.HTTP2.Types (GRPCStatus (..), GRPCStatusCode (..)) import Network.GRPC.Server.Handlers -import Network.GRPC.Server.Wai (ServiceHandler) import Network.GRPC.Server.Wai as Wai import Network.Wai (Application) import Network.Wai.Handler.Warp (Port, Settings, run, runSettings) @@ -51,7 +50,7 @@ runGRpcApp :: ( KnownName name, KnownName (FindPackageName anns) , GRpcMethodHandlers ServerErrorIO methods handlers ) => Port - -> ServerT ('Service name anns methods) ServerErrorIO handlers + -> ServerT Maybe ('Service name anns methods) ServerErrorIO handlers -> IO () runGRpcApp port = runGRpcAppTrans port id @@ -61,7 +60,7 @@ runGRpcAppTrans , GRpcMethodHandlers m methods handlers ) => Port -> (forall a. m a -> ServerErrorIO a) - -> ServerT ('Service name anns methods) m handlers + -> ServerT Maybe ('Service name anns methods) m handlers -> IO () runGRpcAppTrans port f svr = run port (gRpcAppTrans f svr) @@ -73,7 +72,7 @@ runGRpcAppSettings , GRpcMethodHandlers m methods handlers ) => Settings -> (forall a. m a -> ServerErrorIO a) - -> ServerT ('Service name anns methods) m handlers + -> ServerT Maybe ('Service name anns methods) m handlers -> IO () runGRpcAppSettings st f svr = runSettings st (gRpcAppTrans f svr) @@ -86,7 +85,7 @@ runGRpcAppTLS , GRpcMethodHandlers m methods handlers ) => TLSSettings -> Settings -> (forall a. m a -> ServerErrorIO a) - -> ServerT ('Service name anns methods) m handlers + -> ServerT Maybe ('Service name anns methods) m handlers -> IO () runGRpcAppTLS tls st f svr = runTLS tls st (gRpcAppTrans f svr) @@ -98,7 +97,7 @@ runGRpcAppTLS tls st f svr = runTLS tls st (gRpcAppTrans f svr) gRpcApp :: ( KnownName name, KnownName (FindPackageName anns) , GRpcMethodHandlers ServerErrorIO methods handlers ) - => ServerT ('Service name anns methods) ServerErrorIO handlers + => ServerT Maybe ('Service name anns methods) ServerErrorIO handlers -> Application gRpcApp = gRpcAppTrans id @@ -111,7 +110,7 @@ gRpcAppTrans :: ( KnownName name, KnownName (FindPackageName anns) , GRpcMethodHandlers m methods handlers ) => (forall a. m a -> ServerErrorIO a) - -> ServerT ('Service name anns methods) m handlers + -> ServerT Maybe ('Service name anns methods) m handlers -> Application gRpcAppTrans f svr = Wai.grpcApp [uncompressed, gzip] (gRpcServiceHandlers f svr) @@ -120,7 +119,7 @@ gRpcServiceHandlers :: forall name anns methods handlers m. (KnownName name, KnownName (FindPackageName anns), GRpcMethodHandlers m methods handlers) => (forall a. m a -> ServerErrorIO a) - -> ServerT ('Service name anns methods) m handlers + -> ServerT Maybe ('Service name anns methods) m handlers -> [ServiceHandler] gRpcServiceHandlers f (Server svr) = gRpcMethodHandlers f packageName serviceName svr where packageName = BS.pack (nameVal (Proxy @(FindPackageName anns))) @@ -129,7 +128,7 @@ gRpcServiceHandlers f (Server svr) = gRpcMethodHandlers f packageName serviceNam class GRpcMethodHandlers (m :: Type -> Type) (ms :: [Method mnm]) (hs :: [Type]) where gRpcMethodHandlers :: (forall a. m a -> ServerErrorIO a) -> ByteString -> ByteString - -> HandlersT ms m hs -> [ServiceHandler] + -> HandlersT Maybe ms m hs -> [ServiceHandler] instance GRpcMethodHandlers m '[] '[] where gRpcMethodHandlers _ _ _ H0 = [] @@ -172,98 +171,98 @@ instance GRpcMethodHandler m '[ ] 'RetNothing (m ()) where gRpcMethodHandler f _ _ rpc h = unary @_ @() @() rpc (\_ _ -> raiseErrors (f h)) -instance (ProtoBufTypeRef rref r) +instance (ToProtoBufTypeRef rref r) => GRpcMethodHandler m '[ ] ('RetSingle rref) (m r) where gRpcMethodHandler f _ _ rpc h - = unary @_ @() @(ViaProtoBufTypeRef rref r) - rpc (\_ _ -> ViaProtoBufTypeRef <$> raiseErrors (f h)) + = unary @_ @() @(ViaToProtoBufTypeRef rref r) + rpc (\_ _ -> ViaToProtoBufTypeRef <$> raiseErrors (f h)) -instance (ProtoBufTypeRef rref r, MonadIO m) +instance (ToProtoBufTypeRef rref r, MonadIO m) => GRpcMethodHandler m '[ ] ('RetStream rref) (ConduitT r Void m () -> m ()) where gRpcMethodHandler f _ _ rpc h - = serverStream @_ @() @(ViaProtoBufTypeRef rref r) rpc sstream + = serverStream @_ @() @(ViaToProtoBufTypeRef rref r) rpc sstream where sstream :: req -> () - -> IO ((), ServerStream (ViaProtoBufTypeRef rref r) ()) + -> IO ((), ServerStream (ViaToProtoBufTypeRef rref r) ()) sstream _ _ = do -- Variable to connect input and output var <- newEmptyTMVarIO :: IO (TMVar (Maybe r)) -- Start executing the handler - promise <- async (raiseErrors $ ViaProtoBufTypeRef <$> f (h (toTMVarConduit var))) + promise <- async (raiseErrors $ ViaToProtoBufTypeRef <$> f (h (toTMVarConduit var))) -- Return the information let readNext _ = do nextOutput <- atomically $ takeTMVar var case nextOutput of - Just o -> return $ Just ((), ViaProtoBufTypeRef o) + Just o -> return $ Just ((), ViaToProtoBufTypeRef o) Nothing -> do cancel promise return Nothing return ((), ServerStream readNext) -instance (ProtoBufTypeRef vref v) +instance (FromProtoBufTypeRef vref v) => GRpcMethodHandler m '[ 'ArgSingle vref ] 'RetNothing (v -> m ()) where gRpcMethodHandler f _ _ rpc h - = unary @_ @(ViaProtoBufTypeRef vref v) @() - rpc (\_ -> raiseErrors . f . h . unViaProtoBufTypeRef) + = unary @_ @(ViaFromProtoBufTypeRef vref v) @() + rpc (\_ -> raiseErrors . f . h . unViaFromProtoBufTypeRef) -instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) +instance (FromProtoBufTypeRef vref v, ToProtoBufTypeRef rref r) => GRpcMethodHandler m '[ 'ArgSingle vref ] ('RetSingle rref) (v -> m r) where gRpcMethodHandler f _ _ rpc h - = unary @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) - rpc (\_ -> (ViaProtoBufTypeRef <$>) . raiseErrors . f . h . unViaProtoBufTypeRef) + = unary @_ @(ViaFromProtoBufTypeRef vref v) @(ViaToProtoBufTypeRef rref r) + rpc (\_ -> (ViaToProtoBufTypeRef <$>) . raiseErrors . f . h . unViaFromProtoBufTypeRef) -instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r, MonadIO m) +instance (FromProtoBufTypeRef vref v, ToProtoBufTypeRef rref r, MonadIO m) => GRpcMethodHandler m '[ 'ArgStream vref ] ('RetSingle rref) (ConduitT () v m () -> m r) where gRpcMethodHandler f _ _ rpc h - = clientStream @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) + = clientStream @_ @(ViaFromProtoBufTypeRef vref v) @(ViaToProtoBufTypeRef rref r) rpc cstream where cstream :: req - -> IO ((), ClientStream (ViaProtoBufTypeRef vref v) - (ViaProtoBufTypeRef rref r) ()) + -> IO ((), ClientStream (ViaFromProtoBufTypeRef vref v) + (ViaToProtoBufTypeRef rref r) ()) cstream _ = do -- Create a new TMChan chan <- newTMChanIO :: IO (TMChan v) let producer = sourceTMChan @m chan -- Start executing the handler in another thread - promise <- async (raiseErrors $ ViaProtoBufTypeRef <$> f (h producer)) + promise <- async (raiseErrors $ ViaToProtoBufTypeRef <$> f (h producer)) -- Build the actual handler - let cstreamHandler _ (ViaProtoBufTypeRef newInput) + let cstreamHandler _ (ViaFromProtoBufTypeRef newInput) = atomically (writeTMChan chan newInput) cstreamFinalizer _ = atomically (closeTMChan chan) >> wait promise -- Return the information return ((), ClientStream cstreamHandler cstreamFinalizer) -instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r, MonadIO m) +instance (FromProtoBufTypeRef vref v, ToProtoBufTypeRef rref r, MonadIO m) => GRpcMethodHandler m '[ 'ArgSingle vref ] ('RetStream rref) (v -> ConduitT r Void m () -> m ()) where gRpcMethodHandler f _ _ rpc h - = serverStream @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) + = serverStream @_ @(ViaFromProtoBufTypeRef vref v) @(ViaToProtoBufTypeRef rref r) rpc sstream - where sstream :: req -> ViaProtoBufTypeRef vref v - -> IO ((), ServerStream (ViaProtoBufTypeRef rref r) ()) - sstream _ (ViaProtoBufTypeRef v) = do + where sstream :: req -> ViaFromProtoBufTypeRef vref v + -> IO ((), ServerStream (ViaToProtoBufTypeRef rref r) ()) + sstream _ (ViaFromProtoBufTypeRef v) = do -- Variable to connect input and output var <- newEmptyTMVarIO :: IO (TMVar (Maybe r)) -- Start executing the handler - promise <- async (raiseErrors $ ViaProtoBufTypeRef <$> f (h v (toTMVarConduit var))) + promise <- async (raiseErrors $ ViaToProtoBufTypeRef <$> f (h v (toTMVarConduit var))) -- Return the information let readNext _ = do nextOutput <- atomically $ takeTMVar var case nextOutput of - Just o -> return $ Just ((), ViaProtoBufTypeRef o) + Just o -> return $ Just ((), ViaToProtoBufTypeRef o) Nothing -> do cancel promise return Nothing return ((), ServerStream readNext) -instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r, MonadIO m) +instance (FromProtoBufTypeRef vref v, ToProtoBufTypeRef rref r, MonadIO m) => GRpcMethodHandler m '[ 'ArgStream vref ] ('RetStream rref) (ConduitT () v m () -> ConduitT r Void m () -> m ()) where gRpcMethodHandler f _ _ rpc h - = generalStream @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) + = generalStream @_ @(ViaFromProtoBufTypeRef vref v) @(ViaToProtoBufTypeRef rref r) rpc bdstream - where bdstream :: req -> IO ( (), IncomingStream (ViaProtoBufTypeRef vref v) () - , (), OutgoingStream (ViaProtoBufTypeRef rref r) () ) + where bdstream :: req -> IO ( (), IncomingStream (ViaFromProtoBufTypeRef vref v) () + , (), OutgoingStream (ViaToProtoBufTypeRef rref r) () ) bdstream _ = do -- Create a new TMChan and a new variable chan <- newTMChanIO :: IO (TMChan v) @@ -272,7 +271,7 @@ instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r, MonadIO m) -- Start executing the handler promise <- async (raiseErrors $ f $ h producer (toTMVarConduit var)) -- Build the actual handler - let cstreamHandler _ (ViaProtoBufTypeRef newInput) + let cstreamHandler _ (ViaFromProtoBufTypeRef newInput) = atomically (writeTMChan chan newInput) cstreamFinalizer _ = atomically (closeTMChan chan) >> wait promise @@ -280,7 +279,7 @@ instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r, MonadIO m) = do nextOutput <- atomically $ tryTakeTMVar var case nextOutput of Just (Just o) -> - return $ Just ((), ViaProtoBufTypeRef o) + return $ Just ((), ViaToProtoBufTypeRef o) Just Nothing -> do cancel promise return Nothing diff --git a/templates/grpc-server.hsfiles b/templates/grpc-server.hsfiles index 9b71f095..fac5bab4 100644 --- a/templates/grpc-server.hsfiles +++ b/templates/grpc-server.hsfiles @@ -87,10 +87,13 @@ grpc "Schema" id "{{name}}.proto" -- data Message -- = Message { ... } --- deriving (Eq, Show, Generic, HasSchema Schema "Message") +-- deriving ( Eq, Show, Generic + , ToSchema Maybe Schema "Message" + , FromSchema Maybe Schema "Message" ) {-# START_FILE src/Main.hs #-} {-# language PartialTypeSignatures #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Main where import Mu.GRpc.Server @@ -101,5 +104,5 @@ import Schema main :: IO () main = runGRpcApp 8080 server -server :: (MonadServer m) => ServerT Service m _ +server :: (MonadServer m) => ServerT Maybe Service m _ server = Server H0 From 09d7d658876b2cfdfdddd808073a87f84c600eec Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Wed, 18 Dec 2019 08:50:17 +0100 Subject: [PATCH 022/217] =?UTF-8?q?Extract=20`mu-persistent`=20to=20it's?= =?UTF-8?q?=20own=20package!=20=E2=9C=82=EF=B8=8F=20(#47)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- adapter/persistent/LICENSE | 202 ++++++++++++++++++ adapter/persistent/README.md | 46 ++++ adapter/persistent/Setup.hs | 2 + adapter/persistent/mu-persistent.cabal | 22 ++ .../persistent/src/Mu/Adapter/Persistent.hs | 58 +++++ examples/with-persistent/README.md | 4 +- .../mu-example-with-persistent.cabal | 2 + examples/with-persistent/src/Client.hs | 24 +-- examples/with-persistent/src/Schema.hs | 51 +---- stack-nightly.yaml | 1 + stack.yaml | 1 + 11 files changed, 353 insertions(+), 60 deletions(-) create mode 100644 adapter/persistent/LICENSE create mode 100644 adapter/persistent/README.md create mode 100644 adapter/persistent/Setup.hs create mode 100644 adapter/persistent/mu-persistent.cabal create mode 100644 adapter/persistent/src/Mu/Adapter/Persistent.hs diff --git a/adapter/persistent/LICENSE b/adapter/persistent/LICENSE new file mode 100644 index 00000000..ffeb95d1 --- /dev/null +++ b/adapter/persistent/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright © 2019-2020 47 Degrees. + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/adapter/persistent/README.md b/adapter/persistent/README.md new file mode 100644 index 00000000..440a6391 --- /dev/null +++ b/adapter/persistent/README.md @@ -0,0 +1,46 @@ +# mu-persistent + +This are some utilities to integrate easily with `persistent` while using Mu. + +## Usage + +Say you have for example, the following `Entity`: + +```haskell +mkPersist sqlSettings [persistLowerCase| +Person + name T.Text + age Int32 + deriving Show Generic +|] +``` + +But in your `proto3`, the `Person` message is defined as: + +```protobuf +message PersonRequest { + int64 identifier = 1; +} + +message Person { + PersonRequest pid = 1; + string name = 2; + int32 age = 3; +} +``` + +How can you derive the correct `ToSchema` instances that `Mu` needs to work with that nested `Id` that belongs to another message? 🤔 + +You can use `WithEntityNestedId`, along with a custom field mapping and `DerivingVia` to do all the work for you! + +```haskell +{-# language DerivingVia #-} + +type PersonFieldMapping + = '[ "personAge" ':-> "age", "personName" ':-> "name" ] + +deriving via (WithEntityNestedId "Person" PersonFieldMapping (Entity Person)) + instance ToSchema Maybe PersistentSchema "Person" (Entity Person) +``` + +For a more complete example of usage, please check [the example with `persistent`](https://github.com/higherkindness/mu-haskell/blob/master/examples/with-persistent/src/Schema.hs). diff --git a/adapter/persistent/Setup.hs b/adapter/persistent/Setup.hs new file mode 100644 index 00000000..9a994af6 --- /dev/null +++ b/adapter/persistent/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/adapter/persistent/mu-persistent.cabal b/adapter/persistent/mu-persistent.cabal new file mode 100644 index 00000000..39dbe581 --- /dev/null +++ b/adapter/persistent/mu-persistent.cabal @@ -0,0 +1,22 @@ +name: mu-persistent +version: 0.1.0.0 +-- synopsis: +-- description: +homepage: https://github.com/higherkindness/mu-haskell/persistent#readme +license: Apache-2.0 +license-file: LICENSE +author: Flavio Corpa, Alejandro Serrano +maintainer: flavio.corpa@47deg.com +copyright: Copyright © 2019-2020 47 Degrees. +category: Network +build-type: Simple +cabal-version: >=1.10 +extra-source-files: README.md + +library + exposed-modules: Mu.Adapter.Persistent + hs-source-dirs: src + default-language: Haskell2010 + build-depends: base >= 4.7 && < 5 + , mu-schema + , persistent diff --git a/adapter/persistent/src/Mu/Adapter/Persistent.hs b/adapter/persistent/src/Mu/Adapter/Persistent.hs new file mode 100644 index 00000000..45cdd8c0 --- /dev/null +++ b/adapter/persistent/src/Mu/Adapter/Persistent.hs @@ -0,0 +1,58 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language KindSignatures #-} +{-# language MultiParamTypeClasses #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +module Mu.Adapter.Persistent where + +import Data.Functor.Identity +import Data.Int (Int64) +import GHC.Generics +import GHC.TypeLits + +import Database.Persist.Sql +import Mu.Schema +import Mu.Schema.Class +import Mu.Schema.Interpretation + +newtype WithEntityPlainId (ty :: Symbol) (fmap :: Mappings Symbol Symbol) a + = WithEntityPlainId { unWithEntityPlainId :: a } +newtype WithEntityNestedId (ty :: Symbol) (fmap :: Mappings Symbol Symbol) a + = WithEntityNestedId { unWithEntityNestedId :: a } + +instance ( Generic t, Applicative w + , (sch :/: sty) ~ 'DRecord name (idArg ': args) + , idArg ~ 'Mu.Schema.FieldDef idArgName ('TPrimitive Int64) + , Rep t ~ D1 dInfo (C1 cInfo f) + , GToSchemaRecord Identity sch fmap args f + , ToBackendKey (PersistEntityBackend t) t + , PersistEntityBackend t ~ SqlBackend ) + => ToSchema w sch sty (WithEntityPlainId sty fmap (Entity t)) where + toSchema (WithEntityPlainId (Entity key x)) + = TRecord $ Field (pure $ FPrimitive (unSqlBackendKey $ toBackendKey key)) + :* transFieldsNoMaps up (toSchemaRecord (Proxy @fmap) (unM1 $ unM1 $ from x)) + where up :: Identity a -> w a + up (Identity i) = pure i + +instance ( Generic t, Applicative w + , (sch :/: sty) ~ 'DRecord name (nestedIdArg ': args) + , nestedIdArg ~ 'Mu.Schema.FieldDef fname ('TSchematic idTy) + , (sch :/: idTy) ~ 'DRecord idName '[idArg] + , idArg ~ 'Mu.Schema.FieldDef idArgName ('TPrimitive Int64) + , Rep t ~ D1 dInfo (C1 cInfo f) + , GToSchemaRecord Identity sch fmap args f + , ToBackendKey (PersistEntityBackend t) t + , PersistEntityBackend t ~ SqlBackend ) + => ToSchema w sch sty (WithEntityNestedId sty fmap (Entity t)) where + toSchema (WithEntityNestedId (Entity key x)) + = TRecord $ Field (pure $ FSchematic $ TRecord (Field (pure $ FPrimitive key') :* Nil)) + :* transFieldsNoMaps up (toSchemaRecord (Proxy @fmap) (unM1 $ unM1 $ from x)) + where key' = unSqlBackendKey $ toBackendKey key + up :: Identity a -> w a + up (Identity i) = pure i diff --git a/examples/with-persistent/README.md b/examples/with-persistent/README.md index dd3fd785..ff307abe 100644 --- a/examples/with-persistent/README.md +++ b/examples/with-persistent/README.md @@ -5,13 +5,13 @@ Running the server: ```bash -stack run persistent-server +$ stack run persistent-server ``` In another terminal, run the client: ```bash -stack run persistent-client +$ stack run persistent-client add "Flavio" 28 ``` [comment]: # (Start Copyright) diff --git a/examples/with-persistent/mu-example-with-persistent.cabal b/examples/with-persistent/mu-example-with-persistent.cabal index cd0de8fb..8acb2aa4 100644 --- a/examples/with-persistent/mu-example-with-persistent.cabal +++ b/examples/with-persistent/mu-example-with-persistent.cabal @@ -21,6 +21,7 @@ executable persistent-server , monad-logger , mu-schema , mu-rpc + , mu-persistent , mu-protobuf , mu-grpc-server , persistent @@ -35,6 +36,7 @@ executable persistent-client , conduit , mu-schema , mu-rpc + , mu-persistent , mu-protobuf , mu-grpc-client , persistent diff --git a/examples/with-persistent/src/Client.hs b/examples/with-persistent/src/Client.hs index b36f9688..7ed29fcc 100644 --- a/examples/with-persistent/src/Client.hs +++ b/examples/with-persistent/src/Client.hs @@ -5,7 +5,7 @@ {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} {-# language TypeOperators #-} -{-# options_ghc -fno-warn-name-shadowing #-} + module Main where import Data.Conduit @@ -24,26 +24,26 @@ main = do Right client <- setupGrpcClient' config args <- getArgs case args of - ["watch"] -> watching client - ["get", idp] -> get client idp - ["add", name, age] -> add client name age - _ -> putStrLn "unknown command" + ["watch"] -> watching client + ["get", idp] -> get client idp + ["add", nm, ag] -> add client nm ag + _ -> putStrLn "unknown command" get :: GrpcClient -> String -> IO () get client idPerson = do let req = MPersonRequest $ readMaybe idPerson - putStrLn ("GET: Is there some person with id: " ++ idPerson ++ "?") - rknown :: GRpcReply MPerson + putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?" + response :: GRpcReply MPerson <- gRpcCall @PersistentService @"getPerson" client req - putStrLn ("GET: response was: " ++ show rknown) + putStrLn $ "GET: response was: " ++ show response add :: GrpcClient -> String -> String -> IO () -add client name age = do - let p = MPerson Nothing (Just $ T.pack name) (readMaybe age) - putStrLn ("ADD: Creating new person " <> name <> " with age " <> age) +add client nm ag = do + let p = MPerson Nothing (Just $ T.pack nm) (readMaybe ag) + putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag response :: GRpcReply MPersonRequest <- gRpcCall @PersistentService @"newPerson" client p - putStrLn ("ADD: Was creating successful? " <> show response) + putStrLn $ "ADD: was creating successful? " ++ show response watching :: GrpcClient -> IO () watching client = do diff --git a/examples/with-persistent/src/Schema.hs b/examples/with-persistent/src/Schema.hs index 4d586dc4..2ad18a40 100644 --- a/examples/with-persistent/src/Schema.hs +++ b/examples/with-persistent/src/Schema.hs @@ -2,7 +2,6 @@ {-# language DeriveGeneric #-} {-# language DerivingVia #-} {-# language DuplicateRecordFields #-} -{-# language EmptyDataDecls #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language GADTs #-} @@ -14,25 +13,21 @@ {-# language ScopedTypeVariables #-} {-# language StandaloneDeriving #-} {-# language TemplateHaskell #-} -{-# language TypeApplications #-} {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} module Schema where -import Data.Functor.Identity -import Data.Int (Int32, Int64) -import qualified Data.Text as T +import Data.Int (Int32, Int64) +import qualified Data.Text as T import Database.Persist.Sqlite import Database.Persist.TH import GHC.Generics -import GHC.TypeLits +import Mu.Adapter.Persistent (WithEntityNestedId (..)) import Mu.Quasi.GRpc import Mu.Schema -import Mu.Schema.Class -import Mu.Schema.Interpretation grpc "PersistentSchema" id "with-persistent.proto" @@ -59,43 +54,7 @@ data MPerson = MPerson instance ToSchema Maybe PersistentSchema "Person" MPerson instance FromSchema Maybe PersistentSchema "Person" MPerson -newtype WithEntityPlainId (ty :: Symbol) (fmap :: Mappings Symbol Symbol) a - = WithEntityPlainId { unWithEntityPlainId :: a } -newtype WithEntityNestedId (ty :: Symbol) (fmap :: Mappings Symbol Symbol) a - = WithEntityNestedId { unWithEntityNestedId :: a } +type PersonFieldMapping = '[ "personAge" ':-> "age", "personName" ':-> "name" ] -instance ( Generic t, Applicative w - , (sch :/: sty) ~ 'DRecord name (idArg ': args) - , idArg ~ 'Mu.Schema.FieldDef idArgName ('TPrimitive Int64) - , Rep t ~ D1 dInfo (C1 cInfo f) - , GToSchemaRecord Identity sch fmap args f - , ToBackendKey (PersistEntityBackend t) t - , PersistEntityBackend t ~ SqlBackend ) - => ToSchema w sch sty (WithEntityPlainId sty fmap (Entity t)) where - toSchema (WithEntityPlainId (Entity key x)) - = TRecord $ Field (pure $ FPrimitive (unSqlBackendKey $ toBackendKey key)) - :* transFieldsNoMaps up (toSchemaRecord (Proxy @fmap) (unM1 $ unM1 $ from x)) - where up :: Identity a -> w a - up (Identity i) = pure i - -instance ( Generic t, Applicative w - , (sch :/: sty) ~ 'DRecord name (nestedIdArg ': args) - , nestedIdArg ~ 'Mu.Schema.FieldDef fname ('TSchematic idTy) - , (sch :/: idTy) ~ 'DRecord idName '[idArg] - , idArg ~ 'Mu.Schema.FieldDef idArgName ('TPrimitive Int64) - , Rep t ~ D1 dInfo (C1 cInfo f) - , GToSchemaRecord Identity sch fmap args f - , ToBackendKey (PersistEntityBackend t) t - , PersistEntityBackend t ~ SqlBackend ) - => ToSchema w sch sty (WithEntityNestedId sty fmap (Entity t)) where - toSchema (WithEntityNestedId (Entity key x)) - = TRecord $ Field (pure $ FSchematic $ TRecord (Field (pure $ FPrimitive key') :* Nil)) - :* transFieldsNoMaps up (toSchemaRecord (Proxy @fmap) (unM1 $ unM1 $ from x)) - where key' = unSqlBackendKey $ toBackendKey key - up :: Identity a -> w a - up (Identity i) = pure i - -type PersonFieldMapping - = '[ "personAge" ':-> "age", "personName" ':-> "name" ] deriving via (WithEntityNestedId "Person" PersonFieldMapping (Entity Person)) - instance ToSchema Maybe PersistentSchema "Person" (Entity Person) + instance ToSchema Maybe PersistentSchema "Person" (Entity Person) diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 3219036b..8cc58c89 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -6,6 +6,7 @@ packages: - core/rpc - adapter/avro - adapter/protobuf +- adapter/persistent - grpc/client - grpc/server - examples/health-check diff --git a/stack.yaml b/stack.yaml index 18a23acb..61b94b44 100644 --- a/stack.yaml +++ b/stack.yaml @@ -6,6 +6,7 @@ packages: - core/rpc - adapter/avro - adapter/protobuf +- adapter/persistent - grpc/client - grpc/server - examples/health-check From dfd3b591473235b5db29c65d54ec827b22ee5674 Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Thu, 19 Dec 2019 11:54:10 +0100 Subject: [PATCH 023/217] =?UTF-8?q?Replace=20Travis=20with=20Github=20Acti?= =?UTF-8?q?ons=20and=20Nix=20=E2=9D=84=EF=B8=8F=20(#48)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .github/workflows/haskell.yml | 12 +++++++++++ .travis.yml | 27 ------------------------- README.md | 2 +- adapter/avro/mu-avro.cabal | 1 + adapter/protobuf/mu-protobuf.cabal | 1 + default.nix | 5 +++++ examples/health-check/src/Definition.hs | 2 +- examples/route-guide/src/Definition.hs | 2 +- 8 files changed, 22 insertions(+), 30 deletions(-) create mode 100644 .github/workflows/haskell.yml delete mode 100644 .travis.yml create mode 100644 default.nix diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml new file mode 100644 index 00000000..c4f1e080 --- /dev/null +++ b/.github/workflows/haskell.yml @@ -0,0 +1,12 @@ +name: Haskell CI +on: [push] +jobs: + build: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v1 + - uses: cachix/install-nix-action@v6 + - uses: cachix/cachix-action@v2 + with: + name: 47deg + signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}' diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index bb8bf49e..00000000 --- a/.travis.yml +++ /dev/null @@ -1,27 +0,0 @@ -# Choose a build environment -dist: bionic - -# Do not choose a language; we provide our own build tools. -language: generic - -# Caching so the next build will be fast too. -cache: - directories: - - $HOME/.stack - -# Ensure necessary system libraries are present -addons: - apt: - packages: - - libgmp-dev - -before_install: -# Download and unpack the stack executable -- mkdir -p ~/.local/bin -- export PATH=$HOME/.local/bin:$PATH -- travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' - -install: -# Build dependencies -- stack --no-terminal --install-ghc test --only-dependencies -- stack --no-terminal --install-ghc test --only-dependencies --stack-yaml stack-nightly.yaml diff --git a/README.md b/README.md index c9663b63..2cc32027 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # Mu for Haskell -[![Build Status](https://travis-ci.com/higherkindness/mu-haskell.svg?branch=master)](https://travis-ci.com/higherkindness/mu-haskell) +[![Actions Status](https://github.com/higherkindness/mu-haskell/workflows/Haskell%20CI/badge.svg)](https://github.com/higherkindness/mu-haskell/actions) This repo defines a set of libraries to write microservices in a format- and protocol-independent way. It shares the same goals as [Mu for Scala](http://higherkindness.io/mu/), but using idiomatic Haskell and more type-level techniques. diff --git a/adapter/avro/mu-avro.cabal b/adapter/avro/mu-avro.cabal index e7481315..3a47b61d 100644 --- a/adapter/avro/mu-avro.cabal +++ b/adapter/avro/mu-avro.cabal @@ -11,6 +11,7 @@ maintainer: alejandro.serrano@47deg.com -- copyright: category: Network build-type: Simple +data-files: test/avro/*.avsc library exposed-modules: Mu.Adapter.Avro diff --git a/adapter/protobuf/mu-protobuf.cabal b/adapter/protobuf/mu-protobuf.cabal index e5970f63..6f72e91a 100644 --- a/adapter/protobuf/mu-protobuf.cabal +++ b/adapter/protobuf/mu-protobuf.cabal @@ -11,6 +11,7 @@ maintainer: alejandro.serrano@47deg.com -- copyright: category: Network build-type: Simple +data-files: test/protobuf/*.proto library exposed-modules: Mu.Adapter.ProtoBuf diff --git a/default.nix b/default.nix new file mode 100644 index 00000000..d3085a88 --- /dev/null +++ b/default.nix @@ -0,0 +1,5 @@ +{ pkgs ? import (import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz)) +}: + pkgs.haskell-nix.stackProject { + src = pkgs.haskell-nix.haskellLib.cleanGit { src = ./.; }; + } diff --git a/examples/health-check/src/Definition.hs b/examples/health-check/src/Definition.hs index 46b6d3b5..53bc986f 100644 --- a/examples/health-check/src/Definition.hs +++ b/examples/health-check/src/Definition.hs @@ -18,7 +18,7 @@ import GHC.Generics import Mu.Quasi.GRpc import Mu.Schema -$(grpc "HealthCheckSchema" id "healthcheck.proto") +grpc "HealthCheckSchema" id "healthcheck.proto" newtype HealthCheckMsg = HealthCheckMsg { nameService :: Maybe T.Text } diff --git a/examples/route-guide/src/Definition.hs b/examples/route-guide/src/Definition.hs index 079142d6..043b2845 100644 --- a/examples/route-guide/src/Definition.hs +++ b/examples/route-guide/src/Definition.hs @@ -19,7 +19,7 @@ import GHC.Generics import Mu.Quasi.GRpc import Mu.Schema -$(grpc "RouteGuideSchema" id "routeguide.proto") +grpc "RouteGuideSchema" id "routeguide.proto" data Point = Point { latitude, longitude :: Maybe Int32 } From a18b0c4b73de82b030c5b86a4ce8384260024663 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Thu, 19 Dec 2019 14:41:57 +0100 Subject: [PATCH 024/217] Make ghcide happy (#49) --- adapter/avro/hie.yaml | 1 + adapter/avro/src/Mu/Adapter/Avro/Example.hs | 5 +++++ adapter/persistent/hie.yaml | 1 + adapter/protobuf/hie.yaml | 1 + adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs | 6 ++++++ compendium-client/hie.yaml | 1 + core/rpc/hie.yaml | 1 + core/schema/hie.yaml | 1 + examples/health-check/hie.yaml | 1 + examples/health-check/mu-example-health-check.cabal | 11 ----------- examples/health-check/src/Definition.hs | 5 +++++ examples/route-guide/hie.yaml | 1 + examples/route-guide/mu-example-route-guide.cabal | 9 --------- examples/route-guide/src/Definition.hs | 5 +++++ examples/seed/hie.yaml | 1 + examples/seed/src/Schema.hs | 5 +++++ examples/todolist/hie.yaml | 1 + examples/todolist/mu-example-todolist.cabal | 12 ------------ examples/todolist/src/Definition.hs | 5 +++++ examples/with-persistent/hie.yaml | 1 + examples/with-persistent/src/Schema.hs | 5 +++++ grpc/client/hie.yaml | 1 + grpc/server/hie.yaml | 1 + 23 files changed, 49 insertions(+), 32 deletions(-) create mode 100644 adapter/avro/hie.yaml create mode 100644 adapter/persistent/hie.yaml create mode 100644 adapter/protobuf/hie.yaml create mode 100644 compendium-client/hie.yaml create mode 100644 core/rpc/hie.yaml create mode 100644 core/schema/hie.yaml create mode 100644 examples/health-check/hie.yaml create mode 100644 examples/route-guide/hie.yaml create mode 100644 examples/seed/hie.yaml create mode 100644 examples/todolist/hie.yaml create mode 100644 examples/with-persistent/hie.yaml create mode 100644 grpc/client/hie.yaml create mode 100644 grpc/server/hie.yaml diff --git a/adapter/avro/hie.yaml b/adapter/avro/hie.yaml new file mode 100644 index 00000000..588153dc --- /dev/null +++ b/adapter/avro/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-avro:lib" } } diff --git a/adapter/avro/src/Mu/Adapter/Avro/Example.hs b/adapter/avro/src/Mu/Adapter/Avro/Example.hs index df3f3f73..14faf036 100644 --- a/adapter/avro/src/Mu/Adapter/Avro/Example.hs +++ b/adapter/avro/src/Mu/Adapter/Avro/Example.hs @@ -1,3 +1,4 @@ +{-# language CPP #-} {-# language DataKinds #-} {-# language QuasiQuotes #-} @@ -35,4 +36,8 @@ type Example = [avro| } |] +#if __GHCIDE__ +type ExampleFromFile = [avroFile|adapter/avro/test/avro/example.avsc|] +#else type ExampleFromFile = [avroFile|test/avro/example.avsc|] +#endif diff --git a/adapter/persistent/hie.yaml b/adapter/persistent/hie.yaml new file mode 100644 index 00000000..8ad09df0 --- /dev/null +++ b/adapter/persistent/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-persistent:lib" } } diff --git a/adapter/protobuf/hie.yaml b/adapter/protobuf/hie.yaml new file mode 100644 index 00000000..61fd01fc --- /dev/null +++ b/adapter/protobuf/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-protobuf:lib" } } diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs index 057e58fa..13ff7c34 100644 --- a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs @@ -1,3 +1,4 @@ +{-# language CPP #-} {-# language DataKinds #-} {-# language TemplateHaskell #-} {-# language TypeFamilies #-} @@ -5,5 +6,10 @@ module Mu.Adapter.ProtoBuf.Example where import Mu.Quasi.ProtoBuf +#if __GHCIDE__ +protobuf "ExampleProtoBufSchema" "adapter/protobuf/test/protobuf/example.proto" +protobuf "Example2ProtoBufSchema" "adapter/protobuf/test/protobuf/example2.proto" +#else protobuf "ExampleProtoBufSchema" "test/protobuf/example.proto" protobuf "Example2ProtoBufSchema" "test/protobuf/example2.proto" +#endif diff --git a/compendium-client/hie.yaml b/compendium-client/hie.yaml new file mode 100644 index 00000000..6d0b5359 --- /dev/null +++ b/compendium-client/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "compendium-client:lib" } } diff --git a/core/rpc/hie.yaml b/core/rpc/hie.yaml new file mode 100644 index 00000000..ce32bdbb --- /dev/null +++ b/core/rpc/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-rpc:lib" } } diff --git a/core/schema/hie.yaml b/core/schema/hie.yaml new file mode 100644 index 00000000..1b217d94 --- /dev/null +++ b/core/schema/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-schema:lib" } } diff --git a/examples/health-check/hie.yaml b/examples/health-check/hie.yaml new file mode 100644 index 00000000..47447b16 --- /dev/null +++ b/examples/health-check/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-example-health-check:exe:health-server" } } diff --git a/examples/health-check/mu-example-health-check.cabal b/examples/health-check/mu-example-health-check.cabal index db762828..8af8688f 100644 --- a/examples/health-check/mu-example-health-check.cabal +++ b/examples/health-check/mu-example-health-check.cabal @@ -16,17 +16,6 @@ copyright: Copyright © 2019-2020 47 Degrees. category: Network build-type: Simple -library - exposed-modules: Definition - build-depends: base >=4.12 && <5, text, - mu-schema, mu-rpc, mu-protobuf, - stm, stm-containers, - conduit, stm-conduit, - deferred-folds - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall - executable health-server main-is: Server.hs other-modules: Definition diff --git a/examples/health-check/src/Definition.hs b/examples/health-check/src/Definition.hs index 53bc986f..756e6db3 100644 --- a/examples/health-check/src/Definition.hs +++ b/examples/health-check/src/Definition.hs @@ -1,3 +1,4 @@ +{-# language CPP #-} {-# language DataKinds #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-} @@ -18,7 +19,11 @@ import GHC.Generics import Mu.Quasi.GRpc import Mu.Schema +#if __GHCIDE__ +grpc "HealthCheckSchema" id "examples/health-check/healthcheck.proto" +#else grpc "HealthCheckSchema" id "healthcheck.proto" +#endif newtype HealthCheckMsg = HealthCheckMsg { nameService :: Maybe T.Text } diff --git a/examples/route-guide/hie.yaml b/examples/route-guide/hie.yaml new file mode 100644 index 00000000..b9404d05 --- /dev/null +++ b/examples/route-guide/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-example-route-guide:exe:route-guide-server" } } diff --git a/examples/route-guide/mu-example-route-guide.cabal b/examples/route-guide/mu-example-route-guide.cabal index a4c4dd61..b691ae2c 100644 --- a/examples/route-guide/mu-example-route-guide.cabal +++ b/examples/route-guide/mu-example-route-guide.cabal @@ -16,15 +16,6 @@ copyright: Copyright © 2019-2020 47 Degrees. category: Network build-type: Simple -library - exposed-modules: Definition - build-depends: base >=4.12 && <5, text, - mu-schema, mu-rpc, mu-protobuf, - hashable - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall - executable route-guide-server main-is: Server.hs other-modules: Definition diff --git a/examples/route-guide/src/Definition.hs b/examples/route-guide/src/Definition.hs index 043b2845..7c4e897d 100644 --- a/examples/route-guide/src/Definition.hs +++ b/examples/route-guide/src/Definition.hs @@ -1,3 +1,4 @@ +{-# language CPP #-} {-# language DataKinds #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-} @@ -19,7 +20,11 @@ import GHC.Generics import Mu.Quasi.GRpc import Mu.Schema +#if __GHCIDE__ +grpc "RouteGuideSchema" id "examples/route-guide/routeguide.proto" +#else grpc "RouteGuideSchema" id "routeguide.proto" +#endif data Point = Point { latitude, longitude :: Maybe Int32 } diff --git a/examples/seed/hie.yaml b/examples/seed/hie.yaml new file mode 100644 index 00000000..94678535 --- /dev/null +++ b/examples/seed/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-example-seed:exe:seed-server" } } diff --git a/examples/seed/src/Schema.hs b/examples/seed/src/Schema.hs index 80ef7eed..c48d1751 100644 --- a/examples/seed/src/Schema.hs +++ b/examples/seed/src/Schema.hs @@ -1,3 +1,4 @@ +{-# language CPP #-} {-# language DataKinds #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-} @@ -19,7 +20,11 @@ import GHC.Generics import Mu.Quasi.GRpc import Mu.Schema +#if __GHCIDE__ +grpc "SeedSchema" id "examples/seed/seed.proto" +#else grpc "SeedSchema" id "seed.proto" +#endif data Person = Person { name :: Maybe T.Text diff --git a/examples/todolist/hie.yaml b/examples/todolist/hie.yaml new file mode 100644 index 00000000..27952c11 --- /dev/null +++ b/examples/todolist/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-example-todolist:exe:todolist-server" } } diff --git a/examples/todolist/mu-example-todolist.cabal b/examples/todolist/mu-example-todolist.cabal index 7adf61f9..f44214c8 100644 --- a/examples/todolist/mu-example-todolist.cabal +++ b/examples/todolist/mu-example-todolist.cabal @@ -16,18 +16,6 @@ copyright: Copyright © 2019-2020 47 Degrees. category: Network build-type: Simple -library - exposed-modules: Definition - build-depends: base >=4.12 && <5 - , text - , mu-schema - , mu-rpc - , mu-protobuf - , hashable - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall - executable todolist-server main-is: Server.hs other-modules: Definition diff --git a/examples/todolist/src/Definition.hs b/examples/todolist/src/Definition.hs index 2f90b672..31244888 100644 --- a/examples/todolist/src/Definition.hs +++ b/examples/todolist/src/Definition.hs @@ -1,3 +1,4 @@ +{-# language CPP #-} {-# language DataKinds #-} {-# language DeriveAnyClass #-} {-# language DeriveGeneric #-} @@ -18,7 +19,11 @@ import GHC.Generics import Mu.Quasi.GRpc import Mu.Schema +#if __GHCIDE__ +grpc "TodoListSchema" id "examples/todolist/todolist.proto" +#else grpc "TodoListSchema" id "todolist.proto" +#endif newtype MessageId = MessageId { value :: Maybe Int32 diff --git a/examples/with-persistent/hie.yaml b/examples/with-persistent/hie.yaml new file mode 100644 index 00000000..c244f191 --- /dev/null +++ b/examples/with-persistent/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-example-with-persistent:exe:persistent-server" } } diff --git a/examples/with-persistent/src/Schema.hs b/examples/with-persistent/src/Schema.hs index 2ad18a40..a6113b5b 100644 --- a/examples/with-persistent/src/Schema.hs +++ b/examples/with-persistent/src/Schema.hs @@ -1,3 +1,4 @@ +{-# language CPP #-} {-# language DataKinds #-} {-# language DeriveGeneric #-} {-# language DerivingVia #-} @@ -29,7 +30,11 @@ import Mu.Adapter.Persistent (WithEntityNestedId (..)) import Mu.Quasi.GRpc import Mu.Schema +#if __GHCIDE__ +grpc "PersistentSchema" id "examples/with-persistent/with-persistent.proto" +#else grpc "PersistentSchema" id "with-persistent.proto" +#endif newtype MPersonRequest = MPersonRequest { identifier :: Maybe Int64 diff --git a/grpc/client/hie.yaml b/grpc/client/hie.yaml new file mode 100644 index 00000000..2951c5d7 --- /dev/null +++ b/grpc/client/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-grpc-client:lib" } } diff --git a/grpc/server/hie.yaml b/grpc/server/hie.yaml new file mode 100644 index 00000000..a99e3e58 --- /dev/null +++ b/grpc/server/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-grpc-server:lib" } } From 6898d90eed1aff4788b956234315601bb4176441 Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Fri, 20 Dec 2019 08:29:09 +0100 Subject: [PATCH 025/217] =?UTF-8?q?Document=20integration=20with=20Persist?= =?UTF-8?q?ent=20=F0=9F=93=9A=20(#50)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- adapter/persistent/mu-persistent.cabal | 3 + .../persistent/src/Mu/Adapter/Persistent.hs | 15 +- docs/db.md | 208 +++++++++++++++++- examples/with-persistent/src/Schema.hs | 1 - examples/with-persistent/src/Server.hs | 6 +- 5 files changed, 223 insertions(+), 10 deletions(-) diff --git a/adapter/persistent/mu-persistent.cabal b/adapter/persistent/mu-persistent.cabal index 39dbe581..67a75afd 100644 --- a/adapter/persistent/mu-persistent.cabal +++ b/adapter/persistent/mu-persistent.cabal @@ -18,5 +18,8 @@ library hs-source-dirs: src default-language: Haskell2010 build-depends: base >= 4.7 && < 5 + , monad-logger , mu-schema , persistent + , resourcet + , transformers diff --git a/adapter/persistent/src/Mu/Adapter/Persistent.hs b/adapter/persistent/src/Mu/Adapter/Persistent.hs index 45cdd8c0..4edbf30b 100644 --- a/adapter/persistent/src/Mu/Adapter/Persistent.hs +++ b/adapter/persistent/src/Mu/Adapter/Persistent.hs @@ -11,12 +11,15 @@ module Mu.Adapter.Persistent where +import Control.Monad.IO.Class +import Control.Monad.Logger +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Resource.Internal import Data.Functor.Identity -import Data.Int (Int64) +import Data.Int +import Database.Persist.Sql import GHC.Generics import GHC.TypeLits - -import Database.Persist.Sql import Mu.Schema import Mu.Schema.Class import Mu.Schema.Interpretation @@ -56,3 +59,9 @@ instance ( Generic t, Applicative w where key' = unSqlBackendKey $ toBackendKey key up :: Identity a -> w a up (Identity i) = pure i + +runDb :: MonadIO m + => SqlBackend + -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a + -> m a +runDb = (liftIO .) . flip runSqlPersistM diff --git a/docs/db.md b/docs/db.md index 3d05749b..9b8a6493 100644 --- a/docs/db.md +++ b/docs/db.md @@ -1,4 +1,208 @@ # Databases -Explain how to integrate with Persistent. -Explain also how to run a pool of database connections. +In this section of the docs, to have a clearer understanding of how one would use `mu-haskell` to talk to a database, we are going to have a walk through the example of [`with-persistent`](https://github.com/higherkindness/mu-haskell/tree/master/examples/with-persistent). + +## First steps + +We are going to start with our source of truth: the proto file. + +```protobuf +syntax = "proto3"; + +import "google/protobuf/empty.proto"; + +package withpersistent; + +message PersonRequest { int64 identifier = 1; } +message Person { PersonRequest pid = 1; string name = 2; int32 age = 3; } + +service PersistentService { + rpc getPerson (PersonRequest) returns (Person); + rpc newPerson (Person) returns (PersonRequest); + rpc allPeople (google.protobuf.Empty) returns (stream Person); +} +``` + +Maybe this example looks a bit contrived but bear with me, it covers a common use case when working with protobuf: that one of the messages has another message as its identifying key. + +## Definning our Schema + +You are going to need to enable the following extensions: + +```haskell +{-# language DataKinds #-} +{-# language DeriveGeneric #-} +{-# language DerivingVia #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language GeneralizedNewtypeDeriving #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language PolyKinds #-} +{-# language QuasiQuotes #-} +{-# language ScopedTypeVariables #-} +{-# language StandaloneDeriving #-} +{-# language TemplateHaskell #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +``` + +As we've seen in the rest of the docs, we define our own data types to mirror our protobuf schema: + +```haskell +grpc "PersistentSchema" id "with-persistent.proto" + +newtype MPersonRequest = MPersonRequest + { identifier :: Maybe Int64 + } deriving (Eq, Show, Ord, Generic) + +instance ToSchema Maybe PersistentSchema "PersonRequest" MPersonRequest +instance FromSchema Maybe PersistentSchema "PersonRequest" MPersonRequest + +data MPerson = MPerson + { pid :: Maybe MPersonRequest + , name :: Maybe T.Text + , age :: Maybe Int32 } + deriving (Eq, Ord, Show, Generic) + +instance ToSchema Maybe PersistentSchema "Person" MPerson +instance FromSchema Maybe PersistentSchema "Person" MPerson +``` + +Remember that all the magic starts with that first `grpc` line! ✨ + +You might have noticed that this time, we are not using `DeriveAnyClass`, so we need to write the instances for `ToSchema` and `FromSchema` on a separate line from our deriving clause, and let GHC fill them for us. This decision was made due to a current [bug in Persistent](https://github.com/yesodweb/persistent/issues/578), but hopefully it will be fixed in future versions. 🙂 + +## Integration with `persistent` + +This is the bit that changes the most. Since we are interested in storing in our database only the `Person` entities, we are going to declare only that `Entity` using TemplateHaskell and `persistent-template`. + +For our specific example we are going to integrate with `persistent-sqlite`, but feel free to use whatever database you prefer! 😉 + +```haskell +import Data.Int +import qualified Data.Text as T +import Database.Persist.Sqlite +import Database.Persist.TH + +mkPersist sqlSettings [persistLowerCase| +Person json + name T.Text + age Int32 + deriving Show Generic +|] +``` + +Notice how we are deriving `Generic` also with Persistent's QuasiQuotes. + +## Fixing the Id access issue + +If you have worked with `persistent` before, you'll know that it generates it's own Ids, and this is very convenient. In our example, we'll get for free a `PersonId` field which is what we want to get with our `PersonRequest`. + +But, how to derive the correct instance of `ToSchema` that `Mu` needs to work it's magic? How can we explicitly define this mapping? + +We have created some utilities to help you integrate with Persistent in our [`mu-persistent` package](https://github.com/higherkindness/mu-haskell/tree/master/adapter/persistent). One of such is `WithEntityNestedId`, you can use it along with `DerivingVia` to fit our needs: + +```haskell +type PersonFieldMapping + = '[ "personAge" ':-> "age", "personName" ':-> "name" ] + +deriving via (WithEntityNestedId "Person" PersonFieldMapping (Entity Person)) + instance ToSchema Maybe PersistentSchema "Person" (Entity Person) +``` + +Have in mind that we still need to define our own custom field mapping, in this case `PersonFieldMapping` so that the deriving via does it's job properly. + +## Running a pool of database connections + +Now let's focus on the Server! + +All you need to do is open one time the database, and share the connection across all your services: + +```haskell +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} + +module Server where + +import Control.Monad.Logger +import Mu.GRpc.Server +import Mu.Server + +main :: IO () +main = + runStderrLoggingT $ + withSqliteConn @(LoggingT IO) "example.db" $ \conn -> + liftIO $ runGRpcApp 8080 (server conn) +``` + +We have decided in this example to use `LoggintT` from `monad-logger` and `runStderrLoggingT` to get some basic database logs to the console for free, but this is not a must! + +## This actually does not work + +Maybe you might have noticed that this example is not going to work yet. Unless you created `example.db` yourself, we need to define a "migration". Migrations are not actually *required* by Persistent, they are just a simple way to get an Sqlite database up and running. + +We need a small tweak in our `Schema.hs`: + +```diff +- mkPersist sqlSettings [persistLowerCase| ++ share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| + Person json + ... +``` + +And another one on our `Server.hs`: + +```diff +main :: IO () +main = + runStderrLoggingT $ +- withSqliteConn @(LoggingT IO) "example.db" $ \conn -> ++ withSqliteConn @(LoggingT IO) "example.db" $ \conn -> do ++ runDb conn $ runMigration migrateAll + liftIO $ runGRpcApp 8080 (server conn) +``` + +More on that strange `runDb` method in the next section! 😇 + +## Sample usage with a service + +All the pieces are now in place, let's check the implementation of the `allPeople` service: + +```haskell +allPeople :: SqlBackend + -> ConduitT (Entity Person) Void ServerErrorIO () + -> ServerErrorIO () +allPeople conn sink = runDb conn $ + runConduit $ selectSource [] [] .| liftServerConduit sink +``` + +As you can see, all the services need to be passed the `SqlBackend` connection as an argument. + +Two interesting things we want to highlight here: we have provided a small helper called `runDb`, it's implementation is quite simple and it exists due to **developer ergonomics**. We are basically saving you from writing lots of `liftIO $ flip runSqlPersistM`. 😉 + +The second one will be discussed in the next section. + +## On streams and `Conduit` + +Since we are going to work with streams, it is wonderful that `persistent` also provides methods to work with `Conduit` like, for example, `selectSource`. But the Monad in which `persistent` operates returns `ConduitM () (Entity Person) m ()`, and we know that we want instead: `ConduitT (Entity Person) Void ServerErrorIO ()`. 🤔 + +Well, have no fear my friend because we created yet another utility called `liftServerConduit`, orn specifically to address this problem. It's type signature is: + +```haskell +liftServerConduit + :: MonadIO m + => ConduitT a b ServerErrorIO r -> ConduitT a b m r +``` + +What is this type signature telling us? That is, we can turn any of the Conduits given as input, which work on the `ServerErrorIO` Monad from `mu-rpc`, into a Conduit working on other `IO`-like Monad. This is the case, in particular, of the Monad in which Persistent runs. + + +And that concludes our round-trip! + +If you think that something is not clear or could be further improved, feel free to [open an Issue or Pull Request!](https://github.com/higherkindness/mu-haskell/issues) 😊 diff --git a/examples/with-persistent/src/Schema.hs b/examples/with-persistent/src/Schema.hs index a6113b5b..6930c52a 100644 --- a/examples/with-persistent/src/Schema.hs +++ b/examples/with-persistent/src/Schema.hs @@ -2,7 +2,6 @@ {-# language DataKinds #-} {-# language DeriveGeneric #-} {-# language DerivingVia #-} -{-# language DuplicateRecordFields #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} {-# language GADTs #-} diff --git a/examples/with-persistent/src/Server.hs b/examples/with-persistent/src/Server.hs index a0bb837d..9b28429d 100644 --- a/examples/with-persistent/src/Server.hs +++ b/examples/with-persistent/src/Server.hs @@ -3,7 +3,6 @@ {-# language PartialTypeSignatures #-} {-# language TypeApplications #-} {-# language TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Main where @@ -12,6 +11,7 @@ import Control.Monad.Logger import Data.Conduit import qualified Data.Text as T import Database.Persist.Sqlite +import Mu.Adapter.Persistent (runDb) import Mu.GRpc.Server import Mu.Server @@ -22,14 +22,12 @@ main = do putStrLn "running app with persistent" runStderrLoggingT $ withSqliteConn @(LoggingT IO) ":memory:" $ \conn -> do - liftIO $ flip runSqlPersistM conn $ runMigration migrateAll + runDb conn $ runMigration migrateAll liftIO $ runGRpcApp 1234 (server conn) server :: SqlBackend -> ServerT Maybe PersistentService ServerErrorIO _ server p = Server (getPerson p :<|>: newPerson p :<|>: allPeople p :<|>: H0) -runDb = (liftIO .) . flip runSqlPersistM - getPerson :: SqlBackend -> MPersonRequest -> ServerErrorIO (Entity Person) getPerson conn (MPersonRequest (Just idf)) = do r <- runDb conn $ do From 9dab396b8b11cc45da0f5b9ce7076a0525b13b0f Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Fri, 20 Dec 2019 11:16:24 +0100 Subject: [PATCH 026/217] =?UTF-8?q?Fallback=20to=20Travis=20=F0=9F=98=94?= =?UTF-8?q?=20(#54)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .github/workflows/haskell.yml | 12 ------------ .travis.yml | 27 +++++++++++++++++++++++++++ README.md | 2 +- default.nix | 5 ----- 4 files changed, 28 insertions(+), 18 deletions(-) delete mode 100644 .github/workflows/haskell.yml create mode 100644 .travis.yml delete mode 100644 default.nix diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml deleted file mode 100644 index c4f1e080..00000000 --- a/.github/workflows/haskell.yml +++ /dev/null @@ -1,12 +0,0 @@ -name: Haskell CI -on: [push] -jobs: - build: - runs-on: ubuntu-latest - steps: - - uses: actions/checkout@v1 - - uses: cachix/install-nix-action@v6 - - uses: cachix/cachix-action@v2 - with: - name: 47deg - signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}' diff --git a/.travis.yml b/.travis.yml new file mode 100644 index 00000000..bb8bf49e --- /dev/null +++ b/.travis.yml @@ -0,0 +1,27 @@ +# Choose a build environment +dist: bionic + +# Do not choose a language; we provide our own build tools. +language: generic + +# Caching so the next build will be fast too. +cache: + directories: + - $HOME/.stack + +# Ensure necessary system libraries are present +addons: + apt: + packages: + - libgmp-dev + +before_install: +# Download and unpack the stack executable +- mkdir -p ~/.local/bin +- export PATH=$HOME/.local/bin:$PATH +- travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' + +install: +# Build dependencies +- stack --no-terminal --install-ghc test --only-dependencies +- stack --no-terminal --install-ghc test --only-dependencies --stack-yaml stack-nightly.yaml diff --git a/README.md b/README.md index 2cc32027..c9663b63 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # Mu for Haskell -[![Actions Status](https://github.com/higherkindness/mu-haskell/workflows/Haskell%20CI/badge.svg)](https://github.com/higherkindness/mu-haskell/actions) +[![Build Status](https://travis-ci.com/higherkindness/mu-haskell.svg?branch=master)](https://travis-ci.com/higherkindness/mu-haskell) This repo defines a set of libraries to write microservices in a format- and protocol-independent way. It shares the same goals as [Mu for Scala](http://higherkindness.io/mu/), but using idiomatic Haskell and more type-level techniques. diff --git a/default.nix b/default.nix deleted file mode 100644 index d3085a88..00000000 --- a/default.nix +++ /dev/null @@ -1,5 +0,0 @@ -{ pkgs ? import (import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz)) -}: - pkgs.haskell-nix.stackProject { - src = pkgs.haskell-nix.haskellLib.cleanGit { src = ./.; }; - } From 76df4fc02208fabc3919039d5cf317642d4930d8 Mon Sep 17 00:00:00 2001 From: Juan Valencia Date: Fri, 20 Dec 2019 11:18:23 +0100 Subject: [PATCH 027/217] =?UTF-8?q?Docs=20initial=20website=20=F0=9F=96=A8?= =?UTF-8?q?=20(#53)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .gitignore | 13 ++ docs/Gemfile | 3 + docs/Gemfile.lock | 65 +++++++++ docs/README.md | 39 +++-- docs/_config.yml | 21 +++ docs/_data/menu.yml | 9 ++ docs/_data/sidebar.yml | 32 +++++ docs/_includes/_doc.html | 14 ++ docs/_includes/_footer.html | 22 +++ docs/_includes/_head-docs.html | 29 ++++ docs/_includes/_header.html | 13 ++ docs/_includes/_main.html | 13 ++ docs/_includes/_nav.html | 32 +++++ docs/_includes/_sidebar.html | 100 +++++++++++++ docs/_layouts/docs.html | 8 ++ docs/_sass/base/_base.scss | 64 +++++++++ docs/_sass/base/_helpers.scss | 10 ++ docs/_sass/base/_reset.scss | 141 ++++++++++++++++++ docs/_sass/components/_button.scss | 47 ++++++ docs/_sass/components/_code.scss | 23 +++ docs/_sass/components/_doc.scss | 97 +++++++++++++ docs/_sass/components/_footer.scss | 85 +++++++++++ docs/_sass/components/_header.scss | 109 ++++++++++++++ docs/_sass/components/_main.scss | 51 +++++++ docs/_sass/components/_nav.scss | 141 ++++++++++++++++++ docs/_sass/components/_sidebar-menu.scss | 115 +++++++++++++++ docs/_sass/components/_sidebar.scss | 89 ++++++++++++ docs/_sass/components/_table.scss | 29 ++++ docs/_sass/utils/_mixins.scss | 53 +++++++ docs/_sass/utils/_variables.scss | 74 ++++++++++ docs/_sass/vendors/highlight/dracula.scss | 167 ++++++++++++++++++++++ docs/css/docs.scss | 23 +++ docs/docs/README.md | 20 +++ docs/{ => docs}/db.md | 6 + docs/{ => docs}/grpc.md | 6 + docs/{ => docs}/intro.md | 6 + docs/{ => docs}/middleware.md | 6 + docs/{ => docs}/registry.md | 6 + docs/{ => docs}/rpc.md | 6 + docs/{ => docs}/schema.md | 6 + docs/{ => docs}/stream.md | 6 + docs/{ => docs}/transformer.md | 6 + docs/img/favicon.png | Bin 0 -> 2790 bytes docs/img/header-image.svg | 99 +++++++++++++ docs/img/main-feature-primary.svg | 75 ++++++++++ docs/img/main-feature-secondary.svg | 110 ++++++++++++++ docs/img/main-feature-tertiary.svg | 55 +++++++ docs/img/nav-brand-white.svg | 9 ++ docs/img/nav-brand.svg | 9 ++ docs/img/nav-icon-close.svg | 12 ++ docs/img/nav-icon-open.svg | 13 ++ docs/img/sidebar-icon-open.svg | 11 ++ docs/js/docs.js | 162 +++++++++++++++++++++ docs/js/main.js | 31 ++++ 54 files changed, 2379 insertions(+), 12 deletions(-) create mode 100755 docs/Gemfile create mode 100755 docs/Gemfile.lock create mode 100755 docs/_config.yml create mode 100755 docs/_data/menu.yml create mode 100755 docs/_data/sidebar.yml create mode 100644 docs/_includes/_doc.html create mode 100755 docs/_includes/_footer.html create mode 100644 docs/_includes/_head-docs.html create mode 100755 docs/_includes/_header.html create mode 100755 docs/_includes/_main.html create mode 100755 docs/_includes/_nav.html create mode 100755 docs/_includes/_sidebar.html create mode 100755 docs/_layouts/docs.html create mode 100755 docs/_sass/base/_base.scss create mode 100644 docs/_sass/base/_helpers.scss create mode 100755 docs/_sass/base/_reset.scss create mode 100644 docs/_sass/components/_button.scss create mode 100755 docs/_sass/components/_code.scss create mode 100755 docs/_sass/components/_doc.scss create mode 100755 docs/_sass/components/_footer.scss create mode 100755 docs/_sass/components/_header.scss create mode 100755 docs/_sass/components/_main.scss create mode 100755 docs/_sass/components/_nav.scss create mode 100644 docs/_sass/components/_sidebar-menu.scss create mode 100755 docs/_sass/components/_sidebar.scss create mode 100644 docs/_sass/components/_table.scss create mode 100755 docs/_sass/utils/_mixins.scss create mode 100755 docs/_sass/utils/_variables.scss create mode 100644 docs/_sass/vendors/highlight/dracula.scss create mode 100644 docs/css/docs.scss create mode 100644 docs/docs/README.md rename docs/{ => docs}/db.md (99%) rename docs/{ => docs}/grpc.md (93%) rename docs/{ => docs}/intro.md (99%) rename docs/{ => docs}/middleware.md (98%) rename docs/{ => docs}/registry.md (94%) rename docs/{ => docs}/rpc.md (99%) rename docs/{ => docs}/schema.md (99%) rename docs/{ => docs}/stream.md (96%) rename docs/{ => docs}/transformer.md (98%) create mode 100644 docs/img/favicon.png create mode 100644 docs/img/header-image.svg create mode 100644 docs/img/main-feature-primary.svg create mode 100644 docs/img/main-feature-secondary.svg create mode 100644 docs/img/main-feature-tertiary.svg create mode 100644 docs/img/nav-brand-white.svg create mode 100644 docs/img/nav-brand.svg create mode 100644 docs/img/nav-icon-close.svg create mode 100644 docs/img/nav-icon-open.svg create mode 100644 docs/img/sidebar-icon-open.svg create mode 100644 docs/js/docs.js create mode 100755 docs/js/main.js diff --git a/.gitignore b/.gitignore index a11c47c3..312fe419 100644 --- a/.gitignore +++ b/.gitignore @@ -3,3 +3,16 @@ stack*.yaml.lock *~ dist *.pyc + +## User files +.DS_Store + +## Jekyll +_site +.sass-cache +.jekyll-metadata +.jekyll-cache + +## Ruby environment normalization: +.bundle/ +/docs/vendor/ diff --git a/docs/Gemfile b/docs/Gemfile new file mode 100755 index 00000000..49bd86ad --- /dev/null +++ b/docs/Gemfile @@ -0,0 +1,3 @@ +source "https://rubygems.org" + +gem "jekyll", ">= 4.0.0" diff --git a/docs/Gemfile.lock b/docs/Gemfile.lock new file mode 100755 index 00000000..9904c8c4 --- /dev/null +++ b/docs/Gemfile.lock @@ -0,0 +1,65 @@ +GEM + remote: https://rubygems.org/ + specs: + addressable (2.7.0) + public_suffix (>= 2.0.2, < 5.0) + colorator (1.1.0) + concurrent-ruby (1.1.5) + em-websocket (0.5.1) + eventmachine (>= 0.12.9) + http_parser.rb (~> 0.6.0) + eventmachine (1.2.7) + ffi (1.11.3) + forwardable-extended (2.6.0) + http_parser.rb (0.6.0) + i18n (1.7.0) + concurrent-ruby (~> 1.0) + jekyll (4.0.0) + addressable (~> 2.4) + colorator (~> 1.0) + em-websocket (~> 0.5) + i18n (>= 0.9.5, < 2) + jekyll-sass-converter (~> 2.0) + jekyll-watch (~> 2.0) + kramdown (~> 2.1) + kramdown-parser-gfm (~> 1.0) + liquid (~> 4.0) + mercenary (~> 0.3.3) + pathutil (~> 0.9) + rouge (~> 3.0) + safe_yaml (~> 1.0) + terminal-table (~> 1.8) + jekyll-sass-converter (2.0.1) + sassc (> 2.0.1, < 3.0) + jekyll-watch (2.2.1) + listen (~> 3.0) + kramdown (2.1.0) + kramdown-parser-gfm (1.1.0) + kramdown (~> 2.0) + liquid (4.0.3) + listen (3.2.1) + rb-fsevent (~> 0.10, >= 0.10.3) + rb-inotify (~> 0.9, >= 0.9.10) + mercenary (0.3.6) + pathutil (0.16.2) + forwardable-extended (~> 2.6) + public_suffix (4.0.1) + rb-fsevent (0.10.3) + rb-inotify (0.10.0) + ffi (~> 1.0) + rouge (3.14.0) + safe_yaml (1.0.5) + sassc (2.2.1) + ffi (~> 1.9) + terminal-table (1.8.0) + unicode-display_width (~> 1.1, >= 1.1.1) + unicode-display_width (1.6.0) + +PLATFORMS + ruby + +DEPENDENCIES + jekyll (>= 4.0.0) + +BUNDLED WITH + 2.0.1 diff --git a/docs/README.md b/docs/README.md index ca109cb0..43502a87 100644 --- a/docs/README.md +++ b/docs/README.md @@ -1,14 +1,29 @@ # Docs for Mu-Haskell -Mu-Haskell is a set of packages that help you build both servers and clients for (micro)services. The main goal of Mu-Haskell is to make you focus on your domain logic, instead of worrying about format and protocol issues. - -* [Introduction](intro.md) -* [Schemas](schema.md) - * [Registry](registry.md) -* [Services and servers](rpc.md) - * [gRPC servers and clients](grpc.md) - * [Streams](stream.md) - * [Databases](db.md), including resource pools -* Integration with other libraries - * [Using transformers](transformer.md): look here for logging - * [WAI Middleware](middleware.md): look here for metrics +The documentation is built through a Jekyll site as base. + +## Prerequisites + +* You need to have [ruby >= 2.4.0](https://rvm.io/) installed on your system. +* [Bundler >= 2](https://bundler.io/v2.0/guides/bundler_2_upgrade.html) is also needed. + + +## Building the docs + +To preview the site locally, execute the following command from the project root dir. This will install website dependencies under `docs/vendor/bundle`: + +```bash +bundle install --gemfile docs/Gemfile --path vendor/bundle +``` + +Then, through this command, you will run the locally installed Jekyll instance to serve the site: + + +```bash +BUNDLE_GEMFILE=./docs/Gemfile bundle exec jekyll serve -s docs -b /mu-haskell +``` + + +Finally, to have a look at the site, visit: + +http://localhost:4000/mu-haskell diff --git a/docs/_config.yml b/docs/_config.yml new file mode 100755 index 00000000..9ab32fb7 --- /dev/null +++ b/docs/_config.yml @@ -0,0 +1,21 @@ +title: Mu-Haskell +#------------------------- +name: Mu-Haskell +#------------------------- +description: Lorem ipusm +#------------------------- +author: 47 Degrees +keywords: functional-programming, monads, monad-transformers, functional-data-structure, swift, bow, fp-types, adt, free-monads, tagless-final, mtl, for-comprehension, category-theory +#------------------------- +url: https://www.47deg.com +#------------------------- +markdown: kramdown +sass: + sass_dir: _sass + style: compressed + sourcemap: never +#------------------------- +permalink: pretty +#------------------------- +exclude: ['config.ru', 'Gemfile', 'Gemfile.lock', 'vendor', 'Procfile', 'Rakefile'] +#------------------------- diff --git a/docs/_data/menu.yml b/docs/_data/menu.yml new file mode 100755 index 00000000..705db1b9 --- /dev/null +++ b/docs/_data/menu.yml @@ -0,0 +1,9 @@ +nav: + - title: Documentation + url: / + + - title: Github + url: https://github.com/higherkindness/mu-haskell + + - title: License + url: https://github.com/higherkindness/mu-haskell/blob/master/LICENSE diff --git a/docs/_data/sidebar.yml b/docs/_data/sidebar.yml new file mode 100755 index 00000000..5f68720d --- /dev/null +++ b/docs/_data/sidebar.yml @@ -0,0 +1,32 @@ +options: + - title: Start + url: / + + - title: Introduction + url: intro/ + + - title: Schemas + url: schema/ + nested_options: + - title: Registry + url: registry/ + + - title: Services and servers + url: rpc/ + nested_options: + - title: gRPC + url: grpc/ + + - title: Streams + url: stream/ + + - title: Databases + url: db/ + + - title: Integrations + nested_options: + - title: Transformers + url: transformer/ + + - title: Middleware + url: middleware/ diff --git a/docs/_includes/_doc.html b/docs/_includes/_doc.html new file mode 100644 index 00000000..4cf2abc4 --- /dev/null +++ b/docs/_includes/_doc.html @@ -0,0 +1,14 @@ +
+
+ +
+
+ {{ content }} +
+
diff --git a/docs/_includes/_footer.html b/docs/_includes/_footer.html new file mode 100755 index 00000000..c627ebac --- /dev/null +++ b/docs/_includes/_footer.html @@ -0,0 +1,22 @@ + diff --git a/docs/_includes/_head-docs.html b/docs/_includes/_head-docs.html new file mode 100644 index 00000000..8798d6f4 --- /dev/null +++ b/docs/_includes/_head-docs.html @@ -0,0 +1,29 @@ + + + {{site.name}} + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/docs/_includes/_header.html b/docs/_includes/_header.html new file mode 100755 index 00000000..9710685a --- /dev/null +++ b/docs/_includes/_header.html @@ -0,0 +1,13 @@ + diff --git a/docs/_includes/_main.html b/docs/_includes/_main.html new file mode 100755 index 00000000..84a8f116 --- /dev/null +++ b/docs/_includes/_main.html @@ -0,0 +1,13 @@ +
+
+
+ {% for item in site.data.features.content %} +
+ {{ item.title }} +

{{ item.title }}

+

{{ item.description }}

+
+ {% endfor %} +
+
+
\ No newline at end of file diff --git a/docs/_includes/_nav.html b/docs/_includes/_nav.html new file mode 100755 index 00000000..b238cf9b --- /dev/null +++ b/docs/_includes/_nav.html @@ -0,0 +1,32 @@ + diff --git a/docs/_includes/_sidebar.html b/docs/_includes/_sidebar.html new file mode 100755 index 00000000..1603b998 --- /dev/null +++ b/docs/_includes/_sidebar.html @@ -0,0 +1,100 @@ +
+
+ + {{ site.name }} + {{ site.name }} + + +
+
+ {% if site.data.sidebar.options %} + {% for item in site.data.sidebar.options %} + + {% assign item_url = item.url | relative_url %} + {% assign item_url_slash = item_url | append: '/' %} + {% assign page_url = page.url | relative_url %} + {% assign page_url_index = page_url | append: 'index.html' %} + + {% comment %} + + {% endcomment %} + {% assign open_submenu = '' %} + {% assign active_item = '' %} + + {% if item_url == page_url or item_url_slash == page_url or item_url == page_url_index %} + {% assign active_item = 'active' %} + {% endif %} + + {% if item.nested_options %} + {% if item_url == page_url or item_url_slash == page_url %} + {% assign open_submenu = 'open' %} + {% else %} + {% for sub in item.nested_options %} + {% assign sub_url = sub.url | relative_url %} + {% assign sub_url_slash = sub_url | append: '/' %} + {% if sub_url == page_url or sub_url_slash == page_url %} + {% assign open_submenu = 'open' %} + {% endif %} + {% endfor %} + {% endif %} + {% endif %} + +
+ {% if item.nested_options %} {% if item.url %} + + {{item.title}} + +
+ {% else %} + +
+ {% endif %} + +
+ {% for sub in item.nested_options %} + {% assign sub_url = sub.url | relative_url %} + {% assign sub_url_slash = sub_url | append: '/' %} + + {{ sub.title }} + + {% endfor %} +
+ {% else %} + + {{ item.title }} + + {% endif %} +
+ {% endfor %} + {% endif %} +
+
diff --git a/docs/_layouts/docs.html b/docs/_layouts/docs.html new file mode 100755 index 00000000..e28aed17 --- /dev/null +++ b/docs/_layouts/docs.html @@ -0,0 +1,8 @@ + + + {% include _head-docs.html %} + + {% include _sidebar.html %} + {% include _doc.html %} + + diff --git a/docs/_sass/base/_base.scss b/docs/_sass/base/_base.scss new file mode 100755 index 00000000..71378334 --- /dev/null +++ b/docs/_sass/base/_base.scss @@ -0,0 +1,64 @@ +// Base +// ----------------------------------------------- +// ----------------------------------------------- +// Body, html +// ----------------------------------------------- +html { + box-sizing: border-box; + font-size: $base-font-size; +} + +*, +*::after, +*::before { + box-sizing: inherit; +} + +body, +html { + height: 100%; +} + +// Typography +// ----------------------------------------------- +body { + display: flex; + flex-direction: column; + color: $base-font-color; + background: $white; + font-family: $base-font-family; + line-height: $base-line-height; +} + +h1, +h2, +h3, +h4, +h5, +h6 { + color: $header-font-color; + font-family: $header-font-family; + font-weight: $font-semibold; +} + +a { + color: $link-color; + text-decoration: none; + transition: color $base-duration $base-timing; + + &:visited { + color: $link-color; + } + &:hover { + color: $link-hover; + text-decoration: underline; + } + &:active { + color: $white; + } +} + +hr { + display: block; + border: none; +} diff --git a/docs/_sass/base/_helpers.scss b/docs/_sass/base/_helpers.scss new file mode 100644 index 00000000..30ceca6a --- /dev/null +++ b/docs/_sass/base/_helpers.scss @@ -0,0 +1,10 @@ +// Helpers +// ----------------------------------------------- +// ----------------------------------------------- +.wrapper { + padding: 0 ($base-point-grid * 3); + margin: 0 auto; + box-sizing: border-box; + max-width: $bp-xlarge; + height: 100%; +} diff --git a/docs/_sass/base/_reset.scss b/docs/_sass/base/_reset.scss new file mode 100755 index 00000000..76220f63 --- /dev/null +++ b/docs/_sass/base/_reset.scss @@ -0,0 +1,141 @@ +/* http://meyerweb.com/eric/tools/css/reset/ + v2.0 | 20110126 + License: none (public domain) +*/ +a, +abbr, +acronym, +address, +applet, +article, +aside, +audio, +b, +big, +blockquote, +body, +canvas, +caption, +center, +cite, +code, +dd, +del, +details, +dfn, +div, +dl, +dt, +em, +embed, +fieldset, +figcaption, +figure, +footer, +form, +h1, +h2, +h3, +h4, +h5, +h6, +header, +hgroup, +html, +i, +iframe, +img, +ins, +kbd, +label, +legend, +li, +mark, +menu, +nav, +object, +ol, +output, +p, +pre, +q, +ruby, +s, +samp, +section, +small, +span, +strike, +strong, +sub, +summary, +sup, +table, +tbody, +td, +tfoot, +th, +thead, +time, +tr, +tt, +u, +ul, +var, +video { + margin: 0; + padding: 0; + border: 0; + font-size: 100%; + font: inherit; + vertical-align: baseline; +} +/* HTML5 display-role reset for older browsers */ +article, +aside, +details, +figcaption, +figure, +footer, +header, +hgroup, +menu, +nav, +section { + display: block; +} + +body { + line-height: 1; +} + +ol, +ul { + list-style: none; +} + +blockquote, +q { + quotes: none; +} + +blockquote { + &:after, + &:before { + content: ''; + content: none; + } +} + +q { + &:after, + &:before { + content: ''; + content: none; + } +} + +table { + border-collapse: collapse; + border-spacing: 0; +} diff --git a/docs/_sass/components/_button.scss b/docs/_sass/components/_button.scss new file mode 100644 index 00000000..b01a6307 --- /dev/null +++ b/docs/_sass/components/_button.scss @@ -0,0 +1,47 @@ +// Buttons +// ---------------------------------------------- +// ---------------------------------------------- +.button { + display: block; + background: none; + border: none; + outline: none; + text-decoration: none; + position: relative; + + &:hover { + cursor: pointer; + } + + > img { + vertical-align: bottom; + } +} + + +.close { + height: 28px; + position: absolute; + left: 0; + top: 0; + width: 32px; + + &::before, + &::after { + background-color: $white; + content: " "; + height: 100%; + left: 98%; + position: absolute; + top: 50%; + width: 2px; + } + + &::before { + transform: rotate(45deg); + } + + &::after { + transform: rotate(-45deg); + } +} diff --git a/docs/_sass/components/_code.scss b/docs/_sass/components/_code.scss new file mode 100755 index 00000000..aa073d38 --- /dev/null +++ b/docs/_sass/components/_code.scss @@ -0,0 +1,23 @@ +// Code +// ---------------------------------------------- +// ---------------------------------------------- +p code, +ul code { + padding: 2px $base-point-grid; + background: rgba($gray-primary, 0.1); + font-family: $code-font-family; + border-radius: 2px; +} + + +.highlight pre { + background: rgba($brand-primary, 0.06); + padding: ($base-point-grid * 3); + overflow: auto; + margin-bottom: ($base-point-grid * 2); +} + + +code { + font-family: $code-font-family; +} diff --git a/docs/_sass/components/_doc.scss b/docs/_sass/components/_doc.scss new file mode 100755 index 00000000..cfbc00ce --- /dev/null +++ b/docs/_sass/components/_doc.scss @@ -0,0 +1,97 @@ +// Doc content +// ----------------------------------------------- +// ----------------------------------------------- +#site-doc { + position: absolute; + left: 290px; + right: 0; + top: 0; + bottom: 0; + transition: left $base-duration $base-timing; + + &.expanded { + left: 0; + } + + .doc-header { + display: flex; + align-items: center; + height: ($base-point-grid * 11); + padding: 0 ($base-point-grid * 3)0 0; + background: $white; + + .doc-toggle { + transition: transform $base-duration $base-timing; + + &:hover { + transform: scaleX(1.5); + } + + > * { + padding: ($base-point-grid * 2); + margin: ($base-point-grid * 2); + } + } + } + + .doc-content { + padding: ($base-point-grid * 3); + } + + h1 { + font-size: 2.5rem; + border-bottom: 1px solid $border-color; + } + h2 { + font-size: 2rem; + border-bottom: 1px solid $border-color; + } + h3 { + font-size: 1.5rem; + } + h4 { + font-size: 1.25rem; + } + h5 { + font-size: 1.125rem; + } + h6 { + font-size: 1rem; + } + + h1, + h2, + h3, + h4, + h5, + h6 { + margin: { + top: ($base-point-grid * 3); + bottom: ($base-point-grid * 2); + } + + &:first-child { + margin-top: 0; + } + } + + p { + margin: ($base-point-grid * 2) 0; + } + + ul { + padding-left: 20px; + margin-bottom: ($base-point-grid * 2); + li { + list-style: disc; + } + } +} + +// Responsive +// ----------------------------------------------- +@include bp(medium) { + #site-doc { + left: 0; + } +} diff --git a/docs/_sass/components/_footer.scss b/docs/_sass/components/_footer.scss new file mode 100755 index 00000000..cb77883d --- /dev/null +++ b/docs/_sass/components/_footer.scss @@ -0,0 +1,85 @@ +// Footer +// ----------------------------------------------- +// ----------------------------------------------- +#site-footer { + flex: 0 0 0; + height: 200px; + padding: ($base-point-grid * 10) 0; + background: $brand-primary; + color: rgba($white, 0.5); + + a { + color: rgba($white, 0.8); + + &:visited { + color: rgba($white, 0.8); + } + + &:hover { + color: rgba($white, 0.6); + text-decoration: underline; + } + + &:active { + color: rgba($white, 0.8); + } + + + } + + .footer-flex { + display: flex; + justify-content: space-between; + align-items: center; + height: 100%; + + .footer-dev { + width: $column-4; + } + + .footer-menu { + display: flex; + + li { + &:not(:last-child) { + margin-right: ($base-point-grid * 4) + } + } + } + } +} + +// Responsive +// ----------------------------------------------- + +@include bp(medium) { + #site-footer { + .footer-flex { + justify-content: center; + flex-wrap: wrap; + + .footer-dev, + .footer-menu { + width: $column-8; + } + + .footer-dev { + padding-bottom: ($base-point-grid * 2); + margin-bottom: ($base-point-grid * 2); + text-align: center; + border-bottom: 1px solid rgba($white, 0.2); + } + + + .footer-menu { + justify-content: center; + + li { + &:not(:last-child) { + margin-right: ($base-point-grid * 2); + } + } + } + } + } +} diff --git a/docs/_sass/components/_header.scss b/docs/_sass/components/_header.scss new file mode 100755 index 00000000..4167c043 --- /dev/null +++ b/docs/_sass/components/_header.scss @@ -0,0 +1,109 @@ +// Header +// ----------------------------------------------- +// ----------------------------------------------- + +#site-header { + flex: 1 0 auto; + margin-top: ($base-point-grid * 18); + background: rgba($brand-primary, 0.06); + + .header-flex { + display: flex; + align-items: center; + justify-content: space-evenly; + color: $white; + height: 100%; + + .header-text { + width: $column-5; + + h1 { + color: $base-font-color; + font-size: 4.188rem; + line-height: 1.3; + + span { + display: block; + margin: ($base-point-grid * 3) 0; + font-size: 1.286rem; + font-weight: $font-regular; + + strong { + font-weight: $font-bold; + } + } + } + + .header-button { + padding: ($base-point-grid * 1.5) ($base-point-grid * 6); + display: inline-block; + font-weight: $font-semibold; + text-transform: uppercase; + color: $white; + border: none; + background: $brand-primary; + border-radius: 300px; + transition: color $base-duration $base-timing, background-color $base-duration $base-timing; + + &:visited { + color: $white; + } + + &:hover { + text-decoration: none; + color: $white; + background: darken($brand-primary, 0.2); + } + + &:active { + color: $white; + background: darken($brand-primary, 0.2); + + } + } + } + + .header-image { + width: 33%; + text-align: center; + } + } +} + +// Responsive +// ----------------------------------------------- + +@include bp(large) { + #site-header { + .header-flex { + .header-text { + h1 { + font-size: 2.9rem; + } + } + .header-image { + img { + width: 100%; + } + } + } + } +} +@include bp(medium) { + #site-header { + .header-flex { + padding: ($base-point-grid * 20) 0; + .header-text { + text-align: center; + width: $column-12; + + h1 { + font-size: 2.5rem; + } + } + .header-image { + display: none; + } + } + } +} diff --git a/docs/_sass/components/_main.scss b/docs/_sass/components/_main.scss new file mode 100755 index 00000000..245455a5 --- /dev/null +++ b/docs/_sass/components/_main.scss @@ -0,0 +1,51 @@ +// Features +// ----------------------------------------------- +// ----------------------------------------------- + +#site-main { + flex: 1 0 auto; + padding: ($base-point-grid * 10) 0; + + .main-flex { + display: flex; + justify-content: space-between; + align-items: center; + height: 100%; + + .main-item { + width: $column-4; + text-align: center; + + &:not(:last-child) { + margin-right: $gutter-margin; + } + + img { + margin-bottom: $base-point-grid; + } + + h2 { + margin-bottom: $base-point-grid; + font-size: 1.429rem; + } + } + } +} + +// Responsive +// ----------------------------------------------- +@include bp(medium) { + #site-main { + .main-flex { + flex-direction: column; + .main-item { + width: $column-12; + + &:not(:last-child) { + margin-right: 0; + margin-bottom: ($base-point-grid * 8); + } + } + } + } +} diff --git a/docs/_sass/components/_nav.scss b/docs/_sass/components/_nav.scss new file mode 100755 index 00000000..61e40515 --- /dev/null +++ b/docs/_sass/components/_nav.scss @@ -0,0 +1,141 @@ +// Nav +// ----------------------------------------------- +// ----------------------------------------------- +#site-nav { + flex: 0 0 auto; + position: fixed; + padding: ($base-point-grid * 5) 0; + width: 100%; + transition: background-color $base-duration $base-timing, padding $base-duration $base-timing; + height: ($base-point-grid * 18); + + &.nav-scroll { + padding: ($base-point-grid * 2) 0; + background: rgba(244, 245, 255, 0.9); + + } + + .nav-flex { + display: flex; + justify-content: space-between; + align-items: center; + height: 100%; + + .nav-brand { + display: flex; + align-items: center; + font-family: $base-font-family; + font-size: 1.5rem; + color: $base-font-color; + + &:visited, + &:hover, + &:active { + color: $base-font-color; + text-decoration: none; + } + } + + .nav-menu { + position: relative; + + ul { + display: flex; + + .nav-menu-item { + &:not(:last-child) { + margin-right: ($base-point-grid * 5); + } + + a { + padding-bottom: 4px; + font-family: $base-font-family; + color: $gray-primary; + + &:hover { + text-decoration: none; + border-bottom: 2px solid $brand-primary; + } + } + } + } + } + + .nav-icon-open { + padding: 16px; + margin: -16px; + display: none; + transition: transform $base-duration $base-timing; + + &:hover { + transform: scaleX(1.5); + } + } + + .nav-icon-close { + display: none; + padding: 6px; + position: absolute; + background: rgba($brand-primary, 0.96); + right: 100%; + top: 32px; + + img { + display: block; + transition: transform .3s ease; + + &:hover { + transform: rotate(180deg); + } + } + } + } +} + +// Responsive +// ----------------------------------------------- +@include bp(medium) { + #site-nav { + .nav-flex { + .nav-menu { + position: fixed; + padding: ($base-point-grid * 4) ($base-point-grid * 6); + background: rgba($brand-primary, 0.96); + height: 100%; + right: -100%; + top: 0; + width: 50%; + z-index: 2; + transition: right $base-duration $base-timing; + + &.open { + right: 0; + } + + ul { + flex-direction: column; + + .nav-menu-item { + padding: $base-point-grid 0; + &:not(:last-child) { + margin-right: 0; + } + + a { + color: $white; + &:hover { + border-bottom-color: $white; + } + } + } + } + + } + + .nav-icon-open, + .nav-icon-close { + display: block; + } + } + } +} diff --git a/docs/_sass/components/_sidebar-menu.scss b/docs/_sass/components/_sidebar-menu.scss new file mode 100644 index 00000000..439c9432 --- /dev/null +++ b/docs/_sass/components/_sidebar-menu.scss @@ -0,0 +1,115 @@ +// Sidebar menu +// ----------------------------------------------- +// ----------------------------------------------- + +.sidebar-menu { + margin-top: ($base-point-grid * 2); + padding: 0; + + .sidebar-menu-item { + display: flex; + flex-direction: column; + position: relative; + + .sub-menu { + background: $sidebar-active-color; + max-height: 0; + transition: max-height 0.3s ease-in-out; + overflow: hidden; + + a { + display: flex; + justify-content: flex-start; + align-items: center; + padding: $base-point-grid * 2 $base-point-grid * 4; + font-size: 0.875rem; + height: auto; + + &.active { + color: $white; + box-shadow: 3px 0 $white inset; + } + } + } + + a, button { + box-sizing: border-box; + font-family: $base-font-family; + font-size: 1rem; + display: flex; + justify-content: space-between; + align-items: center; + padding: $base-point-grid * 2; + line-height: $base-point-grid * 2; + width: 100%; + color: $white; + @include links($white, $white, rgba($white, 0.8), $white); + transition: background $base-duration $base-timing; + + &:hover { + text-decoration: none; + } + } + + .caret { + position: absolute; + right: ($base-point-grid * 3); + top: $base-point-grid * 2; + pointer-events: none; + } + + .caret::before { + content: ''; + position: absolute; + top: 0; + left: 0; + border-left: 6px solid rgba($white, 0.8); + border-top: 6px solid transparent; + border-bottom: 6px solid transparent; + transition: border 0.3s ease, top 0.2s ease, left 0.2s ease; + } + + .caret::after { + content: ''; + position: absolute; + left: 0; + top: 2px; + border-left: 4px solid $brand-primary; + border-top: 4px solid transparent; + border-bottom: 4px solid transparent; + transition: border 0.3s ease, top 0.3s ease, left 0.3s ease; + } + + &.active { + > a, button { + box-shadow: 3px 0 $white inset; + } + } + + &.open { + > a, button { + background: $sidebar-head-active-color; + } + + .caret::before { + top: 4px; + left: -6px; + border-top: 6px solid rgba($white, 0.8); + border-left: 6px solid transparent; + border-right: 6px solid transparent; + } + + .caret::after { + left: -4px; + top: 4px; + border-top: 4px solid $brand-primary; + border-left: 4px solid transparent; + border-right: 4px solid transparent; + } + + .sub-menu { + max-height: 1600px; // This will suffice for +20 entries in a submenu tops + } + } + } +} diff --git a/docs/_sass/components/_sidebar.scss b/docs/_sass/components/_sidebar.scss new file mode 100755 index 00000000..4d9699fb --- /dev/null +++ b/docs/_sass/components/_sidebar.scss @@ -0,0 +1,89 @@ +// Sidebar +// ----------------------------------------------- +// ----------------------------------------------- + +#site-sidebar { + position: fixed; + background-image: linear-gradient(to bottom, $brand-primary 60%, darken($brand-primary, 6%) 100%); + width: 290px; + height: 100%; + left: 0; + z-index: 2; + transition: left $base-duration $base-timing; + + &:hover { + overflow: hidden auto; + } + + &.toggled { + left: -100%; + } + + .sidebar-brand { + padding: $base-point-grid + 4 $base-point-grid * 2; + font-family: $header-font-family; + font-size: 18px; + display: flex; + justify-content: center; + align-items: center; + background-color: $sidebar-active-color; + + a { + display: flex; + color: $white; + justify-content: center; + align-items: center; + width: 100%; + + &:visited, + &:hover, + &:active { + text-decoration: none; + } + + .brand-wrapper { + width: auto; + height: 64px; + } + + span { + font-size: 1.5rem; + z-index: 30; + white-space: nowrap; + font-weight: 500; + } + } + } + + .sidebar-toggle { + display: none; + } +} + +// Responsive +// ----------------------------------------------- +@include bp(medium) { + + #site-sidebar { + left: -100%; + width: 100%; + + &.toggled { + left: 0; + } + + .sidebar-toggle { + position: absolute; + right: 16px;; + padding: 24px 32px; + display: block; + opacity: 0.7; + transition: opacity 0.3s ease, transform 0.3s ease; + + &:hover { + opacity: 1; + transform: rotate(-180deg); + } + } + } +} diff --git a/docs/_sass/components/_table.scss b/docs/_sass/components/_table.scss new file mode 100644 index 00000000..19099930 --- /dev/null +++ b/docs/_sass/components/_table.scss @@ -0,0 +1,29 @@ +table { + font-size: 1rem; + text-align: left; + overflow-x: auto; + + th { + border-bottom: 3px solid rgba($brand-primary, 0.3); + border-radius: 0; + font-weight: $font-semibold; + } + + tr { + border-bottom: 1px solid rgba($brand-primary, 0.3); + border-radius: 0; + } + + th, + td { + padding: $base-point-grid $base-point-grid * 4; + + &:first-of-type { + padding-left: $base-point-grid * 2; + } + + &:last-of-type { + padding-right: $base-point-grid * 2; + } + } +} diff --git a/docs/_sass/utils/_mixins.scss b/docs/_sass/utils/_mixins.scss new file mode 100755 index 00000000..59419d42 --- /dev/null +++ b/docs/_sass/utils/_mixins.scss @@ -0,0 +1,53 @@ +// Mixins +// ----------------------------------------------- +// ----------------------------------------------- + +// Hover +//------------------------------------------------ +@mixin links($link, $visited, $hover, $active) { + & { + color: $link; + + &:visited { + color: $visited; + } + + &:hover { + color: $hover; + } + + &:active, + &:focus { + color: $active; + } + } +} + +// Breakpoint +// ----------------------------------------------- +// ----------------------------------------------- +@mixin bp($point) { + @if $point==xlarge { + @media (max-width: $bp-xlarge) { + @content; + } + } + + @if $point==large { + @media (max-width: $bp-large) { + @content; + } + } + + @if $point==medium { + @media (max-width: $bp-medium) { + @content; + } + } + + @if $point==small { + @media (max-width: $bp-small) { + @content; + } + } +} diff --git a/docs/_sass/utils/_variables.scss b/docs/_sass/utils/_variables.scss new file mode 100755 index 00000000..d10fb997 --- /dev/null +++ b/docs/_sass/utils/_variables.scss @@ -0,0 +1,74 @@ +// Variables +// ----------------------------------------------- +// ----------------------------------------------- + +// ----------------------------------------------- +// Typography +// ----------------------------------------------- +@import url('https://fonts.googleapis.com/css?family=Fira+Mono:400,500,700&display=swap'); +@import url('https://fonts.googleapis.com/css?family=Montserrat:400,600,700&display=swap'); +// @import url('https://fonts.googleapis.com/css?family=Hind:400,500,600&display=swap'); + +// Colors +// ----------------------------------------------- +$brand-primary: #66296a; +$brand-secondary: #001f39; +$gray-primary: #001f39; +$white: rgb(255, 255, 255); +$link-color: darken($brand-primary, 10%); +$link-hover: darken($brand-primary, 15%); +$sidebar-active-color: lighten($brand-primary, 2%); +$sidebar-head-active-color: lighten($brand-primary, 4%); + +// Typography +// ----------------------------------------------- +$base-font-family: 'Montserrat', sans-serif; +// $header-font-family: 'Hind', sans-serif; +$header-font-family: $base-font-family; +$code-font-family: 'Fira Mono', monospace; +//- +$base-font-color: $gray-primary; +$header-font-color: $base-font-color; +//- +$font-regular: 400; +$font-semibold: 600; +$font-bold: 700; +//- +$base-font-size: 15px; +$base-line-height: 1.6; + +// Sizes +// ----------------------------------------------- +$base-point-grid: 8px; +// Animation +// ----------------------------------------------- +$base-duration: 250ms; +$base-timing: ease-in-out; + +// Breakpoint +// ----------------------------------------------- +$bp-small: 480px; +$bp-medium: 768px; +$bp-large: 992px; +$bp-xlarge: 1140px; + +// Grid +// ----------------------------------------------- +$column-1: (1/12*100%); +$column-2: (2/12*100%); +$column-3: (3/12*100%); +$column-4: (4/12*100%); +$column-5: (5/12*100%); +$column-6: (6/12*100%); +$column-7: (7/12*100%); +$column-8: (8/12*100%); +$column-9: (9/12*100%); +$column-10: (10/12*100%); +$column-11: (11/12*100%); +$column-12: (12/12*100%); +$gutter-margin: ($base-point-grid * 4); + + +// Border +// ----------------------------------------------- +$border-color: rgba($gray-primary, 0.1); diff --git a/docs/_sass/vendors/highlight/dracula.scss b/docs/_sass/vendors/highlight/dracula.scss new file mode 100644 index 00000000..8416140d --- /dev/null +++ b/docs/_sass/vendors/highlight/dracula.scss @@ -0,0 +1,167 @@ +/* Dracula Theme v1.2.5 + * + * https://github.com/zenorocha/dracula-theme + * + * Copyright 2016, All rights reserved + * + * Code licensed under the MIT license + * http://zenorocha.mit-license.org + * + * @author Rob G + * @author Chris Bracco + * @author Zeno Rocha + * @author Piruin Panichphol + */ + +/* + * Variables + */ + +$dt-gray-dark: #282a36; // Background +$dt-gray: #44475a; // Current Line & Selection +$dt-gray-light: #f8f8f2; // Foreground +$dt-blue: #6272a4; // Comment +$dt-cyan: #8be9fd; +$dt-green: #50fa7b; +$dt-orange: #ffb86c; +$dt-pink: #ff79c6; +$dt-purple: #bd93f9; +$dt-red: #ff5555; +$dt-yellow: #f1fa8c; + +/* + * Styles + */ + +.highlight { + background: $dt-gray-dark; + color: $dt-gray-light; + + .hll, + .s, + .sa, + .sb, + .sc, + .dl, + .sd, + .s2, + .se, + .sh, + .si, + .sx, + .sr, + .s1, + .ss { + color: $dt-yellow; + } + + .go { + color: $dt-gray; + } + + .err, + .g, + .l, + .n, + .x, + .p, + .ge, + .gr, + .gh, + .gi, + .gp, + .gs, + .gu, + .gt, + .ld, + .no, + .nd, + .ni, + .ne, + .nn, + .nx, + .py, + .w, + .bp { + color: $dt-gray-light; + } + + .gh, + .gi, + .gu { + font-weight: bold; + } + + .ge { + text-decoration: underline; + } + + .bp { + font-style: italic; + } + + .c, + .ch, + .cm, + .cpf, + .c1, + .cs { + color: $dt-blue; + } + + .kd, + .kt, + .nb, + .nl, + .nv, + .vc, + .vg, + .vi, + .vm { + color: $dt-cyan; + } + + .kd, + .nb, + .nl, + .nv, + .vc, + .vg, + .vi, + .vm { + font-style: italic; + } + + .na, + .nc, + .nf, + .fm { + color: $dt-green; + } + + .k, + .o, + .cp, + .kc, + .kn, + .kp, + .kr, + .nt, + .ow { + color: $dt-pink; + } + + .m, + .mb, + .mf, + .mh, + .mi, + .mo, + .il { + color: $dt-purple; + } + + .gd { + color: $dt-red; + } +} diff --git a/docs/css/docs.scss b/docs/css/docs.scss new file mode 100644 index 00000000..0ba96a32 --- /dev/null +++ b/docs/css/docs.scss @@ -0,0 +1,23 @@ +--- +--- + +// Utils +@import "utils/variables"; +@import "utils/mixins"; + +// Base +@import "base/reset"; +@import "base/base"; +@import "base/helpers"; + +// Components +@import "components/button"; +@import "components/footer"; +@import "components/sidebar"; +@import "components/sidebar-menu"; +@import "components/doc"; +@import "components/code"; +@import "components/table"; + +// Vendor +@import "vendors/highlight/dracula"; diff --git a/docs/docs/README.md b/docs/docs/README.md new file mode 100644 index 00000000..575a09c9 --- /dev/null +++ b/docs/docs/README.md @@ -0,0 +1,20 @@ +--- +layout: docs +title: Mu-Haskell +permalink: / +--- + +# Docs for Mu-Haskell + +Mu-Haskell is a set of packages that help you build both servers and clients for (micro)services. The main goal of Mu-Haskell is to make you focus on your domain logic, instead of worrying about format and protocol issues. + +* [Introduction]({% link docs/intro.md %}) +* [Schemas]({% link docs/schema.md %}) + * [Registry]({% link docs/registry.md %}) +* [Services and servers]({% link docs/rpc.md %}) + * [gRPC servers and clients]({% link docs/grpc.md %}) + * [Streams]({% link docs/stream.md %}) + * [Databases]({% link docs/db.md %}), including resource pools +* Integration with other libraries + * [Using transformers]({% link docs/transformer.md %}): look here for logging + * [WAI Middleware]({% link docs/middleware.md %}): look here for metrics diff --git a/docs/db.md b/docs/docs/db.md similarity index 99% rename from docs/db.md rename to docs/docs/db.md index 9b8a6493..57067523 100644 --- a/docs/db.md +++ b/docs/docs/db.md @@ -1,3 +1,9 @@ +--- +layout: docs +title: Mu-Haskell +permalink: db/ +--- + # Databases In this section of the docs, to have a clearer understanding of how one would use `mu-haskell` to talk to a database, we are going to have a walk through the example of [`with-persistent`](https://github.com/higherkindness/mu-haskell/tree/master/examples/with-persistent). diff --git a/docs/grpc.md b/docs/docs/grpc.md similarity index 93% rename from docs/grpc.md rename to docs/docs/grpc.md index 6863378e..1d9b3183 100644 --- a/docs/grpc.md +++ b/docs/docs/grpc.md @@ -1,3 +1,9 @@ +--- +layout: docs +title: Mu-Haskell +permalink: grpc/ +--- + # gRPC servers and clients Mu-Haskell defines a generic notion of service and server that implements it. This generic server can then be used by `mu-grpc-server`, to provide a concrete implementation using a specific wire format. Or you can use `mu-grpc-client` to build a client. diff --git a/docs/intro.md b/docs/docs/intro.md similarity index 99% rename from docs/intro.md rename to docs/docs/intro.md index f4366eeb..8ba37cd3 100644 --- a/docs/intro.md +++ b/docs/docs/intro.md @@ -1,3 +1,9 @@ +--- +layout: docs +title: Mu-Haskell +permalink: intro/ +--- + # Introduction to Mu-Haskell Many companies have embraced microservices architectures as the best way to scale up their internal software systems, separate work across different company divisions and development teams. Microservices architectures also allow teams to turn an idea or bug report into a working feature of fix in production more quickly, in accordance to the agile principles. diff --git a/docs/middleware.md b/docs/docs/middleware.md similarity index 98% rename from docs/middleware.md rename to docs/docs/middleware.md index 7f49211f..5337014a 100644 --- a/docs/middleware.md +++ b/docs/docs/middleware.md @@ -1,3 +1,9 @@ +--- +layout: docs +title: Mu-Haskell +permalink: middleware/ +--- + # Integration with WAI middleware Although you usually run a `mu-rpc` server directly using a function like `runGRpcApp`, this is just a convenience function to make it simpler to run the server. Under the hood, the library generates a so-called WAI application, which is then fed to an actual server. diff --git a/docs/registry.md b/docs/docs/registry.md similarity index 94% rename from docs/registry.md rename to docs/docs/registry.md index 72403d50..27c8026e 100644 --- a/docs/registry.md +++ b/docs/docs/registry.md @@ -1,3 +1,9 @@ +--- +layout: docs +title: Mu-Haskell +permalink: registry/ +--- + # Registry Schemas evolve over time. It is a good practice to keep an inventory of all the schemas you can work with, in the form of a *registry*. Using `mu-schema` you can declare one such registry as simply a mapping from versions to schemas: diff --git a/docs/rpc.md b/docs/docs/rpc.md similarity index 99% rename from docs/rpc.md rename to docs/docs/rpc.md index 99aa35f4..79b4d400 100644 --- a/docs/rpc.md +++ b/docs/docs/rpc.md @@ -1,3 +1,9 @@ +--- +layout: docs +title: Mu-Haskell +permalink: rpc/ +--- + # Services and servers There are several formats in the wild used to declare service APIs, including [Avro IDL](https://avro.apache.org/docs/current/idl.html), [gRPC](https://grpc.io/), and [OpenAPI](https://swagger.io/specification/). `mu-rpc` abstract the commonalities into a single type-level format for declaring these services, building on the format-independent schema facilities of `mu-schema`. In addition, this package provides a generic notion of *server* of a service. One such server defines one behavior for each method in the service, but does not bother with (de)serialization mechanisms. diff --git a/docs/schema.md b/docs/docs/schema.md similarity index 99% rename from docs/schema.md rename to docs/docs/schema.md index 0c1be938..ddb2ec2c 100644 --- a/docs/schema.md +++ b/docs/docs/schema.md @@ -1,3 +1,9 @@ +--- +layout: docs +title: Mu-Haskell +permalink: schema/ +--- + # Schemas Using `mu-schema` you can describe a schema for your data using type-level techniques. You can then automatically generate: diff --git a/docs/stream.md b/docs/docs/stream.md similarity index 96% rename from docs/stream.md rename to docs/docs/stream.md index 8ce61907..30779e7e 100644 --- a/docs/stream.md +++ b/docs/docs/stream.md @@ -1,3 +1,9 @@ +--- +layout: docs +title: Mu-Haskell +permalink: stream/ +--- + # Streams In the docs about [service definition](rpc.md) we had one single `SayHello` method which takes one value and produces one value. However, we can also declare methods which perform streaming, such as: diff --git a/docs/transformer.md b/docs/docs/transformer.md similarity index 98% rename from docs/transformer.md rename to docs/docs/transformer.md index 1ec49895..a17e6d22 100644 --- a/docs/transformer.md +++ b/docs/docs/transformer.md @@ -1,3 +1,9 @@ +--- +layout: docs +title: Mu-Haskell +permalink: transformer/ +--- + # Integration using transformers You might be wondering: how can I integrate my favorite logging library with `mu-grpc-server`? Our [explanation of services](rpc.md) introduced `MonadServer` as the simplest set of capabilities required for a server: diff --git a/docs/img/favicon.png b/docs/img/favicon.png new file mode 100644 index 0000000000000000000000000000000000000000..74aa4b9f301875711ce055a38b45b94e4f28009b GIT binary patch literal 2790 zcmVo7lfl5@O62lnUzlLMg)N`irOyIr17TdR`2$puV>FHNA zpxUWE!GTu+wS&C9&1mT}1)3jjSMMtd(8M|)QKk4Q(D^`McuLZ0Vm1kmu-piol8p9O zSTpmj`u;%=XhNgY)jfR1crkD&P!PVpst_!^r(J&;_}Q9zpDMf>ct_H7Pi!@Hx9Q=7 z63}25j5H(PqF)XL&;u4w?b&|2LpK8-8qoYFN#}I7=Nn-|nVIJII`S%sOw#nTAkd7B>y$rW0OfKH zH>YU?UkSVxh`?(?2Mase^z@V|9?^4{@9a;)&;4It!1^iR7 z#ka){=4@)!U_h zQYmI5&jm&U+mV+&R~=mYz#2UV)~PuT*_&LYVUW|C!OH|6Pn!NuXm)3-zER2{X~kCy zowqBD%%i+VvA<~eKyvI)gFsE?%BFUz-{>&D7Hev9ZGS*+!}=637I+wRe!f-r?Q=lc zoX13|_%fuKz(}A6X-Sx-xnr$%jL*4hY>FAk3xGp*mD3<{?AHBeACC&zi-I2V$ zuXd`x+AkYx;piTpS5xP?U2Uuf`NaV#rat-w=nTOze;mQ_ig_JCO7sk?#3r5V*QcU* zDOLj@nJ0|q<=bchdBC*(ndBxsW3(vsBwy<2P~Tv3ly!CWHk$9cOV5`no9;MP(@_yW z+Z=M5#p~jj&P})KvC=Uoo$a@Tp??lk59sQr;gg!!(V@N}2Q)tCs>4#umOMW>=?=*& zMh3w(ci*DFWwTE8jiXWWmB4F&KFMp+VX$z+&H8h)TR%tmnnaE<_AP|L{QNrou^idd z{F+ZH@Dj|CKny&d%zgm9k{UZ(^tFMTU;-~Tyji&0gm@ltQI5d9pr$>UQTnBQzF!q=j~5`#07d|h8s8^W2W;<^ z#+93dhb#w0>3A{LM4*RQQ}gR}XDN>a_Hx@F8!V6Pl%ofg@Z$FDitif`xgCeX!ZgAAJFN@^K0v)_ZdzA3L~m`bf}guWdpJ}3LrG=0ixdc zdZg(|9{Cz!Fuya&Bbf%D8TERZ#L+L5WANLdT$J_|f)%N>&jKbGO#qBEubA)lF`!bu z+WFO|{tZCV#htCe7XfOf`Q3`V3Ok#C`ME1w)Dbg|fDQQ; zbr0n^UdlQs4d7mGOBQ?c9Q!In2yBsc#SwjcrM*qjaBhe@+SLQxI9&awUTOznHHBms z{U1Omye6m$=60;rHV%SF4Pjp)KokdyI}Z{#B;UvlZHFn$K@&1yB-UT>NiF9Qc+Z zDb0y`{i{ra&wQl=>H{c5d<3AYC7h3y6+8$WjoqH9k2`9n`Q5{L0TUXX&eZ#i+B#pD zt@GPnPC$mD=Q(+~0l@Z+nfhpDcDi4kZ_~yj3Odo~LSPGUvSL3_(-7T|$@%c19{dN- zadmZ%H-W!t`G!b-C{yPPULHW=spNo<1H>bPPh0+Su}L$dUO!S(??!;GR;>xEbS$_T zh-FrV2%eRKJ;y~{Nz6ZP-ymEApADZ0YDMK@SPbmJ;W%<_d zJm7v{)Q*rLlUmshvzmGzCY%Sx1Ciygs5iKxWM|7X_)P3&P_(=V+JjhgN)EKi4W1%< zrRX30_u@day4UH~dphVTQ#_()EHkjL0LBO&H2xvzVj$`(XxzQ++PY5xL1M#8$BRM# zNzvW04RqymWB9@YYgCw&^Qd&1ON{4H^e}EWUNJf>nx-Z+Iz76F&w>{gpC}68FN9UW zmF1cpGW9+Kyc~FI(zKPLNjyo3y0oiJEBkNk**;cbyujAcfxIai8C;z>)P^2VDJDg0js(>Rg8wPqFvkiVjWIvSLj8b&xk5z5Cl|e7bNWMGS3})O6 zq!}Aq^b;6hxDwf9Fb~>l%C~7_=^T@C9-AsYwHHxzqih9zE_{+3c4y_y)OjKDV$8Q4 zs#&qu0&fbelQy>L-eCt+T8I2&+4MW{uK~s}i1l~Z{Drwa3^hNBIgMfg-Pq!~%Qy5D zg3pzkUuqhnTV`@73_8cD{MQ$D-#|U_WV#(B>jgIMR)ie7PQ2$-qjcodD!=hvxe$3MB zt`^;qo#wYjk#8&=3p@(CG~cRkm2>V>&h=}a?~50!xKK?2TaE7!ss~2NJOMhlvrRu3 z)+All6E&D@1{lu=sV92?IKK3BAzd|QE303uG~oqLOxCIBC@y+2IZn!XRC**wcD{wj z_q1$tSSt<(k=Nu>3`CsE=rO^1jk>kq>sDCCJ zWZI9>%0RB$wK%1Fz3wjyeo>Aq5U1~r9QP|g1C|B5PWu2)+q!tS%u}Xr(8K6Ab|SUPot}Q z;yFfhDb|cVC%i1E3YK=P)s9`Z7w;EdJ)oBLCxJDi+{NAj324A3`0t80oiW70<7jn3VIV3WZ8k;-HWJ2PO$@DhJ{}QUCw|07*qoM6N<$f;e + + + header-image + Created with Sketch. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/docs/img/main-feature-primary.svg b/docs/img/main-feature-primary.svg new file mode 100644 index 00000000..8f7a7569 --- /dev/null +++ b/docs/img/main-feature-primary.svg @@ -0,0 +1,75 @@ + + + + feature-primary + Created with Sketch. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/docs/img/main-feature-secondary.svg b/docs/img/main-feature-secondary.svg new file mode 100644 index 00000000..f73063d5 --- /dev/null +++ b/docs/img/main-feature-secondary.svg @@ -0,0 +1,110 @@ + + + + main-feature-secondary + Created with Sketch. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/docs/img/main-feature-tertiary.svg b/docs/img/main-feature-tertiary.svg new file mode 100644 index 00000000..176fbd4b --- /dev/null +++ b/docs/img/main-feature-tertiary.svg @@ -0,0 +1,55 @@ + + + + main-feature-tertiary + Created with Sketch. + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + \ No newline at end of file diff --git a/docs/img/nav-brand-white.svg b/docs/img/nav-brand-white.svg new file mode 100644 index 00000000..99bbd853 --- /dev/null +++ b/docs/img/nav-brand-white.svg @@ -0,0 +1,9 @@ + + + + nav-brand + Created with Sketch. + + + + diff --git a/docs/img/nav-brand.svg b/docs/img/nav-brand.svg new file mode 100644 index 00000000..4230051b --- /dev/null +++ b/docs/img/nav-brand.svg @@ -0,0 +1,9 @@ + + + + nav-brand + Created with Sketch. + + + + \ No newline at end of file diff --git a/docs/img/nav-icon-close.svg b/docs/img/nav-icon-close.svg new file mode 100644 index 00000000..076619eb --- /dev/null +++ b/docs/img/nav-icon-close.svg @@ -0,0 +1,12 @@ + + + + nav-icon-close + Created with Sketch. + + + + + + + \ No newline at end of file diff --git a/docs/img/nav-icon-open.svg b/docs/img/nav-icon-open.svg new file mode 100644 index 00000000..c4cd84d6 --- /dev/null +++ b/docs/img/nav-icon-open.svg @@ -0,0 +1,13 @@ + + + + nav-icon-open + Created with Sketch. + + + + + + + + \ No newline at end of file diff --git a/docs/img/sidebar-icon-open.svg b/docs/img/sidebar-icon-open.svg new file mode 100644 index 00000000..3df658e8 --- /dev/null +++ b/docs/img/sidebar-icon-open.svg @@ -0,0 +1,11 @@ + + + + sidebar-icon-open + Created with Sketch. + + + + + + \ No newline at end of file diff --git a/docs/js/docs.js b/docs/js/docs.js new file mode 100644 index 00000000..5a87994b --- /dev/null +++ b/docs/js/docs.js @@ -0,0 +1,162 @@ +/** + * Toggle an specific class to the received DOM element. + * @param {string} elemSelector The query selector specifying the target element. + * @param {string} [activeClass='active'] The class to be applied/removed. + */ +function toggleClass(elemSelector, activeClass = 'active') { + const elem = document.querySelector(elemSelector); + if (elem) { + elem.classList.toggle(activeClass); + } +} + +/** + * Toggle specific classes to an array of corresponding DOM elements. + * @param {Array} elemSelectors The query selectors specifying the target elements. + * @param {Array} activeClasses The classes to be applied/removed. + */ +function toggleClasses(elemSelectors, activeClasses) { + elemSelectors.map((elemSelector, idx) => { + toggleClass(elemSelector, activeClasses[idx]); + }); +} + +/** + * Remove active class from siblings DOM elements and apply it to event target. + * @param {Element} element The element receiving the class, and whose siblings will lose it. + * @param {string} [activeClass='active'] The class to be applied. + */ +function activate(element, activeClass = 'active') { + [...element.parentNode.children].map((elem) => elem.classList.remove(activeClass)); + element.classList.add(activeClass); +} + +/** + * Remove active class from siblings parent DOM elements and apply it to element target parent. + * @param {Element} element The element receiving the class, and whose siblings will lose it. + * @param {string} [activeClass='active'] The class to be applied. + */ +function activateParent(element, activeClass = 'active') { + const elemParent = element.parentNode; + activate(elemParent, activeClass); +} + +/** + * Remove active class from siblings parent DOM elements and apply it to element target parent. + * @param {Element} element The element receiving the class, and whose siblings will lose it. + * @param {string} [activeClass='active'] The class to be applied. + */ +function toggleParent(element, activeClass = "active") { + const elemParent = element.parentNode; + if (elemParent) { + elemParent.classList.toggle(activeClass); + } +} + +/** + * This will make the specified elements click event to show/hide the menu sidebar. + */ +function activateToggle() { + const menuToggles = document.querySelectorAll("#menu-toggle, #main-toggle"); + if (menuToggles) { + [...menuToggles].map(elem => { + elem.onclick = e => { + e.preventDefault(); + toggleClass("#site-sidebar", "toggled"); + toggleClass("#site-doc", "expanded"); + }; + }); + } +} + +/** + * This will make the specified elements click event to behave as a menu + * parent entry, or a link, or sometimes both, depending on the context. + */ +function activateMenuNesting() { + const menuParents = document.querySelectorAll(".drop-nested"); + if (menuParents) { + [...menuParents].map(elem => { + elem.onclick = e => { + e.preventDefault(); + toggleParent(elem, "open"); + const elementType = e.currentTarget.tagName.toLowerCase(); + if (elementType === "a") { + const linkElement = e.currentTarget; + const linkElementParent = linkElement.parentNode; + const destination = linkElement.href; + if ( + destination !== window.location.href && + !linkElementParent.classList.contains("active") + ) { + window.location.href = destination; + } + } + }; + }); + } +} + +/** + * Aux function to retrieve repository stars and watchers count info from + * GitHub API and set it on its proper nodes. + */ +async function loadGitHubStats() { + const content = document.querySelector("#content"); + const ghOwner = content.dataset.githubOwner; + const ghRepo = content.dataset.githubRepo; + + if (ghOwner && ghRepo) { + const ghAPI = `https://api.github.com/repos/${ghOwner}/${ghRepo}`; + const ghDataResponse = await fetch(ghAPI); + const ghData = await ghDataResponse.json(); + const watchersElement = document.querySelector("#eyes"); + const starsElement = document.querySelector("#stars"); + watchersElement.textContent = ghData.subscribers_count; + starsElement.textContent = ghData.stargazers_count; + } +} + +/** + * Function to create an anchor with an specific id + * @param {string} id The corresponding id from which the href will be created. + * @returns {Element} The new created anchor. + */ +function anchorForId(id) { + const anchor = document.createElement("a"); + anchor.className = "header-link"; + anchor.href = `#${id}`; + anchor.innerHTML = ''; + return anchor; +} + +/** + * Aux function to retrieve repository stars and watchers count info from + * @param {string} level The specific level to select header from. + * @param {Element} containingElement The element receiving the anchor. + */ +function linkifyAnchors(level, containingElement) { + const headers = containingElement.getElementsByTagName(`h${level}`); + [...headers].map(header => { + if (typeof header.id !== "undefined" && header.id !== "") { + header.append(anchorForId(header.id)); + } + }); +} + +/** + * Function + */ +function linkifyAllLevels() { + const content = document.querySelector("#content"); + [...Array(7).keys()].map(level => { + linkifyAnchors(level, content); + }); +} + +window.addEventListener("DOMContentLoaded", () => { + activateToggle(); + activateMenuNesting(); + // loadGitHubStats(); + // linkifyAllLevels(); +}); diff --git a/docs/js/main.js b/docs/js/main.js new file mode 100755 index 00000000..b5496eed --- /dev/null +++ b/docs/js/main.js @@ -0,0 +1,31 @@ +// This initialization requires that this script is loaded with `defer` +const navElement = document.querySelector("#site-nav"); + +/** + * Toggle an specific class to the received DOM element. + * @param {string} elemSelector The query selector specifying the target element. + * @param {string} [activeClass='active'] The class to be applied/removed. + */ +function toggleClass(elemSelector, activeClass = "active") { + const elem = document.querySelector(elemSelector); + if (elem) { + elem.classList.toggle(activeClass); + } +} + +// Navigation element modification through scrolling +function scrollFunction() { + if (document.documentElement.scrollTop > 0) { + navElement.classList.add("nav-scroll"); + } else { + navElement.classList.remove("nav-scroll"); + } +} + +// Init call +function loadEvent() { + document.addEventListener("scroll", scrollFunction); +} + +// Attach the functions to each event they are interested in +window.addEventListener("load", loadEvent); From 27479ab9fcf0b50eaac16e8199b2f9155c22cc3c Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Fri, 20 Dec 2019 13:15:41 +0100 Subject: [PATCH 028/217] Script to generate standalone Haddock documentation (#55) --- .gitignore | 1 + generate-haddock-docs.sh | 23 +++++++++++++++++++++++ run-docs.sh | 4 ++++ 3 files changed, 28 insertions(+) create mode 100755 generate-haddock-docs.sh create mode 100755 run-docs.sh diff --git a/.gitignore b/.gitignore index 312fe419..ed52919f 100644 --- a/.gitignore +++ b/.gitignore @@ -16,3 +16,4 @@ _site ## Ruby environment normalization: .bundle/ /docs/vendor/ +docs/haddock diff --git a/generate-haddock-docs.sh b/generate-haddock-docs.sh new file mode 100755 index 00000000..3a896c36 --- /dev/null +++ b/generate-haddock-docs.sh @@ -0,0 +1,23 @@ +#!/bin/sh + +DOCSDIR=docs/haddock + +echo "Installing required packages" +stack install standalone-haddock + +echo "Removing previous docs" +rm -rf ${DOCSDIR} + +echo "Building the project" +stack build + +echo "Generating new docs" +stack exec --no-ghc-package-path standalone-haddock -- -o ${DOCSDIR} \ + --compiler-exe=$(stack path --compiler-exe) \ + --dist-dir=$(stack path --dist-dir) \ + --package-db=$(stack path --snapshot-pkg-db) \ + --package-db=$(stack path --local-pkg-db) \ + core/schema core/rpc \ + adapter/avro adapter/protobuf adapter/persistent \ + grpc/client grpc/server \ + compendium-client diff --git a/run-docs.sh b/run-docs.sh new file mode 100755 index 00000000..ea5503dc --- /dev/null +++ b/run-docs.sh @@ -0,0 +1,4 @@ +#!/bin/sh + +bundle install --gemfile docs/Gemfile --path vendor/bundle +BUNDLE_GEMFILE=./docs/Gemfile bundle exec jekyll serve -s docs -b /mu-haskell From a0fd84f7c4dd787cadbe8230a9fac11172492f39 Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Fri, 20 Dec 2019 13:54:39 +0100 Subject: [PATCH 029/217] Update docs with Higher Kinded Data (#56) --- docs/docs/db.md | 20 +++++++++++++------- docs/docs/grpc.md | 6 ++++++ docs/docs/intro.md | 15 ++++++++++----- docs/docs/rpc.md | 24 +++++++++++++++--------- docs/docs/schema.md | 25 +++++++++++++++---------- docs/docs/stream.md | 4 ++-- examples/with-persistent/src/Schema.hs | 4 ++-- 7 files changed, 63 insertions(+), 35 deletions(-) diff --git a/docs/docs/db.md b/docs/docs/db.md index 57067523..109884d4 100644 --- a/docs/docs/db.md +++ b/docs/docs/db.md @@ -70,8 +70,8 @@ instance FromSchema Maybe PersistentSchema "PersonRequest" MPersonRequest data MPerson = MPerson { pid :: Maybe MPersonRequest , name :: Maybe T.Text - , age :: Maybe Int32 } - deriving (Eq, Ord, Show, Generic) + , age :: Maybe Int32 + } deriving (Eq, Ord, Show, Generic) instance ToSchema Maybe PersistentSchema "Person" MPerson instance FromSchema Maybe PersistentSchema "Person" MPerson @@ -181,9 +181,10 @@ More on that strange `runDb` method in the next section! 😇 All the pieces are now in place, let's check the implementation of the `allPeople` service: ```haskell -allPeople :: SqlBackend - -> ConduitT (Entity Person) Void ServerErrorIO () - -> ServerErrorIO () +allPeople + :: SqlBackend + -> ConduitT (Entity Person) Void ServerErrorIO () + -> ServerErrorIO () allPeople conn sink = runDb conn $ runConduit $ selectSource [] [] .| liftServerConduit sink ``` @@ -196,9 +197,14 @@ The second one will be discussed in the next section. ## On streams and `Conduit` -Since we are going to work with streams, it is wonderful that `persistent` also provides methods to work with `Conduit` like, for example, `selectSource`. But the Monad in which `persistent` operates returns `ConduitM () (Entity Person) m ()`, and we know that we want instead: `ConduitT (Entity Person) Void ServerErrorIO ()`. 🤔 +Since we are going to work with streams, it is wonderful that `persistent` also provides methods to work with `Conduit` like, for example, `selectSource`. However... -Well, have no fear my friend because we created yet another utility called `liftServerConduit`, orn specifically to address this problem. It's type signature is: +```diff +- ConduitM () (Entity Person) m () -- the Monad in which persistent operates ++ ConduitT (Entity Person) Void ServerErrorIO () -- the Monad we know we want instead... 🤔 +``` + +Well, have no fear my friend because we created yet another utility called `liftServerConduit`, born specifically to address this problem. Its type signature is: ```haskell liftServerConduit diff --git a/docs/docs/grpc.md b/docs/docs/grpc.md index 1d9b3183..f7f27f26 100644 --- a/docs/docs/grpc.md +++ b/docs/docs/grpc.md @@ -18,6 +18,12 @@ main = runGRpcApp 8080 "helloworld" quickstartServer ## Building a client +-- TODO: + ### Using records +-- TODO: + ### Using `TypeApplications` + +-- TODO: diff --git a/docs/docs/intro.md b/docs/docs/intro.md index 8ba37cd3..dfff2858 100644 --- a/docs/docs/intro.md +++ b/docs/docs/intro.md @@ -57,17 +57,22 @@ The aforementioned `.proto` file defines two messages. The corresponding data ty ```haskell data HelloRequestMessage - = HelloRequestMessage { name :: T.Text } - deriving (Eq, Show, Generic, HasSchema Schema "HelloRequest") + = HelloRequestMessage { name :: Maybe T.Text } + deriving (Eq, Show, Generic + , ToSchema Maybe Schema "HelloRequest" + , FromSchema Maybe Schema "HelloRequest") data HelloReplyMessage - = HelloReplyMessage { message :: T.Text } - deriving (Eq, Show, Generic, HasSchema Schema "HelloReply") + = HelloReplyMessage { message :: Maybe T.Text } + deriving (Eq, Show, Generic + , ToSchema Maybe Schema "HelloReply", + , FromSchema Maybe Schema "HelloReply") ``` You can give those data types and their constructors any name you like. However, keep in mind that: * The names of the fields must correspond with those in the `.proto` files. Otherwise you have to use a *custom mapping*, which is fully supported by `mu-schema` but requires more code. +* All the fields must be wrapped in `Maybe` since all fields in `proto3` are **optional by default**. * The name between quotes in each `deriving` clause defines the message type in the `.proto` file each data type corresponds to. * To use the automatic-mapping functionality, it is required to also derive `Generic`, don't forget it! @@ -81,7 +86,7 @@ Open the `src/Main.hs` file. The contents are quite small right now: a `main` fu main :: IO () main = runGRpcApp 8080 server -server :: (MonadServer m) => ServerT Service m _ +server :: (MonadServer m) => ServerT Maybe Service m _ server = Server H0 ``` diff --git a/docs/docs/rpc.md b/docs/docs/rpc.md index 79b4d400..eafadc55 100644 --- a/docs/docs/rpc.md +++ b/docs/docs/rpc.md @@ -43,7 +43,7 @@ This is everything you need to start using gRPC services and clients in Haskell! ### Looking at the resulting code -In order to use the library proficiently, we should look a bit at the code generated in the previous code. A type-level description of the messages is put into the type `QuickstartSchema`. However, there is some code you still have to write by hand, namely the Haskell type which correspond to that schema. Using `mu-schema` facilities, this amounts to declaring a bunch of data types and including `deriving (Generic, HasSchema Schema "type")` at the end of each of them. +In order to use the library proficiently, we should look a bit at the code generated in the previous code. A type-level description of the messages is put into the type `QuickstartSchema`. However, there is some code you still have to write by hand, namely the Haskell type which correspond to that schema. Using `mu-schema` facilities, this amounts to declaring a bunch of data types and including `deriving (Generic, ToSchema Maybe Schema "type", FromSchema Maybe Schema "type")` at the end of each of them. ```haskell {-# language PolyKinds, DataKinds, TypeFamilies #-} @@ -66,10 +66,16 @@ type instance AnnotatedSchema ProtoBufAnnotation QuickstartSchema , 'AnnField "HelloResponse" "message" ('ProtoBufId 1) ] -- TO BE WRITTEN -newtype HelloRequest = HelloRequest { name :: T.Text } - deriving (Generic, HasSchema QuickstartSchema "HelloRequest") -newtype HelloResponse = HelloResponse { message :: T.Text } - deriving (Generic, HasSchema QuickstartSchema "HelloResponse") +newtype HelloRequest + = HelloRequest { name :: Maybe T.Text } + deriving (Generic + , ToSchema Maybe QuickstartSchema "HelloRequest" + , FromSchema Maybe QuickstartSchema "HelloRequest") +newtype HelloResponse + = HelloResponse { message :: Maybe T.Text } + deriving (Generic + , ToSchema Maybe QuickstartSchema "HelloResponse" + , FromSchema Maybe QuickstartSchema "HelloResponse") ``` The service declaration looks very similar to an schema declaration, but instead of record and enumerations you define *methods*. Each method has a name, a list of arguments, and a return type. @@ -81,8 +87,8 @@ import Mu.Rpc type QuickstartService = 'Service "Greeter" '[ 'Method "SayHello" - '[ 'ArgSingle ('FromSchema QuickstartSchema "HelloRequest") ] - ('RetSingle ('FromSchema QuickstartSchema "HelloResponse")) ] + '[ 'ArgSingle ('FromSchema QuickstartSchema "HelloRequest") ] + ('RetSingle ('FromSchema QuickstartSchema "HelloResponse")) ] ``` In order to support both [Avro IDL](https://avro.apache.org/docs/current/idl.html) and [gRPC](https://grpc.io/), the declaration of the method arguments and returns in a bit fancier that you might expect: @@ -94,7 +100,7 @@ Note that depending on the concrete implementation you use to run the server, on ## Implementing the service -In order to implement the service, you have to define the behavior of each method by means of a *handler*. You can use Haskell types for your handlers, given that you had previously declared that they can be mapped back and forth the schema types using `HasSchema`. For example, the following is a handler for the `SayHello` method in `Greeter`: +In order to implement the service, you have to define the behavior of each method by means of a *handler*. You can use Haskell types for your handlers, given that you had previously declared that they can be mapped back and forth the schema types using `ToSchema` and `FromSchema`. For example, the following is a handler for the `SayHello` method in `Greeter`: ```haskell sayHello :: (MonadServer m) => HelloRequest -> m HelloResponse @@ -113,6 +119,6 @@ Since you can declare more than one method in a service, you need to join them i ```haskell {-# language PartialTypeSignatures #-} -quickstartServer :: (MonadServer m) => ServerT QuickstartService m _ +quickstartServer :: (MonadServer m) => ServerT Maybe QuickstartService m _ quickstartServer = Server (sayHello :<|>: H0) ``` diff --git a/docs/docs/schema.md b/docs/docs/schema.md index ddb2ec2c..69d7697e 100644 --- a/docs/docs/schema.md +++ b/docs/docs/schema.md @@ -89,29 +89,34 @@ data Address = Address { postcode :: T.Text , country :: T.Text } deriving (Eq, Show, Generic) - deriving (HasSchema ExampleSchema "address") + deriving (ToSchema Maybe ExampleSchema "address") + deriving (FromSchema Maybe ExampleSchema "address") ``` -Once again, you need to enable some extensions in the compiler (but do not worry, GHC should tell you which ones you need in case you forgot). You first must include `Generic` in the list of automatically-derived classes. Then you *derive* the mapping by using the line: +Once again, you need to enable some extensions in the compiler (but do not worry, GHC should tell you which ones you need in case you forgot). You first must include `Generic` in the list of automatically-derived classes. Then you *derive* the mapping by using the lines: ```haskell - deriving (HasSchema YourSchema "yourSchemaType") + deriving (ToSchema Maybe YourSchema "yourSchemaType") + deriving (FromSchema Maybe YourSchema "yourSchemaType") ``` ## Customizing the mapping -Sometimes the names of the fields in the Haskell data type and the names of the fields in the schema do not match. For example, in our schema above we use `male`, `female`, and `nb`, but in a Haskell enumeration the name of each constructor must begin with a capital letter. By using a stand-along `HasSchema` instance you can declare a custom mapping from Haskell fields or constructors to schema fields or enum choices, respectively: +Sometimes the names of the fields in the Haskell data type and the names of the fields in the schema do not match. For example, in our schema above we use `male`, `female`, and `nb`, but in a Haskell enumeration the name of each constructor must begin with a capital letter. By using a stand-along `ToSchema` instance you can declare a custom mapping from Haskell fields or constructors to schema fields or enum choices, respectively: ```haskell +{-# language DerivingVia #-} {-# language TypeFamilies #-} -data Gender = Male | Female | NonBinary +type GenderFieldMapping + = '[ "Male" ':-> "male" + , "Female" ':-> "female" + , "NonBinary" ':-> "nb" ] -instance HasSchema ExampleSchema "gender" Gender where - type FieldMapping ExampleSchema "gender" Gender - = '[ "Male" ':-> "male" - , "Female" ':-> "female" - , "NonBinary" ':-> "nb" ] +data Gender = Male | Female | NonBinary + deriving (Eq, Show, Generic) + deriving (ToSchema f ExampleSchema "gender", FromSchema f ExampleSchema "gender") + via (CustomFieldMapping "gender" GenderFieldMapping Gender) ``` ### Protocol Buffers field identifiers diff --git a/docs/docs/stream.md b/docs/docs/stream.md index 30779e7e..ca345451 100644 --- a/docs/docs/stream.md +++ b/docs/docs/stream.md @@ -22,8 +22,8 @@ type QuickstartService = 'Service "Greeter" '[ 'Method "SayHello" ... , 'Method "SayManyHellos" - '[ 'ArgStream ('FromSchema QuickstartSchema "HelloRequest")] - ('RetStream ('FromSchema QuickstartSchema "HelloResponse")) ] + '[ 'ArgStream ('FromSchema QuickstartSchema "HelloRequest")] + ('RetStream ('FromSchema QuickstartSchema "HelloResponse")) ] ``` To define the implementation of this method we build upon the great [Conduit](https://github.com/snoyberg/conduit) library. Your input is now a producer of values, as defined by that library, and you must write the results to the provided sink. Better said with an example: diff --git a/examples/with-persistent/src/Schema.hs b/examples/with-persistent/src/Schema.hs index 6930c52a..73c3ba89 100644 --- a/examples/with-persistent/src/Schema.hs +++ b/examples/with-persistent/src/Schema.hs @@ -52,8 +52,8 @@ Person json data MPerson = MPerson { pid :: Maybe MPersonRequest , name :: Maybe T.Text - , age :: Maybe Int32 } - deriving (Eq, Ord, Show, Generic) + , age :: Maybe Int32 + } deriving (Eq, Ord, Show, Generic) instance ToSchema Maybe PersistentSchema "Person" MPerson instance FromSchema Maybe PersistentSchema "Person" MPerson From a89a7ae80b3b20607cad6e849bf284802ae8249f Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Mon, 23 Dec 2019 09:19:20 +0100 Subject: [PATCH 030/217] =?UTF-8?q?Update=20to=20v3=20of=20cachix-action?= =?UTF-8?q?=20=E2=9D=84=EF=B8=8F=20(#51)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .github/workflows/haskell.yml | 12 +++++++++ .travis.yml | 27 ------------------- README.md | 2 +- default.nix | 24 +++++++++++++++++ .../mu-example-health-check.cabal | 1 + .../route-guide/mu-example-route-guide.cabal | 1 + examples/seed/mu-example-seed.cabal | 1 + examples/todolist/mu-example-todolist.cabal | 1 + .../mu-example-with-persistent.cabal | 1 + 9 files changed, 42 insertions(+), 28 deletions(-) create mode 100644 .github/workflows/haskell.yml delete mode 100644 .travis.yml create mode 100644 default.nix diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml new file mode 100644 index 00000000..4ac188bf --- /dev/null +++ b/.github/workflows/haskell.yml @@ -0,0 +1,12 @@ +name: Haskell CI +on: [push] +jobs: + build: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v1 + - uses: cachix/install-nix-action@v6 + - uses: cachix/cachix-action@v3 + with: + name: 47deg + signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}' diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index bb8bf49e..00000000 --- a/.travis.yml +++ /dev/null @@ -1,27 +0,0 @@ -# Choose a build environment -dist: bionic - -# Do not choose a language; we provide our own build tools. -language: generic - -# Caching so the next build will be fast too. -cache: - directories: - - $HOME/.stack - -# Ensure necessary system libraries are present -addons: - apt: - packages: - - libgmp-dev - -before_install: -# Download and unpack the stack executable -- mkdir -p ~/.local/bin -- export PATH=$HOME/.local/bin:$PATH -- travis_retry curl -L https://get.haskellstack.org/stable/linux-x86_64.tar.gz | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' - -install: -# Build dependencies -- stack --no-terminal --install-ghc test --only-dependencies -- stack --no-terminal --install-ghc test --only-dependencies --stack-yaml stack-nightly.yaml diff --git a/README.md b/README.md index c9663b63..2cc32027 100644 --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # Mu for Haskell -[![Build Status](https://travis-ci.com/higherkindness/mu-haskell.svg?branch=master)](https://travis-ci.com/higherkindness/mu-haskell) +[![Actions Status](https://github.com/higherkindness/mu-haskell/workflows/Haskell%20CI/badge.svg)](https://github.com/higherkindness/mu-haskell/actions) This repo defines a set of libraries to write microservices in a format- and protocol-independent way. It shares the same goals as [Mu for Scala](http://higherkindness.io/mu/), but using idiomatic Haskell and more type-level techniques. diff --git a/default.nix b/default.nix new file mode 100644 index 00000000..88e0ca23 --- /dev/null +++ b/default.nix @@ -0,0 +1,24 @@ +{ nixpkgs ? (fetchTarball https://github.com/NixOS/nixpkgs/archive/b1844ef5816b0af8bc2f6215054279ea35e29b77.tar.gz) +, pkgs ? import nixpkgs (import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/83966f3.tar.gz)) +}: + +let + hnPkgs = pkgs.haskell-nix.stackProject { + src = ./.; + modules = []; + }; +in { + compendium-client = hnPkgs.compendium-client.components.library; + mu-avro = hnPkgs.mu-avro.components.all; + mu-example-health-check = hnPkgs.mu-example-health-check.components.all; + mu-example-route-guide = hnPkgs.mu-example-route-guide.components.all; + mu-example-seed = hnPkgs.mu-example-seed.components.all; + mu-example-todolist = hnPkgs.mu-example-todolist.components.all; + mu-example-with-persistent = hnPkgs.mu-example-with-persistent.components.all; + mu-grpc-client = hnPkgs.mu-grpc-client.components.library; + mu-grpc-server = hnPkgs.mu-grpc-server.components.all; + mu-persistent = hnPkgs.mu-persistent.components.library; + mu-protobuf = hnPkgs.mu-protobuf.components.all; + mu-rpc = hnPkgs.mu-rpc.components.library; + mu-schema = hnPkgs.mu-schema.components.library; +} diff --git a/examples/health-check/mu-example-health-check.cabal b/examples/health-check/mu-example-health-check.cabal index 8af8688f..96a10708 100644 --- a/examples/health-check/mu-example-health-check.cabal +++ b/examples/health-check/mu-example-health-check.cabal @@ -15,6 +15,7 @@ maintainer: alejandro.serrano@47deg.com copyright: Copyright © 2019-2020 47 Degrees. category: Network build-type: Simple +data-files: healthcheck.proto executable health-server main-is: Server.hs diff --git a/examples/route-guide/mu-example-route-guide.cabal b/examples/route-guide/mu-example-route-guide.cabal index b691ae2c..019be74e 100644 --- a/examples/route-guide/mu-example-route-guide.cabal +++ b/examples/route-guide/mu-example-route-guide.cabal @@ -15,6 +15,7 @@ maintainer: alejandro.serrano@47deg.com copyright: Copyright © 2019-2020 47 Degrees. category: Network build-type: Simple +data-files: routeguide.proto executable route-guide-server main-is: Server.hs diff --git a/examples/seed/mu-example-seed.cabal b/examples/seed/mu-example-seed.cabal index 512f6322..543257f7 100644 --- a/examples/seed/mu-example-seed.cabal +++ b/examples/seed/mu-example-seed.cabal @@ -12,6 +12,7 @@ category: Network build-type: Simple cabal-version: >=1.10 extra-source-files: README.md +data-files: seed.proto executable seed-server hs-source-dirs: src diff --git a/examples/todolist/mu-example-todolist.cabal b/examples/todolist/mu-example-todolist.cabal index f44214c8..0c1db304 100644 --- a/examples/todolist/mu-example-todolist.cabal +++ b/examples/todolist/mu-example-todolist.cabal @@ -15,6 +15,7 @@ maintainer: flavio.corpa@47deg.com copyright: Copyright © 2019-2020 47 Degrees. category: Network build-type: Simple +data-files: todolist.proto executable todolist-server main-is: Server.hs diff --git a/examples/with-persistent/mu-example-with-persistent.cabal b/examples/with-persistent/mu-example-with-persistent.cabal index 8acb2aa4..bb10a912 100644 --- a/examples/with-persistent/mu-example-with-persistent.cabal +++ b/examples/with-persistent/mu-example-with-persistent.cabal @@ -10,6 +10,7 @@ category: Network build-type: Simple cabal-version: >=1.10 extra-source-files: README.md +data-files: with-persistent.proto executable persistent-server hs-source-dirs: src From 97a4e05d9a54abe5565466a1341cdff191d22978 Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Thu, 26 Dec 2019 09:25:09 +0100 Subject: [PATCH 031/217] =?UTF-8?q?Add=20client=20with=20Record=20syntax?= =?UTF-8?q?=20to=20persistent=20example=20=F0=9F=91=A9=F0=9F=8F=BC?= =?UTF-8?q?=E2=80=8D=F0=9F=8E=93=20(#60)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- examples/with-persistent/README.md | 8 ++- .../mu-example-with-persistent.cabal | 18 +++++++ examples/with-persistent/src/Client.hs | 6 +-- examples/with-persistent/src/ClientRecord.hs | 53 +++++++++++++++++++ 4 files changed, 79 insertions(+), 6 deletions(-) create mode 100644 examples/with-persistent/src/ClientRecord.hs diff --git a/examples/with-persistent/README.md b/examples/with-persistent/README.md index ff307abe..30a3126d 100644 --- a/examples/with-persistent/README.md +++ b/examples/with-persistent/README.md @@ -14,10 +14,16 @@ In another terminal, run the client: $ stack run persistent-client add "Flavio" 28 ``` +Alternatively, you can also use the record version: + +```bash +$ stack run persistent-client-record watch +``` + [comment]: # (Start Copyright) # Copyright -Mu is designed and developed by 47 Degrees +Mu is designed and developed with ❤️ by 47 Degrees. Copyright (C) 2019-2020 47 Degrees. diff --git a/examples/with-persistent/mu-example-with-persistent.cabal b/examples/with-persistent/mu-example-with-persistent.cabal index bb10a912..7aa61e81 100644 --- a/examples/with-persistent/mu-example-with-persistent.cabal +++ b/examples/with-persistent/mu-example-with-persistent.cabal @@ -47,3 +47,21 @@ executable persistent-client hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + +executable persistent-client-record + main-is: ClientRecord.hs + other-modules: Schema + build-depends: base >=4.12 && <5 + , conduit + , mu-schema + , mu-rpc + , mu-persistent + , mu-protobuf + , mu-grpc-client + , persistent + , persistent-sqlite + , persistent-template + , text + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/examples/with-persistent/src/Client.hs b/examples/with-persistent/src/Client.hs index 7ed29fcc..b77a2ba7 100644 --- a/examples/with-persistent/src/Client.hs +++ b/examples/with-persistent/src/Client.hs @@ -1,21 +1,17 @@ -{-# language AllowAmbiguousTypes #-} {-# language DataKinds #-} -{-# language FlexibleContexts #-} {-# language OverloadedStrings #-} {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} -{-# language TypeOperators #-} module Main where import Data.Conduit import qualified Data.Conduit.Combinators as C import qualified Data.Text as T +import Mu.GRpc.Client.TyApps import System.Environment import Text.Read (readMaybe) -import Mu.GRpc.Client.TyApps - import Schema main :: IO () diff --git a/examples/with-persistent/src/ClientRecord.hs b/examples/with-persistent/src/ClientRecord.hs new file mode 100644 index 00000000..3f5c30db --- /dev/null +++ b/examples/with-persistent/src/ClientRecord.hs @@ -0,0 +1,53 @@ +{-# language DataKinds #-} +{-# language DeriveGeneric #-} +{-# language OverloadedStrings #-} +{-# language TypeApplications #-} + +module Main where + +import Data.Conduit +import qualified Data.Conduit.Combinators as C +import qualified Data.Text as T +import GHC.Generics (Generic) +import Mu.GRpc.Client.Record +import System.Environment +import Text.Read (readMaybe) + +import Schema + +data PersistentCall = PersistentCall + { getPerson :: MPersonRequest -> IO (GRpcReply MPerson) + , newPerson :: MPerson -> IO (GRpcReply MPersonRequest) + , allPeople :: IO (ConduitT () (GRpcReply MPerson) IO ()) + } deriving Generic + +main :: IO () +main = do + let config = grpcClientConfigSimple "127.0.0.1" 1234 False + Right grpcClient <- setupGrpcClient' config + let client = buildService @PersistentService @"" grpcClient + args <- getArgs + case args of + ["watch"] -> watching client + ["get", idp] -> get client idp + ["add", nm, ag] -> add client nm ag + _ -> putStrLn "unknown command" + +get :: PersistentCall -> String -> IO () +get client idPerson = do + let req = MPersonRequest $ readMaybe idPerson + putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?" + res <- getPerson client req + putStrLn $ "GET: response was: " ++ show res + +add :: PersistentCall -> String -> String -> IO () +add client nm ag = do + let p = MPerson Nothing (Just $ T.pack nm) (readMaybe ag) + putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag + res <- newPerson client p + putStrLn $ "ADD: was creating successful? " ++ show res + +watching :: PersistentCall -> IO () +watching client = do + replies <- allPeople client + runConduit $ replies .| C.mapM_ print From aef5798188a48ec05fa6cebe7a15860af5c003d3 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 6 Jan 2020 12:36:08 +0100 Subject: [PATCH 032/217] Add link to GitHub and API docs --- docs/_includes/_doc.html | 6 ++++++ docs/_sass/components/_doc.scss | 20 ++++++++++++++++++++ 2 files changed, 26 insertions(+) diff --git a/docs/_includes/_doc.html b/docs/_includes/_doc.html index 4cf2abc4..3c42272e 100644 --- a/docs/_includes/_doc.html +++ b/docs/_includes/_doc.html @@ -7,6 +7,12 @@ title="Toggle"> Toggle + + +
{{ content }} diff --git a/docs/_sass/components/_doc.scss b/docs/_sass/components/_doc.scss index cfbc00ce..26b56b32 100755 --- a/docs/_sass/components/_doc.scss +++ b/docs/_sass/components/_doc.scss @@ -32,6 +32,26 @@ margin: ($base-point-grid * 2); } } + + ul { + display: flex; + justify-content: space-between; + flex-direction: row; + + .nav-menu-item { + padding: ($base-point-grid * 2); + margin: ($base-point-grid * 2); + list-style-type: none; + + a { + color: $gray-primary; + &:hover { + color: rgba($brand-primary, 0.96); + text-decoration: none; + } + } + } + } } .doc-content { From 7bce91daaec7c9557af6dbcd3d69a3fa2550612f Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Tue, 7 Jan 2020 14:44:00 +0100 Subject: [PATCH 033/217] =?UTF-8?q?Document=20gRPC=20client=20development!?= =?UTF-8?q?=20=F0=9F=93=9A=20(#61)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- docs/docs/grpc.md | 134 ++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 130 insertions(+), 4 deletions(-) diff --git a/docs/docs/grpc.md b/docs/docs/grpc.md index f7f27f26..2fd0330b 100644 --- a/docs/docs/grpc.md +++ b/docs/docs/grpc.md @@ -18,12 +18,138 @@ main = runGRpcApp 8080 "helloworld" quickstartServer ## Building a client --- TODO: +Right now there are two options for building clients: using records or with `TypeApplications`. To give a proper introduction to both options let's consider in detail an example client for the following services: + +```protobuf +service Service { + rpc getPerson (PersonRequest) returns (Person); + rpc newPerson (Person) returns (PersonRequest); + rpc allPeople (google.protobuf.Empty) returns (stream Person); +} +``` + +Regardless of the approach we decide to use, we can construct a basic CLI for the client this way: + +```haskell +import System.Environment + +main :: IO () +main = do + let config = grpcClientConfigSimple "127.0.0.1" 8080 False + Right client <- setupGrpcClient' config + args <- getArgs + case args of + ["watch"] -> watching client + ["get", idp] -> get client idp + ["add", nm, ag] -> add client nm ag + _ -> putStrLn "unknown command" +``` + +Where `watch`, `get` and `add` are the only valid 3 commands that our CLI is going to accept and call each respective service. ### Using records --- TODO: +This option is a bit more verbose but it's also more explicit with the types and _"a bit more magic"_ than the one with `TypeApplications` (due to the use of Generics). + +We need to define a new record type (hence the name) that declares the services our client is going to consume. Remember that the names of the record fields **must match** exactly the methods in the service: + +```haskell +import GHC.Generics (Generic) +import Mu.GRpc.Client.Record + +data Call = Call + { getPerson :: MPersonRequest -> IO (GRpcReply MPerson) + , newPerson :: MPerson -> IO (GRpcReply MPersonRequest) + , allPeople :: IO (ConduitT () (GRpcReply MPerson) IO ()) + } deriving Generic +``` + +Note that we had to derive `Generic`. We also need to tweak a little bit our `main` function: + +```diff +main :: IO () +main = do + let config = grpcClientConfigSimple "127.0.0.1" 1234 False +- Right client <- setupGrpcClient' config ++ Right grpcClient <- setupGrpcClient' config ++ let client = buildService @Service "/grpc" grpcClient + args <- getArgs +``` + +Instead of building our client directly, we need to call `buildService` (and enable `TypeApplications`) to create the actual gRPC client. If you don't like `TypeApplications`, it is also possible to use a combination of `ScopedTypeVariables` and something like `(Proxy :: Proxy Service)` to achieve the same result, but it's a bit more verbose and we _encourge you1_ to use `TypeApplications` instead. 😉 + +That string (or `ByteString`) as a second argument to `buildService` corresponds to the route of the service. + +After that, let's have a look at an example implementation of the three service calls: + +```haskell +import Text.Read (readMaybe) + +get :: Call -> String -> IO () +get client idPerson = do + let req = MPersonRequest $ readMaybe idPerson + putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?" + res <- getPerson client req + putStrLn $ "GET: response was: " ++ show res +``` + +Notice the use of `readMaybe` to convert the strings to the appropiate type in a safe manner! 👆🏼 + +```haskell +add :: Call -> String -> String -> IO () +add client nm ag = do + let p = MPerson Nothing (Just $ T.pack nm) (readMaybe ag) + putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag + res <- newPerson client p + putStrLn $ "ADD: was creating successful? " ++ show res + +watching :: Call -> IO () +watching client = do + replies <- allPeople client + runConduit $ replies .| C.mapM_ print +``` + +### Using `TypeApplications` + +With `TypeApplications` none of the above is needed, all you need to do is call `gRpcCall` with the appropiate service name as a type-level string, and the rest just _magically_ works! ✨ + +```haskell +import Mu.GRpc.Client.TyApps + +get :: GrpcClient -> String -> IO () +get client idPerson = do + let req = MPersonRequest $ readMaybe idPerson + putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?" + response :: GRpcReply MPerson + <- gRpcCall @Service @"getPerson" client req + putStrLn $ "GET: response was: " ++ show response +``` + +Notice that the type signatures of our functions needed to change to receive the `GrpcClient` as an argument, instead of our custom record type. + +```haskell +add :: GrpcClient -> String -> String -> IO () +add client nm ag = do + let p = MPerson Nothing (Just $ T.pack nm) (readMaybe ag) + putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag + response :: GRpcReply MPersonRequest + <- gRpcCall @Service @"newPerson" client p + putStrLn $ "ADD: was creating successful? " ++ show response +``` + +We are being a bit more explicit with the types here (for example, `response :: GRpcReply MPersonRequest`) to help a bit the `show` function because GHC is not able to infer the type on its own. + +```haskell +watching :: GrpcClient -> IO () +watching client = do + replies <- gRpcCall @Service @"allPeople" client + runConduit $ replies .| C.mapM_ (print :: GRpcReply MPerson -> IO ()) +``` + +Here though, while mapping `print` to the `Conduit`, we needed to add a type annotation because the type was ambiguous... I think it's a small price to pay in exchange for the terseness. 🤑 + +--- -### Using `TypeApplications` +1 To read more on `TypeApplications`, you can check [this](https://www.reddit.com/r/haskell/comments/6ufnmr/scrap_your_proxy_arguments_with_typeapplications/), [that](https://blog.sumtypeofway.com/posts/fluent-polymorphism-type-applications.html) and [this](https://kseo.github.io/posts/2017-01-08-visible-type-application-ghc8.html). --- TODO: +To see a **working example** you can check all the code at the [example with persistent](https://github.com/higherkindness/mu-haskell/tree/master/examples/with-persistent). From b3c4b78b9f0bed5bd7cae4256cdfa6f5a13375f0 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Tue, 7 Jan 2020 15:14:21 +0100 Subject: [PATCH 034/217] More thorough Haddock documentation (#65) Closes #62 Co-authored-by: Flavio Corpa --- adapter/avro/mu-avro.cabal | 2 +- adapter/avro/src/Mu/Adapter/Avro.hs | 9 ++- adapter/avro/src/Mu/Quasi/Avro.hs | 12 +++ .../src/Mu/{Adapter => Quasi}/Avro/Example.hs | 6 +- adapter/persistent/mu-persistent.cabal | 2 +- .../persistent/src/Mu/Adapter/Persistent.hs | 33 +++++++- adapter/protobuf/mu-protobuf.cabal | 2 +- adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs | 38 ++++++++- .../protobuf/src/Mu/Adapter/ProtoBuf/Via.hs | 15 ++++ adapter/protobuf/src/Mu/Quasi/GRpc.hs | 13 +++- adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs | 9 ++- .../Mu/{Adapter => Quasi}/ProtoBuf/Example.hs | 7 +- compendium-client/src/Compendium/Client.hs | 40 +++++++--- core/rpc/src/Mu/Rpc.hs | 13 +++- core/rpc/src/Mu/Rpc/Examples.hs | 5 ++ core/rpc/src/Mu/Server.hs | 69 ++++++++++++---- core/schema/src/Data/Functor/MaybeLike.hs | 15 ++++ core/schema/src/Mu/Adapter/Json.hs | 9 ++- core/schema/src/Mu/Schema.hs | 13 +++- core/schema/src/Mu/Schema/Annotations.hs | 36 +++++++-- core/schema/src/Mu/Schema/Class.hs | 45 +++++++++-- .../src/Mu/Schema/Conversion/SchemaToTypes.hs | 23 ++++-- .../src/Mu/Schema/Conversion/TypesToSchema.hs | 29 ++++--- core/schema/src/Mu/Schema/Definition.hs | 78 +++++++++++++++++-- core/schema/src/Mu/Schema/Examples.hs | 6 +- core/schema/src/Mu/Schema/Interpretation.hs | 55 ++++++++++++- .../src/Mu/Schema/Interpretation/Anonymous.hs | 18 +++++ .../Mu/Schema/Interpretation/Schemaless.hs | 38 ++++++++- core/schema/src/Mu/Schema/Registry.hs | 26 +++++++ generate-haddock-docs.sh | 6 +- grpc/client/src/Mu/GRpc/Client/Examples.hs | 5 ++ grpc/client/src/Mu/GRpc/Client/Record.hs | 8 +- grpc/client/src/Mu/GRpc/Client/TyApps.hs | 15 ++-- grpc/server/src/Mu/GRpc/Server.hs | 24 +++++- 34 files changed, 629 insertions(+), 95 deletions(-) rename adapter/avro/src/Mu/{Adapter => Quasi}/Avro/Example.hs (88%) rename adapter/protobuf/src/Mu/{Adapter => Quasi}/ProtoBuf/Example.hs (77%) diff --git a/adapter/avro/mu-avro.cabal b/adapter/avro/mu-avro.cabal index 3a47b61d..c22d516d 100644 --- a/adapter/avro/mu-avro.cabal +++ b/adapter/avro/mu-avro.cabal @@ -15,8 +15,8 @@ data-files: test/avro/*.avsc library exposed-modules: Mu.Adapter.Avro - , Mu.Adapter.Avro.Example , Mu.Quasi.Avro + , Mu.Quasi.Avro.Example -- other-modules: -- other-extensions: build-depends: base >=4.12 && <5 diff --git a/adapter/avro/src/Mu/Adapter/Avro.hs b/adapter/avro/src/Mu/Adapter/Avro.hs index af84fc5a..46ad3259 100644 --- a/adapter/avro/src/Mu/Adapter/Avro.hs +++ b/adapter/avro/src/Mu/Adapter/Avro.hs @@ -10,7 +10,14 @@ {-# language TypeOperators #-} {-# language UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Mu.Adapter.Avro where +{-| +Description : Adapter for Avro serialization + +Just import the module and you can turn any +value with a 'ToSchema' and 'FromSchema' from +and to Avro values. +-} +module Mu.Adapter.Avro () where import Control.Arrow ((***)) import qualified Data.Avro as A diff --git a/adapter/avro/src/Mu/Quasi/Avro.hs b/adapter/avro/src/Mu/Quasi/Avro.hs index 02dac5da..c5663831 100644 --- a/adapter/avro/src/Mu/Quasi/Avro.hs +++ b/adapter/avro/src/Mu/Quasi/Avro.hs @@ -3,7 +3,18 @@ {-# language NamedFieldPuns #-} {-# language TemplateHaskell #-} {-# language ViewPatterns #-} +{-| +Description : Quasi-quoters for Avro IDL format +This module turns schema definitions written in + +into Mu 'Schema's. We provide versions for writing +the IDL inline ('avro') and import it from a file +('avroFile'). + +/Note/: as of now, only the JSON-based IDL format +is supported, not the Java-like one. +-} module Mu.Quasi.Avro ( -- * Quasi-quoters for @.avsc@ files avro @@ -64,6 +75,7 @@ schemaDecFromAvroType (A.Enum name _ _ symbols) = avChoiceToType c = [t|'ChoiceDef $(textToStrLit c)|] schemaDecFromAvroType t = [t|'DSimple $(schemaFromAvroType t)|] +-- | Turns a schema from Avro into a Template Haskell 'Type'. schemaFromAvroType :: A.Type -> Q Type schemaFromAvroType = \case diff --git a/adapter/avro/src/Mu/Adapter/Avro/Example.hs b/adapter/avro/src/Mu/Quasi/Avro/Example.hs similarity index 88% rename from adapter/avro/src/Mu/Adapter/Avro/Example.hs rename to adapter/avro/src/Mu/Quasi/Avro/Example.hs index 14faf036..8e3df458 100644 --- a/adapter/avro/src/Mu/Adapter/Avro/Example.hs +++ b/adapter/avro/src/Mu/Quasi/Avro/Example.hs @@ -1,8 +1,12 @@ {-# language CPP #-} {-# language DataKinds #-} {-# language QuasiQuotes #-} +{-| +Description : Examples for Avro quasi-quoters -module Mu.Adapter.Avro.Example where +Look at the source code of this module. +-} +module Mu.Quasi.Avro.Example where import Mu.Quasi.Avro (avro, avroFile) diff --git a/adapter/persistent/mu-persistent.cabal b/adapter/persistent/mu-persistent.cabal index 67a75afd..000436d7 100644 --- a/adapter/persistent/mu-persistent.cabal +++ b/adapter/persistent/mu-persistent.cabal @@ -1,6 +1,6 @@ name: mu-persistent version: 0.1.0.0 --- synopsis: +synopsis: Utilities for interoperation between Mu and Persistent -- description: homepage: https://github.com/higherkindness/mu-haskell/persistent#readme license: Apache-2.0 diff --git a/adapter/persistent/src/Mu/Adapter/Persistent.hs b/adapter/persistent/src/Mu/Adapter/Persistent.hs index 4edbf30b..fd43409b 100644 --- a/adapter/persistent/src/Mu/Adapter/Persistent.hs +++ b/adapter/persistent/src/Mu/Adapter/Persistent.hs @@ -8,8 +8,21 @@ {-# language TypeApplications #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} +{-| +Description : Utilities for interoperation between Mu and Persistent -module Mu.Adapter.Persistent where +The @persistent@ library, and in particular its quasi-quoters +for entities, generate data types which do not look exactly as +plain records. This module defines some wrappers which modify +the 'ToSchema' and 'FromSchema' derivation to work with them. +-} +module Mu.Adapter.Persistent ( + -- * Wrappers for use with @DerivingVia@ + WithEntityNestedId(..) +, WithEntityPlainId(..) + -- * Generic utilities +, runDb +) where import Control.Monad.IO.Class import Control.Monad.Logger @@ -24,11 +37,22 @@ import Mu.Schema import Mu.Schema.Class import Mu.Schema.Interpretation -newtype WithEntityPlainId (ty :: Symbol) (fmap :: Mappings Symbol Symbol) a - = WithEntityPlainId { unWithEntityPlainId :: a } +-- | Wrapper for 'Entity' to be used with @DerivingVia@. +-- This wrappers indicates that the identifier is to be found +-- as the sole field of another object, like in: +-- +-- > { id: { key: 3 }, name: "Somebody" } newtype WithEntityNestedId (ty :: Symbol) (fmap :: Mappings Symbol Symbol) a = WithEntityNestedId { unWithEntityNestedId :: a } +-- | Wrapper for 'Entity' to be used with @DerivingVia@. +-- This wrappers indicates that the identifier is to be found +-- in the schema at the same level as other fields, like in: +-- +-- > { id: 3, name: "Somebody" } +newtype WithEntityPlainId (ty :: Symbol) (fmap :: Mappings Symbol Symbol) a + = WithEntityPlainId { unWithEntityPlainId :: a } + instance ( Generic t, Applicative w , (sch :/: sty) ~ 'DRecord name (idArg ': args) , idArg ~ 'Mu.Schema.FieldDef idArgName ('TPrimitive Int64) @@ -60,6 +84,9 @@ instance ( Generic t, Applicative w up :: Identity a -> w a up (Identity i) = pure i +-- | Simple utility to execute a database operation +-- in any monad which supports 'IO' operations. +-- Note that all logging messages are discarded. runDb :: MonadIO m => SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a diff --git a/adapter/protobuf/mu-protobuf.cabal b/adapter/protobuf/mu-protobuf.cabal index 6f72e91a..6a5ec04c 100644 --- a/adapter/protobuf/mu-protobuf.cabal +++ b/adapter/protobuf/mu-protobuf.cabal @@ -16,9 +16,9 @@ data-files: test/protobuf/*.proto library exposed-modules: Mu.Adapter.ProtoBuf , Mu.Adapter.ProtoBuf.Via - , Mu.Adapter.ProtoBuf.Example , Mu.Quasi.ProtoBuf , Mu.Quasi.GRpc + , Mu.Quasi.ProtoBuf.Example -- other-modules: -- other-extensions: build-depends: base >=4.12 && <5 diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs index e2341b79..ef5461b0 100644 --- a/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs @@ -15,6 +15,15 @@ {-# language UndecidableInstances #-} {-# language ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Description : Adapter for Protocol Buffers serialization + +Just import the module and you can turn any +value with a 'ToSchema' and 'FromSchema' from +and to Protocol Buffers. Since Protocol Buffers +need information about field identifiers, you +need to annotate your schema using 'ProtoBufAnnotation'. +-} module Mu.Adapter.ProtoBuf ( -- * Custom annotations ProtoBufAnnotation(..) @@ -51,8 +60,11 @@ import qualified Mu.Schema.Registry as R instance ProtoEnum Bool #endif +-- | Annotations for Protocol Buffers fields. data ProtoBufAnnotation - = ProtoBufId Nat + = -- | Numeric field identifier for normal fields + ProtoBufId Nat + -- | List of identifiers for fields which contain a union | ProtoBufOneOfIds [Nat] type family FindProtoBufId (sch :: Schema tn fn) (t :: tn) (f :: fn) where @@ -77,21 +89,33 @@ type family FindProtoBufOneOfIds' (t :: tn) (f :: fn) (p :: ProtoBufAnnotation) -- CONVERSION USING SCHEMAS +-- | Represents those 'Schema's which are supported by Protocol Buffers. +-- Some values which can be represented as 'Term's cannot be so in +-- Protocol Buffers. For example, you cannot have a list within an option. class ProtoBridgeTerm w sch (sch :/: sty) => IsProtoSchema w sch sty instance ProtoBridgeTerm w sch (sch :/: sty) => IsProtoSchema w sch sty -- type HasProtoSchema w sch sty a = (HasSchema w sch sty a, IsProtoSchema w sch sty) +-- | Conversion to Protocol Buffers mediated by a schema. toProtoViaSchema :: forall t f (sch :: Schema t f) a sty. (IsProtoSchema Maybe sch sty, ToSchema Maybe sch sty a) => a -> PBEnc.MessageBuilder toProtoViaSchema = termToProto . toSchema' @_ @_ @sch @Maybe +-- | Conversion from Protocol Buffers mediated by a schema. +-- This function requires a 'PBDec.RawMessage', which means +-- that we already know that the Protocol Buffers message +-- is well-formed. Use 'parseProtoViaSchema' to parse directly +-- from a 'BS.ByteString'. fromProtoViaSchema :: forall t f (sch :: Schema t f) a sty. (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty a) => PBDec.Parser PBDec.RawMessage a fromProtoViaSchema = fromSchema' @_ @_ @sch @Maybe <$> protoToTerm +-- | Conversion from Protocol Buffers mediated by a schema. +-- This function receives the 'BS.ByteString' directly, +-- and parses it as part of its duty. parseProtoViaSchema :: forall sch a sty. (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty a) => BS.ByteString -> Either PBDec.ParseError a @@ -99,18 +123,30 @@ parseProtoViaSchema = PBDec.parse (fromProtoViaSchema @_ @_ @sch) -- CONVERSION USING REGISTRY +-- | Conversion from Protocol Buffers by checking +-- all the 'Schema's in a 'R.Registry'. +-- +-- As 'fromProtoViaSchema', this version requires +-- an already well-formed Protocol Buffers message. fromProtoBufWithRegistry :: forall (r :: R.Registry) t. FromProtoBufRegistry r t => PBDec.Parser PBDec.RawMessage t fromProtoBufWithRegistry = fromProtoBufRegistry' (Proxy @r) +-- | Conversion from Protocol Buffers by checking +-- all the 'Schema's in a 'R.Registry'. +-- +-- As 'parseProtoViaSchema', this version receives +-- a 'BS.ByteString' and parses it as part of its duty. parseProtoBufWithRegistry :: forall (r :: R.Registry) t. FromProtoBufRegistry r t => BS.ByteString -> Either PBDec.ParseError t parseProtoBufWithRegistry = PBDec.parse (fromProtoBufWithRegistry @r) +-- | Represents 'R.Registry's for which every 'Schema' +-- is supported by the Protocol Buffers format. class FromProtoBufRegistry (ms :: Mappings Nat Schema') t where fromProtoBufRegistry' :: Proxy ms -> PBDec.Parser PBDec.RawMessage t diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs index b9f1ccd2..d5b7c7eb 100644 --- a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs @@ -7,6 +7,15 @@ {-# language TypeApplications #-} {-# language UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints -fno-warn-orphans #-} +{-| +Description : Wrappers to customize Protocol Buffers serialization + +In order to interoperate with the @proto3-wire@ library, +we sometimes need an instance of 'Proto3WireEncoder'. +By using the wrappers in this module, such instances can +be obtained automatically if the type can be turned +into a 'Schema'. +-} module Mu.Adapter.ProtoBuf.Via where import Network.GRPC.HTTP2.Proto3Wire @@ -17,8 +26,12 @@ import Mu.Adapter.ProtoBuf import Mu.Rpc import Mu.Schema +-- | Specifies that a type is turned into a Protocol Buffers +-- message by using the schema as intermediate representation. newtype ViaToProtoBufTypeRef (ref :: TypeRef) t = ViaToProtoBufTypeRef { unViaToProtoBufTypeRef :: t } +-- | Specifies that a type can be parsed from a Protocol Buffers +-- message by using the schema as intermediate representation. newtype ViaFromProtoBufTypeRef (ref :: TypeRef) t = ViaFromProtoBufTypeRef { unViaFromProtoBufTypeRef :: t } @@ -35,8 +48,10 @@ instance Proto3WireEncoder () where proto3WireEncode _ = mempty proto3WireDecode = return () +-- | Types which can be parsed from a Protocol Buffers message. class FromProtoBufTypeRef (ref :: TypeRef) t where fromProtoBufTypeRef :: Proxy ref -> PBDec.Parser PBDec.RawMessage t +-- | Types which can be turned into a Protocol Buffers message. class ToProtoBufTypeRef (ref :: TypeRef) t where toProtoBufTypeRef :: Proxy ref -> t -> PBEnc.MessageBuilder diff --git a/adapter/protobuf/src/Mu/Quasi/GRpc.hs b/adapter/protobuf/src/Mu/Quasi/GRpc.hs index 7991b8b2..b03852ac 100644 --- a/adapter/protobuf/src/Mu/Quasi/GRpc.hs +++ b/adapter/protobuf/src/Mu/Quasi/GRpc.hs @@ -1,7 +1,14 @@ {-# language DataKinds #-} {-# language OverloadedStrings #-} {-# language TemplateHaskell #-} --- | Read a @.proto@ file as a 'Service' +{-| +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 @@ -20,8 +27,8 @@ import Mu.Quasi.ProtoBuf import Mu.Rpc -- | Reads a @.proto@ file and generates: --- * A 'Schema' with all the message types, using the --- name given as first argument. +-- * 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. diff --git a/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs b/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs index 9c74632c..b9dc47b5 100644 --- a/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs +++ b/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs @@ -3,7 +3,13 @@ {-# language LambdaCase #-} {-# language NamedFieldPuns #-} {-# language TemplateHaskell #-} +{-| +Description : Quasi-quoters for Protocol Buffers schemas +Read @.proto@ files as a 'Mu.Schema.Definition.Schema'. +If you want to get the service definitions too, +you should use 'Mu.Quasi.GRpc' instead. +-} module Mu.Quasi.ProtoBuf ( -- * Quasi-quoters for @.proto@ files protobuf @@ -23,7 +29,7 @@ import Mu.Adapter.ProtoBuf import Mu.Schema.Definition import Mu.Schema.Annotations --- | Reads a @.proto@ file and generates a 'Schema' +-- | Reads a @.proto@ file and generates a 'Mu.Schema.Definition.Schema' -- with all the message types, using the name given -- as first argument. protobuf :: String -> FilePath -> Q [Dec] @@ -35,6 +41,7 @@ protobuf schemaName fp Right p -> protobufToDecls schemaName p +-- | Shared portion of Protocol Buffers and gRPC quasi-quoters. protobufToDecls :: String -> P.ProtoBuf -> Q [Dec] protobufToDecls schemaName p = do let schemaName' = mkName schemaName diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs b/adapter/protobuf/src/Mu/Quasi/ProtoBuf/Example.hs similarity index 77% rename from adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs rename to adapter/protobuf/src/Mu/Quasi/ProtoBuf/Example.hs index 13ff7c34..9f7cb08a 100644 --- a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Example.hs +++ b/adapter/protobuf/src/Mu/Quasi/ProtoBuf/Example.hs @@ -2,7 +2,12 @@ {-# language DataKinds #-} {-# language TemplateHaskell #-} {-# language TypeFamilies #-} -module Mu.Adapter.ProtoBuf.Example where +{-| +Description : Examples for Protocol Buffers quasi-quoters + +Look at the source code of this module. +-} +module Mu.Quasi.ProtoBuf.Example where import Mu.Quasi.ProtoBuf diff --git a/compendium-client/src/Compendium/Client.hs b/compendium-client/src/Compendium/Client.hs index 410385bb..d5a8b8ca 100644 --- a/compendium-client/src/Compendium/Client.hs +++ b/compendium-client/src/Compendium/Client.hs @@ -4,7 +4,19 @@ {-# language TypeApplications #-} {-# language TypeOperators #-} {-# language ViewPatterns #-} -module Compendium.Client where +{-| +Description : Client for the Compendium schema registry + +Client for the Compendium schema registry +-} +module Compendium.Client ( +-- * Generic query of schemas + IdlName +, transformation +-- * Query Protocol Buffer schemas +, obtainProtoBuf +, ObtainProtoBufError(..) +) where import Data.Aeson import Data.Char @@ -23,6 +35,7 @@ newtype Protocol = Protocol { raw :: Text } deriving (Eq, Show, Generic, FromJSON) +-- | Interface Description Languages supported by Compendium. data IdlName = Avro | Protobuf | Mu | OpenApi | Scala deriving (Eq, Show, Generic) @@ -37,20 +50,29 @@ type TransformationAPI :> QueryParam' '[ Required ] "target" IdlName :> Get '[JSON] Protocol -transformation :: Manager -> BaseUrl - -> Text -> IdlName -> IO (Either ClientError Protocol) +-- | Obtain a schema from the registry. +transformation :: Manager -- ^ Connection details (from 'http-client'). + -> BaseUrl -- ^ URL in which Compendium is running. + -> Text -- ^ Name that identifies the schema. + -> IdlName -- ^ Format of the returned schema. + -> IO (Either ClientError Text) transformation m url ident idl = runClientM (transformation' ident idl) (mkClientEnv m url) -transformation' :: Text -> IdlName -> ClientM Protocol -transformation' - = client (Proxy @TransformationAPI) +transformation' :: Text + -> IdlName + -> ClientM Text +transformation' ident idl + = raw <$> client (Proxy @TransformationAPI) ident idl +-- | Errors which may arise during 'obtainProtoBuf'. data ObtainProtoBufError - = OPEClient ClientError - | OPEParse (ParseErrorBundle Text Char) + = OPEClient ClientError -- ^ Error obtaining schema from Compendium + | OPEParse (ParseErrorBundle Text Char) -- ^ Obtaining the schema was OK, error parsing it deriving (Show) +-- | Obtain a schema from the registry, +-- and parse it as Protocol Buffers. obtainProtoBuf :: Manager -> BaseUrl -> Text -> IO (Either ObtainProtoBufError ProtoBuf) obtainProtoBuf m url ident = do @@ -58,7 +80,7 @@ obtainProtoBuf m url ident = do case r of Left e -> return $ Left (OPEClient e) - Right (Protocol p) + Right p -> case parseProtoBuf p of Left e -> return $ Left (OPEParse e) Right pb -> return $ Right pb diff --git a/core/rpc/src/Mu/Rpc.hs b/core/rpc/src/Mu/Rpc.hs index c8679252..c10f328d 100644 --- a/core/rpc/src/Mu/Rpc.hs +++ b/core/rpc/src/Mu/Rpc.hs @@ -6,7 +6,13 @@ {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} --- | Protocol-independent declaration of services +{-| +Description : Protocol-independent declaration of services + +This module defines a type-level language to describe +RPC-like microservices independently of the transport +and protocol. +-} module Mu.Rpc ( Service', Service(..) , ServiceAnnotation, Package, FindPackageName @@ -21,7 +27,10 @@ import qualified Language.Haskell.TH as TH import Mu.Schema import Mu.Schema.Registry +-- | Services whose names are given by type-level strings. type Service' = Service Symbol Symbol +-- | Annotations for services. At this moment, such +-- annotations can be of any type. type ServiceAnnotation = Type -- | A service is a set of methods. @@ -32,6 +41,8 @@ data Service serviceName methodName -- This is used by some handlers, like gRPC. data Package (s :: Symbol) +-- | Find the 'Package' for a service, to be found +-- as part of the annotations. type family FindPackageName (anns :: [ServiceAnnotation]) :: Symbol where FindPackageName '[] = TypeError ('Text "Cannot find package name for the service") FindPackageName (Package s ': rest) = s diff --git a/core/rpc/src/Mu/Rpc/Examples.hs b/core/rpc/src/Mu/Rpc/Examples.hs index 2cb1aab6..e8170051 100644 --- a/core/rpc/src/Mu/Rpc/Examples.hs +++ b/core/rpc/src/Mu/Rpc/Examples.hs @@ -14,6 +14,11 @@ {-# language TypeOperators #-} {-# language ViewPatterns #-} {-# 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 diff --git a/core/rpc/src/Mu/Server.hs b/core/rpc/src/Mu/Server.hs index d0646486..97631a66 100644 --- a/core/rpc/src/Mu/Server.hs +++ b/core/rpc/src/Mu/Server.hs @@ -10,22 +10,28 @@ {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} --- | Protocol-independent declaration of servers. --- --- A server (represented by 'ServerIO' and in general --- by 'ServerT') is a sequence of handlers (represented --- by 'HandlersIO' and 'HandlersT'), one for each --- operation in the corresponding Mu service declaration. --- --- In general, you should declare a server as: --- --- > server :: ServerIO MyService _ --- > server = Server (h1 :<|>: h2 :<|>: ... :<|>: H0) --- --- where each of @h1@, @h2@, ... handles each method in --- @MyService@ /in the order they were declared/. --- The @_@ in the type allows GHC to fill in the boring --- and long type you would need to write there otherwise. +{-| +Description : Protocol-independent declaration of servers. + +A server (represented by 'ServerT') is a sequence +of handlers (represented by 'HandlersT'), one for each +operation in the corresponding Mu service declaration. + +In general, you should declare a server as: + +> server :: MonadServer m => ServerT w MyService m _ +> server = Server (h1 :<|>: h2 :<|>: ... :<|>: H0) + +where each of @h1@, @h2@, ... handles each method in +@MyService@ /in the order they were declared/. +The @_@ in the type allows GHC to fill in the boring +and long type you would need to write there otherwise. + +/Implementation note/: exceptions raised in handlers +produce an error to be sent as response to the client. +We recommend you to catch exceptions and return custom +'ServerError's instead. +-} module Mu.Server ( -- * Servers and handlers MonadServer, ServerT(..), HandlersT(..) @@ -46,20 +52,31 @@ import Mu.Schema -- | Constraint for monads that can be used as servers type MonadServer m = (MonadError ServerError m, MonadIO m) +-- | Simplest monad which satisfies 'MonadServer'. type ServerErrorIO = ExceptT ServerError IO +-- | Simple 'ServerT' which uses only 'IO' and errors. type ServerIO w srv = ServerT w srv ServerErrorIO +-- | Stop the current handler, +-- returning an error to the client. serverError :: (MonadError ServerError m) => ServerError -> m a serverError = throwError +-- | Wrapper for handlers which do not use errors. +-- Remember that any exception raised in 'IO' +-- is propagated to the client. alwaysOk :: (MonadIO m) => IO a -> m a alwaysOk = liftIO +-- | Errors raised in a handler. data ServerError = ServerError ServerErrorCode String +-- | Possible types of errors. +-- Some of these are handled in a special way +-- by different transpoprt layers. data ServerErrorCode = Unknown | Unavailable @@ -70,10 +87,30 @@ data ServerErrorCode | NotFound deriving (Eq, Show) +-- | Definition of a complete server for a service. data ServerT (w :: Type -> Type) (s :: Service snm mnm) (m :: Type -> Type) (hs :: [Type]) where Server :: HandlersT w methods m hs -> ServerT w ('Service sname anns methods) m hs infixr 5 :<|>: +-- | 'HandlersT' is a sequence of handlers. +-- Note that the handlers for your service +-- must appear __in the same order__ as they +-- are defined. +-- +-- In general you can choose any type you want +-- for your handlers, due to the following restrictions: +-- +-- * Haskell types must be convertible to the +-- corresponding schema type. In other words, +-- they must implement 'FromSchema' if they are +-- inputs, and 'ToSchema' if they are outputs. +-- * Normal returns are represented by returning +-- the corresponding Haskell type. +-- * Input streams turn into @Conduit () t m ()@, +-- where @t@ is the Haskell type for that schema type. +-- * Output streams turn into an __additional argument__ +-- of type @Conduit t Void m ()@. This stream should +-- be connected to a source to get the elements. data HandlersT (w :: Type -> Type) (methods :: [Method mnm]) (m :: Type -> Type) (hs :: [Type]) where H0 :: HandlersT w '[] m '[] (:<|>:) :: Handles w args ret m h => h -> HandlersT w ms m hs diff --git a/core/schema/src/Data/Functor/MaybeLike.hs b/core/schema/src/Data/Functor/MaybeLike.hs index 9ce749ce..55c0a0b9 100644 --- a/core/schema/src/Data/Functor/MaybeLike.hs +++ b/core/schema/src/Data/Functor/MaybeLike.hs @@ -1,7 +1,22 @@ +{-| +Description : Type constructors which can be turned into 'Maybe'. + +Type constructors which can be turned into 'Maybe'. +-} module Data.Functor.MaybeLike where import Data.Functor.Identity +-- | This class may be defined in two ways: +-- +-- * Type constructors which can be turned into 'Maybe' generically. +-- * Type constructors which admit a natural transformation to 'Maybe'. +-- +-- We expect the following rules to hold for those +-- instances of 'MaybeLike' which are also 'Control.Applicative.Alternative': +-- +-- * @likeMaybe empty = empty = Nothing@ +-- * @likeMaybe (x <|> y) = likeMaybe x <|> likeMaybe y@ class MaybeLike f where likeMaybe :: f a -> Maybe a diff --git a/core/schema/src/Mu/Adapter/Json.hs b/core/schema/src/Mu/Adapter/Json.hs index df3134b6..76ecd51a 100644 --- a/core/schema/src/Mu/Adapter/Json.hs +++ b/core/schema/src/Mu/Adapter/Json.hs @@ -9,7 +9,14 @@ {-# language TypeOperators #-} {-# language UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -module Mu.Adapter.Json where +{-| +Description : Adapter for JSON serialization + +Just import the module and you can turn any +value with a 'ToSchema' and 'FromSchema' from +and to JSON values. +-} +module Mu.Adapter.Json () where import Control.Applicative ((<|>)) import Data.Aeson diff --git a/core/schema/src/Mu/Schema.hs b/core/schema/src/Mu/Schema.hs index 44dbd2a7..21dc9af1 100644 --- a/core/schema/src/Mu/Schema.hs +++ b/core/schema/src/Mu/Schema.hs @@ -1,5 +1,16 @@ {-# language DataKinds #-} --- | Schemas for Mu microservices +{-| +Description : Schemas for Mu microservices + +Definition and interpretation of schemas in +the vein of Avro, Protocol Buffers, or JSON Schema. + +Each 'Schema' is made out of types (which in turn +be records or enumerations). A value which obbeys +such a schema is called a 'Term'. Conversion between +Haskell types and schema types is mediated by the +type classes 'ToSchema' and 'FromSchema'. +-} module Mu.Schema ( -- * Schema definition Schema, Schema' diff --git a/core/schema/src/Mu/Schema/Annotations.hs b/core/schema/src/Mu/Schema/Annotations.hs index b534df19..4cb6788a 100644 --- a/core/schema/src/Mu/Schema/Annotations.hs +++ b/core/schema/src/Mu/Schema/Annotations.hs @@ -4,24 +4,44 @@ {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} -module Mu.Schema.Annotations where +{-| +Description : Protocol-defined annotations. + +Libraries can define custom annotations to +indicate additional information not found +in the 'Schema' itself. For example, Protocol +Buffers requires a numerical identifier for +each field in a record. +-} +module Mu.Schema.Annotations ( + -- * Annotate a schema + Annotation(..) +, AnnotatedSchema +, AnnotationDomain + -- * Find annotations for an element +, GetSchemaAnnotation +, GetTypeAnnotation +, GetFieldAnnotation +) where import Data.Kind import GHC.TypeLits import Mu.Schema.Definition --- | Libraries can define custom annotations. --- Each annotation belongs to a domain. +-- | Each annotation belongs to a domain. type AnnotationDomain = Type --- | Libraries can define custom annotations --- to indicate additional information. +-- | Annotations proper. data Annotation domain typeName fieldName where + -- | Annotation over the whole schema. AnnSchema :: domain -> Annotation domain typeName fieldName + -- | Annotation over a type in the schema. AnnType :: typeName -> domain -> Annotation domain typeName fieldName + -- | Annotation over a field in a record + -- or a choice in an enumeration. AnnField :: typeName -> fieldName -> domain -> Annotation domain typeName fieldName @@ -30,18 +50,24 @@ data Annotation domain typeName fieldName where type family AnnotatedSchema domain (sch :: Schema typeName fieldName) :: [Annotation domain typeName fieldName] +-- | Find the annotation over the schema in the given set. +-- If the annotation cannot be found, raise a 'TypeError'. type family GetSchemaAnnotation (anns :: [Annotation domain t f]) :: domain where GetSchemaAnnotation '[] = TypeError ('Text "cannot find schema annotation") GetSchemaAnnotation ('AnnSchema d ': rs) = d GetSchemaAnnotation (r ': rs) = GetSchemaAnnotation rs +-- | Find the annotation over the given type in the given set. +-- If the annotation cannot be found, raise a 'TypeError'. type family GetTypeAnnotation (anns :: [Annotation domain t f]) (ty :: t) :: domain where GetTypeAnnotation '[] ty = TypeError ('Text "cannot find annotation for " ':<>: 'ShowType ty) GetTypeAnnotation ('AnnType ty d ': rs) ty = d GetTypeAnnotation (r ': rs) ty = GetTypeAnnotation rs ty +-- | Find the annotation over the given field or choice in the given type. +-- If the annotation cannot be found, raise a 'TypeError'. type family GetFieldAnnotation (anns :: [Annotation domain t f]) (ty :: t) (fl :: f) :: domain where GetFieldAnnotation '[] ty fl = TypeError ('Text "cannot find annotation for " ':<>: 'ShowType ty ':<>: 'Text "/" ':<>: 'ShowType fl) diff --git a/core/schema/src/Mu/Schema/Class.hs b/core/schema/src/Mu/Schema/Class.hs index 3afe9623..76e06f47 100644 --- a/core/schema/src/Mu/Schema/Class.hs +++ b/core/schema/src/Mu/Schema/Class.hs @@ -12,7 +12,25 @@ {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} --- | Conversion from types to schemas +{-| +Description : Conversion from types to schemas + +This module defines a couple of type classes +'ToSchema' and 'FromSchema' to turn Haskell +types back and forth @mu-haskell@ 'Term's. + +In most cases, the instances can be automatically +derived. If you enable the extensions +@DeriveGeneric@ and @DeriveAnyClass@, you can do: + +> data MyHaskellType = ... +> deriving ( ToSchema f MySchema "MySchemaType" MyHaskellType +> , FromSchema f MySchema "MySchemaType" MyHaskellType) + +If the default mapping which required identical +names for fields in the Haskell and schema types +does not suit you, use 'CustomFieldMapping'. +-} module Mu.Schema.Class ( WithSchema(..) , FromSchema(..), fromSchema' @@ -41,8 +59,8 @@ newtype WithSchema (w :: Type -> Type) (sch :: Schema tn fn) (sty :: tn) a = Wit -- | Defines the conversion of a type @t@ into a 'Term' -- which follows the schema @sch@. -- You can give an optional mapping between the --- field names of @t@ and that of 'SchemaType' --- by means of 'FieldMapping'. +-- field names of @t@ and that of @sty@ +-- by means of 'CustomFieldMapping'. class ToSchema (w :: Type -> Type) (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type) | sch t -> sty where -- | Conversion from Haskell type to schema term. @@ -56,8 +74,8 @@ class ToSchema (w :: Type -> Type) (sch :: Schema typeName fieldName) (sty :: ty -- | Defines the conversion from a 'Term' -- which follows the schema @sch@ into a type @t@. -- You can give an optional mapping between the --- field names of @t@ and that of 'SchemaType' --- by means of 'FieldMapping'. +-- field names of @t@ and that of @sty@ +-- by means of 'CustomFieldMapping'. class FromSchema (w :: Type -> Type) (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type) | sch t -> sty where -- | Conversion from schema term to Haskell type. @@ -81,6 +99,17 @@ fromSchema' :: forall fn tn (sch :: Schema tn fn) w t sty. FromSchema w sch sty t => Term w sch (sch :/: sty) -> t fromSchema' = fromSchema +-- | By default, the names of the fields in the Haskell type +-- and those of the schema types must coincide. By using +-- this wrapper you can override this default setting. +-- +-- This type should be used with @DerivingVia@, as follows: +-- +-- > type MyCustomFieldMapping = '[ "A" ':-> "a", ...] +-- > data MyHaskellType = ... +-- > deriving ( ToSchema f MySchema "MySchemaType" MyHaskellType +-- > , FromSchema f MySchema "MySchemaType" MyHaskellType) +-- > via (CustomFieldMapping "MySchemaType" MyCustomFieldMapping MyHaskellType) newtype CustomFieldMapping (sty :: typeName) (fmap :: [Mapping Symbol fieldName]) a = CustomFieldMapping a @@ -92,6 +121,8 @@ instance (Generic t, GFromSchemaTypeDef w sch fmap (sch :/: sty) (Rep t)) => FromSchema w sch sty (CustomFieldMapping sty fmap t) where fromSchema x = CustomFieldMapping $ to (fromSchemaTypeDef (Proxy @fmap) x) +-- | Changes the underlying wrapper of a Haskell type, +-- by converting back and forth 'Term's with those wrappers. transSchema :: forall fn tn (sch :: Schema tn fn) sty u v a b. ( ToSchema u sch sty a, FromSchema v sch sty b @@ -431,7 +462,9 @@ instance {-# OVERLAPS #-} -- Due to some glitch in 'GHC.Generics', sometimes products -- are not represented by a linear sequence of ':*:', -- so we need to handle some cases in a special way --- (see 'HereLeft' and 'HereRight' instances) +-- (see 'HereLeft' and 'HereRight' instances) + +-- | For internal use only: generic conversion of a list of fields. class GToSchemaRecord (w :: * -> *) (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) (args :: [FieldDef ts fs]) (f :: * -> *) where toSchemaRecord :: Proxy fmap -> f a -> NP (Field w sch) args diff --git a/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs b/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs index 266287c8..792fee3f 100644 --- a/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs +++ b/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs @@ -2,7 +2,13 @@ {-# language DataKinds #-} {-# language TemplateHaskell #-} {-# language TypeOperators #-} --- | Generate a set of Haskell types from a 'Schema'. +{-| +Description : (Deprecated) Generate a set of Haskell types from a 'Schema' + +This module is deprecated. Haskell types +corresponding to schema types should be +written manually. +-} module Mu.Schema.Conversion.SchemaToTypes ( generateTypesFromSchema , Namer @@ -16,7 +22,6 @@ import GHC.Generics (Generic) import Language.Haskell.TH import Language.Haskell.TH.Datatype -import Mu.Schema.Class import Mu.Schema.Definition -- | Generate the name from each new Haskell type @@ -43,7 +48,7 @@ generateTypesFromSchema namer schemaTyName typeDefToDecl :: Type -> Namer -> TypeDefB Type String String -> Q [Dec] -- Records with one field -typeDefToDecl schemaTy namer (DRecord name [f]) +typeDefToDecl _schemaTy namer (DRecord name [f]) = do let complete = completeName namer name fVar <- newName "f" d <- newtypeD (pure []) @@ -52,11 +57,11 @@ typeDefToDecl schemaTy namer (DRecord name [f]) Nothing (pure (RecC (mkName complete) [fieldDefToDecl namer complete fVar f])) [pure (DerivClause Nothing [ConT ''Generic])] - wTy <- VarT <$> newName "w" + _wTy <- VarT <$> newName "w" -- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete [f]) return [d] -- , hsi] -- Records with more than one field -typeDefToDecl schemaTy namer (DRecord name fields) +typeDefToDecl _schemaTy namer (DRecord name fields) = do let complete = completeName namer name fVar <- newName "f" d <- dataD (pure []) @@ -65,11 +70,11 @@ typeDefToDecl schemaTy namer (DRecord name fields) Nothing [pure (RecC (mkName complete) (map (fieldDefToDecl namer complete fVar) fields))] [pure (DerivClause Nothing [ConT ''Generic])] - wTy <- VarT <$> newName "w" + _wTy <- VarT <$> newName "w" -- let hsi = generateHasSchemaInstance wTy schemaTy name complete (fieldMapping complete fields) return [d] -- , hsi] -- Enumerations -typeDefToDecl schemaTy namer (DEnum name choices) +typeDefToDecl _schemaTy namer (DEnum name choices) = do let complete = completeName namer name fVar <- newName "f" d <- dataD (pure []) @@ -79,7 +84,7 @@ typeDefToDecl schemaTy namer (DEnum name choices) [ pure (RecC (mkName (choiceName complete choicename)) []) | ChoiceDef choicename <- choices] [pure (DerivClause Nothing [ConT ''Eq, ConT ''Ord, ConT ''Show, ConT ''Generic])] - wTy <- VarT <$> newName "w" + _wTy <- VarT <$> newName "w" -- let hsi = generateHasSchemaInstance wTy schemaTy name complete (choiceMapping complete choices) return [d] --, hsi] -- Simple things @@ -132,6 +137,7 @@ generateHasSchemaInstance wTy schemaTy schemaName complete mapping #endif -} +{- fieldMapping :: String -> [FieldDefB Type String String] -> Type fieldMapping _complete [] = PromotedNilT fieldMapping complete (FieldDef name _ : rest) @@ -149,6 +155,7 @@ choiceMapping complete (ChoiceDef name : rest) = AppT (AppT (PromotedT '(:->)) (LitT (StrTyLit (choiceName complete name)))) (LitT (StrTyLit name)) +-} -- Name manipulation -- ================= diff --git a/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs b/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs index ef5b0e59..fd4aa763 100644 --- a/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs +++ b/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs @@ -3,17 +3,21 @@ {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} --- | Obtains a 'Schema' from a set of Haskell types. --- --- Unfortunately, GHC does not allow type families --- to appear in instances, so you cannot use the --- resulting type directly. Instead, evaluate it --- in an interpreter session using @:kind!@ and --- copy the result to the file. +{-| +Description: From 'Schema' to Haskell types. + +Obtains a 'Schema' from a set of Haskell types. + +Unfortunately, GHC does not allow type families +to appear in instances, so you cannot use the +resulting type directly. Instead, evaluate it +in an interpreter session using @:kind!@ and +copy the result to the file. +-} module Mu.Schema.Conversion.TypesToSchema ( SchemaFromTypes +, FromType(..) , AsRecord, AsEnum -, FromTypes, FromType(..) ) where import Data.Kind @@ -24,9 +28,14 @@ import GHC.TypeLits import Mu.Schema.Definition -type FromTypes = [FromType Symbol Symbol] +-- | Defines whether to turn each Haskell type +-- into a record or an enumeration. +-- Any type not declared in the given list +-- of 'FromType's is considered primitive. data FromType tn fn - = AsRecord' Type tn (Mappings Symbol fn) + = -- | Declares that the type should become a record. + AsRecord' Type tn (Mappings Symbol fn) + -- | Declares that the type should become an enumeration. | AsEnum' Type tn (Mappings Symbol fn) -- | Declares that the type should become a record. diff --git a/core/schema/src/Mu/Schema/Definition.hs b/core/schema/src/Mu/Schema/Definition.hs index 9ae6af11..154757a2 100644 --- a/core/schema/src/Mu/Schema/Definition.hs +++ b/core/schema/src/Mu/Schema/Definition.hs @@ -6,8 +6,44 @@ {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} --- | Schema definition -module Mu.Schema.Definition where +{-| +Description : Definition of schemas + +This module gives a set of combinators +to define schemas in the sense of Avro +or Protocol Buffers. + +In order to re-use definitions at both +the type and term levels, the actual +constructors are defined in types ending +with @B@, and are parametrized by the type +used to describe identifiers. +The versions without the suffix set this +parameter to 'Type', and are thought as the +API to be used in the type-level. +If you use 'reflectSchema' to obtain a term- +level representation, the parameter is set +to 'TypeRep'. +-} +module Mu.Schema.Definition ( +-- * Definition of schemas + Schema', Schema, SchemaB +, TypeDef, TypeDefB(..) +, ChoiceDef(..) +, FieldDef, FieldDefB(..) +, FieldType, FieldTypeB(..) +, (:/:) +-- * One-to-one mappings +, Mapping(..), Mappings +-- ** Finding correspondences +, MappingRight, MappingLeft +-- * Reflection to term-level +, reflectSchema +, reflectFields, reflectChoices +, reflectFieldTypes, reflectFieldType +-- * Supporting type classes +, KnownName(..) +) where import Data.Kind import Data.Proxy @@ -37,9 +73,11 @@ instance KnownNat n => KnownName (n :: Nat) where -- | A set of type definitions. -- In general, we can use any kind we want for -- both type and field names, although in practice --- you always want to use 'Schema''. +-- you always want to use 'Symbol'. type Schema typeName fieldName = SchemaB Type typeName fieldName +-- | A set of type definitions, +-- parametric on type representations. type SchemaB builtin typeName fieldName = [TypeDefB builtin typeName fieldName] @@ -49,32 +87,52 @@ type SchemaB builtin typeName fieldName -- * an enumeration: an element of a list of choices, -- * a reference to a primitive type. type TypeDef = TypeDefB Type +-- | Defines a type in a schema, +-- parametric on type representations. data TypeDefB builtin typeName fieldName - = DRecord typeName [FieldDefB builtin typeName fieldName] + = -- | A list of key-value pairs. + DRecord typeName [FieldDefB builtin typeName fieldName] + -- | An element of a list of choices. | DEnum typeName [ChoiceDef fieldName] + -- | A reference to a primitive type. | DSimple (FieldTypeB builtin typeName) -- | Defines each of the choices in an enumeration. newtype ChoiceDef fieldName - = ChoiceDef fieldName + = -- | One single choice from an enumeration. + ChoiceDef fieldName -- | Defines a field in a record -- by a name and the corresponding type. type FieldDef = FieldDefB Type +-- | Defines a field in a record, +-- parametric on type representations. data FieldDefB builtin typeName fieldName - = FieldDef fieldName (FieldTypeB builtin typeName) + = -- | One single field in a record. + FieldDef fieldName (FieldTypeB builtin typeName) -- | Types of fields of a record. -- References to other types in the same schema -- are done via the 'TSchematic' constructor. type FieldType = FieldTypeB Type +-- | Types of fields of a record, +-- parametric on type representations. data FieldTypeB builtin typeName - = TNull + = -- | Null, as found in Avro. + TNull + -- | Reference to a primitive type, such as integers or Booleans. + -- The set of supported primitive types depends on the protocol. | TPrimitive builtin + -- | Reference to another type in the schema. | TSchematic typeName + -- | Optional value. | TOption (FieldTypeB builtin typeName) + -- | List of values. | TList (FieldTypeB builtin typeName) + -- | Map of values. + -- The set of supported key types depends on the protocol. | TMap (FieldTypeB builtin typeName) (FieldTypeB builtin typeName) + -- | Represents a choice between types. | TUnion [FieldTypeB builtin typeName] -- | Lookup a type in a schema by its name. @@ -107,8 +165,8 @@ type family MappingLeft (ms :: Mappings a b) (v :: b) :: a where MappingLeft ((x ':-> y) ': rest) y = x MappingLeft (other ': rest) y = MappingLeft rest y --- | Reflect a schema into term-level. class ReflectSchema (s :: Schema tn fn) where + -- | Reflect a schema into term-level. reflectSchema :: Proxy s -> SchemaB TypeRep String String instance ReflectSchema '[] where reflectSchema _ = [] @@ -126,6 +184,7 @@ instance (ReflectFieldType ty, ReflectSchema s) : reflectSchema (Proxy @s) class ReflectFields (fs :: [FieldDef tn fn]) where + -- | Reflect a list of fields into term-level. reflectFields :: Proxy fs -> [FieldDefB TypeRep String String] instance ReflectFields '[] where reflectFields _ = [] @@ -135,6 +194,7 @@ instance (KnownName name, ReflectFieldType ty, ReflectFields fs) : reflectFields (Proxy @fs) class ReflectChoices (cs :: [ChoiceDef fn]) where + -- | Reflect a list of enumeration choices into term-level. reflectChoices :: Proxy cs -> [ChoiceDef String] instance ReflectChoices '[] where reflectChoices _ = [] @@ -144,6 +204,7 @@ instance (KnownName name, ReflectChoices cs) : reflectChoices (Proxy @cs) class ReflectFieldType (ty :: FieldType tn) where + -- | Reflect a schema type into term-level. reflectFieldType :: Proxy ty -> FieldTypeB TypeRep String instance ReflectFieldType 'TNull where reflectFieldType _ = TNull @@ -162,6 +223,7 @@ instance (ReflectFieldTypes ts) => ReflectFieldType ('TUnion ts) where reflectFieldType _ = TUnion (reflectFieldTypes (Proxy @ts)) class ReflectFieldTypes (ts :: [FieldType tn]) where + -- | Reflect a list of schema types into term-level. reflectFieldTypes :: Proxy ts -> [FieldTypeB TypeRep String] instance ReflectFieldTypes '[] where reflectFieldTypes _ = [] diff --git a/core/schema/src/Mu/Schema/Examples.hs b/core/schema/src/Mu/Schema/Examples.hs index c4b0a310..c074005b 100644 --- a/core/schema/src/Mu/Schema/Examples.hs +++ b/core/schema/src/Mu/Schema/Examples.hs @@ -13,7 +13,11 @@ {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} --- | Look at my source code! +{-| +Description : Examples for schema definitions. + +Look at the source code of this module. +-} module Mu.Schema.Examples where import qualified Data.Aeson as J diff --git a/core/schema/src/Mu/Schema/Interpretation.hs b/core/schema/src/Mu/Schema/Interpretation.hs index 546e22a1..7c38cafe 100644 --- a/core/schema/src/Mu/Schema/Interpretation.hs +++ b/core/schema/src/Mu/Schema/Interpretation.hs @@ -10,12 +10,39 @@ {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} --- | Interpretation of schemas +{-| +Description : Interpretation of schemas + +This module defines 'Term's which comply with +a given 'Schema'. These 'Term's are the main +form of values used internally by @mu-haskell@. + +This module follows the ideas of +. +In particular, each interpretation of a 'Field' +wraps its contents into a "wrapper" type @w@, +which may add additional behavior to it. +For example, in Protocol Buffers every field is +optional, and this is expressed by setting +@w@ to 'Maybe'. + +In this module we make use of 'NP' and 'NS' +as defined by . +These are the n-ary versions of a pair and +'Either', respectively. In other words, 'NP' +puts together a bunch of values of different +types, 'NS' allows you to choose from a bunch +of types. +-} module Mu.Schema.Interpretation ( + -- * Interpretation Term(..), Field(..), FieldValue(..) , NS(..), NP(..), Proxy(..) -, transWrap, transFields, transValue -, transWrapNoMaps, transFieldsNoMaps, transValueNoMaps + -- * Transforming the wrapper type +, transWrap, transWrapNoMaps + -- ** For internal use only +, transFields, transFieldsNoMaps +, transValue, transValueNoMaps ) where import Data.Map @@ -26,30 +53,42 @@ import Mu.Schema.Definition -- | Interpretation of a type in a schema. data Term w (sch :: Schema typeName fieldName) (t :: TypeDef typeName fieldName) where + -- | A record given by the value of its fields. TRecord :: NP (Field w sch) args -> Term w sch ('DRecord name args) + -- | An enumeration given by one choice. TEnum :: NS Proxy choices -> Term w sch ('DEnum name choices) + -- | A primitive value. TSimple :: FieldValue w sch t -> Term w sch ('DSimple t) -- | Interpretation of a field. data Field w (sch :: Schema typeName fieldName) (f :: FieldDef typeName fieldName) where + -- | A single field. Note that the contents are wrapped in a @w@ type constructor. Field :: w (FieldValue w sch t) -> Field w sch ('FieldDef name t) -- | Interpretation of a field type, by giving a value of that type. data FieldValue w (sch :: Schema typeName fieldName) (t :: FieldType typeName) where + -- | Null value, as found in Avro and JSON. FNull :: FieldValue w sch 'TNull + -- | Value of a primitive type. FPrimitive :: t -> FieldValue w sch ('TPrimitive t) + -- | Term of another type in the schema. FSchematic :: Term w sch (sch :/: t) -> FieldValue w sch ('TSchematic t) + -- | Optional value. FOption :: Maybe (FieldValue w sch t) -> FieldValue w sch ('TOption t) + -- | List of values. FList :: [FieldValue w sch t] -> FieldValue w sch ('TList t) + -- | Dictionary (key-value map) of values. FMap :: Ord (FieldValue w sch k) => Map (FieldValue w sch k) (FieldValue w sch v) -> FieldValue w sch ('TMap k v) + -- | One single value of one of the specified types. FUnion :: NS (FieldValue w sch) choices -> FieldValue w sch ('TUnion choices) +-- | Change the underlying wrapper of a term. transWrap :: forall tn fn (sch :: Schema tn fn) t u v. (Functor u, forall k. Ord (FieldValue u sch k) => Ord (FieldValue v sch k)) @@ -60,6 +99,10 @@ transWrap n x = case x of TEnum c -> TEnum c TSimple v -> TSimple (transValue n v) +-- | Change the underlying wrapper of a term. +-- This version assumes that no field is a map, +-- which allows for a more general type. +-- If a map is found, an exception is raised. transWrapNoMaps :: forall tn fn (sch :: Schema tn fn) t u v. (Functor u) @@ -70,6 +113,7 @@ transWrapNoMaps n x = case x of TEnum c -> TEnum c TSimple v -> TSimple (transValueNoMaps n v) +-- | Change the underlying wrapper of a list of fields. transFields :: forall tn fn (sch :: Schema tn fn) args u v. (Functor u, forall k. Ord (FieldValue u sch k) => Ord (FieldValue v sch k)) @@ -79,6 +123,8 @@ transFields _ Nil = Nil transFields n (Field v :* rest) = Field (n (fmap (transValue n) v)) :* transFields n rest +-- | Change the underlying wrapper of a list of fields. +-- This version assumes no maps are present as fields. transFieldsNoMaps :: forall tn fn (sch :: Schema tn fn) args u v. (Functor u) @@ -88,6 +134,7 @@ transFieldsNoMaps _ Nil = Nil transFieldsNoMaps n (Field v :* rest) = Field (n (fmap (transValueNoMaps n) v)) :* transFieldsNoMaps n rest +-- | Change the underlying wrapper of a value. transValue :: forall tn fn (sch :: Schema tn fn) l u v. (Functor u, forall k. Ord (FieldValue u sch k) => Ord (FieldValue v sch k)) @@ -105,6 +152,8 @@ transValue n (FUnion u) = FUnion (transUnion u) transUnion (Z z) = Z (transValue n z) transUnion (S s) = S (transUnion s) +-- | Change the underlying wrapper of a value. +-- This version assumes that the value is not a map. transValueNoMaps :: forall tn fn (sch :: Schema tn fn) l u v. (Functor u) diff --git a/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs b/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs index f85d6261..c8e247e1 100644 --- a/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs +++ b/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs @@ -7,12 +7,28 @@ {-# language StandaloneDeriving #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} +{-| +Description : Anonymous terms for schema types + +This module provides "anonymous terms". These +terms can be used when you don't want to write +your own Haskell type, but simply have a quick +and dirty interpretation for a schema type. +An important limitation is that anonymous terms +may only contain primitive fields. + +The names of the types exposed in this module +refer to the amount of fields in the record. +Hence, use 'V0' for empty record, 'V1' for a record +with one field, 'V2' for two, and so forth. +-} module Mu.Schema.Interpretation.Anonymous where import Data.SOP import Mu.Schema +-- | Anonymous term for a record with zero fields. data V0 w sch sty where V0 :: (sch :/: sty ~ 'DRecord nm '[]) => V0 w sch sty @@ -28,6 +44,7 @@ instance (sch :/: sty ~ 'DRecord nm '[]) => FromSchema w sch sty (V0 w sch sty) where fromSchema (TRecord Nil) = V0 +-- | Anonymous term for a record with one field. data V1 w sch sty where V1 :: (sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) @@ -54,6 +71,7 @@ instance ( Functor w where unPrimitive :: FieldValue w sch ('TPrimitive t) -> t unPrimitive (FPrimitive l) = l +-- | Anonymous term for a record with two fields. data V2 w sch sty where V2 :: (sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) diff --git a/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs b/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs index 037bdcb9..122a5b23 100644 --- a/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs +++ b/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs @@ -10,13 +10,24 @@ {-# language TypeApplications #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} +{-| +Description : Terms without an associated schema + +In the edges of your application it's useful to +consider terms for which a type-level schema has +not yet been applied. Think of receiving a JSON +document: you can parse it but checking the schema +is an additional step. +-} module Mu.Schema.Interpretation.Schemaless ( -- * Terms without an associated schema Term(..), Field(..), FieldValue(..) -- * Checking and conversion against a schema -, CheckSchema, checkSchema, fromSchemalessTerm +, checkSchema, fromSchemalessTerm -- * For deserialization to schemaless terms , ToSchemalessTerm(..), ToSchemalessValue(..) + -- * For implementors +, CheckSchema ) where import Control.Applicative ((<|>)) @@ -33,8 +44,11 @@ import qualified Mu.Schema.Interpretation as S -- | Interpretation of a type in a schema. data Term (w :: * -> *) where + -- | A record given by the value of its fields. TRecord :: [Field w] -> Term w + -- | An enumeration given by one choice. TEnum :: Int -> Term w + -- | A primitive value. TSimple :: FieldValue w -> Term w deriving instance Eq (w (FieldValue w)) => Eq (Term w) @@ -43,6 +57,8 @@ deriving instance Show (w (FieldValue w)) => Show (Term w) -- | Interpretation of a field. data Field (w :: * -> *) where + -- | A single field given by its name and its value. + -- Note that the contents are wrapped in a @w@ type constructor. Field :: T.Text -> w (FieldValue w) -> Field w deriving instance Eq (w (FieldValue w)) => Eq (Field w) @@ -58,23 +74,43 @@ data FieldValue (w :: * -> *) where FList :: [FieldValue w] -> FieldValue w FMap :: M.Map (FieldValue w) (FieldValue w) -> FieldValue w +-- | Checks that a schemaless 'Term' obbeys the +-- restrictions for tyoe @t@ of schema @s@. +-- If successful, returns a 'S.Term' indexed +-- by the corresponding schema and type. +-- +-- Use this function to check a schemaless terms +-- at the "borders" of your application. checkSchema :: forall (s :: Schema tn fn) (t :: tn) (w :: * -> *). (Traversable w, CheckSchema s (s :/: t)) => Proxy t -> Term w -> Maybe (S.Term w s (s :/: t)) checkSchema _ = checkSchema' +-- | Converts a schemaless term to a Haskell type +-- by going through the corresponding schema type. fromSchemalessTerm :: forall sch w t sty. (Traversable w, FromSchema w sch sty t, CheckSchema sch (sch :/: sty)) => Term w -> Maybe t fromSchemalessTerm t = fromSchema @_ @_ @w @sch <$> checkSchema (Proxy @sty) t +-- | Deserialization to schemaless terms. class ToSchemalessTerm t w where + -- | Turns a document (such as JSON) into a schemaless term. + -- This function should handle the "compound" types in that format, + -- such as records and enumerations. toSchemalessTerm :: t -> Term w +-- | Deserialization to schemaless values. class ToSchemalessValue t w where + -- | Turns a document (such as JSON) into a schemaless term. + -- This function should handle the "primitive" types in that format. toSchemalessValue :: t -> FieldValue w +-- | Type class used to define the generic 'checkSchema'. +-- +-- Exposed for usage in other modules, +-- in particular 'Mu.Schema.Registry'. class CheckSchema (s :: Schema tn fn) (t :: TypeDef tn fn) where checkSchema' :: Traversable w => Term w -> Maybe (S.Term w s t) class CheckSchemaFields (s :: Schema tn fn) (fields :: [FieldDef tn fn]) where diff --git a/core/schema/src/Mu/Schema/Registry.hs b/core/schema/src/Mu/Schema/Registry.hs index ee083b00..ee7fefd5 100644 --- a/core/schema/src/Mu/Schema/Registry.hs +++ b/core/schema/src/Mu/Schema/Registry.hs @@ -9,6 +9,18 @@ {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} +{-| +Description : Registry of schemas + +A registry of schemas saves the different schemas +supported by an application. Since messages and +protocols may evolve, it's useful to keep an updated +view of the different shapes of data we can handle. + +Examples of registries are found in + +and . +-} module Mu.Schema.Registry ( -- * Registry of schemas Registry, fromRegistry @@ -25,8 +37,22 @@ import Mu.Schema.Class import Mu.Schema.Definition import qualified Mu.Schema.Interpretation.Schemaless as SLess +-- | A 'Registry' is defined as a map from +-- version numbers to type-level schemas. +-- +-- /Implementation note/: you __must__ +-- write newer schemas at the head of the +-- 'Registry'. Otherwise, older schemas +-- take precedence during conversion. type Registry = Mappings Nat Schema' +-- | Converts a schemaless term into a value +-- by checking all the possible schemas in +-- a 'Registry'. +-- +-- /Implementation note/: schemas are checked +-- __in the same order__ in which they appear +-- in the 'Registry' definition. fromRegistry :: forall r t w. FromRegistry w r t => SLess.Term w -> Maybe t fromRegistry = fromRegistry' (Proxy @r) diff --git a/generate-haddock-docs.sh b/generate-haddock-docs.sh index 3a896c36..e2522369 100755 --- a/generate-haddock-docs.sh +++ b/generate-haddock-docs.sh @@ -9,7 +9,7 @@ echo "Removing previous docs" rm -rf ${DOCSDIR} echo "Building the project" -stack build +stack clean && stack build echo "Generating new docs" stack exec --no-ghc-package-path standalone-haddock -- -o ${DOCSDIR} \ @@ -17,7 +17,7 @@ stack exec --no-ghc-package-path standalone-haddock -- -o ${DOCSDIR} \ --dist-dir=$(stack path --dist-dir) \ --package-db=$(stack path --snapshot-pkg-db) \ --package-db=$(stack path --local-pkg-db) \ + --hyperlink-source \ core/schema core/rpc \ adapter/avro adapter/protobuf adapter/persistent \ - grpc/client grpc/server \ - compendium-client + grpc/client grpc/server diff --git a/grpc/client/src/Mu/GRpc/Client/Examples.hs b/grpc/client/src/Mu/GRpc/Client/Examples.hs index 57f3e923..5131c032 100644 --- a/grpc/client/src/Mu/GRpc/Client/Examples.hs +++ b/grpc/client/src/Mu/GRpc/Client/Examples.hs @@ -1,6 +1,11 @@ {-# language DataKinds #-} {-# language TypeApplications #-} {-# language TypeFamilies #-} +{-| +Description : Examples for gRPC clients + +Look at the source code of this module. +-} module Mu.GRpc.Client.Examples where import Data.Conduit diff --git a/grpc/client/src/Mu/GRpc/Client/Record.hs b/grpc/client/src/Mu/GRpc/Client/Record.hs index c0321192..77ed86a8 100644 --- a/grpc/client/src/Mu/GRpc/Client/Record.hs +++ b/grpc/client/src/Mu/GRpc/Client/Record.hs @@ -10,8 +10,12 @@ {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} --- | Client for gRPC services defined using Mu 'Service' --- using plain Haskell records of functions +{-| +Description : Client for gRPC services using plain Haskell records + +For further information over initialization of the connection, +consult the . +-} module Mu.GRpc.Client.Record ( -- * Initialization of the gRPC client GrpcClient diff --git a/grpc/client/src/Mu/GRpc/Client/TyApps.hs b/grpc/client/src/Mu/GRpc/Client/TyApps.hs index e90c1ebb..56d6a89f 100644 --- a/grpc/client/src/Mu/GRpc/Client/TyApps.hs +++ b/grpc/client/src/Mu/GRpc/Client/TyApps.hs @@ -7,8 +7,12 @@ {-# language ScopedTypeVariables #-} {-# language TypeApplications #-} {-# language TypeOperators #-} --- | Client for gRPC services defined using Mu 'Service' --- using 'TypeApplications' +{-| +Description : Client for gRPC services using @TypeApplications@ + +For further information over initialization of the connection, +consult the . +-} module Mu.GRpc.Client.TyApps ( -- * Initialization of the gRPC client GrpcClient @@ -31,13 +35,14 @@ import Mu.GRpc.Client.Internal -- | Call a method from a Mu definition. -- This method is thought to be used with @TypeApplications@: +-- -- > gRpcCall @"packageName" @ServiceDeclaration @"method" -- --- The additional arguments you must provide to 'grpcCall' +-- The additional arguments you must provide to 'gRpcCall' -- depend on the signature of the method itself: -- * The resulting value is always wrapped in 'GRpcReply'. --- * A 'Single' input or output turns into a single value. --- * A 'Stream' input or output turns into a 'ConduitT' +-- * A single input or output turns into a single value. +-- * A streaming input or output turns into a Conduit. gRpcCall :: forall s methodName h. (GRpcServiceMethodCall s (s :-->: methodName) h) => GrpcClient -> h diff --git a/grpc/server/src/Mu/GRpc/Server.hs b/grpc/server/src/Mu/GRpc/Server.hs index caaf8437..56fa774e 100644 --- a/grpc/server/src/Mu/GRpc/Server.hs +++ b/grpc/server/src/Mu/GRpc/Server.hs @@ -9,7 +9,15 @@ {-# language TypeApplications #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} --- | Execute a Mu 'Server' using gRPC as transport layer +{-| +Description : Execute a Mu 'Server' using gRPC as transport layer + +This module allows you to server a Mu 'Server' +as a WAI 'Application' using gRPC as transport layer. + +The simples way is to use 'runGRpcApp', all other +variants provide more control over the settings. +-} module Mu.GRpc.Server ( -- * Run a 'Server' directly runGRpcApp, runGRpcAppTrans @@ -143,11 +151,25 @@ class GRpcMethodHandler m args r h where gRpcMethodHandler :: (forall a. m a -> ServerErrorIO a) -> Proxy args -> Proxy r -> RPC -> h -> ServiceHandler +-- | Turns a 'Conduit' working on 'ServerErrorIO' +-- into any other base monad which supports 'IO', +-- by raising any error as an exception. +-- +-- This function is useful to interoperate with +-- libraries which generate 'Conduit's with other +-- base monads, such as @persistent@. liftServerConduit :: MonadIO m => ConduitT a b ServerErrorIO r -> ConduitT a b m r liftServerConduit = transPipe raiseErrors +-- | Raises errors from 'ServerErrorIO' as exceptions +-- in a monad which supports 'IO'. +-- +-- This function is useful to interoperate with other +-- libraries which cannot handle the additional error +-- layer. In particular, with Conduit, as witnessed +-- by 'liftServerConduit'. raiseErrors :: MonadIO m => ServerErrorIO a -> m a raiseErrors h = liftIO $ do From 08969e482ee73d3862db3ed83832adee24608246 Mon Sep 17 00:00:00 2001 From: Juan Valencia Calvellido Date: Tue, 7 Jan 2020 17:58:50 +0100 Subject: [PATCH 035/217] Slight update on styling --- docs/_includes/_doc.html | 12 ++++++++---- docs/_sass/components/_doc.scss | 22 +++++++--------------- 2 files changed, 15 insertions(+), 19 deletions(-) diff --git a/docs/_includes/_doc.html b/docs/_includes/_doc.html index 3c42272e..7e219d9a 100644 --- a/docs/_includes/_doc.html +++ b/docs/_includes/_doc.html @@ -8,10 +8,14 @@ Toggle - +
+
+ API Docs +
+
+ GitHub +
+
diff --git a/docs/_sass/components/_doc.scss b/docs/_sass/components/_doc.scss index 26b56b32..b485ca7c 100755 --- a/docs/_sass/components/_doc.scss +++ b/docs/_sass/components/_doc.scss @@ -33,23 +33,15 @@ } } - ul { + .link-container { display: flex; - justify-content: space-between; - flex-direction: row; + height: 100%; + width: 100%; + justify-content: flex-end; + align-items: center; - .nav-menu-item { - padding: ($base-point-grid * 2); - margin: ($base-point-grid * 2); - list-style-type: none; - - a { - color: $gray-primary; - &:hover { - color: rgba($brand-primary, 0.96); - text-decoration: none; - } - } + .link-item { + margin-left: ($base-point-grid * 2); } } } From 8584007f2ee6a0aaf13b8bd5daf16af1830c4cbe Mon Sep 17 00:00:00 2001 From: Juan Valencia Date: Thu, 9 Jan 2020 09:44:35 +0100 Subject: [PATCH 036/217] Set Linuwial theme for Haddock generated docs (#66) --- docs/css/linuwial.css | 877 +++++++++++++++++++++++++++++++++++++++ generate-haddock-docs.sh | 3 + 2 files changed, 880 insertions(+) create mode 100644 docs/css/linuwial.css diff --git a/docs/css/linuwial.css b/docs/css/linuwial.css new file mode 100644 index 00000000..cbb58a03 --- /dev/null +++ b/docs/css/linuwial.css @@ -0,0 +1,877 @@ +/* @group Fundamentals */ + +* { margin: 0; padding: 0 } + +/* Is this portable? */ +html { + background-color: white; + width: 100%; + height: 100%; +} + +body { + background: #fefefe; + color: #111; + text-align: left; + min-height: 100vh; + position: relative; + -webkit-text-size-adjust: 100%; + -webkit-font-feature-settings: "kern" 1, "liga" 0; + -moz-font-feature-settings: "kern" 1, "liga" 0; + -o-font-feature-settings: "kern" 1, "liga" 0; + font-feature-settings: "kern" 1, "liga" 0; + letter-spacing: 0.0015rem; +} + +#content a { + overflow-wrap: break-word; +} + +p { + margin: 0.8em 0; +} + +ul, ol { + margin: 0.8em 0 0.8em 2em; +} + +dl { + margin: 0.8em 0; +} + +dt { + font-weight: bold; +} +dd { + margin-left: 2em; +} + +a { text-decoration: none; } +a[href]:link { color: #9E358F; } +a[href]:visited {color: #6F5F9C; } +a[href]:hover { text-decoration:underline; } + +a[href].def:link, a[href].def:visited { color: rgba(69, 59, 97, 0.8); } +a[href].def:hover { color: rgb(78, 98, 114); } + +/* @end */ + +/* @group Show and hide with JS */ + +body.js-enabled .hide-when-js-enabled { + display: none; +} + +/* @end */ + + +/* @group responsive */ + +#package-header .caption { + margin: 0px 1em 0 2em; +} + +@media only screen and (min-width: 1280px) { + #content { + width: 63vw; + max-width: 1450px; + } + + #table-of-contents { + position: fixed; + max-width: 10vw; + top: 10.2em; + left: 2em; + bottom: 1em; + overflow-y: auto; + } + + #synopsis { + display: block; + position: fixed; + float: left; + top: 5em; + bottom: 1em; + right: 0; + max-width: 65vw; + overflow-y: auto; + /* Ensure that synopsis covers everything (including MathJAX markup) */ + z-index: 1; + } + + #synopsis .show { + border: 1px solid #5E5184; + padding: 0.7em; + max-height: 65vh; + } + +} + +@media only screen and (max-width: 1279px) { + #content { + width: 80vw; + } + + #synopsis { + display: block; + padding: 0; + position: relative; + margin: 0; + width: 100%; + } +} + +@media only screen and (max-width: 999px) { + #content { + width: 93vw; + } +} + + +/* menu for wider screens + + Display the package name at the left and the menu links at the right, + inline with each other: + The package name Source . Contents . Index +*/ +@media only screen and (min-width: 1000px) { + #package-header { + text-align: left; + white-space: nowrap; + height: 40px; + padding: 4px 1.5em 0px 1.5em; + overflow: visible; + + display: flex; + justify-content: space-between; + align-items: center; + } + + #package-header .caption { + display: inline-block; + margin: 0; + } + + #package-header ul.links { + margin: 0; + display: inline-table; + } + + #package-header .caption + ul.links { + margin-left: 1em; + } +} + +/* menu for smaller screens + +Display the package name on top of the menu links and center both elements: + The package name + Source . Contents . Index +*/ +@media only screen and (max-width: 999px) { + #package-header { + text-align: center; + padding: 6px 0 4px 0; + overflow: hidden; + } + + #package-header ul.links { + display: block; + text-align: center; + margin: 0; + + /* Hide scrollbar but allow scrolling menu links horizontally */ + white-space: nowrap; + overflow-x: auto; + overflow-y: hidden; + margin-bottom: -17px; + height: 50px; + } + + #package-header .caption { + display: block; + margin: 4px 0; + text-align: center; + } + + #package-header ul.links::-webkit-scrollbar { + display: none; + } + + #package-header ul.links li:first-of-type { + padding-left: 1em; + } + + #package-header ul.links li:last-of-type { + /* + The last link of the menu should offer the same distance to the right + as the #package-header enforces at the left. + */ + padding-right: 1em; + } + + #package-header .caption + ul.links { + padding-top: 9px; + } + + #module-header table.info { + float: none; + top: 0; + margin: 0 auto; + overflow: hidden; + max-width: 80vw; + } +} + +/* @end */ + + +/* @group Fonts & Sizes */ + +/* Basic technique & IE workarounds from YUI 3 + For reasons, see: + http://yui.yahooapis.com/3.1.1/build/cssfonts/fonts.css + */ + + body, button { + font: 400 14px/1.4 'PT Sans', + /* Fallback Font Stack */ + -apple-system, + BlinkMacSystemFont, + 'Segoe UI', + Roboto, + Oxygen-Sans, + Cantarell, + 'Helvetica Neue', + sans-serif; + *font-size: medium; /* for IE */ + *font:x-small; /* for IE in quirks mode */ + } + +h1 { font-size: 146.5%; /* 19pt */ } +h2 { font-size: 131%; /* 17pt */ } +h3 { font-size: 116%; /* 15pt */ } +h4 { font-size: 100%; /* 13pt */ } +h5 { font-size: 100%; /* 13pt */ } + +table { + font-size:inherit; + font:100%; +} + +pre, code, kbd, samp, tt, .src { + font-family:monospace; +} + +.links, .link { + font-size: 85%; /* 11pt */ +} + +#module-header .caption { + font-size: 182%; /* 24pt */ +} + +#module-header .caption sup { + font-size: 80%; + font-weight: normal; +} + +#package-header #page-menu a:link, #package-header #page-menu a:visited { color: white; } + + +.info { + font-size: 90%; +} + + +/* @end */ + +/* @group Common */ + +.caption, h1, h2, h3, h4, h5, h6, summary { + font-weight: bold; + color: #5E5184; + margin: 1.5em 0 1em 0; +} + + +* + h1, * + h2, * + h3, * + h4, * + h5, * + h6 { + margin-top: 2em; +} + +h1 + h2, h2 + h3, h3 + h4, h4 + h5, h5 + h6 { + margin-top: inherit; +} + +ul li + li { + margin-top: 0.2rem; +} + +ul + p { + margin-top: 0.93em; +} + +p + ul { + margin-top: 0.5em; +} + +p { + margin-top: 0.7rem; +} + +ul, ol { + margin: 0.8em 0 0.8em 2em; +} + +ul.links { + list-style: none; + text-align: left; + font-size: 0.95em; +} + +#package-header ul.links, #package-header ul.links button { + font-size: 1rem; +} + +ul.links li { + display: inline; + white-space: nowrap; + padding: 0; +} + +ul.links > li + li:before { + content: '\00B7'; +} + +ul.links li a { + padding: 0.2em 0.5em; +} + +.hide { display: none; } +.show { display: inherit; } +.clear { clear: both; } + +.collapser:before, .expander:before, .noexpander:before { + font-size: 1.2em; + color: #9C5791; + display: inline-block; + padding-right: 7px; +} + +.collapser:before { + content: '▿'; +} +.expander:before { + content: '▹'; +} +.noexpander:before { + content: '▿'; + visibility: hidden; +} + +.collapser, .expander { + cursor: pointer; +} + +.instance.collapser, .instance.expander { + margin-left: 0px; + background-position: left center; + min-width: 9px; + min-height: 9px; +} + +summary { + cursor: pointer; + outline: none; +} + +pre { + padding: 0.5rem 1rem; + margin: 1em 0 0 0; + background-color: #f7f7f7; + overflow: auto; + border: 1px solid #ddd; + border-radius: 0.3em; +} + +pre + p { + margin-top: 1em; +} + +pre + pre { + margin-top: 0.5em; +} + +blockquote { + border-left: 3px solid #c7a5d3; + background-color: #eee4f1; + margin: 0.5em; + padding: 0.0005em 0.3em 0.5em 0.5em; +} + +.src { + background: #f2f2f2; + padding: 0.2em 0.5em; +} + +.keyword { font-weight: normal; } +.def { font-weight: bold; } + +@media print { + #footer { display: none; } +} + +/* @end */ + +/* @group Page Structure */ + +#content { + margin: 3em auto 6em auto; + padding: 0; +} + +#package-header { + background: #5E5184; + border-bottom: 5px solid rgba(69, 59, 97, 0.5); + color: #ddd; + position: relative; + font-size: 1.2em; + text-align: left; + margin: 0 auto; +} + +#package-header .caption { + color: white; + font-style: normal; + font-size: 1rem; + font-weight: bold; +} + +#module-header .caption { + font-weight: bold; + border-bottom: 1px solid #ddd; +} + +table.info { + float: right; + padding: 0.5em 1em; + border: 1px solid #ddd; + color: rgb(78,98,114); + background-color: #fff; + max-width: 60%; + border-spacing: 0; + position: relative; + top: -0.78em; + margin: 0 0 0 2em; +} + +.info th { + padding: 0 1em 0 0; + text-align: right; +} + +#style-menu li { + display: block; + border-style: none; + list-style-type: none; +} + +#footer { + background: #ededed; + border-top: 1px solid #aaa; + padding: 0.5em 0; + color: #222; + text-align: center; + width: 100%; + height: 3em; + margin-top: 3em; + position: relative; + clear: both; +} + +/* @end */ + +/* @group Front Matter */ + +#synopsis .caption, +#contents-list .caption { + font-size: 1rem; +} + +#synopsis, #table-of-contents { + font-size: 16px; +} + +#contents-list { + background: #f4f4f4; + padding: 1em; + margin: 0; +} + +#contents-list .caption { + text-align: left; + margin: 0; +} + +#contents-list ul { + list-style: none; + margin: 0; + margin-top: 10px; + font-size: 14px; +} + +#contents-list ul ul { + margin-left: 1.5em; +} + +#description .caption { + display: none; +} + +#synopsis summary { + display: block; + float: right; + width: 29px; + color: rgba(255,255,255,0); + height: 110px; + margin: 0; + font-size: 1px; + padding: 0; + background: url(synopsis.png) no-repeat 0px -8px; +} + +#synopsis details[open] > summary { + background: url(synopsis.png) no-repeat -75px -8px; +} + +#synopsis ul { + height: 100%; + overflow: auto; + padding: 0.5em; + margin: 0; +} + +#synopsis ul ul { + overflow: hidden; +} + +#synopsis ul, +#synopsis ul li.src { + background-color: rgb(250,247,224); + white-space: nowrap; + list-style: none; + margin-left: 0; +} + +#interface td.src { + white-space: nowrap; +} + +/* @end */ + +/* @group Main Content */ + +#interface div.top + div.top { + margin-top: 1.5em; +} + +#interface p + div.top, +#interface h1 + div.top, +#interface h2 + div.top, +#interface h3 + div.top, +#interface h4 + div.top, +#interface h5 + div.top { + margin-top: 1em; +} +#interface .src .selflink, +#interface .src .link { + float: right; + color: #888; + padding: 0 7px; + -moz-user-select: none; + font-weight: bold; + line-height: 30px; +} +#interface .src .selflink { + margin: 0 -0.5em 0 0.5em; +} + +#interface span.fixity { + color: #919191; + border-left: 1px solid #919191; + padding: 0.2em 0.5em 0.2em 0.5em; + margin: 0 -1em 0 1em; +} + +#interface span.rightedge { + border-left: 1px solid #919191; + padding: 0.2em 0 0.2em 0; + margin: 0 0 0 1em; +} + +#interface table { border-spacing: 2px; } +#interface td { + vertical-align: top; + padding-left: 0.5em; +} + +#interface td.doc p { + margin: 0; +} +#interface td.doc p + p { + margin-top: 0.8em; +} + +.doc table { + border-collapse: collapse; + border-spacing: 0px; +} + +.doc th, +.doc td { + padding: 5px; + border: 1px solid #ddd; +} + +.doc th { + background-color: #f0f0f0; +} + +.clearfix:after { + clear: both; + content: " "; + display: block; + height: 0; + visibility: hidden; +} + +.subs, .top > .doc, .subs > .doc { + padding-left: 1em; + border-left: 1px solid gainsboro; + margin-bottom: 1em; +} + +.top .subs { + margin-bottom: 0.6em; +} + +.subs.fields ul { + list-style: none; + display: table; + margin: 0; +} + +.subs.fields ul li { + display: table-row; +} + +.subs ul li dfn { + display: table-cell; + font-style: normal; + font-weight: bold; + margin: 1px 0; + white-space: nowrap; +} + +.subs ul li > .doc { + display: table-cell; + padding-left: 0.5em; + margin-bottom: 0.5em; +} + +.subs ul li > .doc p { + margin: 0; +} + +.subs .subs p.src { + border: none; + background-color: #f8f8f8; +} + +.subs .subs .caption { + margin-top: 1em ; + margin-bottom: 0px; +} + +.subs p.caption { + margin-top: 0; +} + +.subs .subs .caption + .src { + margin: 0px; + margin-top: 8px; +} + +.subs .subs .src + .src { + margin: 7px 0 0 0; +} + +/* Render short-style data instances */ +.inst ul { + height: 100%; + padding: 0.5em; + margin: 0; +} + +.inst, .inst li { + list-style: none; + margin-left: 1em; +} + +/* Workaround for bug in Firefox (issue #384) */ +.inst-left { + float: left; +} + +.top p.src { + border-bottom: 3px solid #e5e5e5; + line-height: 2rem; + margin-bottom: 1em; +} + +.warning { + color: red; +} + +.arguments { + margin-top: -0.4em; +} +.arguments .caption { + display: none; +} + +.fields { padding-left: 1em; } + +.fields .caption { display: none; } + +.fields p { margin: 0 0; } + +/* this seems bulky to me +.methods, .constructors { + background: #f8f8f8; + border: 1px solid #eee; +} +*/ + +/* @end */ + +/* @group Auxillary Pages */ + + +.extension-list { + list-style-type: none; + margin-left: 0; +} + +#mini { + margin: 0 auto; + padding: 0 1em 1em; +} + +#mini > * { + font-size: 93%; /* 12pt */ +} + +#mini #module-list .caption, +#mini #module-header .caption { + font-size: 125%; /* 15pt */ +} + +#mini #interface h1, +#mini #interface h2, +#mini #interface h3, +#mini #interface h4 { + font-size: 109%; /* 13pt */ + margin: 1em 0 0; +} + +#mini #interface .top, +#mini #interface .src { + margin: 0; +} + +#mini #module-list ul { + list-style: none; + margin: 0; +} + +#alphabet ul { + list-style: none; + padding: 0; + margin: 0.5em 0 0; + text-align: center; +} + +#alphabet li { + display: inline; + margin: 0 0.25em; +} + +#alphabet a { + font-weight: bold; +} + +#index .caption, +#module-list .caption { font-size: 131%; /* 17pt */ } + +#index table { + margin-left: 2em; +} + +#index .src { + font-weight: bold; +} +#index .alt { + font-size: 77%; /* 10pt */ + font-style: italic; + padding-left: 2em; +} + +#index td + td { + padding-left: 1em; +} + +#module-list ul { + list-style: none; + margin: 0 0 0 2em; +} + +#module-list li { + clear: right; +} + +#module-list span.collapser, +#module-list span.expander { + background-position: 0 0.3em; +} + +#module-list .package { + float: right; +} + +:target { + background: -webkit-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); + background: -moz-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); + background: -o-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); + background: -ms-linear-gradient(top, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); + background: linear-gradient(to bottom, transparent 0%, transparent 65%, #fbf36d 60%, #fbf36d 100%); +} + +:target:hover { + background: -webkit-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); + background: -moz-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); + background: -o-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); + background: -ms-linear-gradient(top, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); + background: linear-gradient(to bottom, transparent 0%, transparent 0%, #fbf36d 0%, #fbf36d 100%); +} + +/* @end */ + +/* @group Dropdown menus */ + +#preferences-menu, #style-menu { + width: 25em; + overflow-y: auto; +} + +/* @end */ diff --git a/generate-haddock-docs.sh b/generate-haddock-docs.sh index e2522369..39f57155 100755 --- a/generate-haddock-docs.sh +++ b/generate-haddock-docs.sh @@ -21,3 +21,6 @@ stack exec --no-ghc-package-path standalone-haddock -- -o ${DOCSDIR} \ core/schema core/rpc \ adapter/avro adapter/protobuf adapter/persistent \ grpc/client grpc/server + +echo "Setting Linuwial theme on Haddock generated docs" +find ${DOCSDIR} -name "ocean.css" -exec cp -rf docs/css/linuwial.css {} \; From fb17ab11226003a2dc2da125a965e2fc04244185 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Thu, 9 Jan 2020 14:31:31 +0100 Subject: [PATCH 037/217] Make Haddock style match docs style (#69) --- docs/css/linuwial.css | 23 +++++++++++++---------- 1 file changed, 13 insertions(+), 10 deletions(-) diff --git a/docs/css/linuwial.css b/docs/css/linuwial.css index cbb58a03..8885d0d4 100644 --- a/docs/css/linuwial.css +++ b/docs/css/linuwial.css @@ -1,3 +1,6 @@ +@import url('https://fonts.googleapis.com/css?family=Fira+Mono:400,500,700&display=swap'); +@import url('https://fonts.googleapis.com/css?family=Montserrat:400,600,700&display=swap'); + /* @group Fundamentals */ * { margin: 0; padding: 0 } @@ -47,7 +50,7 @@ dd { } a { text-decoration: none; } -a[href]:link { color: #9E358F; } +a[href]:link { color: #6d2c71; } a[href]:visited {color: #6F5F9C; } a[href]:hover { text-decoration:underline; } @@ -100,7 +103,7 @@ body.js-enabled .hide-when-js-enabled { } #synopsis .show { - border: 1px solid #5E5184; + border: 1px solid #6d2c71; padding: 0.7em; max-height: 65vh; } @@ -234,7 +237,7 @@ Display the package name on top of the menu links and center both elements: */ body, button { - font: 400 14px/1.4 'PT Sans', + font: 400 14px/1.4 'Montserrat', 'PT Sans', /* Fallback Font Stack */ -apple-system, BlinkMacSystemFont, @@ -260,7 +263,7 @@ table { } pre, code, kbd, samp, tt, .src { - font-family:monospace; + font-family: 'Fira Mono', monospace;; } .links, .link { @@ -290,7 +293,7 @@ pre, code, kbd, samp, tt, .src { .caption, h1, h2, h3, h4, h5, h6, summary { font-weight: bold; - color: #5E5184; + color: #512054; margin: 1.5em 0 1em 0; } @@ -431,8 +434,8 @@ blockquote { } #package-header { - background: #5E5184; - border-bottom: 5px solid rgba(69, 59, 97, 0.5); + background: #6d2c71; + border-bottom: 5px solid #512054; color: #ddd; position: relative; font-size: 1.2em; @@ -456,7 +459,7 @@ table.info { float: right; padding: 0.5em 1em; border: 1px solid #ddd; - color: rgb(78,98,114); + color: #512054; background-color: #fff; max-width: 60%; border-spacing: 0; @@ -529,7 +532,7 @@ table.info { } #synopsis summary { - display: block; + display: none; float: right; width: 29px; color: rgba(255,255,255,0); @@ -609,7 +612,7 @@ table.info { margin: 0 0 0 1em; } -#interface table { border-spacing: 2px; } +#interface table { border-spacing: 0px; } #interface td { vertical-align: top; padding-left: 0.5em; From dd0637798c699d9552b2ca1765a81ee62c5eae2d Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Thu, 9 Jan 2020 14:49:11 +0100 Subject: [PATCH 038/217] Update docs about gRPC clients (#68) Co-authored-by: Flavio Corpa --- docs/docs/grpc.md | 24 +++++++++++------------- 1 file changed, 11 insertions(+), 13 deletions(-) diff --git a/docs/docs/grpc.md b/docs/docs/grpc.md index 2fd0330b..d99c5e6c 100644 --- a/docs/docs/grpc.md +++ b/docs/docs/grpc.md @@ -47,20 +47,22 @@ main = do Where `watch`, `get` and `add` are the only valid 3 commands that our CLI is going to accept and call each respective service. +If you are not familiar with `TypeApplications`, you can check [this](https://www.reddit.com/r/haskell/comments/6ufnmr/scrap_your_proxy_arguments_with_typeapplications/), [that](https://blog.sumtypeofway.com/posts/fluent-polymorphism-type-applications.html) and [this](https://kseo.github.io/posts/2017-01-08-visible-type-application-ghc8.html). + ### Using records This option is a bit more verbose but it's also more explicit with the types and _"a bit more magic"_ than the one with `TypeApplications` (due to the use of Generics). -We need to define a new record type (hence the name) that declares the services our client is going to consume. Remember that the names of the record fields **must match** exactly the methods in the service: +We need to define a new record type (hence the name) that declares the services our client is going to consume. The names of the fields **must** match the names of the methods in the service, optionally prefixed by a **common** string. The prefix may also be empty, which means that the names in the record are exactly those in the service definition. In this case, we are prepending `call_` to each of them: ```haskell import GHC.Generics (Generic) import Mu.GRpc.Client.Record data Call = Call - { getPerson :: MPersonRequest -> IO (GRpcReply MPerson) - , newPerson :: MPerson -> IO (GRpcReply MPersonRequest) - , allPeople :: IO (ConduitT () (GRpcReply MPerson) IO ()) + { call_getPerson :: MPersonRequest -> IO (GRpcReply MPerson) + , call_newPerson :: MPerson -> IO (GRpcReply MPersonRequest) + , call_allPeople :: IO (ConduitT () (GRpcReply MPerson) IO ()) } deriving Generic ``` @@ -72,13 +74,11 @@ main = do let config = grpcClientConfigSimple "127.0.0.1" 1234 False - Right client <- setupGrpcClient' config + Right grpcClient <- setupGrpcClient' config -+ let client = buildService @Service "/grpc" grpcClient ++ let client = buildService @Service @"call_" grpcClient args <- getArgs ``` -Instead of building our client directly, we need to call `buildService` (and enable `TypeApplications`) to create the actual gRPC client. If you don't like `TypeApplications`, it is also possible to use a combination of `ScopedTypeVariables` and something like `(Proxy :: Proxy Service)` to achieve the same result, but it's a bit more verbose and we _encourge you1_ to use `TypeApplications` instead. 😉 - -That string (or `ByteString`) as a second argument to `buildService` corresponds to the route of the service. +Instead of building our client directly, we need to call `buildService` (and enable `TypeApplications`) to create the actual gRPC client. There are two type arguments to be explicitly given: the first one is the `Service` definition we want a client for, and the second one is the prefix in the record (in our case, this is `call_`). In the case you want an empty prefix, you write `@""` in that second position. After that, let's have a look at an example implementation of the three service calls: @@ -89,7 +89,7 @@ get :: Call -> String -> IO () get client idPerson = do let req = MPersonRequest $ readMaybe idPerson putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?" - res <- getPerson client req + res <- call_getPerson client req putStrLn $ "GET: response was: " ++ show res ``` @@ -100,12 +100,12 @@ add :: Call -> String -> String -> IO () add client nm ag = do let p = MPerson Nothing (Just $ T.pack nm) (readMaybe ag) putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag - res <- newPerson client p + res <- call_newPerson client p putStrLn $ "ADD: was creating successful? " ++ show res watching :: Call -> IO () watching client = do - replies <- allPeople client + replies <- call_allPeople client runConduit $ replies .| C.mapM_ print ``` @@ -150,6 +150,4 @@ Here though, while mapping `print` to the `Conduit`, we needed to add a type ann --- -1 To read more on `TypeApplications`, you can check [this](https://www.reddit.com/r/haskell/comments/6ufnmr/scrap_your_proxy_arguments_with_typeapplications/), [that](https://blog.sumtypeofway.com/posts/fluent-polymorphism-type-applications.html) and [this](https://kseo.github.io/posts/2017-01-08-visible-type-application-ghc8.html). - To see a **working example** you can check all the code at the [example with persistent](https://github.com/higherkindness/mu-haskell/tree/master/examples/with-persistent). From b8a303f6587515cac932288df1cb8c764bece52f Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Thu, 9 Jan 2020 17:41:26 +0100 Subject: [PATCH 039/217] =?UTF-8?q?Add=20auto-deploy=20of=20microsite=20to?= =?UTF-8?q?=20GH=20Pages=20=F0=9F=90=99=20(#67)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Juan Valencia --- .github/workflows/deploy.yml | 28 ++++++++++++++++++++++++++++ .github/workflows/haskell.yml | 2 +- 2 files changed, 29 insertions(+), 1 deletion(-) create mode 100644 .github/workflows/deploy.yml diff --git a/.github/workflows/deploy.yml b/.github/workflows/deploy.yml new file mode 100644 index 00000000..cc3092a3 --- /dev/null +++ b/.github/workflows/deploy.yml @@ -0,0 +1,28 @@ +name: Deploy +on: + push: + branches: + - master +jobs: + build: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v1 + - uses: mstksg/setup-stack@v1 + - name: Generate Haddock Docs + run: bash ./generate-haddock-docs.sh + - name: Get Bundle & Jekyll + run: | + sudo apt-get update + sudo apt-get install ruby-dev + sudo gem install bundler --force + sudo gem update --system + sudo bundle install --gemfile docs/Gemfile --path vendor/bundle + - name: Build microsite + run: BUNDLE_GEMFILE=./docs/Gemfile bundle exec jekyll build -b /mu-haskell -s docs -d gen-docs + - name: Deploy microsite + uses: peaceiris/actions-gh-pages@v2 + env: + ACTIONS_DEPLOY_KEY: ${{ secrets.ACTIONS_DEPLOY_KEY }} + PUBLISH_BRANCH: gh-pages + PUBLISH_DIR: ./gen-docs diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 4ac188bf..a321d8b7 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -1,5 +1,5 @@ name: Haskell CI -on: [push] +on: [pull_request] jobs: build: runs-on: ubuntu-latest From 036236e7c0ae6c1a5e9ad21e0e5b98d79b653a12 Mon Sep 17 00:00:00 2001 From: Juan Valencia Date: Thu, 9 Jan 2020 19:55:20 +0100 Subject: [PATCH 040/217] Website styling update (#70) --- docs/_sass/components/_button.scss | 4 +- docs/_sass/components/_sidebar-menu.scss | 22 ++--- docs/_sass/components/_sidebar.scss | 10 +- docs/_sass/utils/_variables.scss | 17 ++-- docs/css/linuwial.css | 2 +- docs/img/favicon.png | Bin 2790 -> 2216 bytes docs/img/header-image.svg | 99 -------------------- docs/img/main-feature-primary.svg | 75 --------------- docs/img/main-feature-secondary.svg | 110 ---------------------- docs/img/main-feature-tertiary.svg | 55 ----------- docs/img/nav-brand-white.svg | 109 ++++++++++++++++++++-- docs/img/nav-brand.svg | 111 +++++++++++++++++++++-- docs/img/nav-icon-close.svg | 4 +- docs/img/nav-icon-open.svg | 6 +- docs/img/sidebar-icon-open.svg | 10 +- 15 files changed, 240 insertions(+), 394 deletions(-) delete mode 100644 docs/img/header-image.svg delete mode 100644 docs/img/main-feature-primary.svg delete mode 100644 docs/img/main-feature-secondary.svg delete mode 100644 docs/img/main-feature-tertiary.svg diff --git a/docs/_sass/components/_button.scss b/docs/_sass/components/_button.scss index b01a6307..ddd9d34e 100644 --- a/docs/_sass/components/_button.scss +++ b/docs/_sass/components/_button.scss @@ -28,12 +28,12 @@ &::before, &::after { - background-color: $white; + background-color: $gray-primary; content: " "; height: 100%; left: 98%; position: absolute; - top: 50%; + top: 36%; width: 2px; } diff --git a/docs/_sass/components/_sidebar-menu.scss b/docs/_sass/components/_sidebar-menu.scss index 439c9432..4f2de682 100644 --- a/docs/_sass/components/_sidebar-menu.scss +++ b/docs/_sass/components/_sidebar-menu.scss @@ -12,7 +12,7 @@ position: relative; .sub-menu { - background: $sidebar-active-color; + background: rgba(0,0,0,0.01); max-height: 0; transition: max-height 0.3s ease-in-out; overflow: hidden; @@ -26,8 +26,8 @@ height: auto; &.active { - color: $white; - box-shadow: 3px 0 $white inset; + color: $gray-primary; + box-shadow: 3px 0 $brand-primary inset; } } } @@ -42,8 +42,8 @@ padding: $base-point-grid * 2; line-height: $base-point-grid * 2; width: 100%; - color: $white; - @include links($white, $white, rgba($white, 0.8), $white); + color: $gray-primary; + @include links($gray-primary, $gray-primary, rgba($gray-primary, 0.8), $gray-primary); transition: background $base-duration $base-timing; &:hover { @@ -63,7 +63,7 @@ position: absolute; top: 0; left: 0; - border-left: 6px solid rgba($white, 0.8); + border-left: 6px solid rgba($gray-primary, 0.8); border-top: 6px solid transparent; border-bottom: 6px solid transparent; transition: border 0.3s ease, top 0.2s ease, left 0.2s ease; @@ -74,7 +74,7 @@ position: absolute; left: 0; top: 2px; - border-left: 4px solid $brand-primary; + border-left: 4px solid $white; border-top: 4px solid transparent; border-bottom: 4px solid transparent; transition: border 0.3s ease, top 0.3s ease, left 0.3s ease; @@ -82,19 +82,19 @@ &.active { > a, button { - box-shadow: 3px 0 $white inset; + box-shadow: 3px 0 $brand-primary inset; } } &.open { > a, button { - background: $sidebar-head-active-color; + background: rgba(0,0,0,0.03); } .caret::before { top: 4px; left: -6px; - border-top: 6px solid rgba($white, 0.8); + border-top: 6px solid rgba($gray-primary, 0.8); border-left: 6px solid transparent; border-right: 6px solid transparent; } @@ -102,7 +102,7 @@ .caret::after { left: -4px; top: 4px; - border-top: 4px solid $brand-primary; + border-top: 4px solid $white; border-left: 4px solid transparent; border-right: 4px solid transparent; } diff --git a/docs/_sass/components/_sidebar.scss b/docs/_sass/components/_sidebar.scss index 4d9699fb..f83b913e 100755 --- a/docs/_sass/components/_sidebar.scss +++ b/docs/_sass/components/_sidebar.scss @@ -4,7 +4,8 @@ #site-sidebar { position: fixed; - background-image: linear-gradient(to bottom, $brand-primary 60%, darken($brand-primary, 6%) 100%); + background-image: linear-gradient(to bottom, $white 60%, darken($white, 3%) 100%); + border-right: 1px solid rgba(0,0,0,0.1); width: 290px; height: 100%; left: 0; @@ -30,10 +31,11 @@ a { display: flex; - color: $white; + color: $gray-primary; justify-content: center; align-items: center; width: 100%; + transition: none; &:visited, &:hover, @@ -50,7 +52,7 @@ font-size: 1.5rem; z-index: 30; white-space: nowrap; - font-weight: 500; + font-weight: $font-semibold; } } } @@ -74,7 +76,7 @@ .sidebar-toggle { position: absolute; - right: 16px;; + right: 16px; padding: 24px 32px; display: block; opacity: 0.7; diff --git a/docs/_sass/utils/_variables.scss b/docs/_sass/utils/_variables.scss index d10fb997..cae27179 100755 --- a/docs/_sass/utils/_variables.scss +++ b/docs/_sass/utils/_variables.scss @@ -5,27 +5,26 @@ // ----------------------------------------------- // Typography // ----------------------------------------------- -@import url('https://fonts.googleapis.com/css?family=Fira+Mono:400,500,700&display=swap'); +@import url('https://fonts.googleapis.com/css?family=Fira+Code:400,500,700&display=swap'); @import url('https://fonts.googleapis.com/css?family=Montserrat:400,600,700&display=swap'); -// @import url('https://fonts.googleapis.com/css?family=Hind:400,500,600&display=swap'); // Colors // ----------------------------------------------- -$brand-primary: #66296a; -$brand-secondary: #001f39; -$gray-primary: #001f39; +$brand-primary: #9E358F; +$brand-secondary: #001E38; +$gray-primary: #001E38; $white: rgb(255, 255, 255); $link-color: darken($brand-primary, 10%); $link-hover: darken($brand-primary, 15%); -$sidebar-active-color: lighten($brand-primary, 2%); -$sidebar-head-active-color: lighten($brand-primary, 4%); +$sidebar-active-color: $white; +$sidebar-head-active-color: darken($white, 3%); // Typography // ----------------------------------------------- $base-font-family: 'Montserrat', sans-serif; -// $header-font-family: 'Hind', sans-serif; +$header-font-family: 'Montserrat', sans-serif; $header-font-family: $base-font-family; -$code-font-family: 'Fira Mono', monospace; +$code-font-family: 'Fira Code', monospace; //- $base-font-color: $gray-primary; $header-font-color: $base-font-color; diff --git a/docs/css/linuwial.css b/docs/css/linuwial.css index 8885d0d4..ea19a35a 100644 --- a/docs/css/linuwial.css +++ b/docs/css/linuwial.css @@ -14,7 +14,7 @@ html { body { background: #fefefe; - color: #111; + color: #001E38; text-align: left; min-height: 100vh; position: relative; diff --git a/docs/img/favicon.png b/docs/img/favicon.png index 74aa4b9f301875711ce055a38b45b94e4f28009b..d10c940f669630e6ad33ebb7895b3c91a2af3455 100644 GIT binary patch delta 2178 zcmV-|2z~eF6{r!AJ%0r3000E+0g7(@asU7T2XskIMF->o2@WYS9&abr000OzNklj6gfoidFj%70QMJ_C(%~5Ln0(kVp}MkbjWmKDK}424W^5xi|L} zn(sfE$vwO0?B{;ZIltd;cQ5p+SH0?0uK;juXS8cOW7BC&QksCd1Nb8_J2IxfNl5dC z7u|C$)nk)W(dn5o2Y|D7RfcOji-9`e(a6UhFx$hcb#3QIu6;Tq0`dRLL9Xpg25dm- zq-hA4?k~#UeScd!sKo)U?Tm75rwrKB1vo_7>~d{qr)xW-0o)zV?E|Rl=G3^;wVmZa zB``JOjIJsKJO~_jZD$1%0|8F&IC*6vn7vcd+{6+a|d!&P0yP^fmBd+Zn z2TJ1Hmjt}-+D@fwJC6dmyU+9-2f4O$53mB56XjHjMSlwLS752XDBnqYK(6h)1}shj znD#)e^%vzYN=rbl?JNPF2Zp2oPHRZ#f#3Lx^4FvVAlG�_%aVrVvbfpelg*{-S)5 z53+oxPQ3?jYA(CuE;)BA=R8DBrg~ae7dK) z>F~x+vJ{`^M0}_ z$A2vVR^vHPS(T|hdpYCZzy8o0F>`eN$XTO(8Mzs%7fOt!Bw3OI^?^XuwiAt~|5=eE z`xIGLRz}PwWH{CUUNOrI>*ncfIDVeH#@kmW=#hVAS>T0g`la$2P{M00@ z4_v=k=PQ48r*Gi+A$4Qs-0$l%C|B`9;i%73f1x&5`S#(an!V@xs#z+DhLaRPt-g6K z9ly|L_p*-|Hq~D{?(u>+?su#27gD+ z8r3jz)|jkNQ%LGyE%T~AI&uB<*2=7=+J?MjI3_IsNs2`9dO)q*ayaMQ$JGt@%_|^p z!~kD77{1|{EAFMhkxl!&+H+TOWkn_xa8d^7OY6#KwORiu-a+5t{p$*sO!Fa0l)qBe zbh+wMjwDIQDFV|SKudvD@g*g3^?%G4ee7SpA40+lHUx4cDIw+ZpCq&%WN9Y4Fp7a3 z;JtW53N;0lP-9R{0GxjSdAcxGSd&&qn@z8%Jbtn?vjmtAq^gh>1UATnPk()X!8@pR@*D7`t>~i~xQLTuK0#FMyxx!Wga#V`oXh$_{tl$lqK` zGmCX$cnO_imS(ne@I74^8-JrXZX+-+PH;Bs!uU=Uea~(QOLSo*&OvRo!P3lQmS)bn zm77|*?+IWW@L@Ol{1wlRpq%F_s!dM=~ zIbQ%?yv3I!CDTD|^^B#N=Pk`#+*!jCZBeM`#D95;wWn=?aO2EHpF9`$I~$f}zRS($tGgPiNU3&ETg~vvnb$1M zeEH^u6~~nOwF2`iOEa%V3nyJ2)Hb-As|#amjEUrLVNZgc?*CtX~ zla_$TfX6J&`~gs^3nLVnN-{9t^Sshj7nW4gL%)xN29qN-9RXye!@y$M#ij%25-^sG zNE~!1L2zn-842ITTJ0#m0F21Oo6fonyrK)^g`{lrZ6GPY24HTQ!g(taRs@n32Xz2y z4Dj1nESwQVH`_~TuhQUt_$N~;JcC1M5=Tacv2U}Lz2g_xLjKzMrmp0k7<6} zCz*O)7sj%5*u^@7gD#Afz%XE462PnnhU>yu)>&0EZ5-4F*aLtC6vX+|2Y{z^VU(v; zvf2$$-=z7)w|HodE{rYd8Ysq^MZY6S^Z}mj#%X>A@`u(~Zw2ucBAI>Q%3L)vFHmKjWSUi4DNrx&QzG07*qoM6N<$ Eg5($`wg3PC delta 2757 zcmV;$3OedTZ}o000VeNklri}!x-AXhGW&#bEfc2;Jv^W+qb3&mUgu1=~pzM z+NnOlfmZ>wgS@@XXz4Qrnjdag?<)$>#5x~QrT8k)`9NTJO44d#HVKZf+z6bKjP_Sp zGxM$b{y`6DLVu&v)jfR1crkD&P!PVpst_!^r(J&;_}Q9zpDMf>ct_H7Pi!@Hx9Q=7 z63}25j5H(PqF)XL&;u4w?b&|2LpK8-8qoYFN#}I7=Nn-|nVIJII)CyiiA>V;vmnrnjq8*@U;yQE z4mYQ11YZff7Kp%WLI(>w+Vu34DIU>tnD6XQ!q5x8u2;e5f83(Kma{CVZQv~1{{{S0 zvBkH=4(4oX)#Lj$pxQeBi{(|oJCmj#NNVbA(L<#tfY_^nn&kb*fPe0v$*cwC%4Sl| zqf#kmBY)2YMg!ZCmpxYHQpJqOmQIS$#IT%}=<)0@G|1RqbD{!eIjXRE$Z${}gR zR|}oDD~!yeyhpLWX!t;K>`#M0P36j_cBSpr+0rmAs;q zkOkiXT~bQOi5#1OcO{)}09}ST?ZsuYn^@!^^N7CzoMC*`xI(aKbCo+WC&ki-yIXWu zIe%A|dMRioH~0gAz1rse$%X&OXhyy*xG%Yr@4#*be=s@Zmy%|dru32=jr-+j>C&zi z-I2V$uXd`x+AkYx;piTpS5xP?U2Uuf`NaV#rat-w=nTOze;mQ_ig_JCO7sk?#3r5V z*QcU*DOLj@nJ0|q<=bchdBC*(ndBxsV}Gao%>C!OuLgrR>9R1fItr{R;D*wLZBAqO-*=c>a}%$7Vq zIq43`D@F#vHFw{lzh$#d^^K!Z@|D1AfIi7<(qXW0!_E40vRgk#_?kqHG4?Hl!GHYx zI{mR6+0^`+Pb%;d%#lD0Jf6&c0KJkLJ6rU%ftz3gFE+ecxZ8zbLB3sEhWrW2<~$~< z@;#V|N!q(Tv}Sj#*KdN_eAk6?q0FN5q zCsYS)@0G@tn}mlf2Sw?4G1f$&hksa8^XqkIDUSs9a@!vpERXDzqX(7a-VD0?COr$x z&D6zjL!6E^ud6NidZs=;26$gO;_bkX_bDJ*XIlW8pI@&#v(r5?dOltVo@Fs&*F2J) z?vZ`ZbBX#qA5;zOFkU_?6)e5`7X58#_5uDM(CNtYYwM%;8BPESBdU0GsDG9(WdpJ} z3LrG=0ixdcdZg(|9{Cz!Fuya&Bbf%D8TERZ#L+L5WANLdT$J_|f)%N>&jKbGO#qBE zubA)lF`!bu+WFO|{tZCV#htCe7XfOf`Q3`V3Ok#C`ME1w z)Dbg|fDQQ;br0n^UdlQs4S(QXZc7$>^BnssLMSrVY6gOq3dt?Pr z5@B5YZ$=#WmLe(5iF*C3OoPvSr32~%C`5b&psOXEkChcX2po;wo~e&JYNq+!!+8M{ z8lBG6`;6K;Uzn})+g?sUhN9;=dAR|=_KlhPXk~V~U!8B$#v=+k(da^83vjYxKTy*U z-H^%o@Sz_32hVYJb$^dHfxl__hDd%WQ|Aj_9zf!$)_f2}Xt0lZBLMH+nfy0Hr{8ZZaXX<=%$69U6w}!LgK!5K9z6ZP-ymEApADZ0Y zDMK@SPbmJ;W%<_dJm7v{)Q*rLlUmshvzmGzCY%Sx1Ciygs5iKxWM|7X_)P3&P_(=V z+JjhgN)EKi4W1%6l=G-`noEr5QS>lwH(oJ1ESjb!G&()H zhtGl+7M~~z;4g$#!IkBj9WwPk1H2q~YtpopqDeeSiMq6_O)L9v?Abn6VZ6ZB(Sf`v z8W~)jIMjw7P$?!)^Kn7!mB5FS?ESx%W|h3hgSlXl=6`m!(h71W=fhnUe_qxF6ip9X zj24V5@Zat2gWF{$*Li$UENwV7X?obGDJsw%rkJXLBQYBWdLFY4enVtGl-!I`bmxy% zZMl^}FUd&0JJ}3o+zg}{8(Z`f7+|;(*<>&e+G@(TX=CXelX4!LDn7LrQFNnh1${1j zk{fns<$ul8c_H#*%(oq?S+UmwZwjoFHn!>BVFy%Nhx}vN^gHpd0md^3&g}FTp zH9v|ujbZ`a*y6g&H}n;P&y|~BY8s+jWu0YfL020~GWGr;a5AwzQZk_qJD~o%wHw)F za~{)I6<;oECPnM+v$B@_o#}I@2YX=bQ3+=D9Dg4lMQ$D-#|U_WV#(B>jgIMR)ie7P zQ2$-qjcodD!=hvxe$3MBt`^;qo#wYjk#8&=3p@(CG~cRkm2>V>&h=}a?~50!xKK?2 zTaE7!ss~2NJOMhlvrRu3)+All6E&D@1{lu=sV92?IKK3BAzd|QE303uG~oqLOxCIB zD1R<`F*#1kc~p8NM|Qr2$M>{sb66`52a(MVZn-O}%KEKg_VW5uZrL`g>b*%a!9n0cgPbDVwaH2KxqbyYO{;x<1i7 zr~pCnhX|fZaX~CMCHuP`*|){%U~#z>&##!6l=G+xg-TT7ppX9tCJAgR2jV|c00000 LNkvXXu0mjf4qrl6 diff --git a/docs/img/header-image.svg b/docs/img/header-image.svg deleted file mode 100644 index 6f26dc15..00000000 --- a/docs/img/header-image.svg +++ /dev/null @@ -1,99 +0,0 @@ - - - - header-image - Created with Sketch. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/docs/img/main-feature-primary.svg b/docs/img/main-feature-primary.svg deleted file mode 100644 index 8f7a7569..00000000 --- a/docs/img/main-feature-primary.svg +++ /dev/null @@ -1,75 +0,0 @@ - - - - feature-primary - Created with Sketch. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/docs/img/main-feature-secondary.svg b/docs/img/main-feature-secondary.svg deleted file mode 100644 index f73063d5..00000000 --- a/docs/img/main-feature-secondary.svg +++ /dev/null @@ -1,110 +0,0 @@ - - - - main-feature-secondary - Created with Sketch. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/docs/img/main-feature-tertiary.svg b/docs/img/main-feature-tertiary.svg deleted file mode 100644 index 176fbd4b..00000000 --- a/docs/img/main-feature-tertiary.svg +++ /dev/null @@ -1,55 +0,0 @@ - - - - main-feature-tertiary - Created with Sketch. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - \ No newline at end of file diff --git a/docs/img/nav-brand-white.svg b/docs/img/nav-brand-white.svg index 99bbd853..31f795ef 100644 --- a/docs/img/nav-brand-white.svg +++ b/docs/img/nav-brand-white.svg @@ -1,9 +1,104 @@ - - - - nav-brand - Created with Sketch. - - + + + + + + image/svg+xml + + sidebar-mu-haskell + + + + + + sidebar-mu-haskell + Created with Sketch. + + + + + + + + + + + + + + + diff --git a/docs/img/nav-brand.svg b/docs/img/nav-brand.svg index 4230051b..31f795ef 100644 --- a/docs/img/nav-brand.svg +++ b/docs/img/nav-brand.svg @@ -1,9 +1,104 @@ - - - - nav-brand - Created with Sketch. - - + + + + + + image/svg+xml + + sidebar-mu-haskell + + + + + + sidebar-mu-haskell + Created with Sketch. + + + + + + + + + + + + + + - \ No newline at end of file + + diff --git a/docs/img/nav-icon-close.svg b/docs/img/nav-icon-close.svg index 076619eb..cf9304ef 100644 --- a/docs/img/nav-icon-close.svg +++ b/docs/img/nav-icon-close.svg @@ -1,12 +1,10 @@ - nav-icon-close - Created with Sketch. - \ No newline at end of file + diff --git a/docs/img/nav-icon-open.svg b/docs/img/nav-icon-open.svg index c4cd84d6..d7d37cf2 100644 --- a/docs/img/nav-icon-open.svg +++ b/docs/img/nav-icon-open.svg @@ -1,13 +1,11 @@ - nav-icon-open - Created with Sketch. - + - \ No newline at end of file + diff --git a/docs/img/sidebar-icon-open.svg b/docs/img/sidebar-icon-open.svg index 3df658e8..9593a4c6 100644 --- a/docs/img/sidebar-icon-open.svg +++ b/docs/img/sidebar-icon-open.svg @@ -1,11 +1,9 @@ - sidebar-icon-open - Created with Sketch. - - - + + + - \ No newline at end of file + From fbdcffd646f5f69d81a1a6688e7cf43cb897a3ea Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 13 Jan 2020 10:05:23 +0100 Subject: [PATCH 041/217] Prepare for 0.1 (#71) --- .gitignore | 2 +- cabal.project | 10 ++++++++++ compendium-client/compendium-client.cabal | 17 ++++++++++------- core/schema/mu-schema.cabal | 16 +++++++++------- 4 files changed, 30 insertions(+), 15 deletions(-) create mode 100644 cabal.project diff --git a/.gitignore b/.gitignore index ed52919f..69b41819 100644 --- a/.gitignore +++ b/.gitignore @@ -1,7 +1,7 @@ stack*.yaml.lock .stack-work *~ -dist +dist* *.pyc ## User files diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000..7f27ab2f --- /dev/null +++ b/cabal.project @@ -0,0 +1,10 @@ +packages: compendium-client/ + core/schema/ + core/rpc/ + adapter/avro/ + adapter/protobuf/ + adapter/persistent/ + grpc/client/ + grpc/server/ + +extra-packages: network==3.1.0.1 diff --git a/compendium-client/compendium-client.cabal b/compendium-client/compendium-client.cabal index 05e86194..75cfde6f 100644 --- a/compendium-client/compendium-client.cabal +++ b/compendium-client/compendium-client.cabal @@ -1,18 +1,21 @@ cabal-version: >=1.10 - name: compendium-client -version: 0.1.0.0 -synopsis: Client for the compendium schema server --- description: --- bug-reports: +version: 0.1.0.1 +synopsis: Client for the Compendium schema server +description: Client for the schema server license: Apache-2.0 license-file: LICENSE author: Alejandro Serrano maintainer: alejandro.serrano@47deg.com --- copyright: +copyright: Copyright © 2019-2020 category: Network build-type: Simple --- extra-source-files: README.md, CHANGELOG.md +homepage: https://higherkindness.io/mu-haskell/ +bug-reports: https://github.com/higherkindness/mu-haskell/issues + +source-repository head + type: git + location: https://github.com/higherkindness/mu-haskell library exposed-modules: Compendium.Client diff --git a/core/schema/mu-schema.cabal b/core/schema/mu-schema.cabal index 112d516f..0d2874c2 100644 --- a/core/schema/mu-schema.cabal +++ b/core/schema/mu-schema.cabal @@ -1,21 +1,23 @@ cabal-version: >=1.10 --- Initial package description 'mu-haskell.cabal' generated by 'cabal --- init'. For further documentation, see --- http://haskell.org/cabal/users-guide/ - name: mu-schema version: 0.1.0.0 synopsis: Format-independent schemas for serialization --- description: +description: With @mu-schema@ you can describe schemas using type-level constructs, and derive serializers from those. See @mu-avro@, @mu-protobuf@ for the actual adapters. -- bug-reports: license: Apache-2.0 license-file: LICENSE -author: Alejandro Serrano +author: Alejandro Serrano, Flavio Corpa maintainer: alejandro.serrano@47deg.com --- copyright: +copyright: Copyright © 2019-2020 category: Network build-type: Simple extra-source-files: CHANGELOG.md +homepage: https://higherkindness.io/mu-haskell/ +bug-reports: https://github.com/higherkindness/mu-haskell/issues + +source-repository head + type: git + location: https://github.com/higherkindness/mu-haskell library exposed-modules: Mu.Schema From 2b4bc601c814cc2146db43fdc8e58e6d2f60f973 Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Mon, 13 Jan 2020 11:05:25 +0100 Subject: [PATCH 042/217] =?UTF-8?q?Fill=20all=20cabal=20files=20for=20Hack?= =?UTF-8?q?age!=20=F0=9F=9A=80=20(#72)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- CODEOWNERS | 1 + adapter/avro/mu-avro.cabal | 13 +++-- adapter/persistent/mu-persistent.cabal | 9 ++- adapter/protobuf/mu-protobuf.cabal | 18 +++--- compendium-client/compendium-client.cabal | 2 - core/rpc/mu-rpc.cabal | 31 ++++++----- core/schema/mu-schema.cabal | 1 - grpc/client/mu-grpc-client.cabal | 46 ++++++++++------ grpc/server/mu-grpc-server.cabal | 67 +++++++++++++++-------- 9 files changed, 119 insertions(+), 69 deletions(-) create mode 100644 CODEOWNERS diff --git a/CODEOWNERS b/CODEOWNERS new file mode 100644 index 00000000..94314b03 --- /dev/null +++ b/CODEOWNERS @@ -0,0 +1 @@ +* @serras @kutyel diff --git a/adapter/avro/mu-avro.cabal b/adapter/avro/mu-avro.cabal index c22d516d..2eafedba 100644 --- a/adapter/avro/mu-avro.cabal +++ b/adapter/avro/mu-avro.cabal @@ -2,23 +2,26 @@ cabal-version: >=1.10 name: mu-avro version: 0.1.0.0 synopsis: Avro serialization support for Mu microservices --- description: --- bug-reports: +description: You can use @mu-avro@ to read AVRO Schema Declarations for mu-haskell license: Apache-2.0 license-file: LICENSE author: Alejandro Serrano, Flavio Corpa maintainer: alejandro.serrano@47deg.com --- copyright: +copyright: Copyright © 2019-2020 category: Network build-type: Simple data-files: test/avro/*.avsc +homepage: https://higherkindness.io/mu-haskell/ +bug-reports: https://github.com/higherkindness/mu-haskell/issues + +source-repository head + type: git + location: https://github.com/higherkindness/mu-haskell library exposed-modules: Mu.Adapter.Avro , Mu.Quasi.Avro , Mu.Quasi.Avro.Example - -- other-modules: - -- other-extensions: build-depends: base >=4.12 && <5 , mu-schema , avro diff --git a/adapter/persistent/mu-persistent.cabal b/adapter/persistent/mu-persistent.cabal index 000436d7..b1c19aa8 100644 --- a/adapter/persistent/mu-persistent.cabal +++ b/adapter/persistent/mu-persistent.cabal @@ -1,17 +1,22 @@ name: mu-persistent version: 0.1.0.0 synopsis: Utilities for interoperation between Mu and Persistent --- description: +description: Please see the . homepage: https://github.com/higherkindness/mu-haskell/persistent#readme license: Apache-2.0 license-file: LICENSE author: Flavio Corpa, Alejandro Serrano maintainer: flavio.corpa@47deg.com -copyright: Copyright © 2019-2020 47 Degrees. +copyright: Copyright © 2019-2020 category: Network build-type: Simple cabal-version: >=1.10 extra-source-files: README.md +bug-reports: https://github.com/higherkindness/mu-haskell/issues + +source-repository head + type: git + location: https://github.com/higherkindness/mu-haskell library exposed-modules: Mu.Adapter.Persistent diff --git a/adapter/protobuf/mu-protobuf.cabal b/adapter/protobuf/mu-protobuf.cabal index 6a5ec04c..2cf12581 100644 --- a/adapter/protobuf/mu-protobuf.cabal +++ b/adapter/protobuf/mu-protobuf.cabal @@ -2,16 +2,21 @@ cabal-version: >=1.10 name: mu-protobuf version: 0.1.0.0 synopsis: Protocol Buffers serialization and gRPC schema import for Mu microservices --- description: --- bug-reports: +description: You can use @mu-protobuf@ to read Protobuf Schema Declarations and services for mu-haskell license: Apache-2.0 license-file: LICENSE -author: Alejandro Serrano +author: Alejandro Serrano, Flavio Corpa maintainer: alejandro.serrano@47deg.com --- copyright: +copyright: Copyright © 2019-2020 category: Network build-type: Simple data-files: test/protobuf/*.proto +homepage: https://higherkindness.io/mu-haskell/ +bug-reports: https://github.com/higherkindness/mu-haskell/issues + +source-repository head + type: git + location: https://github.com/higherkindness/mu-haskell library exposed-modules: Mu.Adapter.ProtoBuf @@ -19,8 +24,6 @@ library , Mu.Quasi.ProtoBuf , Mu.Quasi.GRpc , Mu.Quasi.ProtoBuf.Example - -- other-modules: - -- other-extensions: build-depends: base >=4.12 && <5 , mu-schema , mu-rpc @@ -49,4 +52,5 @@ executable test-protobuf , proto3-wire hs-source-dirs: test default-language: Haskell2010 - ghc-options: -Wall -fprint-explicit-foralls + ghc-options: -Wall + -fprint-explicit-foralls diff --git a/compendium-client/compendium-client.cabal b/compendium-client/compendium-client.cabal index 75cfde6f..65716c2a 100644 --- a/compendium-client/compendium-client.cabal +++ b/compendium-client/compendium-client.cabal @@ -19,8 +19,6 @@ source-repository head library exposed-modules: Compendium.Client - -- other-modules: - -- other-extensions: build-depends: base >=4.12 && <5 , aeson , text diff --git a/core/rpc/mu-rpc.cabal b/core/rpc/mu-rpc.cabal index 62891ecb..1117a944 100644 --- a/core/rpc/mu-rpc.cabal +++ b/core/rpc/mu-rpc.cabal @@ -1,30 +1,35 @@ cabal-version: >=1.10 --- Initial package description 'mu-haskell.cabal' generated by 'cabal --- init'. For further documentation, see --- http://haskell.org/cabal/users-guide/ - name: mu-rpc version: 0.1.0.0 synopsis: Protocol-independent declaration of services and servers --- description: --- bug-reports: +description: Protocol-independent declaration of services and servers for mu-haskell license: Apache-2.0 license-file: LICENSE -author: Alejandro Serrano +author: Alejandro Serrano, Flavio Corpa maintainer: alejandro.serrano@47deg.com --- copyright: +copyright: Copyright © 2019-2020 category: Network build-type: Simple extra-source-files: CHANGELOG.md +homepage: https://higherkindness.io/mu-haskell/ +bug-reports: https://github.com/higherkindness/mu-haskell/issues + +source-repository head + type: git + location: https://github.com/higherkindness/mu-haskell library exposed-modules: Mu.Rpc, Mu.Server, Mu.Rpc.Examples - -- other-modules: - -- other-extensions: - build-depends: base >=4.12 && <5, mtl, sop-core, - mu-schema, conduit, text, template-haskell + build-depends: base >=4.12 && <5 + , conduit + , mtl + , mu-schema + , sop-core + , template-haskell + , text hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall -fprint-potential-instances + ghc-options: -Wall + -fprint-potential-instances diff --git a/core/schema/mu-schema.cabal b/core/schema/mu-schema.cabal index 0d2874c2..46fafb71 100644 --- a/core/schema/mu-schema.cabal +++ b/core/schema/mu-schema.cabal @@ -3,7 +3,6 @@ name: mu-schema version: 0.1.0.0 synopsis: Format-independent schemas for serialization description: With @mu-schema@ you can describe schemas using type-level constructs, and derive serializers from those. See @mu-avro@, @mu-protobuf@ for the actual adapters. --- bug-reports: license: Apache-2.0 license-file: LICENSE author: Alejandro Serrano, Flavio Corpa diff --git a/grpc/client/mu-grpc-client.cabal b/grpc/client/mu-grpc-client.cabal index 7a08b0d4..10acbd24 100644 --- a/grpc/client/mu-grpc-client.cabal +++ b/grpc/client/mu-grpc-client.cabal @@ -1,35 +1,47 @@ cabal-version: >=1.10 --- Initial package description 'mu-haskell.cabal' generated by 'cabal --- init'. For further documentation, see --- http://haskell.org/cabal/users-guide/ - name: mu-grpc-client version: 0.1.0.0 synopsis: gRPC clients from Mu definitions --- description: --- bug-reports: +description: With @mu-grpc-client@ you can easily build gRPC clients for mu-haskell! license: Apache-2.0 license-file: LICENSE -author: Alejandro Serrano +author: Alejandro Serrano, Flavio Corpa maintainer: alejandro.serrano@47deg.com --- copyright: +copyright: Copyright © 2019-2020 category: Network build-type: Simple extra-source-files: CHANGELOG.md +homepage: https://higherkindness.io/mu-haskell/ +bug-reports: https://github.com/higherkindness/mu-haskell/issues + +source-repository head + type: git + location: https://github.com/higherkindness/mu-haskell library exposed-modules: Mu.GRpc.Client.TyApps, Mu.GRpc.Client.Record, Mu.GRpc.Client.Examples other-modules: Mu.GRpc.Client.Internal - -- other-extensions: - build-depends: base >=4.12 && <5, sop-core, - bytestring, async, text, - mu-schema, mu-rpc, mu-protobuf, - http2, http2-client, http2-client-grpc, - http2-grpc-proto3-wire, - conduit, stm, stm-chans, stm-conduit, - template-haskell >= 2.12, th-abstraction + build-depends: base >=4.12 && <5 + , async + , bytestring + , conduit + , http2 + , http2-client + , http2-client-grpc + , http2-grpc-proto3-wire + , mu-protobuf + , mu-rpc + , mu-schema + , sop-core + , stm + , stm-chans + , stm-conduit + , template-haskell >= 2.12 + , text + , th-abstraction hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall -fprint-potential-instances \ No newline at end of file + ghc-options: -Wall + -fprint-potential-instances diff --git a/grpc/server/mu-grpc-server.cabal b/grpc/server/mu-grpc-server.cabal index 3481061b..ed29bf77 100644 --- a/grpc/server/mu-grpc-server.cabal +++ b/grpc/server/mu-grpc-server.cabal @@ -1,44 +1,67 @@ cabal-version: >=1.10 --- Initial package description 'mu-haskell.cabal' generated by 'cabal --- init'. For further documentation, see --- http://haskell.org/cabal/users-guide/ - name: mu-grpc-server version: 0.1.0.0 synopsis: gRPC servers for Mu definitions --- description: --- bug-reports: +description: With @mu-grpc-server@ you can easily build gRPC servers for mu-haskell! license: Apache-2.0 license-file: LICENSE -author: Alejandro Serrano +author: Alejandro Serrano, Flavio Corpa maintainer: alejandro.serrano@47deg.com --- copyright: +copyright: Copyright © 2019-2020 category: Network build-type: Simple extra-source-files: CHANGELOG.md +homepage: https://higherkindness.io/mu-haskell/ +bug-reports: https://github.com/higherkindness/mu-haskell/issues + +source-repository head + type: git + location: https://github.com/higherkindness/mu-haskell library exposed-modules: Mu.GRpc.Server - -- other-extensions: - build-depends: base >=4.12 && <5, sop-core, - bytestring, async, mtl, - mu-schema, mu-rpc, mu-protobuf, - warp, warp-grpc, wai, warp-tls, - http2-grpc-types, http2-grpc-proto3-wire, - conduit, stm, stm-conduit + build-depends: base >=4.12 && <5 + , async + , bytestring + , conduit + , http2-grpc-proto3-wire + , http2-grpc-types + , mtl + , mu-protobuf + , mu-rpc + , mu-schema + , sop-core + , stm + , stm-conduit + , wai + , warp + , warp-grpc + , warp-tls hs-source-dirs: src default-language: Haskell2010 - ghc-options: -Wall -fprint-potential-instances + ghc-options: -Wall + -fprint-potential-instances executable grpc-example-server main-is: ExampleServer.hs other-modules: Mu.GRpc.Server - build-depends: base >=4.12 && <5, sop-core, - bytestring, async, mtl, - mu-schema, mu-rpc, mu-protobuf, - warp, warp-grpc, wai, warp-tls, - http2-grpc-types, http2-grpc-proto3-wire, - conduit, stm, stm-conduit + build-depends: base >=4.12 && <5 + , async + , bytestring + , conduit + , http2-grpc-proto3-wire + , http2-grpc-types + , mtl + , mu-protobuf + , mu-rpc + , mu-schema + , sop-core + , stm + , stm-conduit + , wai + , warp + , warp-grpc + , warp-tls hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall From 65d2fb9f0681a9f6fbe6f5f37da914fd3e797dbd Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Mon, 13 Jan 2020 12:40:28 +0100 Subject: [PATCH 043/217] Fix intro docs and project file (#74) --- cabal.project | 2 -- docs/docs/intro.md | 4 ++-- templates/grpc-server.hsfiles | 21 ++++++++++++--------- 3 files changed, 14 insertions(+), 13 deletions(-) diff --git a/cabal.project b/cabal.project index 7f27ab2f..599b33af 100644 --- a/cabal.project +++ b/cabal.project @@ -6,5 +6,3 @@ packages: compendium-client/ adapter/persistent/ grpc/client/ grpc/server/ - -extra-packages: network==3.1.0.1 diff --git a/docs/docs/intro.md b/docs/docs/intro.md index dfff2858..186f0add 100644 --- a/docs/docs/intro.md +++ b/docs/docs/intro.md @@ -21,7 +21,7 @@ The main goal of Mu-Haskell is to make you focus on your domain logic, instead o ### Super-quick summary -1. Create a new project with `stack new my-project url-to-hsfile`. +1. Create a new project with `stack new`. 2. Define your schema and your services in the `.proto` file. 3. Write your Haskell data types in `src/Schema.hs`. 4. Implement the server in `src/Main.hs`. @@ -42,7 +42,7 @@ message HelloReply { string message = 1; } To get started with the project, we provide a [Stack](https://docs.haskellstack.org) template (in fact, we recommend that you use Stack as your build tool, although Cabal should also work perfectly fine). You should run: ``` -stack new my-project url-to-hsfile +stack new my-project https://raw.githubusercontent.com/higherkindness/mu-haskell/master/templates/grpc-server.hsfiles -p "author-email:your@email.com" -p "author-name:Your name" ``` This command creates a new folder called `my-project`, with a few files. The most important from those are the `.proto` file, in which you shall declare your service; `src/Schema.hs`, which loads the service definition at compile-time; and `src/Main.hs`, which contains the code of the server. diff --git a/templates/grpc-server.hsfiles b/templates/grpc-server.hsfiles index fac5bab4..59a49327 100644 --- a/templates/grpc-server.hsfiles +++ b/templates/grpc-server.hsfiles @@ -25,19 +25,21 @@ executable {{name}} mu-grpc-server {-# START_FILE stack.yaml #-} -resolver: lts-14.16 +resolver: lts-14.20 +allow-newer: true extra-deps: # mu -- mu-schema-0.1 -- mu-rpc-0.1 -- mu-protobuf-0.1 -- mu-grpc-server-0.1 +- mu-schema-0.1.0.0 +- mu-rpc-0.1.0.0 +- mu-protobuf-0.1.0.0 +- mu-grpc-server-0.1.0.0 +- compendium-client-0.1.0.1 # dependencies of mu - http2-client-0.9.0.0 - http2-grpc-types-0.5.0.0 - http2-grpc-proto3-wire-0.1.0.0 - warp-grpc-0.2.0.0 -- proto3-wire-1.0.0 +- proto3-wire-1.1.0 - language-protobuf-1.0 {-# START_FILE Setup.hs #-} @@ -83,15 +85,16 @@ import GHC.Generics import Mu.Quasi.GRpc import Mu.Schema -grpc "Schema" id "{{name}}.proto" +grpc "TheSchema" id "{{name}}.proto" -- data Message -- = Message { ... } -- deriving ( Eq, Show, Generic - , ToSchema Maybe Schema "Message" - , FromSchema Maybe Schema "Message" ) +-- , ToSchema Maybe TheSchema "Message" +-- , FromSchema Maybe TheSchema "Message" ) {-# START_FILE src/Main.hs #-} +{-# language FlexibleContexts #-} {-# language PartialTypeSignatures #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Main where From 65e93f2184023d25c6e3a294e66f0ef843e20e91 Mon Sep 17 00:00:00 2001 From: Juan Valencia Date: Mon, 13 Jan 2020 13:14:40 +0100 Subject: [PATCH 044/217] Add some website additional meta information (#75) Co-authored-by: Flavio Corpa --- docs/_config.yml | 2 +- docs/_includes/_head-docs.html | 4 ++-- docs/img/poster.png | Bin 0 -> 43878 bytes 3 files changed, 3 insertions(+), 3 deletions(-) create mode 100644 docs/img/poster.png diff --git a/docs/_config.yml b/docs/_config.yml index 9ab32fb7..17926bce 100755 --- a/docs/_config.yml +++ b/docs/_config.yml @@ -2,7 +2,7 @@ title: Mu-Haskell #------------------------- name: Mu-Haskell #------------------------- -description: Lorem ipusm +description: Mu is a purely functional library for building microservices. #------------------------- author: 47 Degrees keywords: functional-programming, monads, monad-transformers, functional-data-structure, swift, bow, fp-types, adt, free-monads, tagless-final, mtl, for-comprehension, category-theory diff --git a/docs/_includes/_head-docs.html b/docs/_includes/_head-docs.html index 8798d6f4..27486b1d 100644 --- a/docs/_includes/_head-docs.html +++ b/docs/_includes/_head-docs.html @@ -5,7 +5,7 @@ - + @@ -17,7 +17,7 @@ - + diff --git a/docs/img/poster.png b/docs/img/poster.png new file mode 100644 index 0000000000000000000000000000000000000000..fee584e408b4f170e9ae6eec990333cf8ae7422e GIT binary patch literal 43878 zcmZ6z2Rzm9`#*k!V{`1yaR^DWLiXVp$t;BIO|r6g=0Rpjb_gL^3E7(@du7kamOcMB zeLmmc_xpdO$NTZ{?!3l*U-xxAujli5op5zk1tNSpd>tA#1^M`S2Qm~}S;K*2M%Msrh-K5jT&t#pJ z!WcKOH7$Lm)FP-fq|eukk}e%CVls;QZRz3srSjPrVJ#TNquuQufzH*hWLRR_+HMN9 zvkI!ToScX*|Nc#ii!}!4=({K^Ec7@Sx8m46ubg=Pu^><>Cqk1eM3W0UtfeWM52;r~ zMIk4j-5(6cRb(S88MiY#uA~cnXTx-fytlGMU+oMBFg)4b8fQwg_-vP$Fo%zQFSfsC1>n>O?>LRKY2Zr zIWv00LPF#O>4-QZ0+rb@H7H0U+uHwlY4Rkpbn`P1<18;PA2o*3NLxDxh81vG3nnY( z4Zh1T3YfCDYFQ7OvJd;bW`{lmA5!P0$}HeQX_yD~?O?^2lTqI_G~b3p8i$4`-oAaS zUOWn}$Di~=N1P&mbZu;EO0HohjO_s$g*YogV+4P4;FT~a7LHZT;}aI{oo#|RFIrk! zmekirTMK@-@a^cdEN@zJ=JSBn-G<@L{zww|sL9pmdfs~Spl~>ldn;?$HfHG+VbWf5 zuLOMI*^3wCUFKwSjvn(t;GsVb{{auJ$o`s;DU9aK&dzRjzAe)36-jKDxq6XyX>IL~ z_V;mEF`A-1vq-ZUD@r-}3cZE8#ApU9>2@9dq+srDbqee(PE~!FP343-1#N{MBUr!k z@)xy7jPcz|GR322vf@at1ettInM`$QaVD#vzD%eSt(IKAzC2e_YX|}Ltjq4m!-c}p zHJ0oGPKwB_1KrJsS=k-5v3yoE(C@(1Cei5Qvy&{$bC6*-R-Ff%mX}{Cw z#DNEy<94RtoqqRbSUv53=~`p(F(U9$^(%A4OYqQsD6^uOE!LDScuF@5Rg?^@EnJ7{ z0U`WLFMQrn1RjBq$&AgJUN8=q$$2ElpR~yLhPCYL*U;+f`$y+~Lha=1o9oh}uBqus zCT6f89NqZOYn{LUs%ueZs>8B4n-+FTOu+sy5hHRQ;T06ac|I@ zF;mDP^9I`|C&lT5BzZm9=AAxZzibL>H_UnTlDoTPV&h$Uy5$`bQ%GhW0U{!+aewo@ z^JEZiB4_F+AITW`?CA0F`$FxKd#ApiK7Tf~u?g=UK{o{{-%adhN$f7YzHdKP91`PR zVmCGjXhLYmL1@pclk=Z_Q8za?9f=D_**JH>Fc*l+F&e@TvF`3+O{@v3FS2=(z-EG= zR;ZZ@o!PRwLn5l7z<=^gD8*VR1sp`X{?|(JLiF=HM%0%!+0lDm5+5V@Yfb)Q z<-T6}d)#MVIS#{#Rc4RtvD7FWZs!>r-1)xb3|>jZ|3W+nCrK%9uxWXj9Sa%I``ZkX z`I@nk$rAcua8>%PJNWmdB_)mbg3Zjgmic2kz*&qr|2yveRwRQWI&p2Z*v!c(j-Ht0 zy*ej6qjzC_yxi^;-pJNr^^+*&{BgVa&8eDgFNuFA6g=#wVmXfad?wi~->fvH99{u| zZi3yao81xuh!7bJ_pND(ukbQqk5)52$y*GvFB>W7qM(?a7_AFCbC0+S8DFZLc6c); z`P!9~l%PR^(R~Zvhz0k?{EmnfYQ^Jp9%(6kaxMw>U0*WBgByyZsD9JVM%W^qsUA>J zz)FCqGb9;Th91jc?C22MAdROzBxDsqjB9!;M~H9!yGp!?^jLP ze@#z{&+Q3CAzpfjOQw?Uc-6tM=K7GRK|ym(N^tv9>o?~uSh=~mvE55!FdT}=Hh4Gx zuMMGE!@KmsXw{)<%3A|C!7+#AxLA(MKWH@zwK~gQT_-|MQK~dM2<j@=!y>sldvhUR=7*+lb$GCDLPMIyX+ftV? z4XyfP`qV+3N^EbACsQ34{46;iXTqD8as|tFR!;9U(YeUv4dOkBuWFji0_!K45mrzD zvim7MA~}~Ou?GPTHC?zgOb$vy{_VwYq2@VUum|)D5U)C>k&zLPWO`CYF|aIM=CM7N zBtDnElVqO`>8T0-L{?92lHYF)W#a=alBZ_;En~8g(Q&tWwSM`Lbmcs>U^o0ViJcJ!&k;O`@s$t6d-5_r73bS z?_y3lK*mqSaJ&_KCGVm%O!>4$`CB^Ni?j*KY9qA^iLNV26{$^p{KuY9bN>7K$*#YD zG9H~vqO-7KI)dzkBEgR$+pB~GN+<~dZdeOg=1`OE8b9eSbNot&8F|q(%ZVhcnBJS^ z(3qyU6T@QahYufiP~Ct&{AyN8vwJKqBrKdEdIqb@^QY{ll+`fTEWC#s*eH;R*BC?0 z1X6aW37i6dekgyCkcp}sWW4e5am=mDOdMC_nV-~QTU2$E-mzapudkRnSCECeLIuUe zdjWV1SUV>9&=!`@f$v+eW1skK7sM&C$0_9d8Bay49c6B}3+jPGJ|u4WJt5=y7hv#yn6C4KYo zCKSe>qY#8c(giPHaS^3iZ&JBN3cO29`ib2kg8~AI1UD$;+V|H+TyNdJPz_YR zpOr?+Ro0J9c^@lQW(?A zzMFM(j85lx<(tQ2n3IX?ZTOg&%ylMC5C(Qm=jehe83^C4btFf3EO1in62i@sXPrPI zF?`x7?t3_85m;(X0qS-K8^guI-{X?1s$c*TK{o9&*RisfIrW#rS~jJipr8{%K+w z)GInrhlR^$ud`8YU5?vPB`HJW6lp*b^alY~@>C7|YU^h#A_3(&7| zBg*0=b})_^VMWj#dT+n?s-D;gWqV-e`faufD;D`Qp?k?B$NjoUkB4*fLbWKc!9kB_ z^PQD6<7q0>*>It$?zvg})?v$rTec<_3sqz(a%HU8 z4Dy~6-%f}ggeMl#n1=oF*s12_-s&K3h>YDE665l5Sd=_zI11p@(z-gL;!y$(3Qx9L zyo7Fx&N9NVmY3Dl)xHvE%Y^7Ihq0i%J3NWqnrbi|LAzRqtcC61SL`juX^uiE0Je5~ z|Bmls5XRjN!aSA@uiyF&GPr#Jyjre}Swpc&s--lOa5^o+TY-B^R&i#pKWZ0Vr#6rQ zFz@7FMt*MvMxkEI}R61!)FESrYLRDFP;a_oDl~xei7eTZnpr1j)*e&sH z1mVWH26h-fKU@gx@Wbq!hL;_FptRS^(U^(UltX6fp!nmY^R3gucaS1Cotz$w28C8O zRS*6Ssw0Kekz)HfG`0>IoT6=`$y8*>gU(vbs7<*aK;}n8M_=F6jG@m2tnKJru9m3cHfMrTtc9o1 za0;z-`(a(uhR&kX>LtLB0F;9jiqDPNz@T&APL0(og34+1t?j3u5H3AfcCP02{X_9+ zRS>|#ii&&0LMyG+Q}!-35<;zb&Z23txp{HQIiaIauy=>v#=IY=#l^(Be<`ppAD)(e z`69?om|wuvp{<6?*8B8(fksX6* zCS<@u_EmocOMB0^sim|>S?Mpp)UbAKyK26G$)OZ;~-JKFjVv(25d19_EAiBbUi$nM{~WX5aR$OE_BDnRKveJvP^-WjvF-&ZsOU`mG5~mG7w#K$}=d z5zS%6Uq-M8d4qPiqWu^Sl@m+ydwdJ~UZCHVn*5S{jjqYUv5LE>D&4dBrT%u2g`)t> z)!<5Syu9!QNEe+Y;v}a`2_jvcrVwYA5Z(ckZl2?%qNet2Voin+hhd)kWf1Y@g8D{9 zMHQyjf}6hI);W!n>aLBq$7s>4GM+AMpe8mH{-BU zu7S4>cPMDfdU{l_f-ulo=GCl;%#_4o9h(lIfeY6x9PYCgtYS%!he_KJ!r93Pp-ul*&AR(LGuFI{VLDD?AMsoob)jimer4sb%T?N z0DueSBbvG~{XV?l&5Z$Pphoaw*ti{rX%cG+ty@tQ2s3`l*at3rCB2{A-D@?#Ep#J z$ef&<@Ns2jRtA_@TFZ@&mS4y&HgJHRDDr|U@}T=LaDJUj3aSK6Y%B+OlNgM84n&6p zD)J|x#F+qsX=!hV%4EW^kc;;gg5N0J1lPr2sF-+eo!lP!UICh@KhZF{m;boW zl`(?5oNxLbk5(U1i!@+Kjzs4B?nKOQyX5TeyRJ_*#26NLwA03U)kQz8w4b{;KLwEp zC|NbV8lJ_*qC0_uk2w=645NxoV;Qm=U+|g`k!4wrcd;2UM zPMt&1?>zh2vzZ0>-@mG~@gjB!N5Lg`(1z`GS9nH*t7w{zj!q-k zpjyMNR)+!b3LMVK$tE-)<$_$z6od2k?_Y*bQJ}AA&L7NUp8j&Ospm8;m40DZTj_Ot zc6KANrccN73p&4`0Dz4+#l^njDf>#6?i$ePw=5ZITRi*ni`;ilt#TryfRi(!Tk+;= z#oR|ewu+}-qTuo9qLv+>AAOi%i)=%f>$ZRY{=L;N4DgWvhC3baE}4-q6%;gEmM48h zr~gk&@GPlGfLUF9sqP(%z4>9$#>VqhG56>wr(h62&xPng3z7aOAi}x|Va8 zww$&`f2o<`xh8^w%@Iuz`7Ut324(_+NWh(_Q+SH7@^>NGs3J3m?M$CNBLJ-&`SD)e z;3~t~s^Y&Q4-kmZMX;wh(~q8>>|tA^hPiq9_}pXVpYnD7+dn>X?S|YS+Y#AnGZ&q6 zq`B^+X_uU71L5nZR^C^YK0>AxZI0m6D0E=od|EH;v2CiLK#HQGPNYFi-&9dE0|eUc zCQq(fT5{FljD6+Y&Z`T}56Eo@1n?~8e=?$@dw;hyHzNQKLLo=1trgQ|N{HC{b9mZm z$$y2Rn!(yCn7oSznjFaeulZyK}v^$gd?Vf)?Cn+F|Y zvmiywX}mA^(|V`L5k#J$VSCZjO5^egmWcUQpNk5wbLqh?9K5SN=OqM;0!XSNFO~_p z625PL;|+hf3`nuBm6dacrzL~T9L8;j+pfMH%j+`s@p-`-6O4{0$8ZZQEz3Gfia zL5jRIspvza;$c881?1=7a)Tzno7DjPF(*EtWdJJ&GK{B42qnNFM9=k~C@oN-4tRRX zykJh%`clbwrQ@+mIo#)d&noE7{4V1rb(n~lUe}s;L;#)$z~qQF#ML{1p65aQ63+7L zuWYZ`pH}OKa(6q5FuY4ip_fek<5r_%WTb##QqY63yNLx@OjiJ`3|?vJFW6`Dy3f(= z!swy3{V+?^CnnUS{h_P?i?-xotwu4cN9TA9a=Xvfcm5DxC#}a)79?P9Dp|>ljx;g% z*~3%#gF*ddl)34!EoB)OyuA~dx$e}-@R*QW`_Cg^HXQ`R!|-ylBVatDgP=nM;Du zmdqVo+c&kaz#c6&kgYQWp`VpAZ3GzDi4Do^*K4*F_yEyu9fo;}(}=SV8W(FK;-rOA z+ImuiNyCF#BFLBvNTW)%3$b;l<;uqcIU{hq-mmODIx9N^nb@?_EB#Z4aLrUhkWG+4ZADf3RA! zG;p&z&tJK4ehT*c0x~`jL@M-TMbqQ~g}uCs$=gGy*f6628Zywpi!jW;!qHXYr9tu1 zFhJv)2Dl5cNkIh^u=;82eaZuP3J__=CrGWz3AwuI#>vUE`k=5}8@1G|ye?1)0d2#Y zqy(sWou^Mzj#LU!3-3qQkXjTJ4{v^me*l;U0lwkxn1Qk006;k}I^Q=h*A13I;s$oQ zmYREljV>t28eP+Mes43KW=jXHXg{SPFPrV#nJ8ksh@V2U=5od}KfU6OIE694U z$-|nUi~xjlpDa!@ZETBCHZ<=O(_u>h;5=0ZxwSBD?U=I(3*;=zb+Lj-B1HH+`aXaz z7W}kuECm!>*s<0I3Jb``F#HhZLrIWx{_I0Rg$9iLr`j*k^1T~wW|nSL zHpqaiPJo;wzFIJcnv~28w9wCHVA%HR@^D^k zjW;ynXr|J`s*#SgyY|{s_S6#-697hlqMAE4lf#K`TR{hoN*HDX=r^>q`d3}JeGA4p z9q~p6ZG=)llfB_~+If-+YU@?oLJMkZd3m{bcsIf~d!4&}Z6YB;BlqAa+E6%hu;P@E(p}}7HI5&S1VQyX?X-r4Qfx{iD$g%P9rs@~J zXPv7ba@_t>VSb?P@Rkj)$v8Hu z8^W)#Iay7lvKDhr*kT;|NJ~puwaoX|0P z+OnG@0O5^m%AVQGbSjRp&mn?1Rxxfr!0>pj=3j0JxliX^$onw<%a-l{SPa0FZ%NU3 z=-QOuK3@^jE*?D|-(>xfVq-Iy{jd$C!QaMp0}4aXiGj^Y>_%!(00Qm9qx@2loxCag ztArDdy0P!&J0BSKdDXhmRdASY`<+;r+4qpfRbKt3pqVoo>F5zZD}Ly3idY&k+k<($ z=P3656-!SfMTghwVktH(JqwA#8QyR!t*HspEApEUNe4&Pe!3P9aN7o>99$j{>6$+2 zzkWns#g`unB_=hPb1j=4s}B8t;$e1LZ`J^D3G|d3ZnE(o=Ja*|dZUIh}DU#(5u9>dGvqcQ^k|c#uSMVMOgb2}+rf?~adpeKIX>HjtuP`|Uhi%D7 z(bxW}C&-2z#&sM58xRz74GH zm(nIZ->P|Z}dePyI!Wu$#^q-tKIVR4u`C)$`d z`0G_6*Hg3kgpNWO)`w(1mZ&fPap&m}MZJ8C!Pp0$9&lWsuNZscz@D|U_eD-Q=4QZ~ZVOOv zmzFH-OU~U5h|b!0R4a886mps)ObqCC-D~YC|?t>vLNei!%bl(Fg_N8LFV8)z+wu!(*5L|=JD?*?FGq-%}AS75@(MJZ%jCbNxVxA zZ=6e;v}j0E#i6IC2hffC=hmnzqp-s?7KG;zM`f?kY5T!!VqMr1$Iv&{&g~dsJ$PRW9U9Dl>WmxcxGtxN z?yPk&VCL!BJ@tiQ5sRy?TlS6iYtvhs+e*)z(Co!An*VFyVLyu6+;3)baNwuk|0EtVO_ufcAE1m)IW$y|72kO-m?KZ)p{zP z?%YYBHc4`s&&yyRwmQ=T_W)Qm<-!Zds#kg}J~j(3;&v%{zc(iC?M!mgAoQ_y6p!tM z#U6cKmpyJ6(c@KkttmvP=05X>=XQ4QBt66nu1pI+-|RtL>zjb#@^cCYRs*y=Jt{Z% z3 z+J3Bt76986DHdiV%)6FNHVv=m~fbxQ0UXHV`JDs}{@xMkKbJSgV%tKfO{@X$?ATJLY7 zYG<qLlNq;`Oua!1>2g zzr%MWpAW5px9R^5ju3}ciPsQ@dE@E}kZTCljy%-Net`zlga(}3Yr9KKzikDe)9Ips z;XoP@XDoKLI;4zhFj6_2`It39Ld*?iMwMz}vm1w=uebsTt6G?pd*o-gU-@k{&6*cx zbB^7^yY7dPz!1S1k$MYZ3SmLerGW~n&l3jlUcW0QyG2Gv*UUb|fot2?AHA@Wc&6Ok zrJb#LZTJC<)pZsjL|nZDDw_ZS1gdI%`>a6p$VlH9Pxh0I5^@ICux{cR7uYmvRx#Ir zMm&0C_6u(dFZ=-+pf~A5u0jHhTrAlg)ud7B`GUR2O$w=y4E}9JeD)$pmJ(zFAo>J# zpx-Fv%$2sqv$4<+mT91Aq|sM_1dJa46}C%-1IP^<|x78{Gi_dCodsj`T&Op>dlpu72b!Y{jd4zs;eXeZh|ph6ni_DG)nL- z@JNA{3%GxTUN?dA#!ZV#4uMV|4-}%)Rp!_48Z>H(wvzb23DQk@x&9R2{%mQYFIht5 z{Isycga)dVLk1ivK$`->U?*~$uM{w}9SeY@1s0sD7r%+m{FvEnk~vnc_brMOtw;vM zjGQ3FRZC*2qbGOghSYeBSFN;Xw|94aTKh4Vyl+k({dMnCFTgqJQp(|+%4>a~#O zpg{q}7WfAKiMB98=#?MDH1v8?I>=F3akvA4#%XXlHPvy37Oj7|@gL zlo8igImeEBRiMX%rt!sezwEx#DK*wUaMuWRqKoGydCd4{NObIMnQLg2_-ij<119Tz z=>bs>ym5mx)O+aY_4etMosI1$O@WMK@nc17al{9`EUkQ(bBP!*`z0@}lOZi2jI?>7zKX zWEr0`ziFA`>aUP+D?oB4)uJnRj2jX=>*xrKNQ zo3v=SW#iI~K+NC$bj5I}omHPh1rC#j!;EEN*NMvrcHi}6&oKs_5U5zw*ScR^8`|l7 z!^;1d>_*@{E;o8#Mlq?{u$~6Jpy}bU@bK#-@QD-!XhU#pR)Z8hS!14D4$mM@R=BDB z4;UsNFHib7G)iAsQdM5;GJc7??v3pyT7y2)y`J$Xdf-kE=jlGxOtrz%b38S07i!v+PL9it%q1~ehMu`#dSexiS}my zGR}?mqalv#xAYRRu4_z`xFOPNO=qvO2J@76K65@%e9Tf)tCV+fFhJ+Rpu}qRJai2odF_X2*3?+9ZdU7eZezC!mCB zt|I>)Z^hSBJlzDQp=CjX0zw7@aoDYy#|EG0qo^Cg7A;7-rTj7K$E**+fXwz|g5Tb6 zgVDN&NsOHIDoRKh+0X!pAz@c;)zM-jVP9}SbKw4Wg2w&71dnGJ1`fV(sYDM<-LSt{ z60_#K=f?DJ+e8Q8@k+ownZyr{Bjf)$juE&uJA3=GqQgS==lgVJ4(lc5uwPvQx#@o>^tIlXTt4G!>94AhH5;HQ0qfFl zUm50om03|5KD`Z$3tj=T6{nQ77ydrf0|YO0&RS`!FsDh*4nysweV?|s3xCdhvK4(v zZ!U!R7cQnSK0?f|3S?m>Sxv=fy9OVNr&}gDei|=xP|rEmyKCotd)!=9Y$Us6pTrpO zZ&_9O(K;_buU7pnq95~hrSER=Anl5@88cDH`_;T$Ig(l5?#qPwx7%NDn0CJLchBo< zzB(sI)oh4JyvgH~6yB3%?pu;KvBpTl(a}l3x%>i~o3tPA)+Yg`LxS59Bb+nyBN}x^F>W?VsgZ}*^XPY9X zk<0ZvlSi+GGY?&aI!Pmo*qoOBGRw|qHMYb51=Y)6s@S9Tdt93hE-6t?SU%ym^iO^> zH=S|x-VpkV^DhJ>w3mAr^?i3NG&d>6Y1EqL+>DQ(WHcQcUBdMJgn@PM8WyCZw${c@ zmWlLFcMDfEf7!+Ql4WExy|~<6ct<8jK;#7jHD(oMPmG zO;jy9F3cCk_^`o;iQ50P#Suq*{XbU{EUA9sh~nmKkoZ z+&JxjPDhpCU!qTbORjdlFBn7Z&mVeiyI}QRY%1`bpK(k1{O7rE<)qxNJr3Doxs0~$ zI{c0A;kY^Y#PJ|Q60@eei6r&k5~!wPO!}`1O`pu)wk~juoXigxS4(YLn(<_s{+N-$ z_n*~_a?8hd7!r;j9r;B!a=FK4@3+r&GF5Lg!RhKrm*~HRjiO#)^*lE$$4Q)N`>A*x zLFT>=XKPzoUk%z5W-e)(%d^K7r+$p={7f`zJE(L>DtPXb4>sSVRPD=*OaBX6G1hhzDO|cUf zlUw<3@c;Bb!Dq1lt>~w4P-Jkm^KXO+98V06hWsxG!L|DNoXhagXw|pW)GLFLo}EZ&#hBJ@xoI<3plXA?CK>c#=oubnKoUW`rBPxZfj6|LpeDa}^hUk}UQf)fGh`-43-5ayI(;5{^!nkcqlm{3c9q@VmXg}hLZ zT=+Yib+Q?5e0e}ASnle^eH9H}){PomfVlh7+ba+Nxe_nLsbsm*EMb}9IX;(67t1}D z=p{9S=3^uO&3x5opbhZg^jN19r)*ca995I{^~G`UowLyV8qu*^zpg4q<-aP<<9opB zc&t$VJI8}HQrPH>34c^Tjqnx<fu1bu5CrvKfPle?)c(cl-8=tR;HYoQp8>kI1KZlur?a zt6~nJMQ1z&8)hVZ7U;;-84ZA)Khra^9J)rojY^L9F z?QZc^IARnHPaO7M0SLYT9m9X~0^@c_3c1z=Cuoc>loZIA`I@vS>nzO9pxcK*-)DO- z)OuT}|1v+=_RzGb39hW)<{x67mKs{Cl4a6Aiux_@Ts9hTwoCQ7{zzgdA!zHbF=&fS zA*E-KZ@|5urV3mX&Gwb$Cd417>}9nmfiacs^#dqr@(&0{9s{t^xw?|9K-(AqcEg7Xd=OELYH~`h7!5LGh6jbTY`Pz$Zh|T@Ik3MkHrRA zFB7KbFsqW|sI{ttuwvvhNl(wmC)JOuc8{rH=`m4@zV2MlKV9_q-z8^7WGyt&#%d4| z3K9V>v|e5Mnvs}w;ooAc01PcywZh@Bhvg#WC`+d?+E|4gNj9)OQqi5w*3b*JU$cxN zlpu5XVhkvN^l<8`(y=^RJa=+=F6tGPed|LfE$k|=2iL9?)^hLzNWc`h zhzkmM(S0Z!7^LLB-Mh=`7gc-XBrWtiQHxuCj;$Nrocd2NAfE&1e@mXTq#iS;zig36 zPEy?8XVgCr+RFN7AUQDVdXjdPJh-nD5&C%LTQq1|mDz*TIdL`K%&Lmpg=!Vzy%%Vu}cwn}9)w&dZH+^2?{HmqQ4i%b$O@37X94_UNyR#%bh?Lf(*Q|KaAg z=uY9x9J>o5OXHf&vCxSXOHgW>b9987OGVui6YI!Zpt^VOUI=jPT*2D}WUxGwIKLw;UGMrD|UN&8WW-=Iv4$+H4DT@SF4I{A_Ur0l5G42ToG+=zDyG z3uAV&M&)qfjuefa2W+g@pg@dY?F=K#b#^8qfV>k{~(gW*nY~m z=v96lyEwSx21Otu|NkxpeV$S83r2-e9Bc06RQRLfQRZY)6BtV&G)AGqndofW|MaPy z?;7;8&jmIrku1zhqNvE^T&;M1`AKos%tpB^j8wNT8@u|6wzgymyz<2W{q2859RsmM zX{og{2v9)&384F0v0@aKrsH?gW-bVR_{|euFRT1HjyJ|a)4=D-`Xl^g+cd^NbZ6jy zCmY@+@0xjfdKzI@r`d5!{Y<@&38v)?QDE9Z953pCT=IZiyuF@)wh;gfq~9^m)#)=i ze!|nV>9gxs1s3s1!!|$uGg|UV*qBi`I^B}nfGYtI%#-%QK*!;|cdueA!(G+XtgDPL zrsKtII|3R9?9qL%aD#9q=)?ogd%bAbY0nP+7}V}N7&a{nYdbBu8wKq3k9SHqw}d*<73BzZy)SAhkt-0*3 zjP={3xLVI(FxCU98|_#Y{=D$3!JA00u!9(hGDlYE5tVUg&uq!YvjK-kp5Gk~`p6Z~ zl2+)26cn@oqU6d&++;Sxzylg3_vI)?pHu%c0&f352ve)q9>2S#P>+j}cI(!y9?+8Z zv(d{T?YpTEc7k+3=LEcVJe!lTBCA%BHfY^}NCEuM{$|@_)CPm4$NSIzC3@%O*{Ylj zv5?yhmwdri*#I18DG=g2kFF7c@gvqdozJTw1ON3EadRqweDfC6*wG?qf@hZ(u6BOD zl%YR+$g`=$8Jj>-XPW=};`$Q62@CwCN;#sR4E=_%tM8CY1L03oi`K@BbmIv~MFj;b zho>+((m2InWb2JNvmtNs2;mo1Cn1S({t6~RF#)${o7!f)h#xjML0vzx~z!?p}S~8F;aTm5cEHm5-YdcnQQHS z`BE;lFPE5H{Qe2>i6o)JPzRI+@e3?JYj(kv$)m$mk)XMgz&S-I!1{_p7O>++Qp~xO zm54>TUo~Zca9;GQ;|e(~iXnO;5r$}Tv2mqm&&G~^-TQRDv(}ePC-pAx%}JjikN@Ts za=uy#38p)pcOuAuS)}yLeh?e>-)QkMX}T*>JN>3owFtim_ESaFc6EqP3#4_DoLVoRAjRr^ofz+1J@n$#cffi zgHfJ^v%KQQx#dqHr2W&SF2K(Z{Qq8cz-H#xaEZEjTS@|77}7yyU%Qup=bM4JTqAnt z*CS2}U^M|^53ruj{f#=jfXE6v9*R|NA5b^MsOGnk?2wjchzD6+wy8BzXPBD7NG15E zX($%ovaPlfILEj`ZY3yzqN$ok4#-*hVaFr%8G>Vywu<|Aio5F9DjWlgbNUffU5}jnH1v%g%%=9iQtD@Q?hma zG==R5(P&VP@xh}8b>eDrQG$c4GRP|?7OBo@zDeKxKV7IdLQ2iZ6hHCe7&J3o<&a(% zID(FjVsXf8pjn+}MzIsl34P(8C{Ta{ z*3`0q-ER%idF$S9Eyyf7{yk!^KDx+Zx>3x?k8(pvF-mI_=gEm{=Q3l=xgG+-h7l+V+e z&DKyGB5dS?O_XC>&@i!FVz!#tyD;zIPqP^i#>_@aI(;Yk)PCPtfEu6&Anuj6hKyO3 zn^;)1y`i4h81(kF^IH)8d_MQAFS)Mt()--1Mdz&Nq0YrNJ~&HK(ujFi{n4=D?jrTr z6pY|b1QMk|0lZaU$BvWlYuCV-6D{js0zM#G%)bu$YA!*_k?U1=hBroYnA#lhl!8$P zFw~Q$nzsCkid1D?qF$X-T1)H5#}J)$58oL;KizGF#V{D2wDYVpRE)pJ)7nwwA`m8g zG3yOLX~+DQ6Sla>;p%OXQ?-njQ~TKxV&{I$Kx{+-O^=PNeQ)m;loXMi`m7>^;QDGJ zXn;(C(e$DIm+wpb=DJ@OLypWv@f|O7COp<6i{IyusI3rV{lD@$Bc*7Y9Qst)AuG=Y zU}oT^r$wPV%Ybzccu#8nEaeizpFVYuRn8UhfQyD+&nqSj|Ni}(@7_I&Z-)T0m(7gYX{fjzkn8B;9ONZeva|7HO6ktr_2!kxnf-qwFz)J#Xv(|#P zHpSI31E%$StPVRaw{o_1V?@5D^~y@8p9hbmW@ zIPf?_;&iAOjCGb&R|9WIIFPCRJW%GFYYx{#?6wuxGp1EbTkafXSkHLjkF+QsKlTG7 zg8*DJDZ0Eunp;>{a3_|2nb-i36bS>K2p||~{6EH^r`yEozg_@^lW+fG9Awh$|=Ot$VwQ)lNVRCp(B)#4obo+-qz|FL6-}B0e zwh9bhU)Q>Sv-z zMZ{}oRP_2MOUHtzw+`caz`*8`vVmqur)H3HOF)mM*v`wRAVlP~G&rgLjT~}(^*SD# zVtdB;$$y{A{=97h5E3u_CB1~gNqjHN6!poXHyoxXGH`rT(boDv6aG|GlvL(by>z3q zaoV>1-{37NR~9)<72{zLj^9kj)8~1C&y2h%4~@Rn75i^RojUDQ`Y{kRI1&rhY_y(~ z=YoLBPE}#eD#eFG*f0Eq-*#++UB7Zz0}oD;BK!`n4?@X24xY7kQsU()!Vt)*l)58` zchz?J?s$Kkz9VsPSt+)mbC&ZL^lLGVOH#+ZU%=d{uP-AI*{>U8e)LuE6k!XE_6ygVsaUqIH~We!acj=`ALy2uQytjJC%!)_CJ8edX-xMb1DUXNNEGSQtwXZE>Cg~Rm^WTek3eklM7^c zVBZ}a90WSPonjfPgdLG3ixoRM?J)=}r6R6>-q@ro5#zsc6=g(cp>??1;WC2qn3c$T zPgDkhTzEaY1qO@ID@e$=mS)SRAYhTYwrm}SCB%oXc;MIrhg-{_cybRrAV6xSmRm6R zpTp*M>QE?FV)#NWo^Qhe&tGt~!0c`YcRydX-?=EH@%LZi!bFbO4~S#`P=8$m(*e$9^P^!U5UKZzWD`OVx*GlV^_sO>*|K^@W(o{hs zP+pIdq*txqetvq00TB=oNHyR{mj17Ssuc{e>JkTHEOsHy9eOZ8L(2GZ@Q501T@9FC~GVYiVUgiXSotoF9%2-Tyq+SGp7L&Tu!aG%@(T zf-4&)KP|9fqO)3;SWs#^5_DK6=YBCXs7@v5z8%yR1qk}8ABmk=zz+;GRxnBfk09GJ zAcTiKEc4Eo#Lwy^mirQed;(ApclW=kN6cQfO@q&%_0m341(rs;=g*sX34t5^3Z$5z zxlwTzC^J6riacO!0>=^omvgk_gWh2T!~lnvr0K0%@`^lu7^qcH{8NPBouTpUxJU) zq2_mJZoGsC0UZUi6XzND$_g#)VOyeA7dr5r7;ZIbM6z#3|7!~X%C$I?)X4lZ!05HX z2euA@!3y&PUcR#_-Xk)&c{NE8MsWvR*5QblIgM>u*z z3u~`}bqqpJMN#sSQWN(9?j5$I2U}fxNn1GaB*AO~T_4Ie*LK4ef84h!E0Q=)OL6QiM!H*0*nTKZ`#&M_8nxWl$LML^lMP8<3_hLt(N$>?7 zdchrY+Wv9@Rb3aqaJdp9-o2yA55A3yKw&jKr%Oqu5m>T!c3Z4={1Row{4JC=QI)#I z74mxg$9UpY@77Zx@1YR`S3~5=T61<;S$tU;Ke&AVswr^_TDE@Lo{Wr4#?g^?czBqC ziVA#5N_cp9+zrjZzBX$?I%r!PDJ7$duFb9c_wRdndd4LubAbna@p0I;EBYp`Oasum zfmJo6$+&TJH0;9%HXmQ#r~Wt*U6Tp`A5l@sTU&D`BqXf=swh-R;J^+14LFxOG9SJS z^&wDD5+?3@K46=%GE+hnTwU)0wglV~JkIvvp~Im&LR$0|3V}f25)fo(Wd#NX-so~3 zP~dy>l;-{gS%GcgFFMN)>{zACQ=_;9cx(3#>-`pZ*k>Hc&>i;AA(J){w|j(uu^_sFIf6BvfGva&jV{6H1%vr9>3)P;oTa8vQAUdE@|%@}l_ zwcTBCIf(Ad&$Z-GJ9Bpun>TBynUHF!J0OSy1B(R(VDg4D_A?i5ARN~KWnjPvD2_J? z38eJ&-5~I$qQl=(!bq|nUL{?m|3VT|$iSpFU%9KH^ z_Kv1%Yj(Z;j{mw-Tis?jKk2fr(Bl^nz|cb}Dk(*{=w=$J8*1>#gQZo-FD~vd<^^9j z0rr(eM5Ky*`pv8p=!f`9OU=#KU#M3;p9ro00LJv#+gEXhMkYMXn_lRAlBj9c`ru%B z5r0#J;WJ(&>#ZpRB_;e@w{B5TP;^G1`|hG&q5nUw-a0JHCi)gu0ZB1hA zcjm~zb?i%62gJC2N{Gv%dVdpp#v)OF_^G{=VIc$vhLc@{fv@l#Rr&P!vjGzhQ zm>32Y)>heZE?l(DO6x`DTfg+wRD7^5fOY+n_fzCwbMR2{+Uaw1H+4@GDGg8le97~= zZ9wBSq{rs*Z%t>>MdkXI6PJXz`0uhhTpv9>2q85HHbCv=tE{nLT|Gg^ikO`p^Vrx} z9zJ`@H`yP6I;yjWQvVYkGtR}*n$aYuu_R{}1FMcYYg2~5|`NsD(6$q}-IKC33- z6j>f`I!Qi@U6*{fT5cu)We-A``d`8$OGo8#{e0ojfO9ej{s_ExV4x^?Z*g()gYpoE zB=6(bo}QlK($b{V)FJitTn-Kn|MK&>{+Ru{r;yb30K53~`?4Z*cG<4Nbn3 z>u&I?T>-F9C1hnO`1sQE^JyF$9l>MJ#L7?%KDDJLCg`)I)Ni_X-I;FDYx*x590%{y zqa3_K`=eSQAthzh8%+Xzb6d$_gB7NN^zmi#GMA0Y)MvHSUmPJG<2wxv4X{qGQmN%u zZF?{`_xEwh$&$d}-}?O+A6GOqG=xJyKwrP`R!cbcpuIic~$@5#2G%4Kk{JPP_-JCRc4=K`Zv=Ef2lTw_qB5?RHZe^$x&8O!yv>GH8rKM zaK4s&gGSsG{QEaC@D=~^@-nltvqgeywH8EnbPtd}JLijGoD6Uw&ZlZfO z&cSI6^Y8T*8`^b>O-Ts@Ewy@NP)SH%{F-Tnf~uyZi3%pzg2u+i7wV)~;OWuP(Wt(D zetE^krpHT7z*~XQoSdIytY0Wz?S1%WF*d++K3d2CVg33E_uE5&hz)EyQ80$aYkQUO z?3|oc;K}jXTfVR%QUU2FcBI* zS$J0A`T9LbM22l<$B5ZKlv)L5qjYQSFIr#E&l+!yq`vWfq>XylVr{CX0I%}-^QV+S zbvo7e2q)9#C({-uSJUWt8&aYcJh|ccvKDK^v1@Np3GrwIvoZT=_JJ9xHs9aMJq`9{ zm3Dq{tU!x{yx}+ne|9+)%|R8I#e&Xxc(aP{dV$(5C}_+C?;8XpO+ORk6?7E@#O;`N zcXvT~Az>3Gn3q|21Vlu#PoIAF_e;7Q&IOc|pfEF+-Q3&+|8OUeOelUx@7sRrhbI$t ze>fQ6hjez!v^Z;7B5h)cMz;9p&*i&BT~5#4K19HPZwuygccI79L$qA+L6!1OX@FTUyFQLqh`$pP0CnD2?H*t*tGy zJY&1LZ%?{jZ@ya8*$%9dp2b>T03tVz+taf+l6a4VgoJ30qJq5q_cncE3X1M5n4~*W z+1$8yE!Za)Yc;n=+j^z5JZOz2zai%91IN!B1w?FdNq>x%{AwJ=%gA^QE#n}=ABa3V z8Usq?b#*q;xH<4k)%3dd!H@Qd3Q1^4qX#I$w-RV`(FpOT*GKY-+xo*jwkzBZ@z|TW zWhv4fkq|R}MU+I9e3)TjecrrwJI}(LoSbsLNw;>P^x494SRcf8yV+H%^Xe8hm2Se} z*MqoGxS>3@){c7gb^C_o)cjTquL%v3) zDlpe?qbxN8-Ip?Wd8^wi{~FVc-L&6K(TNn!&d2uwzNn67}h+t%vF~UJ~cC zb!3JeF8|YAMPoR0W?GrLf`WjoEOJD|JK&0d>zJjbEEM^EAwcqHVz;-yzg_B31f20A z9@mCdl6#{|-xo7C@IjjfcY+o$oYoWWdpAV4wSDB%pZRPB0rtW0zZ8-|iWfaT6?hn!vQ!Qg5w& zIL`h%%=@8axi-%7s4ks_TyUycul%R#ZhLVQg16~PLyHk|NmEVZgqE;Qo1vdrx<-Fm1yP&?yTFZ@o3ff(h4nleh`)lPq9{2z z>*PMtqrV>SIXycwY;FCKottY^GoN##%!sRc?9&`Wicc6 z{0${sQ~cbVCODC)85zx1!2A9EyLNoMY<8pvEzU2HHO5565ZT!&%q+^-YOLyToVxwb za%Wc8Tqwy5Oz#mHG4Xd0Y${8twAh%5M<+KFr;Q06DxV$Y6Wu%|W@vNW<*=(Ml$x2< zEM?YA_eCV?%^iv~z4Csn2!?01ailes&a`9MO0PU7 z+439VPr#0{>r_xv6Vuhzl@k03zU&PY)V((MM?_Wr_oRZy#I9oGQfi*P5fddY=j(g= zPirOzQ`jCC-o`N59vtW_Mrp2h%ygdIaYI_qE;-woiZrL^VDFCUSIvL5van(OY&pNC z+g4H1+!jI>Y0J83EfODp&G$H2-3o_(MM3SqB#KYHMJBhD1q)tK zX!tuqrWPz^3Ift8ZhR|4T14KV&5gdPhYkOVN?dQPR2yPpx9QhrvjSt8s04I*1Y2@5 zGha99MuGN!xf5vk_zSr$?4)0y+hiJ*X;Mdvp*HQPG)gzThB>V(wTOCw>ph_sF1H{WU;O#!`GvvCE;t$;*TjC-rl~8%hR=; z!S};_mmISA-k-iwOWfSw5ng0gLhui$X-pnRwA@S}2-TSHYe}LptrjZ7hB$rf4@Osu z2&*{FPy){s6NmpPb0yhL+YvUcW1+w8A~?H76Pl>=9DnAg44WFBZWLU4bbFWKbxuHT zk^=ymPZpFjat*cf``+E7Vo0bDVy);6o}q4XZD#> zhCnYQK_Q|0F5yJ0HgstAkf~di!}bt{rdR#>(u3YlB8k_9DT5SSjg`=GkjW!4US7`B z0mfAS_K5!das*PhP*z#lRe!XeDvpZXJ}zDN2P~JT+SrmMjb4HoX|vAJm#~z8MRn4G zybqpPoAr{8tx&u34|QUiQfC!SmaAH^D8sN9J@%VVFBOO(Nb=o|H$Y!By`L%`Ov zGO&CPAu&>oI&JV5S8|4GbJq>4tZhYmQ;q6S*Sg%wc9h=0!#AWYrXk9ubV1bo%Tnu2YU;A2rzo zr^&{fE7hvXefD4Yo8roz0e?9KXvL1F}uB zH(SN=6KIKcd98H*kTtVR&aV(tzR5OAp0+_|PqRaqGWNTy+k zHEF=JfqJ`n$kb@-!S$Qn(gSixRF`AAotEdT!iPOrn)%Y(*Q%S7G1NSs_XGs!E&yGD zxatk|^+Y=4s1z>N#w%ji%)<-Xf?NvFTs8;@2q%}9WVEzly}iBOwBR_06AZFradCRP zoyyjoljZ2Dd^YECT)hiTuU?+o9(#4oCl>IH^?W)7$j8KlTPsGx_=zQ9_z3e$3*@P4 zFMKOb9qpw6H6m&Mbw9ov3JOY_D{2fHaanWPZ0}IL5bMb8z^CzMYv0DCZ@=({DQO6J zJaz`_^+`9*U!K!DvL=$}r&p`|?AnW4)kTlWs-Ms2ms3o>Ab6nz1j}HR@a*ht)S~Gn z`QzfMUoP3{!=e+|AqLKSuzsJ5?cwP|e3gnd;l3T!w^bin9M?PCY>I6Bv+D?-_vc$d z$8{?woV7;X*~lhd_6{3`-ybft(3EWI;R~kLV$N^xY1JRM&XHuL<0F>?J|ZDeaizzZ)pFHhj?skD9~@3Aj`?b9p(0g~KF(#fKCB9nO2|oAv(G0lW*R?s zXK+3bmazo;^Z89#uHE^hzYA-llVj}huVe;ZZ2|$V*@53$K z+}a*ou4&Y!=iDxmu-(ofW+?7`0Cn49@azh}o%Q;$ov6cc`>Ln?5;K~N`qiST>*%Dh zgQbUL3PXN7wa7^Q>xjgF(iQnc=-`gmDxZsHAe>yZxJ0%@iK=X=va<^6ZB354n@gM} zsNiJLba*3XM!~%ID=UQPADO*8oxp3}M9Y@uzF`$t{w}j+@5AZiCp}Ldh{5UW=$eXO zfm;;Vkxoo!J4lL(idy)EkAlW0D{VHM>dk!3;asNvh`Z_W8&=B^T^0iCBEXvJP9{&P1s`cU`wwSzUA8Lyh=BapSoaN7JbbCK^%|7@Suh7B1H&r9KcGP)|>c zPWq1-cUx2$xN`8!!Oo*&m|#yL5tD>DS~K`MhfH+-UT5bIOs+Xb}7i%z37bfQ?W`9>IHeKbSmWvio_ znt-q;oQ{BXQ-}#s$)*p;;k>SoY_zEr^~+1D;SuRmS%Q_tsVc4fPyw|4(1;-V+Znh0AoJ=PV`llq-#|<3t z@2<$`IFN!WygQ2HGayx&`g zxqoro&c%E6^}4*t2W*rwLqlhpXzuTjgR(^2px?e_ay!w7Of$R@wu5D4WPFQ+FK(>- zKIbhINFRhnMbU9_si(}I1wiJuLa$bCvo3mJayay!=9}3jm*QH~dewD8mB-OAbUM+& z(bXCzYAyz)m~MF2F9qtxr$I-XUwsk)XHqS|EK&s(-egQCC-(3ojb|_@jK5~cuXU8n z47!`-PN!V=-7ou-C36hh25C=Dr%QJZYZm+QHW@_Y($o^Y25R`9hUZ84heyK?bPfDO zv*J>Sl6$aiyI84Q=0B^WJaSWT1e_p|d&D~gDZIMVHZc%AAK0}h6}Vq}=13NG&S<6b zWSV`ov7w-(3>z!1j!-W&#nnzjB?a}@#||WhHS-|d{XA{`P&NXwY}e>H znNd3~)!%B$?xb|eb1NyXvhRR$q?*RQ#zHK8+9r6|4xucY=dMP0k2l$1MEeQvb2Gzq zG@5^LyD>{lbo3WRMV98~aiV#_YJGTu?w+2Y&d!g?$;nJONB|yyT3WRTX#M?#9zed+eDD)J?#2K<`tL253ms zHb4I%O?HNS=Kfn;I@sz?Bh1RQxT&9_)zgsU`6CGl|F;$Zp*x)|wo~9Vh_^a_y3_9* ztNuOq6xxGlQ|(cCMcvhS#jKKYTel2n;hj6LmIERcHSOgNjdo0Ch?%Ze01V2|9{I5l z`LXu{Mn@3cc0R~`?`QlBjkLW6qSNvF2xhd~zUW8?&DpS|0A#n__!Ao7N95(@8@8FX zWNuugL|FvPh5iKvhN207hg%HD$RO(L>-+TS6aGhG069j9ldxFay!tDb-2caQX=gHD z-txzGkfR_kHQ%dA8gh&H@vd{4+2occC6QLJEK^xpx3ajnVlu-sV$vD+HK>p#4|c%B z5HRZwc7v_u<3S%}|a}lQMF8hO=WqnN(BE z?^i^TxUv1rLW)W5PtP-@Oj=g&4;V~4Z0kHr?>=}x@7oqKyfs!+P3ooZJw|`MwqB%v z)Wlx4x6i*ghdyKMuSJ+Vf^AEV%1%7Ixtv4Zg}$;creh@3&~vn;HGtA$Wqk0ff@?~Y zpP#?HyxiQ%$`~|n0iC}Mjf|ppR9pmh*qdX2eL1-a;-Lx#2{d2u>Nuy`K`?nB2Na}SjBJ(H!ZQ|P;=-cLw%FglBW35@F78c$!11jZm&EkR8NQC zN0#vl+2f^H8jC#(Z7w#}&%THwxbuuwc~k%T@bE{f64N@8U9n3~<4ivGkk?;mg$=b0 zHw6&3P=X8qk*Fo2AXnCSEbh9dKBs8PEYEf=5SB0}v+wfy>^ly9UPvATfn^nK(&YiE z#l9u)xUP?nPkBWJh~PoPz6z58to(uk@*{avV7BdzL>`vj7}vKx3`?xKJuo0Q zNZQNaN)Xb2-Ey??qfXACqOLl5y=aQ%X>dZvdwb*P-_{eSoI#aKGn{e7ST{<`Lm=2^ zpy_vKPmhwKVtWF;7GMt000jWD`c-*YPCB~q!9i)T{~%SC*dS+XHUD&VUv1gg=yp)N z5C6`E(l6c*-Yn9b^`tSY_B=wB>OIoHu-!oBt>+;YVJiCwAT@TK&LHeQ_O}GCO3Q7N zzXh)i%hYvfe!=M<>i^BL^;u}YO5^5nUv9W&b2!T`(72pRBp7~mY5V5!QJ&@}LnQf# zm+7O|d%AQFO6+vjqu)OK2EzCwd}nZYRf$>|&oycft^3DK`)7;{9Q(qgg6-OT&*M?- z4g(!gqmv7#A-U~qT*EDQ-rai6D9>8e?{g<4^!15fM%>kCB+Wl8bFD}k6>H0 zucCE`3=_6=8(6`R(iYY7u!a ztttl;qv6&AjQXK!)Y3KW0H49cv<_%5OdS}N)=w*ysH8K0ssaz5(_hkTzsrY-5F812 zEzbSMGrp1Kn2;jX`KHJ^uA6Y^U83F(#oarzMN>7F^Ii6vt)NQ=0wVU-sIcyg<1>#Q zfUphsze{x=Qz@K3iPL(_%hQ2o8cQR_#WLe=sBi57ZtVg~}bzL62ij~u_u(~u)XCywV{^11Ul z3D3(%S1a0H%O193m~_|ouCCPCxxyIy`q5ft1hTolde1Z)2LsPScE3^loXXt3DpScD zRLxP*(C7Xw)~%Ml0Qad-f_~)2Ii@Sy+pcc*_-Ot$s#0-fb&KbRRE4XT*NKkvDl#1ej_bqDQ^9L^hXu|OgE9(9z| zbP$X7Zk(oi<9O>)Zl>I(gE0uYQOgR!#^-|Ev#|+969xepnSzQc7(ktXI09iRutqc- z94bF8JCIw3CMG802!iN;86?dBGy=pj)&Cvo-!DoLe-t0ea$W2;sacAIfbLddkud4B z?-A;0aHW5@#7Y?ToOb$T9DdiAm)ElWQ|+DWbj8Qa{2Qpb${e?40U;U^IZZ$+yk^)D z92#sqv&4JYFn~-R#e2=i?ef8Gr}{%kXfRJ99CeZTN=r$}O4TOO_~^lHk(+JFO>%kv znb6asm3_JWgbSO^9A)um3-S>AGH95a_3izR(LsS!k2&-A2;_C#{WqS6H3#(6ls?-w zHHv55C~zir4*9T}YadH74cv$|BNEIA>jQjsxFPktBhHzo=4*HNM5}&XjOZ&fE_5Lb z{V6@ibtwQ2hYcILoTAB9YKv?~Fy+0+I>A~IE>g@Kb2F&mDxE80kcq{Sv0H~4Svf3P zU6>f=+0nuIA5jM=LIHPxzy=5kczW{aKH51*ogiU_1t|KxE*O%G6{A3eMk5wn-ueEY z96(rDR8dv4A3*rQa43{4GzeAo&rTz(veH`*ti!91BWhJ^98Q&Mb^GnDyH5P0_vP?L zZjViyKY#A#R9rc(t*`g>_meU*mWTxJI5E>tdHTJ1AI`TboCpo~eF)jM=;ntB(X%)p zBV!EE%sx;L)-|K6AmUdU&3Dm*Tb+uafrO8DQmZ zo(;%Nxgl^9XVd3$EG~BuIQ>#O=}b4L*SrhY8~Euy7iBKXO&G&??ScFZ27L{-uB1Qw z-=r-57~1iEJr06<%j2{W?vZ=Dy;Dj87HSMUJV|kJIG}hrSZewZHboP{;O|$eS@bhL zK~Y6V#!Vfk4C-yLLOpKCYczKl5Pl=!a72TA4QS3l1_J~|Q7{o#Z!<4X4%IL)(VTy^ zaB)0`uYw5wcu)HV%Fy$6ZjaP_Dr$j z^kmfb^C&+5sG1sXxs03wwv(34<4W4OpOP?g4`v`6C7dz3U1T`IhAE-lYtQO4u_4Xa$OxjLdKLHI#N_!+UUcKfaF;?f6~GF+M)dlp?dS zu_3RjI?XtT#Xp)6WYZLK&=vyw=(;d!OxXOGz~J-R<Z!mtSjh4WV*bFZ_mK8YR^v}IXl5n#b?Zf*mT>2}5-_h8<+ z1n&nlEfR8aW`M*&zaI1J#iGkpdyy|i$$>-KkZGq3(tg*KP)JLW(TN!+cebH6TXg%D z@`&3QNE8@(To5ncU3wlGR^z+Eqg!i88 z=Pr^v!o6CU$>Y9l?GFv(oD%UKfwG4Xb0pbSZ*5X{JQ1{TIVWsPpIB(jSR1D(uH6@~ z*qf76D^$#@eJW>FZ+Q3|XohmQ7OzOT+O|ZO?D%1X=OQ{7B~xZqK~=RI1QpD9DH1X= z9gc8cRt?|>nX|ww_W-Lam`xNW>wbI!c#&yj5ZCQ6)n3U>-lh%cA3~G`i zc!lfpn` z9a-karAAYs{Eb40IVk+Z!m7x5o^7T3Z1>L6dqLbprb=sj%;J5j_nJIm-8$EJtm4zH z8sbXQY{VBI`WampELH~II06sJTf@bY!kaZM2LuEr7aA%^NJ~_pLI-QD_gp}#`-Au= z-6r-a%fjKrnGEk#z~(t*-Q>o)@-MYUhu73SvCOFEfV<;>k8HbP4LqNz7S#QAZ3HMt zD9q0)1P5k-TN|njF|*%=Sr0}+JjU_>4SWYpD+Uv;nO7BbbRvMlZ+!HevvE?~lC?+$! zKOb)p3z048T|^>+j~iG!QFN&YW^v-9CG>(%4 zlCu`j6kq^h=6PI^E^c}DPTY5$C6F{7_VE*7W)3HCO!&|)&^D%VO6PgTc5tON+uYzU zqlExs%?zN|mbU-O84)4#i(VC97FO2+6R!%}AoF#ns8}o$Q>dfthpy7XHl*+n(BtU# z_C5}%Lp6&?IXOlA#Tl^)!5IyXl*YzJz)$xqFY6&qU_T^MWJyS(UxR+fh~Q%&h3J#& z-33SuY>}#zv~>8OC!8QV{IgGmQ4jK~*f?Ib$pW%@YoH2HQBeT^TfZOrLN^dFDFA_q z2#iHla+@FQb-|qS;|~yTff@kGoY)rysVCzb;hjiqqrA2+D$bulTRQ)spfH6eG!lRl z{7gt#+us+`)^7Aog8f^*-bFkr6oxGJjbg+kt`pe|bfKm<9k7 zspzf&$lL*H12{!+XIEQWo8fy9V5k9?4WQbr#y`G5Li@*=tIuFDR7m-Bq)`{cd%GhP*U>KElK=s@ghAYIkP=AC{qXJX>J}K zQoL}PGjM1@9Rdyxv|&3hmYXvg^blO^z@=%09o*lA3qG=1O2gpe=so+MLr_5G!}-3_Di-43WZGX z3ZGsx1A7D}2bM-62nbP$U&M|;?S=uCQ$qt648b277Nck)bIiPx$xGe8myPbfr-|P` zMNL_V6ioH|VG4hD%FWUQLZGi-sb9Z-0+F#|lQ#HDRDW;!7o98Ev0(TAkLWoOmIk~= zCBHk)G}>I@<$;tik1wl!77&iaZ))-l>=u3V@W|UtTJF;mG-ggpODly$59S9MgyApJ zPgNB(ApKN!s#Ipg{%_Q3fSZyhC?(6P5bQK&F#!A2-25j25g4@1hh7(Muw3+01J2CM zK*t_p03GF^Z;J7^orMGj`#4Z2}b7EoiGn3(jW9i|m%Sa_0PF04Ld1B-)oc6J7S z63BxAz6!R8BqOSO8j$lGf>snS^$c*nV!%E9#6wb6R{b;P784sA3j9*X%d5wBcZ-4} zf-R-!WhE|5LF>Y*DrewbC9u%JY_%B)8vFc}(|`dWwG-OV&=B~V|5IK8F=M>I1vV`j z_f=1_vlou}zpvn{k8oOo)rZVKe99A*`J;3|93>A%3JOik_QSa~`yM=6RY`THsHztOpO}RaW z+2bUN4BUEKrcU?b-pka1lssC6e-)L6mKGq_{(*s^%r7gRera$wfB>=s)Lbc!KcEZa z&!6v=)YRmhoIb6tuCh@0zu=(o$jAwNBw&4j|AB6+00jb9M~h*7#-vdTqyJUf0Oxfq_;mx$wc-muGiG6k? zk-!TqE0|$$)II_?h%@x_gDn6->MlNjK*GX;28c$%(EtJxF>C80oCzrPLe*lQ6;7;{ zbL8DVw8pE8ETj>>WKu79Ns(voqUq1-kc;c(oq>I-*(xP2zggk#C}KDpvaf%jGZU3G ztW6+2v;ed8ymlniscuW2*TwINYN#a)TGN?_%3#X@Wgn}4>#NYvP=I9qE-O<& zT6hg)&rBN0oV&9|k-fi<3?L!lA6W5fdcR z;_~h(tNPq?dq`cm?06ysyaA{_3kwS<(*WQ>%Kzl^blomcK@+dPYv!OE!TE;&uStJ4 zc4%^BhlPO(nX!k#n)kjq7UuPe8`5Bpk8vMLd2*>Mb8?YJ`_0Y>q7Os?0g z-uh6xu?6{<&J^;sX4$j%8wdr7JfB#N{w~Q5GH;_LJHOq{mDz|C%lO^-+cj?p@I3Zv zeA0W=W?78Z_w1jYT>{fs{mLdvS`Dl4uYLt#H_CmvGiOL;hDsqYU8so$-7lcCqbNS^ z8&5x0E_Jx%8}u9@*rZfNUraENeA-8H>KHb-_-Uzrxrq%LA+Tj!U$<;9pVkM7^BAC$ zXymf4%sO(OkMC=gxnBy*Jh(O-eRJ3)IlQ}mtin=ndalPFb_@1jr$mo+=CUX2v0n}6 z22$PYpe8f9N{FFzsrw<3bn~h~tZcHd`c;zfJMI((jN+AelL4kA867rRop)@EB^IXB zthTJ42UGq;&RAm|!)u)(YL#4D3%INVUwu5bk3&w^>%1qQxJAJ}7Bc(-?A5Sp4yfqv zJB9DtVe>>uev6RKT}mXgg$I7*qQD3U9)H~b?1*;X>IFWq{U*}Q{t z&J4#-_%SCX<5iO2gI_Gs3{fvVi`VirH{xab_$=ByRsowt6ZuxsO%f_Ao@s%^4z@&~&3rYgBy5JaKzP z^z^{{*_&%VO8Z+6aGroA^zS(7Nnl}nD2vf5;fV_#4aN$(+oO)F-76-#d6@qUq5ep@woWav*ksEWM!NopO|_-&*S}u#sOp0H;eIH& zq4jphptDY&BMJ_to!>3i39)Ow|nN6Bo{i*?Dh1*+adJ z{mhXyw4cUC6Sv{7tgH0|uhb*gxjgb5ZA7O^YwKO>>o4#lobPl)btImbmSPPC0C%^w^eN7P_p@qeR@>y88kTl>HF zmp+}h6y7+H12!bu@~`gFp;28Xd~wq@nkYU&hYyiQ`c7~!6a^lB<5QbEAho8+?E>G#C8)k&v_ zF`-fJ1oKYjolQmq#N5D6@fBi*+d(u$C|qEh)&1aGLpMb%qqs6x0(8JTctGN%p-~7KYkP1G=eUi4@^I={}i@9*79?EMDWr z)yMg3JKk@^Z@CL3l01BI+RbpOaqsjA|<7yb`KSn*1{Q$_N?F{?(BO~rN#HX)Uid4=vd>D)dk~hP-AGM)-Tlp_)a3rD4egpYnFF8UCN?eL1d(@dI@{ zKHP2vIj6F^bNCs;5?s{0;)j`$Zu<3*rc!vn3tKZ%q{vmfS{`A z`-TiQY)TN6C*-(4HuJKi2^Tro4NZm=nIgI$PcV-Cqu1s?WKk}H&Z9s=&|jB*W$dVS0JQT%_$;*Zcj>Dm3KmGA(dL6wxLHeB2*X zw8Z8c^>}JTjca3HGec1o{5u?1kFM@s;GNNv6_@WdcrFG=>&C+v(&#(G+gwZJuUZ~P ze=81cj~^B}y?Mr>w968SLBt3xaD)BqajZm_pjlk!hJX;T7TprX{iyzj^zF&s8H(1s z8>@&{KA(kHE9Q78K8j0htvH2B=AT?$Qqa;OHcSXqj0F#wTC(2M@jiIQBgyhScw5Cm zq?d-%c1Zo;;1Mz*=0HqKbf%|N5rQUEZf;Rtk!7dWFoXa5-1K0l;^s8bv-+@?d&gG9 zolLLjIl)m3#Ylg!Rd)jR;bF29CEQZyw|OP7!!hGe2ClPO2Z$T7RdR*b`1Ux4d-QVEN!yNL2TgQ2@1`2(TIcx}qU%ouQ0;X6B#)fiLO5{5)#-PTrzgNNYqRZpqX`3h<&%SZrPZ!?X+uNEj3pB$+hU?t21B5c@;zY{k@(P4k zpFR+5*vyM68nS@s*Jk@vjTRG>`Vn2(vZY{V`CyNZ=_)oF(3bUc74mQ{zxG6m!>%Nq1B*EcVq~e^YrS!p#%MU_E!8?+DJ^U@~Pmj>ATvFi^W8yfC; zKcS(aE9b?8Kof=T)B>Y!jQ>pIvp3Jw|8E)`fLnPM{wjhS=s*cEleL_Y(Rny>i2UGU zm7>Lj+-X>)q^37x`j#H#`X(~(EOOBKm!C(H!Ck@%c}?Q75}D1_#X0%zpaW6Zxk1@n znbzSUmsXG$NnX>*cm9&$6d5OB;}qG5#Uo;-*7+P4v)lm3cIK>`n}UqmbqlC^ zDuSv@mjs{2P=%h4%pZB@jYi}%+#GoOuG_U1?n*(|TU#GmSHRECyZ zN-V21&CRV^N5sN3HkDA_vH?67CCE(dKS+E$%a{Y*IZS}c}^t}`1R$IK}FqKk> z3jbQLC;)_I4MxTJ)mPEXGfTftmG9>wiC_{<@A7&Q~F^j>C}s6jrIMd_lb**9^YfeoMNlq z+GH{R!XfYs9iOkFdvkxQsBYDHR2uj5XE?;_rCyR=@Z-mi{-j>yGJh#rA6MjTixLXk z@(S-PFf!YkJKv3d8bLvBPIW+%7(VTZD$rY@0GZVHGIwY{F# zv19&zs7Be1ge=#Qzfc-Z7z{tZ&tO72?#w$G7q)FH63)y^Yk~OBFT-F0!)Pn&481VE zZ!mheaNF6&M$gRU7hN}A;=Y!J%=(VrD{-~Q6;)M1~qxEs-8j;8YD`?+)bP7#j3P@k_6J$ zY4QAy)vv&fK_Dq30Y$(-l!x>d3dqS!a^H9{@*P_ZV!eCzdK~f#-6WuCUC`s@xV%9E zr>NUulia^N*0Zf3T8U7^RY3ln{T}6h{so3hbI|1(lEIvvke|A%y(4nA9ObQ6J2$6ag&? zFzbvkSPBpF;IfX$JY$BKczr0 zFHI4Lvnh^E46cs^$U@m~VmG*~zE0YKB{GWs#0t3&>*KbO1b9QtkPh|Rskfo;x)>fs z3l!v4U#l%XzPeNFXj`8%+-|Y;?80E=5p!4Mz>aD;`Q4)D(3W)L25Y~ZicLNK{Op1Z z3M3Vkly2AV59#zSUu#DE?Qp^2qzeq|mRTu^@?IP6F;!ZgwF|DOUcJ^ywQHO5ykB>( z875fCT?q}Nh*Ohq`%|NKdcGB*&G}86wrh|}*3xCp=h@b)@`p*m((%tU&Gj1tW^JA) zLB4wz+8Uku6b5u0Y^Rfuk^6qdVBD)ZJdQk_hfc|#s^Jh>`777E?CiHNkg{I~3yw$y% zrBiHIJY`<%xfZZ+vog|ny-T^^wJ5{DAyjJoL}%k|#~?IZA8u4W4$8K>SLI7N&A2z? zF|#Ry&X0Vy2^3N3X+MXH9X0yhZx62Cz|T0`!FSYJtwDP~d`>KBo)>RR=OJvo#anu? zvkp4^t(f=gc?HRejn>w)HWr2dIiRqu4{RvV*^c?=RJqYHAv)|^G>k*g8 zu!sIztgv{KjKYn$5=z#Ge@K%wj0eboG2BvERv!T|4~RR7xUz@E%xWFZGzuRaKF=&v zeBX_$VKI47fAE63{dVr6`^}Y{!jU|QdY2aq3LQUtZIjZBb$v<0IKv*kqkuPdP|bD1WTXvUS;%`H}J9k<+Y>;SkQEzsQ-NbGp?!w?V%&0sx4BM zSVi}z^z6HG{Gay%R#dd*w9uqKz+GSDBwj3imD?~mfD-Uw=K21E{a;6-U*&iXm!?yu6?Gv6oXPU8@83qAn0K`zh z5l?m_*pce{jVE6!GAv9$KxbF?3ra@hNg|6@GSkC-j`e2(rq;Uios9dzXEmoRofP9O z`o~mz_Q-rpJPX9}s<;r_gh#)bEjq)l`gc}~Wr@+z#D{Tope*U54K8!#@V6-t2k=Mi z3e{Y=40>83e_*#YgCq~(kP6lPlcKR5bPK5bSv;s!f116AhLyi@XhzBEa`Ul73G| zpD>Xh52d!xuBx5y9o$;Ym&L7>qhFvII2|vf^Dla0tLeFXE9!n>$ZFD)Bt5M@W_UIy z9Poatlw)z6SQ+^6d5D}xy03wi((%01yYcQx%xXSe#9jk81`V%1hmzIg!Run*StE`+ zH!Zm9egE8T$@#BIm08J}3`v~O9C0vC90I!MgD{{sWqn}tue->M%P6X*-D*zRZsZq4VU!rW}1 z<~>ixES;o|No|oyHqOa3e;dg~_6Um^RjbQt2%*`#PkF$Tp~3<6IUoguOQJS>5gDRY z%>{$8Mvn3g`|>d_>Z#(xCuJ2;$JS&&wn8jfX)}oIWeGa-l|NQ~^&2y8-?b|RswzVx zLr|WCE<9}CU*Eg{7&}nn{HL)od~#BGu1YH5gv8(6K0p8QV6moT>-o`}pRu{-m6`#e zl1+oi)0Yq|&@d*o?1UtPXiO1wmzn!W5esCbOgP4%V?R&6Z~ zxKv!Th=P+-LlqrUu+ltC^{EqzHGN|ok+t@pr7N3vOGJkEElN$~j?T6_d;})a+nmeX z=#ePYZGBV;X~}kDw)N8a7qt=}17M~0D}b`+TaN6I|5XzFGbdhiWWMj(I;6x5g+8J0Zijc4-t_hGl~CIF0V zP&o;*uJL!P%R*l8|5c)*Z^OUkD{gbKuP|{~N1&Ou9xT>a%lqrDv#4Y?RPv<1a5LMg zaVk3cfYy#U7B2Rgz_}eirHDT=UUt*p%o@N$z<`92hbJ5`_<+rXw2DeN$7^;_-vP>~ zDA&`|SiR!v*S|Wa-O-{cb+{51+-=qJMPoxHMlt|k0~r&+Ql|=sbNIi&XJh>YnTMP5 zSZM9_DOeSH9yAt=xgLA$QQpq2hb%*Vn}Lf$Di~;TGv;dcXf9Byvna-EQNLwa6b z7=hyrdtwA6y%X+llht^keD(ap4ZC+m%~O|@ZedkP<9EnmtGNY-+oI~~aMuOji@6E< zsF>K%+UXVsu}yBO_8mFW-SbO+G25-)C8*vv=6rAcS!?2Om)$pp!pDy@wq>`Ht^|)3 zH;az#4n=1MQk>TuXr!5?H%>WI+_ONURnHDcjm+AWdJ(hy*N8cB$VL@G8t<#l0v_nN^9@KnV z>G3LC(=njLK`U7{e1&F zHj^0ZL(13-+n0*@PjtwmPgcFAnQ+lg!XxN4Ro(N* zho%meY;C91QUI2hRaSm1AP{pCkLVlF__(@O-_ORjzXir!RFTeA{ZR9?vWSeFHg-MN z#w*kjKF-b86*kw==caY2ja%K?J4^dakIRMg-F4t=Ci9H_rA|Y*h6e_4dxNoST1Qsx zv(rYcx;=K?q^l35HQ#Z3i;WL8lH(5VSu3aan3SJ9p@c{`~5Z*)}`!;?zAQRj$7v zu;v(mkMsG`PP-K!t<#;n?^Y(PyA;>;T;n=}^CH5XMSHepob2o>3AgG@9zi5CtenR@ ztKr%n4R$nvF%R6Flx2QssOYR2Ts@vCaT#Gjdv0Ol9@S@|_uW2*$Yf~n*$vBfi0#ni z3ltg+u1u~Wmuqaj46d8&MR*o8dHdHTIDJlA!af&m6t_H|EU?z`O+R_16 zAb?SWTiXpeuy{Vx)V_7GnwDL)Lac#yIpgoy?TDXo1x>DXLFVmhK%TMfg-~~xp%)N3 zD%i*#TQ}({8`Hi%j18u8y#-kNkeZ$AOYA2_J3O0VEoo*L>;c7Obyx-@*2guzgm)KeL2ej?X0x=E3N$lM97gd`Y z>gT6mY#y8$#m1+cdO&I8c8M$nkp>f@8F4~hB9!G>OUKpcK@a&BxfQOugUYNUW#6L? zbPmnTL_E2AQ$1_dmN+hg2P9uX(t>ghPb`XJtL0urxvorx-J*HI_G40cjvC;e5)=y-j-BT zD-!E^(cL`%_=3xW`lI-{7H!RXf0Vk*xbp{MZqXNuRXfYc0gS=j=SPgt;ACpfmW9DTfF=^w_3-O}x!q*y1i8K^V2a6IX4 zG7*XLC-&JXh9tWia~ORIH9n;fE15el3bh(jZBCwo3;l>+aWx3jnH;f@SQ$GvY>{ZS z@H*;^5sC3G`CQWK?l99PhoXtPnOPQM*qp$pVrl4lRz9|S>Y+#(Mi1*;Sr6D-N8e}| z-}6j5yl|}z^1fWw3vOr-Q#s2Sf}JmgmcHO8OXtT6KRI#10ITbV8`HJ1_3p>BPPIS& z?YW91>4ZDKlPd37BMOi2IQJZC4s=AcwUDiU&`gf!)@htkjz&ouu`q+91vyg7S7*Uw z&2REe{(3`Annr%LZ3}0wkk(+%=P9B2Gq)n5%!)hN)(I7VX+I1PgKVe8AKEP>%Ar}I zbeh{nWCXWVQPV!GeSd;4LDjwt*KP*YzI$1vAu}m}>vmj~+2>7~H)4M(O`)nWx6qVU zM+#kT>4(bX9(?FOdAp7*hvha=)9Ed5tI=b#gwlS}$gn;-l9Y&2XxMyJMk#s+sx1c+ z&?5&S4|7c$k%*fWb+1OY7s&KdRn#4p|GZs88rZ{_7;y>T?~hU+(M`?#-JN4U|OrGx$WSEPGM~nIz~n&$k(<#pI~7UsJcAS z;-_$wwcPXa4+!`++*FZq2x$Hm_mCwkEo&)}RstR1EjiD{eGb&r!^?&79O^=eIyVyz zDc4(~9TiqT3{Ki6q|&p}hi}xoRa)ch%c?lsT$5nYKOF!Mah!$ z*nS>wwHrQzSR*>#t)>mCf=NhF84y%s3{#mi?Z2903Bh|bK-tmMaCvIeZR51n3Egr& z-(%CNT$RU#k0eQ1&dZH7G@QRudY`C>%!SOKJTm0{4xAmCMBp+25ox@P2|_KHM<0H3 z2PeLeEFzWU;`&r@GhpfR;fAEnGjZ{|*Xv@49UA#RBm;;-l7-jz1LmD-0|optH26Ji z19a4-js0kgDsuu&Z9W4A$*A7V`%j|jaeS|ZAqS_exgTof%KS#$D{7X4w0|)1GNgC% z-%hU)?G)ytd)d> zq>3PK=QIqi{eZ6w&w8@1`Hro3(-bq6>vBfF%9BS>4ds3@$G@NCj8@Rq>vsL+?s}}| zn!z@0$#_rLxXcG#LcO3ijRsGHG`JR0d1IyK>5 z4}FAq{X-({&9K$BF={+2o`8Ohhyeujz=Yk~-^VCR-8`AdgMc6#a~7w!pcy{72?(Ty z!ANhnH;*8x#Z?cYVS!t5zf%E{fa80Yc38vx@}yp-@PV4TdU#Zn6foF}>?_QZ5CLqm zu4#XntSU1q0(Mmz4G6=61w#VbwtmD`6Jsv5dqxD1HGO z6SS^3i3`RZiEW{x{wiZ(Ij)6H)(ml%Erei8$CdP%p?gX9a3XV;dgO;Hbu7q`ZE7j# za4m&L9_ioO4kbsP1j}<TZ?ZT>i0zKQv`ed(!Q8*}5z)tG&SeHZ{5r6yLbCbpBkAtCC`RQ*++9T7;7ZB2DY4u8q*T3+erJt~@^0=wK1wvOrN zpD!f1^92fS>TixUe)tWNd4{(tx%h7wTX?gffZTM&UYs}M3tYui(H|0W2g8m7YQkq0 zcY)%N8tS2iS&*p7Zs)kH)`vY|%XRO9fh+#i-d$?@zdZ9bP<}y|e6`oSLqah4{Nl_Z zP8`Ug^0|L>Hdm4o`sPNt?s+Y$*L*r+f7_6|-C$mOuZ2di-B4D}t2ZuLv@-%kW zHeP&mdLsl|z_RUo3(k=v3}{lpyA3h=PlGkzd&`zr)+F=XvirL%XnCGNS>g#izqnz%bIqud+CVJ{?M&nN zx%tt4j933>W%4x9Tl;Bey74WuS2s`0#w+WfrcTJ{@Ac?M-2J+}T_4#4c^>p>U7j7= z^n(&wb#Cm(SBK`WySqcrJ%6D3?`(T?CHgxA@=KK?j@y{0k-?O_iP3sn`dyLADsZ<8 zPm<(3tgyaBndK|NpZ1q)EVhlN&g_DBX}j`5v=x#B>NR@Vrl7Q5He6uYFg@|1g^%z5 znz+ww;?<$xn&{sh8=jCL4~J7H34P4_KJhJDwW)A=+|kT5x7u*9v^JUw@2&}YaJ%Yy z^ z!Me|Pgf{mmT|^0KCKu&rNg%SoArjEzldcz{Vs&m0XsLXGpuL=MBWb@YEngX(7%e*j zGGlYMl z7j=wO&L%wlPsuY_+Rp@9Yzm z^)i4m7S?}js6T&ZdCn~Y4P3L}z5{*RXKE?4hbmmnkpRmtffqVl(cG0)^2~X0(OemL z^zFEaTW;^50?ZAB@?l4vk z_-{NypxvL?_rw!YuefqZv-g4@ojpPq?H z*5ao>ie;v`S2EyU9`bx?D(#XN@mr)#CZ*6|VTmIKIUY>U8x>TOxz`b_DJ#F)HN~90 zlsXB?UAorwj#D0mx7Y4d@Yr^;puac9Oi1~+!)Wenszq8p@Q8NlU_U;;xVq(=jbPsDVjTe7WUvhs1 zjW8=0yEq-mtK+`S)1h8xyF-)Mln?5MUn;J*dOD{>3h0U&u1O{~H?*o(gWL;p$qEcF7g{RXtz8d;~0t9y@}xSD|W^4V*rM z+RcQvs#_$Y>n=BpJBS*;j6vi2M>n;px!4#K^3x=L`fGh~1We=Iaat66iT5v~ly z5>xb>ewd+UiX-jQ+Dzc<>j|~9dUr@4q-kRT0}F7r?jwlVfNJ@DvS?a!G^gKlYp{+0 zAQKqT0PlK@{PF?Lk8kq{DiazqXjwSQeEP3X4eCEBQO_N^*$GkKr-dqbz^PeEtH%vw zZqw`B08seT2W@80Dt>JXSKnX&KlfT*9uQ%%0F^v_Z2hgLBBjIV+KjgU-=$5HdBu7r zk7rHW#|!pCc8klTRHTw_Zf+SuviS5;@)Q&lsAgYRaP%|)&dQV_oNHeZaBLEZM0=Y` zDj-ktiy-*<)8V(pMcrXf{XM9~ z2)8V_F@gl$NnD9#Wo5XUUKA3D{dd6Vyt9+lMI@QLd|#L{k6DR6*V=$fChHD zYFmu=Kpb8P?3(H0H$GtjOS9N+X$8k;?}Mb5W`k7o>gp0fObT-E-e+Jp58{enL0lFy z%aFYTxlaMt?bol{1*3lPx6ppiqmMSvLvnIfG)kVvg1E7gS0kX}yDBM!#DHL~Sww~^ z=!v`d`1rhJuRs9T3>%P{f&a*h$MLP0nDMjMK=2SiM02CbqWrb|I}ln<_h;qgY`3Wd zp*Fyr#;n27|3c3LsTrIfMQMovAzNpS02Jhe%gNz`Z_$6MMJk1f4)+O}=dxpB*E3&( zf&eMKDSZ4ct}iC`Jl_);Q-cXAufsqS0F%XBwd8Q~QA~||%7)3ne{@PSEV*7#hYq37 z;NXEhf7Q|&M=3w0|6YZ>sG8lGYX!cXFx8ekX%G!xP!;74$p z^}n^WNC0X(i0uTm+jo6N;6Uhg(g4>VXbV2Q^Z|CC|9v8Y6gM2?4d5W}mP;v)!eWqO zhiPjE_BtWDUjMH^#~qv-{NhX^B7{Nh6C3RaW}n*w1i*6?gv5cV2XKuerJx9aBxERV^Yb1s zUERJk$pDbp3aD-faeePggAU?s)_)^J_m!_>d4JAcsFVB2BNidb$Z`0;9v+aOnS_lQ zmOw~J8NIbYPY-u)I+c1~dkKA9V`_((iXf=15nw^^?X-HuY(kQ5@}lBLA>haZMcn_Y zmY504l{Fi}&FJ(Sn$rgm5U7}0peba2VIKJIefu{^{LDx|FI(Ru<@w(G%UqSd&+gMp zER=WugOf|I!J(lN!00-GWGgBuh29sxP2XmIhr#qO0RpuEv}(Vek1i zi%T^@8jqQnq`=#Tx;CA_@XRSVz*I0KB%0j{Gqd!tu-^b9hPE~c@VNgkD7NA_r-j5H z+>|M!1o#jP$4&?2$l7qCGBH_<>wRC{!UC#x<5!6|6Y!D$^G6Ge&RXZ~4*lOiL;;eN z?XiKSo)pXl0JgERadntIi-;Q5C@jXO_xpwgqxb>S9?Ba7*rDYZ*MHa{!2Mjy!7Ras zrVs~AE6vTdwxQZV(tuAuu!xyI->~c%=;`UTNbey8DebPDZ`3D9HTUaomErq0yfXR!QL5@NL z>x?B@1wakQ8VpG%ubk|?x;$SU&W*e;nfQ@&exmMGMw<1c6OgGGR?=zr{QftsA1A@V zN((Sb%$yEr{iH;p1SAy(1_rPP{|1OsIZ%ASU=yk;Dt1$OYe4XKPYOK1-~u`Z0Arwq z0OlyWZvU@vA5M~z40s%f^-!Ge&7MB^OGYM<7#qrk&U^C&Bz1^rf9nsCDAT$orX~7f UeuItq3Jd(nNh?VeO6Y(7Ke@pFt^fc4 literal 0 HcmV?d00001 From ed98a2070e72bfc2043a5ee1c5c59e41cff44b3f Mon Sep 17 00:00:00 2001 From: Chris Birchall Date: Tue, 14 Jan 2020 07:44:07 +0000 Subject: [PATCH 045/217] Fix some typos in the docs (#76) --- docs/docs/README.md | 2 +- docs/docs/db.md | 12 ++++++------ docs/docs/grpc.md | 9 +++++---- docs/docs/intro.md | 35 ++++++++++++++++++++--------------- docs/docs/rpc.md | 6 +++--- docs/docs/schema.md | 2 +- templates/grpc-server.hsfiles | 1 + 7 files changed, 37 insertions(+), 30 deletions(-) diff --git a/docs/docs/README.md b/docs/docs/README.md index 575a09c9..8f97e026 100644 --- a/docs/docs/README.md +++ b/docs/docs/README.md @@ -6,7 +6,7 @@ permalink: / # Docs for Mu-Haskell -Mu-Haskell is a set of packages that help you build both servers and clients for (micro)services. The main goal of Mu-Haskell is to make you focus on your domain logic, instead of worrying about format and protocol issues. +Mu-Haskell is a set of packages that help you build both servers and clients for (micro)services. The main goal of Mu-Haskell is to allow you to focus on your domain logic, instead of worrying about format and protocol issues. * [Introduction]({% link docs/intro.md %}) * [Schemas]({% link docs/schema.md %}) diff --git a/docs/docs/db.md b/docs/docs/db.md index 109884d4..9da32326 100644 --- a/docs/docs/db.md +++ b/docs/docs/db.md @@ -31,7 +31,7 @@ service PersistentService { Maybe this example looks a bit contrived but bear with me, it covers a common use case when working with protobuf: that one of the messages has another message as its identifying key. -## Definning our Schema +## Defining our Schema You are going to need to enable the following extensions: @@ -119,13 +119,13 @@ deriving via (WithEntityNestedId "Person" PersonFieldMapping (Entity Person)) instance ToSchema Maybe PersistentSchema "Person" (Entity Person) ``` -Have in mind that we still need to define our own custom field mapping, in this case `PersonFieldMapping` so that the deriving via does it's job properly. +Have in mind that we still need to define our own custom field mapping, in this case `PersonFieldMapping` so that the deriving via does its job properly. ## Running a pool of database connections Now let's focus on the Server! -All you need to do is open one time the database, and share the connection across all your services: +All you need to do is open the database once, and share the connection across all your services: ```haskell {-# language FlexibleContexts #-} @@ -147,7 +147,7 @@ main = liftIO $ runGRpcApp 8080 (server conn) ``` -We have decided in this example to use `LoggintT` from `monad-logger` and `runStderrLoggingT` to get some basic database logs to the console for free, but this is not a must! +We have decided in this example to use `LoggingT` from `monad-logger` and `runStderrLoggingT` to get some basic database logs to the console for free, but this is not a must! ## This actually does not work @@ -191,7 +191,7 @@ allPeople conn sink = runDb conn $ As you can see, all the services need to be passed the `SqlBackend` connection as an argument. -Two interesting things we want to highlight here: we have provided a small helper called `runDb`, it's implementation is quite simple and it exists due to **developer ergonomics**. We are basically saving you from writing lots of `liftIO $ flip runSqlPersistM`. 😉 +Two interesting things we want to highlight here: we have provided a small helper called `runDb`, its implementation is quite simple and it exists due to **developer ergonomics**. We are basically saving you from writing lots of `liftIO $ flip runSqlPersistM`. 😉 The second one will be discussed in the next section. @@ -212,7 +212,7 @@ liftServerConduit => ConduitT a b ServerErrorIO r -> ConduitT a b m r ``` -What is this type signature telling us? That is, we can turn any of the Conduits given as input, which work on the `ServerErrorIO` Monad from `mu-rpc`, into a Conduit working on other `IO`-like Monad. This is the case, in particular, of the Monad in which Persistent runs. +What is this type signature telling us? That is, we can turn any of the Conduits given as input, which work on the `ServerErrorIO` Monad from `mu-rpc`, into a Conduit working on another `IO`-like Monad. This is the case, in particular, of the Monad in which Persistent runs. And that concludes our round-trip! diff --git a/docs/docs/grpc.md b/docs/docs/grpc.md index d99c5e6c..56deb81e 100644 --- a/docs/docs/grpc.md +++ b/docs/docs/grpc.md @@ -10,7 +10,7 @@ Mu-Haskell defines a generic notion of service and server that implements it. Th ## Running the server with `mu-grpc` -The combination of the declaration of a service API and a corresponding implementation as a `Server` may served directly using a concrete wire protocol. One example is gRPC, provided by our sibling library `mu-grpc`. The following line starts a server at port `8080`, where the service can be found under the package name `helloworld`: +The combination of the declaration of a service API and a corresponding implementation as a `Server` may be served directly using a concrete wire protocol. One example is gRPC, provided by our sibling library `mu-grpc`. The following line starts a server at port `8080`, where the service can be found under the package name `helloworld`: ```haskell main = runGRpcApp 8080 "helloworld" quickstartServer @@ -47,8 +47,6 @@ main = do Where `watch`, `get` and `add` are the only valid 3 commands that our CLI is going to accept and call each respective service. -If you are not familiar with `TypeApplications`, you can check [this](https://www.reddit.com/r/haskell/comments/6ufnmr/scrap_your_proxy_arguments_with_typeapplications/), [that](https://blog.sumtypeofway.com/posts/fluent-polymorphism-type-applications.html) and [this](https://kseo.github.io/posts/2017-01-08-visible-type-application-ghc8.html). - ### Using records This option is a bit more verbose but it's also more explicit with the types and _"a bit more magic"_ than the one with `TypeApplications` (due to the use of Generics). @@ -66,7 +64,7 @@ data Call = Call } deriving Generic ``` -Note that we had to derive `Generic`. We also need to tweak a little bit our `main` function: +Note that we had to derive `Generic`. We also need to tweak our `main` function a little bit: ```diff main :: IO () @@ -113,6 +111,9 @@ watching client = do With `TypeApplications` none of the above is needed, all you need to do is call `gRpcCall` with the appropiate service name as a type-level string, and the rest just _magically_ works! ✨ +If you are not familiar with `TypeApplications`, you can check [this](https://www.reddit.com/r/haskell/comments/6ufnmr/scrap_your_proxy_arguments_with_typeapplications/), [that](https://blog.sumtypeofway.com/posts/fluent-polymorphism-type-applications.html) and [this](https://kseo.github.io/posts/2017-01-08-visible-type-application-ghc8.html). + + ```haskell import Mu.GRpc.Client.TyApps diff --git a/docs/docs/intro.md b/docs/docs/intro.md index 186f0add..b034973f 100644 --- a/docs/docs/intro.md +++ b/docs/docs/intro.md @@ -6,16 +6,16 @@ permalink: intro/ # Introduction to Mu-Haskell -Many companies have embraced microservices architectures as the best way to scale up their internal software systems, separate work across different company divisions and development teams. Microservices architectures also allow teams to turn an idea or bug report into a working feature of fix in production more quickly, in accordance to the agile principles. +Many companies have embraced microservices architectures as the best way to scale up their internal software systems, and separate work across different company divisions and development teams. Microservices architectures also allow teams to turn an idea or bug report into a working feature or fix in production more quickly, in accordance to the agile principles. -However, microservices are not without costs. Every connection between microservices becomes now a boundary that requires one to act as a server, and the other to act as the client. Each part implementation needs to add the protocol, the codification of the data for transmission, etc. Also, business logic of the application starts to spread around several code bases, making it difficult to maintain. +However, microservices are not without costs. Every connection between microservices becomes now a boundary that requires one service to act as a server, and the other to act as the client. Each service needs to include an implementation of the protocol, the encoding of the data for transmission, etc. The business logic of the application also starts to spread around several code bases, making it difficult to maintain. ## What is Mu-Haskell? -The main goal of Mu-Haskell is to make you focus on your domain logic, instead of worrying about format and protocol issues. To achieve this goal, Mu-Haskell provides two sets of packages: +The main goal of Mu-Haskell is to allow you to focus on your domain logic, instead of worrying about format and protocol issues. To achieve this goal, Mu-Haskell provides two sets of packages: * `mu-schema` and `mu-rpc` define schemas for data and services, in a format- and protocol-independent way. These schemas are checked at compile-time, so you also gain an additional layer of type-safety. -* `mu-avro`, `mu-protobuf`, `mu-grpc` (and other to come) implement each concrete format and protocol, following the interfaces laid out by the former two. In addition, most of those packages can turn a schema in the corresponding format into the corresponding one in `mu-schema` and `mu-rpc` terms, alleviating you from the need of duplicating definitions. +* `mu-avro`, `mu-protobuf`, `mu-grpc` (and other to come) implement each concrete format and protocol, following the interfaces laid out by the former two. In addition, most of those packages can turn a schema in the corresponding format into the corresponding one in `mu-schema` and `mu-rpc` terms, alleviating the need to duplicate definitions. ## Quickstart @@ -42,10 +42,12 @@ message HelloReply { string message = 1; } To get started with the project, we provide a [Stack](https://docs.haskellstack.org) template (in fact, we recommend that you use Stack as your build tool, although Cabal should also work perfectly fine). You should run: ``` -stack new my-project https://raw.githubusercontent.com/higherkindness/mu-haskell/master/templates/grpc-server.hsfiles -p "author-email:your@email.com" -p "author-name:Your name" +stack new my_project https://raw.githubusercontent.com/higherkindness/mu-haskell/master/templates/grpc-server.hsfiles -p "author-email:your@email.com" -p "author-name:Your name" ``` -This command creates a new folder called `my-project`, with a few files. The most important from those are the `.proto` file, in which you shall declare your service; `src/Schema.hs`, which loads the service definition at compile-time; and `src/Main.hs`, which contains the code of the server. +**WARNING:** Do not include a hyphen in your project name, as it will cause the template to generate a '.proto' file containing an invalid package name. Use `my_project`, not `my-project`. + +This command creates a new folder called `my_project`, with a few files. The most important from those are the `.proto` file, in which you will define your service; `src/Schema.hs`, which loads the service definition at compile-time; and `src/Main.hs`, which contains the code of the server. The first step to get your project running is defining the right schema and service. In this case, you can just copy the definition above after the `package` declaration. @@ -59,26 +61,29 @@ The aforementioned `.proto` file defines two messages. The corresponding data ty data HelloRequestMessage = HelloRequestMessage { name :: Maybe T.Text } deriving (Eq, Show, Generic - , ToSchema Maybe Schema "HelloRequest" - , FromSchema Maybe Schema "HelloRequest") + , ToSchema Maybe TheSchema "HelloRequest" + , FromSchema Maybe TheSchema "HelloRequest") data HelloReplyMessage = HelloReplyMessage { message :: Maybe T.Text } deriving (Eq, Show, Generic - , ToSchema Maybe Schema "HelloReply", - , FromSchema Maybe Schema "HelloReply") + , ToSchema Maybe TheSchema "HelloReply" + , FromSchema Maybe TheSchema "HelloReply") ``` -You can give those data types and their constructors any name you like. However, keep in mind that: +These data types should be added to the file `src/Schema.hs`, under the line that starts `grpc ...`. (See the [gRPC page]({% link docs/grpc.md %}) for information about what that line is doing.) + +You can give the data types and their constructors any name you like. However, keep in mind that: * The names of the fields must correspond with those in the `.proto` files. Otherwise you have to use a *custom mapping*, which is fully supported by `mu-schema` but requires more code. * All the fields must be wrapped in `Maybe` since all fields in `proto3` are **optional by default**. +* The name `TheSchema` refers to a type generated by the `grpc` function, so it must match the first argument to that function. * The name between quotes in each `deriving` clause defines the message type in the `.proto` file each data type corresponds to. * To use the automatic-mapping functionality, it is required to also derive `Generic`, don't forget it! #### Server implementation -If you try to compile the project right now by means of `stack build`, you will receive an error about `server` not having the right type. This is because you haven't defined yet any implementation for your service. This is one of the advantages of making the compiler aware of your service definitions: if the `.proto` file changes, you need to adapt your code correspondingly, or otherwise the project doesn't even compile! +If you try to compile the project right now by means of `stack build`, you will receive an error about `server` not having the right type. This is because you haven't yet defined any implementation for your service. This is one of the advantages of making the compiler aware of your service definitions: if the `.proto` file changes, you need to adapt your code correspondingly, or otherwise the project doesn't even compile! Open the `src/Main.hs` file. The contents are quite small right now: a `main` function asks to run the gRPC service defined by `server`. The `server` function, on the other hand, declares that it implements the `Service` service in its signature, but contains no implementations. @@ -90,17 +95,17 @@ server :: (MonadServer m) => ServerT Maybe Service m _ server = Server H0 ``` -The simplest way to provide an implementation for a service is to define one function for each method. You define those functions completely in terms of Haskell data types; in our case `HelloRequestMessage` and `HelloReplyMessage`. Here is a simple definition: +The simplest way to provide an implementation for a service is to define one function for each method. You define those functions completely in terms of Haskell data types; in our case `HelloRequestMessage` and `HelloReplyMessage`. Here is an example definition: ```haskell sayHello :: (MonadServer m) => HelloRequestMessage -> m HelloReplyMessage sayHello (HelloRequestMessage nm) - = return $ HelloReplyMessage ("hello, " ++ nm) + = return (HelloReplyMessage (("hi, " <>) <$> nm)) ``` The `MonadServer` portion in the type is mandated by `mu-rpc`; it tells us that in a method we can perform any `IO` actions and additionally throw server errors (for conditions such as *not found*). We do not make use of any of those here, so we simply use `return` with a value. We could even make the definition a bit more polymorphic by replacing `MonadServer` by `Monad`. -How does `server` know that `sayHello` is part of the implementation of the service? We have to tell it, by adding `sayHello` to the list of methods. Unfortunately, we cannot use a simple lists, so we use `(:<|>:)` to join them, and `H0` to finish it. +How does `server` know that `sayHello` is part of the implementation of the service? We have to tell it, by adding `sayHello` to the list of methods. Unfortunately, we cannot use a normal list, so we use `(:<|>:)` to join them, and `H0` to finish it. ```haskell server = Server (sayHello :<|>: H0) diff --git a/docs/docs/rpc.md b/docs/docs/rpc.md index eafadc55..9a5ceb0b 100644 --- a/docs/docs/rpc.md +++ b/docs/docs/rpc.md @@ -43,7 +43,7 @@ This is everything you need to start using gRPC services and clients in Haskell! ### Looking at the resulting code -In order to use the library proficiently, we should look a bit at the code generated in the previous code. A type-level description of the messages is put into the type `QuickstartSchema`. However, there is some code you still have to write by hand, namely the Haskell type which correspond to that schema. Using `mu-schema` facilities, this amounts to declaring a bunch of data types and including `deriving (Generic, ToSchema Maybe Schema "type", FromSchema Maybe Schema "type")` at the end of each of them. +In order to use the library proficiently, we should look a bit at the code generated in the previous sample. A type-level description of the messages is put into the type `QuickstartSchema`. However, there is some code you still have to write by hand, namely the Haskell type which correspond to that schema. Using `mu-schema` facilities, this amounts to declaring a bunch of data types and including `deriving (Generic, ToSchema Maybe "", FromSchema Maybe "")` at the end of each of them. ```haskell {-# language PolyKinds, DataKinds, TypeFamilies #-} @@ -78,7 +78,7 @@ newtype HelloResponse , FromSchema Maybe QuickstartSchema "HelloResponse") ``` -The service declaration looks very similar to an schema declaration, but instead of record and enumerations you define *methods*. Each method has a name, a list of arguments, and a return type. +The service declaration looks very similar to a schema declaration, but instead of records and enumerations you define *methods*. Each method has a name, a list of arguments, and a return type. ```haskell import Mu.Rpc @@ -91,7 +91,7 @@ type QuickstartService ('RetSingle ('FromSchema QuickstartSchema "HelloResponse")) ] ``` -In order to support both [Avro IDL](https://avro.apache.org/docs/current/idl.html) and [gRPC](https://grpc.io/), the declaration of the method arguments and returns in a bit fancier that you might expect: +In order to support both [Avro IDL](https://avro.apache.org/docs/current/idl.html) and [gRPC](https://grpc.io/), the declaration of the method arguments and return types is a bit fancier than you might expect: * Each *argument* declares the schema type used for serialization. Furthermore, the argument can be declared as `ArgSingle` (only one value is provided by the client) or `ArgStream` (a stream of values is provided). * The *return types* gives the same two choices under the names `RetSingle` or `RetStream`, and additionally supports the declaration of methods which may raise exceptions using `RetThrows`, or methods which do not retun any useful information using `RetNothing`. diff --git a/docs/docs/schema.md b/docs/docs/schema.md index 69d7697e..57f2b4a2 100644 --- a/docs/docs/schema.md +++ b/docs/docs/schema.md @@ -102,7 +102,7 @@ Once again, you need to enable some extensions in the compiler (but do not worry ## Customizing the mapping -Sometimes the names of the fields in the Haskell data type and the names of the fields in the schema do not match. For example, in our schema above we use `male`, `female`, and `nb`, but in a Haskell enumeration the name of each constructor must begin with a capital letter. By using a stand-along `ToSchema` instance you can declare a custom mapping from Haskell fields or constructors to schema fields or enum choices, respectively: +Sometimes the names of the fields in the Haskell data type and the names of the fields in the schema do not match. For example, in our schema above we use `male`, `female`, and `nb`, but in a Haskell enumeration the name of each constructor must begin with a capital letter. By using a standalone `ToSchema` instance you can declare a custom mapping from Haskell fields or constructors to schema fields or enum choices, respectively: ```haskell {-# language DerivingVia #-} diff --git a/templates/grpc-server.hsfiles b/templates/grpc-server.hsfiles index 59a49327..bcbd9241 100644 --- a/templates/grpc-server.hsfiles +++ b/templates/grpc-server.hsfiles @@ -96,6 +96,7 @@ grpc "TheSchema" id "{{name}}.proto" {-# START_FILE src/Main.hs #-} {-# language FlexibleContexts #-} {-# language PartialTypeSignatures #-} +{-# language OverloadedStrings #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} module Main where From 081e61047e70763db6574694fa62a33a8fdfc122 Mon Sep 17 00:00:00 2001 From: Alejandro Serrano Date: Thu, 16 Jan 2020 10:11:38 +0100 Subject: [PATCH 046/217] Various fixes to make gRPC server work (#84) * Better capture exceptions in gRPC server * Require Warp < 3.3 * Adjust template to work correctly --- grpc/server/mu-grpc-server.cabal | 6 +++--- grpc/server/src/Mu/GRpc/Server.hs | 6 ++++++ templates/grpc-server.hsfiles | 4 ++-- 3 files changed, 11 insertions(+), 5 deletions(-) diff --git a/grpc/server/mu-grpc-server.cabal b/grpc/server/mu-grpc-server.cabal index ed29bf77..4950c1e1 100644 --- a/grpc/server/mu-grpc-server.cabal +++ b/grpc/server/mu-grpc-server.cabal @@ -1,6 +1,6 @@ cabal-version: >=1.10 name: mu-grpc-server -version: 0.1.0.0 +version: 0.1.0.1 synopsis: gRPC servers for Mu definitions description: With @mu-grpc-server@ you can easily build gRPC servers for mu-haskell! license: Apache-2.0 @@ -34,7 +34,7 @@ library , stm , stm-conduit , wai - , warp + , warp < 3.3 , warp-grpc , warp-tls hs-source-dirs: src @@ -59,7 +59,7 @@ executable grpc-example-server , stm , stm-conduit , wai - , warp + , warp < 3.3 , warp-grpc , warp-tls hs-source-dirs: src diff --git a/grpc/server/src/Mu/GRpc/Server.hs b/grpc/server/src/Mu/GRpc/Server.hs index 56fa774e..066c2fd2 100644 --- a/grpc/server/src/Mu/GRpc/Server.hs +++ b/grpc/server/src/Mu/GRpc/Server.hs @@ -32,6 +32,7 @@ module Mu.GRpc.Server import Control.Concurrent.Async import Control.Concurrent.STM (atomically) import Control.Concurrent.STM.TMVar +import Control.Exception import Control.Monad.Except import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as BS @@ -179,6 +180,11 @@ raiseErrors h Left (ServerError code msg) -> closeEarly $ GRPCStatus (serverErrorToGRpcError code) (BS.pack msg) + `catches` + [ Handler (\(e :: GRPCStatus) -> throwIO e) + , Handler (\(e :: SomeException) -> closeEarly $ GRPCStatus INTERNAL (BS.pack $ show e)) + ] + where serverErrorToGRpcError :: ServerErrorCode -> GRPCStatusCode serverErrorToGRpcError Unknown = UNKNOWN diff --git a/templates/grpc-server.hsfiles b/templates/grpc-server.hsfiles index bcbd9241..fcd7a164 100644 --- a/templates/grpc-server.hsfiles +++ b/templates/grpc-server.hsfiles @@ -25,14 +25,14 @@ executable {{name}} mu-grpc-server {-# START_FILE stack.yaml #-} -resolver: lts-14.20 +resolver: lts-14.17 allow-newer: true extra-deps: # mu - mu-schema-0.1.0.0 - mu-rpc-0.1.0.0 - mu-protobuf-0.1.0.0 -- mu-grpc-server-0.1.0.0 +- mu-grpc-server-0.1.0.1 - compendium-client-0.1.0.1 # dependencies of mu - http2-client-0.9.0.0 From 19e5c966161a391fbcc33b2641afc49129b694e7 Mon Sep 17 00:00:00 2001 From: Flavio Corpa Date: Thu, 23 Jan 2020 12:59:44 +0100 Subject: [PATCH 047/217] =?UTF-8?q?Allow=20newer=20versions=20of=20Stack?= =?UTF-8?q?=20(lts-14.20)=20=F0=9F=86=95=20(#91)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- default.nix | 2 +- grpc/server/mu-grpc-server.cabal | 4 ++-- stack-nightly.yaml | 4 ++-- stack.yaml | 4 ++-- templates/grpc-server.hsfiles | 4 ++-- 5 files changed, 9 insertions(+), 9 deletions(-) diff --git a/default.nix b/default.nix index 88e0ca23..e581c393 100644 --- a/default.nix +++ b/default.nix @@ -1,5 +1,5 @@ { nixpkgs ? (fetchTarball https://github.com/NixOS/nixpkgs/archive/b1844ef5816b0af8bc2f6215054279ea35e29b77.tar.gz) -, pkgs ? import nixpkgs (import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/83966f3.tar.gz)) +, pkgs ? import nixpkgs (import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/674cdf2.tar.gz)) }: let diff --git a/grpc/server/mu-grpc-server.cabal b/grpc/server/mu-grpc-server.cabal index 4950c1e1..2ae8eb7e 100644 --- a/grpc/server/mu-grpc-server.cabal +++ b/grpc/server/mu-grpc-server.cabal @@ -34,7 +34,7 @@ library , stm , stm-conduit , wai - , warp < 3.3 + , warp , warp-grpc , warp-tls hs-source-dirs: src @@ -59,7 +59,7 @@ executable grpc-example-server , stm , stm-conduit , wai - , warp < 3.3 + , warp , warp-grpc , warp-tls hs-source-dirs: src diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 8cc58c89..fa31883f 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -1,4 +1,4 @@ -resolver: nightly-2019-12-12 +resolver: nightly-2020-01-23 allow-newer: true packages: @@ -21,7 +21,7 @@ extra-deps: - http2-grpc-types-0.5.0.0 - proto3-wire-1.1.0 - http2-grpc-proto3-wire-0.1.0.0 -- warp-grpc-0.2.0.0 +- warp-grpc-0.3.0.0 - http2-client-grpc-0.8.0.0 - avro-0.4.5.4 - language-protobuf-1.0 diff --git a/stack.yaml b/stack.yaml index 61b94b44..af045b3a 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-14.17 +resolver: lts-14.21 allow-newer: true packages: @@ -21,7 +21,7 @@ extra-deps: - http2-grpc-types-0.5.0.0 - proto3-wire-1.1.0 - http2-grpc-proto3-wire-0.1.0.0 -- warp-grpc-0.2.0.0 +- warp-grpc-0.3.0.0 - http2-client-grpc-0.8.0.0 - avro-0.4.5.4 - language-protobuf-1.0 diff --git a/templates/grpc-server.hsfiles b/templates/grpc-server.hsfiles index fcd7a164..770f7d5f 100644 --- a/templates/grpc-server.hsfiles +++ b/templates/grpc-server.hsfiles @@ -25,7 +25,7 @@ executable {{name}} mu-grpc-server {-# START_FILE stack.yaml #-} -resolver: lts-14.17 +resolver: lts-14.21 allow-newer: true extra-deps: # mu @@ -38,7 +38,7 @@ extra-deps: - http2-client-0.9.0.0 - http2-grpc-types-0.5.0.0 - http2-grpc-proto3-wire-0.1.0.0 -- warp-grpc-0.2.0.0 +- warp-grpc-0.3.0.0 - proto3-wire-1.1.0 - language-protobuf-1.0 From c24a55d83c7786ef040f188cb68f8776fad6a41a Mon Sep 17 00:00:00 2001 From: Juan Valencia Date: Fri, 24 Jan 2020 16:42:23 +0100 Subject: [PATCH 048/217] =?UTF-8?q?Set=20new=20Mu=20visual=20identity=20fo?= =?UTF-8?q?r=20the=20website=20=F0=9F=92=85=20(#92)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- docs/_config.yml | 8 +- docs/_includes/_doc.html | 9 +- docs/_includes/_footer.html | 8 +- docs/_includes/_head-docs.html | 17 +++- docs/_sass/base/_base.scss | 3 +- docs/_sass/components/_button.scss | 2 +- docs/_sass/components/_doc.scss | 46 +++++++++- docs/_sass/components/_sidebar-menu.scss | 33 +++---- docs/_sass/components/_sidebar.scss | 6 +- docs/_sass/utils/_variables.scss | 4 +- docs/docs/README.md | 2 +- docs/docs/db.md | 2 +- docs/docs/grpc.md | 2 +- docs/docs/intro.md | 2 +- docs/docs/middleware.md | 2 +- docs/docs/registry.md | 2 +- docs/docs/rpc.md | 2 +- docs/docs/schema.md | 2 +- docs/docs/stream.md | 2 +- docs/docs/transformer.md | 2 +- docs/img/favicon.png | Bin 2216 -> 3791 bytes docs/img/nav-brand-white.svg | 108 ++--------------------- docs/img/nav-brand.svg | 108 ++--------------------- docs/img/poster.png | Bin 43878 -> 55178 bytes docs/js/docs.js | 28 +++--- 25 files changed, 134 insertions(+), 266 deletions(-) diff --git a/docs/_config.yml b/docs/_config.yml index 17926bce..133b9c69 100755 --- a/docs/_config.yml +++ b/docs/_config.yml @@ -1,13 +1,17 @@ -title: Mu-Haskell #------------------------- name: Mu-Haskell #------------------------- +title: Mu-Haskell # To be used on meta tags mainly +#------------------------- description: Mu is a purely functional library for building microservices. #------------------------- author: 47 Degrees keywords: functional-programming, monads, monad-transformers, functional-data-structure, swift, bow, fp-types, adt, free-monads, tagless-final, mtl, for-comprehension, category-theory #------------------------- -url: https://www.47deg.com +github-owner: higherkindness +github-repo: mu-haskell +#------------------------- +url: https://higherkindess.io/mu-haskell #------------------------- markdown: kramdown sass: diff --git a/docs/_includes/_doc.html b/docs/_includes/_doc.html index 7e219d9a..501ce2a1 100644 --- a/docs/_includes/_doc.html +++ b/docs/_includes/_doc.html @@ -5,15 +5,18 @@ type="button" class="button doc-toggle" title="Toggle"> - Toggle + Toggle
- API Docs + API Docs
- GitHub + + GitHub + +
diff --git a/docs/_includes/_footer.html b/docs/_includes/_footer.html index c627ebac..3679b340 100755 --- a/docs/_includes/_footer.html +++ b/docs/_includes/_footer.html @@ -2,9 +2,11 @@
-

mu-haskell is designed and developed by - {{ site.name }} - with support from 47 Degrees

+

+ Mu-Haskell is designed and developed by + {{ site.name }} + with support from 47 Degrees +