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/.github/workflows/deploy.yml b/.github/workflows/deploy.yml new file mode 100644 index 00000000..b2a6dfe4 --- /dev/null +++ b/.github/workflows/deploy.yml @@ -0,0 +1,64 @@ +name: Deploy +on: + push: + branches: + - master +jobs: + build: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v2.3.4 + with: + submodules: true + - name: Unshallow + run: git fetch --prune --unshallow + - uses: serras/setup-stack@v3 + - uses: actions/cache@v2.1.3 + name: Cache ~/.stack + with: + path: ~/.stack + key: ${{ runner.os }}-stack-${{ hashFiles('stack.yaml') }} + restore-keys: | + ${{ runner.os }}-stack- + - uses: actions/cache@v2.1.3 + name: Cache .stack-work + with: + path: .stack-work + key: ${{ runner.os }}-stack-work-${{ hashFiles('stack.yaml') }}-${{ '**/*.hs' }} + restore-keys: | + ${{ runner.os }}-stack-work- + - name: Get rdkafka + run: sudo apt-get install librdkafka-dev + - name: Get Ruby and Bundler + uses: ruby/setup-ruby@v1 + with: + bundler: 2.1.2 + ruby-version: 2.6 + - name: Build microsite without Haddock + run: | + bundle config set path 'vendor/bundle' + bundle install --gemfile docs/Gemfile + BUNDLE_GEMFILE=./docs/Gemfile bundle exec jekyll build -b /mu-haskell -s docs -d gen-docs + - name: Get Standalone Haddock + run: stack --resolver lts-14.27 install standalone-haddock + - name: Build microsite from last release + run: | + LAST_TAG=$(git describe --abbrev=0 --tags) + git checkout $LAST_TAG + bash ./generate-haddock-docs.sh + bundle config set path 'vendor/bundle' + bundle install --gemfile docs/Gemfile + BUNDLE_GEMFILE=./docs/Gemfile bundle exec jekyll build -b /mu-haskell -s docs -d gen-docs + - name: Build microsite from master + run: | + git checkout master + bash ./generate-haddock-docs.sh + bundle config set path 'vendor/bundle' + bundle install --gemfile docs/Gemfile + BUNDLE_GEMFILE=./docs/Gemfile bundle exec jekyll build -b /mu-haskell/wip -s docs -d gen-docs/wip + - 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 new file mode 100644 index 00000000..0863b33a --- /dev/null +++ b/.github/workflows/haskell.yml @@ -0,0 +1,22 @@ +name: Haskell CI +on: [push] +jobs: + build: + runs-on: ubuntu-latest + steps: + - uses: actions/checkout@v2.3.4 + with: + submodules: true + - uses: cachix/install-nix-action@v12 + - uses: cachix/cachix-action@v8 + with: + name: 47deg + signingKey: '${{ secrets.CACHIX_SIGNING_KEY }}' + - run: nix-build + - name: 'Set up HLint' + uses: rwe/actions-hlint-setup@v1.0.2 + - name: 'Run HLint' + uses: rwe/actions-hlint-run@v2.0.1 + with: + path: '["core/schema/src/", "core/rpc/src/", "core/optics/src/", "core/lens/src/", "adapter/avro/src/", "adapter/protobuf/src/", "adapter/persistent/src/", "adapter/kafka/src/", "grpc/common/src/", "grpc/client/src/", "grpc/server/src/", "graphql/src/", "servant/server/src/", "instrumentation/prometheus/src/", "instrumentation/tracing/src/" ]' + fail-on: warning diff --git a/.gitignore b/.gitignore index cd1d2f1e..e5789b7a 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,20 @@ stack*.yaml.lock -.* +.stack-work *~ -dist -*.pyc \ No newline at end of file +dist* +*.pyc +.*sw? + +## User files +.DS_Store + +## Jekyll +_site +.sass-cache +.jekyll-metadata +.jekyll-cache + +## Ruby environment normalization: +.bundle/ +/docs/vendor/ +docs/haddock diff --git a/.gitmodules b/.gitmodules new file mode 100644 index 00000000..629c7e2b --- /dev/null +++ b/.gitmodules @@ -0,0 +1,3 @@ +[submodule "examples/library"] + path = examples/library + url = https://github.com/higherkindness/mu-graphql-example-elm.git 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/.travis.yml b/.travis.yml deleted file mode 100644 index 4816f5c3..00000000 --- a/.travis.yml +++ /dev/null @@ -1,32 +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 - -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 diff --git a/.vscode/extensions.json b/.vscode/extensions.json new file mode 100644 index 00000000..4d30413e --- /dev/null +++ b/.vscode/extensions.json @@ -0,0 +1,6 @@ +{ + "recommendations": [ + "haskell.haskell", + "EditorConfig.EditorConfig" + ] +} diff --git a/.vscode/settings.json b/.vscode/settings.json new file mode 100644 index 00000000..a14c7ba3 --- /dev/null +++ b/.vscode/settings.json @@ -0,0 +1,7 @@ +{ + "[haskell]": { + "editor.formatOnSave": true, + "editor.defaultFormatter": "haskell.haskell" + }, + "haskell.formattingProvider": "stylish-haskell" +} 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/DEVELOPMENT.md b/DEVELOPMENT.md new file mode 100644 index 00000000..1f0b83e2 --- /dev/null +++ b/DEVELOPMENT.md @@ -0,0 +1,38 @@ +# Development recommendations + +Most of our developers use using [Visual Studio Code](https://code.visualstudio.com/). In that case, you just have to open the project, and install the recommended extensions. 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/), but forget about the Visual Studio Code configuration outlined there. +- [Kowainik's Haskell Style Guide](https://kowainik.github.io/posts/2019-02-06-style-guide). + +## Setting up the project + +### Native dependencies + +The included `adapter/kafka` project requires development headers of the rdkafka library: +* on macOS `sudo brew install librdkafka` +* on fedora `sudo dnf install librdkafka-devel` +* on debian `sudo apt-get install librdkafka-dev` + +### Git submodules + +This project uses git submodules (notably for examples/library/). You can run `git submodule update --init --recursive` once after checkout, or `git config --global submodule.recurse true` to globally enable submodules. + +### Integration tests + +See also https://github.com/higherkindness/mu-scala-haskell-integration-tests + +## Visual Studio Code extensions + +To make our lives easier while developing in Haskell, we use a set of recommended extensions. The first time you open the project, the editor should suggest to install all those you do not have: + +- [Haskell](https://marketplace.visualstudio.com/items?itemName=haskell.haskell), the best thing that happened to Haskell for editors/IDEs! ❤️ +- [editorconfig](https://marketplace.visualstudio.com/items?itemName=EditorConfig.EditorConfig), to have consistency between different editors and envs 🐀 + +## Styling 💅🏼 + +We loosely follow [Kowainik's Haskell Style Guide](https://kowainik.github.io/posts/2019-02-06-style-guide). In order to automate styling, we use [stylish-haskell](https://github.com/jaspervdj/stylish-haskell), for which we provide a `.stylish-haskell.yaml` configuration file. + +We don't provide any git hook or tool that enforces our style. By default the provided `.vscode/settings.json` file runs styling on every save. 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. 😊 + +Happy hacking! 👏🏼 diff --git a/rpc/LICENSE b/LICENSE similarity index 99% rename from rpc/LICENSE rename to LICENSE index d6456956..ffeb95d1 100644 --- a/rpc/LICENSE +++ b/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/README.md b/README.md index 832a7319..7c4d26df 100644 --- a/README.md +++ b/README.md @@ -1,16 +1,14 @@ # 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. +[![built with nix](https://builtwithnix.org/badge.svg)](https://builtwithnix.org) +[![Actions Status](https://github.com/higherkindness/mu-haskell/workflows/Haskell%20CI/badge.svg)](https://github.com/higherkindness/mu-haskell/actions) -* [`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: +## [Documentation](docs) -* [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). +## Contributing -## 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. -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 +If you want to contribute, please be sure to read the [development guidelines](DEVELOPMENT.md) first. diff --git a/RELEASE.md b/RELEASE.md new file mode 100644 index 00000000..697fc631 --- /dev/null +++ b/RELEASE.md @@ -0,0 +1,23 @@ +# Releasing a new version of Mu-Haskell + +This list assumes you have your Hackage username and password set in your `.cabal/config` file. + +1. Run `./test-schema.sh` and check that no errors are found + - If found, abort and open issue +2. Check that you can build with all compilers, and update project files if required: + - `stack build` (for the current LTS) + - `stack build --stack-yaml stack-nightly.yaml` (for the next version) + - `cabal build all` +3. For each package, run the following commands: + + ``` + ./release-package.sh + ``` + +4. Push and merge any pending changes +5. Run `./test-templates.sh` and check that no errors are found + - If found, update templates in `templates` folder and open a PR +6. Publish a new release in GitHub: + - Tag by running `git tag -a vX.Y -m "Release X.Y"` + - Push the tag `git push --tags` + - Create a new release in [GitHub](https://github.com/higherkindness/mu-haskell/releases/new) for that tag, or if using [`hub`](https://hub.github.com/hub-release.1.html), run `hub release create vX.Y` diff --git a/grpc/LICENSE b/adapter/avro/LICENSE similarity index 99% rename from grpc/LICENSE rename to adapter/avro/LICENSE index d6456956..ffeb95d1 100644 --- a/grpc/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/avro/hie.yaml b/adapter/avro/hie.yaml new file mode 100644 index 00000000..3c46aadf --- /dev/null +++ b/adapter/avro/hie.yaml @@ -0,0 +1,6 @@ +cradle: + stack: + - path: "./src" + component: "mu-avro:lib" + - path: "./test" + component: "mu-avro:exe:test-avro" diff --git a/adapter/avro/mu-avro.cabal b/adapter/avro/mu-avro.cabal new file mode 100644 index 00000000..5d6f29ca --- /dev/null +++ b/adapter/avro/mu-avro.cabal @@ -0,0 +1,69 @@ +name: mu-avro +version: 0.4.0.4 +synopsis: Avro serialization support for Mu microservices +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 © 2019-2020 +category: Network +build-type: Simple +cabal-version: >=1.10 +data-files: + test/avro/*.avsc + test/avro/*.avdl + +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: + Data.Time.Millis + Mu.Adapter.Avro + Mu.Quasi.Avro + Mu.Quasi.Avro.Example + + build-depends: + aeson >=1.4 && <2 + , avro >=0.5.1 && <0.6 + , base >=4.12 && <5 + , bytestring >=0.10 && <0.11 + , containers >=0.6 && <0.7 + , deepseq >=1.4 && <2 + , language-avro >=0.1.3 && <0.2 + , mu-rpc >=0.4 && <0.6 + , mu-schema >=0.3 && <0.4 + , sop-core >=0.5.0 && <0.6 + , tagged >=0.8.6 && <0.9 + , template-haskell >=2.14 && <2.17 + , text >=1.2 && <2 + , time >=1.9 && <2 + , transformers >=0.5 && <0.6 + , unordered-containers >=0.2 && <0.3 + , uuid >=1.3 && <2 + , vector >=0.12 && <0.13 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances + +executable test-avro + main-is: Avro.hs + build-depends: + avro >=0.5.1 && <0.6 + , base >=4.12 && <5 + , bytestring >=0.10 && <0.11 + , containers >=0.6 && <0.7 + , mu-avro + , mu-schema >=0.3 && <0.4 + + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall diff --git a/adapter/avro/src/Data/Time/Millis.hs b/adapter/avro/src/Data/Time/Millis.hs new file mode 100644 index 00000000..6c99b268 --- /dev/null +++ b/adapter/avro/src/Data/Time/Millis.hs @@ -0,0 +1,42 @@ +{-# language GeneralizedNewtypeDeriving #-} +{-| +Description : Time differences in milliseconds + +Avro defines a specific logical type for time +differences expessed in milliseconds. This module +provides a type which wraps the 'DiffTime' from +the @time@ library (which uses nanoseconds), +offering a millisecond-based interface. +-} +module Data.Time.Millis where + +import Control.DeepSeq (NFData) +import Data.Avro.Encoding.FromAvro +import Data.Avro.Encoding.ToAvro +import Data.Avro.HasAvroSchema +import qualified Data.Avro.Schema.Schema as S +import Data.Int (Int32) +import Data.Tagged +import Data.Time + +-- | Wrapper for time difference expressed in milliseconds +newtype DiffTimeMs = DiffTimeMs { unDiffTimeMs :: DiffTime } + deriving (Show, Eq, Ord, Enum, Num, Fractional, Real, RealFrac, NFData) + +instance HasAvroSchema DiffTimeMs where + schema = Tagged $ S.Int (Just S.TimeMillis) + +instance ToAvro DiffTimeMs where + toAvro s = toAvro s . (fromIntegral :: Integer -> Int32) . diffTimeToMillis + +instance FromAvro DiffTimeMs where + fromAvro (Int _ v) = pure $ millisToDiffTime (toInteger v) + fromAvro _ = Left "expecting time_ms" + +-- | Obtain the underlying time in milliseconds from a 'DiffTimeMs'. +diffTimeToMillis :: DiffTimeMs -> Integer +diffTimeToMillis = (`div` 1000000000) . diffTimeToPicoseconds . unDiffTimeMs + +-- | Build a 'DiffTimeMs' from an amount expressed in milliseconds. +millisToDiffTime :: Integer -> DiffTimeMs +millisToDiffTime = DiffTimeMs . picosecondsToDiffTime . (* 1000000000) diff --git a/adapter/avro/src/Mu/Adapter/Avro.hs b/adapter/avro/src/Mu/Adapter/Avro.hs new file mode 100644 index 00000000..f8547484 --- /dev/null +++ b/adapter/avro/src/Mu/Adapter/Avro.hs @@ -0,0 +1,362 @@ +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +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 +import qualified Data.Avro.Encoding.FromAvro as AVal +import qualified Data.Avro.Encoding.ToAvro as A +import qualified Data.Avro.Schema.ReadSchema as RSch +import qualified Data.Avro.Schema.Schema as ASch +-- 'Tagged . unTagged' can be replaced by 'coerce' +-- eliminating some run-time overhead +import Control.Monad.Trans.State +import Data.Avro.EitherN (putIndexedValue) +import Data.ByteString.Builder (Builder, word8) +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.Maybe (fromJust) +import Data.Tagged +import qualified Data.Text as T +import qualified Data.Vector as V +import GHC.TypeLits + +import Mu.Schema +import qualified Mu.Schema.Interpretation.Schemaless as SLess + +instance SLess.ToSchemalessTerm AVal.Value where + toSchemalessTerm (AVal.Record s r) + = case s of + RSch.Record { RSch.fields = fs } + -> SLess.TRecord $ + zipWith (\k v -> SLess.Field k (SLess.toSchemalessValue v)) + (map RSch.fldName fs) (V.toList r) + _ -> error ("this should never happen:\n" ++ show s) + toSchemalessTerm (AVal.Enum _ i _) + = SLess.TEnum i + toSchemalessTerm (AVal.Union _ _ v) + = SLess.toSchemalessTerm v + toSchemalessTerm v = SLess.TSimple (SLess.toSchemalessValue v) + +instance SLess.ToSchemalessValue AVal.Value where + toSchemalessValue AVal.Null = SLess.FNull + toSchemalessValue (AVal.Boolean b) = SLess.FPrimitive b + toSchemalessValue (AVal.Int _ b) = SLess.FPrimitive b + toSchemalessValue (AVal.Long _ b) = SLess.FPrimitive b + toSchemalessValue (AVal.Float _ b) = SLess.FPrimitive b + toSchemalessValue (AVal.Double _ b) = SLess.FPrimitive b + toSchemalessValue (AVal.String _ b) = SLess.FPrimitive b + toSchemalessValue (AVal.Fixed _ b) = SLess.FPrimitive b + toSchemalessValue (AVal.Bytes _ b) = SLess.FPrimitive b + toSchemalessValue (AVal.Array v) + = SLess.FList $ map SLess.toSchemalessValue $ V.toList v + toSchemalessValue (AVal.Map hm) + = SLess.FMap $ M.fromList + $ map (SLess.FPrimitive *** SLess.toSchemalessValue) + $ HM.toList hm + toSchemalessValue (AVal.Union _ _ v) + = SLess.toSchemalessValue v + toSchemalessValue r@(AVal.Record _ _) + = SLess.FSchematic (SLess.toSchemalessTerm r) + toSchemalessValue e@AVal.Enum {} + = SLess.FSchematic (SLess.toSchemalessTerm e) + +instance (HasAvroSchema' (Term sch (sch :/: sty))) + => A.HasAvroSchema (WithSchema sch sty t) where + schema = coerce $ evalState (schema' @(Term sch (sch :/: sty))) [] +instance ( FromSchema sch sty t + , A.FromAvro (Term sch (sch :/: sty)) ) + => A.FromAvro (WithSchema sch sty t) where + fromAvro entire + = WithSchema . fromSchema' @_ @_ @sch <$> AVal.fromAvro entire +instance ( ToSchema sch sty t + , A.ToAvro (Term sch (sch :/: sty)) ) + => A.ToAvro (WithSchema sch sty t) where + toAvro sch (WithSchema v) + = A.toAvro sch (toSchema' @_ @_ @sch v) + +-- HasAvroSchema instances + +class HasAvroSchema' x where + schema' :: State [ASch.TypeName] (Tagged x ASch.Schema) + +instance TypeError ('Text "you should never use HasAvroSchema directly on Term, use WithSchema") + => A.HasAvroSchema (Term sch t) where + schema = error "this should never happen" +instance HasAvroSchema' (FieldValue sch t) + => A.HasAvroSchema (FieldValue sch t) where + schema = evalState schema' [] + +instance (KnownName name, HasAvroSchemaFields sch args) + => HasAvroSchema' (Term sch ('DRecord name args)) where + schema' + = do let recordName = nameTypeName (Proxy @name) + visited <- gets (recordName `elem`) + if visited + then pure $ Tagged $ ASch.NamedType recordName + else do modify (recordName :) + fields <- schemaF (Proxy @sch) (Proxy @args) + pure $ Tagged $ ASch.Record recordName [] Nothing fields +instance (KnownName name, HasAvroSchemaEnum choices) + => HasAvroSchema' (Term sch ('DEnum name choices)) where + schema' + = do let enumName = nameTypeName (Proxy @name) + choicesNames = schemaE (Proxy @choices) + visited <- gets (enumName `elem`) + if visited + then pure $ Tagged $ ASch.NamedType enumName + else do modify (enumName :) + pure $ Tagged $ ASch.mkEnum enumName [] Nothing choicesNames + +instance HasAvroSchema' (FieldValue sch t) + => HasAvroSchema' (Term sch ('DSimple t)) where + schema' = coerce <$> schema' @(FieldValue sch t) + +instance HasAvroSchema' (FieldValue sch 'TNull) where + schema' = pure $ Tagged ASch.Null +instance A.HasAvroSchema t + => HasAvroSchema' (FieldValue sch ('TPrimitive t)) where + schema' = pure $ coerce $ A.schema @t +instance (HasAvroSchema' (Term sch (sch :/: t))) + => HasAvroSchema' (FieldValue sch ('TSchematic t)) where + schema' = coerce <$> schema' @(Term sch (sch :/: t)) +instance forall sch choices. + HasAvroSchemaUnion (FieldValue sch) choices + => HasAvroSchema' (FieldValue sch ('TUnion choices)) where + schema' = do + schs <- schemaU (Proxy @(FieldValue sch)) (Proxy @choices) + pure $ Tagged $ ASch.mkUnion schs +instance HasAvroSchema' (FieldValue sch t) + => HasAvroSchema' (FieldValue sch ('TOption t)) where + schema' = do + iSchema <- unTagged <$> schema' @(FieldValue sch t) + pure $ Tagged $ ASch.mkUnion $ ASch.Null :| [iSchema] +instance HasAvroSchema' (FieldValue sch t) + => HasAvroSchema' (FieldValue sch ('TList t)) where + schema' = do + iSchema <- unTagged <$> schema' @(FieldValue sch t) + pure $ Tagged $ ASch.Array iSchema +-- These are the only two versions of Map supported by the library +instance HasAvroSchema' (FieldValue sch v) + => HasAvroSchema' (FieldValue sch ('TMap ('TPrimitive T.Text) v)) where + schema' = do + iSchema <- unTagged <$> schema' @(FieldValue sch v) + pure $ Tagged $ ASch.Map iSchema +instance HasAvroSchema' (FieldValue sch v) + => HasAvroSchema' (FieldValue sch ('TMap ('TPrimitive String) v)) where + schema' = do + iSchema <- unTagged <$> schema' @(FieldValue sch v) + pure $ Tagged $ ASch.Map iSchema + +class HasAvroSchemaUnion (f :: k -> *) (xs :: [k]) where + schemaU :: Proxy f -> Proxy xs -> State [ASch.TypeName] (NonEmpty ASch.Schema) +instance HasAvroSchema' (f v) => HasAvroSchemaUnion f '[v] where + schemaU _ _ = do + vSchema <- unTagged <$> schema' @(f v) + pure $ vSchema :| [] +instance (HasAvroSchema' (f x), HasAvroSchemaUnion f (y ': zs)) + => HasAvroSchemaUnion f (x ': y ': zs) where + schemaU p _ = do + xSchema <- unTagged <$> schema' @(f x) + yzsSchema <- schemaU p (Proxy @(y ': zs)) + pure $ xSchema :| NonEmptyList.toList yzsSchema + +class HasAvroSchemaFields sch (fs :: [FieldDef tn fn]) where + schemaF :: Proxy sch -> Proxy fs -> State [ASch.TypeName] [ASch.Field] +instance HasAvroSchemaFields sch '[] where + schemaF _ _ = pure [] +instance (KnownName name, HasAvroSchema' (FieldValue sch t), HasAvroSchemaFields sch fs) + => HasAvroSchemaFields sch ('FieldDef name t ': fs) where + schemaF psch _ = do + let fieldName = nameText (Proxy @name) + schemaT <- unTagged <$> schema' @(FieldValue sch t) + let schemaThis = ASch.Field fieldName [] Nothing Nothing schemaT Nothing + rest <- schemaF psch (Proxy @fs) + pure $ schemaThis : rest + +class HasAvroSchemaEnum (fs :: [ChoiceDef fn]) where + schemaE :: Proxy fs -> [T.Text] +instance HasAvroSchemaEnum '[] where + schemaE _ = [] +instance (KnownName name, HasAvroSchemaEnum fs) + => HasAvroSchemaEnum ('ChoiceDef name ': fs) where + schemaE _ = nameText (Proxy @name) : schemaE (Proxy @fs) + +-- FromAvro instances + +instance (KnownName name, FromAvroFields sch args) + => A.FromAvro (Term sch ('DRecord name args)) where + fromAvro (AVal.Record RSch.Record { RSch.fields = fs } fields) + = TRecord <$> fromAvroF r + where + r = HM.fromList $ zip (map RSch.fldName fs) (V.toList fields) + fromAvro _ = Left "expecting record" +instance (KnownName name, FromAvroEnum choices) + => A.FromAvro (Term sch ('DEnum name choices)) where + fromAvro (AVal.Enum _ _ v) = TEnum <$> fromAvroEnum v + fromAvro _ = Left "expecting enum" +instance (A.FromAvro (FieldValue sch t)) + => A.FromAvro (Term sch ('DSimple t)) where + fromAvro v = TSimple <$> AVal.fromAvro v + +instance A.FromAvro (FieldValue sch 'TNull) where + fromAvro AVal.Null = pure FNull + fromAvro _ = Left "expecting null" +instance A.FromAvro t => A.FromAvro (FieldValue sch ('TPrimitive t)) where + fromAvro v = FPrimitive <$> AVal.fromAvro v +instance ( KnownName t, A.FromAvro (Term sch (sch :/: t)) ) + => A.FromAvro (FieldValue sch ('TSchematic t)) where + fromAvro v = FSchematic <$> AVal.fromAvro v +instance (FromAvroUnion sch choices) + => A.FromAvro (FieldValue sch ('TUnion choices)) where + fromAvro (AVal.Union _ i v) = FUnion <$> fromAvroU i v + fromAvro _ = Left "expecting union" +instance (A.FromAvro (FieldValue sch t)) + => A.FromAvro (FieldValue sch ('TOption t)) where + fromAvro v = FOption <$> AVal.fromAvro v +instance (A.FromAvro (FieldValue sch t)) + => A.FromAvro (FieldValue sch ('TList t)) where + fromAvro v = FList <$> AVal.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 + fromAvro v = FMap . M.mapKeys FPrimitive <$> AVal.fromAvro v +instance (A.FromAvro (FieldValue sch v)) + => A.FromAvro (FieldValue sch ('TMap ('TPrimitive String) v)) where + fromAvro v = FMap . M.mapKeys (FPrimitive . T.unpack) <$> AVal.fromAvro v + +class FromAvroEnum (vs :: [ChoiceDef fn]) where + fromAvroEnum :: T.Text -> Either String (NS Proxy vs) +instance FromAvroEnum '[] where + fromAvroEnum _ = Left "enum choice not found" +instance (KnownName name, FromAvroEnum vs) + => FromAvroEnum ('ChoiceDef name ': vs) where + fromAvroEnum s + | s == fieldName = pure $ Z Proxy + | otherwise = S <$> fromAvroEnum s + where fieldName = nameText (Proxy @name) + +class FromAvroUnion sch choices where + fromAvroU :: Int -> AVal.Value -> Either String (NS (FieldValue sch) choices) +instance FromAvroUnion sch '[] where + fromAvroU _ _ = Left "union choice not found" +instance (A.FromAvro (FieldValue sch u), FromAvroUnion sch us) + => FromAvroUnion sch (u ': us) where + fromAvroU 0 v = Z <$> AVal.fromAvro v + fromAvroU n v = S <$> fromAvroU (n-1) v + +class FromAvroFields sch (fs :: [FieldDef Symbol Symbol]) where + fromAvroF :: HM.HashMap T.Text AVal.Value + -> Either String (NP (Field sch) fs) +instance FromAvroFields sch '[] where + fromAvroF _ = pure Nil +instance (KnownName name, A.FromAvro (FieldValue sch t), FromAvroFields sch fs) + => FromAvroFields sch ('FieldDef name t ': fs) where + fromAvroF v = case HM.lookup fieldName v of + Nothing -> Left "field not found" + Just f -> (:*) <$> (Field <$> AVal.fromAvro f) <*> fromAvroF v + where fieldName = nameText (Proxy @name) + +-- ToAvro instances + +instance (KnownName name, ToAvroFields sch args, HasAvroSchemaFields sch args) + => A.ToAvro (Term sch ('DRecord name args)) where + toAvro s@ASch.Record {} (TRecord fields) + = A.record s $ toAvroF fields + -- if we don't have a record, fall back to the one from schema + toAvro _ (TRecord fields) + = A.record sch (toAvroF fields) + where sch = unTagged $ evalState (schema' @(Term sch ('DRecord name args))) [] +instance (KnownName name, ToAvroEnum choices, HasAvroSchemaEnum choices) + => A.ToAvro (Term sch ('DEnum name choices)) where + toAvro ASch.Enum { ASch.symbols = ss } (TEnum n) + = word8 $ fromIntegral $ toAvroE ss n + -- otherwise fall back to the one from schema + toAvro _ (TEnum n) + = word8 $ fromIntegral $ toAvroE (V.fromList $ schemaE (Proxy @choices)) n +instance (A.ToAvro (FieldValue sch t)) + => A.ToAvro (Term sch ('DSimple t)) where + toAvro s (TSimple v) = A.toAvro s v + +instance A.ToAvro (FieldValue sch 'TNull) where + toAvro _ FNull = mempty +instance A.ToAvro t => A.ToAvro (FieldValue sch ('TPrimitive t)) where + toAvro s (FPrimitive v) = A.toAvro s v +instance ( KnownName t, A.ToAvro (Term sch (sch :/: t)) ) + => A.ToAvro (FieldValue sch ('TSchematic t)) where + toAvro s (FSchematic v) = A.toAvro s v +instance (ToAvroUnion sch choices) + => A.ToAvro (FieldValue sch ('TUnion choices)) where + toAvro (ASch.Union vs) (FUnion v) = toAvroU vs 0 v + toAvro s _ = error ("this should never happen:\n" ++ show s) +instance (A.ToAvro (FieldValue sch t)) + => A.ToAvro (FieldValue sch ('TOption t)) where + toAvro s (FOption v) = A.toAvro s v +instance (A.ToAvro (FieldValue sch t)) + => A.ToAvro (FieldValue sch ('TList t)) where + toAvro s (FList v) = A.toAvro s 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 + toAvro s (FMap v) = A.toAvro s $ M.mapKeys (\(FPrimitive k) -> k) v +instance (A.ToAvro (FieldValue sch v)) + => A.ToAvro (FieldValue sch ('TMap ('TPrimitive String) v)) where + toAvro s (FMap v) = A.toAvro s $ M.mapKeys (\(FPrimitive k) -> T.pack k) v + +class ToAvroEnum choices where + toAvroE :: V.Vector T.Text -> NS Proxy choices -> Int +instance ToAvroEnum '[] where + toAvroE = error "ToAvro in an empty enum" +instance (KnownName u, ToAvroEnum us) + => ToAvroEnum ('ChoiceDef u ': us) where + toAvroE s (Z _) = fromJust $ nameText (Proxy @u) `V.elemIndex` s + toAvroE s (S v) = toAvroE s v + +class ToAvroUnion sch choices where + toAvroU :: V.Vector ASch.Schema + -> Int -> NS (FieldValue sch) choices -> Builder +instance ToAvroUnion sch '[] where + toAvroU = error "this should never happen" +instance (A.ToAvro (FieldValue sch u), ToAvroUnion sch us) + => ToAvroUnion sch (u ': us) where + toAvroU allSch n (Z v) + = putIndexedValue n allSch v + toAvroU allSch n (S v) + = toAvroU allSch (n+1) v + +class ToAvroFields sch (fs :: [FieldDef Symbol Symbol]) where + toAvroF :: NP (Field sch) fs -> [(T.Text, A.Encoder)] +instance ToAvroFields sch '[] where + toAvroF _ = [] +instance (KnownName name, A.ToAvro (FieldValue sch t), ToAvroFields sch fs) + => ToAvroFields sch ('FieldDef name t ': fs) where + toAvroF (Field v :* rest) = (fieldName A..= v) : toAvroF rest + where fieldName = nameText (Proxy @name) + +-- Conversion of symbols to other things +nameText :: KnownName s => proxy s -> T.Text +nameText = T.pack . nameVal +nameTypeName :: KnownName s => proxy s -> ASch.TypeName +nameTypeName = ASch.parseFullname . nameText diff --git a/adapter/avro/src/Mu/Quasi/Avro.hs b/adapter/avro/src/Mu/Quasi/Avro.hs new file mode 100644 index 00000000..7cfbbf27 --- /dev/null +++ b/adapter/avro/src/Mu/Quasi/Avro.hs @@ -0,0 +1,203 @@ +{-# language DataKinds #-} +{-# language KindSignatures #-} +{-# language LambdaCase #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# 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 ( + -- * Service generation from @.avdl@ files + avdl + -- * Quasi-quoters for @.avsc@ files +, avro +, avroFile + -- * Only for internal use +, schemaFromAvroType +) where + +import Control.Monad.IO.Class +import Data.Aeson (decode) +import Data.Avro.Schema.Decimal as D +import qualified Data.Avro.Schema.Schema as A +import qualified Data.ByteString as B +import Data.ByteString.Lazy.Char8 (pack) +import Data.Int +import qualified Data.Set as S +import qualified Data.Text as T +import Data.Time +import Data.Time.Millis +import Data.UUID +import qualified Data.Vector as V +import GHC.TypeLits +import Language.Avro.Parser +import qualified Language.Avro.Types as A +import Language.Haskell.TH +import Language.Haskell.TH.Quote + +import Mu.Rpc +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") + where + schemaFromAvroString :: String -> Q Type + schemaFromAvroString s = + case decode (pack s) of + Nothing -> fail "could not parse avro spec!" + Just (A.Union us) -> schemaFromAvro (V.toList us) + Just t -> schemaFromAvro [t] + +-- | Imports an avro definition from a file as a 'Schema'. +avroFile :: QuasiQuoter +avroFile = quoteFile avro + +-- | Reads a @.avdl@ file and generates: +-- * A 'Mu.Schema.Definition.Schema' with all the record +-- types, using the name given as first argument. +-- * A 'Service' declaration containing all the methods +-- defined in the file. +avdl :: String -> String -> FilePath -> FilePath -> Q [Dec] +avdl schemaName serviceName baseDir initialFile + = do r <- liftIO $ readWithImports baseDir initialFile + case r of + Left e + -> fail ("could not parse Avro IDL: " ++ show e) + Right p + -> avdlToDecls schemaName serviceName p + +avdlToDecls :: String -> String -> A.Protocol -> Q [Dec] +avdlToDecls schemaName serviceName protocol + = do let schemaName' = mkName schemaName + serviceName' = mkName serviceName + schemaDec <- tySynD schemaName' [] (schemaFromAvro $ S.toList (A.types protocol)) + serviceDec <- tySynD serviceName' [] + [t| 'Package $(pkgType (A.ns protocol)) + '[ 'Service $(textToStrLit (A.pname protocol)) + $(typesToList <$> mapM (avroMethodToType schemaName') + (S.toList $ A.messages protocol)) ] |] + pure [schemaDec, serviceDec] + where + pkgType Nothing = [t| ('Nothing :: Maybe Symbol) |] + pkgType (Just (A.Namespace p)) + = [t| 'Just $(textToStrLit (T.intercalate "." p)) |] + +schemaFromAvro :: [A.Schema] -> Q Type +schemaFromAvro = + (typesToList <$>) . mapM schemaDecFromAvroType . flattenAvroDecls + +schemaDecFromAvroType :: A.Schema -> 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 (V.toList symbols))|] + where + avChoiceToType :: T.Text -> Q Type + avChoiceToType c = [t|'ChoiceDef $(textToStrLit c)|] +schemaDecFromAvroType t = [t|'DSimple $(schemaFromAvroType t)|] + +-- | Turns a schema from Avro into a Template Haskell 'Type'. +schemaFromAvroType :: A.Schema -> Q Type +schemaFromAvroType = + \case + A.Null -> [t|'TPrimitive 'TNull|] + A.Boolean -> [t|'TPrimitive Bool|] + A.Int (Just A.Date) -> [t|'TPrimitive Day|] + A.Int (Just A.TimeMillis) -> [t|'TPrimitive DiffTimeMs|] + A.Int _ -> [t|'TPrimitive Int32|] + A.Long (Just (A.DecimalL (A.Decimal p s))) + -> [t|'TPrimitive (D.Decimal $(litT $ numTyLit p) $(litT $ numTyLit s)) |] + A.Long (Just A.TimeMicros) -> [t|'TPrimitive DiffTime|] + A.Long _ -> [t|'TPrimitive Int64|] + A.Float -> [t|'TPrimitive Float|] + A.Double -> [t|'TPrimitive Double|] + A.Bytes _ -> [t|'TPrimitive B.ByteString|] + A.String (Just A.UUID) -> [t|'TPrimitive UUID|] + A.String _ -> [t|'TPrimitive T.Text|] + A.Array item -> [t|'TList $(schemaFromAvroType item)|] + A.Map values -> [t|'TMap ('TPrimitive 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 V.toList options of + [A.Null, x] -> toOption x + [x, A.Null] -> toOption x + _ -> + [t|'TUnion $(typesToList <$> mapM schemaFromAvroType (V.toList options))|] + where toOption x = [t|'TOption $(schemaFromAvroType x)|] + A.Fixed {} -> fail "fixed integers are not currently supported" + +flattenAvroDecls :: [A.Schema] -> [A.Schema] +flattenAvroDecls = concatMap (uncurry (:) . flattenDecl) + where + flattenDecl :: A.Schema -> (A.Schema, [A.Schema]) + flattenDecl (A.Record name a d fields) = + let (flds, tts) = unzip (flattenAvroField <$> fields) + in (A.Record name a d flds, concat tts) + flattenDecl (A.Union _) = error "should never happen, please, file an issue" + flattenDecl t = (t, []) + flattenAvroType :: A.Schema -> (A.Schema, [A.Schema]) + flattenAvroType (A.Record name a d fields) = + let (flds, tts) = unzip (flattenAvroField <$> fields) + in (A.NamedType name, A.Record name a d flds : concat tts) + flattenAvroType (A.Union (V.toList -> ts)) = + let (us, tts) = unzip (map flattenAvroType ts) + in (A.Union $ V.fromList us, concat tts) + flattenAvroType e@A.Enum {A.name} = (A.NamedType name, [e]) + flattenAvroType t = (t, []) + flattenAvroField :: A.Field -> (A.Field, [A.Schema]) + flattenAvroField f = + let (t, decs) = flattenAvroType (A.fldType f) + in (f {A.fldType = t}, decs) + +avroMethodToType :: Name -> A.Method -> Q Type +avroMethodToType schemaName m + = [t| 'Method $(textToStrLit (A.mname m)) + $(typesToList <$> mapM argToType (A.args m)) + $(retToType (A.result m)) |] + where + argToType :: A.Argument -> Q Type + argToType (A.Argument (A.NamedType a) _) + = [t| 'ArgSingle ('Nothing :: Maybe Symbol) ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |] + argToType (A.Argument _ _) + = fail "only named types may be used as arguments" + + retToType :: A.Schema -> Q Type + retToType A.Null + = [t| 'RetNothing |] + retToType (A.NamedType a) + = [t| 'RetSingle ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |] + retToType _ + = fail "only named types may be used as results" + +typesToList :: [Type] -> Type +typesToList = foldr (AppT . AppT PromotedConsT) PromotedNilT + +textToStrLit :: T.Text -> Q Type +textToStrLit s = litT $ strTyLit $ T.unpack s diff --git a/adapter/avro/src/Mu/Quasi/Avro/Example.hs b/adapter/avro/src/Mu/Quasi/Avro/Example.hs new file mode 100644 index 00000000..e0e93241 --- /dev/null +++ b/adapter/avro/src/Mu/Quasi/Avro/Example.hs @@ -0,0 +1,56 @@ +{-# language CPP #-} +{-# language DataKinds #-} +{-# language KindSignatures #-} +{-# language QuasiQuotes #-} +{-# language TemplateHaskell #-} + +{-| +Description : Examples for Avro quasi-quoters + +Look at the source code of this module. +-} +module Mu.Quasi.Avro.Example where + +import Mu.Quasi.Avro (avdl, 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" } + ] + } + } + ] +} +|] + +#if __GHCIDE__ +type ExampleFromFile = [avroFile|adapter/avro/test/avro/example.avsc|] +#else +type ExampleFromFile = [avroFile|test/avro/example.avsc|] +#endif + +#if __GHCIDE__ +avdl "ExampleProtocol" "ExampleService" "." "adapter/avro/test/avro/example.avdl" +#else +avdl "ExampleProtocol" "ExampleService" "." "test/avro/example.avdl" +#endif diff --git a/adapter/avro/test/Avro.hs b/adapter/avro/test/Avro.hs new file mode 100644 index 00000000..6e1dd184 --- /dev/null +++ b/adapter/avro/test/Avro.hs @@ -0,0 +1,44 @@ +{-# language DataKinds #-} +{-# language DerivingVia #-} +{-# language OverloadedStrings #-} +{-# language StandaloneDeriving #-} +{-# language TypeApplications #-} +{-# options_ghc -fno-warn-orphans #-} +module Main where + +import Data.Avro +import qualified Data.ByteString.Lazy as BS +import qualified Data.Map as M +import System.Environment + +import Mu.Adapter.Avro () +import Mu.Schema (WithSchema (..)) +import Mu.Schema.Examples + +exampleAddress :: Address +exampleAddress = Address "1111BB" "Spain" + +examplePerson1, examplePerson2 :: Person +examplePerson1 + = Person "Haskellio" "Gomez" (Just 30) Male exampleAddress [1,2,3] M.empty +examplePerson2 + = Person "Cuarenta" "Siete" Nothing Unspecified exampleAddress [] + (M.fromList [("hola", 1), ("hello", 2)]) + +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 + -- 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 nullCodec [[examplePerson1, examplePerson2]] + BS.writeFile genFile gbs 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/adapter/avro/test/avro/example.avdl b/adapter/avro/test/avro/example.avdl new file mode 100644 index 00000000..436cc4dd --- /dev/null +++ b/adapter/avro/test/avro/example.avdl @@ -0,0 +1,26 @@ +@namespace("example.seed.server.protocol.avro") +protocol Service { + record Person { + string name; + int age; + map things; + } + + error NotFoundError { + string message; + } + + error DuplicatedPersonError { + string message; + } + + record PeopleRequest { + string name; + } + + record PeopleResponse { + union { Person, NotFoundError, DuplicatedPersonError } result; + } + + example.seed.server.protocol.avro.PeopleResponse getPerson(example.seed.server.protocol.avro.PeopleRequest request); +} diff --git a/adapter/avro/test/avro/example.avsc b/adapter/avro/test/avro/example.avsc new file mode 100644 index 00000000..d61240a3 --- /dev/null +++ b/adapter/avro/test/avro/example.avsc @@ -0,0 +1,24 @@ +{ "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"} + ] + } + }, + {"name": "lucky_numbers", "type": { "type": "array", "items": "long" } }, + {"name": "things", "type": "map", "values": "int"} + ] +} diff --git a/schema/test/avro/generate.py b/adapter/avro/test/avro/generate.py similarity index 77% rename from schema/test/avro/generate.py rename to adapter/avro/test/avro/generate.py index fee84510..05609a76 100644 --- a/schema/test/avro/generate.py +++ b/adapter/avro/test/avro/generate.py @@ -4,8 +4,8 @@ import sys example_address = { "postcode": "0000AA", "country": "Nederland"} -example_person1 = {"firstName": "Pythonio", "lastName": "van Gogh", "age": 30, "gender": "male", "address": example_address} -example_person2 = {"firstName": "Fortyseveriano", "lastName": "van Gogh", "address": example_address} +example_person1 = {"firstName": "Pythonio", "lastName": "van Gogh", "age": 30, "gender": "male", "address": example_address, "lucky_numbers": [1,2,3]} +example_person2 = {"firstName": "Fortyseveriano", "lastName": "van Gogh", "address": example_address, "lucky_numbers": []} print(example_person1) print(example_person2) @@ -16,4 +16,4 @@ writer.append(example_person1) writer.append(example_person2) writer.flush() -writer.close() \ No newline at end of file +writer.close() diff --git a/schema/LICENSE b/adapter/kafka/LICENSE similarity index 99% rename from schema/LICENSE rename to adapter/kafka/LICENSE index d6456956..ffeb95d1 100644 --- a/schema/LICENSE +++ b/adapter/kafka/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/kafka/README.md b/adapter/kafka/README.md new file mode 100644 index 00000000..ac8ec776 --- /dev/null +++ b/adapter/kafka/README.md @@ -0,0 +1,3 @@ +# mu-kafka + +This are some utilities to integrate easily with Kafka while using Mu. diff --git a/adapter/kafka/Setup.hs b/adapter/kafka/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/adapter/kafka/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/adapter/kafka/hie.yaml b/adapter/kafka/hie.yaml new file mode 100644 index 00000000..364c3328 --- /dev/null +++ b/adapter/kafka/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-kafka:lib" } } diff --git a/adapter/kafka/mu-kafka.cabal b/adapter/kafka/mu-kafka.cabal new file mode 100644 index 00000000..9f81129b --- /dev/null +++ b/adapter/kafka/mu-kafka.cabal @@ -0,0 +1,42 @@ +name: mu-kafka +version: 0.3.0.0 +synopsis: Utilities for interoperation between Mu and Kafka +description: + This package provides simple interoperation between Mu and Kafka using @hw-kafka-client@ + +homepage: https://github.com/higherkindness/mu-haskell +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 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.Kafka.Consumer + Mu.Kafka.Producer + + other-modules: Mu.Kafka.Internal + hs-source-dirs: src + default-language: Haskell2010 + build-depends: + avro >=0.5.1 && <0.6 + , base >=4.12 && <5 + , bytestring >=0.10 && <0.11 + , conduit >=1.3.2 && <2 + , hw-kafka-client >=3 && <5 + , hw-kafka-conduit >=2.7 && <3 + , mu-avro >=0.4 && <0.5 + , mu-schema >=0.3 && <0.4 + , resourcet >=1.2 && <2 + + ghc-options: -Wall diff --git a/adapter/kafka/src/Mu/Kafka/Consumer.hs b/adapter/kafka/src/Mu/Kafka/Consumer.hs new file mode 100644 index 00000000..dcc8a2dc --- /dev/null +++ b/adapter/kafka/src/Mu/Kafka/Consumer.hs @@ -0,0 +1,86 @@ +{-# language FlexibleContexts #-} +{-# language TypeFamilies #-} +{-| +Description : Kafka consumers as streams of Mu terms + +This module allows you to receive values from +a Kafka topic, and treat then as Mu terms, or +your Haskell types if a conversion exists. + +This module is a wrapper over 'Kafka.Conduit.Source' +from the (awesome) package @hw-kafka-client@. +-} +module Mu.Kafka.Consumer ( + kafkaSource +, kafkaSourceNoClose +, kafkaSourceAutoClose +, module X +) where + +import Conduit (mapC) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import qualified Data.Avro as A +import Data.ByteString +import Data.Conduit +import Mu.Schema + +import qualified Kafka.Conduit.Source as S + +import Kafka.Conduit.Combinators as X +import Kafka.Consumer as X + +import Mu.Kafka.Internal + +fromCR + :: ( FromSchema sch sty t + , A.FromAvro (WithSchema sch sty t) + , A.HasAvroSchema (WithSchema sch sty t) ) + => Proxy sch + -> ConsumerRecord (Maybe ByteString) (Maybe ByteString) + -> ConsumerRecord (Maybe ByteString) (Maybe t) +fromCR proxy (ConsumerRecord t p o ts k v) + = ConsumerRecord t p o ts k (v >>= fromBS proxy) + +-- | Creates a kafka producer for given properties and returns a `Source`. +-- +-- This method of creating a `Source` represents a simple case +-- and does not provide access to `KafkaProducer`. For more complex scenarious +-- 'kafkaSinkNoClose' or 'kafkaSinkAutoClose' can be used. +kafkaSource + :: ( MonadResource m + , FromSchema sch sty t + , A.FromAvro (WithSchema sch sty t) + , A.HasAvroSchema (WithSchema sch sty t) ) + => Proxy sch + -> ConsumerProperties -> Subscription -> Timeout + -> ConduitT () (Either KafkaError (ConsumerRecord (Maybe ByteString) (Maybe t))) m () +kafkaSource proxy props sub ts = + S.kafkaSource props sub ts .| mapC (fmap (fromCR proxy)) + +-- | Create a `Source` for a given `KafkaConsumer`. +-- The consumer will NOT be closed automatically when the `Source` is closed. +kafkaSourceNoClose + :: ( MonadIO m + , FromSchema sch sty t + , A.FromAvro (WithSchema sch sty t) + , A.HasAvroSchema (WithSchema sch sty t) ) + => Proxy sch + -> KafkaConsumer -> Timeout + -> ConduitT () (Either KafkaError (ConsumerRecord (Maybe ByteString) (Maybe t))) m () +kafkaSourceNoClose proxy c t + = S.kafkaSourceNoClose c t .| mapC (fmap (fromCR proxy)) + + +-- | Create a `Source` for a given `KafkaConsumer`. +-- The consumer will be closed automatically when the `Source` is closed. +kafkaSourceAutoClose + :: ( MonadResource m + , FromSchema sch sty t + , A.FromAvro (WithSchema sch sty t) + , A.HasAvroSchema (WithSchema sch sty t) ) + => Proxy sch + -> KafkaConsumer -> Timeout + -> ConduitT () (Either KafkaError (ConsumerRecord (Maybe ByteString) (Maybe t))) m () +kafkaSourceAutoClose proxy c t + = S.kafkaSourceAutoClose c t .| mapC (fmap (fromCR proxy)) diff --git a/adapter/kafka/src/Mu/Kafka/Internal.hs b/adapter/kafka/src/Mu/Kafka/Internal.hs new file mode 100644 index 00000000..878c4af0 --- /dev/null +++ b/adapter/kafka/src/Mu/Kafka/Internal.hs @@ -0,0 +1,28 @@ +{-# language FlexibleContexts #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +module Mu.Kafka.Internal where + +import qualified Data.Avro as A +import Data.ByteString +import Data.ByteString.Lazy (fromStrict, toStrict) + +import Mu.Schema + +toBS :: forall sch sty t. + ( ToSchema sch sty t + , A.HasAvroSchema (WithSchema sch sty t) + , A.ToAvro (WithSchema sch sty t) ) + => Proxy sch -> t -> ByteString +toBS _ = toStrict . A.encodeValue . WithSchema @_ @_ @sch @sty @t + +fromBS :: forall sch sty t. + ( FromSchema sch sty t + , A.FromAvro (WithSchema sch sty t) + , A.HasAvroSchema (WithSchema sch sty t) ) + => Proxy sch -> ByteString -> Maybe t +fromBS _ x = unWithSchema @_ @_ @sch @sty @t <$> resultToMaybe (A.decodeValue (fromStrict x)) + where + resultToMaybe (Left _) = Nothing + resultToMaybe (Right y) = Just y diff --git a/adapter/kafka/src/Mu/Kafka/Producer.hs b/adapter/kafka/src/Mu/Kafka/Producer.hs new file mode 100644 index 00000000..0013bbc9 --- /dev/null +++ b/adapter/kafka/src/Mu/Kafka/Producer.hs @@ -0,0 +1,107 @@ +{-# language DeriveGeneric #-} +{-# language FlexibleContexts #-} +{-# language TypeFamilies #-} +{-| +Description : streams of Mu terms as Kafka producers + +This module allows you to open a "sink" to Kafka. +Every value you sent to the sink will be sent over +to the corresponding Kafka instance. + +This module is a wrapper over 'Kafka.Conduit.Sink' +from the (awesome) package @hw-kafka-client@. +-} +module Mu.Kafka.Producer ( + ProducerRecord'(..) +, kafkaSink +, kafkaSinkAutoClose +, kafkaSinkNoClose +, kafkaBatchSinkNoClose +, module X +) where + +import Conduit (mapC) +import Control.Monad.IO.Class +import Control.Monad.Trans.Resource +import qualified Data.Avro as A +import Data.ByteString +import Data.Conduit +import Data.Typeable +import GHC.Generics +import Mu.Schema + +import qualified Kafka.Conduit.Sink as S +import Kafka.Producer (ProducerRecord (..)) + +import Kafka.Conduit.Combinators as X +import Kafka.Consumer as X (KafkaConsumer) +import Kafka.Producer as X (KafkaError, KafkaProducer, ProducePartition, + ProducerProperties, TopicName) + +import Mu.Kafka.Internal + +data ProducerRecord' k v = ProducerRecord' + { prTopic :: !TopicName + , prPartition :: !ProducePartition + , prKey :: Maybe k + , prValue :: Maybe v + } deriving (Eq, Show, Typeable, Generic) + +toPR + :: ( ToSchema sch sty t + , A.ToAvro (WithSchema sch sty t) + , A.HasAvroSchema (WithSchema sch sty t) ) + => Proxy sch -> ProducerRecord' ByteString t -> ProducerRecord +toPR proxy (ProducerRecord' t p k v) + = ProducerRecord t p k (toBS proxy <$> v) + +-- | Creates a kafka producer for given properties and returns a Sink. +-- +-- This method of creating a Sink represents a simple case +-- and does not provide access to `KafkaProducer`. For more complex scenarious +-- 'kafkaSinkAutoClose' or 'kafkaSinkNoClose' can be used. +kafkaSink + :: ( MonadResource m + , ToSchema sch sty t + , A.ToAvro (WithSchema sch sty t) + , A.HasAvroSchema (WithSchema sch sty t) ) + => Proxy sch -> X.ProducerProperties + -> ConduitT (ProducerRecord' ByteString t) Void m (Maybe KafkaError) +kafkaSink proxy prod + = mapC (toPR proxy) .| S.kafkaSink prod + +-- | Creates a Sink for a given `KafkaProducer`. +-- The producer will be closed when the Sink is closed. +kafkaSinkAutoClose + :: ( MonadResource m + , ToSchema sch sty t + , A.ToAvro (WithSchema sch sty t) + , A.HasAvroSchema (WithSchema sch sty t) ) + => Proxy sch -> KafkaProducer + -> ConduitT (ProducerRecord' ByteString t) Void m (Maybe X.KafkaError) +kafkaSinkAutoClose proxy prod + = mapC (toPR proxy) .| S.kafkaSinkAutoClose prod + +-- | Creates a Sink for a given `KafkaProducer`. +-- The producer will NOT be closed automatically. +kafkaSinkNoClose + :: ( MonadIO m + , ToSchema sch sty t + , A.ToAvro (WithSchema sch sty t) + , A.HasAvroSchema (WithSchema sch sty t) ) + => Proxy sch -> KafkaProducer + -> ConduitT (ProducerRecord' ByteString t) Void m (Maybe X.KafkaError) +kafkaSinkNoClose proxy prod + = mapC (toPR proxy) .| S.kafkaSinkNoClose prod + +-- | Creates a batching Sink for a given `KafkaProducer`. +-- The producer will NOT be closed automatically. +kafkaBatchSinkNoClose + :: ( MonadIO m + , ToSchema sch sty t + , A.ToAvro (WithSchema sch sty t) + , A.HasAvroSchema (WithSchema sch sty t) ) + => Proxy sch -> KafkaProducer + -> ConduitT [ProducerRecord' ByteString t] Void m [(ProducerRecord, KafkaError)] +kafkaBatchSinkNoClose proxy prod + = mapC (fmap (toPR proxy)) .| S.kafkaBatchSinkNoClose prod 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..44671092 --- /dev/null +++ b/adapter/persistent/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain 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/persistent/mu-persistent.cabal b/adapter/persistent/mu-persistent.cabal new file mode 100644 index 00000000..09192faf --- /dev/null +++ b/adapter/persistent/mu-persistent.cabal @@ -0,0 +1,38 @@ +name: mu-persistent +version: 0.3.1.0 +synopsis: Utilities for interoperation between Mu and Persistent +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 +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 + hs-source-dirs: src + default-language: Haskell2010 + build-depends: + base >=4.12 && <5 + , monad-logger >=0.3 && <0.4 + , mu-schema >=0.3 && <0.4 + , persistent >=2.10 && <3 + , resource-pool >=0.2 && <0.3 + , resourcet >=1.2 && <2 + , transformers >=0.5 && <0.6 + + ghc-options: -Wall diff --git a/adapter/persistent/src/Mu/Adapter/Persistent.hs b/adapter/persistent/src/Mu/Adapter/Persistent.hs new file mode 100644 index 00000000..11cad6ba --- /dev/null +++ b/adapter/persistent/src/Mu/Adapter/Persistent.hs @@ -0,0 +1,107 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language GADTs #-} +{-# language KindSignatures #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +Description : Utilities for interoperation between Mu and Persistent + +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, Pool, runDbPool +) where + +import Control.Monad.IO.Class +import Control.Monad.Logger +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Resource.Internal +import Data.Int +import Data.Pool (Pool) +import Database.Persist.Sql +import GHC.Generics +import GHC.TypeLits + +import Mu.Schema +import Mu.Schema.Class + +-- | 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 + , (sch :/: sty) ~ 'DRecord name (idArg ': args) + , idArg ~ 'Mu.Schema.FieldDef idArgName ('TPrimitive Int64) + , Rep t ~ D1 dInfo (C1 cInfo f) + , GToSchemaRecord sch fmap args f + , ToBackendKey (PersistEntityBackend t) t + , PersistEntityBackend t ~ SqlBackend ) + => ToSchema sch sty (WithEntityPlainId sty fmap (Entity t)) where + toSchema (WithEntityPlainId (Entity key x)) + = TRecord $ Field (FPrimitive (unSqlBackendKey $ toBackendKey key)) + :* toSchemaRecord (Proxy @fmap) (unM1 $ unM1 $ from x) + +instance ( Generic t + , (sch :/: sty) ~ 'DRecord name (nestedIdArg ': args) + , nestedIdArg ~ 'Mu.Schema.FieldDef fname k + , ToSchemaKey sch idTy k + , (sch :/: idTy) ~ 'DRecord idName '[idArg] + , idArg ~ 'Mu.Schema.FieldDef idArgName ('TPrimitive Int64) + , Rep t ~ D1 dInfo (C1 cInfo f) + , GToSchemaRecord sch fmap args f + , ToBackendKey (PersistEntityBackend t) t + , PersistEntityBackend t ~ SqlBackend ) + => ToSchema sch sty (WithEntityNestedId sty fmap (Entity t)) where + toSchema (WithEntityNestedId (Entity key x)) + = TRecord $ Field (toSchemaKey $ FSchematic $ TRecord (Field (FPrimitive key') :* Nil)) + :* toSchemaRecord (Proxy @fmap) (unM1 $ unM1 $ from x) + where key' = unSqlBackendKey $ toBackendKey key + +class ToSchemaKey (sch :: Schema') (idTy :: Symbol) t | sch t -> idTy where + toSchemaKey :: FieldValue sch ('TSchematic idTy) -> FieldValue sch t +instance ToSchemaKey sch idTy ('TSchematic idTy) where + toSchemaKey = id +instance ToSchemaKey sch idTy t => ToSchemaKey sch idTy ('TOption t) where + toSchemaKey = FOption . Just . toSchemaKey + +-- | 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 + -> m a +runDb = (liftIO .) . flip runSqlPersistM + +-- | Simple utility to execute a database operation +-- in any monad which supports 'IO' operations. +-- Note that all logging messages are discarded. +runDbPool :: MonadIO m + => Pool SqlBackend + -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a + -> m a +runDbPool = (liftIO .) . flip runSqlPersistMPool diff --git a/adapter/protobuf/LICENSE b/adapter/protobuf/LICENSE new file mode 100644 index 00000000..ffeb95d1 --- /dev/null +++ b/adapter/protobuf/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/protobuf/hie.yaml b/adapter/protobuf/hie.yaml new file mode 100644 index 00000000..cbcc49a1 --- /dev/null +++ b/adapter/protobuf/hie.yaml @@ -0,0 +1,6 @@ +cradle: + stack: + - path: "./src" + component: "mu-protobuf:lib" + - path: "./test" + component: "mu-protobuf:exe:test-protobuf" diff --git a/adapter/protobuf/mu-protobuf.cabal b/adapter/protobuf/mu-protobuf.cabal new file mode 100644 index 00000000..55fa09b1 --- /dev/null +++ b/adapter/protobuf/mu-protobuf.cabal @@ -0,0 +1,66 @@ +name: mu-protobuf +version: 0.4.2.0 +synopsis: + Protocol Buffers serialization and gRPC schema import for Mu microservices + +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, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 +category: Network +build-type: Simple +cabal-version: >=1.10 +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 + Mu.Adapter.ProtoBuf.Via + Mu.Quasi.GRpc + Mu.Quasi.ProtoBuf + Mu.Quasi.ProtoBuf.Example + + build-depends: + base >=4.12 && <5 + , bytestring >=0.10 && <0.11 + , compendium-client >=0.2 && <0.3 + , containers >=0.6 && <0.7 + , http-client >=0.6 && <0.7 + , http2-grpc-proto3-wire >=0.1 && <0.2 + , language-protobuf >=1.0.1 && <2 + , mu-rpc >=0.4 && <0.6 + , mu-schema >=0.3.1.2 && <0.4 + , proto3-wire >=1.1 && <2 + , servant-client-core >=0.16 && <0.19 + , sop-core >=0.5 && <0.6 + , template-haskell >=2.14 && <2.17 + , text >=1.2 && <2 + + 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 + , bytestring + , containers >=0.6 && <0.7 + , mu-protobuf + , mu-schema >=0.3.0 + , proto3-wire + , text + + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall -fprint-explicit-foralls -fprint-potential-instances diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs new file mode 100644 index 00000000..fced60f6 --- /dev/null +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs @@ -0,0 +1,615 @@ +{-# language AllowAmbiguousTypes #-} +{-# language CPP #-} +{-# 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 #-} +{-| +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(..) +, ProtoBufOptionConstant(..) + -- * Conversion using schemas +, IsProtoSchema +, toProtoViaSchema +, fromProtoViaSchema +, parseProtoViaSchema + -- * Conversion using registry +, FromProtoBufRegistry +, fromProtoBufWithRegistry +, parseProtoBufWithRegistry +) where + +import Control.Applicative +import qualified Data.ByteString as BS +import Data.Int +import qualified Data.Map as M +import Data.SOP (All) +import qualified Data.Text as T +import qualified Data.Text.Lazy as LT +import Data.Word (Word32, Word64) +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 + +#if MIN_VERSION_proto3_wire(1,1,0) +instance ProtoEnum Bool +#endif + +-- | Annotations for Protocol Buffers fields. +data ProtoBufAnnotation + = -- | Numeric field identifier for normal fields + -- and whether it should be packed (only used for lists of number-like values) + ProtoBufId Nat [(Symbol, ProtoBufOptionConstant)] + -- | List of identifiers for fields which contain a union + | ProtoBufOneOfIds [Nat] + +-- Values for constants +data ProtoBufOptionConstant + = ProtoBufOptionConstantInt Nat + | ProtoBufOptionConstantBool Bool + | ProtoBufOptionConstantObject [(Symbol, ProtoBufOptionConstant)] + | ProtoBufOptionConstantOther Symbol + +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 opts) = n + FindProtoBufId' t f other + = TypeError ('Text "protocol buffers id not available for field " + ':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f) + +type family FindProtoBufPacked (sch :: Schema tn fn) (t :: tn) (f :: fn) where + FindProtoBufPacked sch t f + = FindProtoBufPacked' t f (GetFieldAnnotation (AnnotatedSchema ProtoBufAnnotation sch) t f) + +type family FindProtoBufPacked' (t :: tn) (f :: fn) (p :: ProtoBufAnnotation) :: Bool where + FindProtoBufPacked' t f ('ProtoBufId n opts) + = FindProtoBufPacked'' t f opts + FindProtoBufPacked' t f other + = TypeError ('Text "protocol buffers id not available for field " + ':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f) + +type family FindProtoBufPacked'' (t :: tn) (f :: fn) (opts :: [(Symbol, ProtoBufOptionConstant)]) :: Bool where + FindProtoBufPacked'' t f '[] = 'True -- by default we are packed + FindProtoBufPacked'' t f ( '("packed", 'ProtoBufOptionConstantBool b) ': rest ) + = b -- found! + FindProtoBufPacked'' t f ( '("packed", other) ': rest ) + = TypeError ('Text "non-boolean value for 'packed' for field " + ':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f) + FindProtoBufPacked'' t f ( other ': rest) + = FindProtoBufPacked'' t f rest + +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 + +-- | 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 sch (sch :/: sty) => IsProtoSchema sch sty +instance ProtoBridgeTerm sch (sch :/: sty) => IsProtoSchema 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 sch sty, ToSchema sch sty a) + => a -> PBEnc.MessageBuilder +toProtoViaSchema = termToProto . toSchema' @_ @_ @sch + +-- | 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 sch sty, FromSchema sch sty a) + => PBDec.Parser PBDec.RawMessage a +fromProtoViaSchema = fromSchema' @_ @_ @sch <$> 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 sch sty, FromSchema sch sty a) + => BS.ByteString -> Either PBDec.ParseError a +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 + +instance FromProtoBufRegistry '[] t where + fromProtoBufRegistry' _ = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "no schema found in registry")) +instance (IsProtoSchema s sty, FromSchema s sty t, FromProtoBufRegistry ms t) + => FromProtoBufRegistry ( (n ':-> s) ': ms) t where + fromProtoBufRegistry' _ = fromProtoViaSchema @_ @_ @s <|> fromProtoBufRegistry' (Proxy @ms) + + +-- ======================================= +-- IMPLEMENTATION OF GENERIC SERIALIZATION +-- ======================================= + +instance Alternative (PBDec.Parser i) where + empty = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "cannot parse")) + PBDec.Parser x <|> PBDec.Parser y + = PBDec.Parser $ \i -> case x i of + Left _ -> y i + 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) + +-- Embedded terms +class ProtoBridgeEmbedTerm (sch :: Schema tn fn) (t :: TypeDef tn fn) where + embedDefaultOneFieldValue :: Maybe (Term sch t) + termToEmbedProto :: FieldNumber -> Term sch t -> PBEnc.MessageBuilder + embedProtoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (Term sch t) + -- support for packed encodings + -- https://developers.google.com/protocol-buffers/docs/encoding#packed + supportsPackingTerm :: Proxy (Term sch t) -> Bool + termToPackedEmbedProto :: FieldNumber -> [Term sch t] -> PBEnc.MessageBuilder + embedProtoToPackedFieldValue :: PBDec.Parser PBDec.RawPrimitive [Term 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 ProtoBridgeOneFieldValue (sch :: Schema tn fn) (t :: FieldType tn) where + defaultOneFieldValue :: Maybe (FieldValue sch t) + oneFieldValueToProto :: FieldNumber -> FieldValue sch t -> PBEnc.MessageBuilder + protoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (FieldValue sch t) + -- support for packed encodings + -- https://developers.google.com/protocol-buffers/docs/encoding#packed + supportsPacking :: Proxy (FieldValue sch t) -> Bool + packedFieldValueToProto :: FieldNumber -> [FieldValue sch t] -> PBEnc.MessageBuilder + protoToPackedFieldValue :: 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 -- +-- -------- + +-- RECORDS +-- ------- + +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 name) fs + => NP (Field sch) fs -> PBEnc.MessageBuilder + go Nil = mempty + go (f :* fs) = fieldToProto @_ @_ @sch @name f <> go fs + protoToTerm = TRecord <$> protoToFields @_ @_ @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 + 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 ProtoBridgeTerm sch ('DRecord name args) + => ProtoBridgeEmbedTerm sch ('DRecord name args) where + embedDefaultOneFieldValue = Nothing + termToEmbedProto fid v = PBEnc.embedded fid (termToProto v) + embedProtoToOneFieldValue = PBDec.embedded' (protoToTerm @_ @_ @sch @('DRecord name args)) + supportsPackingTerm _ = False + termToPackedEmbedProto = error "this is a bug, since we declare we do not support packed encoding" + embedProtoToPackedFieldValue = error "this is a bug, since we declare we do not support packed encoding" + +-- ENUMERATIONS +-- ------------ + +instance TypeError ('Text "protobuf requires wrapping enums in a message") + => 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 sch name choices + , FindZeroEnum sch name choices ) + => ProtoBridgeEmbedTerm sch ('DEnum name choices) where + embedDefaultOneFieldValue = Just $ TEnum $ findZeroEnum @_ @_ @sch @name @choices + termToEmbedProto fid (TEnum v) = PBEnc.int32 fid (enumToProto @_ @_ @sch @name v) + embedProtoToOneFieldValue = PBDec.int32 >>= fmap TEnum . protoToEnum @_ @_ @sch @name + supportsPackingTerm _ = True + termToPackedEmbedProto fid ts + = PBEnc.packedVarints fid $ map (\(TEnum v) -> enumToProto @_ @_ @sch @name v) ts + embedProtoToPackedFieldValue = + PBDec.packedVarints >>= traverse (fmap TEnum . protoToEnum @_ @_ @sch @name) + +class ProtoBridgeEnum (sch :: Schema tn fn) (ty :: tn) (choices :: [ChoiceDef fn]) where + enumToProto :: Integral a => NS Proxy choices -> a + protoToEnum :: Int32 -> PBDec.Parser a (NS Proxy choices) +instance ProtoBridgeEnum sch ty '[] where + enumToProto = error "empty enum" + protoToEnum _ = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "unknown enum type")) +instance (KnownNat (FindProtoBufId sch ty c), ProtoBridgeEnum sch ty cs) + => ProtoBridgeEnum sch ty ('ChoiceDef c ': cs) where + enumToProto (Z _) = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c))) + enumToProto (S v) = enumToProto @_ @_ @sch @ty v + protoToEnum n + | n == enumValue = pure (Z Proxy) + | otherwise = S <$> protoToEnum @_ @_ @sch @ty n + where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c))) + +class FindZeroEnum (sch :: Schema tn fn) (ty :: tn) (choices :: [ChoiceDef fn]) where + findZeroEnum :: NS Proxy choices +class FindZeroEnum_ (sch :: Schema tn fn) (ty :: tn) (thisChoice :: ChoiceDef fn) (pbId :: Nat) (restOfChoices :: [ChoiceDef fn]) where + findZeroEnum_ :: NS Proxy (thisChoice ': restOfChoices) + +instance TypeError ('Text "could not find value 0 for enum") + => FindZeroEnum sch ty '[] where + findZeroEnum = error "this should never be called" +instance (FindZeroEnum_ sch ty ('ChoiceDef this) (FindProtoBufId sch ty this) rest) + => FindZeroEnum sch ty ('ChoiceDef this ': rest) where + findZeroEnum + = findZeroEnum_ @_ @_ @sch @ty @('ChoiceDef this) @(FindProtoBufId sch ty this) @rest + +instance {-# OVERLAPPABLE #-} + (FindZeroEnum sch ty rest) + => FindZeroEnum_ sch ty this n rest where + findZeroEnum_ = S (findZeroEnum @_ @_ @sch @ty @rest) +instance {-# OVERLAPS #-} + FindZeroEnum_ sch ty this 0 rest where + findZeroEnum_ = Z Proxy + +-- SIMPLE +-- ------ + +instance TypeError ('Text "protobuf requires wrapping primitives in a message") + => ProtoBridgeTerm sch ('DSimple t) where + termToProto = error "protobuf requires wrapping primitives in a message" + protoToTerm = error "protobuf requires wrapping primitives in a message" + +-- --------- +-- FIELDS -- +-- --------- + +instance {-# OVERLAPPABLE #-} + (ProtoBridgeOneFieldValue sch t, KnownNat (FindProtoBufId sch ty name)) + => ProtoBridgeField sch ty ('FieldDef name t) where + fieldToProto (Field v) = oneFieldValueToProto fieldId v + where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name)) + protoToField + = Field <$> case defaultOneFieldValue of + Nothing -> do r <- one (Just <$> protoToOneFieldValue) Nothing `at` fieldId + maybe empty pure r + Just d -> one protoToOneFieldValue d `at` fieldId <|> pure d + where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name)) + +instance {-# OVERLAPS #-} + (ProtoBridgeOneFieldValue sch t, KnownNat (FindProtoBufId sch ty name)) + => ProtoBridgeField sch ty ('FieldDef name ('TOption t)) where + fieldToProto (Field (FOption Nothing)) = mempty + fieldToProto (Field (FOption (Just v))) = oneFieldValueToProto fieldId v + where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name)) + protoToField = Field . FOption <$> + (PBDec.one (Just <$> protoToOneFieldValue) Nothing `at` fieldId <|> pure Nothing) + where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name)) + +class KnownBool (b :: Bool) where + boolVal :: proxy b -> Bool +instance KnownBool 'True where + boolVal _ = True +instance KnownBool 'False where + boolVal _ = False + +instance {-# OVERLAPS #-} + ( ProtoBridgeOneFieldValue sch t + , KnownNat (FindProtoBufId sch ty name) + , KnownBool (FindProtoBufPacked sch ty name) ) + => ProtoBridgeField sch ty ('FieldDef name ('TList t)) where + fieldToProto (Field (FList xs)) + | boolVal (Proxy @(FindProtoBufPacked sch ty name)) + , supportsPacking (Proxy @(FieldValue sch t)) + = packedFieldValueToProto fieldId xs + | otherwise + = foldMap (oneFieldValueToProto fieldId) xs + where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name)) + protoToField = Field . FList <$> go + where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name)) + base = PBDec.repeated protoToOneFieldValue `at` fieldId <|> pure [] + go | supportsPacking (Proxy @(FieldValue sch t)) + = PBDec.one protoToPackedFieldValue [] `at` fieldId <|> base + | otherwise + = base + +-- see https://developers.google.com/protocol-buffers/docs/proto3#maps +{- +message MapFieldEntry { + key_type key = 1; + value_type value = 2; +} + +repeated MapFieldEntry map_field = N; +-} +instance ( KnownNat (FindProtoBufId sch ty name) + , ProtoBridgeOneFieldValue sch k + , ProtoBridgeOneFieldValue sch v + , Ord (FieldValue sch k) ) + => ProtoBridgeField sch ty ('FieldDef name ('TMap k v)) where + fieldToProto (Field (FMap mp)) + = foldMap oneMapValueToProto (M.toAscList mp) + where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name)) + oneMapValueToProto (k, v) + = PBEnc.embedded fieldId $ + oneFieldValueToProto 1 k <> oneFieldValueToProto 2 v + protoToField = Field . FMap . M.fromList <$> go + where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name)) + go = PBDec.repeated ( + PBDec.embedded' + ((,) <$> fieldValueWithDefault 1 + <*> fieldValueWithDefault 2)) + `at` fieldId + fieldValueWithDefault innerFieldId + = case defaultOneFieldValue of + Nothing + -> do r <- PBDec.one (Just <$> protoToOneFieldValue) Nothing `at` innerFieldId + maybe empty pure r + Just d + -> PBDec.one protoToOneFieldValue d `at` innerFieldId <|> pure d + +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) + +-- ------------------ +-- TYPES OF FIELDS -- +-- ------------------ + +-- SCHEMATIC +-- --------- + +instance ProtoBridgeEmbedTerm sch (sch :/: t) + => ProtoBridgeOneFieldValue sch ('TSchematic t) where + defaultOneFieldValue = FSchematic <$> embedDefaultOneFieldValue + oneFieldValueToProto fid (FSchematic v) = termToEmbedProto fid v + protoToOneFieldValue = FSchematic <$> embedProtoToOneFieldValue + supportsPacking _ = supportsPackingTerm (Proxy @(Term sch (sch :/: t))) + packedFieldValueToProto fid vs = termToPackedEmbedProto fid $ map (\(FSchematic t) -> t) vs + protoToPackedFieldValue = map FSchematic <$> embedProtoToPackedFieldValue + +-- PRIMITIVE TYPES +-- --------------- + +instance TypeError ('Text "null cannot be converted to protobuf") + => ProtoBridgeOneFieldValue sch 'TNull where + defaultOneFieldValue = error "null cannot be converted to protobuf" + oneFieldValueToProto = error "null cannot be converted to protobuf" + protoToOneFieldValue = error "null cannot be converted to protobuf" + supportsPacking _ = False + packedFieldValueToProto = error "null cannot be converted to protobuf" + protoToPackedFieldValue = error "null cannot be converted to protobuf" + +instance ProtoBridgeOneFieldValue sch ('TPrimitive Int) where + defaultOneFieldValue = Just $ FPrimitive 0 + oneFieldValueToProto fid (FPrimitive n) = PBEnc.int32 fid (fromIntegral n) + protoToOneFieldValue = FPrimitive . fromIntegral <$> PBDec.int32 + supportsPacking _ = True + packedFieldValueToProto fid vs + = PBEnc.packedVarints fid $ map (\(FPrimitive i) -> fromIntegral i) vs + protoToPackedFieldValue = map FPrimitive <$> PBDec.packedVarints + +instance ProtoBridgeOneFieldValue sch ('TPrimitive Int32) where + defaultOneFieldValue = Just $ FPrimitive 0 + oneFieldValueToProto fid (FPrimitive n) = PBEnc.int32 fid n + protoToOneFieldValue = FPrimitive <$> PBDec.int32 + supportsPacking _ = True + packedFieldValueToProto fid vs + = PBEnc.packedVarints fid $ map (\(FPrimitive i) -> fromIntegral i) vs + protoToPackedFieldValue = map FPrimitive <$> PBDec.packedVarints + +instance ProtoBridgeOneFieldValue sch ('TPrimitive Int64) where + defaultOneFieldValue = Just $ FPrimitive 0 + oneFieldValueToProto fid (FPrimitive n) = PBEnc.int64 fid n + protoToOneFieldValue = FPrimitive <$> PBDec.int64 + supportsPacking _ = True + packedFieldValueToProto fid vs + = PBEnc.packedVarints fid $ map (\(FPrimitive i) -> fromIntegral i) vs + protoToPackedFieldValue = map FPrimitive <$> PBDec.packedVarints + +instance ProtoBridgeOneFieldValue sch ('TPrimitive Word32) where + defaultOneFieldValue = Just $ FPrimitive 0 + oneFieldValueToProto fid (FPrimitive n) = PBEnc.uint32 fid n + protoToOneFieldValue = FPrimitive <$> PBDec.uint32 + supportsPacking _ = True + packedFieldValueToProto fid vs = PBEnc.packedVarints fid $ map (\(FPrimitive i) -> fromIntegral i) vs + protoToPackedFieldValue = map FPrimitive <$> PBDec.packedVarints + +instance ProtoBridgeOneFieldValue sch ('TPrimitive Word64) where + defaultOneFieldValue = Just $ FPrimitive 0 + oneFieldValueToProto fid (FPrimitive n) = PBEnc.uint64 fid n + protoToOneFieldValue = FPrimitive <$> PBDec.uint64 + supportsPacking _ = True + packedFieldValueToProto fid vs = PBEnc.packedVarints fid $ map (\(FPrimitive i) -> i) vs + protoToPackedFieldValue = map FPrimitive <$> PBDec.packedVarints + +-- WARNING! These instances may go out of bounds +instance ProtoBridgeOneFieldValue sch ('TPrimitive Integer) where + defaultOneFieldValue = Just $ FPrimitive 0 + oneFieldValueToProto fid (FPrimitive n) = PBEnc.int64 fid (fromInteger n) + protoToOneFieldValue = FPrimitive . fromIntegral <$> PBDec.int64 + supportsPacking _ = True + packedFieldValueToProto fid vs + = PBEnc.packedVarints fid $ map (\(FPrimitive i) -> fromIntegral i) vs + protoToPackedFieldValue = map FPrimitive <$> PBDec.packedVarints + +instance ProtoBridgeOneFieldValue sch ('TPrimitive Float) where + defaultOneFieldValue = Just $ FPrimitive 0 + oneFieldValueToProto fid (FPrimitive n) = PBEnc.float fid n + protoToOneFieldValue = FPrimitive <$> PBDec.float + supportsPacking _ = True + packedFieldValueToProto fid vs + = PBEnc.packedFloats fid $ map (\(FPrimitive i) -> i) vs + protoToPackedFieldValue = map FPrimitive <$> PBDec.packedFloats + +instance ProtoBridgeOneFieldValue sch ('TPrimitive Double) where + defaultOneFieldValue = Just $ FPrimitive 0 + oneFieldValueToProto fid (FPrimitive n) = PBEnc.double fid n + protoToOneFieldValue = FPrimitive <$> PBDec.double + supportsPacking _ = True + packedFieldValueToProto fid vs + = PBEnc.packedDoubles fid $ map (\(FPrimitive i) -> i) vs + protoToPackedFieldValue = map FPrimitive <$> PBDec.packedDoubles + +instance ProtoBridgeOneFieldValue sch ('TPrimitive Bool) where + defaultOneFieldValue = Just $ FPrimitive False + oneFieldValueToProto fid (FPrimitive n) = PBEnc.enum fid n + protoToOneFieldValue = FPrimitive <$> PBDec.bool + supportsPacking _ = True + packedFieldValueToProto fid vs + = PBEnc.packedVarints fid $ map (\(FPrimitive i) -> if i then 1 else 0) vs + protoToPackedFieldValue = map (\(i :: Integer) -> FPrimitive (i /= 0)) <$> PBDec.packedVarints + +instance ProtoBridgeOneFieldValue sch ('TPrimitive T.Text) where + defaultOneFieldValue = Just $ FPrimitive "" + oneFieldValueToProto fid (FPrimitive n) = PBEnc.text fid (LT.fromStrict n) + protoToOneFieldValue = FPrimitive . LT.toStrict <$> PBDec.text + supportsPacking _ = False + packedFieldValueToProto = error "this is a bug, since we declare we do not support packed encoding" + protoToPackedFieldValue = error "this is a bug, since we declare we do not support packed encoding" + +instance ProtoBridgeOneFieldValue sch ('TPrimitive LT.Text) where + defaultOneFieldValue = Just $ FPrimitive "" + oneFieldValueToProto fid (FPrimitive n) = PBEnc.text fid n + protoToOneFieldValue = FPrimitive <$> PBDec.text + supportsPacking _ = False + packedFieldValueToProto = error "this is a bug, since we declare we do not support packed encoding" + protoToPackedFieldValue = error "this is a bug, since we declare we do not support packed encoding" + +instance ProtoBridgeOneFieldValue sch ('TPrimitive BS.ByteString) where + defaultOneFieldValue = Just $ FPrimitive "" + oneFieldValueToProto fid (FPrimitive n) = PBEnc.byteString fid n + protoToOneFieldValue = FPrimitive <$> PBDec.byteString + supportsPacking _ = False + packedFieldValueToProto = error "this is a bug, since we declare we do not support packed encoding" + protoToPackedFieldValue = error "this is a bug, since we declare we do not support packed encoding" + +-- Note that Maybes and Lists require that we recur on the OneFieldValue class + +instance TypeError ('Text "optionals cannot be nested in protobuf") + => ProtoBridgeOneFieldValue sch ('TOption t) where + defaultOneFieldValue = error "optionals cannot be nested in protobuf" + oneFieldValueToProto = error "optionals cannot be nested in protobuf" + protoToOneFieldValue = error "optionals cannot be nested in protobuf" + supportsPacking = error "optionals cannot be nested in protobuf" + packedFieldValueToProto = error "optionals cannot be nested in protobuf" + protoToPackedFieldValue = error "optionals cannot be nested in protobuf" + +instance TypeError ('Text "lists cannot be nested in protobuf") + => ProtoBridgeOneFieldValue sch ('TList t) where + defaultOneFieldValue = error "lists cannot be nested in protobuf" + oneFieldValueToProto = error "lists cannot be nested in protobuf" + protoToOneFieldValue = error "lists cannot be nested in protobuf" + supportsPacking = error "lists cannot be nested in protobuf" + packedFieldValueToProto = error "lists cannot be nested in protobuf" + protoToPackedFieldValue = error "lists cannot be nested in protobuf" + +instance TypeError ('Text "maps cannot be nested in protobuf") + => ProtoBridgeOneFieldValue sch ('TMap k v) where + defaultOneFieldValue = error "maps cannot be nested in protobuf" + oneFieldValueToProto = error "maps cannot be nested in protobuf" + protoToOneFieldValue = error "maps cannot be nested in protobuf" + supportsPacking = error "maps cannot be nested in protobuf" + packedFieldValueToProto = error "maps cannot be nested in protobuf" + protoToPackedFieldValue = error "maps cannot be nested in protobuf" + +instance TypeError ('Text "nested unions are not currently supported") + => ProtoBridgeOneFieldValue sch ('TUnion choices) where + defaultOneFieldValue = error "nested unions are not currently supported" + oneFieldValueToProto = error "nested unions are not currently supported" + protoToOneFieldValue = error "nested unions are not currently supported" + supportsPacking = error "nested unions are not currently supported" + packedFieldValueToProto = error "nested unions are not currently supported" + protoToPackedFieldValue = 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 ( ProtoBridgeOneFieldValue sch t, KnownNat thisId + , ProtoBridgeUnionFieldValue restIds sch ts ) + => ProtoBridgeUnionFieldValue (thisId ': restIds) sch (t ': ts) where + unionFieldValueToProto (Z v) = oneFieldValueToProto fieldId v + where fieldId = fromInteger $ natVal (Proxy @thisId) + unionFieldValueToProto (S v) = unionFieldValueToProto @_ @_ @restIds v + protoToUnionFieldValue + = Z <$> p <|> S <$> protoToUnionFieldValue @_ @_ @restIds + where fieldId = fromInteger $ natVal (Proxy @thisId) + p = do r <- one (Just <$> protoToOneFieldValue) Nothing `at` fieldId + maybe empty pure r diff --git a/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs new file mode 100644 index 00000000..233b59ff --- /dev/null +++ b/adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs @@ -0,0 +1,74 @@ +{-# 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 #-} +{-| +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 +import qualified Proto3.Wire.Decode as PBDec +import qualified Proto3.Wire.Encode as PBEnc + +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 snm) 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 snm) 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 = pure () + +-- | Types which can be parsed from a Protocol Buffers message. +class FromProtoBufTypeRef (ref :: TypeRef snm) t where + fromProtoBufTypeRef :: Proxy ref -> PBDec.Parser PBDec.RawMessage t +-- | Types which can be turned into a Protocol Buffers message. +class ToProtoBufTypeRef (ref :: TypeRef snm) t where + toProtoBufTypeRef :: Proxy ref -> t -> PBEnc.MessageBuilder + +instance (IsProtoSchema sch sty, FromSchema sch sty t) + => FromProtoBufTypeRef ('SchemaRef sch sty) t where + fromProtoBufTypeRef _ = fromProtoViaSchema @_ @_ @sch +instance (IsProtoSchema sch sty, ToSchema sch sty t) + => ToProtoBufTypeRef ('SchemaRef sch sty) t where + toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @sch + +instance ( FromProtoBufRegistry r t + , IsProtoSchema (MappingRight r last) sty + , FromSchema (MappingRight r last) sty t ) + => FromProtoBufTypeRef ('RegistryRef r t last) t where + fromProtoBufTypeRef _ = fromProtoBufWithRegistry @r +instance ( FromProtoBufRegistry r t + , IsProtoSchema (MappingRight r last) sty + , ToSchema (MappingRight r last) sty t ) + => ToProtoBufTypeRef ('RegistryRef 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 new file mode 100644 index 00000000..a7d19328 --- /dev/null +++ b/adapter/protobuf/src/Mu/Quasi/GRpc.hs @@ -0,0 +1,112 @@ +{-# language DataKinds #-} +{-# language KindSignatures #-} +{-# language OverloadedStrings #-} +{-# language TemplateHaskell #-} +{-| +Description : Quasi-quoters for gRPC files + +Read @.proto@ files as a 'Mu.Schema.Definition.Schema' +and a set of 'Service's. The origin of those @.proto@ +files can be local (if using 'grpc') or come +from a Compendium Registry (if using 'compendium'). +-} +module Mu.Quasi.GRpc ( + grpc +, compendium +) where + +import Control.Monad.IO.Class +import qualified Data.Text as T +import GHC.TypeLits +import Language.Haskell.TH +import Language.ProtocolBuffers.Parser +import qualified Language.ProtocolBuffers.Types as P +import Network.HTTP.Client +import Servant.Client.Core.BaseUrl + +import Compendium.Client +import Mu.Quasi.ProtoBuf +import Mu.Rpc + +-- | Reads a @.proto@ file and generates: +-- * A 'Mu.Schema.Definition.Schema' with all the message +-- types, using the name given as first argument. +-- * A 'Service' declaration for each service in the file, +-- where the name is obtained by applying the function +-- given as second argument to the name in the file. +grpc :: String -> (String -> String) -> FilePath -> Q [Dec] +grpc schemaName servicePrefix fp + = do r <- liftIO $ parseProtoBufFile fp + case r of + Left e + -> fail ("could not parse protocol buffers spec: " ++ show e) + Right p + -> grpcToDecls 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 + -> grpcToDecls schemaTypeName servicePrefix p + +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 <- protobufToDecls schemaName p + serviceTy <- mapM (pbServiceDeclToDec servicePrefix pkg schemaName') srvs + pure (schemaDec ++ serviceTy) + +pbServiceDeclToDec :: (String -> String) -> Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Dec +pbServiceDeclToDec servicePrefix pkg schema srv@(P.Service nm _ _) + = tySynD (mkName $ servicePrefix $ T.unpack nm) [] + (pbServiceDeclToType pkg schema srv) + +pbServiceDeclToType :: Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Type +pbServiceDeclToType pkg schema (P.Service nm _ methods) + = [t| 'Package $(pkgType pkg) + '[ 'Service $(textToStrLit nm) + $(typesToList <$> mapM (pbMethodToType schema) methods) ] |] + where + pkgType Nothing = [t| ('Nothing :: Maybe Symbol) |] + pkgType (Just p) = [t| 'Just $(textToStrLit (T.intercalate "." p)) |] + +pbMethodToType :: Name -> P.Method -> Q Type +pbMethodToType s (P.Method nm vr v rr r _) + = [t| 'Method $(textToStrLit nm) + $(argToType vr v) $(retToType rr r) |] + where + argToType P.Single (P.TOther ["google","protobuf","Empty"]) + = [t| '[ ] |] + argToType P.Single (P.TOther a) + = [t| '[ 'ArgSingle ('Nothing :: Maybe Symbol) ('SchemaRef $(schemaTy s) $(textToStrLit (T.intercalate "." a))) ] |] + argToType P.Stream (P.TOther a) + = [t| '[ 'ArgStream ('Nothing :: Maybe Symbol) ('SchemaRef $(schemaTy s) $(textToStrLit (T.intercalate "." 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 ('SchemaRef $(schemaTy s) $(textToStrLit (T.intercalate "." a))) |] + retToType P.Stream (P.TOther a) + = [t| 'RetStream ('SchemaRef $(schemaTy s) $(textToStrLit (T.intercalate "." a))) |] + retToType _ _ + = fail "only message types may be used as results" + +schemaTy :: Name -> Q Type +schemaTy schema = pure $ ConT schema + +typesToList :: [Type] -> Type +typesToList + = foldr (AppT . AppT PromotedConsT) PromotedNilT +textToStrLit :: T.Text -> Q Type +textToStrLit s + = pure $ LitT $ StrTyLit $ T.unpack s diff --git a/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs b/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs new file mode 100644 index 00000000..7360e6b7 --- /dev/null +++ b/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs @@ -0,0 +1,229 @@ +{-# language CPP #-} +{-# language DataKinds #-} +{-# language LambdaCase #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# 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 + -- * Only for internal use + , protobufToDecls + ) where + +import Control.Monad (when) +import Control.Monad.IO.Class +import qualified Data.ByteString as B +import Data.Int +import qualified Data.List as L +import Data.List.NonEmpty (NonEmpty (..)) +import qualified Data.Text as T +import Data.Word +import Language.Haskell.TH +import Language.ProtocolBuffers.Parser +import qualified Language.ProtocolBuffers.Types as P + +import Mu.Adapter.ProtoBuf +import Mu.Schema.Annotations +import Mu.Schema.Definition + +-- | 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] +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 + +-- | Shared portion of Protocol Buffers and gRPC quasi-quoters. +protobufToDecls :: String -> P.ProtoBuf -> Q [Dec] +protobufToDecls schemaName p + = do let schemaName' = mkName schemaName + (schTy, annTy) <- schemaFromProtoBuf p + schemaDec <- tySynD schemaName' [] (pure schTy) +#if MIN_VERSION_template_haskell(2,15,0) + annDec <- tySynInstD (tySynEqn Nothing + [t| AnnotatedSchema ProtoBufAnnotation $(conT schemaName') |] + (pure annTy)) +#else + annDec <- tySynInstD ''AnnotatedSchema + (tySynEqn [ [t| ProtoBufAnnotation |], conT schemaName' ] (pure annTy)) +#endif + pure [schemaDec, annDec] + +schemaFromProtoBuf :: P.ProtoBuf -> Q (Type, Type) +schemaFromProtoBuf P.ProtoBuf {P.types = tys} = do + let decls = flattenDecls (("", tys) :| []) tys + (schTys, anns) <- unzip <$> mapM (pbTypeDeclToType $ shouldOptional decls) decls + pure (typesToList schTys, typesToList (concat anns)) + where + shouldOptional :: [P.TypeDeclaration] -> P.TypeName -> Bool + shouldOptional [] _ = error "this should never happen" + shouldOptional (P.DMessage nm _ _ _ _ : _) this + | nm == last this = True + shouldOptional (P.DEnum nm _ _ : _) this + | nm == last this = False + shouldOptional (_ : rest) this + = shouldOptional rest this + +flattenDecls :: NonEmpty (P.Identifier, [P.TypeDeclaration]) -> [P.TypeDeclaration] -> [P.TypeDeclaration] +flattenDecls (currentScope :| higherScopes) = concatMap flattenDecl + where + flattenDecl (P.DEnum name o f) = [P.DEnum (prependCurrentScope name) o f] + flattenDecl (P.DMessage name o r fs decls) = + let newScopeName = prependCurrentScope name + newScopes = (newScopeName, decls) :| (currentScope : higherScopes) + in P.DMessage newScopeName o r (scopeFieldType newScopes <$> fs) [] : flattenDecls newScopes decls + + scopeFieldType scopes (P.NormalField frep ftype fname fnum fopts) = + P.NormalField frep (qualifyType scopes ftype) fname fnum fopts + scopeFieldType scopes (P.OneOfField fname fields) = P.OneOfField fname (scopeFieldType scopes <$> fields) + scopeFieldType scopes (P.MapField fkey fval fname fnumber fopts) = + P.MapField (qualifyType scopes fkey) (qualifyType scopes fval) fname fnumber fopts + + qualifyType scopes (P.TOther ts) = P.TOther (qualifyTOther scopes ts) + qualifyType _scopes t = t + + qualifyTOther _scopes [] = error "This shouldn't be possible" + qualifyTOther ((_, _) :| []) ts = + [T.intercalate "." ts] -- Top level scope, no need to search anything, use + -- the name as is. Maybe we should search and fail + -- if a type is not found even from top level, but + -- that could be a lot of work as this function is + -- pure right now. + qualifyTOther ((scopeName, decls) :| (restFirst : restTail)) ts = + if L.any (hasDeclFor ts) decls + then [T.intercalate "." (scopeName:ts)] + else qualifyTOther (restFirst :| restTail) ts + + hasDeclFor [] _ = True + hasDeclFor [t] (P.DEnum enumName _ _) = t == enumName + hasDeclFor (_:_:_) P.DEnum{} = False + hasDeclFor (t:ts) (P.DMessage msgName _ _ _ rest) = + let nameMatch = t == msgName + -- 'L.any' returns 'False' if 'rest' is empty, hence the 'null ts' + -- check is required. + restMatch = null ts || L.any (hasDeclFor ts) rest + in nameMatch && restMatch + + prependCurrentScope x = + case fst currentScope of + "" -> x + _ -> fst currentScope <> "." <> x + +pbTypeDeclToType :: (P.TypeName -> Bool) -> P.TypeDeclaration -> Q (Type, [Type]) +pbTypeDeclToType _ (P.DEnum name _ fields) = do + (tys, anns) <- unzip <$> mapM pbChoiceToType fields + (,) <$> [t|'DEnum $(textToStrLit name) $(pure $ typesToList tys)|] <*> pure anns + where + 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 shouldOptional (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, Type) + -- If we have a field type which is not primitive, + -- it's possible to distinguish whether it's missing on wire + -- or should be set to the default, so use Option + -- +info -> https://github.com/higherkindness/mu-haskell/pull/130#issuecomment-596433307 + pbMsgFieldToType (P.NormalField P.Single ty@(P.TOther innerTy) nm n opts) + | shouldOptional innerTy = + (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TOption $(pbFieldTypeToType ty)) |] + <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption opts)) |] + | otherwise = + (,) <$> [t| 'FieldDef $(textToStrLit nm) $(pbFieldTypeToType ty) |] + <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption opts)) |] + pbMsgFieldToType (P.NormalField P.Single ty nm n opts) = + (,) <$> [t| 'FieldDef $(textToStrLit nm) $(pbFieldTypeToType ty) |] + <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption opts)) |] + pbMsgFieldToType (P.NormalField P.Repeated ty nm n opts) = + (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TList $(pbFieldTypeToType ty)) |] + <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption opts)) |] + pbMsgFieldToType (P.MapField k v nm n opts) = + (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v)) |] + <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption opts)) |] + pbMsgFieldToType (P.OneOfField nm vs) + | not (all hasFieldNumber vs) + = fail "nested oneof fields are not supported" + | otherwise + = (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TUnion $(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|] + pbFieldTypeToType P.TUInt32 = [t|'TPrimitive Word32|] + pbFieldTypeToType P.TSInt32 = [t|'TPrimitive Int32|] + pbFieldTypeToType P.TInt64 = [t|'TPrimitive Int64|] + pbFieldTypeToType P.TUInt64 = [t|'TPrimitive Word64|] + 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 + 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" + + pbOption (P.Option oname val) + = do when (oname == ["default"]) + (reportError "mu-protobuf does not (yet) support default values") + [t| '( $(textToStrLit (T.intercalate "." oname)) + , $(pbConstantToOption val) ) |] + + pbConstantToOption (P.KIdentifier names) + = [t| 'ProtoBufOptionConstantOther $(textToStrLit (T.intercalate "." names)) |] + pbConstantToOption (P.KInt n) + = [t| 'ProtoBufOptionConstantInt $(intToLit (fromInteger n)) |] + pbConstantToOption (P.KBool True) + = [t| 'ProtoBufOptionConstantBool 'True |] + pbConstantToOption (P.KBool False) + = [t| 'ProtoBufOptionConstantBool 'False |] + pbConstantToOption (P.KString s) + = [t| 'ProtoBufOptionConstantOther $(textToStrLit s) |] + pbConstantToOption (P.KFloat s) + = [t| 'ProtoBufOptionConstantOther $(textToStrLit (T.pack (show s))) |] + pbConstantToOption (P.KObject s) + = [t| 'ProtoBufOptionConstantObject + $(typesToList <$> mapM (\(n, o) -> [t| '( $(textToStrLit n), $(pbConstantToOption o) ) |] ) s ) |] + +typesToList :: [Type] -> Type +typesToList = foldr (AppT . AppT PromotedConsT) PromotedNilT + +textToStrLit :: T.Text -> Q Type +textToStrLit s = pure $ LitT $ StrTyLit $ T.unpack s + +intToLit :: Int -> Q Type +intToLit n = pure $ LitT $ NumTyLit $ toInteger n diff --git a/adapter/protobuf/src/Mu/Quasi/ProtoBuf/Example.hs b/adapter/protobuf/src/Mu/Quasi/ProtoBuf/Example.hs new file mode 100644 index 00000000..9f7cb08a --- /dev/null +++ b/adapter/protobuf/src/Mu/Quasi/ProtoBuf/Example.hs @@ -0,0 +1,20 @@ +{-# language CPP #-} +{-# language DataKinds #-} +{-# language TemplateHaskell #-} +{-# language TypeFamilies #-} +{-| +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 + +#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/adapter/protobuf/test/ProtoBuf.hs b/adapter/protobuf/test/ProtoBuf.hs new file mode 100644 index 00000000..54cffeee --- /dev/null +++ b/adapter/protobuf/test/ProtoBuf.hs @@ -0,0 +1,107 @@ +{-# language CPP #-} +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingVia #-} +{-# language EmptyCase #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} +{-# language TemplateHaskell #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +module Main where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.Map as M +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 + +import Data.Int +import Mu.Adapter.ProtoBuf +import Mu.Quasi.ProtoBuf +import Mu.Schema + +#if __GHCIDE__ +protobuf "ExampleSchema" "adapter/protobuf/test/protobuf/example.proto" +#else +protobuf "ExampleSchema" "test/protobuf/example.proto" +#endif + +data MGender = NB | Male | Female + deriving (Eq, Show, Generic) + deriving (ToSchema ExampleSchema "gender", FromSchema ExampleSchema "gender") + via CustomFieldMapping "gender" + ["NB" ':-> "nb", "Male" ':-> "male", "Female" ':-> "female" ] MGender + +data MPerson + = MPerson { firstName :: T.Text + , lastName :: T.Text + , age :: Int32 + , gender :: MGender + , address :: Maybe MAddress + , lucky_numbers :: [Int32] + , things :: M.Map T.Text Int32 + , foo :: Maybe MFoo + } + deriving (Eq, Show, Generic) + deriving (ToSchema ExampleSchema "person") + deriving (FromSchema ExampleSchema "person") + +newtype MFoo + = MFoo { fooChoice :: MFooChoice } + deriving (Eq, Show, Generic) + deriving (ToSchema ExampleSchema "Foo") + deriving (FromSchema ExampleSchema "Foo") + +data MFooChoice + = FooInt Int32 + | FooString T.Text + | FooOtherInt Int32 + | FooYetAnotherInt Int32 + deriving (Eq, Show, Generic) + +data MAddress + = MAddress { postcode :: T.Text + , country :: T.Text } + deriving (Eq, Show, Generic) + deriving (ToSchema ExampleSchema "address") + deriving (FromSchema ExampleSchema "address") + +exampleAddress :: Maybe MAddress +exampleAddress = Just $ MAddress "0000AA" "Nederland" + +examplePerson1, examplePerson2 :: MPerson +examplePerson1 = MPerson "Pythonio" "van Gogh" + 30 Male + exampleAddress [1,2,3] + (M.fromList [("hola", 1), ("hello", 2), ("hallo", 3)]) + (Just $ MFoo $ FooString "blah") +examplePerson2 = MPerson "Cuarenta" "Siete" + 0 NB + exampleAddress [] M.empty + (Just $ MFoo $ FooInt 3) + +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 parsedPerson1 = PBDec.parse (fromProtoViaSchema @_ @_ @ExampleSchema) cbs + if parsedPerson1 == examplePerson1 + then putStrLn $ "Parsed correctly as: \n" <> show parsedPerson1 + else putStrLn $ "Parsed person does not match expected person\n" + <> "Parsed person: \n" <> show parsedPerson1 + <> "\nExpected person: \n" <> show examplePerson1 + -- Encode a couple of values + putStrLn "haskell/generate" + print examplePerson1 + let gbs = PBEnc.toLazyByteString (toProtoViaSchema @_ @_ @ExampleSchema examplePerson1) + LBS.writeFile genFile gbs diff --git a/schema/test/protobuf/consume.py b/adapter/protobuf/test/protobuf/consume.py similarity index 80% rename from schema/test/protobuf/consume.py rename to adapter/protobuf/test/protobuf/consume.py index 99a32508..67f6f1b0 100644 --- a/schema/test/protobuf/consume.py +++ b/adapter/protobuf/test/protobuf/consume.py @@ -1,7 +1,8 @@ from example_pb2 import * +import sys f = open(sys.argv[1], "rb") example_person = person() example_person.ParseFromString(f.read()) f.close() -print(example_person) \ No newline at end of file +print(example_person) diff --git a/schema/test/protobuf/example.proto b/adapter/protobuf/test/protobuf/example.proto similarity index 50% rename from schema/test/protobuf/example.proto rename to adapter/protobuf/test/protobuf/example.proto index 8d4ae311..77897947 100644 --- a/schema/test/protobuf/example.proto +++ b/adapter/protobuf/test/protobuf/example.proto @@ -6,6 +6,9 @@ message person { int32 age = 3; gender gender = 4; address address = 5; + repeated int32 lucky_numbers = 6 [packed=true]; + map things = 7; + Foo foo = 8; } message address { @@ -17,4 +20,13 @@ enum gender { nb = 0; male = 1; female = 2; -} \ No newline at end of file +} + +message Foo { + oneof fooChoice { + int32 foo_int = 1; + string foo_string = 2; + int32 foo_other_int = 3; + int32 foo_yet_another_int = 4; + } +} 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/adapter/protobuf/test/protobuf/example_pb2.py b/adapter/protobuf/test/protobuf/example_pb2.py new file mode 100644 index 00000000..1b2b98e3 --- /dev/null +++ b/adapter/protobuf/test/protobuf/example_pb2.py @@ -0,0 +1,313 @@ +# -*- coding: utf-8 -*- +# Generated by the protocol buffer compiler. DO NOT EDIT! +# source: example.proto +"""Generated protocol buffer code.""" +from google.protobuf.internal import enum_type_wrapper +from google.protobuf import descriptor as _descriptor +from google.protobuf import message as _message +from google.protobuf import reflection as _reflection +from google.protobuf import symbol_database as _symbol_database +# @@protoc_insertion_point(imports) + +_sym_db = _symbol_database.Default() + + + + +DESCRIPTOR = _descriptor.FileDescriptor( + name='example.proto', + package='', + syntax='proto3', + serialized_options=None, + create_key=_descriptor._internal_create_key, + serialized_pb=b'\n\rexample.proto\"\xf0\x01\n\x06person\x12\x11\n\tfirstName\x18\x01 \x01(\t\x12\x10\n\x08lastName\x18\x02 \x01(\t\x12\x0b\n\x03\x61ge\x18\x03 \x01(\x05\x12\x17\n\x06gender\x18\x04 \x01(\x0e\x32\x07.gender\x12\x19\n\x07\x61\x64\x64ress\x18\x05 \x01(\x0b\x32\x08.address\x12\x19\n\rlucky_numbers\x18\x06 \x03(\x05\x42\x02\x10\x01\x12#\n\x06things\x18\x07 \x03(\x0b\x32\x13.person.ThingsEntry\x12\x11\n\x03\x66oo\x18\x08 \x01(\x0b\x32\x04.Foo\x1a-\n\x0bThingsEntry\x12\x0b\n\x03key\x18\x01 \x01(\t\x12\r\n\x05value\x18\x02 \x01(\x05:\x02\x38\x01\",\n\x07\x61\x64\x64ress\x12\x10\n\x08postcode\x18\x01 \x01(\t\x12\x0f\n\x07\x63ountry\x18\x02 \x01(\t\"5\n\x03\x46oo\x12\x11\n\x07\x66oo_int\x18\x01 \x01(\x05H\x00\x12\x14\n\nfoo_string\x18\x02 \x01(\tH\x00\x42\x05\n\x03\x46oo*&\n\x06gender\x12\x06\n\x02nb\x10\x00\x12\x08\n\x04male\x10\x01\x12\n\n\x06\x66\x65male\x10\x02\x62\x06proto3' +) + +_GENDER = _descriptor.EnumDescriptor( + name='gender', + full_name='gender', + filename=None, + file=DESCRIPTOR, + create_key=_descriptor._internal_create_key, + values=[ + _descriptor.EnumValueDescriptor( + name='nb', index=0, number=0, + serialized_options=None, + type=None, + create_key=_descriptor._internal_create_key), + _descriptor.EnumValueDescriptor( + name='male', index=1, number=1, + serialized_options=None, + type=None, + create_key=_descriptor._internal_create_key), + _descriptor.EnumValueDescriptor( + name='female', index=2, number=2, + serialized_options=None, + type=None, + create_key=_descriptor._internal_create_key), + ], + containing_type=None, + serialized_options=None, + serialized_start=361, + serialized_end=399, +) +_sym_db.RegisterEnumDescriptor(_GENDER) + +gender = enum_type_wrapper.EnumTypeWrapper(_GENDER) +nb = 0 +male = 1 +female = 2 + + + +_PERSON_THINGSENTRY = _descriptor.Descriptor( + name='ThingsEntry', + full_name='person.ThingsEntry', + filename=None, + file=DESCRIPTOR, + containing_type=None, + create_key=_descriptor._internal_create_key, + fields=[ + _descriptor.FieldDescriptor( + name='key', full_name='person.ThingsEntry.key', index=0, + number=1, type=9, cpp_type=9, label=1, + has_default_value=False, default_value=b"".decode('utf-8'), + message_type=None, enum_type=None, containing_type=None, + is_extension=False, extension_scope=None, + serialized_options=None, file=DESCRIPTOR, create_key=_descriptor._internal_create_key), + _descriptor.FieldDescriptor( + name='value', full_name='person.ThingsEntry.value', index=1, + number=2, type=5, cpp_type=1, label=1, + has_default_value=False, default_value=0, + message_type=None, enum_type=None, containing_type=None, + is_extension=False, extension_scope=None, + serialized_options=None, file=DESCRIPTOR, create_key=_descriptor._internal_create_key), + ], + extensions=[ + ], + nested_types=[], + enum_types=[ + ], + serialized_options=b'8\001', + is_extendable=False, + syntax='proto3', + extension_ranges=[], + oneofs=[ + ], + serialized_start=213, + serialized_end=258, +) + +_PERSON = _descriptor.Descriptor( + name='person', + full_name='person', + filename=None, + file=DESCRIPTOR, + containing_type=None, + create_key=_descriptor._internal_create_key, + fields=[ + _descriptor.FieldDescriptor( + name='firstName', full_name='person.firstName', index=0, + number=1, type=9, cpp_type=9, label=1, + has_default_value=False, default_value=b"".decode('utf-8'), + message_type=None, enum_type=None, containing_type=None, + is_extension=False, extension_scope=None, + serialized_options=None, file=DESCRIPTOR, create_key=_descriptor._internal_create_key), + _descriptor.FieldDescriptor( + name='lastName', full_name='person.lastName', index=1, + number=2, type=9, cpp_type=9, label=1, + has_default_value=False, default_value=b"".decode('utf-8'), + message_type=None, enum_type=None, containing_type=None, + is_extension=False, extension_scope=None, + serialized_options=None, file=DESCRIPTOR, create_key=_descriptor._internal_create_key), + _descriptor.FieldDescriptor( + name='age', full_name='person.age', index=2, + number=3, type=5, cpp_type=1, label=1, + has_default_value=False, default_value=0, + message_type=None, enum_type=None, containing_type=None, + is_extension=False, extension_scope=None, + serialized_options=None, file=DESCRIPTOR, create_key=_descriptor._internal_create_key), + _descriptor.FieldDescriptor( + name='gender', full_name='person.gender', index=3, + number=4, type=14, cpp_type=8, label=1, + has_default_value=False, default_value=0, + message_type=None, enum_type=None, containing_type=None, + is_extension=False, extension_scope=None, + serialized_options=None, file=DESCRIPTOR, create_key=_descriptor._internal_create_key), + _descriptor.FieldDescriptor( + name='address', full_name='person.address', index=4, + number=5, type=11, cpp_type=10, label=1, + has_default_value=False, default_value=None, + message_type=None, enum_type=None, containing_type=None, + is_extension=False, extension_scope=None, + serialized_options=None, file=DESCRIPTOR, create_key=_descriptor._internal_create_key), + _descriptor.FieldDescriptor( + name='lucky_numbers', full_name='person.lucky_numbers', index=5, + number=6, type=5, cpp_type=1, label=3, + has_default_value=False, default_value=[], + message_type=None, enum_type=None, containing_type=None, + is_extension=False, extension_scope=None, + serialized_options=b'\020\001', file=DESCRIPTOR, create_key=_descriptor._internal_create_key), + _descriptor.FieldDescriptor( + name='things', full_name='person.things', index=6, + number=7, type=11, cpp_type=10, label=3, + has_default_value=False, default_value=[], + message_type=None, enum_type=None, containing_type=None, + is_extension=False, extension_scope=None, + serialized_options=None, file=DESCRIPTOR, create_key=_descriptor._internal_create_key), + _descriptor.FieldDescriptor( + name='foo', full_name='person.foo', index=7, + number=8, type=11, cpp_type=10, label=1, + has_default_value=False, default_value=None, + message_type=None, enum_type=None, containing_type=None, + is_extension=False, extension_scope=None, + serialized_options=None, file=DESCRIPTOR, create_key=_descriptor._internal_create_key), + ], + extensions=[ + ], + nested_types=[_PERSON_THINGSENTRY, ], + enum_types=[ + ], + serialized_options=None, + is_extendable=False, + syntax='proto3', + extension_ranges=[], + oneofs=[ + ], + serialized_start=18, + serialized_end=258, +) + + +_ADDRESS = _descriptor.Descriptor( + name='address', + full_name='address', + filename=None, + file=DESCRIPTOR, + containing_type=None, + create_key=_descriptor._internal_create_key, + fields=[ + _descriptor.FieldDescriptor( + name='postcode', full_name='address.postcode', index=0, + number=1, type=9, cpp_type=9, label=1, + has_default_value=False, default_value=b"".decode('utf-8'), + message_type=None, enum_type=None, containing_type=None, + is_extension=False, extension_scope=None, + serialized_options=None, file=DESCRIPTOR, create_key=_descriptor._internal_create_key), + _descriptor.FieldDescriptor( + name='country', full_name='address.country', index=1, + number=2, type=9, cpp_type=9, label=1, + has_default_value=False, default_value=b"".decode('utf-8'), + message_type=None, enum_type=None, containing_type=None, + is_extension=False, extension_scope=None, + serialized_options=None, file=DESCRIPTOR, create_key=_descriptor._internal_create_key), + ], + extensions=[ + ], + nested_types=[], + enum_types=[ + ], + serialized_options=None, + is_extendable=False, + syntax='proto3', + extension_ranges=[], + oneofs=[ + ], + serialized_start=260, + serialized_end=304, +) + + +_FOO = _descriptor.Descriptor( + name='Foo', + full_name='Foo', + filename=None, + file=DESCRIPTOR, + containing_type=None, + create_key=_descriptor._internal_create_key, + fields=[ + _descriptor.FieldDescriptor( + name='foo_int', full_name='Foo.foo_int', index=0, + number=1, type=5, cpp_type=1, label=1, + has_default_value=False, default_value=0, + message_type=None, enum_type=None, containing_type=None, + is_extension=False, extension_scope=None, + serialized_options=None, file=DESCRIPTOR, create_key=_descriptor._internal_create_key), + _descriptor.FieldDescriptor( + name='foo_string', full_name='Foo.foo_string', index=1, + number=2, type=9, cpp_type=9, label=1, + has_default_value=False, default_value=b"".decode('utf-8'), + message_type=None, enum_type=None, containing_type=None, + is_extension=False, extension_scope=None, + serialized_options=None, file=DESCRIPTOR, create_key=_descriptor._internal_create_key), + ], + extensions=[ + ], + nested_types=[], + enum_types=[ + ], + serialized_options=None, + is_extendable=False, + syntax='proto3', + extension_ranges=[], + oneofs=[ + _descriptor.OneofDescriptor( + name='Foo', full_name='Foo.Foo', + index=0, containing_type=None, + create_key=_descriptor._internal_create_key, + fields=[]), + ], + serialized_start=306, + serialized_end=359, +) + +_PERSON_THINGSENTRY.containing_type = _PERSON +_PERSON.fields_by_name['gender'].enum_type = _GENDER +_PERSON.fields_by_name['address'].message_type = _ADDRESS +_PERSON.fields_by_name['things'].message_type = _PERSON_THINGSENTRY +_PERSON.fields_by_name['foo'].message_type = _FOO +_FOO.oneofs_by_name['Foo'].fields.append( + _FOO.fields_by_name['foo_int']) +_FOO.fields_by_name['foo_int'].containing_oneof = _FOO.oneofs_by_name['Foo'] +_FOO.oneofs_by_name['Foo'].fields.append( + _FOO.fields_by_name['foo_string']) +_FOO.fields_by_name['foo_string'].containing_oneof = _FOO.oneofs_by_name['Foo'] +DESCRIPTOR.message_types_by_name['person'] = _PERSON +DESCRIPTOR.message_types_by_name['address'] = _ADDRESS +DESCRIPTOR.message_types_by_name['Foo'] = _FOO +DESCRIPTOR.enum_types_by_name['gender'] = _GENDER +_sym_db.RegisterFileDescriptor(DESCRIPTOR) + +person = _reflection.GeneratedProtocolMessageType('person', (_message.Message,), { + + 'ThingsEntry' : _reflection.GeneratedProtocolMessageType('ThingsEntry', (_message.Message,), { + 'DESCRIPTOR' : _PERSON_THINGSENTRY, + '__module__' : 'example_pb2' + # @@protoc_insertion_point(class_scope:person.ThingsEntry) + }) + , + 'DESCRIPTOR' : _PERSON, + '__module__' : 'example_pb2' + # @@protoc_insertion_point(class_scope:person) + }) +_sym_db.RegisterMessage(person) +_sym_db.RegisterMessage(person.ThingsEntry) + +address = _reflection.GeneratedProtocolMessageType('address', (_message.Message,), { + 'DESCRIPTOR' : _ADDRESS, + '__module__' : 'example_pb2' + # @@protoc_insertion_point(class_scope:address) + }) +_sym_db.RegisterMessage(address) + +Foo = _reflection.GeneratedProtocolMessageType('Foo', (_message.Message,), { + 'DESCRIPTOR' : _FOO, + '__module__' : 'example_pb2' + # @@protoc_insertion_point(class_scope:Foo) + }) +_sym_db.RegisterMessage(Foo) + + +_PERSON_THINGSENTRY._options = None +_PERSON.fields_by_name['lucky_numbers']._options = None +# @@protoc_insertion_point(module_scope) diff --git a/schema/test/protobuf/generate.py b/adapter/protobuf/test/protobuf/generate.py similarity index 58% rename from schema/test/protobuf/generate.py rename to adapter/protobuf/test/protobuf/generate.py index 819a67fc..eed9bd52 100644 --- a/schema/test/protobuf/generate.py +++ b/adapter/protobuf/test/protobuf/generate.py @@ -1,17 +1,27 @@ from example_pb2 import * +import sys example_address = address() example_address.postcode = "0000AA" example_address.country = "Nederland" +example_foo = Foo() +example_foo.foo_string = "blah" + example_person = person() example_person.firstName = "Pythonio" example_person.lastName = "van Gogh" example_person.age = 30 example_person.gender = male +for i in [1,2,3]: + example_person.lucky_numbers.append(i) example_person.address.CopyFrom(example_address) +example_person.things["hola"] = 1 +example_person.things["hello"] = 2 +example_person.things["hallo"] = 3 +example_person.foo.CopyFrom(example_foo) f = open(sys.argv[1], "wb") f.write(example_person.SerializeToString()) f.close() -print(example_person) \ No newline at end of file +print(example_person) diff --git a/cabal-fmt.sh b/cabal-fmt.sh new file mode 100755 index 00000000..af06b546 --- /dev/null +++ b/cabal-fmt.sh @@ -0,0 +1 @@ +find . -name '*.cabal' -exec sh -c 'cabal-fmt -i $0' {} ';' diff --git a/cabal.project b/cabal.project new file mode 100644 index 00000000..653d4135 --- /dev/null +++ b/cabal.project @@ -0,0 +1,31 @@ +allow-newer: base, network, ghc-prim, template-haskell, proto3-wire, http2 + +preferences: base16-bytestring < 1 + +packages: adapter/avro/ + adapter/kafka/ + adapter/persistent/ + adapter/protobuf/ + compendium-client/ + core/lens/ + core/optics/ + core/rpc/ + core/schema/ + examples/health-check/ + examples/library/backend + examples/route-guide/ + examples/seed/ + examples/todolist/ + examples/with-persistent/ + graphql/ + grpc/client/ + grpc/common/ + grpc/server/ + instrumentation/prometheus/ + instrumentation/tracing/ + servant/server/ + +source-repository-package + type: git + location: https://github.com/haskell/c2hs.git + tag: 684b4a529b35fbca2b3d3bcd0bed8d7925f8ea81 diff --git a/compendium-client/LICENSE b/compendium-client/LICENSE new file mode 100644 index 00000000..ffeb95d1 --- /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 © 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/compendium-client/compendium-client.cabal b/compendium-client/compendium-client.cabal new file mode 100644 index 00000000..8914efb4 --- /dev/null +++ b/compendium-client/compendium-client.cabal @@ -0,0 +1,36 @@ +name: compendium-client +version: 0.2.1.1 +synopsis: Client for the Compendium schema server +description: + Client for the schema server + +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 +category: Network +build-type: Simple +cabal-version: >=1.10 +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 + build-depends: + aeson >=1.4 && <2 + , base >=4.12 && <5 + , http-client >=0.6.4 && <0.7 + , language-protobuf >=1.0.1 && <1.1 + , megaparsec >=8 && <10 + , servant >=0.16 && <0.19 + , servant-client >=0.16 && <0.19 + , text >=1.2 && <2 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances 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/compendium-client/src/Compendium/Client.hs b/compendium-client/src/Compendium/Client.hs new file mode 100644 index 00000000..84fe5bd1 --- /dev/null +++ b/compendium-client/src/Compendium/Client.hs @@ -0,0 +1,86 @@ +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language ViewPatterns #-} +{-| +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 +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 + +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) +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 + +-- | 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 Text +transformation' ident idl + = raw <$> client (Proxy @TransformationAPI) ident idl + +-- | Errors which may arise during 'obtainProtoBuf'. +data ObtainProtoBufError + = 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 + r <- transformation m url ident Protobuf + case r of + Left e + -> pure $ Left (OPEClient e) + Right p + -> case parseProtoBuf p of + Left e -> pure $ Left (OPEParse e) + Right pb -> pure $ Right pb diff --git a/core/lens/LICENSE b/core/lens/LICENSE new file mode 100644 index 00000000..ffeb95d1 --- /dev/null +++ b/core/lens/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/core/lens/hie.yaml b/core/lens/hie.yaml new file mode 100644 index 00000000..743dad27 --- /dev/null +++ b/core/lens/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-lens:lib" } } diff --git a/core/lens/mu-lens.cabal b/core/lens/mu-lens.cabal new file mode 100644 index 00000000..faedd451 --- /dev/null +++ b/core/lens/mu-lens.cabal @@ -0,0 +1,36 @@ +name: mu-lens +version: 0.3.0.0 +synopsis: Lenses for @mu-schema@ terms +description: + With @mu-schema@ you can describe schemas using type-level constructs, and derive serializers from those. This package provides convenient access using @lens@es. + +license: Apache-2.0 +license-file: LICENSE +author: Andre Marianiello +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 +category: Network +build-type: Simple +cabal-version: >=1.10 +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.Lens + build-depends: + base >=4.12 && <5 + , containers + , generic-lens + , lens + , mu-rpc + , mu-schema + , sop-core + , text + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/core/lens/src/Mu/Schema/Lens.hs b/core/lens/src/Mu/Schema/Lens.hs new file mode 100644 index 00000000..6d9a37c5 --- /dev/null +++ b/core/lens/src/Mu/Schema/Lens.hs @@ -0,0 +1,394 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language GADTs #-} +{-# language InstanceSigs #-} +{-# language LambdaCase #-} +{-# language PartialTypeSignatures #-} +{-# language PolyKinds #-} +{-# language QuantifiedConstraints #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Mu.Schema.Lens ( + record, + is +) where + +import Control.Lens +import Data.Kind +import Data.Map +import Data.SOP +import qualified Data.Text as T + + +import GHC.Int +import GHC.OverloadedLabels +import GHC.TypeLits hiding (Nat) +import Mu.Schema + +is :: s -> APrism' s () -> Bool +is s l = not $ isn't l s + +-- we need structurally inductive Nats +data Nat = Zero | Succ Nat + +record :: BuildRecord sch args r => r -> Term sch ('DRecord name args) +record = TRecord . buildR + +class BuildRecord (sch :: Schema Symbol Symbol) (args :: [FieldDef Symbol Symbol]) (r :: Type) | sch args -> r where + buildR :: r -> NP (Field sch) args + +instance + {-# OVERLAPPABLE #-} + ( Interpret sch fieldType ~ r, + Uninterpret r ~ fieldType, + UninterpretField sch r + ) => + BuildRecord + sch + '[ 'FieldDef fieldName fieldType + ] + r + where + buildR val = Field (toFieldValue val) :* Nil + +instance + ( Interpret sch fieldType1 ~ v1, + Interpret sch fieldType2 ~ v2, + Uninterpret v1 ~ fieldType1, + Uninterpret v2 ~ fieldType2, + All (UninterpretField sch) '[v1, v2] + ) => + BuildRecord + sch + '[ 'FieldDef fieldName1 fieldType1, + 'FieldDef fieldName2 fieldType2 + ] + (v1, v2) + where + buildR (v1, v2) = Field (toFieldValue v1) :* Field (toFieldValue v2) :* Nil + +instance + ( Interpret sch fieldType1 ~ v1, + Interpret sch fieldType2 ~ v2, + Interpret sch fieldType3 ~ v3, + Uninterpret v1 ~ fieldType1, + Uninterpret v2 ~ fieldType2, + Uninterpret v3 ~ fieldType3, + All (UninterpretField sch) '[v1, v2, v3] + ) => + BuildRecord + sch + '[ 'FieldDef fieldName1 fieldType1, + 'FieldDef fieldName2 fieldType2, + 'FieldDef fieldName3 fieldType3 + ] + (v1, v2, v3) + where + buildR (v1, v2, v3) = + Field (toFieldValue v1) + :* Field (toFieldValue v2) + :* Field (toFieldValue v3) + :* Nil + +instance + ( Functor f, + HasFieldIx (IndexOf fieldName fields) fields fields' fieldType fieldType', + Interpret sch fieldType ~ fieldValue, + Interpret sch fieldType' ~ fieldValue', + Uninterpret fieldValue ~ fieldType, + Uninterpret fieldValue' ~ fieldType', + UninterpretField sch fieldValue' + ) => + IsLabel + fieldName + ( (fieldValue -> f fieldValue') -> + (Term sch ('DRecord name fields) -> f (Term sch ('DRecord name fields'))) + ) + where + fromLabel = field @fieldName + +instance + forall choiceName p f sch name choiceDefs choiceDefs' choiceType choiceType'. + ( Choice p, + Applicative f, + HasChoiceIx (ChoiceIndexOf choiceName choiceDefs) choiceDefs choiceDefs' choiceType choiceType' + ) => + IsLabel + choiceName + ( p choiceType (f choiceType') -> + p (Term sch ('DEnum name choiceDefs)) (f (Term sch ('DEnum name choiceDefs'))) + ) + where + fromLabel = choose @choiceName + +choose :: + forall (choiceName :: Symbol) sch name choiceDefs choiceDefs' choiceType choiceType'. + (HasChoiceIx (ChoiceIndexOf choiceName choiceDefs) choiceDefs choiceDefs' choiceType choiceType') => + Prism + (Term sch ('DEnum name choiceDefs)) + (Term sch ('DEnum name choiceDefs')) + choiceType + choiceType' +choose = chooseIx @(ChoiceIndexOf choiceName choiceDefs) + +class + HasChoiceIx + (choiceIndex :: Nat) + (choiceDefs :: [ChoiceDef Symbol]) + (choiceDefs' :: [ChoiceDef Symbol]) + choiceType + choiceType' + | choiceIndex choiceDefs -> choiceType, + choiceIndex choiceDefs' -> choiceType', + choiceIndex choiceDefs choiceType' -> choiceDefs', + choiceIndex choiceDefs' choiceType -> choiceDefs where + chooseIx :: + Prism + (Term sch ('DEnum name choiceDefs)) + (Term sch ('DEnum name' choiceDefs')) + choiceType + choiceType' + +instance + HasChoiceIx + 'Zero + ('ChoiceDef choiceName ': choiceDefs) + ('ChoiceDef choiceName ': choiceDefs) + () + () + where + chooseIx f = dimap project (either pure (fmap inject)) (right' f) + where + inject :: () -> Term sch ('DEnum name ('ChoiceDef choiceName ': choiceDefs)) + inject () = TEnum (Z (Proxy @('ChoiceDef choiceName))) + project :: + Term sch ('DEnum name ('ChoiceDef choiceName ': choiceDefs)) -> + Either (Term sch ('DEnum name' ('ChoiceDef choiceName' ': choiceDefs))) () + project term = case term of + TEnum (Z Proxy) -> Right () + _ -> Left (TEnum (Z Proxy)) + +instance + (HasChoiceIx choiceIndex choiceDefs choiceDefs' choiceType choiceType') => + HasChoiceIx + ('Succ choiceIndex) + (choiceDef ': choiceDefs) + (choiceDef ': choiceDefs') + choiceType + choiceType' + where + chooseIx f = + dimap + project + inject + (right' (chooseIx @choiceIndex @choiceDefs @choiceDefs' f)) + where + project :: + Term sch ('DEnum name (choiceDef ': choiceDefs)) -> + Either () (Term sch ('DEnum name choiceDefs)) + project (TEnum (Z Proxy)) = Left () + project (TEnum (S inner)) = Right (TEnum inner) + inject :: + Applicative f => + Either () (f (Term sch ('DEnum name choiceDefs'))) -> + f (Term sch ('DEnum name (choiceDef ': choiceDefs'))) + inject (Left ()) = pure (TEnum (Z Proxy)) + inject (Right inner) = fmap wrap inner + wrap :: Term sch ('DEnum name choiceDefs') -> Term sch ('DEnum name (choiceDef ': choiceDefs')) + wrap (TEnum choices) = TEnum (S choices) + +field :: + forall fieldName sch name fieldDefs fieldDefs' fieldType fieldType' fieldValue fieldValue'. + (HasFieldIx (IndexOf fieldName fieldDefs) fieldDefs fieldDefs' fieldType fieldType') => + ( HasFieldIx (IndexOf fieldName fieldDefs) fieldDefs fieldDefs' fieldType fieldType', + Interpret sch fieldType ~ fieldValue, + Interpret sch fieldType' ~ fieldValue', + Uninterpret fieldValue ~ fieldType, + Uninterpret fieldValue' ~ fieldType', + UninterpretField sch fieldValue' + ) => + Lens + (Term sch ('DRecord name fieldDefs)) + (Term sch ('DRecord name fieldDefs')) + fieldValue + fieldValue' +field = fieldValueName @fieldName . interpretIso + +fieldValueName :: + forall fieldName sch name fieldDefs fieldDefs' fieldType fieldType'. + (HasFieldIx (IndexOf fieldName fieldDefs) fieldDefs fieldDefs' fieldType fieldType') => + Lens + (Term sch ('DRecord name fieldDefs)) + (Term sch ('DRecord name fieldDefs')) + (FieldValue sch fieldType) + (FieldValue sch fieldType') +fieldValueName = fieldValueIx @(IndexOf fieldName fieldDefs) + +type family IndexOf (fieldName :: fieldNameKind) (fieldDefs :: [FieldDefB builtin fieldNameKind typeNameKind]) :: Nat where + IndexOf fieldName ('FieldDef fieldName _ ': _) = 'Zero + IndexOf fieldName (_ ': fieldDefs) = 'Succ (IndexOf fieldName fieldDefs) + IndexOf fieldName '[] = TypeError ('Text "does not contain field name " ':<>: 'ShowType fieldName) + +type family + ChoiceIndexOf + (choiceName :: choiceNameKind) + (choiceDefs :: [ChoiceDef choiceNameKind]) :: + Nat where + ChoiceIndexOf choiceName ('ChoiceDef choiceName : _) = 'Zero + ChoiceIndexOf choiceName (_ ': choiceDefs) = 'Succ (ChoiceIndexOf choiceName choiceDefs) + +class + HasFieldIx + (fieldIndex :: Nat) + (fieldDefs :: [FieldDef Symbol Symbol]) + (fieldDefs' :: [FieldDef Symbol Symbol]) + (fieldType :: FieldType Symbol) + (fieldType' :: FieldType Symbol) + | fieldIndex fieldDefs -> fieldType, + fieldIndex fieldDefs' -> fieldType', + fieldIndex fieldDefs fieldType' -> fieldDefs', + fieldIndex fieldDefs' fieldType -> fieldDefs where + fieldValueIx :: + Lens + (Term sch ('DRecord name fieldDefs)) + (Term sch ('DRecord name' fieldDefs')) + (FieldValue sch fieldType) + (FieldValue sch fieldType') + +instance + HasFieldIx + 'Zero + ('FieldDef fieldName fieldType ': fieldDefs) + ('FieldDef fieldName fieldType' ': fieldDefs) + fieldType + fieldType' + where + fieldValueIx f (TRecord (Field fieldValue :* fields)) = TRecord . (:* fields) . Field <$> f fieldValue + +instance + ( HasFieldIx + fieldIndex + fieldDefs + fieldDefs' + fieldType + fieldType' + ) => + HasFieldIx ('Succ fieldIndex) (fieldDef ': fieldDefs) (fieldDef ': fieldDefs') fieldType fieldType' + where + fieldValueIx f (TRecord (firstField :* restOfFields)) = + wrap <$> fieldValueIx @fieldIndex f (TRecord restOfFields) + where + wrap (TRecord fields) = TRecord (firstField :* fields) + +interpretIso :: + ( Uninterpret (Interpret sch fieldType') ~ fieldType', + UninterpretField sch (Interpret sch fieldType') + ) => + Iso (FieldValue sch fieldType) (FieldValue sch fieldType') (Interpret sch fieldType) (Interpret sch fieldType') +interpretIso = dimap fromFieldValue (fmap toFieldValue) + +type family Interpret (sch :: Schema typeName fieldName) (fieldType :: FieldType typeName) :: Type where + Interpret _ 'TNull = () + Interpret _ ('TPrimitive builtin) = builtin + Interpret sch ('TSchematic typeName) = Term sch (sch :/: typeName) + Interpret sch ('TOption innerType) = Maybe (Interpret sch innerType) + Interpret sch ('TList innerType) = [Interpret sch innerType] + Interpret sch ('TMap keyType valueType) = Map (Interpret sch keyType) (Interpret sch valueType) + Interpret sch ('TUnion choiceTypes) = NS Identity (InterpretList sch choiceTypes) + +type family InterpretList sch (fieldTypes :: [FieldType typeName]) :: [Type] where + InterpretList _ '[] = '[] + InterpretList sch (t ': ts) = (Interpret sch t ': InterpretList sch ts) + +fromFieldValue :: FieldValue sch fieldType -> Interpret sch fieldType +fromFieldValue = \case + FNull -> () + (FPrimitive val) -> val + (FSchematic term) -> term + (FOption maybeFieldValue) -> fromFieldValue <$> maybeFieldValue + (FList listFieldValues) -> fromFieldValue <$> listFieldValues + (FMap mapFieldValues) -> mapKeysMonotonic fromFieldValue (fromFieldValue <$> mapFieldValues) + (FUnion (Z val)) -> Z (Identity (fromFieldValue val)) + (FUnion (S val)) -> S (fromFieldValue (FUnion val)) + +class UninterpretField sch a where + type Uninterpret a :: FieldType typeName + toFieldValue :: a -> FieldValue sch (Uninterpret a) + +instance UninterpretField sch () where + type Uninterpret () = 'TNull + toFieldValue () = FNull + +instance UninterpretField sch Integer where + type Uninterpret Integer = 'TPrimitive Integer + toFieldValue = FPrimitive + +instance UninterpretField sch Int32 where + type Uninterpret Int32 = 'TPrimitive Int32 + toFieldValue = FPrimitive + +instance UninterpretField sch Int where + type Uninterpret Int = 'TPrimitive Int + toFieldValue = FPrimitive + +instance UninterpretField sch T.Text where + type Uninterpret T.Text = 'TPrimitive T.Text + toFieldValue = FPrimitive + +instance + ((sch :/: recordName) ~ 'DRecord recordName fieldDefs, sch ~ sch') => + UninterpretField sch (Term sch' ('DRecord recordName fieldDefs)) + where + type Uninterpret (Term sch' ('DRecord recordName fieldDefs)) = 'TSchematic recordName + toFieldValue = FSchematic + +instance + ((sch :/: enumName) ~ 'DEnum enumName choiceDefs) => + UninterpretField sch (Term sch ('DEnum enumName choiceDefs)) + where + type Uninterpret (Term sch ('DEnum enumName choiceDefs)) = 'TSchematic enumName + toFieldValue = FSchematic + +instance (UninterpretField sch a) => UninterpretField sch (Maybe a) where + type Uninterpret (Maybe a) = 'TOption (Uninterpret a) + toFieldValue = FOption . fmap toFieldValue + +instance (UninterpretField sch a) => UninterpretField sch [a] where + type Uninterpret [a] = 'TList (Uninterpret a) + toFieldValue = FList . fmap toFieldValue + +instance + (Ord (FieldValue sch (Uninterpret k)), UninterpretField sch k, UninterpretField sch v) => + UninterpretField sch (Map k v) + where + type Uninterpret (Map k v) = 'TMap (Uninterpret k) (Uninterpret v) + toFieldValue = FMap . mapKeysMonotonic toFieldValue . fmap toFieldValue + +instance + (All (UninterpretField sch) choiceTypes) => + UninterpretField sch (NS Identity (choiceTypes :: [Type])) + where + type Uninterpret (NS Identity choiceTypes) = 'TUnion (UninterpretList choiceTypes) + toFieldValue = FUnion . nsToFieldValues + +nsToFieldValues :: + forall sch choiceTypes. + (All (UninterpretField sch) choiceTypes) => + NS Identity choiceTypes -> + NS (FieldValue sch) (UninterpretList choiceTypes) +nsToFieldValues = \case + (Z val) -> Z . toFieldValue . runIdentity $ val + (S val) -> S (nsToFieldValues val) + +type family UninterpretList (as :: [Type]) :: [FieldType typeName] where + UninterpretList '[] = '[] + UninterpretList (t ': ts) = Uninterpret t ': UninterpretList ts diff --git a/core/optics/LICENSE b/core/optics/LICENSE new file mode 100644 index 00000000..ffeb95d1 --- /dev/null +++ b/core/optics/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/core/optics/hie.yaml b/core/optics/hie.yaml new file mode 100644 index 00000000..284350b2 --- /dev/null +++ b/core/optics/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-optics:lib" } } diff --git a/core/optics/mu-optics.cabal b/core/optics/mu-optics.cabal new file mode 100644 index 00000000..c5859f75 --- /dev/null +++ b/core/optics/mu-optics.cabal @@ -0,0 +1,33 @@ +name: mu-optics +version: 0.3.0.1 +synopsis: Optics for @mu-schema@ terms +description: + With @mu-schema@ you can describe schemas using type-level constructs, and derive serializers from those. This package provides convenient access using @optics@. + +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 +category: Network +build-type: Simple +cabal-version: >=1.10 +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.Optics + build-depends: + base >=4.12 && <5 + , containers >=0.6 && <0.7 + , mu-schema >=0.3 && <0.4 + , optics-core >=0.2 && <0.4 + , sop-core >=0.5 && <0.6 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/core/optics/src/Mu/Schema/Optics.hs b/core/optics/src/Mu/Schema/Optics.hs new file mode 100644 index 00000000..174f19bd --- /dev/null +++ b/core/optics/src/Mu/Schema/Optics.hs @@ -0,0 +1,223 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language GADTs #-} +{-# language LambdaCase #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +{-| +Description : Optics-based interface for @mu-schema@ terms + +This module provides instances of 'LabelOptic' to be +used in conjunction with the @optics@ package. +In particular, there are two kind of optics to access +different parts of a 'Term': + +* With @#field@ you obtain the lens (that is, a getter + and a setter) for the corresponding field in a record. +* With @#choice@ you obtain the prism for the + desired choice in an enumeration. You can use then + 'review' to construct a term with the value. + +In addition, we provide a utility function 'record' to +build a record out of the inner values. We intend the +interface to be very simple, so this function is overloaded +to take tuples of different size, with as many components +as values in the schema type. +-} +module Mu.Schema.Optics ( + -- * Build a term + record, record1, enum +, _U0, _Next, _U1, _U2, _U3 + -- * Re-exported for convenience. +, module Optics.Core + -- * Additional utilities. +, is +) where + +import Data.Kind +import Data.Map +import Data.Maybe (isJust) +import Data.Proxy +import GHC.TypeLits +import Optics.Core + +import Mu.Schema + +instance (FieldLabel sch args fieldName r) + => LabelOptic fieldName A_Lens + (Term sch ('DRecord name args)) + (Term sch ('DRecord name args)) + r r where + labelOptic = lens (\(TRecord r) -> fieldLensGet (Proxy @fieldName) r) + (\(TRecord r) x -> TRecord $ fieldLensSet (Proxy @fieldName) r x) + +-- | Build a Mu record 'Term' from a tuple of its values. +-- +-- Note: if the record has exactly _one_ field, +-- you must use 'record1' instead. +record :: BuildRecord sch args r => r -> Term sch ('DRecord name args) +record values = TRecord $ buildR values + +-- | Build a Mu record 'Term' with exactly one field. +record1 :: TypeLabel sch t1 r1 => r1 -> Term sch ('DRecord name '[ 'FieldDef x1 t1 ]) +record1 value = TRecord $ Field (typeLensSet value) :* Nil + +class BuildRecord (sch :: Schema Symbol Symbol) + (args :: [FieldDef Symbol Symbol]) + (r :: Type) | sch args -> r where + buildR :: r -> NP (Field sch) args + +instance BuildRecord sch '[] () where + buildR _ = Nil + +instance (TypeLabel sch t1 r1, TypeLabel sch t2 r2) + => BuildRecord sch '[ 'FieldDef x1 t1, 'FieldDef x2 t2 ] (r1, r2) where + buildR (v1, v2) = Field (typeLensSet v1) + :* Field (typeLensSet v2) :* Nil + +instance (TypeLabel sch t1 r1, TypeLabel sch t2 r2, TypeLabel sch t3 r3) + => BuildRecord sch + '[ 'FieldDef x1 t1, 'FieldDef x2 t2, 'FieldDef x3 t3 ] (r1, r2, r3) where + buildR (v1, v2, v3) = Field (typeLensSet v1) + :* Field (typeLensSet v2) + :* Field (typeLensSet v3) :* Nil + +class FieldLabel (sch :: Schema Symbol Symbol) + (args :: [FieldDef Symbol Symbol]) + (fieldName :: Symbol) (r :: Type) + | sch args fieldName -> r where + fieldLensGet :: Proxy fieldName -> NP (Field sch) args -> r + fieldLensSet :: Proxy fieldName -> NP (Field sch) args -> r -> NP (Field sch) args + +{- Removed due to FunDeps +instance TypeError ('Text "cannot find field " ':<>: 'ShowType f) + => FieldLabel w sch '[] f t where + fieldLensGet = error "this should never be run" + fieldLensSet = error "this should never be run" +-} +instance {-# OVERLAPS #-} (TypeLabel sch t r) + => FieldLabel sch ('FieldDef f t ': rest) f r where + fieldLensGet _ (Field x :* _) = typeLensGet x + fieldLensSet _ (_ :* r) new = Field (typeLensSet new) :* r +instance {-# OVERLAPPABLE #-} FieldLabel sch rest g t + => FieldLabel sch (f ': rest) g t where + fieldLensGet p (_ :* r) = fieldLensGet p r + fieldLensSet p (x :* r) new = x :* fieldLensSet p r new + +class TypeLabel (sch :: Schema Symbol Symbol) (t :: FieldType Symbol) (r :: Type) + | sch t -> r where + typeLensGet :: FieldValue sch t -> r + typeLensSet :: r -> FieldValue sch t + +instance TypeLabel sch ('TPrimitive t) t where + typeLensGet (FPrimitive x) = x + typeLensSet = FPrimitive + +instance (r ~ (sch :/: t)) => TypeLabel sch ('TSchematic t) (Term sch r) where + typeLensGet (FSchematic x) = x + typeLensSet = FSchematic + +instance (TypeLabel sch o r', r ~ Maybe r') + => TypeLabel sch ('TOption o) r where + typeLensGet (FOption x) = typeLensGet <$> x + typeLensSet new = FOption (typeLensSet <$> new) + +instance (TypeLabel sch o r', r ~ [r']) + => TypeLabel sch ('TList o) r where + typeLensGet (FList x) = typeLensGet <$> x + typeLensSet new = FList (typeLensSet <$> new) + +instance ( TypeLabel sch k k', TypeLabel sch v v' + , r ~ Map k' v', Ord k', Ord (FieldValue sch k) ) + => TypeLabel sch ('TMap k v) r where + typeLensGet (FMap x) = mapKeys typeLensGet (typeLensGet <$> x) + typeLensSet new = FMap (mapKeys typeLensSet (typeLensSet <$> new)) + +instance (r ~ NS (FieldValue sch) choices) + => TypeLabel sch ('TUnion choices) r where + typeLensGet (FUnion x) = x + typeLensSet = FUnion + +-- | Build a Mu enumeration 'Term' from the name of the choice. +enum :: forall (choiceName :: Symbol) choices sch name. + EnumLabel choices choiceName + => Term sch ('DEnum name choices) +enum = TEnum $ enumPrismBuild (Proxy @choiceName) + +-- Useful utility to check whether a value +-- matches a given enumeration choice. +-- +-- > f e | e `is` #sunny = ... +-- > | e `is` #rainy = ... +is :: Is k An_AffineFold => s -> Optic' k is s a -> Bool +is s k = isJust (preview k s) +{-# INLINE is #-} + +instance (EnumLabel choices choiceName, r ~ ()) + => LabelOptic choiceName A_Prism + (Term sch ('DEnum name choices)) + (Term sch ('DEnum name choices)) + r r where + labelOptic = prism' (\_ -> TEnum $ enumPrismBuild (Proxy @choiceName)) + (\(TEnum r) -> enumPrismMatch (Proxy @choiceName) r) + +class EnumLabel (choices :: [ChoiceDef Symbol]) + (choiceName :: Symbol) where + enumPrismBuild :: Proxy choiceName -> NS Proxy choices + enumPrismMatch :: Proxy choiceName -> NS Proxy choices -> Maybe () + +instance TypeError ('Text "cannot find choice " ':<>: 'ShowType c) + => EnumLabel '[] c where + enumPrismBuild = error "this should never be run" + enumPrismMatch = error "this should never be run" +instance {-# OVERLAPS #-} EnumLabel ('ChoiceDef c ': rest) c where + enumPrismBuild _ = Z Proxy + enumPrismMatch _ (Z _) = Just () + enumPrismMatch _ _ = Nothing +instance {-# OVERLAPPABLE #-} EnumLabel rest c + => EnumLabel (d ': rest) c where + enumPrismBuild p = S (enumPrismBuild p) + enumPrismMatch _ (Z _) = Nothing + enumPrismMatch p (S x) = enumPrismMatch p x + +-- | Prism to access the first choice of a union. +_U0 :: forall (sch :: Schema') x xs r. TypeLabel sch x r + => Prism' (NS (FieldValue sch) (x ': xs)) r +_U0 = prism' (Z . typeLensSet) + (\case (Z x) -> Just $ typeLensGet x + (S _) -> Nothing) + +-- | Prism to access all other choices of a union +-- except for the first. Intended to use be used +-- iteratively until you reach the desired choice +-- with '_U0'. +-- +-- > _Next % _Next % _U0 -- access third choice +_Next :: forall (sch :: Schema') x xs. + Prism' (NS (FieldValue sch) (x ': xs)) + (NS (FieldValue sch) xs) +_Next = prism' S + (\case (Z _) -> Nothing + (S x) -> Just x) + +-- | Prism to access the second choice of a union. +_U1 :: forall (sch :: Schema') a b xs r. TypeLabel sch b r + => Prism' (NS (FieldValue sch) (a ': b ': xs)) r +_U1 = _Next % _U0 + +-- | Prism to access the third choice of a union. +_U2 :: forall (sch :: Schema') a b c xs r. TypeLabel sch c r + => Prism' (NS (FieldValue sch) (a ': b ': c ': xs)) r +_U2 = _Next % _U1 + +-- | Prism to access the fourth choice of a union. +_U3 :: forall (sch :: Schema') a b c d xs r. TypeLabel sch d r + => Prism' (NS (FieldValue sch) (a ': b ': c ': d ': xs)) r +_U3 = _Next % _U2 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/core/rpc/LICENSE b/core/rpc/LICENSE new file mode 100644 index 00000000..ffeb95d1 --- /dev/null +++ b/core/rpc/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/core/rpc/Setup.hs b/core/rpc/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/core/rpc/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain 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/rpc/mu-rpc.cabal b/core/rpc/mu-rpc.cabal new file mode 100644 index 00000000..83f154be --- /dev/null +++ b/core/rpc/mu-rpc.cabal @@ -0,0 +1,44 @@ +name: mu-rpc +version: 0.5.0.1 +synopsis: Protocol-independent declaration of services and servers. +description: + Protocol-independent declaration of services and servers for mu-haskell. + +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 +cabal-version: >=1.10 +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.Rpc.Annotations + Mu.Rpc.Examples + Mu.Server + + build-depends: + aeson + , base >=4.12 && <5 + , conduit >=1.3.2 && <1.4 + , http-types >=0.12 && <0.13 + , mtl >=2.2 && <2.3 + , mu-schema >=0.3 && <0.4 + , sop-core >=0.5 && <0.6 + , template-haskell >=2.14 && <2.17 + , text >=1.2 && <1.3 + , wai >=3.2 && <4 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances diff --git a/core/rpc/src/Mu/Rpc.hs b/core/rpc/src/Mu/Rpc.hs new file mode 100644 index 00000000..a14b5c27 --- /dev/null +++ b/core/rpc/src/Mu/Rpc.hs @@ -0,0 +1,276 @@ +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language ExistentialQuantification #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +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 ( + Package', Package(..) +, Service', Service(..), Object, Union +, Method', Method(..), ObjectField +, LookupService, LookupMethod +, TypeRef(..), Argument', Argument(..), Return(..) +, TyInfo(..), RpcInfo(..), ReflectRpcInfo(..) +) where + +import Data.Kind +import Data.Text (Text) +import qualified Data.Text as T +import GHC.TypeLits +import qualified Language.Haskell.TH as TH +import Network.HTTP.Types.Header +import Type.Reflection + +import Mu.Schema +import Mu.Schema.Registry + +-- | Packages whose names are given by type-level strings. +type Package' = Package Symbol Symbol Symbol (TypeRef Symbol) +-- | Services whose names are given by type-level strings. +type Service' = Service Symbol Symbol Symbol (TypeRef Symbol) +-- | Methods whose names are given by type-level strings. +type Method' = Method Symbol Symbol Symbol (TypeRef Symbol) +-- | Arguments whose names are given by type-level strings. +type Argument' = Argument Symbol Symbol (TypeRef Symbol) + +-- | A package is a set of services. +data Package serviceName methodName argName tyRef + = Package (Maybe serviceName) + [Service serviceName methodName argName tyRef] + +-- | A service is a set of methods. +data Service serviceName methodName argName tyRef + = Service serviceName + [Method serviceName methodName argName tyRef] + | OneOf serviceName [serviceName] + +-- | A method is defined by its name, arguments, and return type. +data Method serviceName methodName argName tyRef + = Method methodName + [Argument serviceName argName tyRef] + (Return serviceName tyRef) + +-- Synonyms for GraphQL +-- | An object is a set of fields, in GraphQL lingo. +type Object = 'Service +-- | A union is one of the objects. +type Union = 'OneOf +-- | A field in an object takes some input objects, +-- and returns a value or some other object, +-- in GraphQL lingo. +type ObjectField = 'Method + +-- | Look up a service in a package definition using its name. +type family LookupService (ss :: [Service snm mnm anm tr]) (s :: snm) + :: Service snm mnm anm tr where + LookupService '[] s = TypeError ('Text "could not find method " ':<>: 'ShowType s) + LookupService ('Service s ms ': ss) s = 'Service s ms + LookupService ('OneOf s ms ': ss) s = 'OneOf s ms + LookupService (other ': ss) s = LookupService ss s + +-- | Look up a method in a service definition using its name. +type family LookupMethod (s :: [Method snm mnm anm tr]) (m :: mnm) + :: Method snm mnm anm tr where + LookupMethod '[] m = TypeError ('Text "could not find method " ':<>: 'ShowType m) + LookupMethod ('Method m args r ': ms) m = 'Method m args r + LookupMethod (other ': ms) m = LookupMethod ms m + +-- | Defines a reference to a type, either primitive or coming from the schema. +-- 'TypeRef's are used to define arguments and result types. +data TypeRef serviceName where + -- | A primitive type. + PrimitiveRef :: Type -> TypeRef serviceName + -- | Chain with another service. + ObjectRef :: serviceName -> TypeRef serviceName + -- | Point to schema. + SchemaRef :: Schema typeName fieldName -> typeName -> TypeRef serviceName + -- | Registry subject, type to convert to, and preferred serialization version + RegistryRef :: Registry -> Type -> Nat -> TypeRef serviceName + -- | To be used only during TH generation! + THRef :: TH.Type -> TypeRef serviceName + -- Combinators found in the gRPC and GraphQL languages. + -- | Represents a list of values. + ListRef :: TypeRef serviceName -> TypeRef serviceName + -- | Represents a possibly-missing value. + OptionalRef :: TypeRef serviceName -> TypeRef serviceName + +instance Show (TypeRef s) where + show _ = "ty" + +-- | Defines the way in which arguments are handled. +data Argument serviceName argName tyRef where + -- | Use a single value. + ArgSingle :: Maybe argName + -> tyRef + -> Argument serviceName argName tyRef + -- | Consume a stream of values. + ArgStream :: Maybe argName + -> tyRef + -> Argument serviceName argName tyRef + +-- | Defines the different possibilities for returning +-- information from a method. +data Return serviceName tyRef where + -- | Fire and forget. + RetNothing :: Return serviceName tyRef + -- | Return a single value. + RetSingle :: tyRef -> Return serviceName tyRef + -- | Return a stream of values. + RetStream :: tyRef -> Return serviceName tyRef + -- | Return a value or an error. + RetThrows :: tyRef -> tyRef -> Return serviceName tyRef + +-- | Reflection + +data RpcInfo i + = NoRpcInfo + | RpcInfo { packageInfo :: Package Text Text Text TyInfo + , serviceInfo :: Service Text Text Text TyInfo + , methodInfo :: Maybe (Method Text Text Text TyInfo) + , headers :: RequestHeaders + , extraInfo :: i + } + +data TyInfo + = TyList TyInfo + | TyOption TyInfo + | TyTy Text + deriving (Show, Eq) + +instance Show (RpcInfo i) where + show NoRpcInfo + = "" + show (RpcInfo (Package p _) s m _ _) + = T.unpack $ showPkg p (showMth m (showSvc s)) + where + showPkg Nothing = id + showPkg (Just pkg) = ((pkg <> ":") <>) + showMth Nothing = id + showMth (Just (Method mt _ _)) = (<> (":" <> mt)) + showSvc (Service sv _) = sv + showSvc (OneOf sv _) = sv + +class ReflectRpcInfo (p :: Package') (s :: Service') (m :: Method') where + reflectRpcInfo :: Proxy p -> Proxy s -> Proxy m -> RequestHeaders -> i -> RpcInfo i +class ReflectService (s :: Service') where + reflectService :: Proxy s -> Service Text Text Text TyInfo +class ReflectMethod (m :: Method') where + reflectMethod :: Proxy m -> Method Text Text Text TyInfo +class ReflectArg (arg :: Argument') where + reflectArg :: Proxy arg -> Argument Text Text TyInfo +class ReflectReturn (r :: Return Symbol (TypeRef Symbol)) where + reflectReturn :: Proxy r -> Return Text TyInfo +class ReflectTyRef (r :: TypeRef Symbol) where + reflectTyRef :: Proxy r -> TyInfo + +class KnownMaySymbol (m :: Maybe Symbol) where + maySymbolVal :: Proxy m -> Maybe Text +instance KnownMaySymbol 'Nothing where + maySymbolVal _ = Nothing +instance (KnownSymbol s) => KnownMaySymbol ('Just s) where + maySymbolVal _ = Just $ T.pack $ symbolVal (Proxy @s) + +class KnownSymbols (m :: [Symbol]) where + symbolsVal :: Proxy m -> [Text] +instance KnownSymbols '[] where + symbolsVal _ = [] +instance (KnownSymbol s, KnownSymbols ss) => KnownSymbols (s ': ss) where + symbolsVal _ = T.pack (symbolVal (Proxy @s)) : symbolsVal (Proxy @ss) + +class ReflectServices (ss :: [Service']) where + reflectServices :: Proxy ss -> [Service Text Text Text TyInfo] +instance ReflectServices '[] where + reflectServices _ = [] +instance (ReflectService s, ReflectServices ss) + => ReflectServices (s ': ss) where + reflectServices _ = reflectService (Proxy @s) : reflectServices (Proxy @ss) + +class ReflectMethods (ms :: [Method']) where + reflectMethods :: Proxy ms -> [Method Text Text Text TyInfo] +instance ReflectMethods '[] where + reflectMethods _ = [] +instance (ReflectMethod m, ReflectMethods ms) + => ReflectMethods (m ': ms) where + reflectMethods _ = reflectMethod (Proxy @m) : reflectMethods (Proxy @ms) + +class ReflectArgs (ms :: [Argument']) where + reflectArgs :: Proxy ms -> [Argument Text Text TyInfo] +instance ReflectArgs '[] where + reflectArgs _ = [] +instance (ReflectArg m, ReflectArgs ms) + => ReflectArgs (m ': ms) where + reflectArgs _ = reflectArg (Proxy @m) : reflectArgs (Proxy @ms) + +instance (KnownMaySymbol pname, ReflectServices ss, ReflectService s, ReflectMethod m) + => ReflectRpcInfo ('Package pname ss) s m where + reflectRpcInfo _ ps pm req extra + = RpcInfo (Package (maySymbolVal (Proxy @pname)) + (reflectServices (Proxy @ss))) + (reflectService ps) (Just (reflectMethod pm)) req extra + +instance (KnownSymbol sname, ReflectMethods ms) + => ReflectService ('Service sname ms) where + reflectService _ + = Service (T.pack $ symbolVal (Proxy @sname)) + (reflectMethods (Proxy @ms)) + +instance (KnownSymbol sname, KnownSymbols elts) + => ReflectService ('OneOf sname elts) where + reflectService _ + = OneOf (T.pack $ symbolVal (Proxy @sname)) + (symbolsVal (Proxy @elts)) + +instance (KnownSymbol mname, ReflectArgs args, ReflectReturn r) + => ReflectMethod ('Method mname args r) where + reflectMethod _ + = Method (T.pack $ symbolVal (Proxy @mname)) + (reflectArgs (Proxy @args)) (reflectReturn (Proxy @r)) + +instance (KnownMaySymbol aname, ReflectTyRef t) + => ReflectArg ('ArgSingle aname t) where + reflectArg _ + = ArgSingle (maySymbolVal (Proxy @aname)) (reflectTyRef (Proxy @t)) +instance (KnownMaySymbol aname, ReflectTyRef t) + => ReflectArg ('ArgStream aname t) where + reflectArg _ + = ArgStream (maySymbolVal (Proxy @aname)) (reflectTyRef (Proxy @t)) + +instance ReflectReturn 'RetNothing where + reflectReturn _ = RetNothing +instance (ReflectTyRef t) + => ReflectReturn ('RetSingle t) where + reflectReturn _ = RetSingle (reflectTyRef (Proxy @t)) +instance (ReflectTyRef t) + => ReflectReturn ('RetStream t) where + reflectReturn _ = RetStream (reflectTyRef (Proxy @t)) +instance (ReflectTyRef e, ReflectTyRef t) + => ReflectReturn ('RetThrows e t) where + reflectReturn _ = RetThrows (reflectTyRef (Proxy @e)) + (reflectTyRef (Proxy @t)) + +instance ReflectTyRef t => ReflectTyRef ('ListRef t) where + reflectTyRef _ = TyList (reflectTyRef (Proxy @t)) +instance ReflectTyRef t => ReflectTyRef ('OptionalRef t) where + reflectTyRef _ = TyOption (reflectTyRef (Proxy @t)) +instance Typeable t => ReflectTyRef ('PrimitiveRef t) where + reflectTyRef _ = TyTy (T.pack $ show $ typeRep @t) +instance KnownSymbol s => ReflectTyRef ('ObjectRef s) where + reflectTyRef _ = TyTy (T.pack $ symbolVal $ Proxy @s) +instance KnownSymbol s => ReflectTyRef ('SchemaRef sch s) where + reflectTyRef _ = TyTy (T.pack $ symbolVal $ Proxy @s) +instance Typeable t => ReflectTyRef ('RegistryRef r t n) where + reflectTyRef _ = TyTy (T.pack $ show $ typeRep @t) diff --git a/core/rpc/src/Mu/Rpc/Annotations.hs b/core/rpc/src/Mu/Rpc/Annotations.hs new file mode 100644 index 00000000..4c5e3f54 --- /dev/null +++ b/core/rpc/src/Mu/Rpc/Annotations.hs @@ -0,0 +1,111 @@ +{-# language DataKinds #-} +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +Description : Protocol-defined annotations. + +Libraries can define custom annotations to +indicate additional information not found +in the 'Package' itself. For example, GraphQL +has optional default values for arguments. +-} +module Mu.Rpc.Annotations +( RpcAnnotation (..) +, AnnotatedPackage +, GetPackageAnnotation +, GetPackageAnnotationMay +, GetServiceAnnotation +, GetServiceAnnotationMay +, GetMethodAnnotation +, GetMethodAnnotationMay +, GetArgAnnotation +, GetArgAnnotationMay +) +where + +import GHC.TypeLits + +import Mu.Rpc + +-- | Annotations proper. +data RpcAnnotation domain serviceName methodName argName where + -- | Annotation over the whole package. + AnnPackage :: domain + -> RpcAnnotation domain serviceName methodName argName + -- | Annotation over a service. + AnnService :: serviceName -> domain + -> RpcAnnotation domain serviceName methodName argName + -- | Annotation over a method. + AnnMethod :: serviceName -> methodName -> domain + -> RpcAnnotation domain serviceName methodName argName + -- | Annotation over an argument. + AnnArg :: serviceName -> methodName -> argName -> domain + -> RpcAnnotation domain serviceName methodName argName + +-- |  This type family links each schema to +-- its corresponding annotations from one domain. +type family AnnotatedPackage domain (sch :: Package serviceName methodName argName tyRef) :: + [RpcAnnotation domain serviceName methodName argName] + +-- | Find the annotation over the package in the given set. +-- If the annotation cannot be found, raise a 'TypeError'. +type family GetPackageAnnotation (anns :: [RpcAnnotation domain s m a]) :: domain where + GetPackageAnnotation '[] + = TypeError ('Text "cannot find package annotation") + GetPackageAnnotation ('AnnPackage d ': rs) = d + GetPackageAnnotation (r ': rs) = GetPackageAnnotation rs + +-- | Find the annotation over the package in the given set. +-- If the annotation cannot be found, return Nothing +type family GetPackageAnnotationMay (anns :: [RpcAnnotation domain s m a]) :: Maybe domain where + GetPackageAnnotationMay '[] = 'Nothing + GetPackageAnnotationMay ('AnnPackage d ': rs) = 'Just d + GetPackageAnnotationMay (r ': rs) = GetPackageAnnotationMay rs + +-- | Find the annotation over the given service in the given set. +-- If the annotation cannot be found, raise a 'TypeError'. +type family GetServiceAnnotation (anns :: [RpcAnnotation domain s m a]) (snm :: s) :: domain where + GetServiceAnnotation '[] snm + = TypeError ('Text "cannot find service annotation for " ':<>: 'ShowType snm) + GetServiceAnnotation ('AnnService snm d ': rs) snm = d + GetServiceAnnotation (r ': rs) snm = GetServiceAnnotation rs snm + +-- | Find the annotation over the given service in the given set. +-- If the annotation cannot be found, return Nothing +type family GetServiceAnnotationMay (anns :: [RpcAnnotation domain s m a]) (snm :: s) :: Maybe domain where + GetServiceAnnotationMay '[] snm = 'Nothing + GetServiceAnnotationMay ('AnnService snm d ': rs) snm = 'Just d + GetServiceAnnotationMay (r ': rs) snm = GetServiceAnnotationMay rs snm + +-- | Find the annotation over the given method in the given service. +-- If the annotation cannot be found, raise a 'TypeError'. +type family GetMethodAnnotation (anns :: [RpcAnnotation domain s m a]) (snm :: s) (mnm :: m) :: domain where + GetMethodAnnotation '[] snm mnm + = TypeError ('Text "cannot find method annotation for " ':<>: 'ShowType snm ':<>: 'Text "/" ':<>: 'ShowType mnm) + GetMethodAnnotation ('AnnMethod snm mnm d ': rs) snm mnm = d + GetMethodAnnotation (r ': rs) snm mnm = GetMethodAnnotation rs snm mnm + +-- | Find the annotation over the given method in the given service. +-- If the annotation cannot be found, return Nothing +type family GetMethodAnnotationMay (anns :: [RpcAnnotation domain s m a]) (snm :: s) (mnm :: m) :: Maybe domain where + GetMethodAnnotationMay '[] snm mnm = 'Nothing + GetMethodAnnotationMay ('AnnMethod snm mnm d ': rs) snm mnm = 'Just d + GetMethodAnnotationMay (r ': rs) snm mnm = GetMethodAnnotationMay rs snm mnm + +-- | Find the annotation over the given argument in the given method in the given service. +-- If the annotation cannot be found, raise a 'TypeError'. +type family GetArgAnnotation (anns :: [RpcAnnotation domain s m a]) (snm :: s) (mnm :: m) (anm :: a) :: domain where + GetArgAnnotation '[] snm mnm anm + = TypeError ('Text "cannot find argument annotation for " ':<>: 'ShowType snm ':<>: 'Text "/" ':<>: 'ShowType mnm ':<>: 'Text "/" ':<>: 'ShowType anm) + GetArgAnnotation ('AnnArg snm mnm anm d ': rs) snm mnm anm = d + GetArgAnnotation (r ': rs) snm mnm anm = GetArgAnnotation rs snm mnm anm + +-- | Find the annotation over the given argument in the given method in the given service. +-- If the annotation cannot be found, return Nothing +type family GetArgAnnotationMay (anns :: [RpcAnnotation domain s m a]) (snm :: s) (mnm :: m) (anm :: a) :: Maybe domain where + GetArgAnnotationMay '[] snm mnm anm = 'Nothing + GetArgAnnotationMay ('AnnArg snm mnm anm d ': rs) snm mnm anm = 'Just d + GetArgAnnotationMay (r ': rs) snm mnm anm = GetArgAnnotationMay rs snm mnm anm diff --git a/core/rpc/src/Mu/Rpc/Examples.hs b/core/rpc/src/Mu/Rpc/Examples.hs new file mode 100644 index 00000000..33c75522 --- /dev/null +++ b/core/rpc/src/Mu/Rpc/Examples.hs @@ -0,0 +1,147 @@ +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingVia #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} +{-| +Description : Examples for service and server definitions + +Look at the source code of this module. +-} +module Mu.Rpc.Examples where + +import qualified Data.Aeson as J +import Data.Conduit +import Data.Conduit.Combinators as C +import qualified Data.Text as T +import GHC.Generics +import GHC.TypeLits + +import Mu.Adapter.Json () +import Mu.Rpc +import Mu.Schema +import Mu.Server + +-- Defines the service from gRPC Quickstart +-- https://grpc.io/docs/quickstart/python/ + +type QuickstartSchema + = '[ 'DRecord "HelloRequest" + '[ 'FieldDef "name" ('TPrimitive T.Text) ] + , 'DRecord "HelloResponse" + '[ 'FieldDef "message" ('TPrimitive T.Text) ] + , 'DRecord "HiRequest" + '[ 'FieldDef "number" ('TPrimitive Int) ] + ] + +type QuickStartService + = ('Package ('Just "helloworld") + '[ 'Service "Greeter" + '[ 'Method "SayHello" + '[ 'ArgSingle ('Nothing :: Maybe Symbol) ('SchemaRef QuickstartSchema "HelloRequest") ] + ('RetSingle ('SchemaRef QuickstartSchema "HelloResponse")) + , 'Method "SayHi" + '[ 'ArgSingle ('Nothing :: Maybe Symbol) ('SchemaRef QuickstartSchema "HiRequest")] + ('RetStream ('SchemaRef QuickstartSchema "HelloResponse")) + , 'Method "SayManyHellos" + '[ 'ArgStream ('Nothing :: Maybe Symbol) ('SchemaRef QuickstartSchema "HelloRequest")] + ('RetStream ('SchemaRef QuickstartSchema "HelloResponse")) ] ] :: Package') + +newtype HelloRequest = HelloRequest { name :: T.Text } + deriving ( Show, Eq, Generic + , ToSchema QuickstartSchema "HelloRequest" + , FromSchema QuickstartSchema "HelloRequest" ) + deriving (J.ToJSON, J.FromJSON) + via (WithSchema QuickstartSchema "HelloRequest" HelloRequest) + +newtype HelloResponse = HelloResponse { message :: T.Text } + deriving ( Show, Eq, Generic + , ToSchema QuickstartSchema "HelloResponse" + , FromSchema QuickstartSchema "HelloResponse" ) + deriving (J.ToJSON, J.FromJSON) + via (WithSchema QuickstartSchema "HelloResponse" HelloResponse) + +newtype HiRequest = HiRequest { number :: Int } + deriving ( Show, Eq, Generic + , ToSchema QuickstartSchema "HiRequest" + , FromSchema QuickstartSchema "HiRequest" ) + deriving (J.ToJSON, J.FromJSON) + via (WithSchema QuickstartSchema "HiRequest" HiRequest) + +quickstartServer :: forall m i. (MonadServer m) + => ServerT '[] i QuickStartService m _ +quickstartServer + -- = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0) + = singleService ( method @"SayHello" sayHello + , method @"SayManyHellos" sayManyHellos + , method @"SayHi" sayHi ) + where + sayHello :: HelloRequest -> m HelloResponse + sayHello (HelloRequest nm) + = pure $ HelloResponse $ "hi, " <> nm + sayHi :: HiRequest + -> ConduitT HelloResponse Void m () + -> m () + sayHi (HiRequest n) sink + = runConduit $ C.replicate n (HelloResponse "hi!") .| sink + sayManyHellos :: ConduitT () HelloRequest m () + -> ConduitT HelloResponse Void m () + -> m () + sayManyHellos source sink + = runConduit $ source .| C.mapM sayHello .| sink + +-- From https://www.apollographql.com/docs/apollo-server/schema/schema/ +type ApolloService + = 'Package ('Just "apollo") + '[ Object "Book" + '[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String)) + , ObjectField "author" '[] ('RetSingle ('ObjectRef "Author")) + ] + , Object "Paper" + '[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String)) + , ObjectField "author" '[] ('RetSingle ('ObjectRef "Author")) + ] + , Union "Writing" ["Book", "Paper"] + , Object "Author" + '[ ObjectField "name" '[] ('RetSingle ('PrimitiveRef String)) + , ObjectField "writings" '[] ('RetSingle ('ListRef ('ObjectRef "Writing"))) + ] + ] + +type ApolloBookAuthor = '[ + "Book" ':-> (String, Integer) + , "Paper" ':-> (String, Integer) + , "Writing" ':-> Either (String, Integer) (String, Integer) + , "Author" ':-> Integer + ] + +apolloServer :: forall m i. (MonadServer m) + => ServerT ApolloBookAuthor i ApolloService m _ +apolloServer + = resolver + ( object @"Author" ( field @"name" authorName + , field @"writings" authorWrs ) + , object @"Book" ( field @"author" (pure . snd) + , field @"title" (pure . fst) ) + , object @"Paper" ( field @"author" (pure . snd) + , field @"title" (pure . fst) ) + , union @"Writing" writing ) + where + authorName :: Integer -> m String + authorName _ = pure "alex" -- this would run in the DB + authorWrs :: Integer -> m [Either (String, Integer) (String, Integer)] + authorWrs _ = pure [] + + writing (Left c) = pure $ unionChoice @"Book" c + writing (Right c) = pure $ unionChoice @"Paper" c diff --git a/core/rpc/src/Mu/Server.hs b/core/rpc/src/Mu/Server.hs new file mode 100644 index 00000000..1b3659eb --- /dev/null +++ b/core/rpc/src/Mu/Server.hs @@ -0,0 +1,497 @@ +{-# language AllowAmbiguousTypes #-} +{-# language CPP #-} +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language ExistentialQuantification #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language GADTs #-} +{-# language PatternSynonyms #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-# language ViewPatterns #-} +{-| +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 can declare a server by naming +each of the methods with their handlers: + +> server :: MonadServer m => ServerT MyService m _ +> server = singleService ( method @"m1" h1 +> , method @"m2" h2 +> , ... ) + +or by position: + +> server :: MonadServer m => ServerT MyService m _ +> server = Server (h1 :<|>: h2 :<|>: ... :<|>: H0) + +where each of @h1@, @h2@, ... handles each method in +@MyService@ /in the order they were declared/. + +In both cases, 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, ServiceChain, noContext +, wrapServer + -- ** Definitions by name +, singleService +, method, methodWithInfo +, resolver, object, union +, field, fieldWithInfo +, UnionChoice(..), unionChoice +, NamedList(..) + -- ** Definitions by position +, SingleServerT, pattern Server +, ServerT(..), ServicesT(..), ServiceT(..), HandlersT(.., (:<||>:), (:<|>:)) + -- ** Simple servers using only IO +, ServerErrorIO, ServerIO + -- * Errors which might be raised +, serverError, ServerError(..), ServerErrorCode(..) + -- ** Useful when you do not want to deal with errors +, alwaysOk + -- * For internal use +, Handles, FromRef, ToRef +) where + +import Control.Exception (Exception) +import Control.Monad.Except +import Data.Conduit +import Data.Kind +import Data.Typeable +import GHC.TypeLits + +import Mu.Rpc +import Mu.Schema + +#if __GLASGOW_HASKELL__ < 808 +import Unsafe.Coerce (unsafeCoerce) +#endif + +-- | 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, +-- and whose service has no back-references. +type ServerIO info srv = ServerT '[] info 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 + +-- | To declare that the function doesn't use +-- its context. +noContext :: b -> a1 -> a2 -> b +noContext x _ _ = x + +-- | Errors raised in a handler. +data ServerError + = ServerError ServerErrorCode String + deriving Show + +instance Exception ServerError + +-- | Possible types of errors. +-- Some of these are handled in a special way +-- by different transpoprt layers. +data ServerErrorCode + = Unknown + | Unavailable + | Unimplemented + | Unauthenticated + | Internal + | Invalid + | NotFound + deriving (Eq, Show) + +-- | Defines a mapping between outcome of +-- a service, and its representation as +-- Haskell type. +type ServiceChain snm = Mappings snm Type + +-- | A server for a single service, +-- like most RPC ones. +type SingleServerT = ServerT '[] + +-- | Definition of a complete server +-- for a set of services, with possible +-- references between them. +data ServerT (chn :: ServiceChain snm) (info :: Type) + (s :: Package snm mnm anm (TypeRef snm)) + (m :: Type -> Type) (hs :: [[Type]]) where + Services :: ServicesT chn info s m hs + -> ServerT chn info ('Package pname s) m hs + +pattern Server :: (MappingRight chn sname ~ ()) + => HandlersT chn info () methods m hs + -> ServerT chn info ('Package pname '[ 'Service sname methods ]) m '[hs] +pattern Server svr = Services (ProperSvc svr :<&>: S0) + +infixr 3 :<&>: +-- | Definition of a complete server for a service. +data ServicesT (chn :: ServiceChain snm) (info :: Type) + (s :: [Service snm mnm anm (TypeRef snm)]) + (m :: Type -> Type) (hs :: [[Type]]) where + S0 :: ServicesT chn info '[] m '[] + (:<&>:) :: ServiceT chn info svc m hs + -> ServicesT chn info rest m hss + -> ServicesT chn info (svc ': rest) m (hs ': hss) + +type family InUnion (x :: k) (xs :: [k]) :: Constraint where + InUnion x '[] = TypeError ('ShowType x ':<>: 'Text " is not part of the union") + InUnion x (x ': xs) = () + InUnion x (y ': xs) = InUnion x xs + +data UnionChoice chn elts where + UnionChoice :: (InUnion elt elts, Typeable elt) + => Proxy elt -> MappingRight chn elt + -> UnionChoice chn elts + +unionChoice :: forall elt elts chn. + (InUnion elt elts, Typeable elt) + => MappingRight chn elt -> UnionChoice chn elts +unionChoice = UnionChoice (Proxy @elt) + +-- | Definition of different kinds of services. +data ServiceT chn info svc m hs where + ProperSvc :: HandlersT chn info (MappingRight chn sname) methods m hs + -> ServiceT chn info ('Service sname methods) m hs + OneOfSvc :: (MappingRight chn sname -> m (UnionChoice chn elts)) + -> ServiceT chn info ('OneOf sname elts) m '[] + +-- | '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 (chn :: ServiceChain snm) (info :: Type) + (inh :: *) (methods :: [Method snm mnm anm (TypeRef snm)]) + (m :: Type -> Type) (hs :: [Type]) where + H0 :: HandlersT chn info inh '[] m '[] + Hmore :: Handles chn args ret m h + => Proxy args -> Proxy ret + -> (RpcInfo info -> inh -> h) + -> HandlersT chn info inh ms m hs + -> HandlersT chn info inh ('Method name args ret ': ms) m (h ': hs) + +infixr 4 :<||>: +pattern (:<||>:) :: Handles chn args ret m h + => (RpcInfo info -> inh -> h) -> HandlersT chn info inh ms m hs + -> HandlersT chn info inh ('Method name args ret ': ms) m (h ': hs) +pattern x :<||>: xs <- Hmore _ _ x xs where + x :<||>: xs = Hmore Proxy Proxy x xs + +infixr 4 :<|>: +pattern (:<|>:) :: (Handles chn args ret m h) + => h -> HandlersT chn info () ms m hs + -> HandlersT chn info () ('Method name args ret ': ms) m (h ': hs) +pattern x :<|>: xs <- (($ ()) . ($ NoRpcInfo) -> x) :<||>: xs where + x :<|>: xs = noContext x :<||>: xs + +-- | Defines a relation for handling. +class Handles (chn :: ServiceChain snm) + (args :: [Argument snm anm (TypeRef snm)]) + (ret :: Return snm (TypeRef snm)) + (m :: Type -> Type) (h :: Type) where + wrapHandler :: Proxy '(chn, m) -> Proxy args -> Proxy ret + -> (forall a. m a -> m a) -> h -> h +-- | Defines whether a given type @t@ +-- can be turned into the 'TypeRef' @ref@. +class ToRef (chn :: ServiceChain snm) + (ref :: TypeRef snm) (t :: Type) +-- | Defines whether a given type @t@ +-- can be obtained from the 'TypeRef' @ref@. +class FromRef (chn :: ServiceChain snm) + (ref :: TypeRef snm) (t :: Type) + +-- Type references +instance t ~ s => ToRef chn ('PrimitiveRef t) s +instance ToSchema sch sty t => ToRef chn ('SchemaRef sch sty) t +instance MappingRight chn ref ~ t => ToRef chn ('ObjectRef ref) t +instance t ~ s => ToRef chn ('RegistryRef subject t last) s +instance (ToRef chn ref t, [t] ~ s) => ToRef chn ('ListRef ref) s +instance (ToRef chn ref t, Maybe t ~ s) => ToRef chn ('OptionalRef ref) s + +instance t ~ s => FromRef chn ('PrimitiveRef t) s +instance FromSchema sch sty t => FromRef chn ('SchemaRef sch sty) t +instance MappingRight chn ref ~ t => FromRef chn ('ObjectRef ref) t +instance t ~ s => FromRef chn ('RegistryRef subject t last) s +instance (FromRef chn ref t, [t] ~ s) => FromRef chn ('ListRef ref) s +instance (FromRef chn ref t, Maybe t ~ s) => FromRef chn ('OptionalRef ref) s + +-- Arguments +instance forall chn ref args ret m handler h t aname. + ( FromRef chn ref t, Handles chn args ret m h + , handler ~ (t -> h) ) + => Handles chn ('ArgSingle aname ref ': args) ret m handler where + wrapHandler pchn _ pr f h = wrapHandler pchn (Proxy @args) pr f . h +instance (MonadError ServerError m, FromRef chn ref t, Handles chn args ret m h, + handler ~ (ConduitT () t m () -> h)) + => Handles chn ('ArgStream aname ref ': args) ret m handler where + wrapHandler pchn _ pr f h = wrapHandler pchn (Proxy @args) pr f . h +-- Result with exception +instance (MonadError ServerError m, handler ~ m ()) + => Handles chn '[] 'RetNothing m handler where + wrapHandler _ _ _ f h = f h +instance ( MonadError ServerError m, ToRef chn eref e, ToRef chn vref v + , handler ~ m (Either e v) ) + => Handles chn '[] ('RetThrows eref vref) m handler where + wrapHandler _ _ _ f h = f h +instance (MonadError ServerError m, ToRef chn ref v, handler ~ m v) + => Handles chn '[] ('RetSingle ref) m handler where + wrapHandler _ _ _ f h = f h +instance ( MonadError ServerError m, ToRef chn ref v + , handler ~ (ConduitT v Void m () -> m ()) ) + => Handles chn '[] ('RetStream ref) m handler where + wrapHandler _ _ _ f h = f . h + +-- SIMPLER WAY TO DECLARE SERVICES + +-- | Declares the handler for a method in the service. +-- Intended to be used with @TypeApplications@: +-- +-- > method @"myMethod" myHandler +method :: forall n a p. p -> Named n (a -> () -> p) +method f = Named (\_ _ -> f) + +-- | Declares the handler for a method in the service, +-- which is passed additional information about the call. +-- Intended to be used with @TypeApplications@: +-- +-- > methodWithInfo @"myMethod" myHandler +methodWithInfo :: forall n p info. (RpcInfo info -> p) -> Named n (RpcInfo info -> () -> p) +methodWithInfo f = Named (\x () -> f x) + +-- | Declares the handler for a field in an object. +-- Intended to be used with @TypeApplications@: +-- +-- > field @"myField" myHandler +field :: forall n h info. h -> Named n (RpcInfo info -> h) +field f = Named (const f) + +-- | Declares the handler for a field in an object, +-- which is passed additional information about the call. +-- Intended to be used with @TypeApplications@: +-- +-- > fieldWithInfo @"myField" myHandler +fieldWithInfo :: forall n h info. (RpcInfo info -> h) -> Named n (RpcInfo info -> h) +fieldWithInfo = Named + +-- | Defines a server for a package with a single service. +-- Intended to be used with a tuple of 'method's: +-- +-- > singleService (method @"m1" h1, method @"m2" h2) +singleService + :: ( ToNamedList p nl + , ToHandlers chn info () methods m hs nl + , MappingRight chn sname ~ () ) + => p -> ServerT chn info ('Package pname '[ 'Service sname methods ]) m '[hs] +singleService nl = Server $ toHandlers $ toNamedList nl + +-- | Defines the implementation of a single GraphQL object, +-- which translates as a single Mu service. +-- Intended to be used with @TypeApplications@ +-- and a tuple of 'field's: +-- +-- > object @"myObject" (field @"f1" h1, fielf @"f2" h2) +-- +-- Note: for the root objects in GraphQL (query, mutation, subscription) +-- use 'method' instead of 'object'. +object + :: forall sname p nl chn info ms m hs. + ( ToNamedList p nl + , ToHandlers chn info (MappingRight chn sname) ms m hs nl ) + => p -> Named sname (HandlersT chn info (MappingRight chn sname) ms m hs) +object nl = Named $ toHandlers $ toNamedList nl + +union :: forall sname chn m elts. + (MappingRight chn sname -> m (UnionChoice chn elts)) + -> Named sname (MappingRight chn sname -> m (UnionChoice chn elts)) +union = Named + +-- | Combines the implementation of several GraphQL objects, +-- which means a whole Mu service for a GraphQL server. +-- Intented to be used with a tuple of 'objects': +-- +-- > resolver (object @"o1" ..., object @"o2" ...) +resolver + :: (ToNamedList p nl, ToServices chn info ss m hs nl) + => p -> ServerT chn info ('Package pname ss) m hs +resolver nl = Services $ toServices $ toNamedList nl + +-- | A value tagged with a type-level name. +data Named n h where + Named :: forall n h. h -> Named n h + +infixr 4 :|: +-- | Heterogeneous list in which each element +-- is tagged with a type-level name. +data NamedList (hs :: [(Symbol, *)]) where + N0 :: NamedList '[] + (:|:) :: Named n h -> NamedList hs + -> NamedList ('(n, h) ': hs) + +-- | Used to turn tuples into 'NamedList's. +class ToNamedList p nl | p -> nl where + toNamedList :: p -> NamedList nl + +instance ToNamedList (NamedList nl) nl where + toNamedList = id +instance ToNamedList () '[] where + toNamedList _ = N0 +instance ToNamedList (Named n h) '[ '(n, h) ] where + toNamedList n = n :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2) + '[ '(n1, h1), '(n2, h2) ] where + toNamedList (n1, n2) = n1 :|: n2 :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3) + '[ '(n1, h1), '(n2, h2), '(n3, h3) ] where + toNamedList (n1, n2, n3) = n1 :|: n2 :|: n3 :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4) + '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4) ] where + toNamedList (n1, n2, n3, n4) = n1 :|: n2 :|: n3 :|: n4 :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5) + '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5) ] where + toNamedList (n1, n2, n3, n4, n5) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6) + '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6) ] where + toNamedList (n1, n2, n3, n4, n5, n6) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6, Named n7 h7) + '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7) ] where + toNamedList (n1, n2, n3, n4, n5, n6, n7) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: n7 :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6, Named n7 h7, Named n8 h8) + '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8) ] where + toNamedList (n1, n2, n3, n4, n5, n6, n7, n8) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: n7 :|: n8 :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6, Named n7 h7, Named n8 h8, Named n9 h9) + '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8), '(n9, h9) ] where + toNamedList (n1, n2, n3, n4, n5, n6, n7, n8, n9) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: n7 :|: n8 :|: n9 :|: N0 + +class ToHandlers chn info inh ms m hs nl | chn inh ms m nl -> hs where + toHandlers :: NamedList nl + -> HandlersT chn info inh ms m hs + +instance ToHandlers chn info inh '[] m '[] nl where + toHandlers _ = H0 +instance ( FindHandler name info inh h nl + , Handles chn args ret m h + , ToHandlers chn info inh ms m hs nl ) + => ToHandlers chn info inh ('Method name args ret ': ms) m (h ': hs) nl where + toHandlers nl = findHandler (Proxy @name) nl :<||>: toHandlers nl + +class FindHandler name info inh h nl | name nl -> inh h where + findHandler :: Proxy name -> NamedList nl -> RpcInfo info -> inh -> h +instance (inh ~ h, h ~ TypeError ('Text "cannot find handler for " ':<>: 'ShowType name)) + => FindHandler name info inh h '[] where + findHandler = error "this should never be called" +instance {-# OVERLAPS #-} (RpcInfo info ~ rpc', inh ~ inh', h ~ h') + => FindHandler name info inh h ( '(name, rpc' -> inh' -> h') ': rest ) where + findHandler _ (Named f :|: _) = f +instance {-# OVERLAPPABLE #-} FindHandler name info inh h rest + => FindHandler name info inh h (thing ': rest) where + findHandler p (_ :|: rest) = findHandler p rest + +class ToServices chn info ss m hs nl | chn ss m nl -> hs where + toServices :: NamedList nl + -> ServicesT chn info ss m hs + +instance ToServices chn info '[] m '[] nl where + toServices _ = S0 +instance ( FindService name (HandlersT chn info (MappingRight chn name) methods m h) nl + , ToServices chn info ss m hs nl) + => ToServices chn info ('Service name methods ': ss) m (h ': hs) nl where + toServices nl = ProperSvc (findService (Proxy @name) nl) :<&>: toServices nl +instance ( FindService name (MappingRight chn name -> m (UnionChoice chn elts)) nl + , ToServices chn info ss m hs nl) + => ToServices chn info ('OneOf name elts ': ss) m ('[] ': hs) nl where + toServices nl = OneOfSvc (findService (Proxy @name) nl) :<&>: toServices nl + + +class FindService name h nl | name nl -> h where + findService :: Proxy name -> NamedList nl -> h +instance (h ~ TypeError ('Text "cannot find handler for " ':<>: 'ShowType name)) + => FindService name h '[] where + findService = error "this should never be called" +instance {-# OVERLAPS #-} (h ~ h') + => FindService name h ( '(name, h') ': rest ) where + findService _ (Named f :|: _) = f +instance {-# OVERLAPPABLE #-} FindService name h rest + => FindService name h (thing ': rest) where + findService p (_ :|: rest) = findService p rest + +-- WRAPPING MECHANISM + +wrapServer + :: forall chn info p m topHs. + (forall a. RpcInfo info -> m a -> m a) + -> ServerT chn info p m topHs -> ServerT chn info p m topHs +wrapServer f (Services ss) = Services (wrapServices ss) + where + wrapServices :: forall ss hs. + ServicesT chn info ss m hs + -> ServicesT chn info ss m hs + wrapServices S0 = S0 +#if __GLASGOW_HASKELL__ >= 808 + wrapServices (ProperSvc h :<&>: rest) + = ProperSvc (wrapHandlers h) :<&>: wrapServices rest + wrapServices (OneOfSvc h :<&>: rest) + = OneOfSvc h :<&>: wrapServices rest +#else + wrapServices (ProperSvc h :<&>: rest) + = ProperSvc (unsafeCoerce (wrapHandlers (unsafeCoerce h))) + :<&>: unsafeCoerce (wrapServices rest) + wrapServices (OneOfSvc h :<&>: rest) + = OneOfSvc (unsafeCoerce h) + :<&>: unsafeCoerce (wrapServices rest) +#endif + + wrapHandlers :: forall inh ms innerHs. + HandlersT chn info inh ms m innerHs + -> HandlersT chn info inh ms m innerHs + wrapHandlers H0 = H0 + wrapHandlers (Hmore pargs pret h rest) + = Hmore pargs pret + (\rpc inh -> wrapHandler (Proxy @'(chn, m)) pargs pret (f rpc) (h rpc inh)) + (wrapHandlers rest) 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..ffeb95d1 --- /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 © 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/core/schema/Setup.hs b/core/schema/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/core/schema/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain 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/core/schema/mu-schema.cabal b/core/schema/mu-schema.cabal new file mode 100644 index 00000000..842fff27 --- /dev/null +++ b/core/schema/mu-schema.cabal @@ -0,0 +1,56 @@ +name: mu-schema +version: 0.3.1.2 +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. + +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 +cabal-version: >=1.10 +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.Adapter.Json + Mu.Schema + Mu.Schema.Annotations + Mu.Schema.Class + Mu.Schema.Conversion.SchemaToTypes + Mu.Schema.Conversion.TypesToSchema + Mu.Schema.Definition + Mu.Schema.Examples + Mu.Schema.Interpretation + Mu.Schema.Interpretation.Anonymous + Mu.Schema.Interpretation.Schemaless + Mu.Schema.Registry + + -- other-modules: + -- other-extensions: + build-depends: + aeson >=1.4 && <2 + , base >=4.12 && <5 + , bytestring >=0.10 && <0.11 + , containers >=0.6 && <0.7 + , first-class-families >=0.8 && <0.9 + , sop-core >=0.5 && <0.6 + , template-haskell >=2.14 && <2.17 + , text >=1.2 && <2 + , th-abstraction >=0.3.2 && <0.5 + , unordered-containers >=0.2 && <0.3 + , uuid >=1.3 && <2 + , vector >=0.12 && <0.13 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances diff --git a/schema/src/Mu/Schema/Adapter/Json.hs b/core/schema/src/Mu/Adapter/Json.hs similarity index 61% rename from schema/src/Mu/Schema/Adapter/Json.hs rename to core/schema/src/Mu/Adapter/Json.hs index 14973b91..d3f95ab9 100644 --- a/schema/src/Mu/Schema/Adapter/Json.hs +++ b/core/schema/src/Mu/Adapter/Json.hs @@ -1,21 +1,32 @@ -{-# 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.Schema.Adapter.Json where +{-| +Description : Adapter for JSON serialization -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 +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 Mu.Schema +import Control.Applicative ((<|>)) +import Data.Aeson +import Data.Aeson.Types +import Data.Functor.Contravariant +import qualified Data.HashMap.Strict as HM +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 @@ -34,50 +45,50 @@ 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))) +instance (ToSchema 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))) + toJSON (WithSchema x) = toJSON (toSchema' @_ @_ @sch x) +instance (FromSchema sch sty a, FromJSON (Term sch (sch :/: sty))) => FromJSON (WithSchema sch sty a) where - parseJSON v = WithSchema . fromSchema' @sch <$> parseJSON v + 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" + parseJSON _ = fail "expected object" class ToJSONFields sch fields where toJSONFields :: NP (Field sch) fields -> Object 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 (Field v :* rest) = HM.insert key value (toJSONFields rest) + => 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 class FromJSONFields sch fields where parseJSONFields :: Object -> Parser (NP (Field sch) fields) instance FromJSONFields sch '[] where - parseJSONFields _ = return Nil + parseJSONFields _ = pure 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" + parseJSON _ = fail "expected string" class ToJSONEnum choices where toJSONEnum :: NS Proxy choices -> T.Text 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 @@ -86,9 +97,9 @@ 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) + | v == key = pure (Z Proxy) | otherwise = S <$> parseJSONEnum v where key = T.pack (nameVal (Proxy @c)) @@ -116,11 +127,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 Null = pure FNull + 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 +160,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 diff --git a/core/schema/src/Mu/Schema.hs b/core/schema/src/Mu/Schema.hs new file mode 100644 index 00000000..8ec21c1c --- /dev/null +++ b/core/schema/src/Mu/Schema.hs @@ -0,0 +1,42 @@ +{-# language DataKinds #-} +{-| +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' +, KnownName(..) +, TypeDef, TypeDefB(..) +, ChoiceDef(..) +, FieldDef, FieldDefB(..) +, FieldType, FieldTypeB(..) + -- ** Lookup type in schema +, (:/:) + -- * Interpretation of schemas +, Term(..), Field(..), FieldValue(..) +, NS(..), NP(..), Proxy(..) + -- * Conversion from types to schemas +, WithSchema(..), unWithSchema +, FromSchema(..), fromSchema' +, ToSchema(..), toSchema' +, CustomFieldMapping(..) +, Underlying(..), UnderlyingConversion(..) + -- ** Mappings between fields +, Mapping(..), Mappings, MappingRight, MappingLeft + -- ** Field annotations +, AnnotatedSchema, AnnotationDomain, Annotation(..) +) where + +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 new file mode 100644 index 00000000..4cb6788a --- /dev/null +++ b/core/schema/src/Mu/Schema/Annotations.hs @@ -0,0 +1,75 @@ +{-# language DataKinds #-} +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +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 + +-- | Each annotation belongs to a domain. +type AnnotationDomain = Type + +-- | 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 + +-- | 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] + +-- | 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) + 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 new file mode 100644 index 00000000..a0771882 --- /dev/null +++ b/core/schema/src/Mu/Schema/Class.hs @@ -0,0 +1,603 @@ +{-# language DataKinds #-} +{-# language DefaultSignatures #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language QuantifiedConstraints #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +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 MySchema "MySchemaType" MyHaskellType +> , FromSchema 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(..), unWithSchema +, FromSchema(..), fromSchema' +, ToSchema(..), toSchema' +, CustomFieldMapping(..) +, Mapping(..), Mappings, MappingRight, MappingLeft +, Underlying(..), UnderlyingConversion(..) + -- * Internal use only +, GToSchemaRecord(..) +) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import Data.Kind +import Data.Map as M +import Data.Maybe (fromJust) +import Data.SOP +import qualified Data.Text as T +import qualified Data.UUID as U +import GHC.Generics +import GHC.TypeLits + +import Fcf (Eval, Exp, Pure) +import Fcf.Data.List (Snoc) +import Mu.Schema.Definition +import Mu.Schema.Interpretation + +-- | Tags a value with its schema. +-- For usage with @deriving via@. +newtype WithSchema (sch :: Schema tn fn) (sty :: tn) a where + WithSchema :: forall tn fn (sch :: Schema tn fn) (sty :: tn) a. + a -> WithSchema sch sty a + +-- | Accessor for 'WithSchema'. +-- Intended for usage with @TypeApplications@. +unWithSchema :: forall tn fn (sch :: Schema tn fn) (sty :: tn) a. + WithSchema sch sty a -> a +unWithSchema (WithSchema x) = x + +-- | 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 @sty@ +-- by means of 'CustomFieldMapping'. +class ToSchema (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type) + | sch t -> sty where + -- | Conversion from Haskell type to schema term. + toSchema :: t -> Term sch (sch :/: sty) + + default + toSchema :: (Generic t, GToSchemaTypeDef sch '[] (sch :/: sty) (Rep t)) + => t -> Term 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 @sty@ +-- by means of 'CustomFieldMapping'. +class FromSchema (sch :: Schema typeName fieldName) (sty :: typeName) (t :: Type) + | sch t -> sty where + -- | Conversion from schema term to Haskell type. + fromSchema :: Term sch (sch :/: sty) -> t + + default + fromSchema :: (Generic t, GFromSchemaTypeDef sch '[] (sch :/: sty) (Rep t) ) + => Term sch (sch :/: sty) -> t + fromSchema x = to (fromSchemaTypeDef (Proxy @'[]) x) + +instance (sch :/: sty ~ 'DRecord sty fields) + => ToSchema sch sty (Term sch ('DRecord sty fields)) where + toSchema = id +instance (sch :/: sty ~ 'DEnum sty choices) + => ToSchema sch sty (Term sch ('DEnum sty choices)) where + toSchema = id +instance (sch :/: sty ~ 'DRecord sty fields) + => FromSchema sch sty (Term sch ('DRecord sty fields)) where + fromSchema = id +instance (sch :/: sty ~ 'DEnum sty choices) + => FromSchema sch sty (Term sch ('DEnum sty choices)) where + fromSchema = id + +-- | Conversion from Haskell type to schema term. +-- This version is intended for usage with @TypeApplications@: +-- > toSchema' @MySchema myValue +toSchema' :: forall fn tn (sch :: Schema tn fn) t sty. + ToSchema sch sty t => t -> Term 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 fn tn (sch :: Schema tn fn) t sty. + FromSchema sch sty t => Term 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 + +instance (Generic t, GToSchemaTypeDef sch fmap (sch :/: sty) (Rep t)) + => ToSchema sch sty (CustomFieldMapping sty fmap t) where + toSchema (CustomFieldMapping x) = toSchemaTypeDef (Proxy @fmap) (from x) + +instance (Generic t, GFromSchemaTypeDef sch fmap (sch :/: sty) (Rep t)) + => FromSchema sch sty (CustomFieldMapping sty fmap t) where + fromSchema x = CustomFieldMapping $ to (fromSchemaTypeDef (Proxy @fmap) x) + +-- | This 'newtype' is used to wrap types for which +-- we want a "logical" representation as a Haskell +-- type, but the underlying representation is +-- lower level, like 'UUID's as 'ByteString's. +newtype Underlying basic logical + = Underlying { unUnderlying :: logical } + deriving (Show, Eq) + +-- | This class defines the actual conversion between +-- a "logical" type and its low-level representation. +class UnderlyingConversion basic logical where + toUnderlying :: logical -> basic + fromUnderlying :: basic -> logical + +instance UnderlyingConversion String U.UUID where + toUnderlying = U.toString + fromUnderlying = fromJust . U.fromString +instance UnderlyingConversion T.Text U.UUID where + toUnderlying = U.toText + fromUnderlying = fromJust . U.fromText +instance UnderlyingConversion BL.ByteString U.UUID where + toUnderlying = U.toByteString + fromUnderlying = fromJust . U.fromByteString +instance UnderlyingConversion BS.ByteString U.UUID where + toUnderlying = BL.toStrict . U.toByteString + fromUnderlying = fromJust . U.fromByteString . BL.fromStrict + +-- ====================== +-- CRAZY GENERICS SECTION +-- ====================== + +-- Auxiliary type families to find elements in lists +-- They return an indication of where the thing was found +-- +-- Note: it turns out that GHC.Generics generates some weird +-- instances for records in the form (x :*: y) :*: z +-- and we cover them with the special HereLeft and HereRight +data Where = Here | There Where +data WhereStep = StepNoMore | StepLeft | StepRight + +type family Find (xs :: [k]) (x :: k) :: Where where + Find '[] y = TypeError ('Text "Could not find " ':<>: 'ShowType y) + Find (y ': xs) y = 'Here + Find (x ': xs) y = 'There (Find xs y) + +type family FindCon (xs :: * -> *) (x :: Symbol) :: [WhereStep] where + FindCon xs x = WhenEmpty + (FindCon' '[] xs x) + (TypeError ('Text "Could not find constructor " ':<>: 'ShowType x)) + +type family FindCon' (begin :: [WhereStep]) (xs :: * -> *) (x :: Symbol) :: [WhereStep] where + FindCon' acc (C1 ('MetaCons x p s) f) x = Eval (Snoc acc 'StepNoMore) + FindCon' acc (left :+: right) x = WhenEmpty + (FindCon' (Eval (Snoc acc 'StepLeft)) left x) + (Pure (FindCon' (Eval (Snoc acc 'StepRight)) right x)) + FindCon' acc other x = '[] + +type family WhenEmpty (left :: [a]) (right :: Exp [a]) :: [a] where + WhenEmpty '[] b = Eval b + WhenEmpty a _ = a + +type family FindSel (xs :: * -> *) (x :: Symbol) :: [WhereStep] where + FindSel xs x = WhenEmpty + (FindSel' '[] xs x) + (TypeError ('Text "Could not find field " ':<>: 'ShowType x)) + +type family FindSel' (begin :: [WhereStep]) (xs :: * -> *) (x :: Symbol) :: [WhereStep] where + FindSel' acc (S1 ('MetaSel ('Just x) u ss ds) f) x = Eval (Snoc acc 'StepNoMore) + FindSel' acc (left :*: right) x = WhenEmpty + (FindSel' (Eval (Snoc acc 'StepLeft)) left x) + (Pure (FindSel' (Eval (Snoc acc 'StepRight)) right x)) + FindSel' acc other x = '[] + +type family FindEnumChoice (xs :: [ChoiceDef fs]) (x :: fs) :: Where where + FindEnumChoice '[] x = TypeError ('Text "Could not find enum choice " ':<>: 'ShowType x) + 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 t ': xs) name = 'Here + FindField (other ': xs) name = 'There (FindField xs name) + +-- Generic type definitions +class GToSchemaTypeDef + (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) + (t :: TypeDef ts fs) (f :: * -> *) where + toSchemaTypeDef :: Proxy fmap -> f a -> Term sch t +class GFromSchemaTypeDef + (sch :: Schema ts fs) (fmap :: Mappings Symbol fs) + (t :: TypeDef ts fs) (f :: * -> *) where + fromSchemaTypeDef :: Proxy fmap -> Term sch t -> f a + +-- ------------------ +-- TYPES OF FIELDS -- +-- ------------------ + +instance GToSchemaFieldTypeWrap sch t f + => GToSchemaTypeDef sch fmap ('DSimple t) f where + toSchemaTypeDef _ x = TSimple (toSchemaFieldTypeW x) +instance GFromSchemaFieldTypeWrap sch t f + => GFromSchemaTypeDef sch fmap ('DSimple t) f where + fromSchemaTypeDef _ (TSimple x) = fromSchemaFieldTypeW x + +class GToSchemaFieldTypeWrap + (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where + toSchemaFieldTypeW :: f a -> FieldValue sch t +class GFromSchemaFieldTypeWrap + (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) where + fromSchemaFieldTypeW :: FieldValue sch t -> f a + +instance GToSchemaFieldType sch t f + => GToSchemaFieldTypeWrap sch t (K1 i f) where + toSchemaFieldTypeW (K1 x) = toSchemaFieldType x +instance GFromSchemaFieldType sch t f + => GFromSchemaFieldTypeWrap sch t (K1 i f) where + fromSchemaFieldTypeW x = K1 (fromSchemaFieldType x) +instance GToSchemaFieldTypeWrap sch t f + => GToSchemaFieldTypeWrap sch t (M1 s m f) where + toSchemaFieldTypeW (M1 x) = toSchemaFieldTypeW x +instance GFromSchemaFieldTypeWrap sch t f + => GFromSchemaFieldTypeWrap sch t (M1 s m f) where + fromSchemaFieldTypeW x = M1 (fromSchemaFieldTypeW x) + +class GToSchemaFieldType + (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where + toSchemaFieldType :: f -> FieldValue sch t +class GFromSchemaFieldType + (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where + fromSchemaFieldType :: FieldValue sch t -> f + +class GToSchemaFieldTypeUnion + (sch :: Schema ts fs) (t :: [FieldType ts]) (f :: * -> *) where + toSchemaFieldTypeUnion :: f a -> NS (FieldValue sch) t +class GFromSchemaFieldTypeUnion + (sch :: Schema ts fs) (t :: [FieldType ts]) (f :: * -> *) where + fromSchemaFieldTypeUnion :: NS (FieldValue sch) t -> f a + +-- These instances are straightforward, +-- just turn the "real types" into their +-- schema correspondants. +instance GToSchemaFieldType sch 'TNull () where + toSchemaFieldType _ = FNull +instance GFromSchemaFieldType sch 'TNull () where + fromSchemaFieldType _ = () +instance (UnderlyingConversion t l) + => GToSchemaFieldType sch ('TPrimitive t) (Underlying t l) where + toSchemaFieldType = FPrimitive . toUnderlying . unUnderlying +instance (UnderlyingConversion t l) + => GFromSchemaFieldType sch ('TPrimitive t) (Underlying t l) where + fromSchemaFieldType (FPrimitive x) = Underlying (fromUnderlying x) +instance GToSchemaFieldType sch ('TPrimitive t) t where + toSchemaFieldType = FPrimitive +instance GFromSchemaFieldType sch ('TPrimitive t) t where + fromSchemaFieldType (FPrimitive x) = x +-- 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 ToSchema sch t v + => GToSchemaFieldType sch ('TSchematic t) v where + toSchemaFieldType x = FSchematic $ toSchema x +instance FromSchema sch t v + => GFromSchemaFieldType sch ('TSchematic t) v where + fromSchemaFieldType (FSchematic x) = fromSchema x +instance GToSchemaFieldType sch t v + => GToSchemaFieldType sch ('TOption t) (Maybe v) where + toSchemaFieldType x = FOption (toSchemaFieldType <$> x) +instance GFromSchemaFieldType sch t v + => GFromSchemaFieldType sch ('TOption t) (Maybe v) where + fromSchemaFieldType (FOption x) = fromSchemaFieldType <$> x +instance GToSchemaFieldType sch t v + => GToSchemaFieldType sch ('TList t) [v] where + toSchemaFieldType x = FList (toSchemaFieldType <$> x) +instance GFromSchemaFieldType sch t v + => GFromSchemaFieldType sch ('TList t) [v] where + fromSchemaFieldType (FList x) = fromSchemaFieldType <$> x +instance (GToSchemaFieldType sch sk hk, GToSchemaFieldType sch sv hv, + Ord (FieldValue sch sk)) -- Ord is required to build a map + => GToSchemaFieldType sch ('TMap sk sv) (M.Map hk hv) where + toSchemaFieldType x = FMap (M.mapKeys toSchemaFieldType (M.map toSchemaFieldType x)) +instance (GFromSchemaFieldType sch sk hk, GFromSchemaFieldType sch sv hv, Ord hk) + => GFromSchemaFieldType 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 (GToSchemaFieldType sch) ts vs + => GToSchemaFieldType sch ('TUnion ts) (NS I vs) where + toSchemaFieldType t = FUnion (go t) + where go :: AllZip (GToSchemaFieldType sch) tss vss + => NS I vss -> NS (FieldValue sch) tss + go (Z (I x)) = Z (toSchemaFieldType x) + go (S n) = S (go n) +instance {-# OVERLAPS #-} + AllZip (GFromSchemaFieldType sch) ts vs + => GFromSchemaFieldType sch ('TUnion ts) (NS I vs) where + fromSchemaFieldType (FUnion t) = go t + where go :: AllZip (GFromSchemaFieldType sch) tss vss + => 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, GToSchemaFieldTypeUnion sch ts (Rep f)) + => GToSchemaFieldType sch ('TUnion ts) f where + toSchemaFieldType x = FUnion (toSchemaFieldTypeUnion (from x)) +instance {-# OVERLAPPABLE #-} + (Generic f, GFromSchemaFieldTypeUnion sch ts (Rep f)) + => GFromSchemaFieldType sch ('TUnion ts) f where + fromSchemaFieldType (FUnion x) = to (fromSchemaFieldTypeUnion x) + +instance {-# OVERLAPS #-} GToSchemaFieldTypeUnion sch '[] U1 where + toSchemaFieldTypeUnion U1 = error "this should never happen" +instance {-# OVERLAPS #-} GFromSchemaFieldTypeUnion sch '[] U1 where + fromSchemaFieldTypeUnion _ = U1 +instance {-# OVERLAPS #-} GToSchemaFieldTypeUnion sch '[] (M1 i t U1) where + toSchemaFieldTypeUnion (M1 U1) = error "this should never happen" +instance {-# OVERLAPS #-} GFromSchemaFieldTypeUnion sch '[] (M1 i t U1) where + fromSchemaFieldTypeUnion _ = M1 U1 +instance {-# OVERLAPPABLE #-} + TypeError ('Text "the type does not match the union") + => GToSchemaFieldTypeUnion sch '[] f where + toSchemaFieldTypeUnion = error "this should never happen" +instance {-# OVERLAPPABLE #-} + TypeError ('Text "the type does not match the union") + => GFromSchemaFieldTypeUnion sch '[] f where + fromSchemaFieldTypeUnion = error "this should never happen" + +instance (GToSchemaFieldTypeWrap sch t v) + => GToSchemaFieldTypeUnion sch '[t] v where + toSchemaFieldTypeUnion x = Z (toSchemaFieldTypeW x) +instance (GFromSchemaFieldTypeWrap sch t v) + => GFromSchemaFieldTypeUnion sch '[t] v where + fromSchemaFieldTypeUnion (Z x) = fromSchemaFieldTypeW x + fromSchemaFieldTypeUnion (S _) = error "this should never happen" + +-- remove M1 from thing with more than one element +instance {-# OVERLAPS #-} (GToSchemaFieldTypeUnion sch (a ': b ': rest) v) + => GToSchemaFieldTypeUnion sch (a ': b ': rest) (M1 i t v) where + toSchemaFieldTypeUnion (M1 x) = toSchemaFieldTypeUnion x +instance {-# OVERLAPS #-} (GFromSchemaFieldTypeUnion sch (a ': b ': rest) v) + => GFromSchemaFieldTypeUnion sch (a ': b ': rest) (M1 i t v) where + fromSchemaFieldTypeUnion x = M1 (fromSchemaFieldTypeUnion x) + +instance {-# OVERLAPPABLE #-} (GToSchemaFieldTypeWrap sch t v, GToSchemaFieldTypeUnion sch ts vs) + => GToSchemaFieldTypeUnion sch (t ': ts) (v :+: vs) where + toSchemaFieldTypeUnion (L1 x) = Z (toSchemaFieldTypeW x) + toSchemaFieldTypeUnion (R1 r) = S (toSchemaFieldTypeUnion r) +instance {-# OVERLAPPABLE #-} (GFromSchemaFieldTypeWrap sch t v, GFromSchemaFieldTypeUnion sch ts vs) + => GFromSchemaFieldTypeUnion 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 {-# OVERLAPS #-} ( GToSchemaFieldTypeUnion sch (t ': ts) (v1 :+: (v2 :+: vs)) ) + => GToSchemaFieldTypeUnion sch (t ': ts) ((v1 :+: v2) :+: vs) where + toSchemaFieldTypeUnion (L1 (L1 x)) + = toSchemaFieldTypeUnion @_ @_ @sch @(t ': ts) @(v1 :+: (v2 :+: vs)) (L1 x) + toSchemaFieldTypeUnion (L1 (R1 x)) + = toSchemaFieldTypeUnion @_ @_ @sch @(t ': ts) @(v1 :+: (v2 :+: vs)) (R1 (L1 x)) + toSchemaFieldTypeUnion (R1 r) + = toSchemaFieldTypeUnion @_ @_ @sch @(t ': ts) @(v1 :+: (v2 :+: vs)) (R1 (R1 r)) +instance {-# OVERLAPS #-} ( GFromSchemaFieldTypeUnion sch (t ': ts) (v1 :+: (v2 :+: vs)) ) + => GFromSchemaFieldTypeUnion sch (t ': ts) ((v1 :+: v2) :+: vs) where + fromSchemaFieldTypeUnion t + = case fromSchemaFieldTypeUnion @_ @_ @sch @(t ': ts) @(v1 :+: (v2 :+: vs)) t of + L1 x -> L1 (L1 x) + R1 (L1 x) -> L1 (R1 x) + R1 (R1 x) -> R1 x + +-- --------------- +-- ENUMERATIONS -- +------------------ + +instance {-# OVERLAPPABLE #-} + (GToSchemaEnumDecompose fmap choices f) + => GToSchemaTypeDef sch fmap ('DEnum name choices) f where + toSchemaTypeDef p x = TEnum (toSchemaEnumDecomp p x) +instance {-# OVERLAPPABLE #-} + (GFromSchemaEnumDecompose fmap choices f) + => GFromSchemaTypeDef 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 #-} + GToSchemaTypeDef sch fmap ('DEnum name choices) f + => GToSchemaTypeDef sch fmap ('DEnum name choices) (D1 meta f) where + toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x +instance {-# OVERLAPS #-} + GFromSchemaTypeDef sch fmap ('DEnum name choices) f + => GFromSchemaTypeDef sch fmap ('DEnum name choices) (D1 meta f) where + fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) + +-- 'toSchema' for enumerations: +-- 1. recursively decompose the (:+:)s into their atomic components +-- this is done by 'GToSchemaEnumSymbol' +-- 2. for each atomic component, figure out which is the element +-- in the schema's enumeration that it corresponds to +-- 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 + toSchemaEnumDecomp :: Proxy fmap -> f a -> NS Proxy choices +instance (GToSchemaEnumDecompose fmap choices oneway, GToSchemaEnumDecompose fmap choices oranother) + => GToSchemaEnumDecompose fmap choices (oneway :+: oranother) where + toSchemaEnumDecomp p (L1 x) = toSchemaEnumDecomp p x + toSchemaEnumDecomp p (R1 x) = toSchemaEnumDecomp p x +instance GToSchemaEnumProxy choices (FindEnumChoice choices (MappingRight fmap c)) + => GToSchemaEnumDecompose fmap choices (C1 ('MetaCons c p s) f) where + toSchemaEnumDecomp _ _ + = toSchemaEnumProxy (Proxy @choices) (Proxy @(FindEnumChoice choices (MappingRight fmap c))) +-- Types which have no constructor information cannot be used here + +class GToSchemaEnumProxy (choices :: [k]) (w :: Where) where + toSchemaEnumProxy :: Proxy choices -> Proxy w -> NS Proxy choices +instance GToSchemaEnumProxy (c ': cs) 'Here where + toSchemaEnumProxy _ _ = Z Proxy +instance forall c cs w. GToSchemaEnumProxy cs w + => GToSchemaEnumProxy (c ': cs) ('There w) where + toSchemaEnumProxy _ _ = S (toSchemaEnumProxy (Proxy @cs) (Proxy @w)) + +-- 'fromSchema' for enumerations: +-- 1. for each element in the list of choices +-- (this iteration is done by 'GFromSchemaEnumDecomp') +-- figure out the constructor it corresponds to +-- this is done by 'MappingLeft' and 'FindCon' +-- 2. from that location, build a 'U1' value wrapped +-- in as many 'L1' and 'R1' required. +-- this is done by 'GFromSchemaEnumU1' +class GFromSchemaEnumDecompose (fmap :: Mappings Symbol fs) (choices :: [ChoiceDef fs]) (f :: * -> *) where + fromSchemaEnumDecomp :: Proxy fmap -> NS Proxy choices -> f a +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 ': cs) f where + fromSchemaEnumDecomp _ (Z _) = fromSchemaEnumU1 (Proxy @f) (Proxy @(FindCon f (MappingLeft fmap c))) + fromSchemaEnumDecomp p (S x) = fromSchemaEnumDecomp p x + +class GFromSchemaEnumU1 (f :: * -> *) (w :: [WhereStep]) where + fromSchemaEnumU1 :: Proxy f -> Proxy w -> f a +instance GFromSchemaEnumU1 (C1 m U1) '[ 'StepNoMore ] where + fromSchemaEnumU1 _ _ = M1 U1 +instance GFromSchemaEnumU1 left rest => GFromSchemaEnumU1 (left :+: right) ('StepLeft ': rest) where + fromSchemaEnumU1 _ _ = L1 (fromSchemaEnumU1 (Proxy @left) (Proxy @rest)) +instance GFromSchemaEnumU1 right rest => GFromSchemaEnumU1 (left :+: right) ('StepRight ': rest) where + fromSchemaEnumU1 _ _ = R1 (fromSchemaEnumU1 (Proxy @right) (Proxy @rest)) + +-- ---------- +-- RECORDS -- +------------- + +instance {-# OVERLAPPABLE #-} + (GToSchemaRecord sch fmap args f) + => GToSchemaTypeDef sch fmap ('DRecord name args) f where + toSchemaTypeDef p x = TRecord (toSchemaRecord p x) +instance {-# OVERLAPPABLE #-} + (GFromSchemaRecord sch fmap args f) + => GFromSchemaTypeDef 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 #-} + GToSchemaTypeDef sch fmap ('DRecord name args) f + => GToSchemaTypeDef sch fmap ('DRecord name args) (D1 meta f) where + toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x +instance {-# OVERLAPS #-} + GFromSchemaTypeDef sch fmap ('DRecord name args) f + => GFromSchemaTypeDef sch fmap ('DRecord name args) (D1 meta f) where + fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) +instance {-# OVERLAPS #-} + GToSchemaTypeDef sch fmap ('DRecord name args) f + => GToSchemaTypeDef sch fmap ('DRecord name args) (C1 meta f) where + toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x +instance {-# OVERLAPS #-} + GFromSchemaTypeDef sch fmap ('DRecord name args) f + => GFromSchemaTypeDef sch fmap ('DRecord name args) (C1 meta f) where + fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) + +-- 'toSchema' for records: +-- 1. iterate over each field in the schema of the record +-- this is done by 'GToSchemaRecord' +-- 2. figure out the selector (field) in the Haskell type +-- to which that record corresponds to +-- this is done by 'MappingLeft' and 'FindSel' +-- 3. using that location, obtain the value of the field +-- this is done by 'GToSchemaRecordSearch' +-- +-- 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) + +-- | For internal use only: generic conversion of a list of fields. +class GToSchemaRecord (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 _ _ = 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 + 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 :: * -> *) (wh :: [WhereStep]) where + toSchemaRecordSearch :: Proxy wh -> f a -> FieldValue sch t +instance GToSchemaFieldType sch t v + => GToSchemaRecordSearch sch t (S1 m (K1 i v)) '[ 'StepNoMore ] where + toSchemaRecordSearch _ (M1 (K1 x)) = toSchemaFieldType x +instance forall sch t left right n. + GToSchemaRecordSearch sch t left n + => GToSchemaRecordSearch sch t (left :*: right) ('StepLeft ': n) where + toSchemaRecordSearch _ (xs :*: _) = toSchemaRecordSearch (Proxy @n) xs +instance forall sch t left right n. + GToSchemaRecordSearch sch t right n + => GToSchemaRecordSearch sch t (left :*: right) ('StepRight ': n) where + toSchemaRecordSearch _ (_ :*: xs) = toSchemaRecordSearch (Proxy @n) xs + +-- 'fromSchema' for records +-- 1. decompose the sequence of products into atomic components +-- until we arrive to the selector metadata 'S1' +-- this is done by 'GFromSchemaRecord' +-- 2. figure out the field in the schema it corresponds to +-- 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) + (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 _ 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 + fromSchemaRecord _ _ = U1 + +class GFromSchemaRecordSearch (sch :: Schema ts fs) + (v :: *) (args :: [FieldDef ts fs]) (wh :: Where) where + fromSchemaRecordSearch :: Proxy wh -> NP (Field sch) args -> v +instance (GFromSchemaFieldType 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 + fromSchemaRecordSearch _ (_ :* xs) = fromSchemaRecordSearch (Proxy @n) xs diff --git a/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs b/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs similarity index 57% rename from schema/src/Mu/Schema/Conversion/SchemaToTypes.hs rename to core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs index ea0b5243..51e94d6d 100644 --- a/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs +++ b/core/schema/src/Mu/Schema/Conversion/SchemaToTypes.hs @@ -1,20 +1,28 @@ -{-# language CPP, TemplateHaskell, TypeOperators, DataKinds #-} --- | Generate a set of Haskell types from a 'Schema'. +{-# language CPP #-} +{-# language DataKinds #-} +{-# language TemplateHaskell #-} +{-# language TypeOperators #-} +{-| +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 ) 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.Definition -- | Generate the name from each new Haskell type -- from the name given in the schema. @@ -40,79 +48,99 @@ 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 []) (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]) + pure [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 []) (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) + pure [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 []) (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] + | ChoiceDef choicename <- choices] + [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) + pure [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 -fieldMapping complete (FieldDef name _ _ : rest) +fieldMapping complete (FieldDef name _ : rest) = AppT (AppT PromotedConsT thisMapping) (fieldMapping complete rest) where thisMapping = AppT (AppT (PromotedT '(:->)) @@ -121,12 +149,13 @@ 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 '(:->)) (LitT (StrTyLit (choiceName complete name)))) (LitT (StrTyLit name)) +-} -- Name manipulation -- ================= @@ -141,33 +170,33 @@ 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 -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 -- ======= @@ -180,20 +209,18 @@ 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 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 @@ -201,15 +228,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 @@ -264,9 +290,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 \ No newline at end of file +tyD3 _ _ = Nothing +-} diff --git a/schema/src/Mu/Schema/Conversion/TypesToSchema.hs b/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs similarity index 71% rename from schema/src/Mu/Schema/Conversion/TypesToSchema.hs rename to core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs index 6740d925..fd4aa763 100644 --- a/schema/src/Mu/Schema/Conversion/TypesToSchema.hs +++ b/core/schema/src/Mu/Schema/Conversion/TypesToSchema.hs @@ -1,30 +1,41 @@ -{-# language PolyKinds, DataKinds, TypeFamilies, - TypeOperators, - 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. +{-# language DataKinds #-} +{-# language PolyKinds #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +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 -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] +-- | 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. @@ -42,8 +53,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 @@ -56,7 +67,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") @@ -97,8 +108,8 @@ 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 - = 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/schema/src/Mu/Schema/Definition.hs b/core/schema/src/Mu/Schema/Definition.hs similarity index 56% rename from schema/src/Mu/Schema/Definition.hs rename to core/schema/src/Mu/Schema/Definition.hs index 53699b49..678ecfca 100644 --- a/schema/src/Mu/Schema/Definition.hs +++ b/core/schema/src/Mu/Schema/Definition.hs @@ -1,14 +1,54 @@ -{-# language PolyKinds, DataKinds, - TypeFamilies, TypeOperators, - UndecidableInstances, FlexibleInstances, - ScopedTypeVariables, TypeApplications #-} --- | Schema definition -module Mu.Schema.Definition where - -import Data.Kind -import Data.Proxy -import Data.Typeable -import GHC.TypeLits +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +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 +import Data.Typeable +import GHC.TypeLits -- | A set of type definitions, -- where the names of types and fields are @@ -33,56 +73,83 @@ 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] --- | 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, -- * 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 [Annotation] [FieldDefB builtin typeName fieldName] - | DEnum typeName [Annotation] [ChoiceDef 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. -data ChoiceDef fieldName - = ChoiceDef fieldName [Annotation] +newtype 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 [Annotation] (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] +instance KnownName n => KnownName ('DRecord n fields) where + nameVal _ = nameVal (Proxy @n) +instance KnownName n => KnownName ('DEnum n choices) where + nameVal _ = nameVal (Proxy @n) +instance KnownName n => KnownName ('ChoiceDef n) where + nameVal _ = nameVal (Proxy @n) +instance KnownName n => KnownName ('FieldDef n t) where + nameVal _ = nameVal (Proxy @n) + -- | 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 @@ -92,8 +159,11 @@ type Mappings a b = [Mapping a b] -- | Finds the corresponding right value of @v@ -- in a mapping @ms@. When the kinds are 'Symbol', -- return the same value if not found. +-- When the return type is 'Type', return ' ()' +-- if the value is not found. type family MappingRight (ms :: Mappings a b) (v :: a) :: b where - MappingRight '[] (v :: Symbol) = v + MappingRight '[] (v :: Symbol) = (v :: Symbol) + MappingRight '[] (v :: Symbol) = (() :: Type) MappingRight '[] v = TypeError ('Text "Cannot find value " ':<>: 'ShowType v) MappingRight ((x ':-> y) ': rest) x = y MappingRight (other ': rest) x = MappingRight rest x @@ -101,24 +171,27 @@ type family MappingRight (ms :: Mappings a b) (v :: a) :: b where -- | Finds the corresponding left value of @v@ -- in a mapping @ms@. When the kinds are 'Symbol', -- return the same value if not found. +-- When the return type is 'Type', return ' ()' +-- if the value is not found. type family MappingLeft (ms :: Mappings a b) (v :: b) :: a where - MappingLeft '[] (v :: Symbol) = v + MappingLeft '[] (v :: Symbol) = (v :: Symbol) + MappingLeft '[] (v :: Symbol) = (() :: Type) MappingLeft '[] v = TypeError ('Text "Cannot find value " ':<>: 'ShowType v) 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 _ = [] 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 @@ -126,24 +199,27 @@ 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 _ = [] 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 + -- | Reflect a list of enumeration choices into term-level. reflectChoices :: Proxy cs -> [ChoiceDef String] 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 + -- | Reflect a schema type into term-level. reflectFieldType :: Proxy ty -> FieldTypeB TypeRep String instance ReflectFieldType 'TNull where reflectFieldType _ = TNull @@ -162,9 +238,10 @@ 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 _ = [] 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 new file mode 100644 index 00000000..b2f9ccca --- /dev/null +++ b/core/schema/src/Mu/Schema/Examples.hs @@ -0,0 +1,145 @@ +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingVia #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language QuasiQuotes #-} +{-# language StandaloneDeriving #-} +{-# language TemplateHaskell #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +Description : Examples for schema definitions. + +Look at the source code of this module. +-} +module Mu.Schema.Examples where + +import qualified Data.Aeson as J +import qualified Data.Map as M +import qualified Data.Text as T +import GHC.Generics + +import Mu.Adapter.Json () +import Mu.Schema +import Mu.Schema.Conversion.SchemaToTypes + +data Person + = Person { firstName :: T.Text + , lastName :: T.Text + , age :: Maybe Int + , gender :: Gender + , address :: Address + , lucky_numbers :: [Int] + , things :: M.Map T.Text Int } + deriving (Eq, Show, Generic) + deriving (ToSchema ExampleSchema "person", FromSchema ExampleSchema "person") + deriving (J.ToJSON, J.FromJSON) + via (WithSchema ExampleSchema "person" Person) + +data Address + = Address { postcode :: T.Text + , country :: T.Text } + deriving (Eq, Show, Generic) + deriving (ToSchema ExampleSchema "address", FromSchema ExampleSchema "address") + deriving (J.ToJSON, J.FromJSON) + via (WithSchema ExampleSchema "address" Address) + +type GenderFieldMapping + = '[ "Male" ':-> "male" + , "Female" ':-> "female" + , "NonBinary" ':-> "nb" + , "Gender0" ':-> "gender0" + , "Gender1" ':-> "gender1" + , "Gender2" ':-> "gender2" + , "Gender3" ':-> "gender3" + , "Gender4" ':-> "gender4" + , "Gender5" ':-> "gender5" + , "Gender6" ':-> "gender6" + , "Gender7" ':-> "gender7" + , "Gender8" ':-> "gender8" + , "Gender9" ':-> "gender9" + , "Unspecified" ':-> "unspecified"] + +data Gender + = Male + | Female + | NonBinary + | Gender0 + | Gender1 + | Gender2 + | Gender3 + | Gender4 + | Gender5 + | Gender6 + | Gender7 + | Gender8 + | Gender9 + | Unspecified + deriving (Eq, Show, Generic) + deriving (ToSchema ExampleSchema "gender", FromSchema ExampleSchema "gender") + via (CustomFieldMapping "gender" GenderFieldMapping Gender) + deriving (J.ToJSON, J.FromJSON) + via (WithSchema ExampleSchema "gender" Gender) + +-- Schema for these data types +type ExampleSchema + = '[ 'DEnum "gender" + '[ 'ChoiceDef "male" + , 'ChoiceDef "female" + , 'ChoiceDef "nb" + , 'ChoiceDef "gender0" + , 'ChoiceDef "gender1" + , 'ChoiceDef "gender2" + , 'ChoiceDef "gender3" + , 'ChoiceDef "gender4" + , 'ChoiceDef "gender5" + , 'ChoiceDef "gender6" + , 'ChoiceDef "gender7" + , 'ChoiceDef "gender8" + , 'ChoiceDef "gender9" + , 'ChoiceDef "unspecified" ] + , '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" ('TSchematic "gender") + , 'FieldDef "address" ('TSchematic "address") + , 'FieldDef "lucky_numbers" ('TList ('TPrimitive Int)) + , 'FieldDef "things" ('TMap ('TPrimitive T.Text) ('TPrimitive Int)) ] + ] + +$(generateTypesFromSchema (++"Msg") ''ExampleSchema) + +{- +type ExampleSchema2 + = SchemaFromTypes '[ AsRecord Person "person" + , AsRecord Address "address" + , AsEnum Gender "gender" ] +-} +type ExampleSchema2 + = '[ '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 + = '[ 2 ':-> ExampleSchema2, 1 ':-> ExampleSchema] diff --git a/schema/src/Mu/Schema/Interpretation.hs b/core/schema/src/Mu/Schema/Interpretation.hs similarity index 69% rename from schema/src/Mu/Schema/Interpretation.hs rename to core/schema/src/Mu/Schema/Interpretation.hs index f4de32f4..af28f5f2 100644 --- a/schema/src/Mu/Schema/Interpretation.hs +++ b/core/schema/src/Mu/Schema/Interpretation.hs @@ -1,42 +1,76 @@ -{-# language PolyKinds, DataKinds, GADTs, - TypeFamilies, TypeOperators, - FlexibleInstances, FlexibleContexts, - TypeApplications, ScopedTypeVariables, - UndecidableInstances #-} --- | Interpretation of schemas +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language QuantifiedConstraints #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +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@. + +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(..) ) 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 - TRecord :: NP (Field sch) args -> Term sch ('DRecord name anns args) - TEnum :: NS Proxy choices -> Term sch ('DEnum name anns choices) + -- | A record given by the value of its fields. + TRecord :: NP (Field sch) args -> Term sch ('DRecord name args) + -- | An enumeration given by one choice. + TEnum :: NS Proxy choices -> Term sch ('DEnum name choices) + -- | A primitive value. 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) + -- | A single field. Note that the contents are wrapped in a @w@ type constructor. + 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 + -- | Null value, as found in Avro and JSON. FNull :: FieldValue sch 'TNull + -- | Value of a primitive type. FPrimitive :: t -> FieldValue sch ('TPrimitive t) + -- | Term of another type in the schema. FSchematic :: Term sch (sch :/: t) -> FieldValue sch ('TSchematic t) + -- | Optional value. FOption :: Maybe (FieldValue sch t) -> FieldValue sch ('TOption t) + -- | List of values. FList :: [FieldValue sch t] -> FieldValue sch ('TList t) - FMap :: Map (FieldValue sch k) (FieldValue sch v) + -- | Dictionary (key-value map) of values. + FMap :: Ord (FieldValue sch k) + => Map (FieldValue sch k) (FieldValue sch v) -> FieldValue sch ('TMap k v) + -- | One single value of one of the specified types. FUnion :: NS (FieldValue sch) choices -> FieldValue sch ('TUnion choices) @@ -45,20 +79,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 @@ -68,10 +102,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 new file mode 100644 index 00000000..d7ce9ade --- /dev/null +++ b/core/schema/src/Mu/Schema/Interpretation/Anonymous.hs @@ -0,0 +1,101 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# 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 sch sty where + 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 '[]) + => ToSchema sch sty (V0 sch sty) where + toSchema V0 = TRecord Nil +instance (sch :/: sty ~ 'DRecord nm '[]) + => FromSchema sch sty (V0 sch sty) where + fromSchema (TRecord Nil) = V0 + +-- | Anonymous term for a record with one field. +data V1 sch sty where + V1 :: (sch :/: sty + ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ]) + => a -> V1 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) + +instance ( sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ] ) + => ToSchema sch sty (V1 sch sty) where + toSchema (V1 x) = TRecord (Field (FPrimitive x) :* Nil) +instance ( sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) ] ) + => FromSchema sch sty (V1 sch sty) where + fromSchema (TRecord (Field x :* Nil)) = V1 (unPrimitive x) + where unPrimitive :: FieldValue sch ('TPrimitive t) -> t + unPrimitive (FPrimitive l) = l + +-- | Anonymous term for a record with two fields. +data V2 sch sty where + V2 :: (sch :/: sty + ~ '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 '[ 'FieldDef f ('TPrimitive a) + , 'FieldDef g ('TPrimitive b) ]) + => Show (V2 sch sty) +deriving instance (Eq a, Eq 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 '[ 'FieldDef f ('TPrimitive a) + , 'FieldDef g ('TPrimitive b) ]) + => Ord (V2 sch sty) + +instance ( sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) + , 'FieldDef g ('TPrimitive b) ] ) + => ToSchema sch sty (V2 sch sty) where + toSchema (V2 x y) = TRecord (Field (FPrimitive x) :* Field (FPrimitive y) :* Nil) +instance ( sch :/: sty ~ 'DRecord nm '[ 'FieldDef f ('TPrimitive a) + , 'FieldDef g ('TPrimitive b) ] ) + => FromSchema sch sty (V2 sch sty) where + fromSchema (TRecord (Field x :* Field y :* Nil)) = V2 (unPrimitive x) (unPrimitive y) + where unPrimitive :: FieldValue sch ('TPrimitive t) -> t + unPrimitive (FPrimitive l) = l diff --git a/schema/src/Mu/Schema/Interpretation/Schemaless.hs b/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs similarity index 68% rename from schema/src/Mu/Schema/Interpretation/Schemaless.hs rename to core/schema/src/Mu/Schema/Interpretation/Schemaless.hs index 6e5ef427..cfc62d7e 100644 --- a/schema/src/Mu/Schema/Interpretation/Schemaless.hs +++ b/core/schema/src/Mu/Schema/Interpretation/Schemaless.hs @@ -1,41 +1,68 @@ -{-# 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 #-} +{-| +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 ((<|>)) -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. data Term where + -- | A record given by the value of its fields. TRecord :: [Field] -> Term + -- | An enumeration given by one choice. TEnum :: Int -> Term + -- | A primitive value. TSimple :: FieldValue -> Term - deriving (Eq, Ord, Show) + +deriving instance Eq Term +deriving instance Ord Term +deriving instance Show Term -- | Interpretation of a field. data Field where + -- | A single field given by its name and its value. Field :: T.Text -> FieldValue -> Field - deriving (Eq, Ord, Show) + +deriving instance Eq Field +deriving instance Ord Field +deriving instance Show Field -- | Interpretation of a field type, by giving a value of that type. data FieldValue where @@ -46,23 +73,43 @@ data FieldValue where FList :: [FieldValue] -> FieldValue FMap :: M.Map FieldValue FieldValue -> FieldValue +-- | 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). - CheckSchema s (s :/: t) + :: forall tn fn (s :: Schema tn fn) (t :: tn). + (CheckSchema s (s :/: t)) => Proxy t -> Term -> Maybe (S.Term s (s :/: t)) checkSchema _ = checkSchema' +-- | Converts a schemaless term to a Haskell type +-- by going through the corresponding schema type. fromSchemalessTerm :: forall sch t sty. - (HasSchema sch sty t, CheckSchema sch (sch :/: sty)) + (FromSchema sch sty t, CheckSchema sch (sch :/: sty)) => Term -> Maybe t fromSchemalessTerm t = fromSchema @_ @_ @sch <$> checkSchema (Proxy @sty) t +-- | Deserialization to schemaless terms. class ToSchemalessTerm t 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 +-- | Deserialization to schemaless values. class ToSchemalessValue t where + -- | Turns a document (such as JSON) into a schemaless term. + -- This function should handle the "primitive" types in that format. toSchemalessValue :: t -> FieldValue +-- | 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' :: Term -> Maybe (S.Term s t) class CheckSchemaFields (s :: Schema tn fn) (fields :: [FieldDef tn fn]) where @@ -75,34 +122,34 @@ 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 + 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 v' <- checkSchemaValue v r' <- checkSchemaFields @_ @_ @s @rest fs - return (S.Field v' :* r') + pure (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 (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 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 @@ -125,7 +172,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 +231,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 new file mode 100644 index 00000000..beb60d0d --- /dev/null +++ b/core/schema/src/Mu/Schema/Registry.hs @@ -0,0 +1,68 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# 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 + -- * Terms without an associated schema +, SLess.Term(..), SLess.Field(..), SLess.FieldValue(..) +) where + +import Control.Applicative +import Data.Kind +import Data.Proxy +import GHC.TypeLits + +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. FromRegistry r t + => SLess.Term -> Maybe t +fromRegistry = fromRegistry' (Proxy @r) + +class FromRegistry (ms :: Registry) (t :: Type) where + fromRegistry' :: Proxy ms -> SLess.Term -> Maybe t + +instance FromRegistry '[] t where + fromRegistry' _ _ = Nothing +instance ( Traversable w, FromSchema 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 diff --git a/default.nix b/default.nix new file mode 100644 index 00000000..40f861a4 --- /dev/null +++ b/default.nix @@ -0,0 +1,45 @@ +let + haskellNix = import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/e7961ee.tar.gz) {}; + nixpkgsSrc = haskellNix.sources.nixpkgs-2003; + nixpkgsArgs = haskellNix.nixpkgsArgs; +in +{ pkgs ? import nixpkgsSrc nixpkgsArgs +}: +let + gitignoreSrc = pkgs.fetchFromGitHub { + owner = "hercules-ci"; + repo = "gitignore"; + rev = "c4662e6"; + sha256 = "sha256:1npnx0h6bd0d7ql93ka7azhj40zgjp815fw2r6smg8ch9p7mzdlx"; + }; + inherit (import gitignoreSrc { inherit (pkgs) lib; }) gitignoreSource; + hnPkgs = pkgs.haskell-nix.stackProject { + src = pkgs.haskell-nix.haskellLib.cleanGit { + name = "mu-haskell"; + src = gitignoreSource ./.; + }; + }; +in { + compendium-client = hnPkgs.compendium-client.components.library; + mu-avro = hnPkgs.mu-avro.components.library; + mu-example-health-check = hnPkgs.mu-example-health-check.components.exes; + mu-example-library = hnPkgs.mu-example-library.components.exes; + mu-example-route-guide = hnPkgs.mu-example-route-guide.components.exes; + mu-example-seed = hnPkgs.mu-example-seed.components.exes; + mu-example-todolist = hnPkgs.mu-example-todolist.components.exes; + mu-example-with-persistent = hnPkgs.mu-example-with-persistent.components.exes; + mu-graphql = hnPkgs.mu-graphql.components.library; + mu-grpc-client = hnPkgs.mu-grpc-client.components.library; + mu-grpc-common = hnPkgs.mu-grpc-common.components.library; + mu-grpc-server = hnPkgs.mu-grpc-server.components.library; + mu-kafka = hnPkgs.mu-kafka.components.library; + mu-lens = hnPkgs.mu-lens.components.library; + mu-optics = hnPkgs.mu-optics.components.library; + mu-persistent = hnPkgs.mu-persistent.components.library; + mu-prometheus = hnPkgs.mu-prometheus.components.library; + mu-protobuf = hnPkgs.mu-protobuf.components.library; + mu-rpc = hnPkgs.mu-rpc.components.library; + mu-schema = hnPkgs.mu-schema.components.library; + mu-servant-server = hnPkgs.mu-servant-server.components.library; + mu-tracing = hnPkgs.mu-tracing.components.library; +} 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 100644 index 00000000..5ea0e297 --- /dev/null +++ b/docs/Gemfile.lock @@ -0,0 +1,67 @@ +GEM + remote: https://rubygems.org/ + specs: + addressable (2.8.0) + public_suffix (>= 2.0.2, < 5.0) + colorator (1.1.0) + concurrent-ruby (1.1.8) + em-websocket (0.5.2) + eventmachine (>= 0.12.9) + http_parser.rb (~> 0.6.0) + eventmachine (1.2.7) + ffi (1.15.0) + forwardable-extended (2.6.0) + http_parser.rb (0.6.0) + i18n (1.8.10) + concurrent-ruby (~> 1.0) + jekyll (4.2.0) + addressable (~> 2.4) + colorator (~> 1.0) + em-websocket (~> 0.5) + i18n (~> 1.0) + jekyll-sass-converter (~> 2.0) + jekyll-watch (~> 2.0) + kramdown (~> 2.3) + kramdown-parser-gfm (~> 1.0) + liquid (~> 4.0) + mercenary (~> 0.4.0) + pathutil (~> 0.9) + rouge (~> 3.0) + safe_yaml (~> 1.0) + terminal-table (~> 2.0) + jekyll-sass-converter (2.1.0) + sassc (> 2.0.1, < 3.0) + jekyll-watch (2.2.1) + listen (~> 3.0) + kramdown (2.3.1) + rexml + kramdown-parser-gfm (1.1.0) + kramdown (~> 2.0) + liquid (4.0.3) + listen (3.5.1) + rb-fsevent (~> 0.10, >= 0.10.3) + rb-inotify (~> 0.9, >= 0.9.10) + mercenary (0.4.0) + pathutil (0.16.2) + forwardable-extended (~> 2.6) + public_suffix (4.0.6) + rb-fsevent (0.10.4) + rb-inotify (0.10.1) + ffi (~> 1.0) + rexml (3.2.5) + rouge (3.26.0) + safe_yaml (1.0.5) + sassc (2.4.0) + ffi (~> 1.9) + terminal-table (2.0.0) + unicode-display_width (~> 1.1, >= 1.1.1) + unicode-display_width (1.7.0) + +PLATFORMS + ruby + +DEPENDENCIES + jekyll (>= 4.0.0) + +BUNDLED WITH + 2.1.2 diff --git a/docs/README.md b/docs/README.md new file mode 100644 index 00000000..43502a87 --- /dev/null +++ b/docs/README.md @@ -0,0 +1,29 @@ +# Docs for Mu-Haskell + +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..133b9c69 --- /dev/null +++ b/docs/_config.yml @@ -0,0 +1,25 @@ +#------------------------- +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 +#------------------------- +github-owner: higherkindness +github-repo: mu-haskell +#------------------------- +url: https://higherkindess.io/mu-haskell +#------------------------- +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..02888442 --- /dev/null +++ b/docs/_data/sidebar.yml @@ -0,0 +1,52 @@ +options: + - title: Start + url: / + + - title: Introduction + nested_options: + - title: For RPC + url: intro-rpc/ + + - title: For GraphQL + url: intro-graphql/ + + - title: Schemas + url: schema/ + nested_options: + - title: Serialization formats + url: serializers/ + + - title: Registry + url: registry/ + + - title: Mu-Optics + url: optics/ + + - title: Services + url: rpc/ + nested_options: + - title: gRPC servers + url: grpc/server/ + + - title: gRPC clients + url: grpc/client/ + + - title: GraphQL + url: graphql/ + + - title: OpenAPI / REST + url: openapi/ + + - title: Integrations + nested_options: + - title: Databases + url: db/ + + - title: Transformers + url: transformer/ + + - title: Middleware + url: middleware/ + + - title: Talks + url: talks/ diff --git a/docs/_data/versions.yml b/docs/_data/versions.yml new file mode 100644 index 00000000..fd6b469e --- /dev/null +++ b/docs/_data/versions.yml @@ -0,0 +1,9 @@ +- name: Version + links: + stable: https://higherkindness.io/mu-haskell/ + next: https://higherkindness.io/mu-haskell/wip + +- name: API Docs + links: + stable: https://higherkindness.io/mu-haskell/haddock + next: https://higherkindness.io/mu-haskell/wip/haddock diff --git a/docs/_includes/_doc.html b/docs/_includes/_doc.html new file mode 100644 index 00000000..66d3fa88 --- /dev/null +++ b/docs/_includes/_doc.html @@ -0,0 +1,27 @@ +
+
+ + +
+ {% for item in site.data.versions %} + {% include _dropdown.html item=item %} + {% endfor %} +
+ + GitHub + + +
+
+ +
+
+ {{ content }} +
+
diff --git a/docs/_includes/_dropdown.html b/docs/_includes/_dropdown.html new file mode 100644 index 00000000..0726f4da --- /dev/null +++ b/docs/_includes/_dropdown.html @@ -0,0 +1,24 @@ + diff --git a/docs/_includes/_head-docs.html b/docs/_includes/_head-docs.html new file mode 100644 index 00000000..34501e2f --- /dev/null +++ b/docs/_includes/_head-docs.html @@ -0,0 +1,38 @@ + + + + {% if page.title %} + {% assign pageTitle = site.title | append: ': ' | append: page.title %} + {% else %} + {% assign pageTitle = site.title %} + {% endif %} + + {{ pageTitle }} + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/docs/_includes/_sidebar.html b/docs/_includes/_sidebar.html new file mode 100755 index 00000000..8c498a45 --- /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..e417a6bd --- /dev/null +++ b/docs/_sass/base/_base.scss @@ -0,0 +1,65 @@ +// 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; + position: relative; +} + +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: $link-hover; + } +} + +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..2dfa5d95 --- /dev/null +++ b/docs/_sass/components/_button.scss @@ -0,0 +1,72 @@ +// Buttons +// ---------------------------------------------- +// ---------------------------------------------- +.button { + font-family: $base-font-family; + display: block; + background: none; + border: none; + outline: none; + text-decoration: none; + + &:hover { + cursor: pointer; + } + + > img { + vertical-align: bottom; + } + + &.link-like { + font-size: 1rem; + color: $link-color; + font-weight: $font-regular; + border: none; + padding: 0 0 ($base-point-grid / 2) 0; + margin: + 0 + ($base-point-grid * 2) + -5px + 0; + text-transform: none; + + &:hover, + &:active, + &:focus { + text-decoration: none; + box-shadow: 0 2px; + background: none; + + &::after { + background-position-y: 60%; + } + } + } +} + +.close { + height: 28px; + position: absolute; + left: 0; + top: 0; + width: 32px; + + &::before, + &::after { + background-color: $white; + content: " "; + height: 100%; + left: 98%; + position: absolute; + top: 36%; + 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..28aa5d3f --- /dev/null +++ b/docs/_sass/components/_doc.scss @@ -0,0 +1,156 @@ +// 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); + } + } + + .link-container { + display: flex; + height: 100%; + width: 100%; + justify-content: flex-end; + align-items: center; + + .strong { + font-weight: 600; + } + + .link-item { + margin-left: ($base-point-grid * 2); + + a:hover { + text-decoration: none; + } + } + } + } + + .doc-content { + padding: ($base-point-grid * 4); + } + + 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; + } + + ol, ul { + padding-left: ($base-point-grid * 4); + margin-bottom: ($base-point-grid * 2); + } + + ol li { + list-style: decimal; + } + + ul li { + list-style: disc; + } + + .header-link { + position: absolute; + font-size: 0.6em; + left: -2em; + top: -0.15em; + opacity: 0; + padding: 0.8em; + outline: none; + transform: rotate3d(0, 0, 1, 45deg) scale3d(0.5, 0.5, 0.5); + transition: opacity 0.2s ease, transform 0.2s ease; + + &:hover, + &:focus, + &:active { + text-decoration: none; + } + } + + h1:hover, + h2:hover, + h3:hover, + h4:hover, + h5:hover, + h6:hover { + .header-link { + opacity: 1; + transform: rotate3d(0, 0, 1, 45deg) scale3d(1, 1, 1); + } + } +} + +// Responsive +// ----------------------------------------------- +@include bp(medium) { + .site-doc { + left: 0; + + &.expanded { + overflow: hidden; + } + } +} diff --git a/docs/_sass/components/_dropdown.scss b/docs/_sass/components/_dropdown.scss new file mode 100644 index 00000000..10fba334 --- /dev/null +++ b/docs/_sass/components/_dropdown.scss @@ -0,0 +1,79 @@ +div[id$='-dropdown'] { + position: relative; + + .dropdown { + display: block; + outline: 0; + width: 100%; + + a { + &:hover { + background: lighten($gray-primary, 10%); + } + } + } + + .link-like::after { + content: ""; + position: absolute; + left: 0; + top: 0; + height: 150%; + width: 100%; + background-image: url("../img/arrow-down.svg"); + background-repeat: no-repeat; + background-position-x: 100%; + background-position-y: 25%; + background-size: 0.8em; + transition: background-position 0.1s ease; + + &:hover, + &:active, + &:focus { + &::after { + background-position-y: 60%; + } + } + } + + ul { + list-style: none; + padding-left: 0; + } + + /* Documentation Dropdown Content (Hidden by Default) */ + .dropdown-content { + font-size: 0.8rem; + position: absolute; + overflow: auto; + box-shadow: 0 8px 16px 0 rgba(0, 0, 0, 0.2); + z-index: 1; + background: lighten($gray-primary, 5%); + opacity: 0.5; + transform: rotate3d(1, 0, 0, 90deg); + transition: transform ease 250ms, opacity ease 100ms; + transform-origin: top; + margin-top: 6px; + text-align: center; + + .dropdown-item { + width: 100%; + + .dropdown-item-link { + padding: 12px 9px; + text-decoration: none; + display: block; + border-radius: 0; + color: $white; + } + } + } + + /* Show the documentation dropdown menu (use JS to add this class + to the .dropdown-content container when the user clicks on + the dropdown button) */ + .show { + transform: rotate3d(1, 0, 0, 0); + opacity: 1; + } +} 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..5741f14d --- /dev/null +++ b/docs/_sass/components/_sidebar-menu.scss @@ -0,0 +1,108 @@ +// 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 $brand-primary 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; + transform-origin: 0% 75%; + height: 8px; + transition: transform 0.2s ease; + } + + .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; + } + + .caret::after { + content: ''; + position: absolute; + left: 0; + top: 2px; + border-left: 4px solid $gray-primary; + border-top: 4px solid transparent; + border-bottom: 4px solid transparent; + } + + &.active { + > a, button { + box-shadow: 3px 0 $brand-primary inset; + } + } + + &.open { + > a, button { + background: $sidebar-head-active-color; + } + + .caret { + transform: rotateZ(90deg); + } + + .caret::after { + border-left-color: $sidebar-head-active-color; + } + + .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..5ea86b19 --- /dev/null +++ b/docs/_sass/components/_sidebar.scss @@ -0,0 +1,91 @@ +// Sidebar +// ----------------------------------------------- +// ----------------------------------------------- + +.site-sidebar { + position: fixed; + background-image: linear-gradient(to bottom, $brand-secondary 60%, darken($brand-secondary, 3%) 100%); + border-right: 1px solid rgba(0,0,0,0.1); + 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; + align-items: center; + width: 100%; + transition: none; + + &: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: $font-semibold; + } + } + } + + .sidebar-toggle { + display: none; + } +} + +// Responsive +// ----------------------------------------------- +@include bp(medium) { + + .site-sidebar { + left: -100%; + width: 100%; + + &.toggled { + left: 0; + overflow-y: auto; + } + + .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..fa362199 --- /dev/null +++ b/docs/_sass/utils/_variables.scss @@ -0,0 +1,73 @@ +// Variables +// ----------------------------------------------- +// ----------------------------------------------- + +// ----------------------------------------------- +// Typography +// ----------------------------------------------- +@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'); + +// Colors +// ----------------------------------------------- +$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-secondary, 2%); +$sidebar-head-active-color: lighten($brand-secondary, 4%); + +// Typography +// ----------------------------------------------- +$base-font-family: 'Montserrat', sans-serif; +$header-font-family: 'Montserrat', sans-serif; +$header-font-family: $base-font-family; +$code-font-family: 'Fira Code', 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..b422437c --- /dev/null +++ b/docs/css/docs.scss @@ -0,0 +1,24 @@ +--- +--- + +// 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"; +@import "components/dropdown"; + +// Vendor +@import "vendors/highlight/dracula"; diff --git a/docs/css/linuwial.css b/docs/css/linuwial.css new file mode 100644 index 00000000..ea19a35a --- /dev/null +++ b/docs/css/linuwial.css @@ -0,0 +1,880 @@ +@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 } + +/* Is this portable? */ +html { + background-color: white; + width: 100%; + height: 100%; +} + +body { + background: #fefefe; + color: #001E38; + 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: #6d2c71; } +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 #6d2c71; + 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 'Montserrat', '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: 'Fira Mono', 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: #512054; + 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: #6d2c71; + border-bottom: 5px solid #512054; + 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: #512054; + 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: none; + 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: 0px; } +#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/docs/docs/README.md b/docs/docs/README.md new file mode 100644 index 00000000..fc2338ef --- /dev/null +++ b/docs/docs/README.md @@ -0,0 +1,28 @@ +--- +layout: docs +title: Docs +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 allow you to focus on your domain logic, instead of worrying about format and protocol issues. + +If you prefer listening to reading, we have a bunch of [talks]({% link docs/talks.md %}) covering both the usage and the internals of the library. + +* Introduction + * [For RPC]({% link docs/intro-rpc.md %}) + * [For GraphQL]({% link docs/intro-graphql.md %}) +* [Schemas]({% link docs/schema.md %}) + * [Serialization formats]({% link docs/serializers.md %}): Protocol Buffers and Avro + * [Registry]({% link docs/registry.md %}) + * [Optics]({% link docs/optics.md %}) +* [Services]({% link docs/rpc.md %}) + * [gRPC server]({% link docs/grpc-server.md %}) + * [gRPC client]({% link docs/grpc-client.md %}) + * [GraphQL]({% link docs/graphql.md %}) + * [OpenAPI / REST]({% link docs/rest.md %}) +* Integration with other libraries + * [Databases]({% link docs/db.md %}), including resource pools + * [Using transformers]({% link docs/transformer.md %}): look here for logging + * [WAI Middleware]({% link docs/middleware.md %}): look here for metrics diff --git a/docs/docs/db.md b/docs/docs/db.md new file mode 100644 index 00000000..63591836 --- /dev/null +++ b/docs/docs/db.md @@ -0,0 +1,220 @@ +--- +layout: docs +title: Databases +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). + +## 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. + +## Defining 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 :: Int64 + } deriving (Eq, Show, Ord, Generic) + +instance ToSchema PersistentSchema "PersonRequest" MPersonRequest +instance FromSchema PersistentSchema "PersonRequest" MPersonRequest + +data MPerson = MPerson + { pid :: Maybe MPersonRequest + , name :: T.Text + , age :: Int32 + } deriving (Eq, Ord, Show, Generic) + +instance ToSchema PersistentSchema "Person" MPerson +instance FromSchema 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 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 its job properly. + +## Running a pool of database connections + +Now let's focus on the Server! + +All you need to do is open the database once, 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 msgProtoBuf 8080 (server conn) +``` + +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 + +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 msgProtoBuf 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`, 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. + +## 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`. However... + +```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 + :: 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 another `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/docs/docs/graphql.md b/docs/docs/graphql.md new file mode 100644 index 00000000..66f3acc2 --- /dev/null +++ b/docs/docs/graphql.md @@ -0,0 +1,186 @@ +--- +layout: docs +title: GraphQL services +permalink: graphql/ +--- + +# GraphQL services + +[GraphQL](https://graphql.github.io/) defines a language for queries, mutations, and subscriptions much more powerful than RPC or REST-based microservices. The key ingredient is a more complex query language, in which you do not only specify what you want to obtain, but also precisely describe the parts of the data you require. + +We are going to implement a server for the following GraphQL schema, which is roughly based on the one in the [Apollo Server docs](https://www.apollographql.com/docs/apollo-server/schema/schema/). For those not used to the GraphQL schema language, we define a `Query` type with two *fields*, which represent the different queries we can do against the server. The `author` field takes one *argument*; the exclamation mark means that they are *not* optional, although they have a default value. `Book`s and `Author`s define *object* types which can be further queried; note in particular that there is a recursive reference between them, this is allowed in GraphQL schemas. + +```graphql +type Query { + author(name: String! = ".*"): Author + books: [Book!]! +} + +type Book { + id: Int! + title: String! + author: Author! +} + +type Author { + id: Int! + name: String! + books: [Book!]! +} +``` + +## Importing the schema + +The first step is to import this schema as a type-level definition for Mu. The `graphql` function takes three arguments: + +* The first one defines the name of the *service declaration*, in which we find the (result) objects from the GraphQL schema. +* The second one is the route to the file *with respect to the project root*. + +```haskell +{-# language TemplateHaskell #-} + +import Mu.GraphQL.Quasi + +graphql "ServiceDefinition" "schema.graphql" +``` + +This might be surprising for people already used to GraphQL, the separation between input objects and enumerations, and the rest of the objects may seem quite artificial. However, this is needed because Mu-Haskell strongly separates those part of a service which only hold data, from those which may have some behavior associated with it (sometimes called *resolvers*). + +## Mapping each object type + +Unsurprisingly, in order to implement a server for this schema you need to define a resolver for each of the objects and fields. There's one question to be answered beforehand, though: how do you represent *result* type of those resolvers, that is, how do we represent a (**not** input) *object*? We define those using a *type mapping*, which specifies the type associated to each GraphQL object type, except for the root types like `Query`. + +This is better explained with the example. The question here is: how do we represent an `Author`? Our type mapping says that simply using an `AuthorId`: + +```haskell +{-# language TypeApplications, DataKinds #-} + +type TypeMapping + = '[ "Author" ':-> AuthorId + , "Book" ':-> (BookId, AuthorId) ] +``` + +This means *two* things: + +1. The result the `author` method in `Query` should be `Maybe AuthorId`. We obtain this type by noticing that in the definition of that field, `Author` has no exclamation mark, so it's optional, and the type mapping says that `Author` is mapped to an `AuthorId`. +2. The resolver for each of the fields for `Author` take an *additional* argument given by this type mapping. For example, the resolver for the `name` field should have type `AuthorId -> m String`, the argument coming from the type mapping, and the result type being defined by the schema. + +You might be wondering why this is so complicated? The reason is that we don't want to do too much work upfront. In a traditional RPC service you would return the *whole* `Author`, with every field inside. In contrast, a GraphQL query defines *exactly* which fields are required, and we only want to run the resolvers we need. On the other hand, we still need to have a way to connect the dots, and we use the author identifier for that. + +The following schema shows the way we traverse a GraphQL query and the types involved in it. + +```graphql +{ + author(name: ".*Ende.*") { --> 1. return a Maybe AuthorId + name --> 2. from that (optional) AuthorId return a Text + books { --> 3. from that AuthorId return [(BookId, AuthorId)] + title --> 4. from each (BookId, AuthorId) return a Text + } + } +} +``` + +Note that we could have made `Book` be represented simply by a `BookId` and then query some database to figure our the author. However, in this case we assume this query is going to be quite common, and we cache this information since the beginning. Note that from the implementation point of view, the resolver for the `author` field of `Book` should have the type: + +```haskell +bookAuthor :: (BookId, AuthorId) -> m AuthorId +bookAuthor (_, aid) = pure aid +``` + +The argument and result types come from the type mapping, since they are both object types. Given that we have cached that information, we can return it right away. + +## Implementing the server + +The whole implementation looks as a big list defining each of the resolvers for each of the objects and their fields. There's only one subtlety: for *root* operations we use `method` instead of `field`. The reason is that those fields do not take any information passed by, they are the initial requests. + +```haskell +{-# language ScopedTypeVariables, PartialTypeSignatures #-} + +libraryServer :: forall m. (MonadServer m) + => ServerT TypeMapping ServiceDefinition m _ + = resolver + ( object @"Query" ( method @"author" findAuthor + , method @"books" allBooks ) + , object @"Author" ( field @"id" authorId + , field @"name" authorName + , field @"books" authorBooks ) + , object @"Book" ( field @"id" bookId + , field @"author" bookAuthor + , field @"title" bookTitle ) ) + where -- Query fields + findAuthor :: Text -> m (Maybe AuthorId) + allBooks :: m [(BookId, AuthorId)] + -- Author fields + authorId :: AuthorId -> m Int + authorName :: AuthorId -> m Text + authorBooks :: AuthorId -> m [(BookId, AuthorId)] + -- Book fields + bookId :: (BookId, AuthorId) -> m Int + bookAuthor :: (BookId, AuthorId) -> m AuthorId + bookAuthor (_, aid) = pure aid + bookTitle :: (BookId, AuthorId) -> m Text + -- implementation +``` + +In the above code we have defined all fields in a big `where` block, but of course those may be defined as top-level functions, or inline in call to `field` or `method`. + +The final touch is to start the GraphQL server defined by `libraryServer`. The `Mu.GraphQL.Server` module defines tons of different ways to configure how the server behaves; the simplest option just requires a port and the name of the root type for queries. + +```haskell +main = runGraphQLAppQuery 8080 libraryServer (Proxy @"Query") +``` + +## Mutations + +Queries are not the only [operation](https://graphql.github.io/learn/queries/#operation-name) supported by GraphQL. The next simpler one are *mutations*. The format of requests to the server do not change between them both, but the semantics do, as hinted by their names: whereas queries are intended for requests which do not change the underlying data, mutations are the converse. + +Unfortunately, we cannot guarantee those properties in the Mu handlers: in both cases we can perform any operation allowed by `IO`. The bright side is that implementing the mutation part of a GraphQL schema looks exactly like implementing the query part. The only difference is that we can no longer use the `runGraphQLAppQuery` function to start the server, we need to use the more complex variant in which you specify the names of query, mutations, and subscription types. + +```haskell +main = runGraphQLApp 8080 libraryServer + (Proxy @('Just "Query")) + (Proxy @('Just "Mutation")) + (Proxy @Nothing) +``` + +GraphQL does not mandate for any of these sections to be present, hence the use of a (type-level) `Maybe` to indicate whether the corresponding operation is present or absent. + +## Subscriptions as streams + +The third type of operations are _subscriptions_. In contrast to queries and mutations, which return a single value, subscriptions keep an open connection from which a stream of values can be obtained. Within Mu, these streams are represented using [Conduit](https://github.com/snoyberg/conduit). In particular, a subscription resolver gets an additional _sink_ argument to which you should write the returned values. + +For example, let's create a version of `allBooks` which produces a stream of books instead of a single list. As discussed above, the argument is the sink to where elements must be "dumped". + +```haskell +allBooksStream :: ConduitM (BookId, AuthorId) Void m () -> m () +allBooksStream sink = runConduit $ yieldMany allBooks .| sink +``` + +We do not want to repeat here the awesome [Conduit tutorial](https://github.com/snoyberg/conduit#synopsis), so we shall give just a few strokes of how it works. The `yieldMany` combinator simply takes a list and turns it into a stream. Then we connect that stream to the provided `sink` by means of `(.|)`. All this on itself does nothing: a Conduit is just a description of a computation. To really execute it, we wrap everything on `runConduit`. + +Of course, in real code you would not just return a list. The Conduit ecosystem has adapter to the file system, [databases]({% link docs/db.md %}), messaging queues, and many others. + +## Comparison with other libraries + +There are other libraries targeting GraphQL server definition in Haskell: `graphql-api` and Morpheus GraphQL. The latter also supports defining GraphQL *clients*, a feature not (yet) implemented in Mu. + +[`graphql-api`](https://github.com/haskell-graphql/graphql-api#readme) shares with Mu the encoding of the GraphQL schema in the type-level. In fact, as the [tutorial](https://haskell-graphql-api.readthedocs.io/en/latest/tutorial/Introduction.html) shows, its encoding is much closer to GraphQL's schema definition. + +```haskell +type Hello + = Object "Hello" '[] + '[ Argument "who" Text :> Field "greeting" Text ] +``` + +This is expected: Mu's ability to target both RPC and GraphQL microservices means that sometimes there's some mismatch. + +[Morpheus GraphQL](https://morpheusgraphql.com/) also exposes GraphQL servers from Haskell code. Morpheus shared with Mu the ability to import a GraphQL schema into Haskell code. However, the types and fields are not represented by a type-level encoding, but *directly* as Haskell *records*. + +```haskell +data GreetingArgs = GreetingArgs { argname :: Text } deriving (Generic, GQLType) +data Hello m = Hello { greeting :: GreetingArgs -> m Text } deriving (Generic, GQLType) +``` + +At the moment of writing, Mu has the ability to use records for schema types. In GraphQL terms, that means that you can use Haskell records for input objects and enumerations, but resolvers for each object fields need to be defined separately, as described above. + +Another interesting comparison point is how the different libraries ensure that only the required data is ever consulted. This is quite important, since otherwise we might end up in infinite loops (find an author, query the books, for each book query the author, for each author the books, ...). Both `graphql-api` and Morpheus rely on Haskell's laziness, whereas Mu asks to define a type mapping which is then used as connecting point between objects. diff --git a/docs/docs/grpc-client.md b/docs/docs/grpc-client.md new file mode 100644 index 00000000..60d3c02e --- /dev/null +++ b/docs/docs/grpc-client.md @@ -0,0 +1,178 @@ +--- +layout: docs +title: gRPC clients +permalink: grpc/client/ +--- + +# gRPC clients + +There are several options for building clients: you can choose between optics, records, and `TypeApplications`. Let's consider in detail an example client for the following service: + +```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 <- setup 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. The `setup` function is responsible from initializing the + +### Using optics + +The simplest way to call methods is to use the `optics`-based API. In that case, your setup is done using `initGRpc`, which receives the configuration. + +```haskell +main :: IO () +main = do ... + where setup config = initGRpc config msgProtoBuf +``` + +To call a method, you use the corresponding getter (for those familiar with optics, a version of a lens which does not allow to set). This means that your code reads `client ^. #method`, where `client` is the value obtained previously in the call to `initGRpc`. + +```haskell +{-# language OverloadedLabels #-} + +get :: GRpcConnection QuickstartService -> String -> IO () +get client idPerson = do + let req = record1 (read idPerson) + putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?" + res <- client ^. #getPerson $ req + putStrLn $ "GET: response was: " ++ show res +``` + +Notice the use of `read` to convert the strings to the appropiate type. Be careful, though, since that function throws an exception if the string is not a proper number! In a realistic scenario you should use `readMaybe` from `Text.Read` and handle the appropiate cases. + +Using this approach you must also use the optics-based interface to the terms. As a quick reminder: you use `record` to build new values, and use `value ^. #field` to access a field. The rest of the methods look as follows: + +```haskell +add :: GRpcConnection QuickstartService -> String -> String -> IO () +add client nm ag = do + let p = record (Nothing, T.pack nm, read ag) + putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag + res <- client ^. #newPerson $ p + putStrLn $ "ADD: was creating successful? " ++ show res + +watching :: GRpcConnection QuickstartService -> IO () +watching client = do + replies <- client ^. #allPeople + runConduit $ replies .| C.mapM_ print +``` + +### Using records + +This option is a bit more verbose but it's also more explicit with the types. Furthermore, it allows us to use our Haskell data types, we are not forced to use plain terms. As discussed several times, this is important to ensure that Haskell types are not mere shadows of the schema types. + +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 + { call_getPerson :: MPersonRequest -> IO (GRpcReply MPerson) + , call_newPerson :: MPerson -> IO (GRpcReply MPersonRequest) + , call_allPeople :: IO (ConduitT () (GRpcReply MPerson) IO ()) + } deriving Generic +``` + +Note that we had to derive `Generic`. We also need to tweak our `setup` function a little bit: + +```haskell +{-# language TypeApplications #-} + +main :: IO () +main = do ... + where setup config = buildService @Service @"call_" <$> setupGrpcClient' config +``` + +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. Almost as before, except that we use `call_` followed by the name of the method. + +```haskell +get :: Call -> String -> IO () +get client idPerson = do + let req = MPersonRequest $ read idPerson + putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?" + res <- call_getPerson client req + putStrLn $ "GET: response was: " ++ show res + +add :: Call -> String -> String -> IO () +add client nm ag = do + let p = MPerson Nothing (T.pack nm) (read ag) + putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag + res <- call_newPerson client p + putStrLn $ "ADD: was creating successful? " ++ show res + +watching :: Call -> IO () +watching client = do + replies <- call_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! ✨ + +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 + +main = do ... + where setup config = setupGrpcClient' config + +get :: GrpcClient -> String -> IO () +get client idPerson = do + let req = MPersonRequest $ read idPerson + putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?" + response :: GRpcReply MPerson + <- gRpcCall @'MsgProtoBuf @Service @"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 (T.pack nm) (read ag) + putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag + response :: GRpcReply MPersonRequest + <- gRpcCall @'MsgProtoBuf @Service @"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 @'MsgProtoBuf @Service @"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. 🤑 + +--- + +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). diff --git a/docs/docs/grpc-server.md b/docs/docs/grpc-server.md new file mode 100644 index 00000000..250e4c9a --- /dev/null +++ b/docs/docs/grpc-server.md @@ -0,0 +1,86 @@ +--- +layout: docs +title: gRPC servers +permalink: grpc/server/ +--- + +# gRPC servers + +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. + +## Implementing the service + +Let's get back to the example we used in the [generic RPC section]({% link docs/rpc.md %}). In order to implement the corresponding 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 +sayHello (HelloRequest nm) = pure $ HelloResponse ("hi, " <> nm) +``` + +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]({% link docs/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 `SingleServerT`. You do so by using `singleService` (since gRPC servers may only expose one), and a *tuple* of methods indexed by their name *in the gRPC definition*. In addition to the name of the service, `SingleServerT` 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 :: (MonadServer m) => SingleServerT QuickstartService m _ +quickstartServer = singleService (method @"SayHello" sayHello) +``` + + +## Running the server with `mu-grpc` + +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`, using Protocol Buffers as serialization layer: + +```haskell +main = runGRpcApp msgProtoBuf 8080 quickstartServer +``` + +# Streams + +In the docs about [service definition]({% link docs/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: + +```protobuf +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 'Nothing '[] ('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 + :: (MonadServer m) + => ConduitT () HelloRequest m () + -> ConduitT HelloResponse Void m () + -> m () +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 = singleService ( method @"SayHello" sayHello + , method @"SayManyHellos" sayManyHellos ) +``` diff --git a/docs/docs/intro-graphql.md b/docs/docs/intro-graphql.md new file mode 100644 index 00000000..6bb93428 --- /dev/null +++ b/docs/docs/intro-graphql.md @@ -0,0 +1,176 @@ +--- +layout: docs +title: Introduction for GraphQL +permalink: intro-graphql/ +--- + +# Introduction to Mu-Haskell for GraphQL + +This document will help you get started in writing your first GraphQL server using Mu-Haskell and `mu-graphql`! + +## Using the Stack template + +First of all, we've prepared a Stack template to boostrap your project easily, just run: + +```sh +$ stack new your-project https://raw.githubusercontent.com/higherkindness/mu-haskell/master/templates/graphql-server.hsfiles -p "author-email:haskell.curry@47deg.com" -p "author-name:Haskell Curry" +``` + +After doing this you'll have a compiling project with all the dependencies in place and a simple `Main.hs` file created. + +## Defining your GraphQL Schema + +The template will generate a `schema.graphql` file with a basic "hello" query, feel free to change it with your domain types. For the sake of this intro we'll use the library example from the [Apollo GraphQL docs](https://www.apollographql.com/docs/apollo-server/schema/schema/): + +```graphql +type Book { + title: String! + author: Author! +} + +type Author { + name: String! + books: [Book!]! +} + +type Query { + authors: [Author!]! + books: [Book!]! +} +``` + +This schema defines **three types: a book, an author, and a query**. All GraphQL APIs have a query type which defines all the possible queries you can ask. In our case, we have a query asking for all the authors in the library and another one for all the books. 📚 The exclamation marks all over the place (`!`) in GraphQL mean that the data is required to be returned, removing those would result in a `Maybe type` in Haskell! 😉 + +## Implementing the GraphQL Server + +Now let's have a look at the already finished `src/Main.hs` and we'll go bit by bit explaining what is going on: + +```haskell +graphql "ServiceDefinition" "schema.graphql" + +main :: IO () +main = do + putStrLn "starting GraphQL server on port 8080" + runGraphQLAppQuery 8080 server (Proxy @"Query") + +type ServiceMapping = '[ + "Book" ':-> (Text, Text) + , "Author" ':-> Text + ] + +library :: [(Text, [Text])] +library + = [ ("Robert Louis Stevenson", ["Treasure Island", "Strange Case of Dr Jekyll and Mr Hyde"]) + , ("Immanuel Kant", ["Critique of Pure Reason"]) + , ("Michael Ende", ["The Neverending Story", "Momo"]) + ] + +server :: forall m. MonadServer m => ServerT ServiceMapping ServiceDefinition m _ +server = resolver + ( object @"Book" + ( field @"title" bookTitle + , field @"author" bookAuthor ) + , object @"Author" + ( field @"name" authorName + , field @"books" authorBooks ) + , object @"Query" + ( method @"authors" allAuthors + , method @"books" allBooks ) + ) + where + bookTitle :: (Text, Text) -> m Text + bookTitle (_, title) = pure title + bookAuthor :: (Text, Text) -> m Text + bookAuthor (auth, _) = pure auth + + authorName :: Text -> m Text + authorName = pure + authorBooks :: Text -> m [(Text, Text)] + authorBooks name = pure $ (name,) <$> maybe [] snd (find ((==name) . fst) library) + + allAuthors :: m [Text] + allAuthors = pure $ fst <$> library + allBooks :: m [(Text, Text)] + allBooks = pure [(author, title) | (author, books) <- library, title <- books] +``` + +## Schema generation explained + +Notice this important line: + +```haskell +graphql "ServiceDefinition" "schema.graphql" +``` + +This is where your `schema.graphql` file gets converted to a type-level expression that represents your Schema in terms of Mu-Haskell. Here, we're assigning the new schema the name `ServiceDefinition`, which will be later use in the next section below. + +## Server declaration explained + +As you've seen, we declare the GraphQL server the following way: + +```haskell +server :: forall m. MonadServer m => ServerT ServiceMapping ServiceDefinition m _ +server = resolver + ( object @"Book" + ( field @"title" bookTitle + , field @"author" bookAuthor ) + , object @"Author" + ( field @"name" authorName + , field @"books" authorBooks ) + , object @"Query" + ( method @"authors" allAuthors + , method @"books" allBooks ) + ) +``` + +Here we use the given name `ServiceMapping` for the type-level generated GraphQL Schema that we've created for you! + +To declare the server, you need provide a resolver for each field, using the `object` and `field` functions. Use `method` for the fields in "Query", since it's a special case for us (you can read more about [why here](https://higherkindness.io/mu-haskell/graphql/#implementing-the-server)). + +> The ordering here is casual, you can declare each type wherever you like (as long as it is inside of the same tuple, of course) and it will still work! 🎉 + +## `ServiceMapping` explained + +You might have noticed this strange piece of code: + +```haskell +type ServiceMapping = '[ + "Book" ':-> (Text, Text) + , "Author" ':-> Text + ] +``` + +This is where we establish the _relationship_ between the types. You may have notice that the GraphQL schema contained **recursive** references for the types, that is OK both for GraphQL and for Haskell, but it would not be the case for _other languages!_ + +## Resolvers explained + +Now let's get to the meat. Although GraphQL will use the least amount of calls possible to find the result to your query, you need to provide "paths" or roads to every possible piece of your data. Although the example here is a hardcoded list, it could be anything ranging from a text file to a fully-fledged database! 🚀 + +```haskell +bookTitle :: (Text, Text) -> m Text +bookTitle (_, title) = pure title +bookAuthor :: (Text, Text) -> m Text +bookAuthor (auth, _) = pure auth + +authorName :: Text -> m Text +authorName = pure +authorBooks :: Text -> m [(Text, Text)] +authorBooks name = pure $ (name,) <$> maybe [] snd (find ((==name) . fst) library) + +allAuthors :: m [Text] +allAuthors = pure $ fst <$> library +allBooks :: m [(Text, Text)] +allBooks = pure [(author, title) | (author, books) <- library, title <- books] +``` + +What is that `m` that appears everywhere? Well, since we are using `ScopedTypeVariables`, that `m` refers to the above typeclass constrain `MonadServer m`. That is also why we need to lift with `pure` all of our results into the `MonadServer`. + +We tend to put all those resolver functions in a `where` block, but of course you are free to move them around wherever you want! 😜 + +## Where to go from here + +Here's a [more complete example](https://github.com/higherkindness/mu-haskell/tree/master/graphql/exe) of how a finished server looks like. + +If you are confused or you'd like to know more about how this all works, have a look at our [GraphQL docs](https://higherkindness.io/mu-haskell/graphql/), or feel free to [open an issue](https://github.com/higherkindness/mu-haskell/issues) in the repo and we'll be happy to help! + +Happy hacking! 🔥 diff --git a/docs/docs/intro-rpc.md b/docs/docs/intro-rpc.md new file mode 100644 index 00000000..71457d94 --- /dev/null +++ b/docs/docs/intro-rpc.md @@ -0,0 +1,136 @@ +--- +layout: docs +title: Introduction for RPC +permalink: intro-rpc/ +--- + +# Introduction to Mu-Haskell for RPC + +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 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 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`, `mu-graphql` (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 + +### Super-quick summary + +1. Create a new project with `stack new`. +2. Define your schema and your services in the `.proto` file. +3. Map to your Haskell data types in `src/Schema.hs`, or use optics. +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. The library also supports `.avdl` files which declare the messages in Avro IDL, check the [serialization]({% link docs/serializers.md %}) section for more information. + +```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 https://raw.githubusercontent.com/higherkindness/mu-haskell/master/templates/grpc-server-protobuf.hsfiles -p "author-email:your@email.com" -p "author-name:Your name" +``` + +**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. + +#### Data type definition + +The second step is to define Haskell types corresponding to the message types in the gRPC definition. The recommended route is to create new Haskell data types and check for compatibility at compile-time. The goal is to discourage from making your domain types simple copies of the protocol types. Another possibility is to use the `optics` bridge and work with lenses for the fields. + +##### Using Haskell 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 + , ToSchema TheSchema "HelloRequest" + , FromSchema TheSchema "HelloRequest") + +data HelloReplyMessage + = HelloReplyMessage { message :: T.Text } + deriving (Eq, Show, Generic + , ToSchema TheSchema "HelloReply" + , FromSchema TheSchema "HelloReply") +``` + +These data types should be added to the file `src/Schema.hs`, under the line that starts `grpc ...`. (See the [RPC services page]({% link docs/rpc.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. +* 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! + +##### Using optics + +As we mentioned above, you may decide to not introduce new Haskell types, at the expense of losing some automatic checks against the current version of the schema. However, you gain access to a set of lenses and optics which can be used to inspect the values. In the Mu jargon, values from a schema which are not Haskell types are called *terms*, and we usually define type synonyms for each of them. + +```haskell +type HelloRequestMessage' = Term TheSchema (TheSchema :/: "HelloRequest") +type HelloReplyMessage' = Term TheSchema (TheSchema :/: "HelloReply") +``` + +The arguments to `Term` closely correspond to those in `FromSchema` and `ToSchema` described above. + +#### 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 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`, using Protocol Buffers as serialization layer. 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 msgProtoBuf 8080 server + +server :: (MonadServer m) => SingleServerT Service m _ +server = singleService () +``` + +The simplest way to provide an implementation for a service is to define one function for each method. You can 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) + = pure $ 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`. + +Another possibility is to use the `optics`-based API in `Mu.Schema.Optics`. In that case, you access the value of the fields using `(^.)` followed by the name of the field after `#`, and build messages by using `record` followed by a tuple of the components. The previous example would then be written: + +```haskell +{-# language OverloadedLabels #-} + +sayHello :: (MonadServer m) => HelloRequestMessage' -> m HelloReplyMessage' +sayHello (HelloRequestMessage nm) + = pure $ record ("hi, " <> nm ^. #name) +``` + +How does `server` know that `sayHello` (any of the two versions) is part of the implementation of the service? We have to tell it, by declaring that `sayHello` implements the `SayHello` method from the gRPC definition. If you had more methods, you list each of them using tuple syntax. + +```haskell +server = singleService (method @"SayHello" sayHello) +``` + +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/docs/middleware.md b/docs/docs/middleware.md new file mode 100644 index 00000000..bfa830b9 --- /dev/null +++ b/docs/docs/middleware.md @@ -0,0 +1,74 @@ +--- +layout: docs +title: Middleware +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. + +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 [gRPC server example]({% link docs/grpc-server.md %}) our `main` function looked as follows: + +```haskell +main = runGRpcApp msgSerializer 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 msgSerializer 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 msgSerializer 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 msgSerializer 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 msgSerializer 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/docs/optics.md b/docs/docs/optics.md new file mode 100644 index 00000000..cbb3d831 --- /dev/null +++ b/docs/docs/optics.md @@ -0,0 +1,96 @@ +--- +layout: docs +title: Optics +permalink: optics/ +--- + +# Optics + +We created a new package `mu-optics` is available from **release v0.3 of Mu-Haskell**, and provides an easier API to build both servers and clients using lenses and prisms (probably the ultimate API 😉). This document aims to be a reference of how to use this library and the common use cases for it. + +## Accessing fields with `#field` + +When you want to refer to a method of your type-level schema, whereas in the server or the client, you can use the get operation from the lens (`^.`) in conjunction with the `OverloadedLabels` extension to access that field, as in this example. In this case, the label `#name` should have the same name as the field declared in the corresponding schema definition file. + +```haskell +{-# language OverloadedLabels #-} + +sayHello :: MonadServer m => HelloRequestMessage' -> m HelloReplyMessage' +sayHello (HelloRequestMessage nm) = pure $ record ("hi, " <> nm ^. #name) +``` + +## Generate records with `record` and `record1` + +Sometimes you need to create values that match the generated type-level schema representations, for example, to construct the request of a certain service. Usually, those types will be records, and to help you achieve that task we provided the helpers `record` and `record1`: + +```haskell +get :: GRpcConnection PersistentService 'MsgProtoBuf -> String -> IO () +get client idPerson = do + let request = read idPerson + putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?" + response <- client ^. #getPerson $ record1 request -- <- using `record1` to create a request + putStrLn $ "GET: response was: " ++ show response +``` + +Why the difference? Well, due to some ambiguity in the context of our Schemas, we need to help GHC to know if the record we're creating contains only one field (`record1`) or more (`record`) contained in a tuple of elements. + +> This design might be improved in the future, by using "[OneTuple](https://hackage.haskell.org/package/OneTuple-0.2.2.1/docs/Data-Tuple-OneTuple.html) to rule them all." + +```haskell +add :: GRpcConnection PersistentService 'MsgProtoBuf -> String -> String -> IO () +add client nm ag = do + let person = record (Nothing, T.pack nm, read ag) -- <- using `record` to create Person, a more complex type + putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag + response <- client ^. #newPerson person + putStrLn $ "ADD: was creating successful? " ++ show response +``` + +## Generating enums with `enum` + +Sometimes, besides using records, you'll have your types defined as something like enums, as in this protobuf example: + +```protobuf +enum Weather { + sunny = 0; + cloudy = 1; + rainy = 2; +} +``` + +As expected, we also provided you with the tools you need to construct a valid enum-like value with the helper `enum`: + +```haskell +{-# language TypeApplications #-} + +import Mu.Schema +import Mu.Schema.Optics + +type Weather = Term WeatherProtocol (WeatherProtocol :/: "Weather") + +sunnyDays :: Int -> [Weather] +sunnyDays n = replicate n (enum @"sunny") -- <- see the magic here! ✨ +``` + +Simply enable `TypeApplications` and provide the value you are looking for to construct the enum! 🚀 + +## Accesing enums with prisms! + +Following with the example above, if you need to read an enum value, you can do so using prisms! + +```haskell +{-# language OverloadedLabels #-} + +getWeather :: Weather -> IO () +getWeather e + | e `is` #sunny = putStrLn "is sunny! 😄" + | e `is` #cloudy = putStrLn "is cloudy 😟" + | e `is` #rainy = putStrLn "is rainy... 😭" +``` + +Again, notice the use of `OverloadedLabels` to refer to the possible enum values and our special `is` prism helper, which is just `is s k = isJust (preview k s)`, got it? isJust... badum tss! 🥁 + +## Accessing unions + +Besides this, you have `_U0`, `_U1`, ... and `_Next`, with the goal of giving prisms for the different possibilities of a union. So, lets say you have a field that is an union of `String` and `Int`, you can get prisms using `#field % _U0` and `#field % _U1`. + +> We know the naming of these might be terrible, but they follow the usual convention for this kind of stuff: `_` for a prism, `U` from "Union" and then the index. diff --git a/docs/docs/registry.md b/docs/docs/registry.md new file mode 100644 index 00000000..6522228b --- /dev/null +++ b/docs/docs/registry.md @@ -0,0 +1,28 @@ +--- +layout: docs +title: Registry +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: + +```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]({% link docs/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/docs/docs/rest.md b/docs/docs/rest.md new file mode 100644 index 00000000..ad59bf87 --- /dev/null +++ b/docs/docs/rest.md @@ -0,0 +1,192 @@ +--- +layout: docs +title: OpenAPI / REST services +permalink: openapi/ +--- + +# OpenAPI / REST services + +In order to expose a Mu server using a OpenAPI or REST interface, we make use of the awesome [Servant](https://docs.servant.dev/en/stable/) library. Both libraries describe the API of a server at the type level, use the notion of _handlers_, and follow a similar structure. + +The `mu-servant-server` package contains a function `servantServerHandlers` which unpacks the Mu handlers and repackages them as Servant handlers, with some minor changes to support streaming. The trickiest part, however, is translating the Mu server _type_ into a Servant server _type_. + +## Annotating the server + +When Mu methods are converted to Servant APIs, you may customize certain aspects of the resulting API, including the route, HTTP method, and HTTP status. Additionally, you must specify which content types use be used when encoding and decoding each type in your schema that appears in your methods. All of this customization is done with annotations, via the `AnnotatedSchema` and `AnnotatedPackage` type families. + +For the server we have developed in the [generic RPC section]({% link docs/rpc.md %}), the instances for the services look as follows: + +```haskell +type instance AnnotatedPackage ServantRoute QuickstartService + = '[ 'AnnService "Greeter" ('ServantTopLevelRoute '["greet"]) + , 'AnnMethod "Greeter" "SayHello" + ('ServantRoute '["say", "hello"] 'POST 200), + ] +``` + +The first annotation defines that the whole service lives in the `/greet` route. Each method then gets its own route and HTTP verb. To execute `SayHello`, one has to make a `POST` request to `/greet/say/hello`. The last element is the HTTP status code to be returned by default, in this case `200` which means success. + +You also need to define how message types can be serialized in the API. This will be translated to a `ReqBody` in the corresponding Servant API, which requires a list of acceptable content types for the request. We provide a `DefaultServantContentTypes` which uses JSON for both unary and streaming calls. + +```haskell +type instance + AnnotatedSchema ServantContentTypes QuickstartSchema = + '[ 'AnnType "HelloRequest" DefaultServantContentTypes, + 'AnnType "HelloResponse" DefaultServantContentTypes + ] +``` + +The `MimeRender`/`MimeUnrender` instances necessary to perform this encoding/decoding must exist for the Haskell type you use to represent messages. In this case, that means that both types must support conversion to JSON, which can be achieved using `mu-schema` in combination with `DerivingVia`. + +```haskell +{-# language DerivingVia #-} + +import qualified Data.Aeson as J +import Mu.Adapter.Json () + +newtype HelloRequest = HelloRequest { name :: T.Text } + deriving ( Show, Eq, Generic + , ToSchema QuickstartSchema "HelloRequest" + , FromSchema QuickstartSchema "HelloRequest" ) + deriving (J.ToJSON, J.FromJSON) + via (WithSchema QuickstartSchema "HelloRequest" HelloRequest) +``` + + +If you forget to provide one of these required instances, you will see a message like the following: + +``` + • Missing required AnnotatedPackage ServantRoute type instance + for "myschema" package + • When checking the inferred type +``` + +followed by a large and difficult to read type representing several stuck type families. This message is an indication that you must provide an `AnnotatedPackage` type instance, with a domain of `ServantRoute` for the package with the name `myschema`. + +## Exposing the server + +You are now ready to expose your server using Servant! + +```haskell +import Mu.Servant.Server +import Servant.Server + +main = + let api = packageAPI (quickstartServer @ServerErrorIO) + server = servantServerHandlers toHandler quickstartServer + in run 8081 (serve api server) +``` + +The last line uses functions from Servant and Warp to run the server. The `serve` function has two parameters: +- One is the definition of the API, which can be obtained using the provided `packageAPI` with your server. In this case we had to make explicit the monad we are operating to avoid an ambiguity error. +- The other is the set of Servant handlers, which can be obtained by using `servantServerHandlers toHandler`. + +## Integration with Swagger UI + +You can easily expose not only the server itself, but also its [Swagger / OpenAPI](https://swagger.io/) schema easily, alongside a [Swagger UI](https://swagger.io/tools/swagger-ui/) for testing purposes. Here we make use of the awesome [`servant-swagger-ui` package](https://github.com/haskell-servant/servant-swagger-ui). + +First of all, you need to specify that you want an additional component in your Servant API. You do so in the annotation: + +```haskell +type instance AnnotatedPackage ServantRoute QuickstartService + = '[ 'AnnPackage ('ServantAdditional (SwaggerSchemaUI "swagger-ui" "swagger.json")) + , {- rest of annotations -} ] +``` + +The implementation of this additional component is given by using `servantServerHandlersExtra`, instead of its "non-extra" version. The aforementioned package is ready for consumption in that way: + +```haskell +import Mu.Servant.Server +import Servant.Server +import Servant.Swagger.UI + +main = + let svc = quickstartServer @ServerErrorIO + api = packageAPI svc + server = servantServerHandlersExtra + (swaggerSchemaUIServer (swagger svc)) + toHandler svc + in run 8081 (serve api server) +``` + +And that's all! When you users surf to `yourserver/swagger-ui` they'll see a color- and featureful explanation of the endpoints of your server. + +## Type translation + +> This is not required for using `mu-servant-server`, but may help you understanding how it works under the hood and diagnosing problems. + +There are essentially four categories of `Method` types and each of these is translated slightly differently. + +### Full unary + +Full unary methods have non-streaming arguments and a non-streaming response. Most HTTP endpoints expect unary requests and return unary responses. Unary method handlers look like this + +```haskell +(MonadServer m) => requestType -> m responseType +``` + +For a handler like this, the corresponding "Servant" API type would be + +```haskell +type MyUnaryAPI = + route :> + ReqBody ctypes1 requestType :> + Verb method status ctypes2 responseType +``` + +As you can see, the request body contains a `requestType` value, and the response body contains a `responseType` value. All other types are derived from Mu annotations. + +### Server streaming + +Server streaming methods have non-streaming arguments, but the response is streamed back to the client. Server stream handlers look like this + +```haskell +(MonadServer m) => requestType -> ConduitT responseType Void m () -> m () +``` + +For a handler like this, the corresponding Servant API type would be + +```haskell +type MyServerStreamAPI = + route :> + ReqBody ctypes requestType :> + Stream method status framing ctype (SourceIO (StreamResult responseType)) +``` + +The request body contains a `requestType` value. The response body is a stream of `StreamResult` responseType@ values. `StreamResult responseType` contains either a `responseType` value or an error message describing a problem that occurred while producing `responseType` values. All other types are derived from Mu annotations. + +### Client streaming + +Client streaming methods have a streaming argument, but the response is unary. Client stream handlers look like this + +```haskell +(MonadServer m) => ConduitT () requestType m () -> m responseType +``` + +For a handler like this, the corresponding Servant API type would be + +```haskell +type MyClientStreamAPI = + route :> + StreamBody framing ctype (SourceIO requestType) :> + Verb method status ctypes responseType +``` + +### Bidirectional streaming + +Bidirectional streaming method have a streaming argument and a streaming response. Bidirectional stream handlers look like this + +```haskell +> (MonadServer m) => ConduitT () requestType m () -> ConduitT responseType Void m () -> m() +``` + +For a handler like this, the corresponding Servant API type would be + +```haskell +type MyBidirectionalStreamAPI = + StreamBody framing1 ctype1 (SourceIO requestType) :> + Stream method status framing2 ctype2 (SourceIO (StreamResult responseType)) +``` + +This type should look familiar if you already looked at the server streaming and client streaming examples. The request body is a stream of `requestType` values, and the response body is a stream of `StreamResult responseType` values. All the other types involved are derived from Mu annotations. + diff --git a/docs/docs/rpc.md b/docs/docs/rpc.md new file mode 100644 index 00000000..fd0a77e1 --- /dev/null +++ b/docs/docs/rpc.md @@ -0,0 +1,100 @@ +--- +layout: docs +title: RPC services +permalink: rpc/ +--- + +# RPC services + +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 + +Let us begin with an example taken from the [gRPC Quickstart Guide](https://grpc.io/docs/quickstart/): + +```java +package helloworld; + +service Greeter { + rpc SayHello (HelloRequest) returns (HelloReply) {} +} + +message HelloRequest { string name = 1; } +message HelloReply { string message = 1; } +``` + +As with our sibling `mu-schema` library, we use type-level techniques to represent the messages and services. Since the mapping from such a Protocol Buffers file into the require types is quite direct, you can just import them using one line (in addition to enabling the `TemplateHaskell` extension): + +```haskell +{-# language TemplateHaskell #-} + +import Mu.Quasi.GRpc + +grpc "QuickstartSchema" (const "QuickstartService") "quickstart.proto" +``` + +The `grpc` function takes three arguments: + +* The first one defines the name of the schema type which is going to be generated, and which includes the declaration of all the messages in the file. +* The second one declares how to map the name of *each* service in the file (since more than one may appear) to the name of a Haskell type. In this case, we declare a constant name "QuickstartService". But we could also use `(++ "Service")`, which would then give `GreeterService` as name for the only service in the file. +* The third argument is the route to the file *with respect to the project root*. + +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 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 "", FromSchema "")` at the end of each of them. + +```haskell +{-# 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" ('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 } + deriving (Generic + , ToSchema QuickstartSchema "HelloRequest" + , FromSchema QuickstartSchema "HelloRequest") +newtype HelloResponse + = HelloResponse { message :: T.Text } + deriving (Generic + , ToSchema QuickstartSchema "HelloResponse" + , FromSchema QuickstartSchema "HelloResponse") +``` + +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 + +-- GENERATED +type QuickstartService + = 'Service "Greeter" + '[ 'Method "SayHello" '[] + '[ 'ArgSingle 'Nothing '[] ('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 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). +* gRPC defines no names for arguments, hence the use of `Nothing` in `ArgSingle`. Other service APIs, like GraphQL, have names on that possitions. +* 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`. + +Note that depending on the concrete implementation you use to run the server, one or more of these choices may not be available. For example, gRPC only supports one argument and return value, either single or streaming, but not exceptions. diff --git a/docs/docs/schema.md b/docs/docs/schema.md new file mode 100644 index 00000000..bfedd149 --- /dev/null +++ b/docs/docs/schema.md @@ -0,0 +1,146 @@ +--- +layout: docs +title: Schemas +permalink: schema/ +--- + +# 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, +* 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`. + +## Records and enumerations + +Here is a simple schema which defines the schema types `gender`, `address`, and `person`: + +```haskell +{-# language PolyKinds, DataKinds #-} + +import Mu.Schema +import qualified Data.Text as T + +type ExampleSchema + = '[ '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") ] + ] +``` + +As you can see, a *schema* is just a list of schema types. Each of these types has a *name* and can either be an enumeration or a record. + +* 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 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. + +Note that GHC requires all of `DEnum`, `DRecord`, `FieldDef`, and so forth to be prefixed by a quote sign `'`. This declares that we are working with [promoted types](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#datatype-promotion) (you do not have to understand what a promoted type is, but you need to remember to use the quote sign). + +### Defining a schema using Protocol Buffers + +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 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 TemplateHaskell #-} + +import Mu.Quasi.ProtoBuf + +protobuf "ExampleSchema" "path/to/file.proto" +``` + +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. + +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 `protobuf` block. + +### Limitations on primitive optionals + +You should be aware of a limitation regarding optional values stated in the [Protocol Buffers documentation](https://developers.google.com/protocol-buffers/docs/proto3#default): + +> Note that for scalar message fields, once a message is parsed there's no way of telling whether a field was explicitly set to the default value (for example whether a boolean was set to `false`) or just not set at all: you should bear this in mind when defining your message types. For example, don't have a boolean that switches on some behaviour when set to `false` if you don't want that behaviour to also happen by default. Also note that if a scalar message field **is** set to its default, the value will not be serialized on the wire. + +That means that in a Protocol Buffers message it is not possible to have `'TOption ('TPrimitive p)`, since a lack of such a field means that the default value is to be used. In fact, Protocol Buffers implementations are expected to drop such values in order to save bandwidth. `mu-protobuf` will try to help here, raising a warning in some cases in which `default` is used. + +## 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. + +```haskell +{-# language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} +{-# language DeriveGeneric, DeriveAnyClass #-} + +import GHC.Generics + +data Address + = Address { postcode :: T.Text + , country :: T.Text } + deriving (Eq, Show, Generic) + deriving (ToSchema ExampleSchema "address") + deriving (FromSchema 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 lines: + +```haskell + deriving (ToSchema YourSchema "yourSchemaType") + deriving (FromSchema 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 standalone `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 #-} + +type GenderFieldMapping + = '[ "Male" ':-> "male" + , "Female" ':-> "female" + , "NonBinary" ':-> "nb" ] + +data Gender = Male | Female | NonBinary + deriving (Eq, Show, Generic) + deriving (ToSchema ExampleSchema "gender", FromSchema ExampleSchema "gender") + via (CustomFieldMapping "gender" GenderFieldMapping Gender) +``` + +### 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. 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 +{-# language TypeFamilies #-} + +import Mu.Adapter.ProtoBuf + +type instance AnnotatedSchema ProtoBufAnnotation ExampleSchema + = '[ ... + , 'AnnField "address" "postcode" ('ProtoBufId 1) + , 'AnnField "address" "country " ('ProtoBufId 2) + , ... ] +``` diff --git a/docs/docs/serializers.md b/docs/docs/serializers.md new file mode 100644 index 00000000..1f769e78 --- /dev/null +++ b/docs/docs/serializers.md @@ -0,0 +1,73 @@ +--- +layout: docs +title: Serialization formats +permalink: serializers/ +--- + +# Serialization formats + +Mu supports two serialization formats for messages when defining a gRPC end-point: Protocol Buffers and Avro. That is, the "outer layer" of your network packages uses gRPC, and the "inner data layer" has a choice between the aforementioned formats. + +There are three places where this choice must be made visible: + +1. When reading a service definition file, +2. When defining the conversion from Haskell types to schema types, +3. When starting a server or client. + +## Protocol Buffers + +In this case loading the service definition file looks as follows: + +```haskell +{-# language TemplateHaskell #-} +import Mu.Quasi.GRpc + +grpc "Schema" id "defn.proto" +``` + +This asks the compiler to load the `defn.proto` file in order to create a series of (Haskell) types. The first one, which is called `"Schema"`, as the first argument shows, includes the definition of all the schema types. Then, for every service defined in the file (since `.proto` files may have more than one), the second function is applied to obtain the name of the corresponding Haskell type. In this case we want to use the same names, so we use the identity function. + +```haskell +data PersonMsg + = PersonMsg { name :: Text, age :: Int } + deriving ( Eq, Show, Ord, Generic + , ToSchema Schema "Person" + , FromSchema Schema "Person" ) +``` + +Protocol Buffers version 3 has complicated rules about when a field may or may not appear in the message. For example it is not possible to distinguish whether the empty string is to be transmitted, or that field is missing. In that case, deserialization from a Protocol Buffers message returns the default value. However, for references to other message we can spot the difference, so those references *must* be wrapped in a `Maybe`. + +Finally, when starting a server or client you must provide `msgProtoBuf` as argument. For example, a server is started by running: + +```haskell +runGRpcApp msgProtoBuf 8080 server +``` + +## Avro + +In this case loading the service definition file looks as follows: + +```haskell +{-# language TemplateHaskell #-} +import Mu.Quasi.Avro + +avdl "Schema" "Service" "." "defn.avdl" +``` + +Each `.avdl` file defines just one protocol, so instead of a function like in the case of Protocol Buffers, the second argument is simply the name of the Haskell type to create. But you might have noticed that there's an additional argument, which in this case is `"."`. The reason for this argument is that `.avdl` files routinely *import* other files. This third argument indicates the *base directory* to search for those files. + +The conversion is almost identical to Protocol Buffers too. In Avro fields are required by default, only those fields which are optional (usually specified as a union with `null`) must still use `Maybe`: + +```haskell +data PersonMsg + = PersonMsg { name :: Text, age :: Int } + deriving ( Eq, Show, Ord, Generic + , ToSchema Schema "Person" + , FromSchema Schema "Person" ) +``` + +Finally, when starting a server or client you must provide `msgAvro` as argument. For example, a server is started by running: + +```haskell +runGRpcApp msgAvro 8080 server +``` diff --git a/docs/docs/talks.md b/docs/docs/talks.md new file mode 100644 index 00000000..8ffb6185 --- /dev/null +++ b/docs/docs/talks.md @@ -0,0 +1,33 @@ +--- +layout: docs +title: Talks +permalink: talks/ +--- + +# Talks + +**Warning**: depending on the moment in which each talk has recorded, the code may not be 100% compatible with the latest release of Mu-Haskell. The underlying ideas do remain the same. + +## Using Mu-Haskell + +[Alejandro](https://twitter.com/trupill)'s talk about Mu + GraphQL at [Haskell Love](https://haskell.love/). + +[![haskell-love](https://img.youtube.com/vi/JbeqwfZ2dRc/0.jpg)](https://www.youtube.com/watch?v=JbeqwfZ2dRc) + +[Alejandro](https://twitter.com/trupill)'s talk about Mu + gRPC at [Haskell Amsterdam](https://www.haskell.amsterdam/). + +[![haskell-amsterdam](https://img.youtube.com/vi/gop937MGZJ0/0.jpg)](https://www.youtube.com/watch?v=gop937MGZJ0) + +[Flavio](https://twitter.com/FlavioCorpa)'s talk on Mu + GraphQL at the [Berlin Functional Programming Group](https://www.meetup.com/es-ES/Berlin-Functional-Programming-Group/). + +[![mu-berlin](https://img.youtube.com/vi/ZnYa99QoznE/0.jpg)](https://www.youtube.com/watch?v=ZnYa99QoznE) + +## Implementation + +[Alejandro](https://twitter.com/trupill) and [Flavio](https://twitter.com/FlavioCorpa)'s experience report presentation on [Haskell Symposium](https://icfp20.sigplan.org/details/haskellsymp-2020-papers/6/Describing-Microservices-using-Modern-Haskell-Experience-Report). Here we explore the challenges we had to overcome while use type level techniques. + +[![haskell-symposium](https://img.youtube.com/vi/GDITBmIzCDs/0.jpg)](https://www.youtube.com/watch?v=GDITBmIzCDs) + +[Alejandro](https://twitter.com/trupill)'s talk about the internals of Mu-Haskell, focused mostly on the schema side. + +[![mu-internals](https://img.youtube.com/vi/JbHnzCtWof0/0.jpg)](https://www.youtube.com/watch?v=JbHnzCtWof0) diff --git a/docs/docs/transformer.md b/docs/docs/transformer.md new file mode 100644 index 00000000..9f594bd1 --- /dev/null +++ b/docs/docs/transformer.md @@ -0,0 +1,90 @@ +--- +layout: docs +title: Transformers +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]({% link docs/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]({% link docs/grpc-server.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 + pure $ 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" + pure $ HelloResponse ("hi, " <> nm) +``` + +The most important addition with respect to the original code 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 msgSerializer 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" + pure $ 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 msgSerializer 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/docs/img/arrow-down.svg b/docs/img/arrow-down.svg new file mode 100644 index 00000000..0b4a3def --- /dev/null +++ b/docs/img/arrow-down.svg @@ -0,0 +1,7 @@ + + + arrow-down + + + + diff --git a/docs/img/favicon.png b/docs/img/favicon.png new file mode 100644 index 00000000..a76c4f10 Binary files /dev/null and b/docs/img/favicon.png differ diff --git a/docs/img/nav-brand-white.svg b/docs/img/nav-brand-white.svg new file mode 100644 index 00000000..a27e8b3c --- /dev/null +++ b/docs/img/nav-brand-white.svg @@ -0,0 +1,8 @@ + + + sidebar-haskell + + + + + diff --git a/docs/img/nav-brand.svg b/docs/img/nav-brand.svg new file mode 100644 index 00000000..a27e8b3c --- /dev/null +++ b/docs/img/nav-brand.svg @@ -0,0 +1,8 @@ + + + sidebar-haskell + + + + + diff --git a/docs/img/nav-icon-close.svg b/docs/img/nav-icon-close.svg new file mode 100644 index 00000000..cf9304ef --- /dev/null +++ b/docs/img/nav-icon-close.svg @@ -0,0 +1,10 @@ + + + nav-icon-close + + + + + + + diff --git a/docs/img/nav-icon-open.svg b/docs/img/nav-icon-open.svg new file mode 100644 index 00000000..d7d37cf2 --- /dev/null +++ b/docs/img/nav-icon-open.svg @@ -0,0 +1,11 @@ + + + nav-icon-open + + + + + + + + diff --git a/docs/img/poster.png b/docs/img/poster.png new file mode 100644 index 00000000..ca21c1e6 Binary files /dev/null and b/docs/img/poster.png differ diff --git a/docs/img/sidebar-icon-open.svg b/docs/img/sidebar-icon-open.svg new file mode 100644 index 00000000..9593a4c6 --- /dev/null +++ b/docs/img/sidebar-icon-open.svg @@ -0,0 +1,9 @@ + + + sidebar-icon-open + + + + + + diff --git a/docs/js/docs.js b/docs/js/docs.js new file mode 100644 index 00000000..f49af6fa --- /dev/null +++ b/docs/js/docs.js @@ -0,0 +1,208 @@ +/** + * 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 ghInfo = document.querySelector('meta[property="github-info"]'); + const ghOwner = ghInfo.dataset.githubOwner; + const ghRepo = ghInfo.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 ghStars = ghData.stargazers_count; + const starsElement = document.querySelector("#stars-count"); + if (starsElement) { + if (ghStars) { + starsElement.textContent = `☆ ${ghStars}`; + } + else { + starsElement.remove(); + } + } + } +} + +/** + * 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)); + } + }); +} + +/** + * Go through all headers applying linkify function + */ +function linkifyAllLevels() { + const content = document.querySelector(".doc-content"); + [...Array(7).keys()].map(level => { + linkifyAnchors(level, content); + }); +} + +// Dropdown functions + +/* When the user clicks on the navigation Documentation button, + * toggle between hiding and showing the dropdown content. + */ +function openDropdown(e) { + e.preventDefault(); + e.stopPropagation(); + // Calling close func. in case we're clicking another dropdown with one opened + closeDropdown(e); + const parent = e.target.closest("div[id$='-dropdown']"); + if (parent) { + const dropdown = parent.querySelector(".dropdown-content"); + if (dropdown) { + dropdown.classList.toggle("show"); + if (dropdown.classList.contains("show")) { + document.documentElement.addEventListener("click", closeDropdown); + } + else { + document.documentElement.removeEventListener("click", closeDropdown); + } + } + } +} + +// Close the dropdown if the user clicks (only) outside of it +function closeDropdown(e) { + const dropdown = document.querySelector("div[id$='-dropdown'] > .dropdown-content.show"); + if (dropdown) { + const currentTarget = e.currentTarget || {}; + const currentTargetParent = currentTarget.closest("div[id$='-dropdown']"); + const dropdownParent = dropdown.closest("div[id$='-dropdown']"); + if (currentTargetParent !== dropdownParent) { + dropdown.classList.remove("show"); + } + document.documentElement.removeEventListener("click", closeDropdown); + } +} + + +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); diff --git a/examples/README.md b/examples/README.md index 7a11f53f..f27e5082 100644 --- a/examples/README.md +++ b/examples/README.md @@ -2,4 +2,8 @@ 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 +* Simple TODO list +* Seed example +* Integration with Persistent (db access) diff --git a/examples/deployment/docker/Dockerfile b/examples/deployment/docker/Dockerfile index 3879fcf7..d3c7231c 100644 --- a/examples/deployment/docker/Dockerfile +++ b/examples/deployment/docker/Dockerfile @@ -1,4 +1,4 @@ -FROM fpco/stack-build:lts-14.7 as build +FROM fpco/stack-build:lts-14.22 as build RUN mkdir /opt/build RUN mkdir /opt/build/bin COPY . /opt/build @@ -14,4 +14,4 @@ RUN apt-get update && apt-get install -y \ COPY --from=build /opt/build/bin . # COPY other-files /opt/mu-docker-example/other-files EXPOSE 8080 -CMD ["/opt/mu-docker-example/mu-docker-example"] \ No newline at end of file +CMD ["/opt/mu-docker-example/mu-docker-example"] 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/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/deployment/docker/hie.yaml b/examples/deployment/docker/hie.yaml new file mode 100644 index 00000000..a094e176 --- /dev/null +++ b/examples/deployment/docker/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-docker-example:exe:mu-docker-example" } } diff --git a/examples/deployment/docker/mu-docker-example.cabal b/examples/deployment/docker/mu-docker-example.cabal index 8e061db7..84169806 100644 --- a/examples/deployment/docker/mu-docker-example.cabal +++ b/examples/deployment/docker/mu-docker-example.cabal @@ -1,25 +1,25 @@ -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-docker-example -version: 0.1.0.0 --- synopsis: --- 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 +name: mu-docker-example +version: 0.3.0.0 +synopsis: Example of a mu-haskell service deployed with Docker +description: Example of a mu-haskell service deployed with Docker. +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2020 +cabal-version: >=1.10 +category: Network +build-type: Simple +bug-reports: https://github.com/higherkindness/mu-haskell/issues +extra-source-files: README.md executable mu-docker-example - main-is: Main.hs - build-depends: base >=4.12 && <5, - mu-schema, mu-rpc, mu-grpc - default-language: Haskell2010 - ghc-options: -Wall \ No newline at end of file + main-is: Main.hs + build-depends: + base >=4.12 && <5 + , mu-grpc-server >=0.3.0 + , mu-rpc >=0.3.0 + , mu-schema >=0.3.0 + + default-language: Haskell2010 + ghc-options: -Wall diff --git a/examples/deployment/docker/stack.yaml b/examples/deployment/docker/stack.yaml index 0c2a6b3a..630a55cf 100644 --- a/examples/deployment/docker/stack.yaml +++ b/examples/deployment/docker/stack.yaml @@ -1,23 +1,16 @@ -resolver: lts-14.12 - -packages: -- . - +resolver: lts-14.22 +allow-newer: true extra-deps: -- proto3-wire-1.0.0 +# 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.1 +- compendium-client-0.2.0.0 +# dependencies of mu - http2-client-0.9.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 -- git: https://github.com/higherkindness/mu-haskell.git - commit: f61557f418b20ab0f4dae56b2b612d52a0efcca0 - subdirs: - - schema - - rpc - - grpc \ No newline at end of file +- http2-grpc-types-0.5.0.0 +- http2-grpc-proto3-wire-0.1.0.0 +- warp-grpc-0.3.0.0 +- proto3-wire-1.1.0 +- language-protobuf-1.0.1 diff --git a/examples/error-parsing/LICENSE b/examples/error-parsing/LICENSE new file mode 100644 index 00000000..ffeb95d1 --- /dev/null +++ b/examples/error-parsing/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/examples/error-parsing/errorparsing.proto b/examples/error-parsing/errorparsing.proto new file mode 100644 index 00000000..31912ba7 --- /dev/null +++ b/examples/error-parsing/errorparsing.proto @@ -0,0 +1,12 @@ +syntax = "proto3"; + +import "google/protobuf/empty.proto"; + +package hello; + +message HelloRequest { string name = 1; } +message HelloReply { string reply = 1; } + +service Service { + rpc SayHello (HelloRequest) returns (HelloReply) {} +} diff --git a/examples/error-parsing/hie.yaml b/examples/error-parsing/hie.yaml new file mode 100644 index 00000000..d6461dc9 --- /dev/null +++ b/examples/error-parsing/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-example-error-parsing:exe:error-parsing-server" } } diff --git a/examples/error-parsing/mu-example-error-parsing.cabal b/examples/error-parsing/mu-example-error-parsing.cabal new file mode 100644 index 00000000..3232d808 --- /dev/null +++ b/examples/error-parsing/mu-example-error-parsing.cabal @@ -0,0 +1,43 @@ +name: mu-example-error-parsing +version: 0.4.0.0 +synopsis: + Example error-parsing project + +description: + Example error-parsing project + +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 47 Degrees. +cabal-version: >=1.10 +category: Network +build-type: Simple +data-files: errorparsing.proto +bug-reports: https://github.com/higherkindness/mu-haskell/issues + +executable error-parsing + main-is: Main.hs + other-modules: ProtoExample + build-depends: + AC-Angle >=1 && <2 + , async >=2.2 && <3 + , base >=4.12 && <5 + , conduit >=1.3.2 && <2 + , hashable >=1.3 && <2 + , mu-grpc-server >=0.4.0 + , mu-grpc-client >=0.4.0 + , mu-protobuf >=0.4.0 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.0 + , http2-client >=0.8 + , stm >=2.5 && <3 + , stm-chans >=3 && <4 + , text >=1.2 && <2 + , time >=1.9 && <2 + , transformers >=0.5 && <0.6 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/examples/error-parsing/src/Main.hs b/examples/error-parsing/src/Main.hs new file mode 100644 index 00000000..c91ab87e --- /dev/null +++ b/examples/error-parsing/src/Main.hs @@ -0,0 +1,120 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE InstanceSigs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Main where + +import Control.Concurrent (threadDelay) +import qualified Control.Concurrent.Async as Async +import Data.Either +import Data.Text (Text) +import qualified Data.Text as T +import GHC.IO (finally) +import Mu.GRpc.Client.Record +import Mu.GRpc.Client.TyApps +import Mu.GRpc.Server +import Mu.Server hiding (resolver) +import Network.HTTP2.Client +import ProtoExample +import Prelude + +------------------------------------------------------------------------------ +-- app + +runServer :: IO () +runServer = do + runGRpcApp msgProtoBuf 8070 grpcServer + +------------------------------------------------------------------------------ +-- grpc server api + +grpcServer :: MonadServer m => SingleServerT i Service m _ +grpcServer = + singleService + ( method @"SayHello" sayHello + ) + +sayHello :: MonadServer m => HelloRequestMessage -> m HelloReplyMessage +sayHello (HelloRequestMessage nm) = do + case nm of + -- in some cases we want to throw an error, here when the name sent is 'Bob' + "Bob" -> throwError $ ServerError NotFound "Bob not there" + _ -> pure $ HelloReplyMessage ("hi, " <> nm) + +------------------------------------------------------------------------------ +-- grpc client calls + +outboundSayHello' :: HostName -> PortNumber -> T.Text -> IO (GRpcReply Text) +outboundSayHello' host port req = do + attempt <- setupGrpcClient' (grpcClientConfigSimple host port False) + case attempt of + Right c -> do + x <- fmap (\(HelloReplyMessage r) -> r) <$> outBoundSayHello c (HelloRequestMessage req) + pure x + _ -> undefined + +outBoundSayHello :: GrpcClient -> HelloRequestMessage -> IO (GRpcReply HelloReplyMessage) +outBoundSayHello = gRpcCall @'MsgProtoBuf @Service @"Service" @"SayHello" + +------------------------------------------------------------------------------ +-- test + +runTest :: IO () +runTest = do + putStrLn "testing things..." + aliceResult <- outboundSayHello' "127.0.0.1" 8070 "Alice" + putStr "The result for saying hello to Alice: " + print (show aliceResult) + bobResult <- outboundSayHello' "127.0.0.1" 8070 "Bob" + -- bobResult should give a valid error from the server (NotFound), instead of a generic "not enough bytes" + putStr "The result for saying hello to Bob: " + print bobResult + putStrLn "done with the haskell test, waiting 10 seconds before shutting down..." + threadDelay $ 10 * 1000000 -- wait 10 seconds to allow running grpcurl against the server, too. + +main :: IO () +main = do + server <- Async.async runServer + finally runTest (Async.cancel server) diff --git a/examples/error-parsing/src/ProtoExample.hs b/examples/error-parsing/src/ProtoExample.hs new file mode 100644 index 00000000..0cd65a75 --- /dev/null +++ b/examples/error-parsing/src/ProtoExample.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module ProtoExample where + +import Data.Text as T +import GHC.Generics +import Mu.Quasi.GRpc +import Mu.Schema + +grpc "TheSchema" id "errorparsing.proto" + +data HelloRequestMessage = HelloRequestMessage {name :: T.Text} + deriving + ( Eq, + Show, + Generic, + ToSchema TheSchema "HelloRequest", + FromSchema TheSchema "HelloRequest" + ) + +data HelloReplyMessage = HelloReplyMessage {reply :: T.Text} + deriving + ( Eq, + Show, + Generic, + ToSchema TheSchema "HelloReply", + FromSchema TheSchema "HelloReply" + ) 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/health-check/healthcheck.avdl b/examples/health-check/healthcheck.avdl new file mode 100644 index 00000000..85d5d802 --- /dev/null +++ b/examples/health-check/healthcheck.avdl @@ -0,0 +1,14 @@ +@namespace("healthcheck") +protocol HealthCheckServiceFS2 { + record HealthCheck { string nameService; } + record ServerStatus { string status; } + record HealthStatus { HealthCheck hc; ServerStatus status; } + record AllStatus { array all; } + + void setStatus(HealthStatus newStatus); + ServerStatus check(HealthCheck service); + void clearStatus(HealthCheck service); + AllStatus checkAll(); + void cleanAll(); + // stream ServerStatus watch(HealthCheck service); +} diff --git a/examples/health-check/healthcheck.proto b/examples/health-check/healthcheck.proto index de3a1a9e..612fb7b4 100644 --- a/examples/health-check/healthcheck.proto +++ b/examples/health-check/healthcheck.proto @@ -4,7 +4,7 @@ import "google/protobuf/empty.proto"; package healthcheck; -service HealthCheckService { +service HealthCheckServiceFS2 { rpc setStatus (HealthStatus) returns (google.protobuf.Empty) {} rpc check (HealthCheck) returns (ServerStatus) {} rpc clearStatus (HealthCheck) returns (google.protobuf.Empty) {} @@ -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/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 c7e026c3..449318de 100644 --- a/examples/health-check/mu-example-health-check.cabal +++ b/examples/health-check/mu-example-health-check.cabal @@ -1,60 +1,87 @@ -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-health-check -version: 0.1.0.0 --- synopsis: --- 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: Definition - build-depends: base >=4.12 && <5, text, - mu-schema, mu-rpc, mu-grpc, - stm, stm-containers, - conduit, stm-conduit, - deferred-folds - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall +name: mu-example-health-check +version: 0.4.0.0 +synopsis: + Example health-check project from mu-scala (with protobuf) ported to mu-haskell + +description: + Example health-check project from mu-scala (with protobuf) ported to mu-haskell. + +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 47 Degrees. +category: Network +build-type: Simple +cabal-version: >=1.10 +data-files: healthcheck.proto +bug-reports: https://github.com/higherkindness/mu-haskell/issues executable health-server - main-is: Server.hs - other-modules: Definition - build-depends: base >=4.12 && <5, text, - mu-schema, mu-rpc, mu-grpc, - stm, stm-containers, - conduit, stm-conduit, - deferred-folds - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall + main-is: Server.hs + other-modules: Definition + build-depends: + aeson + , async >=2.2 && <3 + , base >=4.12 && <5 + , conduit >=1.3.2 && <2 + , deferred-folds >=0.9 && <0.10 + , mu-graphql >=0.4.0 + , mu-grpc-server >=0.4.0 + , mu-prometheus >=0.4.0 + , mu-protobuf >=0.4.0 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.0 + , mu-servant-server >=0.4.0 + , mu-tracing >=0.4.0 + , prometheus-client >=1 && <2 + , servant-server + , servant-swagger-ui + , stm >=2.5 && <3 + , stm-conduit >=4 && <5 + , stm-containers >=1.1 && <2 + , swagger2 + , text >=1.2 && <2 + , tracing-control >=0.0.6 + , wai >=3.2 && <4 + , warp >=3.3 && <4 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall 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 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall + main-is: ClientTyApps.hs + other-modules: Definition + build-depends: + aeson + , base >=4.12 && <5 + , conduit >=1.3.2 && <2 + , mu-grpc-client >=0.4.0 + , mu-protobuf >=0.4.0 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.0 + , swagger2 + , text >=1.2 && <2 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall 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 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall \ No newline at end of file + main-is: ClientRecord.hs + other-modules: Definition + build-depends: + aeson + , base >=4.12 && <5 + , conduit >=1.3.2 && <2 + , mu-grpc-client >=0.4.0 + , mu-protobuf >=0.4.0 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.0 + , swagger2 + , text >=1.2 && <2 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/examples/health-check/src/ClientRecord.hs b/examples/health-check/src/ClientRecord.hs index 6b62de4c..1ded6d43 100644 --- a/examples/health-check/src/ClientRecord.hs +++ b/examples/health-check/src/ClientRecord.hs @@ -1,70 +1,71 @@ -{-# language DataKinds, ScopedTypeVariables, - TypeOperators, OverloadedStrings, - FlexibleContexts, AllowAmbiguousTypes, - DeriveGeneric, TypeApplications #-} +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language DeriveGeneric #-} +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} 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.Client.GRpc.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 @"" +buildHealthCall = buildService @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"" 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" 50051 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 (Just hcm) (Just $ 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 961f1cf7..c0b9abd7 100644 --- a/examples/health-check/src/ClientTyApps.hs +++ b/examples/health-check/src/ClientTyApps.hs @@ -1,59 +1,60 @@ -{-# language DataKinds, ScopedTypeVariables, - TypeApplications, TypeOperators, - FlexibleContexts, AllowAmbiguousTypes, - OverloadedStrings #-} +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} 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.Client.GRpc.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" 50051 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 @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"check" client hcm + putStrLn ("UNARY: Actually the status is " <> show rknown) + update client who "SERVING" + r <- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"clearStatus" client hcm + putStrLn ("UNARY: Was clearing successful? " <> show r) + runknown :: GRpcReply ServerStatusMsg + <- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"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 @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"setStatus" client + (HealthStatusMsg (Just hcm) (Just $ ServerStatusMsg (T.pack newstatus))) + putStrLn ("UNARY: Was setting successful? " <> show r) + rstatus :: GRpcReply ServerStatusMsg + <- gRpcCall @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"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 @'MsgProtoBuf @HealthCheckService @"HealthCheckServiceFS2" @"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 c7917523..5e5a2046 100644 --- a/examples/health-check/src/Definition.hs +++ b/examples/health-check/src/Definition.hs @@ -1,56 +1,65 @@ -{-# language PolyKinds, DataKinds, TypeOperators, - MultiParamTypeClasses, TypeFamilies, - FlexibleInstances, FlexibleContexts, - DeriveGeneric, DeriveAnyClass, - DuplicateRecordFields, OverloadedLabels, - TemplateHaskell #-} +{-# language CPP #-} +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingVia #-} +{-# 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 qualified Data.Aeson as J +import qualified Data.Swagger as Swagger +import Data.Text as T +import GHC.Generics -import Mu.Schema -import Mu.Rpc.Quasi +import Mu.Adapter.Json () +import Mu.Quasi.GRpc +import Mu.Schema -$(grpc "HealthCheckSchema" id "healthcheck.proto") +#if __GHCIDE__ +grpc "HealthCheckSchema" id "examples/health-check/protobuf/healthcheck.proto" +#else +grpc "HealthCheckSchema" id "healthcheck.proto" +#endif + +type HealthCheckService = HealthCheckServiceFS2 newtype HealthCheckMsg = HealthCheckMsg { nameService :: T.Text } - deriving (Eq, Show, Ord, Generic, HasSchema HealthCheckSchema "HealthCheck") + deriving ( Eq, Show, Ord, Generic + , ToSchema HealthCheckSchema "HealthCheck" + , FromSchema HealthCheckSchema "HealthCheck" + , Swagger.ToSchema ) + deriving (J.ToJSON, J.FromJSON) + via (WithSchema HealthCheckSchema "HealthCheck" HealthCheckMsg) newtype ServerStatusMsg = ServerStatusMsg { status :: T.Text } - deriving (Eq, Show, Ord, Generic, HasSchema HealthCheckSchema "ServerStatus") + deriving ( Eq, Show, Ord, Generic + , ToSchema HealthCheckSchema "ServerStatus" + , FromSchema HealthCheckSchema "ServerStatus" + , Swagger.ToSchema ) + deriving (J.ToJSON, J.FromJSON) + via (WithSchema HealthCheckSchema "ServerStatus" ServerStatusMsg) 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 HealthCheckSchema "HealthStatus" + , FromSchema HealthCheckSchema "HealthStatus" + , Swagger.ToSchema ) + deriving (J.ToJSON, J.FromJSON) + via (WithSchema HealthCheckSchema "HealthStatus" HealthStatusMsg) 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")) - ] --} \ No newline at end of file + deriving ( Eq, Show, Ord, Generic + , ToSchema HealthCheckSchema "AllStatus" + , FromSchema HealthCheckSchema "AllStatus" + , Swagger.ToSchema ) + deriving (J.ToJSON, J.FromJSON) + via (WithSchema HealthCheckSchema "AllStatus" AllStatusMsg) diff --git a/examples/health-check/src/Server.hs b/examples/health-check/src/Server.hs index 3508c48f..73f7af72 100644 --- a/examples/health-check/src/Server.hs +++ b/examples/health-check/src/Server.hs @@ -1,26 +1,72 @@ -{-# language OverloadedStrings, PartialTypeSignatures #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language PolyKinds #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +-- this line must appear *after* TypeFamilies +{-# language NoMonoLocalBinds #-} + module Main where -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 Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Monad.IO.Class +import Control.Monad.Trace +import Data.Conduit +import qualified Data.Conduit.Combinators as C +import Data.Conduit.TMChan +import Data.Maybe (fromMaybe) +import Data.Proxy +import qualified Data.Text as T +import DeferredFolds.UnfoldlM +import Monitor.Tracing.Zipkin (Endpoint (..)) +import Network.Wai.Handler.Warp +import Prometheus +import Servant.Server (serve) +import Servant.Swagger.UI +import qualified StmContainers.Map as M -import Mu.Server -import Mu.Server.GRpc +import Mu.GraphQL.Server +import Mu.GRpc.Server +import Mu.Instrumentation.Prometheus +import Mu.Instrumentation.Tracing +import Mu.Rpc.Annotations +import Mu.Schema.Annotations +import Mu.Servant.Server +import Mu.Server -import Definition +import Definition main :: IO () -main = do +main = do + -- Initialize prometheus + met <- initPrometheus "health" + -- Initialize zipkin + zpk <- newZipkin defaultZipkinSettings + { settingsPublishPeriod = Just 1 + , settingsEndpoint = Just $ Endpoint (Just "me") Nothing Nothing Nothing } + let rootInfo = MuTracing alwaysSampled "health-check" + -- Initialize app m <- M.newIO upd <- newTBMChanIO 100 + -- Put together the server + let s = zipkin rootInfo $ prometheus met $ server m upd + servantAPI = packageAPI s + servant = servantServerHandlersExtra (toHandler . runZipkin zpk) + (swaggerSchemaUIServer (swagger s)) s + -- Run the app putStrLn "running health check application" - runGRpcApp 8080 (server m upd) + runConcurrently $ (\_ _ _ _ -> ()) + <$> Concurrently (runner 8080 (serve servantAPI servant)) + <*> Concurrently (runner 50051 (gRpcAppTrans msgProtoBuf (runZipkin zpk) s)) + <*> Concurrently (runner 50052 (gRpcAppTrans msgAvro (runZipkin zpk) s)) + <*> Concurrently (runner 50053 (graphQLAppTransQuery (runZipkin zpk) s + (Proxy @"HealthCheckServiceFS2"))) + where runner p app = run p (prometheusWai ["metrics"] app) -- Server implementation -- https://github.com/higherkindness/mu/blob/master/modules/health-check-unary/src/main/scala/higherkindness/mu/rpc/healthcheck/unary/handler/HealthServiceImpl.scala @@ -28,49 +74,106 @@ main = do type StatusMap = M.Map T.Text T.Text type StatusUpdates = TBMChan HealthStatusMsg -server :: StatusMap -> StatusUpdates -> ServerIO HealthCheckService _ +server :: (MonadServer m, MonadTrace m) + => StatusMap -> StatusUpdates + -> ServerT '[] info HealthCheckService m _ 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 - -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) - -clearStatus_ :: StatusMap -> HealthCheckMsg -> IO () -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) - -cleanAll_ :: StatusMap -> IO () -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 + = wrapServer (\info h -> liftIO (print info) >> h) $ + singleService ( method @"setStatus" $ setStatus_ m upd + , method @"check" $ checkH_ m + , method @"clearStatus" $ clearStatus_ m + , method @"checkAll" $ checkAll_ m + , method @"cleanAll" $ cleanAll_ m + , method @"watch" $ watch_ upd) + +setStatus_ :: (MonadServer m, MonadTrace m) + => StatusMap -> StatusUpdates -> HealthStatusMsg + -> m () +setStatus_ m upd + s@(HealthStatusMsg (Just (HealthCheckMsg nm)) (Just (ServerStatusMsg ss))) + = childSpan "setStatus" $ 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_ :: (MonadServer m, MonadTrace m) + => StatusMap -> HealthCheckMsg + -> m ServerStatusMsg +checkH_ _ (HealthCheckMsg "") = serverError (ServerError Invalid "no server name given") +checkH_ m (HealthCheckMsg nm) = alwaysOk $ do + putStr "check: " >> print nm + ss <- atomically $ M.lookup nm m + pure $ ServerStatusMsg (fromMaybe "" ss) + +clearStatus_ :: (MonadServer m, MonadTrace m) + => StatusMap -> HealthCheckMsg -> m () +clearStatus_ _ (HealthCheckMsg "") = serverError (ServerError Invalid "no server name given") +clearStatus_ m (HealthCheckMsg nm) = alwaysOk $ do + putStr "clearStatus: " >> print nm + atomically $ M.delete nm m + +checkAll_ :: (MonadServer m, MonadTrace m) + => StatusMap -> m AllStatusMsg +checkAll_ m = alwaysOk $ 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 (Just (HealthCheckMsg k)) (Just (ServerStatusMsg v)) + +cleanAll_ :: (MonadServer m, MonadTrace m) + => StatusMap -> m () +cleanAll_ m = alwaysOk $ do + putStrLn "cleanAll" + atomically $ M.reset m + +watch_ :: (MonadServer m, MonadTrace m) + => StatusUpdates + -> HealthCheckMsg + -> ConduitT ServerStatusMsg Void m () + -> m () +watch_ upd hcm@(HealthCheckMsg nm) sink = do + alwaysOk (putStr "watch: " >> print nm) + runConduit $ sourceTBMChan upd + .| 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 -> pure () + +instance MonadMonitor m => MonadMonitor (TraceT m) + +-- Information for servant + +type instance AnnotatedPackage ServantRoute HealthCheckServiceFS2 + = '[ 'AnnPackage ('ServantAdditional (SwaggerSchemaUI "swagger-ui" "swagger.json")) + , 'AnnService "HealthCheckServiceFS2" + ('ServantTopLevelRoute '["health"]) + , 'AnnMethod "HealthCheckServiceFS2" "setStatus" + ('ServantRoute '["status"] 'POST 200) + , 'AnnMethod "HealthCheckServiceFS2" "check" + ('ServantRoute '["status"] 'GET 200) + , 'AnnMethod "HealthCheckServiceFS2" "clearStatus" + ('ServantRoute '["status"] 'DELETE 200) + , 'AnnMethod "HealthCheckServiceFS2" "checkAll" + ('ServantRoute '["all", "status"] 'GET 200) + , 'AnnMethod "HealthCheckServiceFS2" "cleanAll" + ('ServantRoute '["all", "status"] 'DELETE 200) + , 'AnnMethod "HealthCheckServiceFS2" "watch" + ('ServantRoute '["watch"] 'GET 200) + ] + +type instance AnnotatedSchema ServantContentTypes HealthCheckSchema + = '[ 'AnnType "HealthCheck" DefaultServantContentTypes + , 'AnnType "ServerStatus" DefaultServantContentTypes + , 'AnnType "HealthStatus" DefaultServantContentTypes + , 'AnnType "AllStatus" DefaultServantContentTypes + ] diff --git a/examples/library b/examples/library new file mode 160000 index 00000000..b2cfb27c --- /dev/null +++ b/examples/library @@ -0,0 +1 @@ +Subproject commit b2cfb27c24d14fe51c0d7d13b602eb7584a9a598 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/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 c9991efc..b77acc80 100644 --- a/examples/route-guide/mu-example-route-guide.cabal +++ b/examples/route-guide/mu-example-route-guide.cabal @@ -1,37 +1,41 @@ -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-route-guide +version: 0.4.0.0 +synopsis: + Example route-guide project from mu-scala ported to mu-haskell -name: mu-example-route-guide -version: 0.1.0.0 --- synopsis: --- description: --- bug-reports: -license: Apache-2.0 -license-file: LICENSE -author: Alejandro Serrano -maintainer: alejandro.serrano@47deg.com --- copyright: -category: Network -build-type: Simple +description: + Example route-guide project from mu-scala ported to mu-haskell. -library - exposed-modules: Definition - build-depends: base >=4.12 && <5, text, - mu-schema, mu-rpc, mu-grpc, - hashable - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 47 Degrees. +cabal-version: >=1.10 +category: Network +build-type: Simple +data-files: routeguide.proto +bug-reports: https://github.com/higherkindness/mu-haskell/issues executable route-guide-server - main-is: Server.hs - other-modules: Definition - build-depends: base >=4.12 && <5, text, - mu-schema, mu-rpc, mu-grpc, - stm, stm-chans, hashable, - conduit, AC-Angle, time, async - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall \ No newline at end of file + main-is: Server.hs + other-modules: Definition + build-depends: + AC-Angle >=1 && <2 + , async >=2.2 && <3 + , base >=4.12 && <5 + , conduit >=1.3.2 && <2 + , hashable >=1.3 && <2 + , mu-grpc-server >=0.4.0 + , mu-protobuf >=0.4.0 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.0 + , stm >=2.5 && <3 + , stm-chans >=3 && <4 + , text >=1.2 && <2 + , time >=1.9 && <2 + , transformers >=0.5 && <0.6 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall diff --git a/examples/route-guide/src/Definition.hs b/examples/route-guide/src/Definition.hs index 47b0a726..06fd916d 100644 --- a/examples/route-guide/src/Definition.hs +++ b/examples/route-guide/src/Definition.hs @@ -1,71 +1,57 @@ -{-# language PolyKinds, DataKinds, TypeOperators, - MultiParamTypeClasses, TypeFamilies, - FlexibleInstances, FlexibleContexts, - DeriveGeneric, DeriveAnyClass, - DuplicateRecordFields, TemplateHaskell #-} +{-# language CPP #-} +{-# 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.Schema.Adapter.ProtoBuf -import Mu.Rpc -import Mu.Rpc.Quasi +import Mu.Quasi.GRpc +import Mu.Schema -$(grpc "RouteGuideSchema" id "routeguide.proto") +#if __GHCIDE__ +grpc "RouteGuideSchema" id "examples/route-guide/routeguide.proto" +#else +grpc "RouteGuideSchema" id "routeguide.proto" +#endif data Point = Point { latitude, longitude :: Int32 } - deriving (Eq, Show, Ord, Generic, Hashable, HasSchema RouteGuideSchema "Point") + deriving ( Eq, Show, Ord, Generic, Hashable + , ToSchema RouteGuideSchema "Point" + , FromSchema 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 RouteGuideSchema "Rectangle" + , FromSchema RouteGuideSchema "Rectangle" ) data Feature - = Feature { name :: T.Text, location :: Point } - deriving (Eq, Show, Ord, Generic, HasSchema RouteGuideSchema "Feature") + = Feature { name :: T.Text, location :: Maybe Point } + deriving ( Eq, Show, Ord, Generic + , ToSchema RouteGuideSchema "Feature" + , FromSchema 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 :: T.Text, location :: Maybe Point } + deriving ( Eq, Show, Ord, Generic + , ToSchema RouteGuideSchema "RouteNote" + , FromSchema RouteGuideSchema "RouteNote" ) data RouteSummary = RouteSummary { point_count, feature_count, distance, elapsed_time :: Int32 } - deriving (Eq, Show, Ord, Generic, HasSchema RouteGuideSchema "RouteSummary") - -{- -type RG = 'FromSchema RouteGuideSchema -type RouteGuideService - = 'Service "RouteGuideService" '[Package "routeguide"] - '[ 'Method "GetFeature" '[] '[ 'ArgSingle (RG "Point") ] ('RetSingle (RG "Feature")) - , 'Method "ListFeatures" '[] '[ 'ArgSingle (RG "Rectangle") ] ('RetStream (RG "Feature")) - , 'Method "RecordRoute" '[] '[ 'ArgStream (RG "Point") ] ('RetSingle (RG "RouteSummary")) - , 'Method "RouteChat" '[] '[ 'ArgStream (RG "RouteNote") ] ('RetStream (RG "RouteNote")) - ] - -type RouteGuideSchema - = '[ 'DRecord "Point" '[] - '[ 'FieldDef "latitude" '[ProtoBufId 1] ('TPrimitive Int32) - , 'FieldDef "longitude" '[ProtoBufId 2] ('TPrimitive Int32) ] - , 'DRecord "Rectangle" '[] - '[ 'FieldDef "lo" '[ProtoBufId 1] ('TSchematic "Point") - , 'FieldDef "hi" '[ProtoBufId 2] ('TSchematic "Point") ] - , 'DRecord "Feature" '[] - '[ 'FieldDef "name" '[ProtoBufId 1] ('TPrimitive T.Text) - , 'FieldDef "location" '[ProtoBufId 2] ('TSchematic "Point") ] - , 'DRecord "FeatureDatabase" '[] - '[ 'FieldDef "feature" '[ProtoBufId 1] ('TList ('TSchematic "Feature")) ] - , 'DRecord "RouteNote" '[] - '[ 'FieldDef "message" '[ProtoBufId 2] ('TPrimitive T.Text) - , 'FieldDef "location" '[ProtoBufId 1] ('TSchematic "Point") ] - , 'DRecord "RouteSummary" '[] - '[ 'FieldDef "point_count" '[ProtoBufId 1] ('TPrimitive Int32) - , 'FieldDef "feature_count" '[ProtoBufId 2] ('TPrimitive Int32) - , 'FieldDef "distance" '[ProtoBufId 3] ('TPrimitive Int32) - , 'FieldDef "elapsed_time" '[ProtoBufId 4] ('TPrimitive Int32) ] - ] --} \ No newline at end of file + deriving ( Eq, Show, Ord, Generic + , ToSchema RouteGuideSchema "RouteSummary" + , FromSchema RouteGuideSchema "RouteSummary" ) diff --git a/examples/route-guide/src/Server.hs b/examples/route-guide/src/Server.hs index 8b373a54..28e133a2 100644 --- a/examples/route-guide/src/Server.hs +++ b/examples/route-guide/src/Server.hs @@ -1,32 +1,38 @@ -{-# language OverloadedStrings, PartialTypeSignatures, - DuplicateRecordFields, ScopedTypeVariables #-} +{-# language DataKinds #-} +{-# language DuplicateRecordFields #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + 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.Server.GRpc - -import Definition +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Concurrent.STM.TBMChan +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.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 - runGRpcApp 8080 (server features routeNotes) + runGRpcApp msgProtoBuf 8080 (server features routeNotes) -- Utilities -- https://github.com/higherkindness/mu/blob/master/modules/examples/routeguide/common/src/main/scala/Utils.scala @@ -34,16 +40,17 @@ 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 lox loy)) (Just (Point hix hiy))) + (Point x 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) @@ -54,65 +61,83 @@ 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)) - in fromInteger $ r * ceiling c + c = 2 * atan2 (sqrt a) (sqrt (1 - a)) + in fromInteger $ r * ceiling c where int32ToDouble :: Int32 -> Double int32ToDouble = fromInteger . toInteger -- 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 info RouteGuideService _ 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) - -listFeatures :: Features -> Rectangle -> ConduitT Feature Void IO () -> IO () -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) + = singleService ( method @"GetFeature" $ getFeature f + , method @"ListFeatures" $ listFeatures f + , method @"RecordRoute" $ recordRoute f + , method @"RouteChat" $ routeChat m) + +getFeature :: Features -> Point -> ServerErrorIO Feature +getFeature fs p = pure $ fromMaybe nilFeature (findFeatureIn fs p) + where nilFeature = Feature "" (Just (Point 0 0)) + +listFeatures :: Features -> Rectangle + -> ConduitT Feature Void ServerErrorIO () + -> ServerErrorIO () +listFeatures fs rect result = runConduit $ sourceList (featuresWithinBounds fs rect) .| result + +recordRoute :: Features + -> ConduitT () Point ServerErrorIO () + -> ServerErrorIO RouteSummary +recordRoute fs ps = do + initialTime <- liftIO getCurrentTime + (\(rs, _, _) -> rs) <$> runConduit (ps .| C.foldM step (initial, Nothing, initialTime)) + where + initial = RouteSummary 0 0 0 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 = case previous of + Nothing -> 0 + Just d -> d `calcDistance` point + new_elapsed = diffUTCTime currentTime startTime + 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) + (floor new_elapsed) + pure (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 - -readStmMap :: Show b => (a -> b -> Bool) -> TMVar a -> TBMChan b -> ConduitT () b IO () + -> ConduitT () RouteNote ServerErrorIO () + -> ConduitT RouteNote Void ServerErrorIO () + -> ServerErrorIO () +routeChat notesMap inS outS = do + toWatch <- liftIO newEmptyTMVarIO + -- 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)-> Just l1 == l2) toWatch notesMap .| outS + res <- liftIO $ concurrently inA outA + case res of + (Right _, Right _) -> pure () + (Left e, _) -> serverError e + (_, Left e) -> serverError e + where + addNoteToMap :: TMVar Point -> RouteNote -> ServerErrorIO () + addNoteToMap toWatch newNote@(RouteNote _ (Just loc)) = liftIO $ atomically $ do + _ <- tryTakeTMVar toWatch + putTMVar toWatch loc + writeTBMChan notesMap newNote + addNoteToMap _toWatch _ = pure () + +readStmMap :: (MonadIO m, Show b) => (a -> b -> Bool) -> TMVar a -> TBMChan b -> ConduitT () b m () readStmMap p toWatch m = go where go = do v <- liftIO $ atomically $ (,) <$> readTBMChan m <*> tryReadTMVar toWatch case v of - (Nothing, _) -> return () + (Nothing, _) -> pure () (Just v', Just e') | p e' v' -> liftIO (print v') >> yield v' >> go - _ -> go \ No newline at end of file + _ -> go 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..ffeb95d1 --- /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 © 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/examples/seed/README.md b/examples/seed/README.md new file mode 100644 index 00000000..c071e04d --- /dev/null +++ b/examples/seed/README.md @@ -0,0 +1,18 @@ +# Seed RPC example with Protobuf + +## Execution + +Running the server: + +```bash +stack run mu-example-seed-protobuf +``` + +[comment]: # (Start Copyright) +# Copyright + +Mu is designed and developed by 47 Degrees + +Copyright © 2020 47 Degrees. + +[comment]: # (End Copyright) diff --git a/examples/seed/Setup.hs b/examples/seed/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/examples/seed/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/seed/hie.yaml b/examples/seed/hie.yaml new file mode 100644 index 00000000..dda486ae --- /dev/null +++ b/examples/seed/hie.yaml @@ -0,0 +1,8 @@ +cradle: + stack: + - path: "./src/Main.hs" + component: "mu-example-seed:exe:seed-server" + - path: "./src/Lens.hs" + component: "mu-example-seed:exe:seed-server-lens" + - path: "./src/Optics.hs" + component: "mu-example-seed:exe:seed-server-optics" diff --git a/examples/seed/mu-example-seed.cabal b/examples/seed/mu-example-seed.cabal new file mode 100644 index 00000000..7b698834 --- /dev/null +++ b/examples/seed/mu-example-seed.cabal @@ -0,0 +1,85 @@ +name: mu-example-seed +version: 0.3.0.0 +synopsis: + Example seed project from mu-scala (with protobuf) ported to mu-haskell + +description: + Example seed project from mu-scala (with protobuf) ported to mu-haskell. + +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 +data-files: + *.proto + *.avdl + +homepage: + https://github.com/higherkindness/mu-haskell/examples/seed/protobuf#readme + +bug-reports: https://github.com/higherkindness/mu-haskell/issues + +executable seed-server + hs-source-dirs: src + main-is: Main.hs + other-modules: Schema + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances + build-depends: + async >=2.2 && <3 + , base >=4.12 && <5 + , conduit >=1.3.2 && <2 + , monad-logger >=0.3 && <0.4 + , mu-graphql >=0.4.0 + , mu-grpc-server >=0.4.0 + , mu-protobuf >=0.4.0 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.0 + , random >=1.1 && <2 + , stm >=2.5 && <3 + , text >=1.2 && <2 + , wai >=3.2 && <4 + +executable seed-server-optics + hs-source-dirs: src + main-is: Optics.hs + other-modules: Schema + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances + build-depends: + base >=4.12 && <5 + , conduit >=1.3.2 && <2 + , monad-logger >=0.3 && <0.4 + , mu-grpc-server >=0.4.0 + , mu-optics >=0.3.0 + , mu-protobuf >=0.4.0 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.0 + , random >=1.1 && <2 + , stm >=2.5 && <3 + , text >=1.2 && <2 + +executable seed-server-lens + hs-source-dirs: src + main-is: Lens.hs + other-modules: Schema + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances + build-depends: + base >=4.12 && <5 + , conduit >=1.3.2 && <2 + , lens + , monad-logger >=0.3 && <0.4 + , mu-grpc-server >=0.4.0 + , mu-lens >=0.3.0 + , mu-protobuf >=0.4.0 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.0 + , random >=1.1 && <2 + , stm >=2.5 && <3 + , text >=1.2 && <2 diff --git a/examples/seed/seed.avdl b/examples/seed/seed.avdl new file mode 100644 index 00000000..858a0d53 --- /dev/null +++ b/examples/seed/seed.avdl @@ -0,0 +1,25 @@ +@namespace("example.seed.server.protocol.avro") +protocol Service { + record Person { + string name; + int age; + } + + error NotFoundError { + string message; + } + + error DuplicatedPersonError { + string message; + } + + record PeopleRequest { + string name; + } + + record PeopleResponse { + union { Person, NotFoundError, DuplicatedPersonError } result; + } + + example.seed.server.protocol.avro.PeopleResponse getPerson(example.seed.server.protocol.avro.PeopleRequest request); +} diff --git a/examples/seed/seed.graphql b/examples/seed/seed.graphql new file mode 100644 index 00000000..e2bcbb65 --- /dev/null +++ b/examples/seed/seed.graphql @@ -0,0 +1,31 @@ +schema { + query: PeopleService +} + +type PeopleService { + getPerson(arg: PeopleRequest): PeopleResponse + getWeather(arg: WeatherRequest): WeatherResponse +} + +type Person { + name: String! + age: Int! +} +input PeopleRequest { + name: String! +} +type PeopleResponse { + person: Person +} + +enum Weather { + sunny + cloudy + rainy +} +input WeatherRequest { + currentWeather: Weather +} +type WeatherResponse { + message: String! +} diff --git a/examples/seed/seed.proto b/examples/seed/seed.proto new file mode 100644 index 00000000..76597995 --- /dev/null +++ b/examples/seed/seed.proto @@ -0,0 +1,24 @@ +syntax = "proto3"; +package seed; + +message Person { string name = 1; int32 age = 2; } +message PeopleRequest { string name = 1; } +message PeopleResponse { Person person = 1; } + +enum Weather { + sunny = 0; + cloudy = 1; + rainy = 2; +} +message WeatherRequest { + Weather currentWeather = 1; +} +message WeatherResponse { + string message = 1; +} + +service PeopleService { + rpc getPerson (PeopleRequest) returns (PeopleResponse); + rpc getPersonStream (stream PeopleRequest) returns (stream PeopleResponse); + rpc getWeather (WeatherRequest) returns (WeatherResponse); +} diff --git a/examples/seed/src/Lens.hs b/examples/seed/src/Lens.hs new file mode 100644 index 00000000..2599bb54 --- /dev/null +++ b/examples/seed/src/Lens.hs @@ -0,0 +1,74 @@ +{-# language DataKinds #-} +{-# language DuplicateRecordFields #-} +{-# language FlexibleContexts #-} +{-# language OverloadedLabels #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Main where + +import Control.Concurrent (threadDelay) +import Control.Lens +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.Schema +import Mu.Schema.Lens +import Mu.Server + +import Schema + +type Person = Term SeedSchema (SeedSchema :/: "Person") +type PeopleRequest = Term SeedSchema (SeedSchema :/: "PeopleRequest") +type PeopleResponse = Term SeedSchema (SeedSchema :/: "PeopleResponse") +type Weather = Term SeedSchema (SeedSchema :/: "Weather") +type WeatherRequest = Term SeedSchema (SeedSchema :/: "WeatherRequest") +type WeatherResponse = Term SeedSchema (SeedSchema :/: "WeatherResponse") + +main :: IO () +main = do + putStrLn "running seed application" + runGRpcAppTrans msgProtoBuf 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 :: (MonadServer m, MonadLogger m) => SingleServerT info PeopleService m _ +server = singleService + ( method @"getPerson" getPerson + , method @"getPersonStream" getPersonStream + , method @"getWeather" getWeather ) + +evolvePerson :: PeopleRequest -> PeopleResponse +evolvePerson req = record (Just $ record (req ^. #name, 18)) + +getPerson :: Monad m => PeopleRequest -> m PeopleResponse +getPerson = pure . evolvePerson + +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 + logDebugN $ T.pack $ "stream request: " ++ show req + pure $ evolvePerson req + +getWeather :: (MonadServer m) + => WeatherRequest + -> m WeatherResponse +getWeather msg + = pure $ record $ go $ msg ^. #currentWeather + where go e | e `is` #sunny = "is sunny! 😄" + | e `is` #cloudy = "is cloudy 😟" + | e `is` #rainy = "is rainy... 😭" + | otherwise = error "this should never happen" diff --git a/examples/seed/src/Main.hs b/examples/seed/src/Main.hs new file mode 100644 index 00000000..836004b2 --- /dev/null +++ b/examples/seed/src/Main.hs @@ -0,0 +1,117 @@ +{-# language DataKinds #-} +{-# language DeriveAnyClass #-} +{-# language DeriveGeneric #-} +{-# language DerivingVia #-} +{-# language DuplicateRecordFields #-} +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Main where + +import Control.Concurrent (threadDelay) +import Control.Concurrent.Async +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Logger +import Data.Conduit +import Data.Conduit.Combinators as C +import Data.Int +import Data.Text as T +import GHC.Generics +import Mu.GraphQL.Server +import Mu.GRpc.Server +import Mu.Schema +import Mu.Server + +import Schema + +data Person = Person + { name :: T.Text + , age :: Int32 + } deriving ( Eq, Show, Ord, Generic + , ToSchema SeedSchema "Person" + , FromSchema SeedSchema "Person" ) + +newtype PeopleRequest = PeopleRequest + { name :: T.Text + } deriving ( Eq, Show, Ord, Generic + , ToSchema SeedSchema "PeopleRequest" + , FromSchema SeedSchema "PeopleRequest" ) + +newtype PeopleResponse = PeopleResponse + { person :: Maybe Person + } deriving ( Eq, Show, Ord, Generic + , ToSchema SeedSchema "PeopleResponse" + , FromSchema SeedSchema "PeopleResponse" ) + +type WeatherMapping + = '[ "SUNNY" ':-> "sunny" + , "CLOUDY" ':-> "cloudy" + , "RAINY" ':-> "rainy" ] + +data Weather = SUNNY | CLOUDY | RAINY + deriving ( Eq, Show, Ord, Generic ) + deriving ( ToSchema SeedSchema "Weather" + , FromSchema SeedSchema "Weather" ) + via ( CustomFieldMapping "Weather" WeatherMapping Weather ) + +newtype WeatherRequest = WeatherRequest + { currentWeather :: Weather + } deriving ( Eq, Show, Ord, Generic + , ToSchema SeedSchema "WeatherRequest" + , FromSchema SeedSchema "WeatherRequest" ) + +newtype WeatherResponse = WeatherResponse + { message :: T.Text + } deriving ( Eq, Show, Ord, Generic + , ToSchema SeedSchema "WeatherResponse" + , FromSchema SeedSchema "WeatherResponse" ) + +main :: IO () +main = do + putStrLn "running seed application" + runConcurrently $ (\_ _ _ -> ()) + <$> Concurrently (runGRpcAppTrans msgProtoBuf 8080 runStderrLoggingT server) + <*> Concurrently (runGRpcAppTrans msgAvro 8081 runStderrLoggingT server) + <*> Concurrently (runGraphQLAppTrans 50053 runStderrLoggingT server + (Proxy @('Just "PeopleService")) + (Proxy @'Nothing) (Proxy @'Nothing)) + +-- 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) => SingleServerT info PeopleService m _ +server = singleService + ( method @"getPerson" getPerson + , method @"getPersonStream" getPersonStream + , method @"getWeather" getWeather + ) + +evolvePerson :: PeopleRequest -> PeopleResponse +evolvePerson (PeopleRequest n) = PeopleResponse $ Just $ Person n 18 + +getPerson :: Monad m => PeopleRequest -> m PeopleResponse +getPerson = pure . evolvePerson + +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 + logDebugN $ T.pack $ "stream request: " ++ show req + pure $ evolvePerson req + +getWeather :: (MonadServer m) + => WeatherRequest + -> m WeatherResponse +getWeather (WeatherRequest w) + = pure $ WeatherResponse $ go w + where go SUNNY = "is sunny! 😄" + go CLOUDY = "is cloudy 😟" + go RAINY = "is rainy... 😭" diff --git a/examples/seed/src/Optics.hs b/examples/seed/src/Optics.hs new file mode 100644 index 00000000..a9eb0221 --- /dev/null +++ b/examples/seed/src/Optics.hs @@ -0,0 +1,73 @@ +{-# language DataKinds #-} +{-# language DuplicateRecordFields #-} +{-# language FlexibleContexts #-} +{-# language OverloadedLabels #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# 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.Schema +import Mu.Schema.Optics +import Mu.Server + +import Schema + +type Person = Term SeedSchema (SeedSchema :/: "Person") +type PeopleRequest = Term SeedSchema (SeedSchema :/: "PeopleRequest") +type PeopleResponse = Term SeedSchema (SeedSchema :/: "PeopleResponse") +type Weather = Term SeedSchema (SeedSchema :/: "Weather") +type WeatherRequest = Term SeedSchema (SeedSchema :/: "WeatherRequest") +type WeatherResponse = Term SeedSchema (SeedSchema :/: "WeatherResponse") + +main :: IO () +main = do + putStrLn "running seed application" + runGRpcAppTrans msgProtoBuf 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 :: (MonadServer m, MonadLogger m) => SingleServerT info PeopleService m _ +server = singleService + ( method @"getPerson" getPerson + , method @"getPersonStream" getPersonStream + , method @"getWeather" getWeather ) + +evolvePerson :: PeopleRequest -> PeopleResponse +evolvePerson req = record1 (Just $ record (req ^. #name, 18)) + +getPerson :: Monad m => PeopleRequest -> m PeopleResponse +getPerson = pure . evolvePerson + +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 + logDebugN $ T.pack $ "stream request: " ++ show req + pure $ evolvePerson req + +getWeather :: (MonadServer m) + => WeatherRequest + -> m WeatherResponse +getWeather msg + = pure $ record1 $ go $ msg ^. #currentWeather + where go e | e `is` #sunny = "is sunny! 😄" + | e `is` #cloudy = "is cloudy 😟" + | e `is` #rainy = "is rainy... 😭" + | otherwise = error "this should never happen" diff --git a/examples/seed/src/Schema.hs b/examples/seed/src/Schema.hs new file mode 100644 index 00000000..dabf220f --- /dev/null +++ b/examples/seed/src/Schema.hs @@ -0,0 +1,19 @@ +{-# language CPP #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language TemplateHaskell #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} + +module Schema where + +import Mu.Quasi.GRpc + +#if __GHCIDE__ +grpc "SeedSchema" id "examples/seed/protobuf/seed.proto" +#else +grpc "SeedSchema" id "seed.proto" +#endif diff --git a/examples/todolist/LICENSE b/examples/todolist/LICENSE new file mode 100644 index 00000000..ffeb95d1 --- /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 © 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/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/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 new file mode 100644 index 00000000..165a4104 --- /dev/null +++ b/examples/todolist/mu-example-todolist.cabal @@ -0,0 +1,33 @@ +name: mu-example-todolist +version: 0.3.0.0 +synopsis: Example todolist project from mu-scala ported to mu-haskell +description: + Example todolist project from mu-scala ported to mu-haskell. + +license: Apache-2.0 +license-file: LICENSE +author: Flavio Corpa, Alejandro Serrano +maintainer: flavio.corpa@47deg.com +copyright: Copyright © 2020 47 Degrees. +category: Network +build-type: Simple +cabal-version: >=1.10 +data-files: todolist.proto +bug-reports: https://github.com/higherkindness/mu-haskell/issues + +executable todolist-server + main-is: Server.hs + other-modules: Definition + build-depends: + base >=4.12 && <5 + , mu-grpc-server >=0.4.0 + , mu-protobuf >=0.4.0 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.0 + , stm >=2.5 && <3 + , text >=1.2 && <2 + , transformers >=0.5 && <0.6 + + 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..407f7fe1 --- /dev/null +++ b/examples/todolist/src/Definition.hs @@ -0,0 +1,59 @@ +{-# language CPP #-} +{-# 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 + +#if __GHCIDE__ +grpc "TodoListSchema" id "examples/todolist/todolist.proto" +#else +grpc "TodoListSchema" id "todolist.proto" +#endif + +newtype MessageId = MessageId + { value :: Int32 + } deriving ( Eq, Show, Ord, Generic + , ToSchema TodoListSchema "MessageId" + , FromSchema TodoListSchema "MessageId" ) + +data TodoListMessage = TodoListMessage + { id, tagId :: Int32 + , title :: Text + , completed :: Bool + } deriving ( Eq, Show, Ord, Generic + , ToSchema TodoListSchema "TodoListMessage" + , FromSchema TodoListSchema "TodoListMessage" ) + +data TodoListRequest = TodoListRequest + { title :: Text + , tagId :: Int32 + } deriving ( Eq, Show, Ord, Generic + , ToSchema TodoListSchema "TodoListRequest" + , FromSchema TodoListSchema "TodoListRequest" ) + +newtype TodoListList = TodoListList + { list :: [TodoListMessage] + } deriving ( Eq, Show, Ord, Generic + , ToSchema TodoListSchema "TodoListList" + , FromSchema TodoListSchema "TodoListList" ) + +newtype TodoListResponse = TodoListResponse + { msg :: Maybe TodoListMessage + } deriving ( Eq, Show, Ord, Generic + , ToSchema TodoListSchema "TodoListResponse" + , FromSchema TodoListSchema "TodoListResponse" ) diff --git a/examples/todolist/src/Server.hs b/examples/todolist/src/Server.hs new file mode 100644 index 00000000..6411669d --- /dev/null +++ b/examples/todolist/src/Server.hs @@ -0,0 +1,95 @@ +{-# language DataKinds #-} +{-# language NamedFieldPuns #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language TypeApplications #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Main where + +import Control.Concurrent.STM +import Control.Monad.IO.Class (liftIO) +import Data.Int +import Data.List (find) + +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 msgProtoBuf 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 info TodoListService _ +server i t + = singleService ( method @"reset" $ reset i t + , method @"insert" $ insert i t + , method @"retrieve" $ retrieve t + , method @"list" $ list_ t + , method @"update" $ update t + , method @"destroy" $ destroy t ) + +reset :: Id -> TodoList -> ServerErrorIO MessageId +reset i t = alwaysOk $ do + putStrLn "reset" + atomically $ do + writeTVar i 0 + writeTVar t [] + pure $ MessageId (-1) + +insert :: Id -> TodoList -> TodoListRequest -> ServerErrorIO TodoListResponse +insert oldId t (TodoListRequest titl tgId) = alwaysOk $ 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 (Just newTodo) + +getMsg :: Int32 -> TodoListMessage -> Bool +getMsg x TodoListMessage {id} = id == x + +retrieve :: TodoList -> MessageId -> ServerErrorIO TodoListResponse +retrieve t (MessageId idMsg) = do + liftIO (putStr "retrieve: " >> print idMsg) + todos <- liftIO $ readTVarIO t + case find (getMsg idMsg) todos of + Just todo -> pure $ TodoListResponse (Just todo) + Nothing -> serverError $ ServerError NotFound "unknown todolist id" + +list_ :: TodoList -> ServerErrorIO TodoListList +list_ t = alwaysOk $ do + putStrLn "list" + atomically $ do + todos <- readTVar t + pure $ TodoListList todos + +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 (Just mg) + +destroy :: TodoList -> MessageId -> ServerErrorIO MessageId +destroy t (MessageId 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 idMsg) -- OK ✅ + Nothing -> pure Nothing -- did nothing + maybe (serverError $ ServerError NotFound "unknown message id") pure r 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/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..30a3126d --- /dev/null +++ b/examples/with-persistent/README.md @@ -0,0 +1,30 @@ +# with-persistent + +## Execution + +Running the server: + +```bash +$ stack run persistent-server +``` + +In another terminal, run the client: + +```bash +$ 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 with ❤️ 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..44671092 --- /dev/null +++ b/examples/with-persistent/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain 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/mu-example-with-persistent.cabal b/examples/with-persistent/mu-example-with-persistent.cabal new file mode 100644 index 00000000..5d016305 --- /dev/null +++ b/examples/with-persistent/mu-example-with-persistent.cabal @@ -0,0 +1,96 @@ +name: mu-example-with-persistent +version: 0.3.0.0 +synopsis: Example of a mu-haskell project integrated with persistent +description: Example of a mu-haskell project integrated with persistent. +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 +data-files: with-persistent.proto +homepage: + https://github.com/higherkindness/mu-haskell/examples/with-persistent#readme + +bug-reports: https://github.com/higherkindness/mu-haskell/issues + +executable persistent-server + hs-source-dirs: src + main-is: Server.hs + other-modules: Schema + default-language: Haskell2010 + build-depends: + base >=4.12 && <5 + , conduit >=1.3.2 && <2 + , monad-logger >=0.3 && <0.4 + , mu-grpc-server >=0.4 + , mu-persistent >=0.3 + , mu-protobuf >=0.4 + , mu-rpc >=0.4 + , mu-schema >=0.3 + , persistent >=2.10 && <3 + , persistent-sqlite >=2.10 && <3 + , persistent-template >=2.8 && <3 + , text >=1.2 && <2 + +executable persistent-client + main-is: Client.hs + other-modules: Schema + build-depends: + base >=4.12 && <5 + , conduit >=1.3.2 && <2 + , mu-grpc-client >=0.3.0 + , mu-persistent >=0.3.0 + , mu-protobuf >=0.4.0 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.0 + , persistent >=2.10 && <3 + , persistent-sqlite >=2.10 && <3 + , persistent-template >=2.8 && <3 + , text >=1.2 && <2 + + 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 >=1.3.2 && <2 + , mu-grpc-client >=0.3.0 + , mu-persistent >=0.3.0 + , mu-protobuf >=0.4.0 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.0 + , persistent >=2.10 && <3 + , persistent-sqlite >=2.10 && <3 + , persistent-template >=2.8 && <3 + , text >=1.2 && <2 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall + +executable persistent-client-optics + main-is: ClientOptics.hs + other-modules: Schema + build-depends: + base >=4.12 && <5 + , conduit >=1.3.2 && <2 + , mu-grpc-client >=0.3.0.0 + , mu-optics >=0.3.0.0 + , mu-persistent >=0.3.0 + , mu-protobuf >=0.4.0 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.0 + , persistent >=2.10 && <3 + , persistent-sqlite >=2.10 && <3 + , persistent-template >=2.8 && <3 + , text >=1.2 && <2 + + 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..e617d21d --- /dev/null +++ b/examples/with-persistent/src/Client.hs @@ -0,0 +1,46 @@ +{-# language DataKinds #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} + +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 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", nm, ag] -> add client nm ag + _ -> putStrLn "unknown command" + +get :: GrpcClient -> String -> IO () +get client idPerson = do + let req = MPersonRequest $ read idPerson + putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?" + response :: GRpcReply MPerson + <- gRpcCall @'MsgProtoBuf @PersistentService @"PersistentService" @"getPerson" client req + putStrLn $ "GET: response was: " ++ show response + +add :: GrpcClient -> String -> String -> IO () +add client nm ag = do + let p = MPerson Nothing (T.pack nm) (read ag) + putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag + response :: GRpcReply MPersonRequest + <- gRpcCall @'MsgProtoBuf @PersistentService @"PersistentService" @"newPerson" client p + putStrLn $ "ADD: was creating successful? " ++ show response + +watching :: GrpcClient -> IO () +watching client = do + replies <- gRpcCall @'MsgProtoBuf @PersistentService @"PersistentService" @"allPeople" client + runConduit $ replies .| C.mapM_ (print :: GRpcReply MPerson -> IO ()) diff --git a/examples/with-persistent/src/ClientOptics.hs b/examples/with-persistent/src/ClientOptics.hs new file mode 100644 index 00000000..acf3315a --- /dev/null +++ b/examples/with-persistent/src/ClientOptics.hs @@ -0,0 +1,41 @@ +{-# language DataKinds #-} +{-# language OverloadedLabels #-} + +module Main where + +import Data.Conduit +import qualified Data.Conduit.Combinators as C +import qualified Data.Text as T +import Mu.GRpc.Client.Optics +import System.Environment + +import Schema + +main :: IO () +main = do + Right client <- initGRpc (grpcClientConfigSimple "127.0.0.1" 1234 False) msgProtoBuf + args <- getArgs + case args of + ["watch"] -> watching client + ["get", idp] -> get client idp + ["add", nm, ag] -> add client nm ag + _ -> putStrLn "unknown command" + +get :: GRpcConnection PersistentService 'MsgProtoBuf -> String -> IO () +get client idPerson = do + let req = read idPerson + putStrLn $ "GET: is there some person with id: " ++ idPerson ++ "?" + response <- client ^. #getPerson $ record1 req + putStrLn $ "GET: response was: " ++ show response + +add :: GRpcConnection PersistentService 'MsgProtoBuf -> String -> String -> IO () +add client nm ag = do + let p = record (Nothing, T.pack nm, read ag) + putStrLn $ "ADD: creating new person " ++ nm ++ " with age " ++ ag + response <- client ^. #newPerson $ p + putStrLn $ "ADD: was creating successful? " ++ show response + +watching :: GRpcConnection PersistentService 'MsgProtoBuf -> IO () +watching client = do + replies <- client ^. #allPeople + runConduit $ replies .| C.mapM_ print diff --git a/examples/with-persistent/src/ClientRecord.hs b/examples/with-persistent/src/ClientRecord.hs new file mode 100644 index 00000000..8f25a3ec --- /dev/null +++ b/examples/with-persistent/src/ClientRecord.hs @@ -0,0 +1,52 @@ +{-# 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 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 @'MsgProtoBuf @PersistentService @"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 $ read 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 (T.pack nm) (read 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 diff --git a/examples/with-persistent/src/Schema.hs b/examples/with-persistent/src/Schema.hs new file mode 100644 index 00000000..8ddb205a --- /dev/null +++ b/examples/with-persistent/src/Schema.hs @@ -0,0 +1,64 @@ +{-# language CPP #-} +{-# 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 #-} + +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.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 :: Int64 + } deriving (Eq, Show, Ord, Generic) + +instance ToSchema PersistentSchema "PersonRequest" MPersonRequest +instance FromSchema PersistentSchema "PersonRequest" MPersonRequest + +share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase| +Person json + name T.Text + age Int32 + deriving Show Generic +|] + +data MPerson = MPerson + { pid :: Maybe MPersonRequest + , name :: T.Text + , age :: Int32 + } deriving (Eq, Ord, Show, Generic) + +instance ToSchema PersistentSchema "Person" MPerson +instance FromSchema PersistentSchema "Person" MPerson + +type PersonFieldMapping = '[ "personAge" ':-> "age", "personName" ':-> "name" ] + +deriving via (WithEntityNestedId "Person" PersonFieldMapping (Entity Person)) + instance ToSchema PersistentSchema "Person" (Entity Person) diff --git a/examples/with-persistent/src/Server.hs b/examples/with-persistent/src/Server.hs new file mode 100644 index 00000000..98037f52 --- /dev/null +++ b/examples/with-persistent/src/Server.hs @@ -0,0 +1,53 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +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.Adapter.Persistent (runDb) +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 + runDb conn $ runMigration migrateAll + liftIO $ runGRpcApp msgProtoBuf 1234 (server conn) + +server :: SqlBackend -> SingleServerT info PersistentService ServerErrorIO _ +server p + = singleService ( method @"getPerson" $ getPerson p + , method @"newPerson" $ newPerson p + , method @"allPeople" $ allPeople p) + +getPerson :: SqlBackend -> MPersonRequest -> ServerErrorIO (Entity Person) +getPerson conn (MPersonRequest 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 -> MPerson -> ServerErrorIO MPersonRequest +newPerson conn (MPerson _ name age) = runDb conn $ do + PersonKey (SqlBackendKey nId) <- insert (Person name age) + pure $ MPersonRequest 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/generate-haddock-docs.sh b/generate-haddock-docs.sh new file mode 100755 index 00000000..60d10911 --- /dev/null +++ b/generate-haddock-docs.sh @@ -0,0 +1,32 @@ +#!/bin/sh + +DOCSDIR=docs/haddock + +echo "Removing previous docs" +rm -rf ${DOCSDIR} + +echo "Building the project" +stack clean && 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) \ + --hyperlink-source \ + core/schema core/rpc core/optics core/lens \ + adapter/avro adapter/protobuf adapter/persistent adapter/kafka \ + instrumentation/prometheus instrumentation/tracing \ + grpc/common grpc/client grpc/server graphql servant/server + +echo "Setting Linuwial theme on Haddock generated docs" +if [ "$1" == "ocean" ] +then + echo "Replacing ocean.css with linuwial.css" + find ${DOCSDIR} -name "ocean.css" -exec cp -rf docs/css/linuwial.css {} \; +else + echo "Replacing linuwial.css with our own" + cp docs/css/linuwial.css ${DOCSDIR} + find ${DOCSDIR} -name "linuwial.css" -exec cp -rf docs/css/linuwial.css {} \; +fi diff --git a/graphql/LICENSE b/graphql/LICENSE new file mode 100644 index 00000000..ffeb95d1 --- /dev/null +++ b/graphql/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/graphql/Setup.hs b/graphql/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/graphql/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/graphql/exe/Main.hs b/graphql/exe/Main.hs new file mode 100644 index 00000000..7d8fd09e --- /dev/null +++ b/graphql/exe/Main.hs @@ -0,0 +1,135 @@ +{-# language CPP #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language LambdaCase #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TemplateHaskell #-} +{-# language TupleSections #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Main where + +import qualified Data.Aeson as JSON +import Data.Conduit +import Data.Conduit.Combinators (yieldMany) +import Data.List (find) +import Data.Maybe (fromMaybe, listToMaybe) +import Data.Proxy +import qualified Data.Text as T +import Text.Regex.TDFA ((=~)) +import Text.Regex.TDFA.Common (fst3, snd3, thd3) + +import Network.Wai.Handler.Warp (run) +import Network.Wai.Middleware.AddHeaders (addHeaders) + +import Mu.GraphQL.Quasi +import Mu.GraphQL.Server +import Mu.Schema +import Mu.Server + +#if __GHCIDE__ +graphql "ServiceDefinition" "graphql/exe/schema.graphql" +#else +graphql "ServiceDefinition" "exe/schema.graphql" +#endif + +-- GraphQL App + +main :: IO () +main = do + putStrLn "starting GraphQL server on port 8000" + let hm = addHeaders [ + ("Access-Control-Allow-Origin", "*") + , ("Access-Control-Allow-Headers", "Content-Type") + ] + run 8000 $ hm $ graphQLApp libraryServer + (Proxy @('Just "Query")) + (Proxy @'Nothing) + (Proxy @('Just "Subscription")) + +data WritingMapping + = ABook (Integer, Integer) | AnArticle (Integer, Integer) + +type ServiceMapping = '[ + "Book" ':-> (Integer, Integer) + , "Article" ':-> (Integer, Integer) + , "Author" ':-> Integer + , "Writing" ':-> WritingMapping + ] + +library :: [(Integer, T.Text, [(Integer, (T.Text, Integer))])] +library + = [ (1, "Robert Louis Stevenson", [(1, ("Treasure Island", 4)), (2, ("Strange Case of Dr Jekyll and Mr Hyde", 4))]) + , (2, "Immanuel Kant", [(3, ("Critique of Pure Reason", 1))]) + , (3, "Michael Ende", [(4, ("The Neverending Story", 5)), (5, ("Momo", 3))]) + ] + +articles :: [(Integer, T.Text, [(Integer, (T.Text, Integer))])] +articles + = [ (1, "Fuencislo Robles", [(6, ("On Warm Chocolate", 4)), (2, ("On Cold Chocolate", 4))]) ] + +libraryServer :: forall m i. (MonadServer m) + => ServerT ServiceMapping i ServiceDefinition m _ +libraryServer + = resolver ( object @"Book" ( field @"id" bookOrArticleId + , field @"title" bookTitle + , field @"author" bookOrArticleAuthor + , field @"info" bookInfo ) + , object @"Article" ( field @"id" bookOrArticleId + , field @"title" articleTitle + , field @"author" bookOrArticleAuthor ) + , object @"Author" ( field @"id" authorId + , field @"name" authorName + , field @"writings" authorBooks ) + , object @"Query" ( method @"author" findAuthor + , method @"book" findBookTitle + , method @"authors" allAuthors + , method @"books" allBooks' ) + , object @"Subscription" ( method @"books" allBooksConduit ) + , union @"Writing" (\case (ABook x) -> pure $ unionChoice @"Book" x + (AnArticle x) -> pure $ unionChoice @"Article" x) + ) + where + findBook i = find ((==i) . fst3) library + findArticle i = find ((==i) . fst3) articles + + bookOrArticleId (_, bid) = pure bid + bookOrArticleAuthor (aid, _) = pure aid + bookTitle (aid, bid) = pure $ fromMaybe "" $ do + bk <- findBook aid + ev <- lookup bid (thd3 bk) + pure (fst ev) + bookInfo (aid, bid) = pure $ do + bk <- findBook aid + ev <- lookup bid (thd3 bk) + pure $ JSON.object ["score" JSON..= snd ev] + articleTitle (aid, bid) = pure $ fromMaybe "" $ do + bk <- findArticle aid + ev <- lookup bid (thd3 bk) + pure (fst ev) + + authorId = pure + authorName aid = pure $ maybe "" snd3 (findBook aid) + authorBooks aid = pure $ maybe [] (map (ABook . (aid,) . fst) . thd3) (findBook aid) + <> maybe [] (map (AnArticle . (aid,) . fst) . thd3) (findArticle aid) + + findAuthor rx = pure $ listToMaybe + [aid | (aid, name, _) <- library, name =~ rx] + + findBookTitle rx = pure $ listToMaybe + [(aid, bid) | (aid, _, books) <- library + , (bid, (title, _)) <- books + , title =~ rx] + + allAuthors = pure $ fst3 <$> library + allBooks = [(aid, bid) | (aid, _, books) <- library, (bid, _) <- books] + allBooks' = pure allBooks + + allBooksConduit :: ConduitM (Integer, Integer) Void m () -> m () + allBooksConduit sink = runConduit $ yieldMany allBooks .| sink diff --git a/graphql/exe/schema.graphql b/graphql/exe/schema.graphql new file mode 100644 index 00000000..9d832945 --- /dev/null +++ b/graphql/exe/schema.graphql @@ -0,0 +1,36 @@ +type Book { + id: Int! + title: String! + author: Author! + info: JSON +} + +type Article { + id: Int! + title: String! + author: Author! +} + +union Writing = Book | Article + +type Author { + id: Int! + name: String! + writings: [Writing!]! +} + +type Query { + author(name: String! = ".*"): Author + book(title: String! = ".*"): Book + authors: [Author!]! + books: [Book!]! +} + +type Subscription { + books: Book! +} + +schema { + query: Query + subscription: Subscription +} diff --git a/graphql/hie.yaml b/graphql/hie.yaml new file mode 100644 index 00000000..3fbcef01 --- /dev/null +++ b/graphql/hie.yaml @@ -0,0 +1,6 @@ +cradle: + stack: + - path: "./src" + component: "mu-graphql:lib" + - path: "./exe" + component: "mu-graphql:exe:library-graphql" diff --git a/graphql/mu-graphql.cabal b/graphql/mu-graphql.cabal new file mode 100644 index 00000000..e1db96d7 --- /dev/null +++ b/graphql/mu-graphql.cabal @@ -0,0 +1,81 @@ +name: mu-graphql +version: 0.5.0.2 +synopsis: GraphQL support for Mu +description: GraphQL servers and clients for Mu-Haskell +cabal-version: >=1.10 +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2020 +category: Network +build-type: Simple +homepage: https://higherkindness.io/mu-haskell/ +bug-reports: https://github.com/higherkindness/mu-haskell/issues +data-files: exe/*.graphql + +library + exposed-modules: + Mu.GraphQL.Annotations + Mu.GraphQL.Quasi + Mu.GraphQL.Server + + other-modules: + Mu.GraphQL.Quasi.LostParser + Mu.GraphQL.Query.Definition + Mu.GraphQL.Query.Introspection + Mu.GraphQL.Query.Parse + Mu.GraphQL.Query.Run + Mu.GraphQL.Subscription.Protocol + + build-depends: + aeson >=1.4 && <2 + , async >=2.2 && <3 + , base >=4.12 && <5 + , bytestring >=0.10 && <0.11 + , conduit >=1.3.2 && <2 + , foldl >=1.4 && <2 + , graphql >=0.11 + , http-types >=0.12 && <0.13 + , list-t >=1.0 && <2 + , megaparsec >=8 && <10 + , mtl >=2.2 && <2.3 + , mu-rpc >=0.5 && <0.6 + , mu-schema >=0.3 && <0.4 + , parsers >=0.12 && <0.13 + , scientific >=0.3 && <0.4 + , sop-core >=0.5 && <0.6 + , stm >=2.5 && <3 + , stm-chans >=3 && <4 + , stm-conduit >=4 && <5 + , stm-containers >=1.1 && <2 + , template-haskell >=2.14 && <2.17 + , text >=1.2 && <1.3 + , unordered-containers >=0.2 && <0.3 + , uuid >=1.3 && <2 + , wai >=3.2 && <4 + , wai-websockets >=3 && <4 + , warp >=3.3 && <4 + , warp-tls >=3.2 && <4 + , websockets >=0.12 && <0.13 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances + +executable library-graphql + main-is: Main.hs + hs-source-dirs: exe + default-language: Haskell2010 + ghc-options: -Wall -threaded + build-depends: + base >=4.12 && <5 + , aeson >=1.4 && <2 + , conduit >=1.3.2 && <1.4 + , mu-graphql + , mu-rpc >=0.5 && <0.6 + , mu-schema >=0.3 && <0.4 + , regex-tdfa >=1.3 && <2 + , text >=1.2 && <2 + , wai-extra >=3 && <4 + , warp >=3.3 && <4 diff --git a/graphql/readme.md b/graphql/readme.md new file mode 100644 index 00000000..82abda51 --- /dev/null +++ b/graphql/readme.md @@ -0,0 +1,10 @@ +# mu-graphql + +This package contains everything you need to build a **type-safe GraphQL server** in Haskell with Mu. Check out the code at [`exe/Main.hs`](https://github.com/higherkindness/mu-haskell/blob/master/graphql/exe/Main.hs) for a complete example. + +## GraphQL client examples + +If you are interested in seeing how this server can be consumed in some GraphQL client frameworks, you have these other examples available: + +- Elm: https://github.com/higherkindness/mu-graphql-example-elm +- Reason: https://github.com/higherkindness/mu-graphql-example-reason diff --git a/graphql/src/Mu/GraphQL/Annotations.hs b/graphql/src/Mu/GraphQL/Annotations.hs new file mode 100644 index 00000000..fd908209 --- /dev/null +++ b/graphql/src/Mu/GraphQL/Annotations.hs @@ -0,0 +1,121 @@ +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TupleSections #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-| +Description : Annotations for GraphQL services + +GraphQL schemas may contain some information which +cannot be directly represented in a Mu schema or +service definition. The types in this module +can be used with the annotation mechanism in Mu +to provide this additional information. +-} +module Mu.GraphQL.Annotations ( + ValueConst(..) +, DefaultValue(..) +, ReflectValueConst(..) +, fromGQLValueConst +, module Mu.Rpc.Annotations +) where + +import Control.Applicative (Alternative (..)) +import Data.Proxy +import qualified Data.Text as T +import GHC.TypeLits +import qualified Language.GraphQL.AST as GQL + +import Mu.Rpc.Annotations + +-- | Specifies the default value of an argument. +-- To be used as an annotation. +newtype DefaultValue + = DefaultValue (ValueConst Nat Symbol) + +-- | Type-level GraphQL constant values. +-- Due to limitations in type-level literal values +-- floating point constants cannot be represented. +data ValueConst nat symbol + = VCInt nat -- ^ Integer. + | VCString symbol -- ^ String. + | VCBoolean Bool -- ^ Boolean. + | VCNull -- ^ Null. + | VCEnum symbol -- ^ Enumeration value. + | VCList [ValueConst nat symbol] -- ^ List of constant values. + | VCObject [(symbol, ValueConst nat symbol)] + -- ^ Object represented by (key, value) tuples. + +-- | Turn a 'GQL.ValueConst' coming from parsing +-- in the annotation data type. Mostly used +-- internally to generate Mu schemas from GraphQL schemas. +fromGQLValueConst :: forall f. Alternative f + => GQL.ConstValue -> f (ValueConst Integer String) +fromGQLValueConst (GQL.ConstInt n) + = pure $ VCInt (fromIntegral n) +fromGQLValueConst (GQL.ConstString s) + = pure $ VCString $ T.unpack s +fromGQLValueConst (GQL.ConstBoolean b) + = pure $ VCBoolean b +fromGQLValueConst GQL.ConstNull + = pure VCNull +fromGQLValueConst (GQL.ConstEnum s) + = pure $ VCEnum $ T.unpack s +fromGQLValueConst (GQL.ConstList xs) + = VCList <$> traverse fromGQLValueConst xs +fromGQLValueConst (GQL.ConstObject o) + = VCObject <$> traverse fromGQLField o + where fromGQLField :: GQL.ObjectField GQL.ConstValue + -> f (String, ValueConst Integer String) + fromGQLField (GQL.ObjectField n (GQL.Node v _) _) + = (T.unpack n,) <$> fromGQLValueConst v +fromGQLValueConst _ = empty + +-- | Obtain the GraphQL constant corresponding +-- to a type-level constant. Inhabited by any +-- 'ValueConst', but still required to please +-- the type checker. +class ReflectValueConst (v :: ValueConst nat symbol) where + -- | Obtain the GraphQL constant corresponding + -- to a type-level constant. + reflectValueConst :: proxy v -> GQL.ConstValue +instance KnownNat n => ReflectValueConst ('VCInt n) where + reflectValueConst _ = GQL.ConstInt $ fromInteger $ natVal (Proxy @n) +instance KnownSymbol s => ReflectValueConst ('VCString s) where + reflectValueConst _ = GQL.ConstString $ T.pack $ symbolVal (Proxy @s) +instance ReflectValueConst ('VCBoolean 'True) where + reflectValueConst _ = GQL.ConstBoolean True +instance ReflectValueConst ('VCBoolean 'False) where + reflectValueConst _ = GQL.ConstBoolean False +instance ReflectValueConst 'VCNull where + reflectValueConst _ = GQL.ConstNull +instance KnownSymbol e => ReflectValueConst ('VCEnum e) where + reflectValueConst _ = GQL.ConstString $ T.pack $ symbolVal (Proxy @e) +instance ReflectValueConstList xs => ReflectValueConst ('VCList xs) where + reflectValueConst _ = GQL.ConstList $ reflectValueConstList (Proxy @xs) +instance ReflectValueConstObject xs => ReflectValueConst ('VCObject xs) where + reflectValueConst _ = GQL.ConstObject $ reflectValueConstObject (Proxy @xs) + +class ReflectValueConstList xs where + reflectValueConstList :: proxy xs -> [GQL.ConstValue] +instance ReflectValueConstList '[] where + reflectValueConstList _ = [] +instance (ReflectValueConst x, ReflectValueConstList xs) + => ReflectValueConstList (x ': xs) where + reflectValueConstList _ + = reflectValueConst (Proxy @x) : reflectValueConstList (Proxy @xs) + +class ReflectValueConstObject xs where + reflectValueConstObject :: proxy xs -> [GQL.ObjectField GQL.ConstValue] +instance ReflectValueConstObject '[] where + reflectValueConstObject _ = [] +instance (KnownSymbol a, ReflectValueConst x, ReflectValueConstObject xs) + => ReflectValueConstObject ( '(a, x) ': xs) where + reflectValueConstObject _ + = GQL.ObjectField (T.pack $ symbolVal (Proxy @a)) + (GQL.Node (reflectValueConst (Proxy @x)) zl) + zl + : reflectValueConstObject (Proxy @xs) + where zl = GQL.Location 0 0 diff --git a/graphql/src/Mu/GraphQL/Quasi.hs b/graphql/src/Mu/GraphQL/Quasi.hs new file mode 100644 index 00000000..100a16e4 --- /dev/null +++ b/graphql/src/Mu/GraphQL/Quasi.hs @@ -0,0 +1,254 @@ +{-# language DataKinds #-} +{-# language OverloadedStrings #-} +{-# language TemplateHaskell #-} +{-# language TupleSections #-} +{-# language ViewPatterns #-} +{-| +Description : Quasi-quoters for GraphQL schemas + +Read @.graphql@ files as a 'Mu.Schema.Definition.Schema' +and 'Package' with one 'Service' per object in the schema. +-} +module Mu.GraphQL.Quasi ( + graphql +, Primitives +, graphqlWithExtendedPrimitives +, graphql' +) where + +import Control.Monad.IO.Class (liftIO) +import qualified Data.Aeson as JSON +import Data.Foldable (toList) +import qualified Data.HashMap.Strict as HM +import Data.List (foldl') +import Data.Maybe (catMaybes) +import qualified Data.Text as T +import qualified Data.Text.IO as TIO +import Data.UUID (UUID) +import qualified Language.GraphQL.AST as GQL +import Language.Haskell.TH + +import Mu.GraphQL.Annotations +import Mu.GraphQL.Quasi.LostParser (parseTypeSysDefinition) +import Mu.Rpc +import Mu.Schema.Definition + +-- | Imports an GraphQL schema definition from a file. +graphql :: String -- ^ Name for the 'Package' type, the 'Schema' is derived from it + -> FilePath -- ^ Route to the file + -> Q [Dec] +graphql name = graphql' [] (name <> "Schema") name + +-- | Imports an GraphQL schema definition from a file. +graphqlWithExtendedPrimitives + :: Primitives + -> String -- ^ Name for the 'Package' type, the 'Schema' is derived from it + -> FilePath -- ^ Route to the file + -> Q [Dec] +graphqlWithExtendedPrimitives prims name = graphql' prims (name <> "Schema") name + +-- | Imports an GraphQL schema definition from a file. +graphql' :: Primitives + -> String -- ^ Name for the 'Schema' type + -> String -- ^ Name for the 'Package' type + -> FilePath -- ^ Route to the file + -> Q [Dec] +graphql' prims scName svName file = do + schema <- liftIO $ TIO.readFile file + case parseTypeSysDefinition schema of + Left e -> fail ("could not parse graphql spec: " ++ show e) + Right p -> graphqlToDecls (basicPrimitives <> prims) scName svName p + +type Primitives = [(GQL.Name, TypeQ)] + +basicPrimitives :: Primitives +basicPrimitives + = [ ("Int", [t|Integer|]) + , ("Float", [t|Double|]) + , ("String", [t|T.Text|]) + , ("Boolean", [t|Bool|]) + , ("UUID", [t|UUID|]) + , ("JSON", [t|JSON.Value|]) + , ("JSONObject", [t|JSON.Object|])] + +type TypeMap = HM.HashMap T.Text GQLType +type SchemaMap = HM.HashMap T.Text GQL.OperationType + +data Result = + GQLScalar + | GQLSchema Type + | GQLService Type [(T.Text, (T.Text, (T.Text, Type)))] + +data GQLType = + Enum + | Object + | Scalar + | InputObject + | Union + | Interface + +classifySchema :: [GQL.TypeSystemDefinition] -> SchemaMap +classifySchema = foldl' schemaToMap HM.empty + where + schemaToMap :: SchemaMap -> GQL.TypeSystemDefinition -> SchemaMap + schemaToMap mp (GQL.SchemaDefinition _ (toList -> ops)) = foldl' operationToKeyValue mp ops + schemaToMap _ _ = error "this should have been taken care by graphqlToDecls" + operationToKeyValue :: SchemaMap -> GQL.OperationTypeDefinition -> SchemaMap + operationToKeyValue mp (GQL.OperationTypeDefinition opType name) = HM.insert name opType mp + +classify :: [GQL.TypeDefinition] -> TypeMap +classify = HM.fromList . (typeToKeyValue <$>) + where + typeToKeyValue :: GQL.TypeDefinition -> (T.Text, GQLType) + typeToKeyValue (GQL.ScalarTypeDefinition _ name _) + = (name, Scalar) + typeToKeyValue (GQL.ObjectTypeDefinition _ name _ _ _) + = (name, Object) + typeToKeyValue (GQL.InterfaceTypeDefinition _ name _ _) + = (name, Interface) + typeToKeyValue (GQL.UnionTypeDefinition _ name _ _) + = (name, Union) + typeToKeyValue (GQL.EnumTypeDefinition _ name _ _) + = (name, Enum) + typeToKeyValue (GQL.InputObjectTypeDefinition _ name _ _) + = (name, InputObject) + +-- | Constructs the GraphQL tree splitting between Schemas and Services. +graphqlToDecls + :: Primitives + -> String -> String + -> [GQL.TypeSystemDefinition] -> Q [Dec] +graphqlToDecls prims schemaName serviceName allTypes = do + let schemaName' = mkName schemaName + serviceName' = mkName serviceName + types = [t | GQL.TypeDefinition t <- allTypes] + schTypes = [t | t@GQL.SchemaDefinition {} <- allTypes] + typeMap = classify types + schMap = classifySchema schTypes + rs <- traverse (typeToDec prims schemaName' typeMap schMap) types + let schemaTypes = [x | GQLSchema x <- rs] + serviceTypes = [x | GQLService x _ <- rs] + defaultDefs = concat [d | GQLService _ d <- rs] + schemaDec <- tySynD schemaName' [] (pure $ typesToList schemaTypes) + pkgTy <- [t| 'Package ('Just $(textToStrLit $ T.pack serviceName)) + $(pure $ typesToList serviceTypes) |] + serviceDec <- tySynD serviceName' [] (pure pkgTy) + defaultDec <- [d| type instance AnnotatedPackage DefaultValue $(pure pkgTy) = + $(typesToList <$> traverse defaultDeclToTy defaultDefs) |] + pure $ schemaDec : serviceDec : defaultDec + +defaultDeclToTy :: (T.Text, (T.Text, (T.Text, Type))) -> Q Type +defaultDeclToTy (sn, (mn, (an, dv))) + = [t| 'AnnArg $(textToStrLit sn) $(textToStrLit mn) $(textToStrLit an) $(pure dv) |] + +-- | Reads a GraphQL 'TypeDefinition' and returns a 'Result'. +typeToDec :: Primitives + -> Name -> TypeMap -> SchemaMap + -> GQL.TypeDefinition -> Q Result +typeToDec _ _ _ _ GQL.InterfaceTypeDefinition {} + = fail "interface types are not supported" +typeToDec _ _ _ _ (GQL.UnionTypeDefinition _ nm _ (GQL.UnionMemberTypes elts)) = do + selts <- mapM textToStrLit elts + GQLService <$> [t| 'OneOf $(textToStrLit nm) + $(pure $ typesToList selts) |] + <*> pure [] +typeToDec prims schemaName tm _ (GQL.ScalarTypeDefinition _ s _) = + GQLScalar <$ gqlTypeToType prims s tm schemaName +typeToDec prims schemaName tm sm (GQL.ObjectTypeDefinition _ nm _ _ flds) = do + (fieldInfos, defaults) <- unzip <$> traverse (gqlFieldToType nm) flds + GQLService <$> [t| 'Service $(textToStrLit nm) + $(pure $ typesToList fieldInfos) |] + <*> pure ((nm,) <$> concat defaults) + where + gqlFieldToType :: T.Text -> GQL.FieldDefinition + -> Q (Type, [(T.Text, (T.Text, Type))]) + gqlFieldToType sn (GQL.FieldDefinition _ fnm (GQL.ArgumentsDefinition args) ftyp _) = do + (argInfos, defaults) <- unzip <$> traverse argToType args + (,) <$> [t| 'Method $(textToStrLit fnm) + $(pure $ typesToList argInfos) + $(returnType sn ftyp) |] + <*> pure ((fnm,) <$> catMaybes defaults) + returnType :: T.Text -> GQL.Type -> Q Type + returnType serviceName typ = + case HM.lookup serviceName sm of + Just GQL.Subscription -> [t|'RetStream $(retToType typ)|] + _ -> [t|'RetSingle $(retToType typ)|] + argToType :: GQL.InputValueDefinition -> Q (Type, Maybe (T.Text, Type)) + argToType (GQL.InputValueDefinition _ aname atype Nothing _) = + (, Nothing) <$> [t| 'ArgSingle ('Just $(textToStrLit aname)) $(retToType atype) |] + argToType (GQL.InputValueDefinition _ aname atype (Just (GQL.Node defs _)) _) = + (,) <$> [t| 'ArgSingle ('Just $(textToStrLit aname)) $(retToType atype) |] + <*> (Just . (aname,) <$> [t| 'DefaultValue $( defToVConst defs ) |]) + defToVConst :: GQL.ConstValue -> Q Type + defToVConst (GQL.ConstBoolean _) = [t| 'VCBoolean|] + defToVConst GQL.ConstNull = [t| 'VCNull |] + defToVConst (GQL.ConstInt _) = [t| 'VCInt |] + defToVConst (GQL.ConstFloat _) + = fail "floats as default arguments are not supported" + defToVConst (GQL.ConstString s) + = [t| 'VCString $(textToStrLit s) |] + defToVConst (GQL.ConstEnum e) + = [t| 'VCEnum $(textToStrLit e) |] + defToVConst (GQL.ConstList xs) + = [t| 'VCList $(typesToList <$> traverse defToVConst xs) |] + defToVConst (GQL.ConstObject obj) + = [t| 'VCObject $(typesToList <$> traverse fromGQLField obj) |] + fromGQLField :: GQL.ObjectField GQL.ConstValue -> Q Type + fromGQLField (GQL.ObjectField n (GQL.Node v _) _) = [t| ($(textToStrLit n), $(defToVConst v)) |] + retToType :: GQL.Type -> Q Type + retToType (GQL.TypeNonNull (GQL.NonNullTypeNamed a)) = + [t| $(gqlTypeToType prims a tm schemaName) |] + retToType (GQL.TypeNonNull (GQL.NonNullTypeList a)) = + [t| 'ListRef $(retToType a) |] + retToType (GQL.TypeNamed a) = + [t| 'OptionalRef $(gqlTypeToType prims a tm schemaName) |] + retToType (GQL.TypeList a) = + [t| 'OptionalRef ('ListRef $(retToType a)) |] +typeToDec _ _ _ _ (GQL.EnumTypeDefinition _ name _ symbols) = + GQLSchema <$> [t|'DEnum $(textToStrLit name) + $(typesToList <$> traverse gqlChoiceToType symbols)|] + where + gqlChoiceToType :: GQL.EnumValueDefinition -> Q Type + gqlChoiceToType (GQL.EnumValueDefinition _ c _) = + [t|'ChoiceDef $(textToStrLit c)|] +typeToDec prims _ _ _ (GQL.InputObjectTypeDefinition _ name _ fields) = + GQLSchema <$> [t|'DRecord $(textToStrLit name) + $(typesToList <$> traverse gqlFieldToType fields)|] + where + gqlFieldToType :: GQL.InputValueDefinition -> Q Type + gqlFieldToType (GQL.InputValueDefinition _ fname ftype _ _) = + [t|'FieldDef $(textToStrLit fname) $(ginputTypeToType ftype)|] + ginputTypeToType :: GQL.Type -> Q Type + ginputTypeToType (GQL.TypeNonNull (GQL.NonNullTypeNamed a)) = + [t| $(typeToPrimType a) |] + ginputTypeToType (GQL.TypeNonNull (GQL.NonNullTypeList a)) = + [t| 'TList $(ginputTypeToType a) |] + ginputTypeToType (GQL.TypeNamed a) = + [t| 'TOption $(typeToPrimType a) |] + ginputTypeToType (GQL.TypeList a) = + [t| 'TOption ('TList $(ginputTypeToType a)) |] + typeToPrimType :: GQL.Name -> Q Type + typeToPrimType nm + = case lookup nm prims of + Just ty -> [t|'TPrimitive $ty|] + Nothing -> [t|'TSchematic $(textToStrLit nm)|] + +-- For the JSON scalar we follow +-- https://github.com/taion/graphql-type-json + +gqlTypeToType :: Primitives -> GQL.Name -> TypeMap -> Name -> Q Type +gqlTypeToType prims name tm schemaName + = case lookup name prims of + Just ty -> [t|'PrimitiveRef $ty|] + Nothing + -> let schemaRef = [t|'SchemaRef $(conT schemaName) $(textToStrLit name)|] + in case HM.lookup name tm of + Just Enum -> schemaRef + Just InputObject -> schemaRef + _ -> [t|'ObjectRef $(textToStrLit name)|] + +typesToList :: [Type] -> Type +typesToList = foldr (AppT . AppT PromotedConsT) PromotedNilT + +textToStrLit :: T.Text -> Q Type +textToStrLit = litT . strTyLit . T.unpack diff --git a/graphql/src/Mu/GraphQL/Quasi/LostParser.hs b/graphql/src/Mu/GraphQL/Quasi/LostParser.hs new file mode 100644 index 00000000..333dabcc --- /dev/null +++ b/graphql/src/Mu/GraphQL/Quasi/LostParser.hs @@ -0,0 +1,28 @@ +{-# language OverloadedStrings #-} +{-# language ViewPatterns #-} +module Mu.GraphQL.Quasi.LostParser ( + parseTypeSysDefinition, parseDoc +) where + +import Data.Foldable (toList) +import qualified Data.Text as T +import Language.GraphQL.AST (document) +import qualified Language.GraphQL.AST as GQL +import Text.Megaparsec (runParser) + +parseDoc :: T.Text -> Either T.Text [GQL.Definition] +parseDoc s = + case runParser document "" s of + Right d -> Right (toList d) + Left e -> Left (T.pack $ show e) + +parseTypeSysDefinition :: T.Text -> Either T.Text [GQL.TypeSystemDefinition] +parseTypeSysDefinition s = + case runParser document "" s of + Right (toList -> d) + -> let tds = [td | GQL.TypeSystemDefinition td _ <- d] + in if length d == length tds + then Right tds + else Left "unexpected query or type system extension" + Left e + -> Left (T.pack $ show e) diff --git a/graphql/src/Mu/GraphQL/Query/Definition.hs b/graphql/src/Mu/GraphQL/Query/Definition.hs new file mode 100644 index 00000000..a8a139c1 --- /dev/null +++ b/graphql/src/Mu/GraphQL/Query/Definition.hs @@ -0,0 +1,132 @@ +{-# language DataKinds #-} +{-# language GADTs #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeOperators #-} +module Mu.GraphQL.Query.Definition where + +import Data.SOP.NP +import Data.SOP.NS +import Data.Text +import Data.Typeable +import qualified Language.GraphQL.AST as GQL +import Mu.Rpc +import Mu.Schema + +data Document (p :: Package snm mnm anm (TypeRef snm)) + (qr :: Maybe snm) (mut :: Maybe snm) (sub :: Maybe snm) where + QueryDoc + :: LookupService ss qr ~ 'Service qr qms + => ServiceQuery ('Package pname ss) (LookupService ss qr) + -> Document ('Package pname ss) ('Just qr) mut sub + MutationDoc + :: LookupService ss mut ~ 'Service mut mms + => ServiceQuery ('Package pname ss) (LookupService ss mut) + -> Document ('Package pname ss) qr ('Just mut) sub + SubscriptionDoc + :: LookupService ss sub ~ 'Service sub mms + => OneMethodQuery ('Package pname ss) (LookupService ss sub) + -> Document ('Package pname ss) qr mut ('Just sub) + +data ServiceQuery (p :: Package snm mnm anm (TypeRef snm)) + (s :: Service snm mnm anm (TypeRef snm)) where + ServiceQuery :: [OneMethodQuery p ('Service nm ms)] + -> ServiceQuery p ('Service nm ms) + OneOfQuery :: NP (ChosenOneOfQuery p) elts + -> ServiceQuery p ('OneOf nm elts) + +data OneMethodQuery (p :: Package snm mnm anm (TypeRef snm)) + (s :: Service snm mnm anm (TypeRef snm)) where + OneMethodQuery + :: Maybe Text + -> NS (ChosenMethodQuery p) ms + -> OneMethodQuery p ('Service nm ms) + -- the special '__typename' field + TypeNameQuery + :: Maybe Text + -> OneMethodQuery p s + -- introspection fields + SchemaQuery + :: Maybe Text + -> [GQL.Selection] + -> OneMethodQuery p s + TypeQuery + :: Maybe Text + -> Text + -> [GQL.Selection] + -> OneMethodQuery p s + +data ChosenOneOfQuery p elt where + ChosenOneOfQuery + :: Typeable elt => Proxy elt + -> ServiceQuery ('Package pname ss) (LookupService ss elt) + -> ChosenOneOfQuery ('Package pname ss) elt + +data ChosenMethodQuery (p :: Package snm mnm anm (TypeRef snm)) + (m :: Method snm mnm anm (TypeRef snm)) where + ChosenMethodQuery + :: GQL.Field + -> NP (ArgumentValue p) args + -> ReturnQuery p r + -> ChosenMethodQuery p ('Method mname args r) + +data ArgumentValue (p :: Package snm mnm anm (TypeRef snm)) + (a :: Argument snm anm (TypeRef snm)) where + ArgumentValue :: ArgumentValue' p r + -> ArgumentValue p ('ArgSingle aname r) + ArgumentStream :: ArgumentValue' p ('ListRef r) + -> ArgumentValue p ('ArgStream aname r) + +data ArgumentValue' (p :: Package snm mnm anm (TypeRef snm)) + (r :: TypeRef snm) where + ArgPrimitive :: t -> ArgumentValue' p ('PrimitiveRef t) + ArgSchema :: Term sch (sch :/: sty) + -> ArgumentValue' p ('SchemaRef sch sty) + ArgList :: [ArgumentValue' p r] + -> ArgumentValue' p ('ListRef r) + ArgOptional :: Maybe (ArgumentValue' p r) + -> ArgumentValue' p ('OptionalRef r) + +data ReturnQuery (p :: Package snm mnm anm (TypeRef snm)) + (r :: Return snm (TypeRef snm)) where + RNothing :: ReturnQuery p 'RetNothing + RSingle :: ReturnQuery' p r -> ReturnQuery p ('RetSingle r) + RStream :: ReturnQuery' p r -> ReturnQuery p ('RetStream r) + +data ReturnQuery' (p :: Package snm mnm anm (TypeRef snm)) + (r :: TypeRef snm) where + RetPrimitive :: ReturnQuery' p ('PrimitiveRef t) + RetSchema :: SchemaQuery sch (sch :/: sty) + -> ReturnQuery' p ('SchemaRef sch sty) + RetList :: ReturnQuery' p r -> ReturnQuery' p ('ListRef r) + RetOptional :: ReturnQuery' p r -> ReturnQuery' p ('OptionalRef r) + RetObject :: ServiceQuery ('Package pname ss) (LookupService ss s) + -> ReturnQuery' ('Package pname ss) ('ObjectRef s) + +data SchemaQuery (sch :: Schema tn fn) (t :: TypeDef tn fn) where + QueryEnum :: SchemaQuery sch ('DEnum nm choices) + QueryRecord :: [OneFieldQuery sch fs] + -> SchemaQuery sch ('DRecord ty fs) + +data OneFieldQuery (sch :: Schema tn fn) (fs :: [FieldDef tn fn]) where + OneFieldQuery + :: Maybe Text + -> NS (ChosenFieldQuery sch) fs + -> OneFieldQuery sch fs + TypeNameFieldQuery + :: Maybe Text + -> OneFieldQuery sch fs + +data ChosenFieldQuery (sch :: Schema tn fn) (f :: FieldDef tn fn) where + ChosenFieldQuery + :: ReturnSchemaQuery sch r + -> ChosenFieldQuery sch ('FieldDef name r) + +data ReturnSchemaQuery (sch :: Schema tn fn) (r :: FieldType tn) where + RetSchPrimitive :: ReturnSchemaQuery sch ('TPrimitive t) + RetSchSchema :: SchemaQuery sch (sch :/: sty) + -> ReturnSchemaQuery sch ('TSchematic sty) + RetSchList :: ReturnSchemaQuery sch r + -> ReturnSchemaQuery sch ('TList r) + RetSchOptional :: ReturnSchemaQuery sch r + -> ReturnSchemaQuery sch ('TOption r) diff --git a/graphql/src/Mu/GraphQL/Query/Introspection.hs b/graphql/src/Mu/GraphQL/Query/Introspection.hs new file mode 100644 index 00000000..c11ed14b --- /dev/null +++ b/graphql/src/Mu/GraphQL/Query/Introspection.hs @@ -0,0 +1,389 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +module Mu.GraphQL.Query.Introspection where + +import Control.Monad.Writer +import qualified Data.Aeson as JSON +import qualified Data.HashMap.Strict as HM +import qualified Data.HashSet as S +import Data.Int (Int32) +import Data.Maybe (catMaybes, fromMaybe) +import Data.Proxy +import qualified Data.Text as T +import GHC.TypeLits +import Mu.Rpc +import qualified Mu.Schema as Mu + +type TypeMap = HM.HashMap T.Text Type + +data Schema + = Schema { queryType :: Maybe T.Text + , mutationType :: Maybe T.Text + , subscriptionType :: Maybe T.Text + , types :: TypeMap } + deriving Show + +data Type + = Type + { kind :: TypeKind + , typeName :: Maybe T.Text + , fields :: [Field] + , enumValues :: [EnumValue] + , possibleTypes :: [Type] + , ofType :: Maybe Type + } + | TypeRef { to :: T.Text } + deriving Show + +data Field + = Field + { fieldName :: T.Text + , args :: [Input] + , fieldType :: Type + } + deriving Show + +data Input + = Input + { inputName :: T.Text + , inputDefaultValue :: Maybe T.Text + , inputType :: Type + } + deriving Show + +newtype EnumValue + = EnumValue { enumValueName :: T.Text } + deriving Show + +data TypeKind + = SCALAR + | OBJECT + | INTERFACE + | UNION + | ENUM + | INPUT_OBJECT + | LIST + | NON_NULL + deriving Show + +tSimple :: T.Text -> Type +tSimple t = Type SCALAR (Just t) [] [] [] Nothing + +tList :: Type -> Type +tList = Type LIST Nothing [] [] [] . Just + +tNonNull :: Type -> Type +tNonNull = Type NON_NULL Nothing [] [] [] . Just + +unwrapNonNull :: Type -> Maybe Type +unwrapNonNull (Type NON_NULL _ _ _ _ x) = x +unwrapNonNull _ = Nothing + +-- BUILD INTROSPECTION DATA +-- ======================== + +class Introspect (p :: Package') + (qr :: Maybe Symbol) + (mut :: Maybe Symbol) + (sub :: Maybe Symbol) where + introspect + :: Proxy p -> Proxy qr -> Proxy mut -> Proxy sub -> Schema + +instance ( IntrospectServices ss sub + , KnownMaybeSymbol qr + , KnownMaybeSymbol mut + , KnownMaybeSymbol sub) + => Introspect ('Package nm ss) qr mut sub where + introspect _ _ _ _ + = let (_, ts) = runWriter $ + introspectServices (Proxy @ss) (Proxy @sub) >> + tell (HM.fromList ( + (\i -> (i, tSimple i)) + <$> [ "Null", "Int", "Float" + , "String", "Boolean", "ID" + , "JSON", "JSONObject" ] )) + -- return only reachable types + qrS = maybeSymbolVal (Proxy @qr) + mutS = maybeSymbolVal (Proxy @mut) + subS = maybeSymbolVal (Proxy @sub) + initials = S.fromList $ catMaybes [qrS, mutS, subS] + reach = reachableFrom ts initials + -- + finalTs = HM.filterWithKey (\k _ -> k `S.member` reach) ts + in Schema qrS mutS subS finalTs + +reachableFrom :: TypeMap -> S.HashSet T.Text -> S.HashSet T.Text +reachableFrom mp tys + = let tys' = S.toList tys + fromThis = S.fromList . reachableFromOne <$> tys' + allReachable = S.unions fromThis + in if tys == allReachable + then tys + else reachableFrom mp allReachable + where + reachableFromOne :: T.Text -> [T.Text] + reachableFromOne t + = case HM.lookup t mp of + Just ty@Type {} + -> t : concatMap reachableFromField (fields ty) + _ -> error "this should never happen" + + reachableFromField :: Field -> [T.Text] + reachableFromField f + = reachableFromType (fieldType f) ++ concatMap reachableFromInput (args f) + + reachableFromInput :: Input -> [T.Text] + reachableFromInput i = reachableFromType (inputType i) + + reachableFromType :: Type -> [T.Text] + reachableFromType (TypeRef t) = [t] + reachableFromType t@Type {} + = case ofType t of + Just t' -> reachableFromType t' + Nothing -> case typeName t of + Just tn -> [tn] + Nothing -> [] + +class KnownMaybeSymbol (s :: Maybe Symbol) where + maybeSymbolVal :: Proxy s -> Maybe T.Text +instance KnownSymbol s => KnownMaybeSymbol ('Just s) where + maybeSymbolVal _ = Just $ T.pack $ symbolVal (Proxy @s) +instance KnownMaybeSymbol 'Nothing where + maybeSymbolVal _ = Nothing + +type family IsSub (sname :: Symbol) (sub :: Maybe Symbol) :: Bool where + IsSub sname 'Nothing = 'False + IsSub sname ('Just sname) = 'True + IsSub sname ('Just other) = 'False + +class IntrospectServices (ss :: [Service']) (sub :: Maybe Symbol) where + introspectServices + :: Proxy ss -> Proxy sub -> Writer TypeMap () +instance IntrospectServices '[] sub where + introspectServices _ _ = pure () +instance ( KnownSymbol sname + , IntrospectFields smethods (IsSub sname sub) + , IntrospectServices ss sub ) + => IntrospectServices ('Service sname smethods ': ss) sub where + introspectServices _ psub = do + let name = T.pack $ symbolVal (Proxy @sname) + fs <- introspectFields (Proxy @smethods) (Proxy @(IsSub sname sub)) + let t = Type OBJECT (Just name) fs [] [] Nothing + -- add this one to the mix + tell (HM.singleton name t) + -- continue with the rest + introspectServices (Proxy @ss) psub + +instance ( KnownSymbol sname, KnownSymbols elts + , IntrospectServices ss sub ) + => IntrospectServices ('OneOf sname elts ': ss) sub where + introspectServices _ psub = do + let name = T.pack $ symbolVal (Proxy @sname) + tys = map tSimple (symbolsVal (Proxy @elts)) + t = Type UNION (Just name) [] [] tys Nothing + -- add this one to the mix + tell (HM.singleton name t) + -- continue with the rest + introspectServices (Proxy @ss) psub + +class KnownSymbols (ss :: [Symbol]) where + symbolsVal :: Proxy ss -> [T.Text] +instance KnownSymbols '[] where + symbolsVal _ = [] +instance (KnownSymbol s, KnownSymbols ss) + => KnownSymbols (s ': ss) where + symbolsVal _ = T.pack (symbolVal (Proxy @s)) : symbolsVal (Proxy @ss) + +class IntrospectFields (fs :: [Method']) (isSub :: Bool) where + introspectFields + :: Proxy fs -> Proxy isSub -> Writer TypeMap [Field] +instance IntrospectFields '[] isSub where + introspectFields _ _ = pure [] +instance ( KnownSymbol mname + , IntrospectInputs margs + , IntrospectReturn mret isSub + , IntrospectFields fs isSub) + => IntrospectFields ('Method mname margs mret ': fs) isSub where + introspectFields _ pIsSub = do + let name = T.pack $ symbolVal (Proxy @mname) + inputs <- introspectInputs (Proxy @margs) + ret <- introspectReturn (Proxy @mret) pIsSub + let this = Field name inputs ret + (this :) <$> introspectFields (Proxy @fs) pIsSub + +class IntrospectInputs (args :: [Argument']) where + introspectInputs + :: Proxy args -> Writer TypeMap [Input] +instance IntrospectInputs '[] where + introspectInputs _ = pure [] +instance ( KnownMaybeSymbol nm + , IntrospectTypeRef r + , IntrospectInputs args ) + => IntrospectInputs ('ArgSingle nm r ': args) where + introspectInputs _ = do + let nm = maybeSymbolVal (Proxy @nm) + t <- introspectTypeRef (Proxy @r) False + -- TODO: Find default value + let this = Input (fromMaybe "arg" nm) Nothing t + (this :) <$> introspectInputs (Proxy @args) +instance ( KnownMaybeSymbol nm + , IntrospectTypeRef r + , IntrospectInputs args ) + => IntrospectInputs ('ArgStream nm r ': args) where + introspectInputs _ = do + let nm = maybeSymbolVal (Proxy @nm) + t <- tList <$> introspectTypeRef (Proxy @r) False + -- TODO: Find default value + let this = Input (fromMaybe "arg" nm) Nothing t + (this :) <$> introspectInputs (Proxy @args) + +class IntrospectReturn (r :: Return Symbol (TypeRef Symbol)) (isSub :: Bool) where + introspectReturn + :: Proxy r -> Proxy isSub -> Writer TypeMap Type + +instance IntrospectReturn 'RetNothing isSub where + introspectReturn _ _ = pure $ tSimple "Null" +instance IntrospectTypeRef t + => IntrospectReturn ('RetSingle t) isSub where + introspectReturn _ _ = introspectTypeRef (Proxy @t) True +instance IntrospectTypeRef t + => IntrospectReturn ('RetStream t) 'False where + introspectReturn _ _ = tList <$> introspectTypeRef (Proxy @t) True +instance IntrospectTypeRef t + => IntrospectReturn ('RetStream t) 'True where + introspectReturn _ _ = introspectTypeRef (Proxy @t) True + +class IntrospectTypeRef (tr :: TypeRef Symbol) where + introspectTypeRef + :: Proxy tr -> Bool -> Writer TypeMap Type + +instance IntrospectTypeRef ('PrimitiveRef Bool) where + introspectTypeRef _ _ = pure $ tNonNull $ tSimple "Boolean" +instance IntrospectTypeRef ('PrimitiveRef Int32) where + introspectTypeRef _ _ = pure $ tNonNull $ tSimple "Int" +instance IntrospectTypeRef ('PrimitiveRef Integer) where + introspectTypeRef _ _ = pure $ tNonNull $ tSimple "Int" +instance IntrospectTypeRef ('PrimitiveRef Double) where + introspectTypeRef _ _ = pure $ tNonNull $ tSimple "Float" +instance IntrospectTypeRef ('PrimitiveRef String) where + introspectTypeRef _ _ = pure $ tNonNull $ tSimple "String" +instance IntrospectTypeRef ('PrimitiveRef T.Text) where + introspectTypeRef _ _ = pure $ tNonNull $ tSimple "String" +instance IntrospectTypeRef ('PrimitiveRef JSON.Value) where + introspectTypeRef _ _ = pure $ tNonNull $ tSimple "JSON" +instance IntrospectTypeRef ('PrimitiveRef JSON.Object) where + introspectTypeRef _ _ = pure $ tNonNull $ tSimple "JSONObject" + +instance (IntrospectTypeRef r) + => IntrospectTypeRef ('ListRef r) where + introspectTypeRef _ isRet = tList <$> introspectTypeRef (Proxy @r) isRet +instance (IntrospectTypeRef r) + => IntrospectTypeRef ('OptionalRef r) where + introspectTypeRef _ isRet = do + r <- introspectTypeRef (Proxy @r) isRet + pure $ fromMaybe r (unwrapNonNull r) + +instance (KnownSymbol o) + => IntrospectTypeRef ('ObjectRef o) where + introspectTypeRef _ _ + = pure $ TypeRef $ T.pack $ symbolVal (Proxy @o) + +instance (IntrospectSchema sch, KnownSymbol t) + => IntrospectTypeRef ('SchemaRef sch t) where + introspectTypeRef _ isRet = do + let (k, suffix) = if isRet then (OBJECT, "R") else (INPUT_OBJECT, "") + introspectSchema k suffix (Proxy @sch) + pure $ TypeRef $ T.pack (symbolVal (Proxy @t)) <> suffix + +class IntrospectSchema (ts :: [Mu.TypeDef Symbol Symbol]) where + introspectSchema + :: TypeKind -> T.Text -> Proxy ts -> Writer TypeMap () +instance IntrospectSchema '[] where + introspectSchema _ _ _ = pure () +instance (KnownSymbol name, IntrospectSchemaFields fields, IntrospectSchema ts) + => IntrospectSchema ('Mu.DRecord name fields ': ts) where + introspectSchema k suffix _ = do + let name = T.pack (symbolVal (Proxy @name)) <> suffix + fs = introspectSchemaFields suffix (Proxy @fields) + t = Type k (Just name) fs [] [] Nothing + -- add this one to the mix + tell (HM.singleton name t) + -- continue with the rest + introspectSchema k suffix (Proxy @ts) +instance (KnownSymbol name, IntrospectSchemaEnum choices, IntrospectSchema ts) + => IntrospectSchema ('Mu.DEnum name choices ': ts) where + introspectSchema k suffix _ = do + let name = T.pack (symbolVal (Proxy @name)) <> suffix + cs = introspectSchemaEnum (Proxy @choices) + t = Type ENUM (Just name) [] cs [] Nothing + -- add this one to the mix + tell (HM.singleton name t) + -- continue with the rest + introspectSchema k suffix (Proxy @ts) + +class IntrospectSchemaFields (fs :: [Mu.FieldDef Symbol Symbol]) where + introspectSchemaFields + :: T.Text -> Proxy fs -> [Field] +instance IntrospectSchemaFields '[] where + introspectSchemaFields _ _ = [] +instance (KnownSymbol fname,IntrospectSchemaFieldType r, IntrospectSchemaFields fs) + => IntrospectSchemaFields ('Mu.FieldDef fname r ': fs) where + introspectSchemaFields suffix _ + = let name = T.pack $ symbolVal (Proxy @fname) + ret = introspectSchemaFieldType suffix (Proxy @r) + this = Field name [] ret + in this : introspectSchemaFields suffix (Proxy @fs) + +class IntrospectSchemaFieldType (t :: Mu.FieldType Symbol) where + introspectSchemaFieldType + :: T.Text -> Proxy t -> Type + +instance IntrospectSchemaFieldType ('Mu.TPrimitive Bool) where + introspectSchemaFieldType _ _ = tNonNull $ tSimple "Boolean" +instance IntrospectSchemaFieldType ('Mu.TPrimitive Int32) where + introspectSchemaFieldType _ _ = tNonNull $ tSimple "Int" +instance IntrospectSchemaFieldType ('Mu.TPrimitive Integer) where + introspectSchemaFieldType _ _ = tNonNull $ tSimple "Int" +instance IntrospectSchemaFieldType ('Mu.TPrimitive Double) where + introspectSchemaFieldType _ _ = tNonNull $ tSimple "Float" +instance IntrospectSchemaFieldType ('Mu.TPrimitive String) where + introspectSchemaFieldType _ _ = tNonNull $ tSimple "String" +instance IntrospectSchemaFieldType ('Mu.TPrimitive T.Text) where + introspectSchemaFieldType _ _ = tNonNull $ tSimple "String" +instance IntrospectSchemaFieldType ('Mu.TPrimitive JSON.Value) where + introspectSchemaFieldType _ _ = tNonNull $ tSimple "JSON" +instance IntrospectSchemaFieldType ('Mu.TPrimitive JSON.Object) where + introspectSchemaFieldType _ _ = tNonNull $ tSimple "JSONObject" + +instance (IntrospectSchemaFieldType r) + => IntrospectSchemaFieldType ('Mu.TList r) where + introspectSchemaFieldType suffix _ + = tList $ introspectSchemaFieldType suffix (Proxy @r) +instance (IntrospectSchemaFieldType r) + => IntrospectSchemaFieldType ('Mu.TOption r) where + introspectSchemaFieldType suffix _ + = let r = introspectSchemaFieldType suffix (Proxy @r) + in fromMaybe r (unwrapNonNull r) + +instance (KnownSymbol nm) + => IntrospectSchemaFieldType ('Mu.TSchematic nm) where + introspectSchemaFieldType suffix _ + = TypeRef $ T.pack (symbolVal (Proxy @nm)) <> suffix + +class IntrospectSchemaEnum (c :: [Mu.ChoiceDef Symbol]) where + introspectSchemaEnum :: Proxy c -> [EnumValue] +instance IntrospectSchemaEnum '[] where + introspectSchemaEnum _ = [] +instance (KnownSymbol nm, IntrospectSchemaEnum cs) + => IntrospectSchemaEnum ('Mu.ChoiceDef nm ': cs) where + introspectSchemaEnum _ + = let this = EnumValue $ T.pack $ symbolVal (Proxy @nm) + in this : introspectSchemaEnum (Proxy @cs) diff --git a/graphql/src/Mu/GraphQL/Query/Parse.hs b/graphql/src/Mu/GraphQL/Query/Parse.hs new file mode 100644 index 00000000..f489ce79 --- /dev/null +++ b/graphql/src/Mu/GraphQL/Query/Parse.hs @@ -0,0 +1,920 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TupleSections #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-# language ViewPatterns #-} +{-# OPTIONS_GHC -Wincomplete-patterns -fno-warn-orphans #-} + +module Mu.GraphQL.Query.Parse where + +import Control.Monad.Except +import qualified Data.Aeson as A +import qualified Data.Foldable as F +import qualified Data.HashMap.Strict as HM +import Data.Int (Int32) +import Data.List (find) +import Data.Maybe +import Data.Proxy +import Data.SOP.NS +import Data.Scientific (Scientific, floatingOrInteger, fromFloatDigits) +import qualified Data.Text as T +import GHC.TypeLits +import qualified Language.GraphQL.AST as GQL + +import Mu.GraphQL.Annotations +import Mu.GraphQL.Query.Definition +import Mu.Rpc +import Mu.Schema + +type VariableMapC = HM.HashMap T.Text GQL.ConstValue +type VariableMap = HM.HashMap T.Text GQL.Value +type FragmentMap = HM.HashMap T.Text GQL.FragmentDefinition + +instance A.FromJSON GQL.ConstValue where + parseJSON A.Null = pure GQL.ConstNull + parseJSON (A.Bool b) = pure $ GQL.ConstBoolean b + parseJSON (A.String s) = pure $ GQL.ConstString s + parseJSON (A.Number n) = case floatingOrInteger n :: Either Double Int32 of + Right i -> pure $ GQL.ConstInt i + Left m -> pure $ GQL.ConstFloat m + parseJSON (A.Array xs) = GQL.ConstList . F.toList <$> traverse A.parseJSON xs + parseJSON (A.Object o) = GQL.ConstObject . fmap toObjFld . HM.toList <$> traverse A.parseJSON o + where + toObjFld :: (T.Text, GQL.ConstValue) -> GQL.ObjectField GQL.ConstValue + toObjFld (k, v) = GQL.ObjectField k (GQL.Node v zl) zl + zl = GQL.Location 0 0 + +parseDoc :: + forall qr mut sub p f. + ( MonadError T.Text f, ParseTypedDoc p qr mut sub ) => + Maybe T.Text -> VariableMapC -> + [GQL.Definition] -> + f (Document p qr mut sub) +-- If there's no operation name, there must be only one query +parseDoc Nothing vmap defns + = case partitionExDefs defns of + ([unnamed], [], frs) + -> parseTypedDocQuery HM.empty (fragmentsToMap frs) unnamed + ([], [named], frs) + -> parseTypedDoc vmap (fragmentsToMap frs) named + ([], [], _) -> throwError "no operation to execute" + (_, [], _) -> throwError "more than one unnamed query" + ([], _, _) -> throwError "more than one named operation but no 'operationName' given" + (_, _, _) -> throwError "both named and unnamed queries, but no 'operationName' given" +-- If there's an operation name, look in the named queries +parseDoc (Just operationName) vmap defns + = case partitionExDefs defns of + (_, named, frs) -> maybe notFound + (parseTypedDoc vmap (fragmentsToMap frs)) + (find isThis named) + where isThis (GQL.OperationDefinition _ (Just nm) _ _ _ _) + = nm == operationName + isThis _ = False + notFound :: MonadError T.Text f => f a + notFound = throwError $ "operation '" <> operationName <> "' was not found" + +partitionExDefs + :: [GQL.Definition] + -> ([[GQL.Selection]], [GQL.OperationDefinition], [GQL.FragmentDefinition]) +partitionExDefs defs + = ( [ F.toList ss + | GQL.ExecutableDefinition (GQL.DefinitionOperation (GQL.SelectionSet ss _)) <- defs ] + , [ od + | GQL.ExecutableDefinition (GQL.DefinitionOperation od@GQL.OperationDefinition {}) <- defs ] + , [ fr + | GQL.ExecutableDefinition (GQL.DefinitionFragment fr) <- defs ]) + +parseTypedDoc :: + (MonadError T.Text f, ParseTypedDoc p qr mut sub) => + VariableMapC -> FragmentMap -> + GQL.OperationDefinition -> + f (Document p qr mut sub) +parseTypedDoc _ _ GQL.SelectionSet {} + = error "this should have been handled in parseDoc" +parseTypedDoc vmap frmap (GQL.OperationDefinition typ _ vdefs _ (F.toList -> ss) _) + = let defVmap = parseVariableMap vdefs + finalVmap = constToValue <$> HM.union vmap defVmap -- first one takes precedence + in case typ of + GQL.Query -> parseTypedDocQuery finalVmap frmap ss + GQL.Mutation -> parseTypedDocMutation finalVmap frmap ss + GQL.Subscription -> parseTypedDocSubscription finalVmap frmap ss + +fragmentsToMap :: [GQL.FragmentDefinition] -> FragmentMap +fragmentsToMap = HM.fromList . map fragmentToThingy + where fragmentToThingy :: GQL.FragmentDefinition -> (T.Text, GQL.FragmentDefinition) + fragmentToThingy f = (fdName f, f) + +class ParseTypedDoc (p :: Package') + (qr :: Maybe Symbol) (mut :: Maybe Symbol) (sub :: Maybe Symbol) where + parseTypedDocQuery :: + MonadError T.Text f => + VariableMap -> FragmentMap -> + [GQL.Selection] -> + f (Document p qr mut sub) + parseTypedDocMutation :: + MonadError T.Text f => + VariableMap -> FragmentMap -> + [GQL.Selection] -> + f (Document p qr mut sub) + parseTypedDocSubscription :: + MonadError T.Text f => + VariableMap -> FragmentMap -> + [GQL.Selection] -> + f (Document p qr mut sub) + +instance + ( p ~ 'Package pname ss, + LookupService ss qr ~ 'Service qr qmethods, + KnownName qr, ParseMethod p ('Service qr qmethods) qmethods, + LookupService ss mut ~ 'Service mut mmethods, + KnownName mut, ParseMethod p ('Service mut mmethods) mmethods, + LookupService ss sub ~ 'Service sub smethods, + KnownName sub, ParseMethod p ('Service sub smethods) smethods + ) => ParseTypedDoc p ('Just qr) ('Just mut) ('Just sub) where + parseTypedDocQuery vmap frmap sset + = QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset + parseTypedDocMutation vmap frmap sset + = MutationDoc <$> parseQuery (Proxy @p) (Proxy @mut) vmap frmap sset + parseTypedDocSubscription vmap frmap sset + = do q <- parseQuery (Proxy @p) (Proxy @sub) vmap frmap sset + case q of + ServiceQuery [one] + -> pure $ SubscriptionDoc one + _ -> throwError "subscriptions may only have one field" + +instance + ( p ~ 'Package pname ss, + LookupService ss qr ~ 'Service qr qmethods, + KnownName qr, ParseMethod p ('Service qr qmethods) qmethods, + LookupService ss mut ~ 'Service mut mmethods, + KnownName mut, ParseMethod p ('Service mut mmethods) mmethods + ) => ParseTypedDoc p ('Just qr) ('Just mut) 'Nothing where + parseTypedDocQuery vmap frmap sset + = QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset + parseTypedDocMutation vmap frmap sset + = MutationDoc <$> parseQuery (Proxy @p) (Proxy @mut) vmap frmap sset + parseTypedDocSubscription _ _ _ + = throwError "no subscriptions are defined in the schema" + +instance + ( p ~ 'Package pname ss, + LookupService ss qr ~ 'Service qr qmethods, + KnownName qr, ParseMethod p ('Service qr qmethods) qmethods, + LookupService ss sub ~ 'Service sub smethods, + KnownName sub, ParseMethod p ('Service sub smethods) smethods + ) => ParseTypedDoc p ('Just qr) 'Nothing ('Just sub) where + parseTypedDocQuery vmap frmap sset + = QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset + parseTypedDocMutation _ _ _ + = throwError "no mutations are defined in the schema" + parseTypedDocSubscription vmap frmap sset + = do q <- parseQuery (Proxy @p) (Proxy @sub) vmap frmap sset + case q of + ServiceQuery [one] + -> pure $ SubscriptionDoc one + _ -> throwError "subscriptions may only have one field" + +instance + ( p ~ 'Package pname ss, + LookupService ss qr ~ 'Service qr qmethods, + KnownName qr, ParseMethod p ('Service qr qmethods) qmethods + ) => ParseTypedDoc p ('Just qr) 'Nothing 'Nothing where + parseTypedDocQuery vmap frmap sset + = QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset + parseTypedDocMutation _ _ _ + = throwError "no mutations are defined in the schema" + parseTypedDocSubscription _ _ _ + = throwError "no subscriptions are defined in the schema" + +instance + ( p ~ 'Package pname ss, + LookupService ss mut ~ 'Service mut mmethods, + KnownName mut, ParseMethod p ('Service mut mmethods) mmethods, + LookupService ss sub ~ 'Service sub smethods, + KnownName sub, ParseMethod p ('Service sub smethods) smethods + ) => ParseTypedDoc p 'Nothing ('Just mut) ('Just sub) where + parseTypedDocQuery _ _ _ + = throwError "no queries are defined in the schema" + parseTypedDocMutation vmap frmap sset + = MutationDoc <$> parseQuery (Proxy @p) (Proxy @mut) vmap frmap sset + parseTypedDocSubscription vmap frmap sset + = do q <- parseQuery (Proxy @p) (Proxy @sub) vmap frmap sset + case q of + ServiceQuery [one] + -> pure $ SubscriptionDoc one + _ -> throwError "subscriptions may only have one field" + +instance + ( p ~ 'Package pname ss, + LookupService ss mut ~ 'Service mut mmethods, + KnownName mut, ParseMethod p ('Service mut mmethods) mmethods + ) => ParseTypedDoc p 'Nothing ('Just mut) 'Nothing where + parseTypedDocQuery _ _ _ + = throwError "no queries are defined in the schema" + parseTypedDocMutation vmap frmap sset + = MutationDoc <$> parseQuery (Proxy @p) (Proxy @mut) vmap frmap sset + parseTypedDocSubscription _ _ _ + = throwError "no subscriptions are defined in the schema" + +instance + ( p ~ 'Package pname ss, + LookupService ss sub ~ 'Service sub smethods, + KnownName sub, ParseMethod p ('Service sub smethods) smethods + ) => ParseTypedDoc p 'Nothing 'Nothing ('Just sub) where + parseTypedDocQuery _ _ _ + = throwError "no queries are defined in the schema" + parseTypedDocMutation _ _ _ + = throwError "no mutations are defined in the schema" + parseTypedDocSubscription vmap frmap sset + = do q <- parseQuery (Proxy @p) (Proxy @sub) vmap frmap sset + case q of + ServiceQuery [one] + -> pure $ SubscriptionDoc one + _ -> throwError "subscriptions may only have one field" + +instance + ParseTypedDoc p 'Nothing 'Nothing 'Nothing where + parseTypedDocQuery _ _ _ + = throwError "no queries are defined in the schema" + parseTypedDocMutation _ _ _ + = throwError "no mutations are defined in the schema" + parseTypedDocSubscription _ _ _ + = throwError "no subscriptions are defined in the schema" + +parseVariableMap :: [GQL.VariableDefinition] -> VariableMapC +parseVariableMap vmap + = HM.fromList [(v, def) + | GQL.VariableDefinition v _ (Just (GQL.Node def _)) _ <- vmap] + +constToValue :: GQL.ConstValue -> GQL.Value +constToValue (GQL.ConstInt n) = GQL.Int n +constToValue (GQL.ConstFloat n) = GQL.Float n +constToValue (GQL.ConstString n) = GQL.String n +constToValue (GQL.ConstBoolean n) = GQL.Boolean n +constToValue GQL.ConstNull = GQL.Null +constToValue (GQL.ConstEnum n) = GQL.Enum n +constToValue (GQL.ConstList n) + = GQL.List $ constToValue <$> n +constToValue (GQL.ConstObject n) + = GQL.Object + [ GQL.ObjectField a (GQL.Node (constToValue v) m) l + | GQL.ObjectField a (GQL.Node v m) l <- n ] + +class ParseQuery (p :: Package') (s :: Symbol) where + parseQuery + :: ( MonadError T.Text f, p ~ 'Package pname ss, KnownName s ) + => Proxy p -> Proxy s + -> VariableMap -> FragmentMap -> [GQL.Selection] + -> f (ServiceQuery p (LookupService ss s)) + +instance ( p ~ 'Package pname ss + , KnownName s + , ParseQuery' p s (LookupService ss s) ) + => ParseQuery p s where + parseQuery pp ps = parseQuery' pp ps (Proxy @(LookupService ss s)) + +class ParseQuery' (p :: Package') (s :: Symbol) (svc :: Service') where + parseQuery' + :: ( MonadError T.Text f, p ~ 'Package pname ss + , LookupService ss s ~ svc, KnownName s ) + => Proxy p -> Proxy s -> Proxy svc + -> VariableMap -> FragmentMap -> [GQL.Selection] + -> f (ServiceQuery p svc) + +instance (ParseQueryOneOf p elts) + => ParseQuery' p s ('OneOf s elts) where + parseQuery' pp _ps _ vmap frmap fs + = OneOfQuery <$> parseQueryOneOf pp (Proxy @elts) vmap frmap fs + +class ParseQueryOneOf (p :: Package') (s :: [Symbol]) where + parseQueryOneOf + :: ( MonadError T.Text f, p ~ 'Package pname ss ) + => Proxy p -> Proxy s + -> VariableMap -> FragmentMap -> [GQL.Selection] + -> f (NP (ChosenOneOfQuery p) s) + +instance ParseQueryOneOf p '[] where + parseQueryOneOf _ _ _ _ _ = pure Nil +instance ( ParseQuery p s, KnownSymbol s + , ParseQueryOneOf p ss) + => ParseQueryOneOf p (s ': ss) where + parseQueryOneOf pp _ps vmap frmap sel + = do refinedSel <- refineSelection sel + parsedQ <- parseQuery pp (Proxy @s) vmap frmap refinedSel + restQ <- parseQueryOneOf pp (Proxy @ss) vmap frmap sel + pure (ChosenOneOfQuery (Proxy @s) parsedQ :* restQ) + where + -- refineSelection :: [GQL.Selection] -> f [GQL.Selection] + refineSelection [] = pure [] + refineSelection (f@GQL.FieldSelection {} : rest) + = (f :) <$> refineSelection rest + refineSelection (GQL.InlineFragmentSelection (GQL.InlineFragment ty dirs innerSs _) : rest) + | any (shouldSkip vmap) dirs + = refineSelection rest + | Nothing <- ty + = (++) <$> refineSelection (F.toList innerSs) <*> refineSelection rest + | Just selectedTy <- ty, selectedTy == T.pack (nameVal (Proxy @s)) + = (++) <$> refineSelection (F.toList innerSs) <*> refineSelection rest + | otherwise + = refineSelection rest + refineSelection (GQL.FragmentSpreadSelection (GQL.FragmentSpread nm dirs _) : rest) + | any (shouldSkip vmap) dirs + = refineSelection rest + | Just (GQL.FragmentDefinition _ fTy fDirs fSel fLoc) <- HM.lookup nm frmap + = refineSelection (GQL.InlineFragmentSelection (GQL.InlineFragment (Just fTy) fDirs fSel fLoc) : rest) + | otherwise -- the fragment definition was not found + = throwError $ "fragment '" <> nm <> "' was not found" + + +instance ( ParseMethod p ('Service s methods) methods, KnownName s ) + => ParseQuery' p s ('Service s methods) where + parseQuery' _pp _ps _psvc vmap frmap fs = ServiceQuery <$> go fs + where + go [] = pure [] + go (GQL.FieldSelection fld : ss) + = (++) <$> (maybeToList <$> fieldToMethod fld) <*> go ss + go (GQL.FragmentSpreadSelection (GQL.FragmentSpread nm dirs _) : ss) + | any (shouldSkip vmap) dirs + = go ss + | Just (GQL.FragmentDefinition _ fTy fDirs fSel fLoc) <- HM.lookup nm frmap + = go (GQL.InlineFragmentSelection (GQL.InlineFragment (Just fTy) fDirs fSel fLoc) : ss) + | otherwise -- the fragment definition was not found + = throwError $ "fragment '" <> nm <> "' was not found" + go (GQL.InlineFragmentSelection (GQL.InlineFragment ty dirs innerSs _) : ss) + | any (shouldSkip vmap) dirs + = go ss + | Nothing <- ty + = go (F.toList innerSs ++ ss) + | Just selectedTy <- ty + = let thisTy = T.pack (nameVal (Proxy @s)) + in if selectedTy == thisTy + then go (F.toList innerSs ++ ss) + else throwError $ "fragment for '" <> selectedTy <> "' used in '" <> thisTy <> "'" + -- fieldToMethod :: GQL.Field -> f (Maybe (OneMethodQuery p ('Service sname methods))) + fieldToMethod f@(GQL.Field alias name args dirs sels _) + | any (shouldSkip vmap) dirs + = pure Nothing + | name == "__typename" + = case (args, sels) of + ([], []) -> pure $ Just $ TypeNameQuery alias + _ -> throwError "__typename does not admit arguments nor selection of subfields" + | name == "__schema" + = case args of + [] -> Just . SchemaQuery alias <$> unFragment frmap (F.toList sels) + _ -> throwError "__schema does not admit selection of subfields" + | name == "__type" + = let getString (GQL.String s) = Just s + getString (GQL.Variable v) = HM.lookup v vmap >>= getString + getString _ = Nothing + in case args of + [GQL.Argument _ (GQL.Node val _) _] + -> case getString val of + Just s -> Just . TypeQuery alias s <$> unFragment frmap sels + _ -> throwError "__type requires a string argument" + _ -> throwError "__type requires one single argument" + | otherwise + = Just . OneMethodQuery alias + <$> selectMethod (Proxy @('Service s methods)) + (T.pack $ nameVal (Proxy @s)) + vmap frmap f + +shouldSkip :: VariableMap -> GQL.Directive -> Bool +shouldSkip vmap (GQL.Directive nm [GQL.Argument ifn (GQL.Node v _) _] _) + | nm == "skip", ifn == "if" + = case valueParser' @'[] @('TPrimitive Bool) vmap "" v of + Right (FPrimitive b) -> b + _ -> False + | nm == "include", ifn == "if" + = case valueParser' @'[] @('TPrimitive Bool) vmap "" v of + Right (FPrimitive b) -> not b + _ -> False +shouldSkip _ _ = False + +unFragment :: MonadError T.Text f + => FragmentMap -> [GQL.Selection] -> f [GQL.Selection] +unFragment _ [] = pure [] +unFragment frmap (GQL.FragmentSpreadSelection (GQL.FragmentSpread nm _ _) : ss) + | Just fr <- HM.lookup nm frmap + = (++) <$> unFragment frmap (fdSelectionSet fr) + <*> unFragment frmap ss + | otherwise -- the fragment definition was not found + = throwError $ "fragment '" <> nm <> "' was not found" +unFragment frmap (GQL.FieldSelection (GQL.Field al nm args dir innerss loc) : ss) + = (:) <$> (GQL.FieldSelection . flip (GQL.Field al nm args dir) loc + <$> unFragment frmap innerss) + <*> unFragment frmap ss +unFragment _ _ + = throwError "inline fragments are not (yet) supported" + +class ParseMethod (p :: Package') (s :: Service') (ms :: [Method']) where + selectMethod :: + MonadError T.Text f => + Proxy s -> + T.Text -> + VariableMap -> + FragmentMap -> + GQL.Field -> + {- GQL.Name -> + [GQL.Argument] -> + GQL.SelectionSet -> -} + f (NS (ChosenMethodQuery p) ms) + +instance ParseMethod p s '[] where + selectMethod _ tyName _ _ (fName -> wanted) + = throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'" +instance + ( KnownName mname, ParseMethod p s ms + , ParseArgs p s ('Method mname args r) args + , ParseDifferentReturn p r) => + ParseMethod p s ('Method mname args r ': ms) + where + selectMethod s tyName vmap frmap f@(GQL.Field _ wanted args _ sels _) + | wanted == mname + = Z <$> (ChosenMethodQuery f + <$> parseArgs (Proxy @s) (Proxy @('Method mname args r)) vmap args + <*> parseDiffReturn vmap frmap wanted sels) + | otherwise + = S <$> selectMethod s tyName vmap frmap f + where + mname = T.pack $ nameVal (Proxy @mname) + +class ParseArgs (p :: Package') (s :: Service') (m :: Method') (args :: [Argument']) where + parseArgs :: MonadError T.Text f + => Proxy s -> Proxy m + -> VariableMap + -> [GQL.Argument] + -> f (NP (ArgumentValue p) args) + +instance ParseArgs p s m '[] where + parseArgs _ _ _ _ = pure Nil +-- one single argument without name +instance ParseArg p a + => ParseArgs p s m '[ 'ArgSingle 'Nothing a ] where + parseArgs _ _ vmap [GQL.Argument _ (GQL.Node x _) _] + = (\v -> ArgumentValue v :* Nil) <$> parseArg' vmap "arg" x + parseArgs _ _ _ _ + = throwError "this field receives one single argument" +instance ParseArg p a + => ParseArgs p s m '[ 'ArgStream 'Nothing a ] where + parseArgs _ _ vmap [GQL.Argument _ (GQL.Node x _) _] + = (\v -> ArgumentStream v :* Nil) <$> parseArg' vmap "arg" x + parseArgs _ _ _ _ + = throwError "this field receives one single argument" +-- more than one argument +instance ( KnownName aname, ParseMaybeArg p a, ParseArgs p s m as + , s ~ 'Service snm sms, m ~ 'Method mnm margs mr + , ann ~ GetArgAnnotationMay (AnnotatedPackage DefaultValue p) snm mnm aname + , FindDefaultArgValue ann ) + => ParseArgs p s m ('ArgSingle ('Just aname) a ': as) where + parseArgs ps pm vmap args + = let aname = T.pack $ nameVal (Proxy @aname) + in case find ((== nameVal (Proxy @aname)) . T.unpack . argName) args of + Just (GQL.Argument _ (GQL.Node x _) _) + -> (:*) <$> (ArgumentValue <$> parseMaybeArg vmap aname (Just x)) + <*> parseArgs ps pm vmap args + Nothing + -> do let x = findDefaultArgValue (Proxy @ann) + (:*) <$> (ArgumentValue <$> parseMaybeArg vmap aname (constToValue <$> x)) + <*> parseArgs ps pm vmap args +instance ( KnownName aname, ParseArg p a, ParseArgs p s m as + , s ~ 'Service snm sms, m ~ 'Method mnm margs mr + , ann ~ GetArgAnnotationMay (AnnotatedPackage DefaultValue p) snm mnm aname + , FindDefaultArgValue ann ) + => ParseArgs p s m ('ArgStream ('Just aname) a ': as) where + parseArgs ps pm vmap args + = let aname = T.pack $ nameVal (Proxy @aname) + in case find ((== nameVal (Proxy @aname)) . T.unpack . argName) args of + Just (GQL.Argument _ (GQL.Node x _) _) + -> (:*) <$> (ArgumentStream <$> parseMaybeArg vmap aname (Just x)) + <*> parseArgs ps pm vmap args + Nothing + -> do let x = findDefaultArgValue (Proxy @ann) + (:*) <$> (ArgumentStream <$> parseMaybeArg vmap aname (constToValue <$> x)) + <*> parseArgs ps pm vmap args + +class FindDefaultArgValue (vs :: Maybe DefaultValue) where + findDefaultArgValue :: Proxy vs + -> Maybe GQL.ConstValue +instance FindDefaultArgValue 'Nothing where + findDefaultArgValue _ = Nothing +instance ReflectValueConst v + => FindDefaultArgValue ('Just ('DefaultValue v)) where + findDefaultArgValue _ = Just $ reflectValueConst (Proxy @v) + +class ParseMaybeArg (p :: Package') (a :: TypeRef Symbol) where + parseMaybeArg :: MonadError T.Text f + => VariableMap + -> T.Text + -> Maybe GQL.Value + -> f (ArgumentValue' p a) + +instance {-# OVERLAPS #-} (ParseArg p a) + => ParseMaybeArg p ('OptionalRef a) where + parseMaybeArg vmap aname (Just x) + = ArgOptional . Just <$> parseArg' vmap aname x + parseMaybeArg _ _ Nothing + = pure $ ArgOptional Nothing +instance {-# OVERLAPS #-} (ParseArg p a) + => ParseMaybeArg p ('ListRef a) where + parseMaybeArg vmap aname (Just x) + = parseArg' vmap aname x + parseMaybeArg _ _ Nothing + = pure $ ArgList [] +instance {-# OVERLAPPABLE #-} (ParseArg p a) + => ParseMaybeArg p a where + parseMaybeArg vmap aname (Just x) + = parseArg' vmap aname x + parseMaybeArg _ aname Nothing + = throwError $ "argument '" <> aname <> + "' was not given a value, and has no default one" + + +parseArg' :: (ParseArg p a, MonadError T.Text f) + => VariableMap + -> T.Text + -> GQL.Value + -> f (ArgumentValue' p a) +parseArg' vmap aname (GQL.Variable x) + = case HM.lookup x vmap of + Nothing -> throwError $ "variable '" <> x <> "' was not found" + Just v -> parseArg vmap aname v +parseArg' vmap aname v = parseArg vmap aname v + +class ParseArg (p :: Package') (a :: TypeRef Symbol) where + parseArg :: MonadError T.Text f + => VariableMap + -> T.Text + -> GQL.Value + -> f (ArgumentValue' p a) + +instance (ParseArg p r) => ParseArg p ('ListRef r) where + parseArg vmap aname (GQL.List xs) + = ArgList <$> traverse (parseArg' vmap aname) xs + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef Bool) where + parseArg _ _ (GQL.Boolean b) + = pure $ ArgPrimitive b + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef Int32) where + parseArg _ _ (GQL.Int b) + = pure $ ArgPrimitive $ fromIntegral b + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef Integer) where + parseArg _ _ (GQL.Int b) + = pure $ ArgPrimitive (toInteger b) + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef Scientific) where + parseArg _ _ (GQL.Float b) + = pure $ ArgPrimitive $ fromFloatDigits b + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef Double) where + parseArg _ _ (GQL.Float b) + = pure $ ArgPrimitive b + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef T.Text) where + parseArg _ _ (GQL.String b) + = pure $ ArgPrimitive b + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef String) where + parseArg _ _ (GQL.String b) + = pure $ ArgPrimitive $ T.unpack b + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance ParseArg p ('PrimitiveRef ()) where + parseArg _ _ GQL.Null = pure $ ArgPrimitive () + parseArg _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance (ObjectOrEnumParser sch (sch :/: sty)) + => ParseArg p ('SchemaRef sch sty) where + parseArg vmap aname v + = ArgSchema <$> parseObjectOrEnum' vmap aname v + +parseObjectOrEnum' :: (ObjectOrEnumParser sch t, MonadError T.Text f) + => VariableMap + -> T.Text + -> GQL.Value + -> f (Term sch t) +parseObjectOrEnum' vmap aname (GQL.Variable x) + = case HM.lookup x vmap of + Nothing -> throwError $ "variable '" <> x <> "' was not found" + Just v -> parseObjectOrEnum vmap aname v +parseObjectOrEnum' vmap aname v + = parseObjectOrEnum vmap aname v + +class ObjectOrEnumParser (sch :: Schema') (t :: TypeDef Symbol Symbol) where + parseObjectOrEnum :: MonadError T.Text f + => VariableMap + -> T.Text + -> GQL.Value + -> f (Term sch t) + +instance (ObjectParser sch args, KnownName name) + => ObjectOrEnumParser sch ('DRecord name args) where + parseObjectOrEnum vmap _ (GQL.Object vs) + = TRecord <$> objectParser vmap (T.pack $ nameVal (Proxy @name)) vs + parseObjectOrEnum _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" +instance (EnumParser choices, KnownName name) + => ObjectOrEnumParser sch ('DEnum name choices) where + parseObjectOrEnum _ _ (GQL.Enum nm) + = TEnum <$> enumParser (T.pack $ nameVal (Proxy @name)) nm + parseObjectOrEnum _ aname _ + = throwError $ "argument '" <> aname <> "' was not of right type" + +class ObjectParser (sch :: Schema') (args :: [FieldDef Symbol Symbol]) where + objectParser :: MonadError T.Text f + => VariableMap + -> T.Text + -> [GQL.ObjectField GQL.Value] + -> f (NP (Field sch) args) + +instance ObjectParser sch '[] where + objectParser _ _ _ = pure Nil +instance + (ObjectParser sch args, ValueParser sch v, KnownName nm) => + ObjectParser sch ('FieldDef nm v ': args) + where + objectParser vmap tyName args + = let wanted = T.pack $ nameVal (Proxy @nm) + in case find ((== wanted) . GQL.name) args of + Just (GQL.ObjectField _ (GQL.Node v _) _) + -> (:*) <$> (Field <$> valueParser' vmap wanted v) <*> objectParser vmap tyName args + Nothing -> throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'" + +class EnumParser (choices :: [ChoiceDef Symbol]) where + enumParser :: MonadError T.Text f + => T.Text -> GQL.Name + -> f (NS Proxy choices) + +instance EnumParser '[] where + enumParser tyName wanted + = throwError $ "value '" <> wanted <> "' was not found on enum '" <> tyName <> "'" +instance (KnownName name, EnumParser choices) + => EnumParser ('ChoiceDef name ': choices) where + enumParser tyName wanted + | wanted == mname = pure (Z Proxy) + | otherwise = S <$> enumParser tyName wanted + where + mname = T.pack $ nameVal (Proxy @name) + +valueParser' :: (ValueParser sch v, MonadError T.Text f) + => VariableMap + -> T.Text + -> GQL.Value + -> f (FieldValue sch v) +valueParser' vmap aname (GQL.Variable x) + = case HM.lookup x vmap of + Nothing -> throwError $ "variable '" <> x <> "' was not found" + Just v -> valueParser vmap aname v +valueParser' vmap aname v = valueParser vmap aname v + +class ValueParser (sch :: Schema') (v :: FieldType Symbol) where + valueParser :: MonadError T.Text f + => VariableMap + -> T.Text + -> GQL.Value + -> f (FieldValue sch v) + +instance ValueParser sch 'TNull where + valueParser _ _ GQL.Null = pure FNull + valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" +instance ValueParser sch ('TPrimitive Bool) where + valueParser _ _ (GQL.Boolean b) = pure $ FPrimitive b + valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" +instance ValueParser sch ('TPrimitive Int32) where + valueParser _ _ (GQL.Int b) = pure $ FPrimitive $ fromIntegral b + valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" +instance ValueParser sch ('TPrimitive Integer) where + valueParser _ _ (GQL.Int b) = pure $ FPrimitive $ toInteger b + valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" +instance ValueParser sch ('TPrimitive Scientific) where + valueParser _ _ (GQL.Float b) = pure $ FPrimitive $ fromFloatDigits b + valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" +instance ValueParser sch ('TPrimitive Double) where + valueParser _ _ (GQL.Float b) = pure $ FPrimitive b + valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" +instance ValueParser sch ('TPrimitive T.Text) where + valueParser _ _ (GQL.String b) = pure $ FPrimitive b + valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" +instance ValueParser sch ('TPrimitive String) where + valueParser _ _ (GQL.String b) = pure $ FPrimitive $ T.unpack b + valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" +instance (ValueParser sch r) => ValueParser sch ('TList r) where + valueParser vmap fname (GQL.List xs) = FList <$> traverse (valueParser' vmap fname) xs + valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" +instance (ValueParser sch r) => ValueParser sch ('TOption r) where + valueParser _ _ GQL.Null = pure $ FOption Nothing + valueParser vmap fname v = FOption . Just <$> valueParser' vmap fname v +instance (ObjectOrEnumParser sch (sch :/: sty), KnownName sty) + => ValueParser sch ('TSchematic sty) where + valueParser vmap _ v = FSchematic <$> parseObjectOrEnum' vmap (T.pack $ nameVal (Proxy @sty)) v +instance ValueParser sch ('TPrimitive A.Value) where + valueParser vmap _ x = FPrimitive <$> toAesonValue vmap x +instance ValueParser sch ('TPrimitive A.Object) where + valueParser vm _ (GQL.Object xs) = FPrimitive . HM.fromList <$> traverse (toKeyValuePairs vm) xs + valueParser _ fname _ = throwError $ "field '" <> fname <> "' was not of right type" + +toKeyValuePairs :: MonadError T.Text m => VariableMap -> GQL.ObjectField GQL.Value -> m (T.Text, A.Value) +toKeyValuePairs vmap (GQL.ObjectField key (GQL.Node v _) _) = (key,) <$> toAesonValue vmap v + +toAesonValue :: MonadError T.Text m => VariableMap -> GQL.Value -> m A.Value +toAesonValue vm (GQL.Variable v) = + case HM.lookup v vm of + Nothing -> throwError $ "variable '" <> v <> "' was not found" + Just xs -> toAesonValue vm xs +toAesonValue _ (GQL.Int n) = pure . A.Number $ fromIntegral n +toAesonValue _ (GQL.Float d) = pure . A.Number $ fromFloatDigits d +toAesonValue _ (GQL.String s) = pure $ A.String s +toAesonValue _ (GQL.Boolean b) = pure $ A.Bool b +toAesonValue _ GQL.Null = pure A.Null +toAesonValue _ (GQL.Enum e) = pure $ A.String e +toAesonValue vm (GQL.List xs) = A.toJSON <$> traverse (toAesonValue vm) xs +toAesonValue vm (GQL.Object xs) = A.Object . HM.fromList <$> traverse (toKeyValuePairs vm) xs + +class ParseDifferentReturn (p :: Package') (r :: Return Symbol (TypeRef Symbol)) where + parseDiffReturn :: MonadError T.Text f + => VariableMap + -> FragmentMap + -> T.Text + -> [GQL.Selection] + -> f (ReturnQuery p r) +instance ParseDifferentReturn p 'RetNothing where + parseDiffReturn _ _ _ [] = pure RNothing + parseDiffReturn _ _ fname _ + = throwError $ "field '" <> fname <> "' should not have a selection of subfields" +instance ParseReturn p r => ParseDifferentReturn p ('RetSingle r) where + parseDiffReturn vmap frmap fname s + = RSingle <$> parseReturn vmap frmap fname s +instance ParseReturn p r => ParseDifferentReturn p ('RetStream r) where + parseDiffReturn vmap frmap fname s + = RStream <$> parseReturn vmap frmap fname s + +class ParseReturn (p :: Package') (r :: TypeRef Symbol) where + parseReturn :: MonadError T.Text f + => VariableMap + -> FragmentMap + -> T.Text + -> [GQL.Selection] + -> f (ReturnQuery' p r) + +instance ParseReturn p ('PrimitiveRef t) where + parseReturn _ _ _ [] + = pure RetPrimitive + parseReturn _ _ fname _ + = throwError $ "field '" <> fname <> "' should not have a selection of subfields" +instance (ParseSchema sch (sch :/: sty)) + => ParseReturn p ('SchemaRef sch sty) where + parseReturn vmap frmap fname s + = RetSchema <$> parseSchema vmap frmap fname s +instance ParseReturn p r + => ParseReturn p ('ListRef r) where + parseReturn vmap frmap fname s + = RetList <$> parseReturn vmap frmap fname s +instance ParseReturn p r + => ParseReturn p ('OptionalRef r) where + parseReturn vmap frmap fname s + = RetOptional <$> parseReturn vmap frmap fname s +instance ( p ~ 'Package pname ss, ParseQuery p s, KnownName s ) + => ParseReturn p ('ObjectRef s) where + parseReturn vmap frmap _ s + = RetObject <$> parseQuery (Proxy @p) (Proxy @s) vmap frmap s + +class ParseSchema (s :: Schema') (t :: TypeDef Symbol Symbol) where + parseSchema :: MonadError T.Text f + => VariableMap + -> FragmentMap + -> T.Text + -> [GQL.Selection] + -> f (SchemaQuery s t) +instance ParseSchema sch ('DEnum name choices) where + parseSchema _ _ _ [] + = pure QueryEnum + parseSchema _ _ fname _ + = throwError $ "field '" <> fname <> "' should not have a selection of subfields" +instance (KnownName name, ParseField sch fields) + => ParseSchema sch ('DRecord name fields) where + parseSchema vmap frmap _ s + = QueryRecord <$> parseSchemaQuery (Proxy @sch) (Proxy @('DRecord name fields)) vmap frmap s + +parseSchemaQuery :: + forall (sch :: Schema') t (rname :: Symbol) fields f. + ( MonadError T.Text f + , t ~  'DRecord rname fields + , KnownName rname + , ParseField sch fields ) => + Proxy sch -> + Proxy t -> + VariableMap -> FragmentMap -> [GQL.Selection] -> + f [OneFieldQuery sch fields] +parseSchemaQuery _ _ _ _ [] = pure [] +parseSchemaQuery pp ps vmap frmap (GQL.FieldSelection fld : ss) + = (++) <$> (maybeToList <$> fieldToMethod fld) + <*> parseSchemaQuery pp ps vmap frmap ss + where + fieldToMethod :: GQL.Field -> f (Maybe (OneFieldQuery sch fields)) + fieldToMethod (GQL.Field alias name args dirs sels _) + | any (shouldSkip vmap) dirs + = pure Nothing + | name == "__typename" + = case (args, sels) of + ([], []) -> pure $ Just $ TypeNameFieldQuery alias + _ -> throwError "__typename does not admit arguments nor selection of subfields" + | _:_ <- args + = throwError "this field does not support arguments" + | otherwise + = Just . OneFieldQuery alias + <$> selectField (T.pack $ nameVal (Proxy @rname)) vmap frmap name sels +parseSchemaQuery pp ps vmap frmap (GQL.FragmentSpreadSelection (GQL.FragmentSpread nm dirs _) : ss) + | Just fr <- HM.lookup nm frmap + = if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ fdDirectives fr) + then (++) <$> parseSchemaQuery pp ps vmap frmap (fdSelectionSet fr) + <*> parseSchemaQuery pp ps vmap frmap ss + else parseSchemaQuery pp ps vmap frmap ss + | otherwise -- the fragment definition was not found + = throwError $ "fragment '" <> nm <> "' was not found" +parseSchemaQuery _ _ _ _ (_ : _) -- Inline fragments are not yet supported + = throwError "inline fragments are not (yet) supported" + +class ParseField (sch :: Schema') (fs :: [FieldDef Symbol Symbol]) where + selectField :: + MonadError T.Text f => + T.Text -> + VariableMap -> + FragmentMap -> + GQL.Name -> + [GQL.Selection] -> + f (NS (ChosenFieldQuery sch) fs) + +instance ParseField sch '[] where + selectField tyName _ _ wanted _ + = throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'" +instance + (KnownName fname, ParseField sch fs, ParseSchemaReturn sch r) => + ParseField sch ('FieldDef fname r ': fs) + where + selectField tyName vmap frmap wanted sels + | wanted == mname + = Z <$> (ChosenFieldQuery <$> parseSchemaReturn vmap frmap wanted sels) + | otherwise + = S <$> selectField tyName vmap frmap wanted sels + where + mname = T.pack $ nameVal (Proxy @fname) + +class ParseSchemaReturn (sch :: Schema') (r :: FieldType Symbol) where + parseSchemaReturn :: MonadError T.Text f + => VariableMap + -> FragmentMap + -> T.Text + -> [GQL.Selection] + -> f (ReturnSchemaQuery sch r) + +instance ParseSchemaReturn sch ('TPrimitive t) where + parseSchemaReturn _ _ _ [] + = pure RetSchPrimitive + parseSchemaReturn _ _ fname _ + = throwError $ "field '" <> fname <> "' should not have a selection of subfields" +instance ( ParseSchema sch (sch :/: sty) ) + => ParseSchemaReturn sch ('TSchematic sty) where + parseSchemaReturn vmap frmap fname s + = RetSchSchema <$> parseSchema vmap frmap fname s +instance ParseSchemaReturn sch r + => ParseSchemaReturn sch ('TList r) where + parseSchemaReturn vmap frmap fname s + = RetSchList <$> parseSchemaReturn vmap frmap fname s +instance ParseSchemaReturn sch r + => ParseSchemaReturn sch ('TOption r) where + parseSchemaReturn vmap frmap fname s + = RetSchOptional <$> parseSchemaReturn vmap frmap fname s + +-- some useful field accessors + +fdName :: GQL.FragmentDefinition -> GQL.Name +fdName (GQL.FragmentDefinition nm _ _ _ _) = nm + +fdDirectives :: GQL.FragmentDefinition -> [GQL.Directive] +fdDirectives (GQL.FragmentDefinition _ _ ds _ _) = ds + +fdSelectionSet :: GQL.FragmentDefinition -> [GQL.Selection] +fdSelectionSet (GQL.FragmentDefinition _ _ _ ss _) + = F.toList ss + +argName :: GQL.Argument -> GQL.Name +argName (GQL.Argument nm _ _) = nm + +fName :: GQL.Field -> GQL.Name +fName (GQL.Field _ nm _ _ _ _) = nm diff --git a/graphql/src/Mu/GraphQL/Query/Run.hs b/graphql/src/Mu/GraphQL/Query/Run.hs new file mode 100644 index 00000000..b539e3b9 --- /dev/null +++ b/graphql/src/Mu/GraphQL/Query/Run.hs @@ -0,0 +1,867 @@ +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedLists #-} +{-# language OverloadedStrings #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TupleSections #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-# OPTIONS_GHC -fprint-explicit-foralls #-} +module Mu.GraphQL.Query.Run ( + GraphQLApp +, runPipeline +, runSubscriptionPipeline +, runDocument +, runQuery +, runSubscription +-- * Typeclass to be able to run query handlers +, RunQueryFindHandler +) where + +import Control.Concurrent.STM.TMQueue +import Control.Monad.Except (MonadError, runExceptT) +import Control.Monad.Writer +import qualified Data.Aeson as Aeson +import qualified Data.Aeson.Types as Aeson +import Data.Conduit +import Data.Conduit.Combinators (sinkList, yieldMany) +import Data.Conduit.TQueue +import qualified Data.HashMap.Strict as HM +import Data.Maybe +import qualified Data.Text as T +import Data.Typeable +import GHC.TypeLits +import qualified Language.GraphQL.AST as GQL +import Network.HTTP.Types.Header +import Unsafe.Coerce (unsafeCoerce) + +import Mu.GraphQL.Query.Definition +import qualified Mu.GraphQL.Query.Introspection as Intro +import Mu.GraphQL.Query.Parse +import Mu.Rpc +import Mu.Schema +import Mu.Server + +data GraphQLError + = GraphQLError ServerError [T.Text] + +type GraphQLApp p qr mut sub m chn hs + = (ParseTypedDoc p qr mut sub, RunDocument p qr mut sub m chn hs) + +runPipeline + :: forall qr mut sub p m chn hs. GraphQLApp p qr mut sub m chn hs + => (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> ServerT chn GQL.Field p m hs + -> Proxy qr -> Proxy mut -> Proxy sub + -> Maybe T.Text -> VariableMapC -> [GQL.Definition] + -> IO Aeson.Value +runPipeline f req svr _ _ _ opName vmap doc + = case parseDoc @qr @mut @sub opName vmap doc of + Left e -> pure $ singleErrValue e + Right (d :: Document p qr mut sub) -> do + (data_, errors) <- runWriterT (runDocument f req svr d) + case errors of + [] -> pure $ Aeson.object [ ("data", data_) ] + _ -> pure $ Aeson.object [ ("data", data_), ("errors", Aeson.listValue errValue errors) ] + +runSubscriptionPipeline + :: forall qr mut sub p m chn hs. GraphQLApp p qr mut sub m chn hs + => (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> ServerT chn GQL.Field p m hs + -> Proxy qr -> Proxy mut -> Proxy sub + -> Maybe T.Text -> VariableMapC -> [GQL.Definition] + -> ConduitT Aeson.Value Void IO () + -> IO () +runSubscriptionPipeline f req svr _ _ _ opName vmap doc sink + = case parseDoc @qr @mut @sub opName vmap doc of + Left e + -> yieldSingleError e sink + Right (d :: Document p qr mut sub) + -> runDocumentSubscription f req svr d sink + +singleErrValue :: T.Text -> Aeson.Value +singleErrValue e + = Aeson.object [ ("errors", Aeson.Array [ + Aeson.object [ ("message", Aeson.String e) ] ])] + +errValue :: GraphQLError -> Aeson.Value +errValue (GraphQLError (ServerError _ msg) path) + = Aeson.object [ + ("message", Aeson.String $ T.pack msg) + , ("path", Aeson.toJSON path) + ] + +yieldSingleError :: Monad m + => T.Text -> ConduitM Aeson.Value Void m () -> m () +yieldSingleError e sink = + runConduit $ yieldMany ([singleErrValue e] :: [Aeson.Value]) .| sink + +yieldError :: Monad m + => ServerError -> [T.Text] + -> ConduitM Aeson.Value Void m () -> m () +yieldError e path sink = do + let val = Aeson.object [ ("errors", Aeson.listValue errValue [GraphQLError e path]) ] + runConduit $ yieldMany ([val] :: [Aeson.Value]) .| sink + +class RunDocument (p :: Package') + (qr :: Maybe Symbol) + (mut :: Maybe Symbol) + (sub :: Maybe Symbol) + m chn hs where + runDocument :: + (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> ServerT chn GQL.Field p m hs + -> Document p qr mut sub + -> WriterT [GraphQLError] IO Aeson.Value + runDocumentSubscription :: + (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> ServerT chn GQL.Field p m hs + -> Document p qr mut sub + -> ConduitT Aeson.Value Void IO () + -> IO () + +instance + ( p ~ 'Package pname ss + , KnownSymbol qr + , RunQueryFindHandler m p hs chn ss (LookupService ss qr) hs + , MappingRight chn qr ~ () + , KnownSymbol mut + , RunQueryFindHandler m p hs chn ss (LookupService ss mut) hs + , MappingRight chn mut ~ () + , KnownSymbol sub + , RunQueryFindHandler m p hs chn ss (LookupService ss sub) hs + , MappingRight chn sub ~ () + , Intro.Introspect p ('Just qr) ('Just mut) ('Just sub) + ) => RunDocument p ('Just qr) ('Just mut) ('Just sub) m chn hs where + runDocument f req svr d + = let i = Intro.introspect (Proxy @p) (Proxy @('Just qr)) (Proxy @('Just mut)) (Proxy @('Just sub)) + in case d of + QueryDoc q + -> runQuery f req i svr [] () q + MutationDoc q + -> runQuery f req i svr [] () q + SubscriptionDoc _ + -> pure $ singleErrValue "cannot execute subscriptions in this wire" + runDocumentSubscription f req svr (SubscriptionDoc d) + = runSubscription f req svr [] () d + runDocumentSubscription f req svr d = yieldDocument f req svr d + +instance + ( p ~ 'Package pname ss + , KnownSymbol qr + , RunQueryFindHandler m p hs chn ss (LookupService ss qr) hs + , MappingRight chn qr ~ () + , KnownSymbol mut + , RunQueryFindHandler m p hs chn ss (LookupService ss mut) hs + , MappingRight chn mut ~ () + , Intro.Introspect p ('Just qr) ('Just mut) 'Nothing + ) => RunDocument p ('Just qr) ('Just mut) 'Nothing m chn hs where + runDocument f req svr d + = let i = Intro.introspect (Proxy @p) (Proxy @('Just qr)) (Proxy @('Just mut)) (Proxy @'Nothing) + in case d of + QueryDoc q + -> runQuery f req i svr [] () q + MutationDoc q + -> runQuery f req i svr [] () q + runDocumentSubscription = yieldDocument + +instance + ( p ~ 'Package pname ss + , KnownSymbol qr + , RunQueryFindHandler m p hs chn ss (LookupService ss qr) hs + , MappingRight chn qr ~ () + , KnownSymbol sub + , RunQueryFindHandler m p hs chn ss (LookupService ss sub) hs + , MappingRight chn sub ~ () + , Intro.Introspect p ('Just qr) 'Nothing ('Just sub) + ) => RunDocument p ('Just qr) 'Nothing ('Just sub) m chn hs where + runDocument f req svr d + = let i = Intro.introspect (Proxy @p) (Proxy @('Just qr)) (Proxy @'Nothing) (Proxy @('Just sub)) + in case d of + QueryDoc q + -> runQuery f req i svr [] () q + SubscriptionDoc _ + -> pure $ singleErrValue "cannot execute subscriptions in this wire" + runDocumentSubscription f req svr (SubscriptionDoc d) + = runSubscription f req svr [] () d + runDocumentSubscription f req svr d = yieldDocument f req svr d + +instance + ( p ~ 'Package pname ss + , KnownSymbol qr + , RunQueryFindHandler m p hs chn ss (LookupService ss qr) hs + , MappingRight chn qr ~ () + , Intro.Introspect p ('Just qr) 'Nothing 'Nothing + ) => RunDocument p ('Just qr) 'Nothing 'Nothing m chn hs where + runDocument f req svr d + = let i = Intro.introspect (Proxy @p) (Proxy @('Just qr)) (Proxy @'Nothing) (Proxy @'Nothing) + in case d of + QueryDoc q + -> runQuery f req i svr [] () q + runDocumentSubscription = yieldDocument + +instance + ( TypeError ('Text "you need to have a query in your schema") + ) => RunDocument p 'Nothing mut sub m chn hs where + runDocument _ = error "this should never be called" + runDocumentSubscription _ = error "this should never be called" + +yieldDocument :: + forall p qr mut sub m chn hs. + RunDocument p qr mut sub m chn hs + => (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> ServerT chn GQL.Field p m hs + -> Document p qr mut sub + -> ConduitT Aeson.Value Void IO () + -> IO () +yieldDocument f req svr doc sink = do + (data_, errors) <- runWriterT (runDocument @p @qr @mut @sub @m @chn @hs f req svr doc) + let (val :: Aeson.Value) + = case errors of + [] -> Aeson.object [ ("data", data_) ] + _ -> Aeson.object [ ("data", data_), ("errors", Aeson.listValue errValue errors) ] + runConduit $ yieldMany ([val] :: [Aeson.Value]) .| sink + +runQuery + :: forall m p s pname ss hs chn inh. + ( RunQueryFindHandler m p hs chn ss s hs + , p ~ 'Package pname ss + , inh ~ MappingRight chn (ServiceName s) ) + => (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> Intro.Schema -> ServerT chn GQL.Field p m hs + -> [T.Text] + -> inh + -> ServiceQuery p s + -> WriterT [GraphQLError] IO Aeson.Value +runQuery f req sch whole@(Services ss) path = runQueryFindHandler f req sch whole path ss + +runSubscription + :: forall m p s pname ss hs chn inh. + ( RunQueryFindHandler m p hs chn ss s hs + , p ~ 'Package pname ss + , inh ~ MappingRight chn (ServiceName s) ) + => (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> ServerT chn GQL.Field p m hs + -> [T.Text] + -> inh + -> OneMethodQuery p s + -> ConduitT Aeson.Value Void IO () + -> IO () +runSubscription f req whole@(Services ss) path + = runSubscriptionFindHandler f req whole path ss + +class RunQueryFindHandler m p whole chn ss s hs where + runQueryFindHandler + :: ( p ~ 'Package pname wholess + , inh ~ MappingRight chn (ServiceName s) ) + => (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> Intro.Schema -> ServerT chn GQL.Field p m whole + -> [T.Text] + -> ServicesT chn GQL.Field ss m hs + -> inh + -> ServiceQuery p s + -> WriterT [GraphQLError] IO Aeson.Value + runSubscriptionFindHandler + :: ( p ~ 'Package pname wholess + , inh ~ MappingRight chn (ServiceName s) ) + => (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> ServerT chn GQL.Field p m whole + -> [T.Text] + -> ServicesT chn GQL.Field ss m hs + -> inh + -> OneMethodQuery p s + -> ConduitT Aeson.Value Void IO () + -> IO () + +class RunQueryOnFoundHandler m p whole chn (s :: Service snm mnm anm (TypeRef snm)) hs where + type ServiceName s :: snm + runQueryOnFoundHandler + :: ( p ~ 'Package pname wholess + , inh ~ MappingRight chn (ServiceName s) ) + => (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> Intro.Schema -> ServerT chn GQL.Field p m whole + -> [T.Text] + -> ServiceT chn GQL.Field s m hs + -> inh + -> ServiceQuery p s + -> WriterT [GraphQLError] IO Aeson.Value + runSubscriptionOnFoundHandler + :: ( p ~ 'Package pname wholess + , inh ~ MappingRight chn (ServiceName s) ) + => (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> ServerT chn GQL.Field p m whole + -> [T.Text] + -> ServiceT chn GQL.Field s m hs + -> inh + -> OneMethodQuery p s + -> ConduitT Aeson.Value Void IO () + -> IO () + +instance TypeError ('Text "Could not find handler for " ':<>: 'ShowType s) + => RunQueryFindHandler m p whole chn '[] s '[] where + runQueryFindHandler _ = error "this should never be called" + runSubscriptionFindHandler _ = error "this should never be called" +instance {-# OVERLAPPABLE #-} + RunQueryFindHandler m p whole chn ss s hs + => RunQueryFindHandler m p whole chn (other ': ss) s (h ': hs) where + runQueryFindHandler f req sch whole path (_ :<&>: that) + = runQueryFindHandler f req sch whole path that + runSubscriptionFindHandler f req whole path (_ :<&>: that) + = runSubscriptionFindHandler f req whole path that +instance {-# OVERLAPS #-} + (RunQueryOnFoundHandler m p whole chn s h) + => RunQueryFindHandler m p whole chn (s ': ss) s (h ': hs) where + runQueryFindHandler f req sch whole path (s :<&>: _) + = runQueryOnFoundHandler f req sch whole path s + runSubscriptionFindHandler f req whole path (s :<&>: _) + = runSubscriptionOnFoundHandler f req whole path s + +instance ( KnownName sname, RunMethod m p whole chn ('Service sname ms) ms h ) + => RunQueryOnFoundHandler m p whole chn ('Service sname ms) h where + type ServiceName ('Service sname ms) = sname + runQueryOnFoundHandler f req sch whole path (ProperSvc this) inh (ServiceQuery queries) + = Aeson.object . catMaybes <$> mapM runOneQuery queries + where + -- if we include the signature we have to write + -- an explicit type signature for 'runQueryFindHandler' + runOneQuery (OneMethodQuery nm args) + = runMethod f req whole (Proxy @('Service sname ms)) path nm inh this args + -- handle __typename + runOneQuery (TypeNameQuery nm) + = let realName = fromMaybe "__typename" nm + in pure $ Just (realName, Aeson.String $ T.pack $ nameVal (Proxy @sname)) + -- handle __schema + runOneQuery (SchemaQuery nm ss) + = do let realName = fromMaybe "__schema" nm + Just . (realName, ) <$> runIntroSchema path sch ss + -- handle __type + runOneQuery (TypeQuery nm ty ss) + = do let realName = fromMaybe "__schema" nm + res <- runIntroType path sch (Intro.TypeRef ty) ss + case res of + Just val -> pure $ Just (realName, val) + Nothing -> do tell [GraphQLError + (ServerError Invalid + $ "cannot find type '" <> T.unpack ty <> "'") + path] + pure $ Just (realName, Aeson.Null) + -- subscriptions should only have one element + runSubscriptionOnFoundHandler f req whole path (ProperSvc this) inh (OneMethodQuery nm args) sink + = runMethodSubscription f req whole (Proxy @('Service sname ms)) path nm inh this args sink + runSubscriptionOnFoundHandler _ _ _ _ _ _ (TypeNameQuery nm) sink + = let realName = fromMaybe "__typename" nm + o = Aeson.object [(realName, Aeson.String $ T.pack $ nameVal (Proxy @sname))] + in runConduit $ yieldMany ([o] :: [Aeson.Value]) .| sink + runSubscriptionOnFoundHandler _ _ _ _ _ _ _ sink + = runConduit $ yieldMany + ([singleErrValue "__schema and __type are not supported in subscriptions"] + :: [Aeson.Value]) + .| sink + +instance ( KnownName sname, RunUnion m p whole chn elts ) + => RunQueryOnFoundHandler m p whole chn ('OneOf sname elts) h where + type ServiceName ('OneOf sname elts) = sname + runQueryOnFoundHandler f req sch whole path (OneOfSvc this) inh (OneOfQuery queries) + = do res <- liftIO $ runExceptT $ f $ this inh + case res of + Left e -> tell [GraphQLError e path] >> pure Aeson.Null + Right x -> runUnion f req sch whole path queries x + runSubscriptionOnFoundHandler _ _ _ _ (OneOfSvc _) _ _ _ + = error "this should never happen" + +class RunUnion m p whole chn elts where + runUnion + :: (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> Intro.Schema -> ServerT chn GQL.Field p m whole + -> [T.Text] + -> NP (ChosenOneOfQuery p) elts + -> UnionChoice chn elts + -> WriterT [GraphQLError] IO Aeson.Value + +instance RunUnion m p whole chn '[] where + runUnion _ = error "this should never happen" +instance forall m p pname s sname whole ss chn elts. + ( RunQueryFindHandler m p whole chn ss s whole + , p ~ 'Package pname ss + , s ~ LookupService ss sname + , ServiceName s ~ sname + , RunUnion m p whole chn elts ) + => RunUnion m p whole chn (sname ': elts) where + runUnion f req sch whole path + (ChosenOneOfQuery (Proxy :: Proxy sname) q :* rest) + choice@(UnionChoice (Proxy :: Proxy other) v) + = case eqT @sname @other of + Nothing -> runUnion f req sch whole path rest (unsafeCoerce choice) + Just Refl -> runQuery @m @('Package pname ss) @(LookupService ss sname) @pname @ss @whole f req sch whole path v q + +class RunMethod m p whole chn s ms hs where + runMethod + :: ( p ~ 'Package pname wholess + , inh ~ MappingRight chn (ServiceName s) ) + => (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> ServerT chn GQL.Field p m whole + -> Proxy s -> [T.Text] -> Maybe T.Text -> inh + -> HandlersT chn GQL.Field inh ms m hs + -> NS (ChosenMethodQuery p) ms + -> WriterT [GraphQLError] IO (Maybe (T.Text, Aeson.Value)) + runMethodSubscription + :: ( p ~ 'Package pname wholess + , inh ~ MappingRight chn (ServiceName s) ) + => (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> ServerT chn GQL.Field p m whole + -> Proxy s -> [T.Text] -> Maybe T.Text -> inh + -> HandlersT chn GQL.Field inh ms m hs + -> NS (ChosenMethodQuery p) ms + -> ConduitT Aeson.Value Void IO () + -> IO () + +instance RunMethod m p whole chn s '[] '[] where + runMethod _ = error "this should never be called" + runMethodSubscription _ = error "this should never be called" +instance ( RunMethod m p whole chn s ms hs + , KnownName mname + , RunHandler m p whole chn args r h + , ReflectRpcInfo p s ('Method mname args r) ) + => RunMethod m p whole chn s ('Method mname args r ': ms) (h ': hs) where + -- handle normal methods + runMethod f req whole _ path nm inh (h :<||>: _) (Z (ChosenMethodQuery fld args ret)) + = ((realName ,) <$>) <$> runHandler f req whole (path ++ [realName]) (h rpcInfo inh) args ret + where realName = fromMaybe (T.pack $ nameVal (Proxy @mname)) nm + rpcInfo = reflectRpcInfo (Proxy @p) (Proxy @s) (Proxy @('Method mname args r)) req fld + runMethod f req whole p path nm inh (_ :<||>: r) (S cont) + = runMethod f req whole p path nm inh r cont + runMethod _ _ _ _ _ _ _ _ _ = error "this should never happen" + -- handle subscriptions + runMethodSubscription f req whole _ path nm inh (h :<||>: _) (Z (ChosenMethodQuery fld args ret)) sink + = runHandlerSubscription f req whole (path ++ [realName]) (h rpcInfo inh) args ret sink + where realName = fromMaybe (T.pack $ nameVal (Proxy @mname)) nm + rpcInfo = reflectRpcInfo (Proxy @p) (Proxy @s) (Proxy @('Method mname args r)) req fld + runMethodSubscription f req whole p path nm inh (_ :<||>: r) (S cont) sink + = runMethodSubscription f req whole p path nm inh r cont sink + runMethodSubscription _ _ _ _ _ _ _ _ _ _ = error "this should never happen" + +class Handles chn args r m h + => RunHandler m p whole chn args r h where + runHandler + :: (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> ServerT chn GQL.Field p m whole + -> [T.Text] + -> h + -> NP (ArgumentValue p) args + -> ReturnQuery p r + -> WriterT [GraphQLError] IO (Maybe Aeson.Value) + runHandlerSubscription + :: (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> ServerT chn GQL.Field p m whole + -> [T.Text] + -> h + -> NP (ArgumentValue p) args + -> ReturnQuery p r + -> ConduitT Aeson.Value Void IO () + -> IO () + +instance (ArgumentConversion chn ref t, RunHandler m p whole chn rest r h) + => RunHandler m p whole chn ('ArgSingle aname ref ': rest) r (t -> h) where + runHandler f req whole path h (ArgumentValue one :* rest) + = runHandler f req whole path (h (convertArg (Proxy @chn) one)) rest + runHandlerSubscription f req whole path h (ArgumentValue one :* rest) + = runHandlerSubscription f req whole path (h (convertArg (Proxy @chn) one)) rest +instance ( MonadError ServerError m + , FromRef chn ref t + , ArgumentConversion chn ('ListRef ref) [t] + , RunHandler m p whole chn rest r h ) + => RunHandler m p whole chn ('ArgStream aname ref ': rest) r (ConduitT () t m () -> h) where + runHandler f req whole path h (ArgumentStream lst :* rest) + = let converted :: [t] = convertArg (Proxy @chn) lst + in runHandler f req whole path (h (yieldMany converted)) rest + runHandlerSubscription f req whole path h (ArgumentStream lst :* rest) sink + = let converted :: [t] = convertArg (Proxy @chn) lst + in runHandlerSubscription f req whole path (h (yieldMany converted)) rest sink +instance (MonadError ServerError m) + => RunHandler m p whole chn '[] 'RetNothing (m ()) where + runHandler f _req _ path h Nil _ = do + res <- liftIO $ runExceptT (f h) + case res of + Right _ -> pure $ Just Aeson.Null + Left e -> tell [GraphQLError e path] >> pure Nothing + runHandlerSubscription f _req _ path h Nil _ sink = do + res <- liftIO $ runExceptT (f h) + case res of + Right _ -> runConduit $ yieldMany ([] :: [Aeson.Value]) .| sink + Left e -> yieldError e path sink +instance (MonadError ServerError m, ResultConversion m p whole chn r l) + => RunHandler m p whole chn '[] ('RetSingle r) (m l) where + runHandler f req whole path h Nil (RSingle q) = do + res <- liftIO $ runExceptT (f h) + case res of + Right v -> convertResult f req whole path q v + Left e -> tell [GraphQLError e path] >> pure Nothing + runHandlerSubscription f req whole path h Nil (RSingle q) sink = do + res <- liftIO $ runExceptT (f h) + val <- case res of + Right v -> do + (data_, errors) <- runWriterT (convertResult f req whole path q v) + case errors of + [] -> pure $ Aeson.object [ ("data", fromMaybe Aeson.Null data_) ] + _ -> pure $ Aeson.object [ ("data", fromMaybe Aeson.Null data_) + , ("errors", Aeson.listValue errValue errors) ] + Left e -> pure $ Aeson.object [ ("errors", Aeson.listValue errValue [GraphQLError e path]) ] + runConduit $ yieldMany ([val] :: [Aeson.Value]) .| sink +instance (MonadIO m, MonadError ServerError m, ResultConversion m p whole chn r l) + => RunHandler m p whole chn '[] ('RetStream r) (ConduitT l Void m () -> m ()) where + runHandler f req whole path h Nil (RStream q) = do + queue <- liftIO newTMQueueIO + res <- liftIO $ runExceptT $ f $ h (sinkTMQueue queue) + case res of + Right _ -> do + info <- runConduit $ sourceTMQueue queue .| sinkList + Just . Aeson.toJSON . catMaybes <$> traverse (convertResult f req whole path q) info + Left e -> tell [GraphQLError e []] >> pure Nothing + runHandlerSubscription f req whole path h Nil (RStream q) sink = do + res <- liftIO $ runExceptT $ f $ h + (transPipe liftIO (mapInputM convert (error "this should not be called") sink)) + case res of + Right _ -> return () + Left e -> yieldError e path sink + where + convert :: l -> IO Aeson.Value + convert v = do + (data_, errors) <- runWriterT (convertResult f req whole path q v) + case errors of + [] -> pure $ Aeson.object [ ("data", fromMaybe Aeson.Null data_) ] + _ -> pure $ Aeson.object [ ("data", fromMaybe Aeson.Null data_) + , ("errors", Aeson.listValue errValue errors) ] + +class FromRef chn ref t + => ArgumentConversion chn ref t where + convertArg :: Proxy chn -> ArgumentValue' p ref -> t +instance ArgumentConversion chn ('PrimitiveRef s) s where + convertArg _ (ArgPrimitive x) = x +instance FromSchema sch sty t + => ArgumentConversion chn ('SchemaRef sch sty) t where + convertArg _ (ArgSchema x) = fromSchema x +instance ArgumentConversion chn ref t + => ArgumentConversion chn ('ListRef ref) [t] where + convertArg p (ArgList x) = convertArg p <$> x +instance ArgumentConversion chn ref t + => ArgumentConversion chn ('OptionalRef ref) (Maybe t) where + convertArg p (ArgOptional x) = convertArg p <$> x + +class ToRef chn r l => ResultConversion m p whole chn r l where + convertResult :: (forall a. m a -> ServerErrorIO a) + -> RequestHeaders + -> ServerT chn GQL.Field p m whole + -> [T.Text] + -> ReturnQuery' p r + -> l -> WriterT [GraphQLError] IO (Maybe Aeson.Value) + +instance Aeson.ToJSON t => ResultConversion m p whole chn ('PrimitiveRef t) t where + convertResult _ _ _ _ RetPrimitive = pure . Just . Aeson.toJSON +instance ( ToSchema sch l r + , RunSchemaQuery sch (sch :/: l) ) + => ResultConversion m p whole chn ('SchemaRef sch l) r where + convertResult _ _ _ _ (RetSchema r) t + = pure $ Just $ runSchemaQuery (toSchema' @_ @_ @sch @r t) r +instance ( MappingRight chn ref ~ t + , MappingRight chn (ServiceName svc) ~ t + , LookupService ss ref ~ svc + , RunQueryFindHandler m ('Package pname ss) whole chn ss svc whole) + => ResultConversion m ('Package pname ss) whole chn ('ObjectRef ref) t where + convertResult f req whole path (RetObject q) h + = Just <$> runQuery @m @('Package pname ss) @(LookupService ss ref) f req + (error "cannot inspect schema inside a field") + whole path h q +instance ResultConversion m p whole chn r s + => ResultConversion m p whole chn ('OptionalRef r) (Maybe s) where + convertResult _ _ _ _ _ Nothing + = pure Nothing + convertResult f req whole path (RetOptional q) (Just x) + = convertResult f req whole path q x +instance ResultConversion m p whole chn r s + => ResultConversion m p whole chn ('ListRef r) [s] where + convertResult f req whole path (RetList q) xs + = Just . Aeson.toJSON . catMaybes <$> mapM (convertResult f req whole path q) xs + +class RunSchemaQuery sch r where + runSchemaQuery + :: Term sch r + -> SchemaQuery sch r + -> Aeson.Value +instance ( Aeson.ToJSON (Term sch ('DEnum name choices)) ) + => RunSchemaQuery sch ('DEnum name choices) where + runSchemaQuery t _ = Aeson.toJSON t +instance ( KnownName rname, RunSchemaField sch fields ) + => RunSchemaQuery sch ('DRecord rname fields) where + runSchemaQuery (TRecord args) (QueryRecord rs) + = Aeson.object $ mapMaybe runOneQuery rs + where + runOneQuery (OneFieldQuery nm choice) + = let (val, fname) = runSchemaField args choice + realName = fromMaybe fname nm + in (realName,) <$> val + runOneQuery (TypeNameFieldQuery nm) + = let realName = fromMaybe "__typename" nm + -- add the 'R' because it's on return position + in pure (realName, Aeson.String $ T.pack $ nameVal (Proxy @rname) ++ "R") + + +class RunSchemaField sch args where + runSchemaField + :: NP (Field sch) args + -> NS (ChosenFieldQuery sch) args + -> (Maybe Aeson.Value, T.Text) + +instance RunSchemaField sch '[] where + runSchemaField = error "this should never be called" +instance (KnownName fname, RunSchemaType sch t, RunSchemaField sch fs) + => RunSchemaField sch ('FieldDef fname t ': fs) where + runSchemaField (Field x :* _) (Z (ChosenFieldQuery c)) + = (runSchemaType x c, T.pack $ nameVal (Proxy @fname)) + runSchemaField (_ :* xs) (S rest) + = runSchemaField xs rest + +class RunSchemaType sch t where + runSchemaType + :: FieldValue sch t + -> ReturnSchemaQuery sch t + -> Maybe Aeson.Value +instance ( Aeson.ToJSON t ) + => RunSchemaType sch ('TPrimitive t) where + runSchemaType (FPrimitive x) _ + = Just $ Aeson.toJSON x +instance RunSchemaType sch r + => RunSchemaType sch ('TList r) where + runSchemaType (FList xs) (RetSchList r) + = Just . Aeson.toJSON $ mapMaybe (`runSchemaType` r) xs +instance RunSchemaType sch r + => RunSchemaType sch ('TOption r) where + runSchemaType (FOption xs) (RetSchOptional r) + = xs >>= flip runSchemaType r +instance RunSchemaQuery sch (sch :/: l) + => RunSchemaType sch ('TSchematic l) where + runSchemaType (FSchematic t) (RetSchSchema r) + = Just $ runSchemaQuery t r + + +runIntroSchema + :: [T.Text] -> Intro.Schema -> [GQL.Selection] + -> WriterT [GraphQLError] IO Aeson.Value +runIntroSchema path s@(Intro.Schema qr mut sub ts) ss + = do things <- catMaybes <$> traverse runOne ss + pure $ Aeson.object things + where + runOne (GQL.FieldSelection (GQL.Field alias nm _ _ innerss _)) + = let realName :: T.Text = fromMaybe nm alias + path' = path ++ [realName] + in fmap (realName,) <$> case nm of + "description" + -> pure $ Just Aeson.Null + "directives" + -> pure $ Just $ Aeson.Array [] + "queryType" + -> case qr >>= flip HM.lookup ts of + Nothing -> pure Nothing + Just ty -> runIntroType path' s ty innerss + "mutationType" + -> case mut >>= flip HM.lookup ts of + Nothing -> pure Nothing + Just ty -> runIntroType path' s ty innerss + "subscriptionType" + -> case sub >>= flip HM.lookup ts of + Nothing -> pure Nothing + Just ty -> runIntroType path' s ty innerss + "types" + -> do tys <- catMaybes <$> mapM (\t -> runIntroType path' s t innerss) (HM.elems ts) + pure $ Just $ Aeson.toJSON tys + _ -> do tell [GraphQLError + (ServerError Invalid + $ "field '" <> T.unpack nm <> "' was not found on type '__Schema'") + path] + pure Nothing + -- we do not support spreads here + runOne _ = pure Nothing + +runIntroType + :: [T.Text] -> Intro.Schema -> Intro.Type -> [GQL.Selection] + -> WriterT [GraphQLError] IO (Maybe Aeson.Value) +runIntroType path s@(Intro.Schema _ _ _ ts) (Intro.TypeRef t) ss + = case HM.lookup t ts of + Nothing -> pure Nothing + Just ty -> runIntroType path s ty ss +runIntroType path s (Intro.Type k tnm fs vals posTys ofT) ss + = do things <- catMaybes <$> traverse runOne ss + pure $ Just $ Aeson.object things + where + runOne (GQL.FieldSelection (GQL.Field alias nm _ _ innerss _)) + = let realName :: T.Text = fromMaybe nm alias + path' = path ++ [realName] + in fmap (realName,) <$> case (nm, innerss) of + ("kind", []) + -> pure $ Just $ Aeson.String $ T.pack (show k) + ("name", []) + -> pure $ Just $ maybe Aeson.Null Aeson.String tnm + ("description", []) + -> pure $ Just Aeson.Null + + ("fields", _) + -> case k of + Intro.OBJECT + -> do things <- mapM (\f -> runIntroFields path' f innerss) fs + pure $ Just $ Aeson.toJSON things + _ -> pure $ Just Aeson.Null + ("inputFields", _) + -> case k of + Intro.INPUT_OBJECT + -> do things <- mapM (\f -> runIntroFields path' f innerss) fs + pure $ Just $ Aeson.toJSON things + _ -> pure $ Just Aeson.Null + ("enumValues", _) + -> do things <- mapM (\e -> runIntroEnums path' e innerss) vals + pure $ Just $ Aeson.toJSON things + + ("ofType", _) + -> case ofT of + Nothing -> pure $ Just Aeson.Null + Just o -> runIntroType path' s o innerss + + -- unions and interfaces are not supported + ("interfaces", _) + -> pure $ Just $ Aeson.Array [] + ("possibleTypes", _) + -> case k of + Intro.UNION + -> do res <- catMaybes <$> + mapM (\o -> runIntroType path' s o innerss) posTys + pure $ Just $ Aeson.toJSON res + _ -> pure $ Just Aeson.Null + + _ -> do tell [GraphQLError + (ServerError Invalid + $ "field '" <> T.unpack nm <> "' was not found on type '__Type'") + path] + pure Nothing + -- we do not support spreads here + runOne _ = pure Nothing + + runIntroFields + :: [T.Text] -> Intro.Field -> [GQL.Selection] + -> WriterT [GraphQLError] IO (Maybe Aeson.Value) + runIntroFields fpath fld fss + = do things <- catMaybes <$> traverse (runIntroField fpath fld) fss + pure $ Just $ Aeson.object things + + runIntroField fpath (Intro.Field fnm fargs fty) + (GQL.FieldSelection (GQL.Field alias nm _ _ innerss _)) + = let realName :: T.Text = fromMaybe nm alias + fpath' = fpath ++ [realName] + in fmap (realName,) <$> case (nm, innerss) of + ("name", []) + -> pure $ Just $ Aeson.String fnm + ("description", []) + -> pure $ Just Aeson.Null + ("isDeprecated", []) + -> pure $ Just $ Aeson.Bool False + ("deprecationReason", []) + -> pure $ Just Aeson.Null + + -- this is used by __InputValue, + -- which is required when the field + -- is inside an INPUT_OBJECT + ("defaultValue", []) + -> pure $ Just Aeson.Null + + ("type", _) + -> runIntroType fpath' s fty innerss + ("args", _) + -> do things <- mapM (\i -> runIntroInputs fpath' i innerss) fargs + pure $ Just $ Aeson.toJSON things + + _ -> do tell [GraphQLError + (ServerError Invalid + $ "field '" <> T.unpack nm <> "' was not found on type '__Field'") + fpath] + pure Nothing + -- we do not support spreads here + runIntroField _ _ _ = pure Nothing + + runIntroEnums + :: [T.Text] -> Intro.EnumValue -> [GQL.Selection] + -> WriterT [GraphQLError] IO (Maybe Aeson.Value) + runIntroEnums epath enm ess + = do things <- catMaybes <$> traverse (runIntroEnum epath enm) ess + pure $ Just $ Aeson.object things + + runIntroEnum epath (Intro.EnumValue enm) + (GQL.FieldSelection (GQL.Field alias nm _ _ innerss _)) + = let realName :: T.Text = fromMaybe nm alias + in fmap (realName,) <$> case (nm, innerss) of + ("name", []) + -> pure $ Just $ Aeson.String enm + ("description", []) + -> pure $ Just Aeson.Null + ("isDeprecated", []) + -> pure $ Just $ Aeson.Bool False + ("deprecationReason", []) + -> pure $ Just Aeson.Null + + _ -> do tell [GraphQLError + (ServerError Invalid + $ "field '" <> T.unpack nm <> "' was not found on type '__EnumValue'") + epath] + pure Nothing + -- we do not support spreads here + runIntroEnum _ _ _ = pure Nothing + + runIntroInputs + :: [T.Text] -> Intro.Input -> [GQL.Selection] + -> WriterT [GraphQLError] IO (Maybe Aeson.Value) + runIntroInputs ipath inm iss + = do things <- catMaybes <$> traverse (runIntroInput ipath inm) iss + pure $ Just $ Aeson.object things + + runIntroInput ipath (Intro.Input inm def ty) + (GQL.FieldSelection (GQL.Field alias nm _ _ innerss _)) + = let realName :: T.Text = fromMaybe nm alias + ipath' = ipath ++ [realName] + in fmap (realName,) <$> case (nm, innerss) of + ("name", []) + -> pure $ Just $ Aeson.String inm + ("description", []) + -> pure $ Just Aeson.Null + ("defaultValue", []) + -> pure $ Just $ maybe Aeson.Null Aeson.String def + + ("type", _) + -> runIntroType ipath' s ty innerss + + _ -> do tell [GraphQLError + (ServerError Invalid + $ "field '" <> T.unpack nm <> "' was not found on type '__Field'") + ipath] + pure Nothing + -- we do not support spreads here + runIntroInput _ _ _ = pure Nothing diff --git a/graphql/src/Mu/GraphQL/Server.hs b/graphql/src/Mu/GraphQL/Server.hs new file mode 100644 index 00000000..39773d08 --- /dev/null +++ b/graphql/src/Mu/GraphQL/Server.hs @@ -0,0 +1,260 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language GADTs #-} +{-# language OverloadedLists #-} +{-# language OverloadedStrings #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-| +Description : Execute a Mu 'Server' using GraphQL + +This module allows you to server a Mu 'Server' +as a WAI 'Application' using GraphQL. + +The simples way is to use 'runGraphQLAppQuery' +(if you only provide GraphQL queries) or +'runGraphQLApp' (if you also have mutations +or subscriptions). All other variants provide +more control over the settings. +-} +module Mu.GraphQL.Server ( + GraphQLApp + -- * Run an GraphQL resolver directly + , runGraphQLApp + , runGraphQLAppSettings + , runGraphQLAppQuery + , runGraphQLAppTrans + -- * Build a WAI 'Application' + , graphQLApp + , graphQLAppQuery + , graphQLAppTrans + , graphQLAppTransQuery + -- * Lifting of 'Conduit's + , liftServerConduit +) where + +import Control.Applicative ((<|>)) +import Control.Exception (throw) +import Control.Monad.Except (MonadIO (..), join, runExceptT) +import qualified Data.Aeson as A +import Data.Aeson.Text (encodeToLazyText) +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Conduit (ConduitT, transPipe) +import qualified Data.HashMap.Strict as HM +import Data.Proxy (Proxy (..)) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8') +import Data.Text.Encoding.Error (UnicodeException (..)) +import qualified Data.Text.Lazy.Encoding as T +import qualified Language.GraphQL.AST as GQL +import Network.HTTP.Types.Header (hContentType) +import Network.HTTP.Types.Method (StdMethod (..), parseMethod) +import Network.HTTP.Types.Status (ok200) +import Network.Wai +import Network.Wai.Handler.Warp (Port, Settings, run, runSettings) +import qualified Network.Wai.Handler.WebSockets as WS +import qualified Network.WebSockets as WS + +import Mu.GraphQL.Quasi.LostParser (parseDoc) +import Mu.GraphQL.Query.Parse (VariableMapC) +import Mu.GraphQL.Query.Run (GraphQLApp, runPipeline, runSubscriptionPipeline) +import Mu.GraphQL.Subscription.Protocol (protocol) +import Mu.Server (ServerErrorIO, ServerT) + +data GraphQLInput = GraphQLInput T.Text VariableMapC (Maybe T.Text) + +instance A.FromJSON GraphQLInput where + parseJSON = A.withObject "GraphQLInput" $ + \v -> GraphQLInput + <$> v A..: "query" + <*> (v A..: "variables" <|> pure HM.empty) + <*> v A..:? "operationName" + +-- | Turn a Mu GraphQL 'Server' into a WAI 'Application'. +-- Use this version when your server has not only +-- queries, but also mutations or subscriptions. +graphQLApp :: + ( GraphQLApp p qr mut sub ServerErrorIO chn hs ) + => ServerT chn GQL.Field p ServerErrorIO hs + -> Proxy qr + -> Proxy mut + -> Proxy sub + -> Application +graphQLApp = graphQLAppTrans id + +-- | Turn a Mu GraphQL 'Server' into a WAI 'Application'. +-- Use this version when your server has only queries. +graphQLAppQuery :: + forall qr p chn hs. + ( GraphQLApp p ('Just qr) 'Nothing 'Nothing ServerErrorIO chn hs ) + => ServerT chn GQL.Field p ServerErrorIO hs + -> Proxy qr + -> Application +graphQLAppQuery svr _ + = graphQLApp svr (Proxy @('Just qr)) (Proxy @'Nothing) (Proxy @'Nothing) + +-- | Turn a Mu GraphQL 'Server' into a WAI 'Application' +-- using a combined transformer stack. +-- See also documentation for 'graphQLAppQuery'. +graphQLAppTransQuery :: + forall qr m p chn hs. + ( GraphQLApp p ('Just qr) 'Nothing 'Nothing m chn hs ) + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn GQL.Field p m hs + -> Proxy qr + -> Application +graphQLAppTransQuery f svr _ + = graphQLAppTrans f svr (Proxy @('Just qr)) (Proxy @'Nothing) (Proxy @'Nothing) + +-- | Turn a Mu GraphQL 'Server' into a WAI 'Application' +-- using a combined transformer stack. +-- See also documentation for 'graphQLApp'. +graphQLAppTrans :: + ( GraphQLApp p qr mut sub m chn hs ) + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn GQL.Field p m hs + -> Proxy qr + -> Proxy mut + -> Proxy sub + -> Application +graphQLAppTrans f server q m s + = WS.websocketsOr WS.defaultConnectionOptions + (wsGraphQLAppTrans f server q m s) + (httpGraphQLAppTrans f server q m s) + +httpGraphQLAppTrans :: + ( GraphQLApp p qr mut sub m chn hs ) + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn GQL.Field p m hs + -> Proxy qr + -> Proxy mut + -> Proxy sub + -> Application +httpGraphQLAppTrans f server q m s req res = + case parseMethod (requestMethod req) of + Left err -> toError $ either unpackUnicodeException id (decodeUtf8' err) + Right GET -> do + let qst = queryString req + opN = decodeUtf8' <$> join (lookup "operationName" qst) + decodedQuery = fmap decodeUtf8' =<< lookup "query" qst + case (decodedQuery, lookup "variables" qst) of + (Just (Right qry), Just (Just vars)) -> + case A.eitherDecode $ fromStrict vars of + Left err -> toError $ T.pack err + Right vrs -> case sequence opN of + Left err -> toError $ "Could not parse operation name: " <> unpackUnicodeException err + Right opName -> execQuery opName vrs qry + (Just (Right qry), _) -> case sequence opN of + Left err -> toError $ "Could not parse query: " <> unpackUnicodeException err + Right opName -> execQuery opName HM.empty qry + _ -> toError "Error parsing query" + Right POST -> do + body <- strictRequestBody req + case lookup hContentType $ requestHeaders req of + Just "application/json" -> + case A.eitherDecode body of + Left err -> toError $ T.pack err + Right (GraphQLInput qry vars opName) -> execQuery opName vars qry + Just "application/graphql" -> + case decodeUtf8' $ toStrict body of + Left err -> toError $ "Could not decode utf8 from body: " <> unpackUnicodeException err + Right msg -> execQuery Nothing HM.empty msg + _ -> toError "No `Content-Type` header found!" + _ -> toError "Unsupported method" + where + execQuery :: Maybe T.Text -> VariableMapC -> T.Text -> IO ResponseReceived + execQuery opn vals qry = + case parseDoc qry of + Left err -> toError err + Right doc -> runPipeline f (requestHeaders req) server q m s opn vals doc + >>= toResponse + toError :: T.Text -> IO ResponseReceived + toError err = toResponse $ A.object [ ("errors", A.Array [ A.object [ ("message", A.String err) ] ])] + toResponse :: A.Value -> IO ResponseReceived + toResponse = res . responseBuilder ok200 [] . T.encodeUtf8Builder . encodeToLazyText + unpackUnicodeException :: UnicodeException -> T.Text + unpackUnicodeException (DecodeError str _) = T.pack str + unpackUnicodeException _ = error "EncodeError is deprecated" + +wsGraphQLAppTrans + :: ( GraphQLApp p qr mut sub m chn hs ) + => (forall a. m a -> ServerErrorIO a) + -> ServerT chn GQL.Field p m hs + -> Proxy qr + -> Proxy mut + -> Proxy sub + -> WS.ServerApp +wsGraphQLAppTrans f server q m s conn + = do let headers = WS.requestHeaders $ WS.pendingRequest conn + case lookup "Sec-WebSocket-Protocol" headers of + Just v + | v == "graphql-ws" || v == "graphql-transport-ws" + -> do conn' <- WS.acceptRequestWith conn (WS.AcceptRequest (Just v) []) + flip protocol conn' $ + runSubscriptionPipeline f headers server q m s + _ -> WS.rejectRequest conn "unsupported protocol" + +-- | Run a Mu 'graphQLApp' using the given 'Settings'. +-- +-- Go to 'Network.Wai.Handler.Warp' to declare 'Settings'. +runGraphQLAppSettings :: + ( GraphQLApp p qr mut sub ServerErrorIO chn hs ) + => Settings + -> ServerT chn GQL.Field p ServerErrorIO hs + -> Proxy qr + -> Proxy mut + -> Proxy sub + -> IO () +runGraphQLAppSettings st svr q m s = runSettings st (graphQLApp svr q m s) + +-- | Run a Mu 'graphQLApp' on the given port. +runGraphQLApp :: + ( GraphQLApp p qr mut sub ServerErrorIO chn hs ) + => Port + -> ServerT chn GQL.Field p ServerErrorIO hs + -> Proxy qr + -> Proxy mut + -> Proxy sub + -> IO () +runGraphQLApp port svr q m s = run port (graphQLApp svr q m s) + +-- | Run a Mu 'graphQLApp' on a transformer stack on the given port. +runGraphQLAppTrans :: + ( GraphQLApp p qr mut sub m chn hs ) + => Port + -> (forall a. m a -> ServerErrorIO a) + -> ServerT chn GQL.Field p m hs + -> Proxy qr + -> Proxy mut + -> Proxy sub + -> IO () +runGraphQLAppTrans port f svr q m s = run port (graphQLAppTrans f svr q m s) + +-- | Run a query-only Mu 'graphQLApp' on the given port. +runGraphQLAppQuery :: + ( GraphQLApp p ('Just qr) 'Nothing 'Nothing ServerErrorIO chn hs ) + => Port + -> ServerT chn GQL.Field p ServerErrorIO hs + -> Proxy qr + -> IO () +runGraphQLAppQuery port svr q = run port (graphQLAppQuery svr q) + +-- | 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 i o ServerErrorIO r -> ConduitT i o m r +liftServerConduit = transPipe raiseErrors + where raiseErrors :: forall m a. MonadIO m => ServerErrorIO a -> m a + raiseErrors h + = liftIO $ do + h' <- runExceptT h + case h' of + Right r -> pure r + Left e -> throw e diff --git a/graphql/src/Mu/GraphQL/Subscription/Protocol.hs b/graphql/src/Mu/GraphQL/Subscription/Protocol.hs new file mode 100644 index 00000000..ab0e2286 --- /dev/null +++ b/graphql/src/Mu/GraphQL/Subscription/Protocol.hs @@ -0,0 +1,161 @@ +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language ScopedTypeVariables #-} +{- +This module implements the protocol as specified in +https://github.com/apollographql/subscriptions-transport-ws/blob/master/PROTOCOL.md +-} +module Mu.GraphQL.Subscription.Protocol where + +import Control.Applicative +import Control.Concurrent +import Control.Concurrent.Async +import Control.Concurrent.STM +import Control.Monad (forM_) +import Control.Monad.IO.Class (MonadIO (liftIO)) +import Data.Aeson ((.:), (.:?), (.=)) +import qualified Data.Aeson as A +import Data.Conduit +import qualified Data.HashMap.Strict as HM +import qualified Data.Text as T +import Language.GraphQL.AST +import qualified ListT as L +import Network.WebSockets +import qualified StmContainers.Map as M + +import qualified Mu.GraphQL.Quasi.LostParser as P +import Mu.GraphQL.Query.Parse + +protocol :: ( Maybe T.Text -> VariableMapC -> [Definition] + -> ConduitT A.Value Void IO () + -> IO () ) + -> Connection -> IO () +protocol f conn = start + where + -- listen for GQL_CONNECTION_INIT + start = do + msg <- receiveJSON conn + case msg of + Just (GQLConnectionInit _) + -> do -- send GQL_CONNECTION_ACK + sendJSON conn GQLConnectionAck + vars <- M.newIO + -- send GQL_KEEP_ALIVE each 1s. + withAsync keepAlive $ \ka -> + -- start listening for incoming messages + listen ka vars + _ -> start -- Keep waiting + -- keep-alive + keepAlive = do + sendJSON conn GQLKeepAlive + threadDelay 1000000 + keepAlive + -- listen for messages from client + listen ka vars = do + msg <- receiveJSON conn + case msg of + Just (GQLStart i q v o) -- start handling + -> withAsync (handle i q v o >> atomically (M.delete i vars)) $ \t -> do + atomically $ M.insert t i vars + listen ka vars + Just (GQLStop i) -- stop with handling that query + -> do r <- atomically $ M.lookup i vars + case r of + Nothing -> return () + Just a -> do cancel a + atomically $ M.delete i vars + listen ka vars + Just GQLTerminate -- terminate all queries + -> do cancelAll ka vars + sendClose conn ("GraphQL session terminated" :: T.Text) + _ -> listen ka vars -- Keep going + -- Handle a single query + handle i q v o + = case P.parseDoc q of + Left err -> sendJSON conn (GQLError i (A.toJSON err)) + Right d -> do + f o v d (cndt i) + sendJSON conn (GQLComplete i) + -- Conduit which sends the results via the wire + cndt i = do + msg <- await + case msg of + Nothing -> return () + Just v -> do liftIO $ sendJSON conn (GQLData i v) + cndt i + -- Cancel all pending subscriptions + cancelAll ka vars + = do cancel ka + vs <- atomically $ L.toList $ M.listT vars + forM_ (map snd vs) cancel + +receiveJSON :: A.FromJSON a => Connection -> IO (Maybe a) +receiveJSON conn = do + d <- receiveData conn + return $ A.decode d + +sendJSON :: A.ToJSON a => Connection -> a -> IO () +sendJSON conn v + = sendTextData conn (A.encode v) + +data ClientMessage + = GQLConnectionInit { initPayload :: Maybe A.Value } + | GQLStart { clientMsgId :: T.Text + , query :: T.Text + , variables :: VariableMapC + , operationName :: Maybe T.Text} + | GQLStop { clientMsgId :: T.Text } + | GQLTerminate + deriving Show + +data ServerMessage + = GQLConnectionError { errorPayload :: Maybe A.Value } + | GQLConnectionAck + | GQLData { serverMsgId :: T.Text + , payload :: A.Value } + | GQLError { serverMsgId :: T.Text + , payload :: A.Value } + | GQLComplete { serverMsgId :: T.Text} + | GQLKeepAlive + deriving Show + +-- NOTE: using https://github.com/apollographql/subscriptions-transport-ws/blob/master/src/message-types.ts +-- as source of truth for the message types + +instance A.FromJSON ClientMessage where + parseJSON = A.withObject "ClientMessage" $ \v -> do + ty :: String <- v .: "type" + case ty of + "connection_init" + -> GQLConnectionInit <$> v .:? "payload" + "start" + -> do i <- v .: "id" + (q,vrs,opN) <- v .: "payload" >>= parsePayload + pure $ GQLStart i q vrs opN + "stop" + -> GQLStop <$> v .: "id" + "terminate" + -> pure GQLTerminate + _ -> empty + where + parsePayload = A.withObject "ClientMessage/GQL_START" $ + \v -> (,,) <$> v .: "query" + <*> (v .: "variables" <|> pure HM.empty) + <*> v .:? "operationName" + +theType :: (A.KeyValue kv) => T.Text -> kv +theType t = "type" .= t + +instance A.ToJSON ServerMessage where + toJSON (GQLConnectionError e) + = A.object [theType "connection_error", "payload" .= e] + toJSON GQLConnectionAck + = A.object [theType "connection_ack"] + toJSON (GQLData i p) + = A.object [theType "data", "id" .= i, "payload" .= p] + toJSON (GQLError i p) + = A.object [theType "error", "id" .= i, "payload" .= p] + toJSON (GQLComplete i) + = A.object [theType "complete", "id" .= i] + toJSON GQLKeepAlive + = A.object [theType "ka"] diff --git a/grpc/Setup.hs b/grpc/Setup.hs deleted file mode 100644 index 9a994af6..00000000 --- a/grpc/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain 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..ffeb95d1 --- /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 © 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/grpc/client/Setup.hs b/grpc/client/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/grpc/client/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain 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/client/mu-grpc-client.cabal b/grpc/client/mu-grpc-client.cabal new file mode 100644 index 00000000..1b989067 --- /dev/null +++ b/grpc/client/mu-grpc-client.cabal @@ -0,0 +1,58 @@ +name: mu-grpc-client +version: 0.4.0.1 +synopsis: gRPC clients from Mu definitions +description: + With @mu-grpc-client@ you can easily build gRPC clients for mu-haskell! + +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 +category: Network +build-type: Simple +cabal-version: >=1.10 +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.Examples + Mu.GRpc.Client.Optics + Mu.GRpc.Client.Record + Mu.GRpc.Client.TyApps + + other-modules: Mu.GRpc.Client.Internal + build-depends: + async >=2.2 && <3 + , avro >=0.5.1 && <0.6 + , base >=4.12 && <5 + , bytestring >=0.10 && <0.11 + , conduit >=1.3.2 && <2 + , http2 >=1.6 && <2.1 + , http2-client >=0.9 && <1 + , http2-client-grpc >=0.8 && <0.9 + , http2-grpc-types >=0.5 && <0.6 + , mu-grpc-common >=0.4 && <0.5 + , mu-optics >=0.3 && <0.4 + , mu-protobuf >=0.4 && <0.5 + , mu-rpc >=0.4 && <0.6 + , mu-schema >=0.3 && <0.4 + , optics-core >=0.2 && <0.4 + , sop-core >=0.5 && <0.6 + , stm >=2.5 && <3 + , stm-chans >=3 && <4 + , stm-conduit >=4 && <5 + , template-haskell >=2.14 && <2.17 + , text >=1.2 && <2 + , th-abstraction >=0.3.2 && <0.5 + , tracing >=0.0.5 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances diff --git a/grpc/client/src/Mu/GRpc/Client/Examples.hs b/grpc/client/src/Mu/GRpc/Client/Examples.hs new file mode 100644 index 00000000..8d530be4 --- /dev/null +++ b/grpc/client/src/Mu/GRpc/Client/Examples.hs @@ -0,0 +1,42 @@ +{-# 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 +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.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 + = do Right c <- setupGrpcClient' (grpcClientConfigSimple host port False) + fmap (\(HelloResponse r) -> r) <$> sayHello c (HelloRequest req) + +sayHello :: GrpcClient -> HelloRequest -> IO (GRpcReply HelloResponse) +sayHello = gRpcCall @'MsgProtoBuf @QuickStartService @"Greeter" @"SayHello" + +sayHi' :: HostName -> PortNumber -> Int -> IO [GRpcReply T.Text] +sayHi' host port n + = do Right c <- setupGrpcClient' (grpcClientConfigSimple host port False) + cndt <- sayHi c (HiRequest n) + runConduit $ cndt .| C.map (fmap (\(HelloResponse r) -> r)) .| consume + +sayHi :: GrpcClient -> HiRequest -> IO (ConduitT () (GRpcReply HelloResponse) IO ()) +sayHi = gRpcCall @'MsgProtoBuf @QuickStartService @"Greeter" @"SayHi" diff --git a/grpc/client/src/Mu/GRpc/Client/Internal.hs b/grpc/client/src/Mu/GRpc/Client/Internal.hs new file mode 100644 index 00000000..85ebf00c --- /dev/null +++ b/grpc/client/src/Mu/GRpc/Client/Internal.hs @@ -0,0 +1,354 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language DeriveFunctor #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language LambdaCase #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-# OPTIONS_GHC -fprint-explicit-kinds #-} +-- | Client for gRPC services defined using Mu 'Service' +module Mu.GRpc.Client.Internal where + +import Control.Concurrent.Async +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TMChan +import Control.Concurrent.STM.TMVar +import Control.Exception (throwIO) +import Control.Monad.IO.Class +import Data.Avro +import qualified Data.ByteString.Char8 as BS +import Data.Conduit +import qualified Data.Conduit.Combinators as C +import Data.Conduit.TMChan +import Data.Kind +import Data.Text as T +import GHC.TypeLits +import Monitor.Tracing +import Monitor.Tracing.Zipkin +import Network.GRPC.Client (CompressMode (..), IncomingEvent (..), + OutgoingEvent (..), RawReply, StreamDone (..)) +import Network.GRPC.Client.Helpers +import Network.GRPC.HTTP2.Encoding (GRPCInput, GRPCOutput) +import Network.HTTP2 (ErrorCode) +import Network.HTTP2.Client (ClientError, ClientIO, TooMuchConcurrency, + runExceptT, ExceptT) + +import Mu.Adapter.ProtoBuf.Via +import Mu.GRpc.Avro +import Mu.GRpc.Bridge +import Mu.Rpc +import Mu.Schema + +-- | Initialize a connection to a gRPC server. +setupGrpcClient' :: MonadIO m + => GrpcClientConfig -> m (Either ClientError GrpcClient) +setupGrpcClient' = liftIO . runExceptT . setupGrpcClient + +-- | Initialize a connection to a gRPC server +-- and pass information about distributed tracing. +setupGrpcClientZipkin + :: (MonadIO m, MonadTrace m) + => GrpcClientConfig -> T.Text -> m (Either ClientError GrpcClient) +setupGrpcClientZipkin cfg spanName + = clientSpan spanName $ \case + Nothing -> setupGrpcClient' cfg + (Just b3) -> setupGrpcClient' cfg { + _grpcClientConfigHeaders = ("b3", b3ToHeaderValue b3) + : _grpcClientConfigHeaders cfg + } + +class GRpcServiceMethodCall (p :: GRpcMessageProtocol) + (pkg :: snm) (s :: snm) + (m :: Method snm mnm anm (TypeRef snm)) h where + gRpcServiceMethodCall :: Proxy p -> Proxy pkg -> Proxy s -> Proxy m -> GrpcClient -> h +instance ( KnownName serviceName, KnownName pkg, KnownName mname + , GRpcMethodCall p ('Method mname margs mret) h, MkRPC p ) + => GRpcServiceMethodCall p pkg serviceName ('Method mname margs mret) h where + gRpcServiceMethodCall pro _ _ = gRpcMethodCall @p rpc + where pkgName = BS.pack (nameVal (Proxy @pkg)) + svrName = BS.pack (nameVal (Proxy @serviceName)) + metName = BS.pack (nameVal (Proxy @mname)) + rpc = mkRPC pro pkgName svrName metName + +data GRpcReply a + = GRpcTooMuchConcurrency TooMuchConcurrency + | GRpcErrorCode ErrorCode + | GRpcErrorString String + | GRpcClientError ClientError + | GRpcOk a + deriving (Show, Functor) + +buildGRpcReply1 :: Either TooMuchConcurrency (RawReply a) -> GRpcReply a +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 + +buildGRpcReply3 :: Either TooMuchConcurrency v -> GRpcReply () +buildGRpcReply3 (Left tmc) = GRpcTooMuchConcurrency tmc +buildGRpcReply3 (Right _) = GRpcOk () + +simplifyResponse :: ClientIO (GRpcReply a) -> IO (GRpcReply a) +simplifyResponse reply = do + r <- runExceptT reply + pure $ case r of + Left e -> GRpcClientError e + Right v -> v + +-- These type classes allow us to abstract over +-- the choice of message protocol (PB or Avro) + +class GRPCInput (RPCTy p) (GRpcIWTy p ref r) + => GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where + type GRpcIWTy p ref r :: Type + buildGRpcIWTy :: Proxy p -> Proxy ref -> r -> GRpcIWTy p ref r + +instance ToProtoBufTypeRef ref r + => GRpcInputWrapper 'MsgProtoBuf ref r where + type GRpcIWTy 'MsgProtoBuf ref r = ViaToProtoBufTypeRef ref r + buildGRpcIWTy _ _ = ViaToProtoBufTypeRef + +instance forall (sch :: Schema') (sty :: Symbol) (r :: Type). + ( ToSchema sch sty r + , ToAvro (WithSchema sch sty r) + , HasAvroSchema (WithSchema sch sty r) ) + => GRpcInputWrapper 'MsgAvro ('SchemaRef sch sty) r where + type GRpcIWTy 'MsgAvro ('SchemaRef sch sty) r = ViaToAvroTypeRef ('SchemaRef sch sty) r + buildGRpcIWTy _ _ = ViaToAvroTypeRef + +class GRPCOutput (RPCTy p) (GRpcOWTy p ref r) + => GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where + type GRpcOWTy p ref r :: Type + unGRpcOWTy :: Proxy p -> Proxy ref -> GRpcOWTy p ref r -> r + +instance FromProtoBufTypeRef ref r + => GRpcOutputWrapper 'MsgProtoBuf ref r where + type GRpcOWTy 'MsgProtoBuf ref r = ViaFromProtoBufTypeRef ref r + unGRpcOWTy _ _ = unViaFromProtoBufTypeRef + +instance forall (sch :: Schema') (sty :: Symbol) (r :: Type). + ( FromSchema sch sty r + , FromAvro (WithSchema sch sty r) + , HasAvroSchema (WithSchema sch sty r) ) + => GRpcOutputWrapper 'MsgAvro ('SchemaRef sch sty) r where + type GRpcOWTy 'MsgAvro ('SchemaRef sch sty) r = ViaFromAvroTypeRef ('SchemaRef sch sty) r + unGRpcOWTy _ _ = unViaFromAvroTypeRef + +-- ----------------------------- +-- IMPLEMENTATION OF THE METHODS +-- ----------------------------- + +class GRpcMethodCall (p :: GRpcMessageProtocol) (method :: Method') h where + gRpcMethodCall :: RPCTy p -> Proxy method -> GrpcClient -> h + +instance ( KnownName name + , GRPCInput (RPCTy p) (), GRPCOutput (RPCTy p) () + , handler ~ IO (GRpcReply ()) ) + => GRpcMethodCall p ('Method name '[ ] 'RetNothing) handler where + gRpcMethodCall rpc _ client + = simplifyResponse $ + buildGRpcReply1 <$> + rawUnary rpc client () + +instance ( KnownName name + , GRPCInput (RPCTy p) (), GRpcOutputWrapper p rref r + , handler ~ IO (GRpcReply r) ) + => GRpcMethodCall p ('Method name '[ ] ('RetSingle rref)) handler where + gRpcMethodCall rpc _ client + = fmap (fmap (unGRpcOWTy (Proxy @p) (Proxy @rref))) $ + simplifyResponse $ + buildGRpcReply1 <$> + rawUnary @_ @() @(GRpcOWTy p rref r) rpc client () + +instance ( KnownName name + , GRPCInput (RPCTy p) (), GRpcOutputWrapper p rref r + , handler ~ IO (ConduitT () (GRpcReply r) IO ()) ) + => GRpcMethodCall p ('Method name '[ ] ('RetStream rref)) handler where + gRpcMethodCall rpc _ 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 @_ @() @(GRpcOWTy p rref r) + rpc client () () + (\_ _ newVal -> liftIO $ atomically $ do + -- on the first iteration, say that everything is OK + _ <- tryPutTMVar var (GRpcOk ()) + writeTMChan chan (unGRpcOWTy (Proxy @p) (Proxy @rref) 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 + pure go + +instance ( KnownName name + , GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) () + , handler ~ (v -> IO (GRpcReply ())) ) + => GRpcMethodCall p ('Method name '[ 'ArgSingle aname vref ] + 'RetNothing) handler where + gRpcMethodCall rpc _ client x + = simplifyResponse $ + buildGRpcReply1 <$> + rawUnary @_ @(GRpcIWTy p vref v) @() rpc client (buildGRpcIWTy (Proxy @p) (Proxy @vref) x) + +instance ( KnownName name + , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r + , handler ~ (v -> IO (GRpcReply r)) ) + => GRpcMethodCall p ('Method name '[ 'ArgSingle aname vref ] + ('RetSingle rref)) handler where + gRpcMethodCall rpc _ client x + = fmap (fmap (unGRpcOWTy (Proxy @p) (Proxy @rref))) $ + simplifyResponse $ + buildGRpcReply1 <$> + rawUnary @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) + rpc client (buildGRpcIWTy (Proxy @p) (Proxy @vref) x) + +instance ( KnownName name + , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r + , handler ~ (v -> IO (ConduitT () (GRpcReply r) IO ())) ) + => GRpcMethodCall p ('Method name '[ 'ArgSingle aname vref ] + ('RetStream rref)) handler where + gRpcMethodCall rpc _ client x + = 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 @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) + rpc client () (buildGRpcIWTy (Proxy @p) (Proxy @vref) x) + (\_ _ newVal -> liftIO $ atomically $ do + -- on the first iteration, say that everything is OK + _ <- tryPutTMVar var (GRpcOk ()) + writeTMChan chan (unGRpcOWTy (Proxy @p) (Proxy @rref) 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 + pure go + +instance ( KnownName name + , GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) () + , handler ~ (CompressMode -> IO (ConduitT v Void IO (GRpcReply ()))) ) + => GRpcMethodCall p ('Method name '[ 'ArgStream aname vref ] + 'RetNothing) handler where + gRpcMethodCall rpc _ client compress + = do -- Create a new TMChan + chan <- newTMChanIO :: IO (TMChan v) + -- Start executing the client in another thread + promise <- async $ + simplifyResponse $ + buildGRpcReply2 <$> + rawStreamClient @_ @(GRpcIWTy p vref v) @() rpc client () + (\_ -> do nextVal <- liftIO $ atomically $ readTMChan chan + case nextVal of + Nothing -> pure ((), Left StreamDone) + Just v -> pure ((), Right (compress, buildGRpcIWTy (Proxy @p) (Proxy @vref) v))) + pure (conduitFromChannel chan promise) + +instance ( KnownName name + , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r + , handler ~ (CompressMode -> IO (ConduitT v Void IO (GRpcReply r))) ) + => GRpcMethodCall p ('Method name '[ 'ArgStream aname vref ] + ('RetSingle rref)) handler where + gRpcMethodCall rpc _ client compress + = do -- Create a new TMChan + chan <- newTMChanIO :: IO (TMChan v) + -- Start executing the client in another thread + promise <- async $ + fmap (fmap (unGRpcOWTy (Proxy @p) (Proxy @rref))) $ + simplifyResponse $ + buildGRpcReply2 <$> + rawStreamClient @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) rpc client () + (\_ -> do nextVal <- liftIO $ atomically $ readTMChan chan + case nextVal of + Nothing -> pure ((), Left StreamDone) + Just v -> pure ((), Right (compress, buildGRpcIWTy (Proxy @p) (Proxy @vref) v))) + pure (conduitFromChannel chan promise) + +conduitFromChannel :: MonadIO m => TMChan a -> Async b -> ConduitT a o m b +conduitFromChannel chan promise = go + where go = do x <- await + case x of + Just v -> do liftIO $ atomically $ writeTMChan chan v + go + Nothing -> do liftIO $ atomically $ closeTMChan chan + liftIO $ wait promise + +instance ( KnownName name + , GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r + , handler ~ (CompressMode -> IO (ConduitT v Void IO (), ConduitT () r IO (GRpcReply ())))) + => GRpcMethodCall p ('Method name '[ 'ArgStream aname vref ] + ('RetStream rref)) handler where + gRpcMethodCall rpc _ client compress + = do serverChan <- newTMChanIO :: IO (TMChan r) + clientChan <- newTMChanIO :: IO (TMChan v) + finalReply <- newEmptyTMVarIO :: IO (TMVar (GRpcReply ())) + -- Start executing the client in another thread + -- TODO: Is there anything that makes sure that this thread doesn't keep running forever? + _ <- async $ do + v <- simplifyResponse $ + buildGRpcReply3 <$> + rawGeneralStream + @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) + rpc client + () (incomingEventConsumer serverChan) + () (outgoingEventProducer clientChan) + liftIO $ atomically $ putTMVar finalReply v + let clientConduit = do + sinkTMChan clientChan + liftIO . atomically . closeTMChan $ clientChan + serverConduit = do + sourceTMChan serverChan + liftIO . atomically . readTMVar $ finalReply + pure (clientConduit, serverConduit) + where + incomingEventConsumer :: TMChan r -> () -> IncomingEvent (GRpcOWTy p rref r) () -> ExceptT ClientError IO () + incomingEventConsumer serverChan _ ievent = + case ievent of + RecvMessage o -> do + liftIO $ atomically $ writeTMChan serverChan (unGRpcOWTy (Proxy @p) (Proxy @rref) o) + Invalid e -> liftIO $ do + atomically $ closeTMChan serverChan + throwIO e + Trailers _ -> + -- TODO: Read the trailers and use them to make the 'finalReply' + liftIO $ atomically $ closeTMChan serverChan + Headers _ -> + -- TODO: Read the headers and use them to make the 'finalReply' + pure () + + outgoingEventProducer :: TMChan v -> () -> ExceptT ClientError IO ((), OutgoingEvent (GRpcIWTy p vref v) ()) + outgoingEventProducer clientChan _ = do + nextVal <- liftIO $ atomically $ readTMChan clientChan + case nextVal of + Nothing -> pure ((), Finalize) + Just v -> pure ((), SendMessage compress (buildGRpcIWTy (Proxy @p) (Proxy @vref) v)) diff --git a/grpc/client/src/Mu/GRpc/Client/Optics.hs b/grpc/client/src/Mu/GRpc/Client/Optics.hs new file mode 100644 index 00000000..f181fca6 --- /dev/null +++ b/grpc/client/src/Mu/GRpc/Client/Optics.hs @@ -0,0 +1,177 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} +{-# language GADTs #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +Description : Client for gRPC services using optics and labels + +For further information over initialization of the connection, +consult the . +-} +module Mu.GRpc.Client.Optics ( + -- * Initialization of the gRPC client + GRpcConnection +, initGRpc +, initGRpcZipkin +, GRpcMessageProtocol(..) +, msgProtoBuf +, msgAvro +, G.GrpcClientConfig +, G.grpcClientConfigSimple + -- * Request arguments and responses +, CompressMode +, GRpcReply(..) + -- * Re-exported for convenience +, module Optics.Core +, module Mu.Schema.Optics +) where + +import Control.Monad.IO.Class +import qualified Data.ByteString.Char8 as BS +import Data.Conduit +import Data.Proxy +import Data.Text as T +import GHC.TypeLits +import Monitor.Tracing +import Network.GRPC.Client (CompressMode) +import qualified Network.GRPC.Client.Helpers as G +import Network.HTTP2.Client (ClientError) +import Optics.Core + +import Mu.GRpc.Bridge +import Mu.GRpc.Client.Internal +import Mu.Rpc +import Mu.Schema +import Mu.Schema.Optics + +-- | Represents a connection to the service @s@. +newtype GRpcConnection (s :: Package') (p :: GRpcMessageProtocol) + = GRpcConnection { gcClient :: G.GrpcClient } + +-- | Initializes a connection to a gRPC server. +-- Usually the service you are connecting to is +-- inferred from the usage later on. +-- However, it can also be made explicit by using +-- +-- > initGRpc config msgProtoBuf @Service +-- +initGRpc :: MonadIO m + => G.GrpcClientConfig -- ^ gRPC configuration + -> Proxy p + -> forall s. m (Either ClientError (GRpcConnection s p)) +initGRpc config _ = do + setup <- setupGrpcClient' config + pure $ case setup of + Left e -> Left e + Right c -> Right $ GRpcConnection c + +-- | Initializes a connection to a gRPC server, +-- creating a new span for distributed tracing. +-- Usually the service you are connecting to is +-- inferred from the usage later on. +-- However, it can also be made explicit by using +-- +-- > initGRpcZipkin config msgProtoBuf "person" @Service +-- +initGRpcZipkin :: (MonadIO m, MonadTrace m) + => G.GrpcClientConfig -- ^ gRPC configuration + -> Proxy p + -> T.Text + -> forall s. m (Either ClientError (GRpcConnection s p)) +initGRpcZipkin config _ spanName = do + setup <- setupGrpcClientZipkin config spanName + pure $ case setup of + Left e -> Left e + Right c -> Right $ GRpcConnection c + +instance forall (pkg :: Package') (pkgName :: Symbol) + (service :: Service') (serviceName :: Symbol) + (methods :: [Method']) + (p :: GRpcMessageProtocol) (m :: Symbol) t. + ( pkg ~ 'Package ('Just pkgName) '[service] + , service ~ 'Service serviceName methods + , SearchMethodOptic p methods m t + , KnownName serviceName + , KnownName pkgName + , KnownName m + , MkRPC p ) + => LabelOptic m A_Getter + (GRpcConnection pkg p) + (GRpcConnection pkg p) + t t where + labelOptic = to (searchMethodOptic @p (Proxy @methods) (Proxy @m) rpc . gcClient) + where pkgName = BS.pack (nameVal (Proxy @pkgName)) + svrName = BS.pack (nameVal (Proxy @serviceName)) + metName = BS.pack (nameVal (Proxy @m)) + rpc = mkRPC (Proxy @p) pkgName svrName metName + +class SearchMethodOptic (p :: GRpcMessageProtocol) (methods :: [Method']) (m :: Symbol) t + | p methods m -> t where + searchMethodOptic :: Proxy methods -> Proxy m -> RPCTy p -> G.GrpcClient -> t + +{- Not possible due to functional dependency +instance TypeError ('Text "could not find method " ':<>: ShowType m) + => SearchMethodOptic '[] m t where +-} +instance {-# OVERLAPS #-} MethodOptic p ('Method name ins outs) t + => SearchMethodOptic p ('Method name ins outs ': rest) name t where + searchMethodOptic _ _ rpc = methodOptic @p rpc (Proxy @('Method name ins outs)) +instance {-# OVERLAPPABLE #-} SearchMethodOptic p rest name t + => SearchMethodOptic p ('Method other ins outs ': rest) name t where + searchMethodOptic _ = searchMethodOptic @p (Proxy @rest) + +class GRpcMethodCall p method t + => MethodOptic (p :: GRpcMessageProtocol) (method :: Method') t + | p method -> t where + methodOptic :: RPCTy p -> Proxy method -> G.GrpcClient -> t + methodOptic = gRpcMethodCall @p + +-- No arguments +instance forall (name :: Symbol) t p. + ( GRpcMethodCall p ('Method name '[ ] 'RetNothing) t + , t ~ IO (GRpcReply ()) ) + => MethodOptic p ('Method name '[ ] 'RetNothing) t +instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) t p. + ( GRpcMethodCall p ('Method name '[ ] ('RetSingle ('SchemaRef sch r))) t + , t ~ IO (GRpcReply (Term sch (sch :/: r))) ) + => MethodOptic p ('Method name '[ ] ('RetSingle ('SchemaRef sch r))) t +instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (r :: Symbol) t p. + ( GRpcMethodCall p ('Method name '[ ] ('RetStream ('SchemaRef sch r))) t + , t ~ IO (ConduitT () (GRpcReply (Term sch (sch :/: r))) IO ()) ) + => MethodOptic p ('Method name '[ ] ('RetStream ('SchemaRef sch r))) t +-- Simple arguments +instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) aname t p. + ( GRpcMethodCall p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] 'RetNothing) t + , t ~ (Term sch (sch :/: v) -> IO (GRpcReply ())) ) + => MethodOptic p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] 'RetNothing) t +instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname t p. + ( GRpcMethodCall p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t + , t ~ (Term sch (sch :/: v) + -> IO (GRpcReply (Term sch (sch :/: r))) ) ) + => MethodOptic p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t +instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname t p. + ( GRpcMethodCall p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t + , t ~ (Term sch (sch :/: v) + -> IO (ConduitT () (GRpcReply (Term sch (sch :/: r))) IO ()) ) ) + => MethodOptic p ('Method name '[ 'ArgSingle aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t +-- Stream arguments +instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname t p. + ( GRpcMethodCall p ('Method name '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t + , t ~ (CompressMode + -> IO (ConduitT (Term sch (sch :/: v)) + Void IO + (GRpcReply (Term sch (sch :/: r))))) ) + => MethodOptic p ('Method name '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetSingle ('SchemaRef sch r))) t +instance forall (name :: Symbol) (sch :: Schema Symbol Symbol) (v :: Symbol) (r :: Symbol) aname t p. + ( GRpcMethodCall p ('Method name '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t + , t ~ (CompressMode + -> IO (ConduitT (Term sch (sch :/: v)) + (GRpcReply (Term sch (sch :/: r))) IO ())) ) + => MethodOptic p ('Method name '[ 'ArgStream aname ('SchemaRef sch v) ] ('RetStream ('SchemaRef sch r))) t diff --git a/grpc/client/src/Mu/GRpc/Client/Record.hs b/grpc/client/src/Mu/GRpc/Client/Record.hs new file mode 100644 index 00000000..a94f4246 --- /dev/null +++ b/grpc/client/src/Mu/GRpc/Client/Record.hs @@ -0,0 +1,272 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TemplateHaskell #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +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 +, GrpcClientConfig +, grpcClientConfigSimple +, setupGrpcClient' +, setupGrpcClientZipkin + -- * Fill and generate the Haskell record of functions +, buildService +, GRpcMessageProtocol(..) +, CompressMode(..) +, GRpcReply(..) +, generateRecordFromService +) where + +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 Mu.GRpc.Bridge +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. +buildService :: forall (pro :: GRpcMessageProtocol) + (pkg :: Package') (s :: Symbol) (p :: Symbol) t + (pkgName :: Symbol) (ss :: [Service']) + (ms :: [Method']). + ( pkg ~ 'Package ('Just pkgName) ss + , LookupService ss s ~ 'Service s ms + , Generic t + , BuildService pro pkgName s p ms (Rep t) ) + => GrpcClient -> t +buildService client + = to (buildService' (Proxy @pro) (Proxy @pkgName) (Proxy @s) (Proxy @p) (Proxy @ms) client) + +class BuildService (pro :: GRpcMessageProtocol) (pkg :: Symbol) (s :: Symbol) + (p :: Symbol) (ms :: [Method']) (f :: * -> *) where + buildService' :: Proxy pro -> Proxy pkg -> Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a + +instance BuildService pro pkg s p ms U1 where + buildService' _ _ _ _ _ _ = U1 +instance BuildService pro pkg s p ms f => BuildService pro pkg s p ms (D1 meta f) where + buildService' ppro ppkg ps ppr pms client + = M1 (buildService' ppro ppkg ps ppr pms client) +instance BuildService pro pkg s p ms f => BuildService pro pkg s p ms (C1 meta f) where + buildService' ppro ppkg ps ppr pms client + = M1 (buildService' ppro ppkg ps ppr pms client) +instance TypeError ('Text "building a service from sums is not supported") + => BuildService pro pkg s p ms (f :+: g) where + buildService' = error "this should never happen" +instance (BuildService pro pkg s p ms f, BuildService pro pkg s p ms g) + => BuildService pro pkg s p ms (f :*: g) where + buildService' ppro ppkg ps ppr pms client + = buildService' ppro ppkg ps ppr pms client :*: buildService' ppro ppkg ps ppr pms client +instance (m ~ AppendSymbol p x, GRpcServiceMethodCall pro pkg sname (LookupMethod ms x) h) + => BuildService pro pkg sname p ms (S1 ('MetaSel ('Just m) u ss ds) (K1 i h)) where + buildService' ppro ppkg ps _ _ client + = M1 $ K1 $ gRpcServiceMethodCall ppro ppkg ps (Proxy @(LookupMethod ms x)) client + +-- TEMPLATE HASKELL +-- ================ + +-- | Generate the plain Haskell record corresponding to +-- a Mu 'Service' definition, and a concrete implementation +-- of 'buildService' for that record. +generateRecordFromService :: String -> String -> Namer -> Name -> Q [Dec] +generateRecordFromService newRecordName fieldsPrefix tNamer serviceTyName + = do let serviceTy = ConT serviceTyName + srvDef <- typeToServiceDef serviceTy + case srvDef of + Nothing -> fail "service definition cannot be parsed" + Just sd -> serviceDefToDecl serviceTyName newRecordName fieldsPrefix tNamer sd + +type Namer = String -> String + +serviceDefToDecl :: Name -> String -> String -> Namer + -> Service String String String (TypeRef snm) + -> Q [Dec] +serviceDefToDecl serviceTyName complete fieldsPrefix tNamer (Service _ methods) + = do d <- dataD (pure []) + (mkName complete) + [] + Nothing + [RecC (mkName complete) <$> mapM (methodToDecl fieldsPrefix tNamer) methods] + [pure (DerivClause Nothing [ConT ''Generic])] + let buildName = mkName ("build" ++ complete) + s <- SigD buildName <$> [t|GrpcClient -> $(pure (ConT (mkName complete)))|] + c <- Clause [] <$> (NormalB <$> [e|buildService @ $(conT serviceTyName) + @ $(litT (strTyLit fieldsPrefix))|]) + <*> pure [] + pure [d, s, FunD buildName [c]] + +methodToDecl :: String -> Namer + -> Method String String String (TypeRef snm) + -> Q (Name, Bang, Type) +methodToDecl fieldsPrefix tNamer (Method mName args ret) + = do let nm = firstLower (fieldsPrefix ++ mName) + ty <- computeMethodType tNamer args ret + pure ( mkName nm, Bang NoSourceUnpackedness NoSourceStrictness, ty ) + +computeMethodType :: Namer + -> [Argument String String (TypeRef snm)] + -> Return String (TypeRef snm) + -> Q Type +computeMethodType _ [] RetNothing + = [t|IO (GRpcReply ())|] +computeMethodType n [] (RetSingle r) + = [t|IO (GRpcReply $(typeRefToType n r))|] +computeMethodType n [ArgSingle _ v] RetNothing + = [t|$(typeRefToType n v) -> IO (GRpcReply ())|] +computeMethodType n [ArgSingle _ v] (RetSingle r) + = [t|$(typeRefToType n v) -> IO (GRpcReply $(typeRefToType n r))|] +computeMethodType n [ArgStream _ v] (RetSingle r) + = [t|CompressMode -> IO (ConduitT $(typeRefToType n v) Void IO (GRpcReply $(typeRefToType n r)))|] +computeMethodType n [ArgSingle _ v] (RetStream r) + = [t|$(typeRefToType n v) -> IO (ConduitT () (GRpcReply $(typeRefToType n r)) IO ())|] +computeMethodType n [ArgStream _ v] (RetStream r) + = [t|CompressMode -> IO (ConduitT $(typeRefToType n v) (GRpcReply $(typeRefToType n r)) IO ())|] +computeMethodType _ _ _ = fail "method signature not supported" + +typeRefToType :: Namer -> TypeRef snm -> Q Type +typeRefToType tNamer (THRef (LitT (StrTyLit s))) + = pure $ ConT (mkName $ completeName tNamer s) +typeRefToType _tNamer (THRef ty) + = pure ty +typeRefToType _ _ = error "this should never happen" + +completeName :: Namer -> String -> String +completeName namer name = firstUpper (namer (firstUpper name)) + +firstUpper :: String -> String +firstUpper [] = error "Empty names are not allowed" +firstUpper (x:rest) = toUpper x : rest + +firstLower :: String -> String +firstLower [] = error "Empty names are not allowed" +firstLower (x:rest) = toLower x : rest + +-- Parsing +-- ======= + +typeToServiceDef :: Type -> Q (Maybe (Service String String String (TypeRef snm))) +typeToServiceDef toplevelty + = typeToServiceDef' <$> resolveTypeSynonyms toplevelty + where + typeToServiceDef' :: Type -> Maybe (Service String String String (TypeRef snm)) + typeToServiceDef' expanded + = do (sn, _, methods) <- tyD3 'Service expanded + methods' <- tyList methods + Service <$> tyString sn + <*> mapM typeToMethodDef methods' + + typeToMethodDef :: Type -> Maybe (Method String String String (TypeRef snm)) + typeToMethodDef ty + = do (mn, _, args, ret) <- tyD4 'Method ty + args' <- tyList args + Method <$> tyString mn + <*> mapM typeToArgDef args' + <*> typeToRetDef ret + + typeToArgDef :: Type -> Maybe (Argument String String (TypeRef snm)) + typeToArgDef ty + = (do (n, _, t) <- tyD3 'ArgSingle ty + ArgSingle <$> tyMaybeString n <*> typeToTypeRef t) + <|> (do (n, _, t) <- tyD3 'ArgStream ty + ArgStream <$> tyMaybeString n <*> typeToTypeRef t) + + typeToRetDef :: Type -> Maybe (Return String (TypeRef snm)) + typeToRetDef ty + = RetNothing <$ tyD0 'RetNothing ty + <|> RetSingle <$> (tyD1 'RetSingle ty >>= typeToTypeRef) + <|> (do (e, v) <- tyD2 'RetThrows ty + RetThrows <$> typeToTypeRef e <*> typeToTypeRef v) + <|> RetStream <$> (tyD1 'RetStream ty >>= typeToTypeRef) + + typeToTypeRef :: Type -> Maybe (TypeRef snm) + typeToTypeRef ty + = (do (_,innerTy) <- tyD2 'SchemaRef ty + pure (THRef innerTy)) + <|> (do (_,innerTy,_) <- tyD3 'RegistryRef ty + pure (THRef innerTy)) + +tyMaybeString :: Type -> Maybe (Maybe String) +tyMaybeString (PromotedT c) + | c == 'Nothing + = pure Nothing +tyMaybeString (AppT (PromotedT c) r) + | c == 'Just + = Just <$> tyString r +tyMaybeString _ + = Nothing + +tyString :: Type -> Maybe String +tyString (SigT t _) + = tyString t +tyString (LitT (StrTyLit s)) + = Just s +tyString _ + = Nothing + +tyList :: Type -> Maybe [Type] +tyList (SigT t _) + = tyList t +tyList PromotedNilT + = Just [] +tyList (AppT (AppT PromotedConsT ty) rest) + = (ty :) <$> tyList rest +tyList _ = Nothing + +tyD0 :: Name -> Type -> Maybe () +tyD0 name (SigT t _) = tyD0 name t +tyD0 name (PromotedT c) + | c == name = Just () + | otherwise = Nothing +tyD0 _ _ = Nothing + +tyD1 :: Name -> Type -> Maybe Type +tyD1 name (SigT t _) = tyD1 name t +tyD1 name (AppT (PromotedT c) x) + | c == name = Just x + | otherwise = Nothing +tyD1 _ _ = Nothing + +tyD2 :: Name -> Type -> Maybe (Type, Type) +tyD2 name (SigT t _) = tyD2 name t +tyD2 name (AppT (AppT (PromotedT c) x) y) + | c == name = Just (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 + +tyD4 :: Name -> Type -> Maybe (Type, Type, Type, Type) +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 diff --git a/grpc/client/src/Mu/GRpc/Client/TyApps.hs b/grpc/client/src/Mu/GRpc/Client/TyApps.hs new file mode 100644 index 00000000..64416805 --- /dev/null +++ b/grpc/client/src/Mu/GRpc/Client/TyApps.hs @@ -0,0 +1,59 @@ +{-# language AllowAmbiguousTypes #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeOperators #-} +{-| +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 +, GrpcClientConfig +, grpcClientConfigSimple +, setupGrpcClient' +, setupGrpcClientZipkin + -- * Call methods from the gRPC service +, gRpcCall +, GRpcMessageProtocol(..) +, CompressMode(..) +, GRpcReply(..) +) where + +import GHC.TypeLits +import Network.GRPC.Client (CompressMode (..)) +import Network.GRPC.Client.Helpers + +import Mu.Rpc +import Mu.Schema + +import Mu.GRpc.Bridge +import Mu.GRpc.Client.Internal + +-- | Call a method from a Mu definition. +-- This method is thought to be used with @TypeApplications@: +-- +-- > gRpcCall @'MsgFormat @"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'. +-- * A single input or output turns into a single value. +-- * A streaming input or output turns into a Conduit. +gRpcCall :: forall (pro :: GRpcMessageProtocol) (pkg :: Package') + (srvName :: Symbol) (methodName :: Symbol) h + pkgName services methods. + ( pkg ~  'Package ('Just pkgName) services + , LookupService services srvName ~ 'Service srvName methods + , GRpcServiceMethodCall pro pkgName srvName (LookupMethod methods methodName) h) + => GrpcClient -> h +gRpcCall + = gRpcServiceMethodCall (Proxy @pro) (Proxy @pkgName) (Proxy @srvName) + (Proxy @(LookupMethod methods methodName)) diff --git a/grpc/common/LICENSE b/grpc/common/LICENSE new file mode 100644 index 00000000..ffeb95d1 --- /dev/null +++ b/grpc/common/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/grpc/common/Setup.hs b/grpc/common/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/grpc/common/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/grpc/common/hie.yaml b/grpc/common/hie.yaml new file mode 100644 index 00000000..dbda86c5 --- /dev/null +++ b/grpc/common/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-grpc-common:lib" } } diff --git a/grpc/common/mu-grpc-common.cabal b/grpc/common/mu-grpc-common.cabal new file mode 100644 index 00000000..0a9588c2 --- /dev/null +++ b/grpc/common/mu-grpc-common.cabal @@ -0,0 +1,41 @@ +name: mu-grpc-common +version: 0.4.0.0 +synopsis: gRPC for Mu, common modules for client and server +description: + Use @mu-grpc-server@ or @mu-grpc-client@ (the common parts). + +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 +category: Network +build-type: Simple +cabal-version: >=1.10 +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.Avro + Mu.GRpc.Bridge + + build-depends: + avro >=0.5.1 && <0.6 + , base >=4.12 && <5 + , binary >=0.8 && <0.9 + , bytestring >=0.10 && <0.11 + , http2-grpc-proto3-wire >=0.1 && <0.2 + , http2-grpc-types >=0.5 && <0.6 + , mu-avro >=0.4 && <0.5 + , mu-protobuf >=0.4 && <0.5 + , mu-rpc >=0.4 && <0.6 + , mu-schema >=0.3 && <0.4 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances diff --git a/grpc/common/src/Mu/GRpc/Avro.hs b/grpc/common/src/Mu/GRpc/Avro.hs new file mode 100644 index 00000000..6e2c3c4b --- /dev/null +++ b/grpc/common/src/Mu/GRpc/Avro.hs @@ -0,0 +1,136 @@ +{-# language CPP #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language UndecidableInstances #-} +{-# options_ghc -fno-warn-orphans -fno-warn-simplifiable-class-constraints #-} +{-| +Description : (Internal) Wrappers for Avro serialization + +Intended for internal use. + +This module provides the required instances of +the common type classes from 'Mu.GRpc.Bridge' +to make it work with Avro. +-} +module Mu.GRpc.Avro ( + AvroRPC(..) +, ViaFromAvroTypeRef(..) +, ViaToAvroTypeRef(..) +) where + +import Data.Avro +import Data.Binary.Builder (fromByteString, putWord32be, singleton) +import Data.Binary.Get (Decoder (..), getByteString, getInt8, getWord32be, + runGetIncremental) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as ByteString +import Data.ByteString.Lazy (fromStrict, toStrict) +import Data.Kind +import GHC.TypeLits +import Network.GRPC.HTTP2.Encoding +import Network.GRPC.HTTP2.Types + +#if MIN_VERSION_base(4,11,0) +#else +import Data.Monoid ((<>)) +#endif + +import Mu.Adapter.Avro () +import Mu.Rpc +import Mu.Schema + +-- | A proxy type for giving static information about RPCs. +-- Intended for internal use. +data AvroRPC = AvroRPC { pkg :: ByteString, srv :: ByteString, meth :: ByteString } + +instance IsRPC AvroRPC where + path rpc = "/" <> pkg rpc <> "." <> srv rpc <> "/" <> meth rpc + {-# INLINE path #-} + +-- | Wrapper used to tag a type with its corresponding +-- 'TypeRef' used for deserialization from Avro. +-- Intended for internal use. +newtype ViaFromAvroTypeRef (ref :: TypeRef snm) t + = ViaFromAvroTypeRef { unViaFromAvroTypeRef :: t } +-- | Wrapper used to tag a type with its corresponding +-- 'TypeRef' used for serialization to Avro. +-- Intended for internal use. +newtype ViaToAvroTypeRef (ref :: TypeRef snm) t + = ViaToAvroTypeRef { unViaToAvroTypeRef :: t } + +instance GRPCInput AvroRPC () where + encodeInput _ c () = encodeEmpty c + decodeInput _ _ = runGetIncremental $ pure $ Right () + +instance GRPCOutput AvroRPC () where + encodeOutput _ c () = encodeEmpty c + decodeOutput _ _ = runGetIncremental $ pure $ Right () + +encodeEmpty :: Compression -> Builder +encodeEmpty compression = + mconcat [ singleton (if _compressionByteSet compression then 1 else 0) + , putWord32be (fromIntegral $ ByteString.length bin) + , fromByteString bin + ] + where + bin = _compressionFunction compression "" + +instance forall (sch :: Schema') (sty :: Symbol) (i :: Type). + ( HasAvroSchema (WithSchema sch sty i) + , FromAvro (WithSchema sch sty i) ) + => GRPCInput AvroRPC (ViaFromAvroTypeRef ('SchemaRef sch sty) i) where + encodeInput = error "eif/you should not call this" + decodeInput _ i = (ViaFromAvroTypeRef . unWithSchema @_ @_ @sch @sty @i <$>) <$> decoder i + +instance forall (sch :: Schema') (sty :: Symbol) (i :: Type). + ( HasAvroSchema (WithSchema sch sty i) + , FromAvro (WithSchema sch sty i) ) + => GRPCOutput AvroRPC (ViaFromAvroTypeRef ('SchemaRef sch sty) i) where + encodeOutput = error "eof/you should not call this" + decodeOutput _ i = (ViaFromAvroTypeRef . unWithSchema @_ @_ @sch @sty @i <$>) <$> decoder i + +instance forall (sch :: Schema') (sty :: Symbol) (o :: Type). + ( HasAvroSchema (WithSchema sch sty o) + , ToAvro (WithSchema sch sty o) ) + => GRPCInput AvroRPC (ViaToAvroTypeRef ('SchemaRef sch sty) o) where + encodeInput _ compression + = encoder compression . WithSchema @_ @_ @sch @sty . unViaToAvroTypeRef + decodeInput = error "dit/you should not call this" + +instance forall (sch :: Schema') (sty :: Symbol) (o :: Type). + ( HasAvroSchema (WithSchema sch sty o) + , ToAvro (WithSchema sch sty o) ) + => GRPCOutput AvroRPC (ViaToAvroTypeRef ('SchemaRef sch sty) o) where + encodeOutput _ compression + = encoder compression . WithSchema @_ @_ @sch @sty . unViaToAvroTypeRef + decodeOutput = error "dot/you should not call this" + +encoder :: (HasAvroSchema m, ToAvro m) + => Compression -> m -> Builder +encoder compression plain = + mconcat [ singleton (if _compressionByteSet compression then 1 else 0) + , putWord32be (fromIntegral $ ByteString.length bin) + , fromByteString bin + ] + where + bin = _compressionFunction compression $ toStrict $ encodeValue plain + +decoder :: (HasAvroSchema a, FromAvro a) + => Compression -> Decoder (Either String a) +decoder compression = runGetIncremental $ do + isCompressed <- getInt8 -- 1byte + let decompress = if isCompressed == 0 then pure else _decompressionFunction compression + n <- getWord32be -- 4bytes + decodeValue . fromStrict <$> (decompress =<< getByteString (fromIntegral n)) + +-- Based on https://hackage.haskell.org/package/binary/docs/Data-Binary-Get-Internal.html +instance Functor Decoder where + fmap f (Done b s a) = Done b s (f a) + fmap f (Partial k) = Partial (fmap f . k) + fmap _ (Fail b s msg) = Fail b s msg diff --git a/grpc/common/src/Mu/GRpc/Bridge.hs b/grpc/common/src/Mu/GRpc/Bridge.hs new file mode 100644 index 00000000..e268e23e --- /dev/null +++ b/grpc/common/src/Mu/GRpc/Bridge.hs @@ -0,0 +1,51 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} +{-| +Description : Supported serialization formats for gRPC + +Currently Protocol Buffers and Avro can be used as +serialization format for the messages in gRPC +requests and replies. This module provides types +and proxies used in both @mu-grpc-client@ and +@mu-grpc-server@ to drive this choice of serialization. +-} +module Mu.GRpc.Bridge where + +import Data.ByteString +import Data.Kind +import Data.Proxy +import Network.GRPC.HTTP2.Proto3Wire + +import Mu.GRpc.Avro + +-- | Serialization formats supported with gRPC. +data GRpcMessageProtocol + = MsgProtoBuf -- ^ Protocol Buffers. + | MsgAvro -- ^ Avro. + deriving (Eq, Show) + +-- | Choose Protocol Buffers as serialization format for gRPC. +-- This value is commonly used to create a client or server. +msgProtoBuf :: Proxy 'MsgProtoBuf +msgProtoBuf = Proxy +-- | Choose Avro as serialization format for gRPC. +-- This value is commonly used to create a client or server. +msgAvro :: Proxy 'MsgAvro +msgAvro = Proxy + +-- | Defines how to build serialization-specific +-- RPC locators from a triple of (package, server, method). +class MkRPC (p :: GRpcMessageProtocol) where + type RPCTy p :: Type + mkRPC :: Proxy p -> ByteString -> ByteString -> ByteString -> RPCTy p +instance MkRPC 'MsgProtoBuf where + type RPCTy 'MsgProtoBuf = RPC + mkRPC _ = RPC +instance MkRPC 'MsgAvro where + type RPCTy 'MsgAvro = AvroRPC + mkRPC _ = AvroRPC 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..ffeb95d1 --- /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 © 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/grpc/server/Setup.hs b/grpc/server/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/grpc/server/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/grpc/server/exe/ExampleServer.hs b/grpc/server/exe/ExampleServer.hs new file mode 100644 index 00000000..7bc97a19 --- /dev/null +++ b/grpc/server/exe/ExampleServer.hs @@ -0,0 +1,19 @@ +{-# 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 + putStrLn "running quickstart application" + runGRpcApp msgProtoBuf 8080 quickstartServer diff --git a/grpc/server/hie.yaml b/grpc/server/hie.yaml new file mode 100644 index 00000000..5502c470 --- /dev/null +++ b/grpc/server/hie.yaml @@ -0,0 +1,6 @@ +cradle: + stack: + - path: "./src" + component: "mu-grpc-server:lib" + - path: "./exe" + component: "mu-grpc-server:exe:grpc-example-server" diff --git a/grpc/server/mu-grpc-server.cabal b/grpc/server/mu-grpc-server.cabal new file mode 100644 index 00000000..3ca0c0f9 --- /dev/null +++ b/grpc/server/mu-grpc-server.cabal @@ -0,0 +1,76 @@ +name: mu-grpc-server +version: 0.5.0.0 +synopsis: gRPC servers for Mu definitions +description: + With @mu-grpc-server@ you can easily build gRPC servers for mu-haskell! + +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano, Flavio Corpa +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 +cabal-version: >=1.10 +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 + build-depends: + async >=2.2 && <3 + , avro >=0.5.1 && <0.6 + , base >=4.12 && <5 + , binary >=0.8 && <0.9 + , bytestring >=0.10 && <0.11 + , conduit >=1.3.2 && <2 + , http2-grpc-types >=0.5 && <0.6 + , mtl >=2.2 && <3 + , mu-grpc-common >=0.4 && <0.5 + , mu-protobuf >=0.4 && <0.5 + , mu-rpc >=0.5 && <0.6 + , mu-schema >=0.3 && <0.4 + , sop-core >=0.5 && <0.6 + , stm >=2.5 && <3 + , stm-conduit >=4 && <5 + , wai >=3.2 && <4 + , warp >=3.3 && <4 + , warp-grpc >=0.4.0.1 && <0.5 + , warp-tls >=3.2 && <4 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances + +executable grpc-example-server + main-is: ExampleServer.hs + build-depends: + async >=2.2 && <3 + , avro >=0.5.1 && <0.6 + , base >=4.12 && <5 + , binary >=0.8 && <0.9 + , bytestring >=0.10 && <0.11 + , conduit >=1.3.2 && <2 + , http2-grpc-types >=0.5 && <0.6 + , mtl >=2.2 && <3 + , mu-grpc-common >=0.4 && <0.5 + , mu-grpc-server + , mu-protobuf >=0.4 && <0.5 + , mu-rpc >=0.5 && <0.6 + , mu-schema >=0.3 && <0.4 + , sop-core >=0.5 && <0.6 + , stm >=2.5 && <3 + , stm-conduit >=4 && <5 + , wai >=3.2 && <4 + , warp >=3.3 && <4 + , warp-grpc >=0.4.0.1 && <0.5 + , warp-tls >=3.2 && <4 + + hs-source-dirs: exe + default-language: Haskell2010 + ghc-options: -Wall -fprint-explicit-kinds -fprint-explicit-foralls diff --git a/grpc/server/src/Mu/GRpc/Server.hs b/grpc/server/src/Mu/GRpc/Server.hs new file mode 100644 index 00000000..07a5da65 --- /dev/null +++ b/grpc/server/src/Mu/GRpc/Server.hs @@ -0,0 +1,531 @@ +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} +{-| +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 +( -- * Supported messaging formats + GRpcMessageProtocol(..) +, msgProtoBuf, msgAvro + -- * Run a 'Server' directly +, runGRpcApp, runGRpcAppTrans +, runGRpcAppSettings, Settings +, runGRpcAppTLS, TLSSettings + -- * Convert a 'Server' into a WAI application +, gRpcApp, gRpcAppTrans +, WrappedServer(..), gRpcMultipleApp, gRpcMultipleAppTrans + -- * Raise errors as exceptions in IO +, raiseErrors, liftServerConduit + -- * Re-export useful instances +, module Avro +) where + +import Control.Concurrent.Async +import Control.Concurrent.STM (atomically) +import Control.Concurrent.STM.TMVar +import Control.Exception +import Control.Monad.Except +import Data.Avro +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 GHC.TypeLits +import Network.GRPC.HTTP2.Encoding (GRPCInput, GRPCOutput, gzip, uncompressed) +import Network.GRPC.HTTP2.Types (GRPCStatus (..), GRPCStatusCode (..)) +import Network.GRPC.Server.Handlers.Trans +import Network.GRPC.Server.Wai as Wai +import Network.Wai (Application, Request, requestHeaders) +import Network.Wai.Handler.Warp (Port, Settings, run, runSettings) +import Network.Wai.Handler.WarpTLS (TLSSettings, runTLS) + +import Mu.Adapter.ProtoBuf.Via +import Mu.GRpc.Avro +import qualified Mu.GRpc.Avro as Avro +import Mu.GRpc.Bridge +import Mu.Rpc +import Mu.Schema +import Mu.Server + +-- | Run a Mu 'Server' on the given port. +runGRpcApp + :: ( KnownName name + , GRpcServiceHandlers ('Package ('Just name) services) + protocol ServerErrorIO chn services handlers ) + => Proxy protocol + -> Port + -> ServerT chn () ('Package ('Just name) services) ServerErrorIO handlers + -> IO () +runGRpcApp protocol port = runGRpcAppTrans protocol port id + +-- | Run a Mu 'Server' on the given port. +runGRpcAppTrans + :: ( KnownName name + , GRpcServiceHandlers ('Package ('Just name) services) + protocol m chn services handlers ) + => Proxy protocol + -> Port + -> (forall a. m a -> ServerErrorIO a) + -> ServerT chn () ('Package ('Just name) services) m handlers + -> IO () +runGRpcAppTrans protocol port f svr = run port (gRpcAppTrans protocol f svr) + +-- | Run a Mu 'Server' using the given 'Settings'. +-- +-- Go to 'Network.Wai.Handler.Warp' to declare 'Settings'. +runGRpcAppSettings + :: ( KnownName name + , GRpcServiceHandlers ('Package ('Just name) services) + protocol m chn services handlers ) + => Proxy protocol + -> Settings + -> (forall a. m a -> ServerErrorIO a) + -> ServerT chn () ('Package ('Just name) services) m handlers + -> IO () +runGRpcAppSettings protocol st f svr = runSettings st (gRpcAppTrans protocol f svr) + +-- | Run a Mu 'Server' using the given 'TLSSettings' and 'Settings'. +-- +-- Go to 'Network.Wai.Handler.WarpTLS' to declare 'TLSSettings' +-- and to 'Network.Wai.Handler.Warp' to declare 'Settings'. +runGRpcAppTLS + :: ( KnownName name + , GRpcServiceHandlers ('Package ('Just name) services) + protocol m chn services handlers ) + => Proxy protocol + -> TLSSettings -> Settings + -> (forall a. m a -> ServerErrorIO a) + -> ServerT chn () ('Package ('Just name) services) m handlers + -> IO () +runGRpcAppTLS protocol tls st f svr = runTLS tls st (gRpcAppTrans protocol f svr) + +-- | 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. +gRpcApp + :: ( KnownName name + , GRpcServiceHandlers ('Package ('Just name) services) + protocol ServerErrorIO chn services handlers ) + => Proxy protocol + -> ServerT chn () ('Package ('Just name) services) ServerErrorIO handlers + -> Application +gRpcApp protocol = gRpcAppTrans protocol 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 + , GRpcServiceHandlers ('Package ('Just name) services) + protocol m chn services handlers ) + => Proxy protocol + -> (forall a. m a -> ServerErrorIO a) + -> ServerT chn () ('Package ('Just name) services) m handlers + -> Application +gRpcAppTrans protocol f svr + = Wai.grpcApp [uncompressed, gzip] + (gRpcServerHandlers protocol f svr) + +-- | Turn several Mu 'Server's 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. +gRpcMultipleApp + :: Proxy protocol + -> [WrappedServer protocol ServerErrorIO] + -> Application +gRpcMultipleApp protocol = gRpcMultipleAppTrans protocol id + +-- | Turn several Mu 'Server's 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. +gRpcMultipleAppTrans + :: Proxy protocol + -> (forall a. m a -> ServerErrorIO a) + -> [WrappedServer protocol m] + -> Application +gRpcMultipleAppTrans protocol f svr + = Wai.grpcApp [uncompressed, gzip] + (concatMap (gRpcServerHandlersS protocol f) svr) + +gRpcServerHandlers + :: forall name services handlers m protocol chn. + ( KnownName name + , GRpcServiceHandlers ('Package ('Just name) services) + protocol m chn services handlers ) + => Proxy protocol + -> (forall a. m a -> ServerErrorIO a) + -> ServerT chn () ('Package ('Just name) services) m handlers + -> [ServiceHandler] +gRpcServerHandlers pr f (Services svr) + = gRpcServiceHandlers f (Proxy @('Package ('Just name) services)) pr packageName svr + where packageName = BS.pack (nameVal (Proxy @name)) + +data WrappedServer protocol m where + Srv :: ( KnownName name + , GRpcServiceHandlers ('Package ('Just name) services) + protocol m chn services handlers ) + => ServerT chn () ('Package ('Just name) services) m handlers + -> WrappedServer protocol m + +gRpcServerHandlersS + :: Proxy protocol + -> (forall a. m a -> ServerErrorIO a) + -> WrappedServer protocol m + -> [ServiceHandler] +gRpcServerHandlersS pr f (Srv svr) + = gRpcServerHandlers pr f svr + +class GRpcServiceHandlers (fullP :: Package snm mnm anm (TypeRef snm)) + (p :: GRpcMessageProtocol) (m :: Type -> Type) + (chn :: ServiceChain snm) + (ss :: [Service snm mnm anm (TypeRef snm)]) (hs :: [[Type]]) where + gRpcServiceHandlers :: (forall a. m a -> ServerErrorIO a) + -> Proxy fullP -> Proxy p -> ByteString + -> ServicesT chn () ss m hs -> [ServiceHandler] + +instance GRpcServiceHandlers fullP p m chn '[] '[] where + gRpcServiceHandlers _ _ _ _ S0 = [] +instance ( KnownName name + , GRpcMethodHandlers fullP ('Service name methods) + p m chn (MappingRight chn name) methods h + , GRpcServiceHandlers fullP p m chn rest hs ) + => GRpcServiceHandlers fullP p m chn ('Service name methods ': rest) (h ': hs) where + gRpcServiceHandlers f pfullP pr packageName (ProperSvc svr :<&>: rest) + = gRpcMethodHandlers f pfullP (Proxy @('Service name methods)) pr + packageName serviceName svr + ++ gRpcServiceHandlers f pfullP pr packageName rest + where serviceName = BS.pack (nameVal (Proxy @name)) + +instance ( GHC.TypeLits.TypeError ('Text "unions are not supported in gRPC") ) + => GRpcServiceHandlers fullP p m chn ('OneOf name methods ': rest) hs where + gRpcServiceHandlers _ = error "unions are not supported in gRPC" + +class GRpcMethodHandlers (fullP :: Package snm mnm anm (TypeRef snm)) + (fullS :: Service snm mnm anm (TypeRef snm)) + (p :: GRpcMessageProtocol) (m :: Type -> Type) + (chn :: ServiceChain snm) (inh :: Type) + (ms :: [Method snm mnm anm (TypeRef snm)]) (hs :: [Type]) where + gRpcMethodHandlers :: (forall a. m a -> ServerErrorIO a) + -> Proxy fullP -> Proxy fullS -> Proxy p -> ByteString -> ByteString + -> HandlersT chn () inh ms m hs -> [ServiceHandler] + +instance GRpcMethodHandlers fullP fullS p m chn inh '[] '[] where + gRpcMethodHandlers _ _ _ _ _ _ H0 = [] +instance ( KnownName name, MkRPC p + , ReflectRpcInfo fullP fullS ('Method name args r) + , GRpcMethodHandler p m args r h + , GRpcMethodHandlers fullP fullS p m chn () rest hs) + => GRpcMethodHandlers fullP fullS p m chn () + ('Method name args r ': rest) (h ': hs) where + gRpcMethodHandlers f pfullP pfullS pr p s (Hmore _ _ h rest) + = gRpcMethodHandler f pr (Proxy @args) (Proxy @r) (mkRPC pr p s methodName) + (\req -> h (reflectInfo (requestHeaders req)) ()) + : gRpcMethodHandlers f pfullP pfullS pr p s rest + where methodName = BS.pack (nameVal (Proxy @name)) + reflectInfo hdrs + = reflectRpcInfo pfullP pfullS (Proxy @('Method name args r)) hdrs () + +class GRpcMethodHandler p m (args :: [Argument snm anm (TypeRef snm)]) r h where + gRpcMethodHandler :: (forall a. m a -> ServerErrorIO a) + -> Proxy p -> Proxy args -> Proxy r + -> RPCTy p -> (Request -> 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 + h' <- runExceptT h + case h' of + Right r -> pure r + 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 + serverErrorToGRpcError Unavailable = UNAVAILABLE + serverErrorToGRpcError Unimplemented = UNIMPLEMENTED + serverErrorToGRpcError Unauthenticated = UNAUTHENTICATED + serverErrorToGRpcError Internal = INTERNAL + serverErrorToGRpcError NotFound = NOT_FOUND + serverErrorToGRpcError Invalid = INVALID_ARGUMENT + +----- +-- IMPLEMENTATION OF THE METHODS +----- + +-- These type classes allow us to abstract over +-- the choice of message protocol (PB or Avro) + +class GRPCOutput (RPCTy p) (GRpcOWTy p ref r) + => GRpcOutputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where + type GRpcOWTy p ref r :: Type + buildGRpcOWTy :: Proxy p -> Proxy ref -> r -> GRpcOWTy p ref r + +instance ToProtoBufTypeRef ref r + => GRpcOutputWrapper 'MsgProtoBuf ref r where + type GRpcOWTy 'MsgProtoBuf ref r = ViaToProtoBufTypeRef ref r + buildGRpcOWTy _ _ = ViaToProtoBufTypeRef + +instance forall (sch :: Schema') sty (r :: Type). + ( ToSchema sch sty r + , ToAvro (WithSchema sch sty r) + , HasAvroSchema (WithSchema sch sty r) ) + => GRpcOutputWrapper 'MsgAvro ('SchemaRef sch sty) r where + type GRpcOWTy 'MsgAvro ('SchemaRef sch sty) r = ViaToAvroTypeRef ('SchemaRef sch sty) r + buildGRpcOWTy _ _ = ViaToAvroTypeRef + +class GRPCInput (RPCTy p) (GRpcIWTy p ref r) + => GRpcInputWrapper (p :: GRpcMessageProtocol) (ref :: TypeRef snm) (r :: Type) where + type GRpcIWTy p ref r :: Type + unGRpcIWTy :: Proxy p -> Proxy ref -> GRpcIWTy p ref r -> r + +instance FromProtoBufTypeRef ref r + => GRpcInputWrapper 'MsgProtoBuf ref r where + type GRpcIWTy 'MsgProtoBuf ref r = ViaFromProtoBufTypeRef ref r + unGRpcIWTy _ _ = unViaFromProtoBufTypeRef + +instance forall (sch :: Schema') sty (r :: Type). + ( FromSchema sch sty r + , FromAvro (WithSchema sch sty r) + , HasAvroSchema (WithSchema sch sty r) ) + => GRpcInputWrapper 'MsgAvro ('SchemaRef sch sty) r where + type GRpcIWTy 'MsgAvro ('SchemaRef sch sty) r = ViaFromAvroTypeRef ('SchemaRef sch sty) r + unGRpcIWTy _ _ = unViaFromAvroTypeRef + +--- + +instance (MonadIO m, GRPCInput (RPCTy p) (), GRPCOutput (RPCTy p) ()) + => GRpcMethodHandler p m '[ ] 'RetNothing (m ()) where + gRpcMethodHandler f _ _ _ rpc h + = unary @m @_ @() @() (raiseErrors . f) rpc (\req _ -> h req) + +----- + +instance (MonadIO m, GRPCInput (RPCTy p) (), GRpcOutputWrapper p rref r) + => GRpcMethodHandler p m '[ ] ('RetSingle rref) (m r) where + gRpcMethodHandler f _ _ _ rpc h + = unary @m @_ @() @(GRpcOWTy p rref r) + (raiseErrors . f) rpc + (\req _ -> buildGRpcOWTy (Proxy @p) (Proxy @rref) <$> h req) + +----- + +instance (MonadIO m, GRPCInput (RPCTy p) (), GRpcOutputWrapper p rref r, MonadIO m) + => GRpcMethodHandler p m '[ ] ('RetStream rref) + (ConduitT r Void m () -> m ()) where + gRpcMethodHandler f _ _ _ rpc h + = serverStream @m @_ @() @(GRpcOWTy p rref r) (raiseErrors . f) rpc sstream + where sstream :: Request -> () + -> m ((), ServerStream m (GRpcOWTy p rref r) ()) + sstream req _ = do + -- Variable to connect input and output + var <- liftIO newEmptyTMVarIO :: m (TMVar (Maybe r)) + -- Start executing the handler + promise <- liftIO $ async (raiseErrors $ f (h req (toTMVarConduit var))) + -- Return the information + let readNext _ + = do nextOutput <- liftIO $ atomically $ takeTMVar var + case nextOutput of + Just o -> pure $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o) + Nothing -> do liftIO $ cancel promise + pure Nothing + pure ((), ServerStream readNext) + +----- + +instance (MonadIO m, GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) ()) + => GRpcMethodHandler p m '[ 'ArgSingle aname vref ] 'RetNothing (v -> m ()) where + gRpcMethodHandler f _ _ _ rpc h + = unary @m @_ @(GRpcIWTy p vref v) @() + (raiseErrors . f) rpc + (\req -> h req . unGRpcIWTy (Proxy @p) (Proxy @vref)) + +----- + +instance (MonadIO m, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r) + => GRpcMethodHandler p m '[ 'ArgSingle aname vref ] ('RetSingle rref) (v -> m r) where + gRpcMethodHandler f _ _ _ rpc h + = unary @m @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) + (raiseErrors . f) rpc + (\req -> (buildGRpcOWTy (Proxy @p) (Proxy @rref) <$>) + . h req + . unGRpcIWTy (Proxy @p) (Proxy @vref)) + +----- + +instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m) + => GRpcMethodHandler p m '[ 'ArgSingle aname vref ] ('RetStream rref) + (v -> ConduitT r Void m () -> m ()) where + gRpcMethodHandler f _ _ _ rpc h + = serverStream @m @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) + (raiseErrors . f) rpc sstream + where sstream :: Request -> GRpcIWTy p vref v + -> m ((), ServerStream m (GRpcOWTy p rref r) ()) + sstream req v = do + -- Variable to connect input and output + var <- liftIO newEmptyTMVarIO :: m (TMVar (Maybe r)) + -- Start executing the handler + let v' = unGRpcIWTy (Proxy @p) (Proxy @vref) v + promise <- liftIO $ async (raiseErrors $ f (h req v' (toTMVarConduit var))) + -- Return the information + let readNext _ + = do nextOutput <- liftIO $ atomically $ takeTMVar var + case nextOutput of + Just o -> pure $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o) + Nothing -> do liftIO $ cancel promise + pure Nothing + pure ((), ServerStream readNext) + +----- + +instance (MonadIO m, GRpcInputWrapper p vref v, GRPCOutput (RPCTy p) (), MonadIO m) + => GRpcMethodHandler p m '[ 'ArgStream aname vref ] 'RetNothing + (ConduitT () v m () -> m ()) where + gRpcMethodHandler f _ _ _ rpc h + = clientStream @m @_ @(GRpcIWTy p vref v) @() + (raiseErrors . f) rpc cstream + where cstream :: Request + -> m ((), ClientStream m (GRpcIWTy p vref v) () ()) + cstream req = do + -- Create a new TMChan + chan <- liftIO newTMChanIO :: m (TMChan v) + let producer = sourceTMChan @m chan + -- Start executing the handler in another thread + promise <- liftIO $ async (raiseErrors $ f (h req producer)) + -- Build the actual handler + let cstreamHandler _ newInput + = liftIO $ atomically $ + writeTMChan chan (unGRpcIWTy (Proxy @p) (Proxy @vref) newInput) + cstreamFinalizer _ + = liftIO $ atomically (closeTMChan chan) >> wait promise + -- Return the information + pure ((), ClientStream cstreamHandler cstreamFinalizer) + +----- + +instance (MonadIO m, GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m) + => GRpcMethodHandler p m '[ 'ArgStream aname vref ] ('RetSingle rref) + (ConduitT () v m () -> m r) where + gRpcMethodHandler f _ _ _ rpc h + = clientStream @m @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) + (raiseErrors . f) rpc cstream + where cstream :: Request + -> m ((), ClientStream m (GRpcIWTy p vref v) + (GRpcOWTy p rref r) ()) + cstream req = do + -- Create a new TMChan + chan <- liftIO newTMChanIO :: m (TMChan v) + let producer = sourceTMChan @m chan + -- Start executing the handler in another thread + promise <- liftIO $ async + (raiseErrors + $ buildGRpcOWTy (Proxy @p) (Proxy @rref) + <$> f (h req producer)) + -- Build the actual handler + let cstreamHandler _ newInput + = liftIO $ atomically $ + writeTMChan chan (unGRpcIWTy (Proxy @p) (Proxy @vref) newInput) + cstreamFinalizer _ + = liftIO $ atomically (closeTMChan chan) >> wait promise + -- Return the information + pure ((), ClientStream cstreamHandler cstreamFinalizer) + +----- + +instance (GRpcInputWrapper p vref v, GRpcOutputWrapper p rref r, MonadIO m) + => GRpcMethodHandler p m '[ 'ArgStream aname vref ] ('RetStream rref) + (ConduitT () v m () -> ConduitT r Void m () -> m ()) where + gRpcMethodHandler f _ _ _ rpc h + = generalStream @m @_ @(GRpcIWTy p vref v) @(GRpcOWTy p rref r) + (raiseErrors . f) rpc bdstream + where bdstream :: Request + -> m ( (), IncomingStream m (GRpcIWTy p vref v) () + , (), OutgoingStream m (GRpcOWTy p rref r) () ) + bdstream req = do + -- Create a new TMChan for consuming the client stream, it will be + -- the producer for the conduit. + clientChan <- liftIO newTMChanIO :: m (TMChan v) + let producer = sourceTMChan @m clientChan + + -- Create a new TMChan for producing the server stream, it will be + -- the consumer for the conduit. + serverChan <- liftIO newTMChanIO :: m (TMChan r) + let consumer = sinkTMChan @m serverChan + + -- Start executing the handler + handlerPromise <- liftIO $ async $ do + raiseErrors $ f $ h req producer consumer + atomically $ closeTMChan serverChan + + -- Build the actual handler + let cstreamHandler _ newInput + = liftIO $ atomically $ + writeTMChan clientChan (unGRpcIWTy (Proxy @p) (Proxy @vref) newInput) + cstreamFinalizer _ + = liftIO $ atomically (closeTMChan clientChan) >> wait handlerPromise + readNext _ + = do nextOutput <- liftIO $ atomically $ readTMChan serverChan + case nextOutput of + Just o -> + pure $ Just ((), buildGRpcOWTy (Proxy @p) (Proxy @rref) o) + Nothing -> do + pure Nothing + pure ((), IncomingStream cstreamHandler cstreamFinalizer, (), OutgoingStream readNext) + +----- + +toTMVarConduit :: MonadIO m => TMVar (Maybe r) -> ConduitT r Void m () +toTMVarConduit var = do + x <- await + liftIO $ atomically $ putTMVar var x + toTMVarConduit var diff --git a/grpc/src/ExampleServer.hs b/grpc/src/ExampleServer.hs deleted file mode 100644 index d38a2c83..00000000 --- a/grpc/src/ExampleServer.hs +++ /dev/null @@ -1,10 +0,0 @@ -{-# language OverloadedStrings #-} -module Main where - -import Mu.Server.GRpc -import Mu.Rpc.Examples - -main :: IO () -main = do - putStrLn "running quickstart application" - runGRpcApp 8080 quickstartServer \ No newline at end of file diff --git a/grpc/src/Mu/Client/GRpc/Examples.hs b/grpc/src/Mu/Client/GRpc/Examples.hs deleted file mode 100644 index 6af7d6e9..00000000 --- a/grpc/src/Mu/Client/GRpc/Examples.hs +++ /dev/null @@ -1,28 +0,0 @@ -{-# language DataKinds, TypeApplications #-} -module Mu.Client.GRpc.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 Mu.Client.GRpc.TyApps -import Mu.Rpc.Examples - -sayHello' :: HostName -> PortNumber -> T.Text -> IO (GRpcReply T.Text) -sayHello' host port req - = do Right c <- setupGrpcClient' (grpcClientConfigSimple host port False) - fmap (\(HelloResponse r) -> r) <$> sayHello c (HelloRequest req) - -sayHello :: GrpcClient -> HelloRequest -> IO (GRpcReply HelloResponse) -sayHello = gRpcCall @QuickStartService @"SayHello" - -sayHi' :: HostName -> PortNumber -> Int -> IO [GRpcReply T.Text] -sayHi' host port n - = do Right c <- setupGrpcClient' (grpcClientConfigSimple host port False) - cndt <- sayHi c (HiRequest 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 diff --git a/grpc/src/Mu/Client/GRpc/Internal.hs b/grpc/src/Mu/Client/GRpc/Internal.hs deleted file mode 100644 index 2c117b0c..00000000 --- a/grpc/src/Mu/Client/GRpc/Internal.hs +++ /dev/null @@ -1,221 +0,0 @@ -{-# language PolyKinds, DataKinds, GADTs, - MultiParamTypeClasses, - FlexibleInstances, FlexibleContexts, - ScopedTypeVariables, TypeApplications, - TypeOperators, DeriveFunctor, - AllowAmbiguousTypes, - TupleSections, UndecidableInstances #-} --- | Client for gRPC services defined using Mu 'Service' -module Mu.Client.GRpc.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.GRpc.Shared - -setupGrpcClient' :: GrpcClientConfig -> IO (Either ClientError GrpcClient) -setupGrpcClient' = runExceptT . setupGrpcClient - -class GRpcServiceMethodCall (s :: Service snm mnm) (m :: Method mnm) h where - gRpcServiceMethodCall :: Proxy s -> Proxy m -> GrpcClient -> h -instance (KnownName serviceName, KnownName (FindPackageName anns), GRpcMethodCall m h) - => GRpcServiceMethodCall ('Service serviceName anns methods) m h where - gRpcServiceMethodCall _ = gRpcMethodCall pkgName svrName - where pkgName = BS.pack (nameVal (Proxy @(FindPackageName anns))) - svrName = BS.pack (nameVal (Proxy @serviceName)) - -data GRpcReply a - = GRpcTooMuchConcurrency TooMuchConcurrency - | GRpcErrorCode ErrorCode - | GRpcErrorString String - | GRpcClientError ClientError - | GRpcOk a - deriving (Show, Functor) - -buildGRpcReply1 :: Either TooMuchConcurrency (RawReply a) -> GRpcReply a -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 - -buildGRpcReply3 :: Either TooMuchConcurrency v -> GRpcReply () -buildGRpcReply3 (Left tmc) = GRpcTooMuchConcurrency tmc -buildGRpcReply3 (Right _) = GRpcOk () - -simplifyResponse :: ClientIO (GRpcReply a) -> IO (GRpcReply a) -simplifyResponse reply = do - r <- runExceptT reply - case r of - Left e -> return $ GRpcClientError e - Right v -> return v - -class GRpcMethodCall method h where - gRpcMethodCall :: ByteString -> ByteString -> Proxy method -> GrpcClient -> h - -instance (KnownName name, handler ~ IO (GRpcReply ())) - => GRpcMethodCall ('Method name anns '[ ] 'RetNothing) handler where - gRpcMethodCall pkgName srvName _ client - = simplifyResponse $ - buildGRpcReply1 <$> - rawUnary rpc client () - where methodName = BS.pack (nameVal (Proxy @name)) - rpc = RPC pkgName srvName methodName - -instance ( KnownName name, ProtoBufTypeRef rref r - , handler ~ IO (GRpcReply r) ) - => GRpcMethodCall ('Method name anns '[ ] ('RetSingle rref)) handler where - gRpcMethodCall pkgName srvName _ client - = fmap (fmap unViaProtoBufTypeRef) $ - simplifyResponse $ - buildGRpcReply1 <$> - rawUnary @_ @_ @(ViaProtoBufTypeRef rref _)rpc client () - 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 - gRpcMethodCall pkgName srvName _ client x - = simplifyResponse $ - buildGRpcReply1 <$> - rawUnary @_ @(ViaProtoBufTypeRef vref _) rpc client (ViaProtoBufTypeRef x) - where methodName = BS.pack (nameVal (Proxy @name)) - rpc = RPC pkgName srvName methodName - -instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef 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) $ - simplifyResponse $ - buildGRpcReply1 <$> - rawUnary @_ @(ViaProtoBufTypeRef vref _) @(ViaProtoBufTypeRef rref _) - rpc client (ViaProtoBufTypeRef x) - where methodName = BS.pack (nameVal (Proxy @name)) - rpc = RPC pkgName srvName methodName - -instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef 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 - = do -- Create a new TMChan - chan <- newTMChanIO :: IO (TMChan v) - -- Start executing the client in another thread - promise <- async $ - fmap (fmap unViaProtoBufTypeRef) $ - simplifyResponse $ - buildGRpcReply2 <$> - rawStreamClient @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) rpc client () - (\_ -> do nextVal <- liftIO $ atomically $ readTMChan chan - case nextVal of - Nothing -> return ((), Left StreamDone) - Just v -> return ((), Right (compress, ViaProtoBufTypeRef v))) - -- This conduit feeds information to the other thread - let go = do x <- await - case x of - Just v -> do liftIO $ atomically $ writeTMChan chan v - go - Nothing -> do liftIO $ atomically $ closeTMChan chan - liftIO $ wait promise - return go - where methodName = BS.pack (nameVal (Proxy @name)) - rpc = RPC pkgName srvName methodName - -instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r - , handler ~ (v -> IO (ConduitT () (GRpcReply r) IO ())) ) - => GRpcMethodCall ('Method name anns '[ 'ArgSingle vref ] ('RetStream rref)) handler where - gRpcMethodCall pkgName srvName _ client x - = 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 vref v) @(ViaProtoBufTypeRef rref r) - rpc client () (ViaProtoBufTypeRef x) - (\_ _ (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, ProtoBufTypeRef 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 - = do -- Create a new TMChan - inchan <- newTMChanIO :: IO (TMChan (GRpcReply r)) - outchan <- newTMChanIO :: IO (TMChan v) - var <- newEmptyTMVarIO -- if full, this means an error - -- Start executing the client in another thread - _ <- async $ do - v <- simplifyResponse $ - buildGRpcReply3 <$> - rawGeneralStream - @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef 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) - 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))) - case v of - GRpcOk () -> liftIO $ atomically $ closeTMChan inchan - _ -> 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 - 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 - 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 diff --git a/grpc/src/Mu/Client/GRpc/Record.hs b/grpc/src/Mu/Client/GRpc/Record.hs deleted file mode 100644 index 18785f82..00000000 --- a/grpc/src/Mu/Client/GRpc/Record.hs +++ /dev/null @@ -1,236 +0,0 @@ -{-# language PolyKinds, DataKinds, TypeOperators, - MultiParamTypeClasses, TypeFamilies, - FlexibleInstances, FlexibleContexts, - UndecidableInstances, TypeApplications, - ScopedTypeVariables, AllowAmbiguousTypes, - TemplateHaskell #-} --- | Client for gRPC services defined using Mu 'Service' --- using plain Haskell records of functions -module Mu.Client.GRpc.Record ( - -- * Initialization of the gRPC client - GrpcClient -, GrpcClientConfig -, grpcClientConfigSimple -, setupGrpcClient' - -- * Fill and generate the Haskell record of functions -, buildService -, CompressMode(..) -, GRpcReply(..) -, 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 Network.GRPC.Client (CompressMode(..)) -import Network.GRPC.Client.Helpers - -import Mu.Client.GRpc.Internal -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]). - (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) - -class BuildService (s :: Service') (p :: Symbol) (ms :: [Method Symbol]) (f :: * -> *) where - buildService' :: Proxy s -> Proxy p -> Proxy ms -> GrpcClient -> f a - -instance BuildService s p ms U1 where - buildService' _ _ _ _ = U1 -instance BuildService s p ms f => BuildService s p ms (D1 meta f) where - buildService' ps ppr pms client - = M1 (buildService' ps ppr pms client) -instance BuildService s p ms f => BuildService s p ms (C1 meta f) where - buildService' ps ppr pms client - = M1 (buildService' ps ppr pms client) -instance TypeError ('Text "building a service from sums is not supported") - => BuildService s p ms (f :+: g) where - buildService' = error "this should never happen" -instance (BuildService s p ms f, BuildService s p ms g) - => BuildService s p ms (f :*: g) where - buildService' ps ppr pms client - = buildService' ps ppr pms client :*: buildService' ps ppr pms client -instance (m ~ AppendSymbol p x, GRpcServiceMethodCall s (s :-->: x) h) - => BuildService s p ms (S1 ('MetaSel ('Just m) u ss ds) (K1 i h)) where - buildService' ps _ _ client - = M1 $ K1 $ gRpcServiceMethodCall ps (Proxy @(s :-->: x)) client - --- TEMPLATE HASKELL --- ================ - --- | Generate the plain Haskell record corresponding to --- a Mu 'Service' definition, and a concrete implementation --- of 'buildService' for that record. -generateRecordFromService :: String -> String -> Namer -> Name -> Q [Dec] -generateRecordFromService newRecordName fieldsPrefix tNamer serviceTyName - = do let serviceTy = ConT serviceTyName - srvDef <- typeToServiceDef serviceTy - case srvDef of - Nothing -> fail "service definition cannot be parsed" - Just sd -> serviceDefToDecl serviceTyName newRecordName fieldsPrefix tNamer sd - -type Namer = String -> String - -serviceDefToDecl :: Name -> String -> String -> Namer -> Service String String -> Q [Dec] -serviceDefToDecl serviceTyName complete fieldsPrefix tNamer (Service _ _ methods) - = do d <- dataD (pure []) - (mkName complete) - [] - Nothing - [RecC (mkName complete) <$> mapM (methodToDecl fieldsPrefix tNamer) methods] - [pure (DerivClause Nothing [ConT ''Generic])] - let buildName = mkName ("build" ++ complete) - s <- SigD buildName <$> [t|GrpcClient -> $(return (ConT (mkName complete)))|] - c <- Clause <$> pure [] - <*> (NormalB <$> [e|buildService @($(return $ ConT serviceTyName)) - @($(return $ LitT (StrTyLit fieldsPrefix)))|]) - <*> pure [] - return [d, s, FunD buildName [c]] - -methodToDecl :: String -> Namer -> Method String -> Q (Name, Bang, Type) -methodToDecl fieldsPrefix tNamer (Method mName _ args ret) - = do let nm = firstLower (fieldsPrefix ++ mName) - ty <- computeMethodType tNamer args ret - return ( mkName nm, Bang NoSourceUnpackedness NoSourceStrictness, ty ) - -computeMethodType :: Namer -> [Argument] -> Return -> Q Type -computeMethodType _ [] RetNothing - = [t|IO (GRpcReply ())|] -computeMethodType n [] (RetSingle r) - = [t|IO (GRpcReply $(typeRefToType n r))|] -computeMethodType n [ArgSingle v] RetNothing - = [t|$(typeRefToType n v) -> IO (GRpcReply ())|] -computeMethodType n [ArgSingle v] (RetSingle r) - = [t|$(typeRefToType n v) -> IO (GRpcReply $(typeRefToType n r))|] -computeMethodType n [ArgStream v] (RetSingle r) - = [t|CompressMode -> IO (ConduitT $(typeRefToType n v) Void IO (GRpcReply $(typeRefToType n r)))|] -computeMethodType n [ArgSingle v] (RetStream r) - = [t|$(typeRefToType n v) -> IO (ConduitT () (GRpcReply $(typeRefToType n r)) IO ())|] -computeMethodType n [ArgStream v] (RetStream r) - = [t|CompressMode -> IO (ConduitT $(typeRefToType n v) (GRpcReply $(typeRefToType n r)) IO ())|] -computeMethodType _ _ _ = fail "method signature not supported" - -typeRefToType :: Namer -> TypeRef -> Q Type -typeRefToType tNamer (FromTH (LitT (StrTyLit s))) - = return $ ConT (mkName $ completeName tNamer s) -typeRefToType _tNamer (FromTH ty) - = return ty -typeRefToType _ _ = error "this should never happen" - -completeName :: Namer -> String -> String -completeName namer name = firstUpper (namer (firstUpper name)) - -firstUpper :: String -> String -firstUpper [] = error "Empty names are not allowed" -firstUpper (x:rest) = toUpper x : rest - -firstLower :: String -> String -firstLower [] = error "Empty names are not allowed" -firstLower (x:rest) = toLower x : rest - --- Parsing --- ======= - -typeToServiceDef :: Type -> Q (Maybe (Service String String)) -typeToServiceDef toplevelty - = typeToServiceDef' <$> resolveTypeSynonyms toplevelty - where - typeToServiceDef' :: Type -> Maybe (Service String String) - typeToServiceDef' expanded - = do (sn, _, methods) <- tyD3 'Service expanded - methods' <- tyList methods - Service <$> tyString sn - <*> pure [] - <*> mapM typeToMethodDef methods' - - typeToMethodDef :: Type -> Maybe (Method String) - typeToMethodDef ty - = do (mn, _, args, ret) <- tyD4 'Method ty - args' <- tyList args - Method <$> tyString mn - <*> pure [] - <*> mapM typeToArgDef args' - <*> typeToRetDef ret - - typeToArgDef :: Type -> Maybe Argument - typeToArgDef ty - = ArgSingle <$> (tyD1 'ArgSingle ty >>= typeToTypeRef) - <|> ArgStream <$> (tyD1 'ArgStream ty >>= typeToTypeRef) - - typeToRetDef :: Type -> Maybe Return - typeToRetDef ty - = RetNothing <$ tyD0 'RetNothing ty - <|> RetSingle <$> (tyD1 'RetSingle ty >>= typeToTypeRef) - <|> (do (e, v) <- tyD2 'RetThrows ty - RetThrows <$> typeToTypeRef e <*> typeToTypeRef v) - <|> RetStream <$> (tyD1 'RetStream ty >>= typeToTypeRef) - - typeToTypeRef :: Type -> Maybe TypeRef - typeToTypeRef ty - = (do (_,innerTy) <- tyD2 'FromSchema ty - return (FromTH innerTy)) - <|> (do (_,innerTy,_) <- tyD3 'FromRegistry ty - return (FromTH innerTy)) - -tyString :: Type -> Maybe String -tyString (SigT t _) - = tyString t -tyString (LitT (StrTyLit s)) - = Just s -tyString _ - = Nothing - -tyList :: Type -> Maybe [Type] -tyList (SigT t _) - = tyList t -tyList PromotedNilT - = Just [] -tyList (AppT (AppT PromotedConsT ty) rest) - = (ty :) <$> tyList rest -tyList _ = Nothing - -tyD0 :: Name -> Type -> Maybe () -tyD0 name (SigT t _) = tyD0 name t -tyD0 name (PromotedT c) - | c == name = Just () - | otherwise = Nothing -tyD0 _ _ = Nothing - -tyD1 :: Name -> Type -> Maybe Type -tyD1 name (SigT t _) = tyD1 name t -tyD1 name (AppT (PromotedT c) x) - | c == name = Just x - | otherwise = Nothing -tyD1 _ _ = Nothing - -tyD2 :: Name -> Type -> Maybe (Type, Type) -tyD2 name (SigT t _) = tyD2 name t -tyD2 name (AppT (AppT (PromotedT c) x) y) - | c == name = Just (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 - -tyD4 :: Name -> Type -> Maybe (Type, Type, Type, Type) -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 diff --git a/grpc/src/Mu/Client/GRpc/TyApps.hs b/grpc/src/Mu/Client/GRpc/TyApps.hs deleted file mode 100644 index d494bbf0..00000000 --- a/grpc/src/Mu/Client/GRpc/TyApps.hs +++ /dev/null @@ -1,39 +0,0 @@ -{-# language PolyKinds, DataKinds, GADTs, - MultiParamTypeClasses, FlexibleContexts, - ScopedTypeVariables, TypeApplications, - TypeOperators, AllowAmbiguousTypes #-} --- | Client for gRPC services defined using Mu 'Service' --- using 'TypeApplications' -module Mu.Client.GRpc.TyApps ( - -- * Initialization of the gRPC client - GrpcClient -, GrpcClientConfig -, grpcClientConfigSimple -, setupGrpcClient' - -- * Call methods from the gRPC service -, gRpcCall -, CompressMode(..) -, GRpcReply(..) -) where - -import Network.GRPC.Client (CompressMode(..)) -import Network.GRPC.Client.Helpers - -import Mu.Rpc -import Mu.Schema - -import Mu.Client.GRpc.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' --- 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' -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 diff --git a/grpc/src/Mu/GRpc/Shared.hs b/grpc/src/Mu/GRpc/Shared.hs deleted file mode 100644 index 72063d54..00000000 --- a/grpc/src/Mu/GRpc/Shared.hs +++ /dev/null @@ -1,43 +0,0 @@ -{-# language PolyKinds, DataKinds, - MultiParamTypeClasses, - ScopedTypeVariables, TypeApplications, - FlexibleInstances, FlexibleContexts, - UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints -fno-warn-orphans #-} -module Mu.GRpc.Shared where - -import Network.GRPC.HTTP2.Proto3Wire -import qualified Proto3.Wire.Encode as PBEnc -import qualified Proto3.Wire.Decode as PBDec - -import Mu.Rpc -import Mu.Schema - -import Mu.Schema.Adapter.ProtoBuf - -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) - -instance Proto3WireEncoder () where - proto3WireEncode _ = mempty - proto3WireDecode = return () - -class ProtoBufTypeRef (ref :: TypeRef) t where - fromProtoBufTypeRef :: Proxy ref -> PBDec.Parser PBDec.RawMessage t - toProtoBufTypeRef :: Proxy ref -> t -> PBEnc.MessageBuilder - -instance (HasProtoSchema sch sty t) - => ProtoBufTypeRef ('FromSchema sch sty) t where - 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 diff --git a/grpc/src/Mu/Server/GRpc.hs b/grpc/src/Mu/Server/GRpc.hs deleted file mode 100644 index 164b7007..00000000 --- a/grpc/src/Mu/Server/GRpc.hs +++ /dev/null @@ -1,210 +0,0 @@ -{-# language PolyKinds, DataKinds, GADTs, - MultiParamTypeClasses, - FlexibleInstances, FlexibleContexts, - UndecidableInstances, - TypeApplications, TypeOperators, - ScopedTypeVariables #-} --- | Execute a Mu 'Server' using gRPC as transport layer -module Mu.Server.GRpc ( - -- * Run a 'Server' directly - runGRpcApp -, runGRpcAppSettings, Settings -, runGRpcAppTLS, TLSSettings - -- * Convert a 'Server' into a WAI application -, 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.GRpc.Shared - --- | Run a Mu 'Server' on the given port. -runGRpcApp - :: ( KnownName name, KnownName (FindPackageName anns) - , GRpcMethodHandlers methods handlers ) - => Port -> ServerIO ('Service name anns methods) handlers - -> IO () -runGRpcApp port svr = run port (gRpcApp 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 - -> IO () -runGRpcAppSettings st svr = runSettings st (gRpcApp svr) - --- | Run a Mu 'Server' using the given 'TLSSettings' and 'Settings'. --- --- Go to 'Network.Wai.Handler.WarpTLS' to declare 'TLSSettings' --- and to 'Network.Wai.Handler.Warp' to declare 'Settings'. -runGRpcAppTLS - :: ( KnownName name, KnownName (FindPackageName anns) - , GRpcMethodHandlers methods handlers ) - => TLSSettings -> Settings - -> ServerIO ('Service name anns methods) handlers - -> IO () -runGRpcAppTLS tls st svr = runTLS tls st (gRpcApp svr) - --- | 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. -gRpcApp - :: (KnownName name, KnownName (FindPackageName anns), GRpcMethodHandlers methods handlers) - => ServerIO ('Service name anns methods) handlers - -> Application -gRpcApp svr = Wai.grpcApp [uncompressed, gzip] - (gRpcServiceHandlers svr) - -gRpcServiceHandlers - :: forall name anns methods handlers. - (KnownName name, KnownName (FindPackageName anns), GRpcMethodHandlers methods handlers) - => ServerIO ('Service name anns methods) handlers - -> [ServiceHandler] -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] - -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 - where methodName = BS.pack (nameVal (Proxy @name)) - -class GRpcMethodHandler args r h where - gRpcMethodHandler :: Proxy args -> Proxy r -> RPC -> h -> ServiceHandler - -instance GRpcMethodHandler '[ ] 'RetNothing (IO ()) where - gRpcMethodHandler _ _ rpc h - = unary @_ @() @() rpc (\_ _ -> h) - -instance (ProtoBufTypeRef rref r) - => GRpcMethodHandler '[ ] ('RetSingle rref) (IO r) where - gRpcMethodHandler _ _ rpc h - = unary @_ @() @(ViaProtoBufTypeRef rref r) - rpc (\_ _ -> ViaProtoBufTypeRef <$> h) - -instance (ProtoBufTypeRef vref v) - => GRpcMethodHandler '[ 'ArgSingle vref ] 'RetNothing (v -> IO ()) where - gRpcMethodHandler _ _ rpc h - = unary @_ @(ViaProtoBufTypeRef vref v) @() - rpc (\_ -> h . unViaProtoBufTypeRef) - -instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) - => GRpcMethodHandler '[ 'ArgSingle vref ] ('RetSingle rref) - (v -> IO r) where - gRpcMethodHandler _ _ rpc h - = unary @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) - rpc (\_ -> (ViaProtoBufTypeRef <$>) . h . unViaProtoBufTypeRef) - -instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r) - => GRpcMethodHandler '[ 'ArgStream vref ] ('RetSingle rref) - (ConduitT () v IO () -> IO 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) ()) - cstream _ = do - -- Create a new TMChan - chan <- newTMChanIO :: IO (TMChan v) - let producer = sourceTMChan @IO chan - -- Start executing the handler in another thread - promise <- async (ViaProtoBufTypeRef <$> h producer) - -- Build the actual handler - let cstreamHandler _ (ViaProtoBufTypeRef 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) - => GRpcMethodHandler '[ 'ArgSingle vref ] ('RetStream rref) - (v -> ConduitT r Void IO () -> IO ()) where - gRpcMethodHandler _ _ rpc h - = serverStream @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) - rpc sstream - where sstream :: req -> ViaProtoBufTypeRef vref v - -> IO ((), ServerStream (ViaProtoBufTypeRef rref r) ()) - sstream _ (ViaProtoBufTypeRef v) = do - -- Variable to connect input and output - var <- newEmptyTMVarIO :: IO (TMVar (Maybe r)) - -- Start executing the handler - promise <- async (ViaProtoBufTypeRef <$> h v (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, ProtoBufTypeRef rref r) - => GRpcMethodHandler '[ 'ArgStream vref ] ('RetStream rref) - (ConduitT () v IO () -> ConduitT r Void IO () -> IO ()) where - gRpcMethodHandler _ _ rpc h - = generalStream @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) - rpc bdstream - where bdstream :: req -> IO ( (), IncomingStream (ViaProtoBufTypeRef vref v) () - , (), OutgoingStream (ViaProtoBufTypeRef rref r) () ) - bdstream _ = do - -- Create a new TMChan and a new variable - chan <- newTMChanIO :: IO (TMChan v) - let producer = sourceTMChan @IO chan - var <- newEmptyTMVarIO :: IO (TMVar (Maybe r)) - -- Start executing the handler - promise <- async (h producer (toTMVarConduit var)) - -- Build the actual handler - let cstreamHandler _ (ViaProtoBufTypeRef newInput) - = atomically (writeTMChan chan newInput) - cstreamFinalizer _ - = atomically (closeTMChan chan) >> wait promise - readNext _ - = do nextOutput <- atomically $ tryTakeTMVar var - case nextOutput of - Just (Just o) -> - return $ Just ((), ViaProtoBufTypeRef o) - Just Nothing -> do - cancel promise - return Nothing - Nothing -> -- no new elements to output - readNext () - 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 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/instrumentation/prometheus/LICENSE b/instrumentation/prometheus/LICENSE new file mode 100644 index 00000000..ffeb95d1 --- /dev/null +++ b/instrumentation/prometheus/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/instrumentation/prometheus/hie.yaml b/instrumentation/prometheus/hie.yaml new file mode 100644 index 00000000..a1147895 --- /dev/null +++ b/instrumentation/prometheus/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-prometheus:lib" } } diff --git a/instrumentation/prometheus/mu-prometheus.cabal b/instrumentation/prometheus/mu-prometheus.cabal new file mode 100644 index 00000000..97d5c0a0 --- /dev/null +++ b/instrumentation/prometheus/mu-prometheus.cabal @@ -0,0 +1,34 @@ +name: mu-prometheus +version: 0.5.0.0 +synopsis: Metrics support for Mu using Prometheus +description: Get metrics of your running Mu servers using Prometheus +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2020 +category: Network +build-type: Simple +cabal-version: >=1.10 +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.Instrumentation.Prometheus + build-depends: + base >=4.12 && <5 + , lifted-base >=0.2 && <0.3 + , monad-control >1 && <2 + , mu-rpc >=0.5 && <0.6 + , prometheus-client >1 && <2 + , text >=1.2 && <2 + , wai >=3.2 && <4 + , wai-middleware-prometheus >1 && <2 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances diff --git a/instrumentation/prometheus/src/Mu/Instrumentation/Prometheus.hs b/instrumentation/prometheus/src/Mu/Instrumentation/Prometheus.hs new file mode 100644 index 00000000..59c10ce1 --- /dev/null +++ b/instrumentation/prometheus/src/Mu/Instrumentation/Prometheus.hs @@ -0,0 +1,74 @@ +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +module Mu.Instrumentation.Prometheus ( + initPrometheus +, prometheus +, prometheusWai +) where + +import Control.Concurrent.MVar.Lifted +import Control.Exception.Lifted +import Control.Monad.Trans.Control +import Data.Text (Text) +import Mu.Rpc +import Mu.Server +import Network.Wai +import qualified Network.Wai.Middleware.Prometheus as Wai +import Prometheus + +-- Taken from https://github.com/higherkindness/mu-scala/blob/master/modules/metrics/prometheus/src/main/scala/higherkindness/mu/rpc/prometheus/PrometheusMetrics.scala + +data MuMetrics + = MuMetrics { + activeCalls :: Gauge + , messagesSent :: Vector Label2 Counter + , messagesReceived :: Vector Label2 Counter + , callsTotal :: Vector Label2 Histogram + } + +initPrometheus :: Text -> IO MuMetrics +initPrometheus prefix = + MuMetrics <$> register (gauge $ Info (prefix <> "_active_calls") "") + <*> register (vector ("service", "method") + $ counter $ Info (prefix <> "_messages_sent") "") + <*> register (vector ("service", "method") + $ counter $ Info (prefix <> "_messages_received") "") + <*> register (vector ("service", "method") + $ histogram (Info (prefix <> "_calls_total") "") + defaultBuckets) + +prometheus :: (MonadBaseControl IO m, MonadMonitor m) + => MuMetrics -> ServerT chn info p m topHs -> ServerT chn info p m topHs +prometheus m = wrapServer (prometheusMetrics m) + +prometheusMetrics :: forall m a info. (MonadBaseControl IO m, MonadMonitor m) + => MuMetrics -> RpcInfo info -> m a -> m a +prometheusMetrics metrics NoRpcInfo run = do + incGauge (activeCalls metrics) + run `finally` decGauge (activeCalls metrics) +prometheusMetrics metrics (RpcInfo _pkg ss mm _ _) run = do + let sname' = case ss of + Service sname _ -> sname + OneOf sname _ -> sname + mname' = case mm of + Just (Method mname _ _) -> mname + Nothing -> "" + incGauge (activeCalls metrics) + withLabel (messagesReceived metrics) (sname', mname') incCounter + ( do -- We are forced to use a MVar because 'withLabel' only allows IO () + r <- liftBaseWith $ \runInIO -> do + result :: MVar (StM m a) <- newEmptyMVar + withLabel (callsTotal metrics) (sname', mname') $ \h -> + h `observeDuration` (runInIO run >>= putMVar result) + takeMVar result + x <- restoreM r + withLabel (messagesSent metrics) (sname', mname') incCounter + pure x ) + `finally` decGauge (activeCalls metrics) + +prometheusWai :: [Text] -> Middleware +prometheusWai endpoint + = Wai.prometheus (Wai.PrometheusSettings endpoint False False) diff --git a/instrumentation/tracing/LICENSE b/instrumentation/tracing/LICENSE new file mode 100644 index 00000000..ffeb95d1 --- /dev/null +++ b/instrumentation/tracing/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/instrumentation/tracing/hie.yaml b/instrumentation/tracing/hie.yaml new file mode 100644 index 00000000..283b0aab --- /dev/null +++ b/instrumentation/tracing/hie.yaml @@ -0,0 +1 @@ +cradle: { stack: { component: "mu-tracing:lib" } } diff --git a/instrumentation/tracing/mu-tracing.cabal b/instrumentation/tracing/mu-tracing.cabal new file mode 100644 index 00000000..ead588bd --- /dev/null +++ b/instrumentation/tracing/mu-tracing.cabal @@ -0,0 +1,31 @@ +name: mu-tracing +version: 0.4.0.0 +synopsis: Tracing support for Mu +description: Generate distributed traces for Mu services +license: Apache-2.0 +license-file: LICENSE +author: Alejandro Serrano +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2020 +category: Network +build-type: Simple +cabal-version: >=1.10 +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.Instrumentation.Tracing + build-depends: + base >=4.12 && <5 + , containers >=0.6 && <0.7 + , mu-rpc >=0.4.0 + , text >=1.2 && <2 + , tracing-control >=0.0.6 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances diff --git a/instrumentation/tracing/src/Mu/Instrumentation/Tracing.hs b/instrumentation/tracing/src/Mu/Instrumentation/Tracing.hs new file mode 100644 index 00000000..19d2f834 --- /dev/null +++ b/instrumentation/tracing/src/Mu/Instrumentation/Tracing.hs @@ -0,0 +1,80 @@ +{-# language FlexibleInstances #-} +{-# language MultiParamTypeClasses #-} +{-# language OverloadedStrings #-} +{-# language PolyKinds #-} +{-# language UndecidableInstances #-} +{-# language ViewPatterns #-} +{-| +Description : Distributed tracing for Mu + +This module injects distributed tracing +for Mu servers. Currently it only supports +Zipkin as backend. + +In order to use this module, you need to +follow these steps: + +1. Establish a connection with 'newZipkin'. +2. Wrap the server using 'zipkin', giving + information for the root. +3. Run the server using the transformer version + of your protocol, like |grpcAppTrans|. +-} +module Mu.Instrumentation.Tracing ( + -- * Distributed tracing + MuTracing(..) +, zipkin +, runZipkin + -- ** Establish connection +, newZipkin +, defaultZipkinSettings +, Settings(..) + -- * Useful re-exports +, module Monitor.Tracing +) where + +import Control.Applicative ((<|>)) +import Control.Monad.IO.Class +import Control.Monad.Trace +import Control.Monad.Trace.Class +import qualified Data.Map.Strict as M +import Data.Text +import Monitor.Tracing +import Monitor.Tracing.Zipkin +import Mu.Rpc +import Mu.Server + +data MuTracing + = MuTracing { + samplingPolicy :: SamplingPolicy + , rootName :: Text + } + +-- | Runs with a given 'Zipkin' connection. +-- You can create one with 'newZipkin'. +runZipkin :: Zipkin -> TraceT m a -> m a +runZipkin = flip run + +-- | Create a new connection to 'Zipkin'. +newZipkin :: Settings -> IO Zipkin +newZipkin = new + +defaultZipkinSettings :: Settings +defaultZipkinSettings = defaultSettings + +-- | Wraps a server to do distributed tracing +-- using 'Zipkin' as backend. +zipkin :: (MonadIO m, MonadTrace m) + => MuTracing -> ServerT chn i p m topHs -> ServerT chn i p m topHs +zipkin m = wrapServer (zipkinTracing m) + +zipkinTracing :: (MonadIO m, MonadTrace m) + => MuTracing -> RpcInfo i -> m a -> m a +zipkinTracing zpk NoRpcInfo h = + rootSpan (samplingPolicy zpk) (rootName zpk) h +zipkinTracing zpk (RpcInfo _ _ _ (M.fromList -> hdrs) _) h = + case getB3 of + Nothing -> rootSpan (samplingPolicy zpk) (rootName zpk) h + Just spn -> serverSpan spn h + where getB3 = (b3FromHeaderValue =<< M.lookup "b3" hdrs) + <|> b3FromHeaders hdrs diff --git a/python-test.nix b/python-test.nix new file mode 100644 index 00000000..37c2bda8 --- /dev/null +++ b/python-test.nix @@ -0,0 +1,34 @@ +self: pkgs: +with pkgs; +let + python3-packages = python-packages: with python-packages; [ + avro + ]; + python3 = pkgs.python36Packages.python.withPackages python3-packages; + python2-packages = python-packages: with python-packages; [ + protobuf + ]; + python2 = pkgs.python27Packages.python.withPackages python2-packages; + stack = pkgs.stack; +in { + test-schema = writeShellScriptBin "test-schema.sh" '' + #!/bin/sh + echo "BUILDING" + ${stack}/bin/stack build mu-avro mu-protobuf + mkdir -p dist + + echo "\nAVRO\n====\n" + echo "python/generate" + ${python3}/bin/python adapter/avro/test/avro/generate.py adapter/avro/test/avro/example.avsc dist/avro-python.avro + ${stack}/bin/stack test-avro dist/avro-haskell.avro dist/avro-python.avro + echo "ptyhon/consume" + ${python3}/bin/python adapter/avro/test/avro/consume.py adapter/avro/test/avro/example.avsc dist/avro-haskell.avro + + echo "\nPROTOBUF\n========\n" + echo "python/generate" + ${python2}/bin/python adapter/protobuf/test/protobuf/generate.py dist/protobuf-python.pbuf + ${stack}/bin/stack exec test-protobuf dist/protobuf-haskell.pbuf dist/protobuf-python.pbuf + echo "python/consume" + ${python2}/bin/python adapter/protobuf/test/protobuf/consume.py dist/protobuf-haskell.pbuf + ''; +} diff --git a/release-package.sh b/release-package.sh new file mode 100755 index 00000000..d08ea470 --- /dev/null +++ b/release-package.sh @@ -0,0 +1,9 @@ +#!/bin/sh + +cabal sdist ${1} +cabal upload dist-newstyle/sdist/${1}-${2}.tar.gz +echo "Check that it has been published correctly, and press Enter" +read +cabal upload --publish dist-newstyle/sdist/${1}-${2}.tar.gz +cabal v2-haddock --builddir="dist-newstyle" --haddock-for-hackage --enable-doc ${1} +cabal upload -d --publish dist-newstyle/${1}-${2}-docs.tar.gz diff --git a/rpc/README.md b/rpc/README.md deleted file mode 100644 index 24b7e317..00000000 --- a/rpc/README.md +++ /dev/null @@ -1,169 +0,0 @@ -# `mu-rpc`: protocol-independent declaration of 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. - -## Importing the schema and the service - -Let us begin with an example taken from the [gRPC Quickstart Guide](https://grpc.io/docs/quickstart/): - -```java -package helloworld; - -service Greeter { - rpc SayHello (HelloRequest) returns (HelloReply) {} -} - -message HelloRequest { string name = 1; } -message HelloReply { string message = 1; } -``` - -As with our sibling `mu-schema` library, we use type-level techniques to represent the messages and services. Since the mapping from such a Protocol Buffers file into the require types is quite direct, you can just import them using one line (in addition to enabling the `TemplateHaskell` extension): - -```haskell -{-# language TemplateHaskell #-} - -$(grpc "QuickstartSchema" (const "QuickstartService") "quickstart.proto") -``` - -The `grpc` function takes three arguments: - -* The first one defines the name of the schema type which is going to be generated, and which includes the declaration of all the messages in the file. -* The second one declares how to map the name of *each* service in the file (since more than one may appear) to the name of a Haskell type. In this case, we declare a constant name "QuickstartService". But we could also use `(++ "Service")`, which would then give `GreeterService` as name for the only service in the file. -* The third argument is the route to the file *with respect to the project root*. - -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. - -```haskell -{-# language PolyKinds, DataKinds #-} -{-# language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} -{-# language DeriveGeneric, DeriveAnyClass #-} - -import qualified Data.Text as T -import GHC.Generics -import Mu.Schema - --- GENERATED -type QuickstartSchema - = '[ 'DRecord "HelloRequest" '[] - '[ 'FieldDef "name" '[ ProtoBufId 1 ] ('TPrimitive T.Text) ] - , 'DRecord "HelloResponse" '[] - '[ 'FieldDef "message" '[ ProtoBufId 1 ] ('TPrimitive T.Text) ] - ] - --- 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") -``` - -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. - -```haskell -import Mu.Rpc - --- GENERATED -type QuickstartService - = 'Service "Greeter" - '[ 'Method "SayHello" - '[ '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: - -* 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`. - -Note that depending on the concrete implementation you use to run the server, one or more of these choices may not be available. For example, gRPC only supports one argument and return value, either single or streaming, but not exceptions. - -## 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`: - -```haskell -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. - -```haskell -{-# language PartialTypeSignatures #-} - -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 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/rpc/Setup.hs b/rpc/Setup.hs deleted file mode 100644 index 9a994af6..00000000 --- a/rpc/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/rpc/mu-rpc.cabal b/rpc/mu-rpc.cabal deleted file mode 100644 index b54053e3..00000000 --- a/rpc/mu-rpc.cabal +++ /dev/null @@ -1,32 +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-rpc -version: 0.1.0.0 -synopsis: Protocol-independent declaration of services and servers --- 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: 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 - 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/rpc/src/Mu/Rpc.hs deleted file mode 100644 index 6e0beeb9..00000000 --- a/rpc/src/Mu/Rpc.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# language DataKinds, PolyKinds, - GADTs, ExistentialQuantification, - TypeFamilies, ConstraintKinds, - TypeOperators, - UndecidableInstances #-} --- | Protocol-independent declaration of services -module Mu.Rpc ( - Service', Service(..) -, Annotation, Package, FindPackageName -, Method(..), (:-->:) -, TypeRef(..), Argument(..), Return(..) -) where - -import Data.Kind -import GHC.TypeLits -import qualified Language.Haskell.TH as TH - -import Mu.Schema -import Mu.Schema.Registry - -type Service' = Service Symbol Symbol - --- | A service is a set of methods. -data Service serviceName methodName - = Service serviceName [Annotation] [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 - 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 - --- | Look up a method in a service definition using its name. --- Useful to declare handlers like @HandlerIO (MyService :-->: "MyMethod")@. -type family (:-->:) (s :: Service snm mnm) (m :: mnm) :: Method mnm where - 'Service sname anns methods :-->: m = LookupMethod methods m - -type family LookupMethod (s :: [Method mnm]) (m :: snm) :: Method snm where - LookupMethod '[] m = TypeError ('Text "could not find method " ':<>: 'ShowType m) - LookupMethod ('Method m anns args r ': ms) m = 'Method m anns args r - LookupMethod (other ': ms) m = LookupMethod ms m - --- | Defines how to handle the type -data TypeRef where - FromSchema :: Schema typeName fieldName -> typeName -> TypeRef - -- | Registry subject, type to convert to, and preferred serialization version - FromRegistry :: Registry -> Type -> Nat -> TypeRef - -- | To be used only during TH generation! - FromTH :: TH.Type -> TypeRef - --- | Defines the way in which arguments are handled. -data Argument where - -- | Use a single value. - ArgSingle :: TypeRef -> Argument - -- | Consume a stream of values. - ArgStream :: TypeRef -> Argument - --- | Defines the different possibilities for returning --- information from a method. -data Return where - -- | Fire and forget. - RetNothing :: Return - -- | Return a single value. - RetSingle :: TypeRef -> Return - -- | Return a value or an error - -- (this can be found in Avro IDL). - RetThrows :: TypeRef -> TypeRef -> Return - -- | Return a stream of values - -- (this can be found in gRPC). - RetStream :: TypeRef -> Return \ No newline at end of file diff --git a/rpc/src/Mu/Rpc/Examples.hs b/rpc/src/Mu/Rpc/Examples.hs deleted file mode 100644 index 3989001a..00000000 --- a/rpc/src/Mu/Rpc/Examples.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# language PolyKinds, DataKinds, GADTs, - MultiParamTypeClasses, - FlexibleInstances, OverloadedStrings, - DeriveGeneric, DeriveAnyClass, TypeOperators, - PartialTypeSignatures, TypeFamilies #-} -{-# 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 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/ - -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) ] - ] - -type QuickStartService - = 'Service "Greeter" '[Package "helloworld"] - '[ 'Method "SayHello" '[] - '[ 'ArgSingle ('FromSchema QuickstartSchema "HelloRequest") ] - ('RetSingle ('FromSchema QuickstartSchema "HelloResponse")) - , 'Method "SayHi" '[] - '[ 'ArgSingle ('FromSchema QuickstartSchema "HiRequest")] - ('RetStream ('FromSchema QuickstartSchema "HelloResponse")) - , 'Method "SayManyHellos" '[] - '[ 'ArgStream ('FromSchema QuickstartSchema "HelloRequest")] - ('RetStream ('FromSchema 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") - -quickstartServer :: ServerIO QuickStartService _ -quickstartServer - = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0) - where sayHello :: HelloRequest -> IO HelloResponse - sayHello (HelloRequest nm) - = return (HelloResponse ("hi, " <> nm)) - sayHi :: HiRequest -> ConduitT HelloResponse Void IO () -> IO () - sayHi (HiRequest n) sink - = runConduit $ C.replicate n (HelloResponse "hi!") .| sink - sayManyHellos :: ConduitT () HelloRequest IO () - -> ConduitT HelloResponse Void IO () - -> IO () - sayManyHellos source sink - = runConduit $ source .| C.mapM sayHello .| sink \ No newline at end of file diff --git a/rpc/src/Mu/Rpc/Quasi.hs b/rpc/src/Mu/Rpc/Quasi.hs deleted file mode 100644 index 90465d70..00000000 --- a/rpc/src/Mu/Rpc/Quasi.hs +++ /dev/null @@ -1,78 +0,0 @@ -{-# language TemplateHaskell, DataKinds, OverloadedStrings #-} --- | Read a @.proto@ file as a 'Service' -module Mu.Rpc.Quasi ( - grpc -) 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 Mu.Schema.Quasi -import Mu.Rpc - --- | Reads a @.proto@ file and generates: --- * A 'Schema' with all the message types, using the --- name given as first argument. --- * A 'Service' declaration for each service in the file, --- where the name is obtained by applying the function --- given as second argument to the name in the file. -grpc :: String -> (String -> String) -> FilePath -> Q [Dec] -grpc schemaName servicePrefix fp - = do r <- liftIO $ parseProtoBufFile 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) - -pbServiceDeclToDec :: (String -> String) -> Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Dec -pbServiceDeclToDec servicePrefix pkg schema srv@(P.Service nm _ _) - = tySynD (mkName $ servicePrefix $ T.unpack nm) [] - (pbServiceDeclToType pkg schema srv) - -pbServiceDeclToType :: Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Type -pbServiceDeclToType pkg schema (P.Service nm _ methods) - = [t| 'Service $(textToStrLit nm) $(pkgType pkg) - $(typesToList <$> mapM (pbMethodToType schema) methods) |] - where - pkgType Nothing = [t| '[] |] - pkgType (Just p) = [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |] - -pbMethodToType :: Name -> P.Method -> Q Type -pbMethodToType s (P.Method nm vr v rr r _) - = [t| 'Method $(textToStrLit nm) '[] - $(argToType vr v) $(retToType rr r) |] - where - argToType P.Single (P.TOther ["google","protobuf","Empty"]) - = [t| '[ ] |] - argToType P.Single (P.TOther a) - = [t| '[ 'ArgSingle ('FromSchema $(schemaTy s) $(textToStrLit (last a))) ] |] - argToType P.Stream (P.TOther a) - = [t| '[ 'ArgStream ('FromSchema $(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))) |] - retToType P.Stream (P.TOther a) - = [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 - -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 \ No newline at end of file diff --git a/rpc/src/Mu/Server.hs b/rpc/src/Mu/Server.hs deleted file mode 100644 index 3bd2f870..00000000 --- a/rpc/src/Mu/Server.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# language DataKinds, PolyKinds, - GADTs, TypeFamilies, - ExistentialQuantification, - MultiParamTypeClasses, - FlexibleInstances, - UndecidableInstances, - TypeOperators, - ConstraintKinds, - RankNTypes #-} --- | 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. -module Mu.Server ( - -- * Servers and handlers - ServerIO, ServerT(..) -, HandlersIO, HandlersT(..) -) where - -import Data.Conduit -import Data.Kind - -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 -type ServerIO service = ServerT service IO - -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 - --- Define a relation for handling -class Handles (args :: [Argument]) (ret :: Return) - (m :: Type -> Type) (h :: Type) -class HandlesRef (ref :: TypeRef) (t :: Type) - --- Type references -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)) - => Handles ('ArgSingle ref ': args) ret m handler -instance (HandlesRef ref t, Handles args ret m h, handler ~ (ConduitT () t IO () -> 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)) - => Handles '[] ('RetThrows eref vref) m handler -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 diff --git a/run-docs.sh b/run-docs.sh new file mode 100755 index 00000000..cebdba7f --- /dev/null +++ b/run-docs.sh @@ -0,0 +1,5 @@ +#!/bin/sh + +bundle config set path 'vendor/bundle' +bundle install --gemfile docs/Gemfile +BUNDLE_GEMFILE=./docs/Gemfile bundle exec jekyll serve -s docs -b /mu-haskell diff --git a/schema/README.md b/schema/README.md deleted file mode 100644 index 7313cb0e..00000000 --- a/schema/README.md +++ /dev/null @@ -1,151 +0,0 @@ -# `mu-schema`: format-independent schemas for serialization - -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, -* 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`. - -## Records and enumerations - -Here is a simple schema which defines the schema types `gender`, `address`, and `person`: - -```haskell -{-# language PolyKinds, DataKinds #-} - -import Mu.Schema -import qualified Data.Text as T - -type ExampleSchema - = '[ '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") ] - ] -``` - -As you can see, a *schema* is just a list of schema types. Each of these types has a *name* and can either be an enumeration or a record. - -* 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`. - * `TSchematic` to reference another type *in the same schema* by name. - * `TOption`, `TList`, `TMap`, and `TUnion` are combinators for the field types. - -Note that GHC requires all of `DEnum`, `DRecord`, `FieldDef`, and so forth to be prefixed by a quote sign `'`. This declares that we are working with [promoted types](https://downloads.haskell.org/~ghc/latest/docs/html/users_guide/glasgow_exts.html#datatype-promotion) (you do not have to understand what a promoted type is, but you need to remember to use the quote sign). - -### Defining a schema using Protocol Buffers - -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 `|]`. - -```haskell -{-# language QuasiQuotes #-} - -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. - -```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; -} -|] -``` - -## 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. - -```haskell -{-# language MultiParamTypeClasses, TypeSynonymInstances, FlexibleInstances #-} -{-# language DeriveGeneric, DeriveAnyClass #-} - -import GHC.Generics - -data Address - = Address { postcode :: T.Text - , country :: T.Text } - deriving (Eq, Show, Generic) - deriving (HasSchema 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: - -```haskell - deriving (HasSchema 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: - -```haskell -{-# language TypeFamilies #-} - -data Gender = Male | Female | NonBinary - -instance HasSchema ExampleSchema "gender" Gender where - type FieldMapping ExampleSchema "gender" Gender - = '[ "Male" ':-> "male" - , "Female" ':-> "female" - , "NonBinary" ':-> "nb" ] -``` - -### 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: - -```haskell -import Mu.Schema.Adapter.ProtoBuf - -type ExampleSchema - = '[ ... - , 'DRecord "address" - '[ 'FieldDef "postcode" '[ ProtoBufId 1 ] ('TPrimitive T.Text) - , 'FieldDef "country" '[ ProtoBufId 2 ] ('TPrimitive T.Text) ] - , ... ] -``` - -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/schema/Setup.hs b/schema/Setup.hs deleted file mode 100644 index 9a994af6..00000000 --- a/schema/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/schema/mu-schema.cabal b/schema/mu-schema.cabal deleted file mode 100644 index 58b5c139..00000000 --- a/schema/mu-schema.cabal +++ /dev/null @@ -1,61 +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-schema -version: 0.1.0.0 -synopsis: Format-independent schemas for serialization --- 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: 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 - -- 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 - 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 diff --git a/schema/src/Mu/Schema.hs b/schema/src/Mu/Schema.hs deleted file mode 100644 index 18770239..00000000 --- a/schema/src/Mu/Schema.hs +++ /dev/null @@ -1,27 +0,0 @@ -{-# language DataKinds #-} --- | Schemas for Mu microservices -module Mu.Schema ( - -- * Quasi-quoters for schemas - protobuf, protobufFile - -- * Schema definition -, Schema, Schema' -, Annotation, KnownName(..) -, TypeDef, TypeDefB(..) -, ChoiceDef(..) -, FieldDef, FieldDefB(..) -, FieldType, FieldTypeB(..) - -- ** Lookup type in schema -, (:/:) - -- * Interpretation of schemas -, Term(..), Field(..), FieldValue(..) -, NS(..), NP(..), Proxy(..) - -- * Conversion from types to schemas -, WithSchema(..), HasSchema(..), toSchema', fromSchema' - -- ** Mappings between fields -, Mapping(..), Mappings, MappingRight, MappingLeft -) where - -import Mu.Schema.Definition -import Mu.Schema.Interpretation -import Mu.Schema.Class -import Mu.Schema.Quasi \ No newline at end of file diff --git a/schema/src/Mu/Schema/Adapter/Avro.hs b/schema/src/Mu/Schema/Adapter/Avro.hs deleted file mode 100644 index 7ea960ce..00000000 --- a/schema/src/Mu/Schema/Adapter/Avro.hs +++ /dev/null @@ -1,309 +0,0 @@ -{-# language PolyKinds, DataKinds, GADTs, - FlexibleInstances, FlexibleContexts, - TypeApplications, TypeOperators, - ScopedTypeVariables, RankNTypes, - MultiParamTypeClasses, - UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Mu.Schema.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 --- '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 Mu.Schema -import qualified Mu.Schema.Interpretation.Schemaless as SLess - -instance SLess.ToSchemalessTerm (AVal.Value t) where - toSchemalessTerm (AVal.Record _ r) - = SLess.TRecord $ map (\(k,v) -> SLess.Field k (SLess.toSchemalessValue v)) - $ HM.toList r - toSchemalessTerm (AVal.Enum _ i _) - = SLess.TEnum i - toSchemalessTerm (AVal.Union _ _ v) - = SLess.toSchemalessTerm v - toSchemalessTerm v = SLess.TSimple (SLess.toSchemalessValue v) - -instance SLess.ToSchemalessValue (AVal.Value t) where - toSchemalessValue AVal.Null = SLess.FNull - toSchemalessValue (AVal.Boolean b) = SLess.FPrimitive b - toSchemalessValue (AVal.Int b) = SLess.FPrimitive b - toSchemalessValue (AVal.Long b) = SLess.FPrimitive b - toSchemalessValue (AVal.Float b) = SLess.FPrimitive b - toSchemalessValue (AVal.Double b) = SLess.FPrimitive b - toSchemalessValue (AVal.String b) = SLess.FPrimitive b - toSchemalessValue (AVal.Fixed _ b) = SLess.FPrimitive b - toSchemalessValue (AVal.Bytes b) = SLess.FPrimitive b - toSchemalessValue (AVal.Array v) - = SLess.FList $ map SLess.toSchemalessValue $ V.toList v - toSchemalessValue (AVal.Map hm) - = SLess.FMap $ M.fromList - $ map (SLess.FPrimitive *** SLess.toSchemalessValue) - $ HM.toList hm - toSchemalessValue (AVal.Union _ _ v) - = SLess.toSchemalessValue v - toSchemalessValue r@(AVal.Record _ _) - = SLess.FSchematic (SLess.toSchemalessTerm r) - toSchemalessValue e@AVal.Enum {} - = SLess.FSchematic (SLess.toSchemalessTerm e) - -instance HasAvroSchemas sch sch - => A.HasAvroSchema (WithSchema 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 - 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)) - (unTagged $ A.schema @(Term sch (sch :/: sty))) - (A.toAvro (toSchema' @sch 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) - => HasAvroSchemas r (d ': ds) where - schemas pr _ = V.cons thisSchema (schemas pr (Proxy @ds)) - where thisSchema = unTagged $ A.schema @(Term r d) - --- HasAvroSchema instances - -instance (KnownName name, HasAvroSchemaFields sch args) - => A.HasAvroSchema (Term sch ('DRecord name anns 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 - 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 sch 'TNull) where - schema = Tagged ASch.Null -instance A.HasAvroSchema t - => A.HasAvroSchema (FieldValue sch ('TPrimitive t)) where - schema = coerce $ A.schema @t -instance KnownName t - => A.HasAvroSchema (FieldValue 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] --- 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)) - -class HasAvroSchemaUnion (f :: k -> *) (xs :: [k]) where - schemaU :: Proxy f -> Proxy xs -> NonEmpty ASch.Type -instance A.HasAvroSchema (f v) => HasAvroSchemaUnion f '[v] where - schemaU _ _ = vSchema :| [] - where vSchema = unTagged (A.schema @(f v)) -instance (A.HasAvroSchema (f x), HasAvroSchemaUnion f (y ': zs)) - => HasAvroSchemaUnion f (x ': y ': zs) where - schemaU p _ = xSchema :| NonEmptyList.toList yzsSchema - where xSchema = unTagged (A.schema @(f x)) - yzsSchema = schemaU p (Proxy @(y ': zs)) - -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) - => HasAvroSchemaFields sch ('FieldDef name anns t ': fs) where - schemaF psch _ = schemaThis : schemaF psch (Proxy @fs) - where fieldName = nameText (Proxy @name) - schemaT = unTagged $ A.schema @(FieldValue sch t) - schemaThis = ASch.Field fieldName [] Nothing Nothing schemaT Nothing - -class HasAvroSchemaEnum (fs :: [ChoiceDef fn]) where - schemaE :: Proxy fs -> [T.Text] -instance HasAvroSchemaEnum '[] where - schemaE _ = [] -instance (KnownName name, HasAvroSchemaEnum fs) - => HasAvroSchemaEnum ('ChoiceDef name anns ': 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 - 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 - 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 - fromAvro v = TSimple <$> A.fromAvro v - -instance A.FromAvro (FieldValue 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 - fromAvro v = FPrimitive <$> A.fromAvro v -instance (KnownName t, A.FromAvro (Term sch (sch :/: t))) - => A.FromAvro (FieldValue 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 - 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 - fromAvro v = FOption <$> A.fromAvro v -instance A.FromAvro (FieldValue sch t) - => A.FromAvro (FieldValue 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 - fromAvro v = FMap . M.mapKeys FPrimitive <$> A.fromAvro v -instance A.FromAvro (FieldValue sch v) - => A.FromAvro (FieldValue sch ('TMap ('TPrimitive String) v)) where - fromAvro v = FMap . M.mapKeys (FPrimitive . T.unpack) <$> A.fromAvro v - -class FromAvroEnum (vs :: [ChoiceDef fn]) where - fromAvroEnum :: AVal.Value ASch.Type -> Int -> A.Result (NS Proxy vs) -instance FromAvroEnum '[] where - fromAvroEnum v _ = A.badValue v "element not found" -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 - fromAvroU _ v = A.badValue v "union choice not found" -instance (A.FromAvro (FieldValue sch u), FromAvroUnion sch us) - => FromAvroUnion sch (u ': us) where - fromAvroU branch v - | ASch.matches branch (unTagged (A.schema @(FieldValue 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 - fromAvroF _ = return Nil -instance (KnownName name, A.FromAvro (FieldValue sch t), FromAvroFields sch fs) - => FromAvroFields sch ('FieldDef name anns 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 - where fieldName = nameText (Proxy @name) - --- ToAvro instances - -instance (KnownName name, HasAvroSchemaFields sch args, ToAvroFields sch args) - => A.ToAvro (Term sch ('DRecord name anns args)) where - toAvro (TRecord fields) = AVal.Record wholeSchema (toAvroF fields) - where wholeSchema = unTagged (A.schema @(Term sch ('DRecord name anns args))) -instance (KnownName name, HasAvroSchemaEnum choices, ToAvroEnum choices) - => A.ToAvro (Term sch ('DEnum name anns choices)) where - toAvro (TEnum n) = AVal.Enum wholeSchema choice text - where wholeSchema = unTagged (A.schema @(Term sch ('DEnum name anns choices))) - (choice, text) = toAvroE n -instance A.ToAvro (FieldValue sch t) - => A.ToAvro (Term sch ('DSimple t)) where - toAvro (TSimple v) = A.toAvro v - -instance A.ToAvro (FieldValue sch 'TNull) where - toAvro FNull = AVal.Null -instance A.ToAvro t => A.ToAvro (FieldValue 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 - toAvro (FSchematic v) = A.toAvro v -instance forall sch choices. - (HasAvroSchemaUnion (FieldValue sch) choices, ToAvroUnion sch choices) - => A.ToAvro (FieldValue sch ('TUnion choices)) where - 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 -instance A.ToAvro (FieldValue sch t) - => A.ToAvro (FieldValue sch ('TOption t)) where - toAvro (FOption v) = A.toAvro v -instance A.ToAvro (FieldValue sch t) - => A.ToAvro (FieldValue 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 - 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 - 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) -instance ToAvroUnion sch '[] where - toAvroU _ = error "ToAvro in an empty union" -instance forall sch u us. - (A.ToAvro (FieldValue sch u), ToAvroUnion sch us) - => ToAvroUnion sch (u ': us) where - toAvroU (Z v) = (unTagged (A.schema @(FieldValue sch u)), A.toAvro v) - toAvroU (S n) = toAvroU n - -class ToAvroEnum choices where - toAvroE :: NS Proxy choices -> (Int, T.Text) -instance ToAvroEnum '[] where - toAvroE = error "ToAvro in an empty enum" -instance (KnownName u, ToAvroEnum us) - => ToAvroEnum ('ChoiceDef u anns ': us) where - toAvroE (Z _) = (0, nameText (Proxy @u)) - 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) -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 - toAvroF (Field v :* rest) = HM.insert fieldName fieldValue (toAvroF rest) - where fieldName = nameText (Proxy @name) - fieldValue = A.toAvro v - --- Conversion of symbols to other things -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 diff --git a/schema/src/Mu/Schema/Adapter/ProtoBuf.hs b/schema/src/Mu/Schema/Adapter/ProtoBuf.hs deleted file mode 100644 index f1d7ddf9..00000000 --- a/schema/src/Mu/Schema/Adapter/ProtoBuf.hs +++ /dev/null @@ -1,329 +0,0 @@ -{-# language PolyKinds, DataKinds, GADTs, - TypeFamilies, TypeOperators, - MultiParamTypeClasses, - FlexibleInstances, FlexibleContexts, - ScopedTypeVariables, TypeApplications, - UndecidableInstances, - OverloadedStrings, ConstraintKinds, - AllowAmbiguousTypes #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -module Mu.Schema.Adapter.ProtoBuf ( - -- * Custom annotations - ProtoBufId - -- * Conversion using schemas -, IsProtoSchema -, HasProtoSchema -, toProtoViaSchema -, fromProtoViaSchema -, parseProtoViaSchema - -- * Conversion using registry -, FromProtoBufRegistry -, fromProtoBufWithRegistry -, 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.Definition -import Mu.Schema.Interpretation -import Mu.Schema.Class -import qualified Mu.Schema.Registry as R - --- ANNOTATION FOR CONVERSION - -data ProtoBufId (n :: 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 - --- CONVERSION USING SCHEMAS - -class ProtoBridgeTerm sch (sch :/: sty) => IsProtoSchema sch sty -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. - (HasProtoSchema sch sty a) - => a -> PBEnc.MessageBuilder -toProtoViaSchema = termToProto . toSchema' @sch - -fromProtoViaSchema :: forall sch a sty. - (HasProtoSchema sch sty a) - => PBDec.Parser PBDec.RawMessage a -fromProtoViaSchema = fromSchema' @sch <$> protoToTerm - -parseProtoViaSchema :: forall sch a sty. - (HasProtoSchema sch sty a) - => BS.ByteString -> Either PBDec.ParseError a -parseProtoViaSchema = PBDec.parse (fromProtoViaSchema @sch) - --- CONVERSION USING REGISTRY - -fromProtoBufWithRegistry - :: forall (r :: R.Registry) t. - FromProtoBufRegistry r t - => PBDec.Parser PBDec.RawMessage t -fromProtoBufWithRegistry = fromProtoBufRegistry' (Proxy @r) - -parseProtoBufWithRegistry - :: forall (r :: R.Registry) t. - FromProtoBufRegistry r t - => BS.ByteString -> Either PBDec.ParseError t -parseProtoBufWithRegistry = PBDec.parse (fromProtoBufWithRegistry @r) - -class FromProtoBufRegistry (ms :: Mappings Nat Schema') t where - fromProtoBufRegistry' :: Proxy ms -> PBDec.Parser PBDec.RawMessage t - -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) - - --- ======================================= --- IMPLEMENTATION OF GENERIC SERIALIZATION --- ======================================= - -instance Alternative (PBDec.Parser i) where - empty = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "cannot parse")) - PBDec.Parser x <|> PBDec.Parser y - = PBDec.Parser $ \i -> case x i of - Left _ -> y i - 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) - --- 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 ProtoBridgeField (sch :: Schema tn fn) (f :: FieldDef tn fn) where - fieldToProto :: Field sch f -> PBEnc.MessageBuilder - protoToField :: PBDec.Parser PBDec.RawMessage (Field 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 ProtoBridgeOneFieldValue (sch :: Schema tn fn) (t :: FieldType tn) where - protoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (FieldValue sch t) - --- -------- --- TERMS -- --- -------- - --- RECORDS --- ------- - -instance (All (ProtoBridgeField sch) args, ProtoBridgeFields sch args) - => ProtoBridgeTerm sch ('DRecord name anns args) where - termToProto (TRecord fields) = go fields - where go :: forall fs. All (ProtoBridgeField sch) fs - => NP (Field sch) fs -> PBEnc.MessageBuilder - go Nil = mempty - go (f :* fs) = fieldToProto f <> go fs - protoToTerm = TRecord <$> protoToFields - -class ProtoBridgeFields sch fields where - protoToFields :: PBDec.Parser PBDec.RawMessage (NP (Field sch) fields) -instance ProtoBridgeFields sch '[] where - protoToFields = pure Nil -instance (ProtoBridgeField sch f, ProtoBridgeFields sch fs) - => ProtoBridgeFields sch (f ': fs) where - protoToFields = (:*) <$> protoToField <*> protoToFields - -instance ProtoBridgeTerm sch ('DRecord name anns args) - => ProtoBridgeEmbedTerm sch ('DRecord name anns args) where - termToEmbedProto fid v = PBEnc.embedded fid (termToProto v) - embedProtoToFieldValue = do - t <- PBDec.embedded (protoToTerm @_ @_ @sch @('DRecord name anns 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)) - --- ENUMERATIONS --- ------------ - -instance TypeError ('Text "protobuf requires wrapping enums in a message") - => ProtoBridgeTerm sch ('DEnum name anns 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 - embedProtoToFieldValue = do n <- PBDec.one PBDec.int32 0 - TEnum <$> protoToEnum n - embedProtoToOneFieldValue = do n <- PBDec.int32 - TEnum <$> protoToEnum n - -class ProtoBridgeEnum (choices :: [ChoiceDef fn]) where - enumToProto :: FieldNumber -> NS Proxy choices -> PBEnc.MessageBuilder - protoToEnum :: Int32 -> PBDec.Parser a (NS Proxy choices) -instance ProtoBridgeEnum '[] 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 - enumToProto fid (Z _) = PBEnc.int32 fid enumValue - where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId c anns))) - enumToProto fid (S v) = enumToProto fid v - protoToEnum n - | n == enumValue = return (Z Proxy) - | otherwise = S <$> protoToEnum n - where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId c anns))) - --- SIMPLE --- ------ - -instance TypeError ('Text "protobuf requires wrapping primitives in a message") - => ProtoBridgeTerm sch ('DSimple t) where - termToProto = error "protobuf requires wrapping primitives in a message" - protoToTerm = error "protobuf requires wrapping primitives in a message" - --- --------- --- FIELDS -- --- --------- - -instance (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)) - --- ------------------ --- TYPES OF FIELDS -- --- ------------------ - --- SCHEMATIC --- --------- - -instance ProtoBridgeEmbedTerm sch (sch :/: t) - => ProtoBridgeFieldValue sch ('TSchematic t) where - fieldValueToProto fid (FSchematic v) = termToEmbedProto fid v - protoToFieldValue = FSchematic <$> embedProtoToFieldValue -instance ProtoBridgeEmbedTerm sch (sch :/: t) - => ProtoBridgeOneFieldValue sch ('TSchematic t) where - protoToOneFieldValue = FSchematic <$> embedProtoToOneFieldValue - --- PRIMITIVE TYPES --- --------------- - -instance TypeError ('Text "null cannot be converted to protobuf") - => ProtoBridgeFieldValue 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 - protoToOneFieldValue = error "null cannot be converted to protobuf" - -instance ProtoBridgeFieldValue 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 - protoToOneFieldValue = FPrimitive . fromIntegral <$> PBDec.int32 - -instance ProtoBridgeFieldValue 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 - protoToOneFieldValue = FPrimitive <$> PBDec.int32 - -instance ProtoBridgeFieldValue 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 - protoToOneFieldValue = FPrimitive <$> PBDec.int64 - --- WARNING! These instances may go out of bounds -instance ProtoBridgeFieldValue 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 - protoToOneFieldValue = FPrimitive . fromIntegral <$> PBDec.int64 - -instance ProtoBridgeFieldValue 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 - protoToOneFieldValue = FPrimitive <$> PBDec.float - -instance ProtoBridgeFieldValue 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 - protoToOneFieldValue = FPrimitive <$> PBDec.double - -instance ProtoBridgeFieldValue 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 - protoToOneFieldValue = FPrimitive <$> PBDec.bool - -instance ProtoBridgeFieldValue 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 - protoToOneFieldValue = FPrimitive . LT.toStrict <$> PBDec.text - -instance ProtoBridgeFieldValue 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 - protoToOneFieldValue = FPrimitive <$> PBDec.text - -instance ProtoBridgeFieldValue 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 - 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 - 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 - protoToOneFieldValue = error "optionals cannot be nested in protobuf" - -instance (ProtoBridgeFieldValue sch t, ProtoBridgeOneFieldValue sch t) - => ProtoBridgeFieldValue 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 - protoToOneFieldValue = error "lists cannot be nested in protobuf" - -instance TypeError ('Text "maps are not currently supported") - => ProtoBridgeFieldValue sch ('TMap k v) where - fieldValueToProto = error "maps are not currently supported" - protoToFieldValue = error "maps are not currently supported" - --- TODO: Missing unions!! \ No newline at end of file diff --git a/schema/src/Mu/Schema/Class.hs b/schema/src/Mu/Schema/Class.hs deleted file mode 100644 index c4ab1741..00000000 --- a/schema/src/Mu/Schema/Class.hs +++ /dev/null @@ -1,344 +0,0 @@ -{-# language PolyKinds, DataKinds, GADTs, - TypeFamilies, TypeOperators, - FunctionalDependencies, - FlexibleInstances, FlexibleContexts, - TypeApplications, ScopedTypeVariables, - UndecidableInstances, - DefaultSignatures #-} --- | 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 Mu.Schema.Definition -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 - --- | 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 --- field names of @t@ and that of 'SchemaType' --- by means of 'FieldMapping'. -class HasSchema (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 - - 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) - - 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) - --- | 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' = 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' = fromSchema - --- ====================== --- CRAZY GENERICS SECTION --- ====================== - --- Auxiliary type families to find elements in lists --- They return an indication of where the thing was found --- --- Note: it turns out that GHC.Generics generates some weird --- instances for records in the form (x :*: y) :*: z --- and we cover them with the special HereLeft and HereRight -data Where = Here | HereLeft | HereRight | There Where - -type family Find (xs :: [k]) (x :: k) :: Where where - Find '[] y = TypeError ('Text "Could not find " ':<>: 'ShowType y) - Find (y ': xs) y = 'Here - Find (x ': xs) y = 'There (Find xs y) - -type family FindCon (xs :: * -> *) (x :: Symbol) :: Where where - FindCon (C1 ('MetaCons x p s) f) x = 'Here - FindCon (C1 ('MetaCons x p s) f :+: rest) x = 'Here - FindCon (other :+: rest) x = 'There (FindCon rest x) - FindCon nothing x = TypeError ('Text "Could not find constructor " ':<>: 'ShowType x) - -type family FindSel (xs :: * -> *) (x :: Symbol) :: Where where - FindSel (S1 ('MetaSel ('Just x) u ss ds) f) x = 'Here - FindSel (S1 ('MetaSel ('Just x) u ss ds) f :*: rest) x = 'Here - FindSel ((S1 ('MetaSel ('Just x) u ss ds) f :*: other) :*: rest) x = 'HereLeft - FindSel ((other :*: S1 ('MetaSel ('Just x) u ss ds) f) :*: rest) x = 'HereRight - FindSel (other :*: rest) x = 'There (FindSel rest x) - FindSel nothing x = TypeError ('Text "Could not find selector " ':<>: 'ShowType x) - -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) - -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) - --- 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 - --- ------------------ --- 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) - -class GSchemaFieldType (sch :: Schema ts fs) (t :: FieldType ts) (f :: *) where - toSchemaFieldType :: f -> FieldValue sch t - fromSchemaFieldType :: FieldValue sch t -> f - --- These instances are straightforward, --- just turn the "real types" into their --- schema correspondants. -instance GSchemaFieldType sch 'TNull () where - toSchemaFieldType _ = FNull - fromSchemaFieldType _ = () -instance GSchemaFieldType sch ('TPrimitive t) t where - toSchemaFieldType = FPrimitive - fromSchemaFieldType (FPrimitive x) = x --- This instance "ties the loop" with the whole schema, --- and it 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 - toSchemaFieldType x = FSchematic $ toSchema x - fromSchemaFieldType (FSchematic x) = fromSchema x -instance GSchemaFieldType sch t v => GSchemaFieldType sch ('TOption t) (Maybe v) where - toSchemaFieldType x = FOption (toSchemaFieldType <$> x) - fromSchemaFieldType (FOption x) = fromSchemaFieldType <$> x -instance GSchemaFieldType sch t v => GSchemaFieldType sch ('TList t) [v] where - toSchemaFieldType x = FList (toSchemaFieldType <$> x) - 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 - toSchemaFieldType x = FMap (M.mapKeys toSchemaFieldType (M.map toSchemaFieldType 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. -instance 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 - => NS I vss -> NS (FieldValue sch) tss - go (Z (I x)) = Z (toSchemaFieldType x) - 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 - go (Z x) = Z (I (fromSchemaFieldType x)) - go (S n) = S (go n) - --- --------------- --- ENUMERATIONS -- ------------------- - -instance {-# OVERLAPPABLE #-} - (GToSchemaEnumDecompose fmap choices f, GFromSchemaEnumDecompose fmap choices f) - => GSchemaTypeDef sch fmap ('DEnum name anns 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 - toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x - fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) - --- 'toSchema' for enumerations: --- 1. recursively decompose the (:+:)s into their atomic components --- this is done by 'GToSchemaEnumSymbol' --- 2. for each atomic component, figure out which is the element --- in the schema's enumeration that it corresponds to --- 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 - toSchemaEnumDecomp :: Proxy fmap -> f a -> NS Proxy choices -instance (GToSchemaEnumDecompose fmap choices oneway, GToSchemaEnumDecompose fmap choices oranother) - => GToSchemaEnumDecompose fmap choices (oneway :+: oranother) where - toSchemaEnumDecomp p (L1 x) = toSchemaEnumDecomp p x - toSchemaEnumDecomp p (R1 x) = toSchemaEnumDecomp p x -instance GToSchemaEnumProxy choices (FindEnumChoice choices (MappingRight fmap c)) - => GToSchemaEnumDecompose fmap choices (C1 ('MetaCons c p s) f) where - toSchemaEnumDecomp _ _ - = toSchemaEnumProxy (Proxy @choices) (Proxy @(FindEnumChoice choices (MappingRight fmap c))) --- Types which have no constructor information cannot be used here - -class GToSchemaEnumProxy (choices :: [k]) (w :: Where) where - toSchemaEnumProxy :: Proxy choices -> Proxy w -> NS Proxy choices -instance GToSchemaEnumProxy (c ': cs) 'Here where - toSchemaEnumProxy _ _ = Z Proxy -instance forall c cs w. GToSchemaEnumProxy cs w - => GToSchemaEnumProxy (c ': cs) ('There w) where - toSchemaEnumProxy _ _ = S (toSchemaEnumProxy (Proxy @cs) (Proxy @w)) - --- 'fromSchema' for enumerations: --- 1. for each element in the list of choices --- (this iteration is done by 'GFromSchemaEnumDecomp') --- figure out the constructor it corresponds to --- this is done by 'MappingLeft' and 'FindCon' --- 2. from that location, build a 'U1' value wrapped --- in as many 'L1' and 'R1' required. --- this is done by 'GFromSchemaEnumU1' -class GFromSchemaEnumDecompose (fmap :: Mappings Symbol fs) (choices :: [ChoiceDef fs]) (f :: * -> *) where - fromSchemaEnumDecomp :: Proxy fmap -> NS Proxy choices -> f a -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 - fromSchemaEnumDecomp _ (Z _) = fromSchemaEnumU1 (Proxy @f) (Proxy @(FindCon f (MappingLeft fmap c))) - fromSchemaEnumDecomp p (S x) = fromSchemaEnumDecomp p x - -class GFromSchemaEnumU1 (f :: * -> *) (w :: Where) where - fromSchemaEnumU1 :: Proxy f -> Proxy w -> f a -instance GFromSchemaEnumU1 (C1 m U1 :+: rest) 'Here where - fromSchemaEnumU1 _ _ = L1 (M1 U1) -instance GFromSchemaEnumU1 (C1 m U1) 'Here where - fromSchemaEnumU1 _ _ = M1 U1 -instance forall other rest w. GFromSchemaEnumU1 rest w - => GFromSchemaEnumU1 (other :+: rest) ('There w) where - fromSchemaEnumU1 _ _ = R1 (fromSchemaEnumU1 (Proxy @rest) (Proxy @w)) - --- ---------- --- RECORDS -- -------------- - -instance {-# OVERLAPPABLE #-} - (GToSchemaRecord sch fmap args f, GFromSchemaRecord sch fmap args f) - => GSchemaTypeDef sch fmap ('DRecord name anns 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 - 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 - toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x - fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x) - --- 'toSchema' for records: --- 1. iterate over each field in the schema of the record --- this is done by 'GToSchemaRecord' --- 2. figure out the selector (field) in the Haskell type --- to which that record corresponds to --- this is done by 'MappingLeft' and 'FindSel' --- 3. using that location, obtain the value of the field --- this is done by 'GToSchemaRecordSearch' --- --- 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) -class GToSchemaRecord (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 _ _ = 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 - 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 - toSchemaRecordSearch _ (_ :*: xs) = toSchemaRecordSearch (Proxy @n) xs - --- 'fromSchema' for records --- 1. decompose the sequence of products into atomic components --- until we arrive to the selector metadata 'S1' --- this is done by 'GFromSchemaRecord' --- 2. figure out the field in the schema it corresponds to --- 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) - (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 _ 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 - 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 anns 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 - fromSchemaRecordSearch _ (_ :* xs) = fromSchemaRecordSearch (Proxy @n) xs \ No newline at end of file diff --git a/schema/src/Mu/Schema/Examples.hs b/schema/src/Mu/Schema/Examples.hs deleted file mode 100644 index 4520be94..00000000 --- a/schema/src/Mu/Schema/Examples.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# language PolyKinds, DataKinds, GADTs, - TypeFamilies, TypeOperators, - MultiParamTypeClasses, FlexibleInstances, - TypeApplications, - DeriveGeneric, DerivingVia, DeriveAnyClass, - TemplateHaskell, QuasiQuotes #-} --- | Look at my source code! -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 - -data Person - = Person { firstName :: T.Text - , lastName :: T.Text - , age :: Maybe Int - , gender :: Maybe Gender - , address :: Address } - deriving (Eq, Show, Generic) - deriving (HasSchema ExampleSchema "person") - deriving (A.HasAvroSchema, A.FromAvro, A.ToAvro, 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) - 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) - via (WithSchema ExampleSchema "gender" Gender) - --- Schema for these data types -type ExampleSchema - = '[ 'DEnum "gender" '[] - '[ 'ChoiceDef "male" '[ ProtoBufId 1 ] - , 'ChoiceDef "female" '[ ProtoBufId 2 ] - , 'ChoiceDef "nb" '[ ProtoBufId 0 ] ] - , '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") ] - ] - -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) - -{- -type ExampleSchema2 - = SchemaFromTypes '[ AsRecord Person "person" - , AsRecord Address "address" - , AsEnum Gender "gender" ] --} -type ExampleSchema2 - = '[ 'DEnum "gender" '[] - '[ 'ChoiceDef "Male" '[ ProtoBufId 1 ] - , 'ChoiceDef "Female" '[ ProtoBufId 2 ] - , 'ChoiceDef "NonBinary" '[ ProtoBufId 0 ] ] - , '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") ] - ] - -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 diff --git a/schema/src/Mu/Schema/Interpretation/Anonymous.hs b/schema/src/Mu/Schema/Interpretation/Anonymous.hs deleted file mode 100644 index 46258d3e..00000000 --- a/schema/src/Mu/Schema/Interpretation/Anonymous.hs +++ /dev/null @@ -1,70 +0,0 @@ -{-# language PolyKinds, DataKinds, GADTs, - TypeOperators, - MultiParamTypeClasses, - FlexibleInstances, FlexibleContexts, - UndecidableInstances, - StandaloneDeriving #-} -module Mu.Schema.Interpretation.Anonymous where - -import Data.SOP - -import Mu.Schema - -data V0 sch sty where - V0 :: (sch :/: sty ~ 'DRecord nm anns '[]) - => 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 '[]) - => 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) ]) - => a -> V1 sch sty - -deriving instance (Show a, sch :/: sty - ~ 'DRecord anns nm '[ 'FieldDef f fanns ('TPrimitive a) ]) - => Show (V1 sch sty) -deriving instance (Eq a, sch :/: sty - ~ 'DRecord nm anns '[ 'FieldDef f fanns ('TPrimitive a) ]) - => Eq (V1 sch sty) -deriving instance (Ord a, sch :/: sty - ~ 'DRecord nm anns '[ 'FieldDef f fanns ('TPrimitive a) ]) - => Ord (V1 sch sty) - -instance (sch :/: sty - ~ 'DRecord nm anns '[ 'FieldDef f fanns ('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) ]) - => 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) ]) - => 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) ]) - => 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) ]) - => Ord (V2 sch sty) - -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 diff --git a/schema/src/Mu/Schema/Quasi.hs b/schema/src/Mu/Schema/Quasi.hs deleted file mode 100644 index 9172879f..00000000 --- a/schema/src/Mu/Schema/Quasi.hs +++ /dev/null @@ -1,102 +0,0 @@ -{-# language TemplateHaskell, DataKinds #-} -module Mu.Schema.Quasi ( - -- * Quasi-quoters for @.proto@ files - protobuf -, protobufFile - -- * Only for internal use -, schemaFromProtoBuf -) where - -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.Definition -import Mu.Schema.Adapter.ProtoBuf - --- | 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 } - = 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 - -pbTypeDeclToType :: P.TypeDeclaration -> Q Type -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) |] - 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" - - 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.TOther t) = [t| 'TSchematic $(textToStrLit (last t)) |] - -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 -intToLit :: Int -> Q Type -intToLit n - = return $ LitT $ NumTyLit $ toInteger n \ No newline at end of file diff --git a/schema/src/Mu/Schema/Registry.hs b/schema/src/Mu/Schema/Registry.hs deleted file mode 100644 index c80a7bbc..00000000 --- a/schema/src/Mu/Schema/Registry.hs +++ /dev/null @@ -1,36 +0,0 @@ -{-# language PolyKinds, DataKinds, TypeFamilies, - ScopedTypeVariables, MultiParamTypeClasses, - FlexibleInstances, FlexibleContexts, - TypeOperators, UndecidableInstances, - TypeApplications, AllowAmbiguousTypes #-} -module Mu.Schema.Registry ( - -- * Registry of schemas - Registry, fromRegistry - -- * Terms without an associated schema -, SLess.Term(..), SLess.Field(..), SLess.FieldValue(..) -) where - -import Data.Proxy -import Data.Kind -import Control.Applicative -import GHC.TypeLits - -import Mu.Schema.Definition -import Mu.Schema.Class -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 = fromRegistry' (Proxy @r) - -class FromRegistry (ms :: Registry) (t :: Type) where - fromRegistry' :: Proxy ms -> SLess.Term -> Maybe t - -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 diff --git a/schema/test/Avro.hs b/schema/test/Avro.hs deleted file mode 100644 index 8bdd047f..00000000 --- a/schema/test/Avro.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# language OverloadedStrings, TypeApplications, - NamedFieldPuns #-} -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.Examples - -exampleAddress :: Address -exampleAddress = Address "1111BB" "Spain" - -examplePerson1, examplePerson2 :: Person -examplePerson1 = Person "Haskellio" "Gómez" (Just 30) (Just Male) exampleAddress -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 [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 diff --git a/schema/test/ProtoBuf.hs b/schema/test/ProtoBuf.hs deleted file mode 100644 index 8e1b7158..00000000 --- a/schema/test/ProtoBuf.hs +++ /dev/null @@ -1,34 +0,0 @@ -{-# language OverloadedStrings, TypeApplications, - NamedFieldPuns #-} -module Main where - -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 Mu.Schema () -import Mu.Schema.Adapter.ProtoBuf () -import Mu.Schema.Examples - -exampleAddress :: Address -exampleAddress = Address "1111BB" "Spain" - -examplePerson1, examplePerson2 :: Person -examplePerson1 = Person "Haskellio" "Gómez" (Just 30) (Just Male) exampleAddress -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 protoBufToPerson cbs - print people - -- Encode a couple of values - putStrLn "haskell/generate" - print examplePerson1 - let gbs = PBEnc.toLazyByteString (personToProtoBuf examplePerson1) - LBS.writeFile genFile gbs \ No newline at end of file diff --git a/schema/test/avro/example.avsc b/schema/test/avro/example.avsc deleted file mode 100644 index 96c6cb25..00000000 --- a/schema/test/avro/example.avsc +++ /dev/null @@ -1,22 +0,0 @@ -[ { "type": "enum", - "name": "gender", - "symbols" : ["male", "female", "nb"] - } -, { "type": "record" - , "name": "address" - , "fields": [ - {"name": "postcode", "type": "string"}, - {"name": "country", "type": "string"} - ] - } -,{ "type": "record", - "name": "person", - "fields": [ - {"name": "firstName", "type": "string"}, - {"name": "lastName", "type": "string"}, - {"name": "age", "type": ["long", "null"]}, - {"name": "gender", "type": ["gender", "null"]}, - {"name": "address", "type": "address"} - ] - } -] \ No newline at end of file diff --git a/schema/test/protobuf/example_pb2.py b/schema/test/protobuf/example_pb2.py deleted file mode 100644 index 87635172..00000000 --- a/schema/test/protobuf/example_pb2.py +++ /dev/null @@ -1,178 +0,0 @@ -# -*- coding: utf-8 -*- -# Generated by the protocol buffer compiler. DO NOT EDIT! -# source: example.proto - -import sys -_b=sys.version_info[0]<3 and (lambda x:x) or (lambda x:x.encode('latin1')) -from google.protobuf.internal import enum_type_wrapper -from google.protobuf import descriptor as _descriptor -from google.protobuf import message as _message -from google.protobuf import reflection as _reflection -from google.protobuf import symbol_database as _symbol_database -# @@protoc_insertion_point(imports) - -_sym_db = _symbol_database.Default() - - - - -DESCRIPTOR = _descriptor.FileDescriptor( - name='example.proto', - package='', - syntax='proto3', - serialized_options=None, - serialized_pb=_b('\n\rexample.proto\"n\n\x06person\x12\x11\n\tfirstName\x18\x01 \x01(\t\x12\x10\n\x08lastName\x18\x02 \x01(\t\x12\x0b\n\x03\x61ge\x18\x03 \x01(\x05\x12\x17\n\x06gender\x18\x04 \x01(\x0e\x32\x07.gender\x12\x19\n\x07\x61\x64\x64ress\x18\x05 \x01(\x0b\x32\x08.address\",\n\x07\x61\x64\x64ress\x12\x10\n\x08postcode\x18\x01 \x01(\t\x12\x0f\n\x07\x63ountry\x18\x02 \x01(\t*&\n\x06gender\x12\x06\n\x02nb\x10\x00\x12\x08\n\x04male\x10\x01\x12\n\n\x06\x66\x65male\x10\x02\x62\x06proto3') -) - -_GENDER = _descriptor.EnumDescriptor( - name='gender', - full_name='gender', - filename=None, - file=DESCRIPTOR, - values=[ - _descriptor.EnumValueDescriptor( - name='nb', index=0, number=0, - serialized_options=None, - type=None), - _descriptor.EnumValueDescriptor( - name='male', index=1, number=1, - serialized_options=None, - type=None), - _descriptor.EnumValueDescriptor( - name='female', index=2, number=2, - serialized_options=None, - type=None), - ], - containing_type=None, - serialized_options=None, - serialized_start=175, - serialized_end=213, -) -_sym_db.RegisterEnumDescriptor(_GENDER) - -gender = enum_type_wrapper.EnumTypeWrapper(_GENDER) -nb = 0 -male = 1 -female = 2 - - - -_PERSON = _descriptor.Descriptor( - name='person', - full_name='person', - filename=None, - file=DESCRIPTOR, - containing_type=None, - fields=[ - _descriptor.FieldDescriptor( - name='firstName', full_name='person.firstName', index=0, - number=1, type=9, cpp_type=9, label=1, - has_default_value=False, default_value=_b("").decode('utf-8'), - message_type=None, enum_type=None, containing_type=None, - is_extension=False, extension_scope=None, - serialized_options=None, file=DESCRIPTOR), - _descriptor.FieldDescriptor( - name='lastName', full_name='person.lastName', index=1, - number=2, type=9, cpp_type=9, label=1, - has_default_value=False, default_value=_b("").decode('utf-8'), - message_type=None, enum_type=None, containing_type=None, - is_extension=False, extension_scope=None, - serialized_options=None, file=DESCRIPTOR), - _descriptor.FieldDescriptor( - name='age', full_name='person.age', index=2, - number=3, type=5, cpp_type=1, label=1, - has_default_value=False, default_value=0, - message_type=None, enum_type=None, containing_type=None, - is_extension=False, extension_scope=None, - serialized_options=None, file=DESCRIPTOR), - _descriptor.FieldDescriptor( - name='gender', full_name='person.gender', index=3, - number=4, type=14, cpp_type=8, label=1, - has_default_value=False, default_value=0, - message_type=None, enum_type=None, containing_type=None, - is_extension=False, extension_scope=None, - serialized_options=None, file=DESCRIPTOR), - _descriptor.FieldDescriptor( - name='address', full_name='person.address', index=4, - number=5, type=11, cpp_type=10, label=1, - has_default_value=False, default_value=None, - message_type=None, enum_type=None, containing_type=None, - is_extension=False, extension_scope=None, - serialized_options=None, file=DESCRIPTOR), - ], - extensions=[ - ], - nested_types=[], - enum_types=[ - ], - serialized_options=None, - is_extendable=False, - syntax='proto3', - extension_ranges=[], - oneofs=[ - ], - serialized_start=17, - serialized_end=127, -) - - -_ADDRESS = _descriptor.Descriptor( - name='address', - full_name='address', - filename=None, - file=DESCRIPTOR, - containing_type=None, - fields=[ - _descriptor.FieldDescriptor( - name='postcode', full_name='address.postcode', index=0, - number=1, type=9, cpp_type=9, label=1, - has_default_value=False, default_value=_b("").decode('utf-8'), - message_type=None, enum_type=None, containing_type=None, - is_extension=False, extension_scope=None, - serialized_options=None, file=DESCRIPTOR), - _descriptor.FieldDescriptor( - name='country', full_name='address.country', index=1, - number=2, type=9, cpp_type=9, label=1, - has_default_value=False, default_value=_b("").decode('utf-8'), - message_type=None, enum_type=None, containing_type=None, - is_extension=False, extension_scope=None, - serialized_options=None, file=DESCRIPTOR), - ], - extensions=[ - ], - nested_types=[], - enum_types=[ - ], - serialized_options=None, - is_extendable=False, - syntax='proto3', - extension_ranges=[], - oneofs=[ - ], - serialized_start=129, - serialized_end=173, -) - -_PERSON.fields_by_name['gender'].enum_type = _GENDER -_PERSON.fields_by_name['address'].message_type = _ADDRESS -DESCRIPTOR.message_types_by_name['person'] = _PERSON -DESCRIPTOR.message_types_by_name['address'] = _ADDRESS -DESCRIPTOR.enum_types_by_name['gender'] = _GENDER -_sym_db.RegisterFileDescriptor(DESCRIPTOR) - -person = _reflection.GeneratedProtocolMessageType('person', (_message.Message,), { - 'DESCRIPTOR' : _PERSON, - '__module__' : 'example_pb2' - # @@protoc_insertion_point(class_scope:person) - }) -_sym_db.RegisterMessage(person) - -address = _reflection.GeneratedProtocolMessageType('address', (_message.Message,), { - 'DESCRIPTOR' : _ADDRESS, - '__module__' : 'example_pb2' - # @@protoc_insertion_point(class_scope:address) - }) -_sym_db.RegisterMessage(address) - - -# @@protoc_insertion_point(module_scope) diff --git a/servant/server/CHANGELOG.md b/servant/server/CHANGELOG.md new file mode 100644 index 00000000..e69cc087 --- /dev/null +++ b/servant/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/servant/server/LICENSE b/servant/server/LICENSE new file mode 100644 index 00000000..ffeb95d1 --- /dev/null +++ b/servant/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 © 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/servant/server/Setup.hs b/servant/server/Setup.hs new file mode 100644 index 00000000..44671092 --- /dev/null +++ b/servant/server/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/servant/server/exe/ExampleServer.hs b/servant/server/exe/ExampleServer.hs new file mode 100644 index 00000000..714bb485 --- /dev/null +++ b/servant/server/exe/ExampleServer.hs @@ -0,0 +1,46 @@ +{-# language DataKinds #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} + +module Main where + +import qualified Data.Text.IO as Text +import Mu.Rpc.Annotations +import Mu.Rpc.Examples +import Mu.Schema.Annotations +import Mu.Servant.Server +import Mu.Server +import Network.Wai.Handler.Warp +import Servant + +main :: IO () +main = do + putStrLn "running quickstart application" + Text.putStrLn $ layout quickstartAPI + run 8081 (serve quickstartAPI servantServer) + +servantServer :: _ +servantServer = servantServerHandlers toHandler quickstartServer + +quickstartAPI :: Proxy _ +quickstartAPI = packageAPI (quickstartServer @ServerErrorIO) + +type instance + AnnotatedPackage ServantRoute QuickStartService = + '[ 'AnnService "Greeter" ('ServantTopLevelRoute '["greet"]), + 'AnnMethod "Greeter" "SayHello" + ('ServantRoute '["say", "hello"] 'POST 200), + 'AnnMethod "Greeter" "SayHi" + ('ServantRoute '["say", "hi"] 'POST 200), + 'AnnMethod "Greeter" "SayManyHellos" + ('ServantRoute '["say", "many", "hellos"] 'POST 200) + ] + +type instance + AnnotatedSchema ServantContentTypes QuickstartSchema = + '[ 'AnnType "HelloRequest" DefaultServantContentTypes, + 'AnnType "HelloResponse" DefaultServantContentTypes, + 'AnnType "HiRequest" DefaultServantContentTypes + ] diff --git a/servant/server/hie.yaml b/servant/server/hie.yaml new file mode 100644 index 00000000..61871b85 --- /dev/null +++ b/servant/server/hie.yaml @@ -0,0 +1,6 @@ +cradle: + stack: + - path: "./src" + component: "mu-servant-server:lib" + - path: "./exe" + component: "mu-servant-server:exe:servant-example-server" diff --git a/servant/server/mu-servant-server.cabal b/servant/server/mu-servant-server.cabal new file mode 100644 index 00000000..1fda79eb --- /dev/null +++ b/servant/server/mu-servant-server.cabal @@ -0,0 +1,61 @@ +name: mu-servant-server +version: 0.5.0.0 +synopsis: Servant servers for Mu definitions +description: + With @mu-servant-server@ you can easily build Servant servers for mu-haskell! + +license: Apache-2.0 +license-file: LICENSE +author: Andre Marianiello +maintainer: alejandro.serrano@47deg.com +copyright: Copyright © 2019-2020 +cabal-version: >=1.10 +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.Servant.Server + build-depends: + aeson >=1.4 && <2 + , async >=2.2 && <3 + , base >=4.12 && <5 + , conduit >=1.3.2 && <2 + , generic-aeson >=0.2 && <0.3 + , ghc-prim >=0.5 && <0.7 + , mtl >=2.2 && <3 + , mu-rpc >=0.5 && <0.6 + , mu-schema >=0.3 && <0.4 + , servant >=0.16 && <0.19 + , servant-server >=0.16 && <0.19 + , servant-swagger >=1.1.7 && <2 + , stm >=2.5 && <3 + , swagger2 >=2.5 && <3 + , utf8-string >=1 && <2 + + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall -fprint-potential-instances + +executable servant-example-server + main-is: ExampleServer.hs + build-depends: + aeson >=1.4 && <2 + , base >=4.12 && <5 + , conduit >=1.3.2 && <2 + , mu-rpc >=0.5 && <0.6 + , mu-schema >=0.3 && <0.4 + , mu-servant-server + , servant-server >=0.16 && <0.19 + , text >=1.2 && <2 + , warp >=3.3 && <4 + + hs-source-dirs: exe + default-language: Haskell2010 + ghc-options: -Wall -fprint-explicit-kinds -fprint-explicit-foralls diff --git a/servant/server/src/Mu/Servant/Server.hs b/servant/server/src/Mu/Servant/Server.hs new file mode 100644 index 00000000..fa1a8a5e --- /dev/null +++ b/servant/server/src/Mu/Servant/Server.hs @@ -0,0 +1,515 @@ +{-# language ConstraintKinds #-} +{-# language DataKinds #-} +{-# language DeriveGeneric #-} +{-# language FlexibleContexts #-} +{-# language FlexibleInstances #-} +{-# language GADTs #-} +{-# language MultiParamTypeClasses #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# language UndecidableInstances #-} + +{-| +Description : Execute a Mu 'Server' using Servant + +This module allows you to serve a Mu 'Server' +as an OpenAPI / Swagger / REST end-point. +In particular, it translates to the kind of +type-level APIs used by Servant. +-} +module Mu.Servant.Server ( + -- * Convert Mu to Servant + servantServerHandlers, + servantServerHandlersExtra, + toHandler, + packageAPI, + swagger, + -- * Required annotations + ServantRoute(..), + DefaultServantContentTypes, + ServantContentTypes(..), + ServantStreamContentType(..), + -- Reexports + StdMethod(..), + module Servant.API +) where + +import Conduit +import Control.Concurrent +import Control.Concurrent.Async +import Control.Monad.Except +import Data.Aeson +import qualified Data.ByteString.Lazy.UTF8 as LB8 +import Data.Conduit.Internal (ConduitT (..), Pipe (..)) +import Data.Kind +import Data.Swagger (Swagger, ToSchema (..)) +import GHC.Generics +import GHC.TypeLits +import GHC.Types (Any) +import Generics.Generic.Aeson +import Mu.Rpc +import Mu.Rpc.Annotations +import Mu.Schema +import Mu.Schema.Annotations +import Mu.Server +import Servant +import Servant.API +import Servant.Swagger +import Servant.Types.SourceT + +-- | Reinterprets a Mu server action as a Servant handler. +toHandler :: ServerErrorIO a -> Handler a +toHandler = Handler . withExceptT convertServerError + +-- | Translates a Mu `Mu.Server.ServerError` into a Servant `Servant.ServerError`. +convertServerError :: Mu.Server.ServerError -> Servant.ServerError +convertServerError (Mu.Server.ServerError code msg) = case code of + Unknown -> err502 {errBody = LB8.fromString msg} + Unavailable -> err503 {errBody = LB8.fromString msg} + Unimplemented -> err501 {errBody = LB8.fromString msg} + Unauthenticated -> err401 {errBody = LB8.fromString msg} + Internal -> err500 {errBody = LB8.fromString msg} + Invalid -> err400 {errBody = LB8.fromString msg} + NotFound -> err404 {errBody = LB8.fromString msg} + +-- | Converts a Mu server into Servant server +-- by running all Mu handler actions in the `Handler` type. +-- This version assumes /no/ additional routes +-- in the Servant server when compared to Mu's. +servantServerHandlers :: + forall pname m chn ss handlers. + ( ServantServiceHandlers + ('Package pname ss) + m + chn + ss + handlers + , ExtraFor ('Package pname ss) ~ EmptyAPI + ) + => (forall a. m a -> Handler a) -- ^ how to turn the inner Mu monad into 'Handler', use 'toHandler' (or a composition with it) in most cases + -> Mu.Server.ServerT chn () ('Package pname ss) m handlers -- ^ server to be converted + -> Servant.Server (PackageAPI ('Package pname ss) handlers) +servantServerHandlers f (Services svcs) = + emptyServer :<|> servantServiceHandlers f (Proxy @('Package pname ss)) svcs + +-- | Converts a Mu server into Servant server +-- by running all Mu handler actions in the `Handler` type. +-- This version should be used when additional +-- routes have been added in the Servant version. +servantServerHandlersExtra :: + forall pname m chn ss handlers. + ( ServantServiceHandlers + ('Package pname ss) + m + chn + ss + handlers + ) + => (forall a. m a -> Handler a) -- ^ how to turn the inner Mu monad into 'Handler', use 'toHandler' (or a composition with it) in most cases + -> Server (ExtraFor ('Package pname ss)) -- ^ additional handler for the extra route + -> Mu.Server.ServerT chn () ('Package pname ss) m handlers -- ^ server to be converted + -> Servant.Server (PackageAPI ('Package pname ss) handlers) +servantServerHandlersExtra f extra (Services svcs) = + extra :<|> servantServiceHandlers f (Proxy @('Package pname ss)) svcs + +-- | Converts the information from a Mu server +-- into a 'Swagger' document. +swagger :: forall pname ss handlers chn m. + HasSwagger (ServicesAPI ('Package pname ss) ss handlers) + => Mu.Server.ServerT chn () ('Package pname ss) m handlers + -> Swagger +swagger _ = toSwagger (Proxy @(ServicesAPI ('Package pname ss) ss handlers)) + +-- | Obtains a Servant API 'Proxy' value for use +-- with functions like 'serve' and 'layout'. +packageAPI :: Mu.Server.ServerT chn t pkg s handlers -> Proxy (PackageAPI pkg handlers) +packageAPI _ = Proxy + +type family PackageAPI (pkg :: Package snm mnm anm (TypeRef snm)) handlers where + PackageAPI ('Package pnm ss) handlers = PackageAPI' (ExtraFor ('Package pnm ss)) ('Package pnm ss) handlers + +type family PackageAPI' (extra :: Type) (pkg :: Package snm mnm anm (TypeRef snm)) handlers where + PackageAPI' extra ('Package pnm ss) handlers = extra :<|> ServicesAPI ('Package pnm ss) ss handlers + +class + ServantServiceHandlers + (pkg :: Package snm mnm anm (TypeRef snm)) + (m :: Type -> Type) + (chn :: ServiceChain snm) + (ss :: [Service snm mnm anm (TypeRef snm)]) + (hss :: [[Type]]) where + type ServicesAPI pkg ss hss + + servantServiceHandlers :: + (forall a. m a -> Handler a) -> + Proxy pkg -> + ServicesT chn info ss m hss -> + Servant.Server (ServicesAPI pkg ss hss) + +instance ServantServiceHandlers pkg m chn '[] '[] where + type ServicesAPI pkg '[] '[] = EmptyAPI + servantServiceHandlers _ _ S0 = emptyServer + +instance + ( ServantMethodHandlers + pkg + sname + m + chn + (MappingRight chn sname) + methods + hs, + ServantServiceHandlers pkg m chn rest hss + ) => + ServantServiceHandlers pkg m chn ('Service sname methods ': rest) (hs ': hss) + where + type + ServicesAPI pkg ('Service sname methods ': rest) (hs ': hss) = + MethodsAPI pkg sname methods hs :<|> ServicesAPI pkg rest hss + servantServiceHandlers f pkgP (ProperSvc svr :<&>: rest) = + servantMethodHandlers f pkgP (Proxy @sname) svr + :<|> servantServiceHandlers f pkgP rest + +instance (TypeError ('Text "unions are not supported by Servant servers")) + => ServantServiceHandlers pkg m chn ('OneOf sname methods ': rest) hs where + type ServicesAPI pkg ('OneOf sname methods ': rest) hs = + TypeError ('Text "unions are not supported by Servant servers") + servantServiceHandlers _ = error "unions are not supported by Servant servers" + +class + ServantMethodHandlers + (pkg :: Package Symbol Symbol anm (TypeRef Symbol)) + (sname :: Symbol) + (m :: Type -> Type) + (chn :: ServiceChain snm) + (inh :: Type) + (ms :: [Method snm Symbol anm (TypeRef snm)]) + (hs :: [Type]) where + type MethodsAPI pkg sname ms hs + servantMethodHandlers :: + (forall a. m a -> Handler a) -> + Proxy pkg -> + Proxy sname -> + HandlersT chn info inh ms m hs -> + Servant.Server (MethodsAPI pkg sname ms hs) + +instance + ServantMethodHandlers pkg svc m chn inh '[] '[] where + type MethodsAPI _ _ '[] '[] = EmptyAPI + servantMethodHandlers _ _ _ H0 = emptyServer + +instance + ( ServantMethodHandler httpMethod httpStatus m args ret h, + ServantMethodHandlers pkg sname m chn () rest hs, + HttpMethodFor pkg sname mname ~ httpMethod, + HttpStatusFor pkg sname mname ~ httpStatus, + Server (MethodAPI pkg sname ('Method mname args ret) h) ~ Server (HandlerAPI httpMethod httpStatus args ret h) + ) => + ServantMethodHandlers pkg sname m chn () ('Method mname args ret ': rest) (h ': hs) + where + type + MethodsAPI pkg sname ('Method mname args ret ': rest) (h ': hs) = + MethodAPI pkg sname ('Method mname args ret) h + :<|> MethodsAPI pkg sname rest hs + servantMethodHandlers f pkgP snameP (Hmore _ _ h rest) = + servantMethodHandler + f + (Proxy @httpMethod) + (Proxy @httpStatus) + (Proxy @args) + (Proxy @ret) + (h NoRpcInfo ()) + :<|> servantMethodHandlers f pkgP snameP rest + +type family MethodAPI pkg sname method h where + MethodAPI pkg sname ('Method mname args ret) h = + PrefixRoute (RouteFor pkg sname mname) + ( HandlerAPI + (HttpMethodFor pkg sname mname) + (HttpStatusFor pkg sname mname) + args + ret + h + ) + +class + ServantMethodHandler + (httpMethod :: StdMethod) + (httpStatus :: Nat) + (m :: Type -> Type) + (args :: [Argument snm anm (TypeRef snm)]) + (ret :: Return snm (TypeRef snm)) + (h :: Type) where + type + HandlerAPI + httpMethod + httpStatus + args + ret + h + servantMethodHandler :: + (forall a. m a -> Handler a) -> + Proxy httpMethod -> + Proxy httpStatus -> + Proxy args -> + Proxy ret -> + h -> + Servant.Server (HandlerAPI httpMethod httpStatus args ret h) + +instance ServantMethodHandler httpMethod httpStatus m '[] 'RetNothing (m ()) where + type + HandlerAPI httpMethod httpStatus '[] 'RetNothing (m ()) = + -- according to https://github.com/haskell-servant/servant/issues/683 + -- we always need a content type for NoContent + Verb httpMethod httpStatus '[JSON] NoContent + servantMethodHandler f _ _ _ _ = fmap (const NoContent) . f + +instance ServantMethodHandler httpMethod httpStatus m '[] ('RetSingle rref) (m r) where + type + HandlerAPI httpMethod httpStatus '[] ('RetSingle rref) (m r) = + Verb httpMethod httpStatus (UnaryContentTypesFor rref) r + servantMethodHandler f _ _ _ _ = f + +instance + (MonadServer m) => + ServantMethodHandler httpMethod httpStatus m '[] ('RetStream rref) (ConduitT r Void m () -> m ()) + where + type + HandlerAPI httpMethod httpStatus '[] ('RetStream rref) (ConduitT r Void m () -> m ()) = + Stream httpMethod httpStatus (StreamFramingFor rref) (StreamContentTypeFor rref) (SourceIO (StreamResult r)) + servantMethodHandler f _ _ _ _ = liftIO . sinkToSource f + +-- | represents a single element that will be streamed from the server to the client. That element will either be a `Result` containing a return value, or an `Error` indicating that something went wrong. Without this wrapper, server streams that encountered an error after the response headers have been sent would simply terminate without communicating to the client that anything went wrong. +data StreamResult a = Error String | Result a + deriving (Generic, Show) + +instance Data.Swagger.ToSchema a => Data.Swagger.ToSchema (StreamResult a) +instance ToJSON a => ToJSON (StreamResult a) where + toJSON = gtoJson + +-- converts a conduit sink into a Servant SourceIO for interoperating with server streaming handlers +sinkToSource :: + forall r m. + (MonadServer m) => + (forall a. m a -> Handler a) -> + (ConduitT r Void m () -> m ()) -> + IO (SourceIO (StreamResult r)) +sinkToSource f sink = do + var <- newEmptyMVar :: IO (MVar (Maybe r)) + forwarder <- liftIO $ async $ do + e <- runHandler . f . sink $ toMVarConduit var + -- signal that the conduit finished + putMVar var Nothing + pure e + let step :: StepT IO (StreamResult r) + step = Effect $ do + nextOutput <- takeMVar var + case nextOutput of + Just r -> pure $ Yield (Result r) step + Nothing -> do + -- waiting on this thread should get us sync and async exceptions + res <- wait forwarder + case res of + Left err -> do + let streamErr = LB8.toString $ errBody err + pure $ Yield (Mu.Servant.Server.Error streamErr) Stop + Right () -> pure Stop + pure $ fromStepT step + +toMVarConduit :: MonadServer m => MVar (Maybe r) -> ConduitT r Void m () +toMVarConduit var = do + x <- await + case x of + Nothing -> pure () + Just _ -> do + liftIO $ putMVar var x + toMVarConduit var + +instance + (ServantMethodHandler httpMethod httpStatus m rest ret h) => + ServantMethodHandler httpMethod httpStatus m ('ArgSingle anm aref ': rest) ret (t -> h) + where + type + HandlerAPI httpMethod httpStatus ('ArgSingle anm aref ': rest) ret (t -> h) = + ReqBody (UnaryContentTypesFor aref) t :> HandlerAPI httpMethod httpStatus rest ret h + servantMethodHandler f mP sP _ retP h t = + servantMethodHandler f mP sP (Proxy @rest) retP (h t) + +instance + (MonadServer m, ServantMethodHandler httpMethod httpStatus m rest ret h) => + ServantMethodHandler httpMethod httpStatus m ('ArgStream anm aref ': rest) ret (ConduitT () t m () -> h) + where + type + HandlerAPI httpMethod httpStatus ('ArgStream anm aref ': rest) ret (ConduitT () t m () -> h) = + StreamBody (StreamFramingFor aref) (StreamContentTypeFor aref) (SourceIO t) + :> HandlerAPI httpMethod httpStatus rest ret h + servantMethodHandler f mP sP _ retP h = + servantMethodHandler f mP sP (Proxy @rest) retP . h . sourceToSource + +-- converts a Servant SourceIO into a conduit for interoperating with client streaming handlers +sourceToSource :: (MonadServer m) => SourceIO t -> ConduitT () t m () +sourceToSource (SourceT src) = ConduitT (PipeM (liftIO $ src (pure . go)) >>=) + where + go :: (MonadServer m) => StepT IO t -> Pipe i i t u m () + go Stop = Done () + go (Skip s) = go s + go (Yield t s) = HaveOutput (go s) t + go (Effect m) = PipeM (liftIO $ go <$> m) + go (Servant.Types.SourceT.Error msg) = + PipeM (throwError $ Mu.Server.ServerError Invalid ("error reading stream: " ++ msg)) + +-- | ServantRoute represents the URL path components of a route. It is used as an `AnnotatedPackage` domain to override the default path for a `Method`. When used in an `AnnService`, the specified `TopLevelRoute` is used as a prefix for all `Method`s in that `Service`. +-- 1. List of components for the route, +-- 2. HTTP method which must be used, +-- 3. HTTP status code of a successful HTTP response from a specific `Method`. Use 200 for the usual status code. +data ServantRoute + = ServantAdditional Type + | ServantTopLevelRoute [Symbol] + | ServantRoute [Symbol] StdMethod Nat + +type family Assert (err :: Constraint) (break :: k1) (a :: k2) :: k2 where + -- these cases exist to force evaluation of the "break" parameter when it either has kind [RpcAnnotation ...] or [Annotation ...] + Assert _ '[ 'AnnSchema a, 'AnnSchema a ] _ = Any + Assert _ '[ 'AnnPackage a, 'AnnPackage a ] _ = Any + -- this case should be used whenever "break" is not stuck + Assert _ _ a = a + +-- a helper type synonym used to provide better errors when a required AnnotatedPackage instance doesn't exist +type WithAnnotatedPackageInstance domain pkg a = + Assert (NoPackageAnnotations domain pkg) (AnnotatedPackage domain pkg) a + +-- a helper type synonym used to provide better errors when a required AnnotatedSchema instance doesn't exist +type WithAnnotatedSchemaInstance domain sch a = + Assert (NoSchemaAnnotations domain sch) (AnnotatedSchema domain sch) a + + +-- a helper type family for generating custom error messages about missing AnnotatedPackage instances +type family NoPackageAnnotations domain pkg :: Constraint where + NoPackageAnnotations domain ('Package ('Just pname) _) + = TypeError ( + 'Text "Missing required AnnotatedPackage " ':<>: 'ShowType domain ':<>: 'Text " type instance" ':$$: + 'Text "for " ':<>: 'ShowType pname ':<>: 'Text " package" + ) + NoPackageAnnotations domain pkg + = TypeError ( + 'Text "Missing required AnnotatedPackage " ':<>: 'ShowType domain ':<>: 'Text " type instance" ':$$: + 'Text "for unnamed package: " ':$$: 'ShowType pkg + ) + +-- a helper type family for generating custom error messages about missing AnnotatedSchema instances +type family NoSchemaAnnotations domain sch :: Constraint where + NoSchemaAnnotations domain sch + = TypeError ( + 'Text "Missing required AnnotatedSchema " ':<>: 'ShowType domain ':<>: 'Text " type instance" ':$$: + 'Text "for schema:" ':$$: 'ShowType sch + ) + +-- used to construct a route for a specific method m of service s in package pkg from the @AnnotatedPackage ServantRoute pkg@ instance, along with a custom error message +type family RouteFor (pkg :: Package snm mnm anm tyref) (s :: Symbol) (m :: Symbol) :: [Symbol] where + RouteFor pkg s m = + WithAnnotatedPackageInstance ServantRoute pkg ( + Concat + (UnwrapServantRoute (FromMaybe ('ServantRoute '[s] Any Any) (GetServiceAnnotationMay (AnnotatedPackage ServantRoute pkg) s))) + (UnwrapServantRoute (FromMaybe ('ServantRoute '[m] Any Any) (GetMethodAnnotationMay (AnnotatedPackage ServantRoute pkg) s m))) + ) + +type family UnwrapServantRoute s where + UnwrapServantRoute ('ServantTopLevelRoute s) = s + UnwrapServantRoute ('ServantRoute s _ _) = s + +type family ExtraFor (pkg :: Package snm mnm anm tyref) :: Type where + ExtraFor pkg = + WithAnnotatedPackageInstance ServantRoute pkg + (UnwrapServantExtra (FromMaybe ('ServantAdditional EmptyAPI) (GetPackageAnnotationMay (AnnotatedPackage ServantRoute pkg)))) + +type family UnwrapServantExtra s where + UnwrapServantExtra ('ServantAdditional e) = e + +type family FromMaybe (a :: k) (ma :: Maybe k) :: k where + FromMaybe a 'Nothing = a + FromMaybe _ ('Just a) = a + +type family Concat (as :: [k]) (bs :: [k]) :: [k] where + Concat '[] bs = bs + Concat (a ': as) bs = a ': Concat as bs + +type family PrefixRoute (prefix :: [Symbol]) route where + PrefixRoute '[] route = route + PrefixRoute (p ': rest) route = p :> PrefixRoute rest route + +-- | ServantContentTypes represents that acceptable content types that can be used when a message in encoded: +-- 1. in a unary (non-streaming) HTTP request\/response body, +-- 2. encoded in a streaming HTTP request\/response body. +-- It is used as an `AnnotatedSchema` domain. +data ServantContentTypes + = ServantContentTypes + { unary :: [Type] + , stream :: Maybe ServantStreamContentType + } + +type DefaultServantContentTypes + = 'ServantContentTypes '[JSON] ('Just ('ServantStreamContentType NewlineFraming JSON)) + +data ServantStreamContentType + = ServantStreamContentType + { framing :: Type, + streamContentType :: Type + } + +-- extracts a StdMethod from a ServantMethod annotation of a given method, defaulting to POST if such an annotation doesn't exist +type family HttpMethodFor pkg sname mname :: StdMethod where + HttpMethodFor pkg sname mname = + WithAnnotatedPackageInstance ServantRoute pkg ( + UnwrapServantMethod (FromMaybe ('ServantRoute Any 'POST Any) (GetMethodAnnotationMay (AnnotatedPackage ServantRoute pkg) sname mname)) + ) + +type family UnwrapServantMethod m where + UnwrapServantMethod ('ServantRoute _ m _) = m + +-- extracts the HTTP status code from the ServantStatus annotation of a given method, or defaults to 200 if such an annotation doesn't exist +type family HttpStatusFor pkg sname mname :: Nat where + HttpStatusFor pkg sname mname = + WithAnnotatedPackageInstance ServantRoute pkg ( + UnwrapServantStatus (FromMaybe ('ServantRoute Any Any 200) (GetMethodAnnotationMay (AnnotatedPackage ServantRoute pkg) sname mname)) + ) + +type family UnwrapServantStatus s where + UnwrapServantStatus ('ServantRoute _ _ s) = s + +-- extracts a list of content types from a ServantUnaryContentTypes annotation of a given method +type family UnaryContentTypesFor (tyRef :: TypeRef sname) :: [Type] where + UnaryContentTypesFor ('SchemaRef schema typeName) = + WithAnnotatedSchemaInstance ServantContentTypes schema ( + UnwrapServantUnaryContentType (GetTypeAnnotation (AnnotatedSchema ServantContentTypes schema) typeName) + ) + +type family UnwrapServantUnaryContentType (sctype :: ServantContentTypes) :: [Type] where + UnwrapServantUnaryContentType ('ServantContentTypes ctype stype) = ctype + +-- extracts a content type from a ServantStreamContentType annotation of a given method +type family StreamContentTypeFor (tyRef :: TypeRef sname) :: Type where + StreamContentTypeFor ('SchemaRef schema typeName) = + WithAnnotatedSchemaInstance ServantContentTypes schema ( + StreamContentType (GetTypeAnnotation (AnnotatedSchema ServantContentTypes schema) typeName) + ) + +type family StreamContentType (sct :: ServantContentTypes) where + StreamContentType ('ServantContentTypes _ 'Nothing) + = TypeError ('Text "missing stream content type") + StreamContentType ('ServantContentTypes _ ('Just ('ServantStreamContentType _ ctype))) = ctype + +-- extracts a framing from a ServantStreamContentType annotation of a given method +type family StreamFramingFor (tyRef :: TypeRef sname) :: Type where + StreamFramingFor ('SchemaRef schema typeName) = + WithAnnotatedSchemaInstance ServantContentTypes schema ( + StreamFraming (GetTypeAnnotation (AnnotatedSchema ServantContentTypes schema) typeName) + ) + +type family StreamFraming (sct :: ServantContentTypes) where + StreamFraming ('ServantContentTypes _ 'Nothing) + = TypeError ('Text "missing stream content type") + StreamFraming ('ServantContentTypes _ ('Just ('ServantStreamContentType framing _))) = framing diff --git a/stack-14.yaml b/stack-14.yaml new file mode 100644 index 00000000..87c8e895 --- /dev/null +++ b/stack-14.yaml @@ -0,0 +1,60 @@ +resolver: lts-14.27 +allow-newer: true + +packages: +- adapter/avro +- adapter/kafka +- adapter/persistent +- adapter/protobuf +- compendium-client +- core/lens +- core/optics +- core/rpc +- core/schema +- examples/health-check +- examples/library/backend +- examples/route-guide +- examples/seed +- examples/todolist +- examples/with-persistent +- graphql +- grpc/client +- grpc/common +- grpc/server +- instrumentation/prometheus +- instrumentation/tracing +- servant/server + +extra-deps: +- http2-client-0.9.0.0 +- http2-client-grpc-0.8.0.0 +- http2-grpc-proto3-wire-0.1.0.0 +- http2-grpc-types-0.5.0.0 +- proto3-wire-1.2.0 +- warp-grpc-0.4.0.1 +- hw-kafka-client-3.1.1 +- hw-kafka-conduit-2.7.0 +- tracing-control-0.0.6 +- wai-middleware-prometheus-1.0.0 +- graphql-0.11.0.0 +- generic-aeson-0.2.0.11 +- parameterized-0.5.0.0 +# Not in LTS 14 +- conduit-1.3.3 +- first-class-families-0.8.0.0 +- sop-core-0.5.0.1 +- primitive-0.7.0.1 +- regex-base-0.94.0.0 +- regex-tdfa-1.3.1.0 +# Dropped in LTS 16 +- primitive-extras-0.8 +- primitive-unlifted-0.1.3.0 +- stm-hamt-1.2.0.4 +- stm-containers-1.1.0.4 +- stm-lifted-2.5.0.0 +# Updated servant +- servant-0.18 +- servant-client-core-0.18 +- servant-client-0.18 +- servant-server-0.18 +- servant-swagger-1.1.10 diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 205b63a4..b9aab357 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -1,22 +1,37 @@ -resolver: nightly-2019-11-04 +resolver: nightly-2021-01-27 allow-newer: true packages: -- schema -- rpc -- grpc +- adapter/avro +- adapter/kafka +- adapter/persistent +- adapter/protobuf +- compendium-client +- core/lens +- core/optics +- core/rpc +- core/schema - examples/health-check +- examples/library/backend - examples/route-guide +- examples/seed +- examples/todolist +- examples/with-persistent +- graphql +- grpc/client +- grpc/common +- grpc/server +- instrumentation/prometheus +- instrumentation/tracing +- servant/server extra-deps: -- proto3-wire-1.0.0 - http2-client-0.9.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 +- http2-client-grpc-0.8.0.0 +- http2-grpc-proto3-wire-0.1.0.0 +- http2-grpc-types-0.5.0.0 +- proto3-wire-1.2.0 +- warp-grpc-0.4.0.1 +- hw-kafka-conduit-2.7.0 +- wai-middleware-prometheus-1.0.0 +- graphql-0.11.0.0 diff --git a/stack.yaml b/stack.yaml index b3e6c0bf..40cef67f 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,27 +1,38 @@ -resolver: lts-14.13 +resolver: lts-17.8 +allow-newer: true packages: -- schema -- rpc -- grpc +- adapter/avro +- adapter/kafka +- adapter/persistent +- adapter/protobuf +- compendium-client +- core/lens +- core/optics +- core/rpc +- core/schema - examples/health-check +- examples/library/backend - examples/route-guide +- examples/seed +- examples/todolist +- examples/error-parsing +- examples/with-persistent +- graphql +- grpc/client +- grpc/common +- grpc/server +- instrumentation/prometheus +- instrumentation/tracing +- servant/server extra-deps: -- proto3-wire-1.0.0 - http2-client-0.9.0.0 -- 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 +- http2-client-grpc-0.8.0.0 +- http2-grpc-proto3-wire-0.1.0.0 +- http2-grpc-types-0.5.0.0 +- proto3-wire-1.2.0 +- warp-grpc-0.4.0.1 +- hw-kafka-conduit-2.7.0 +- wai-middleware-prometheus-1.0.0 +- graphql-0.11.0.0 diff --git a/templates/graphql-server.hsfiles b/templates/graphql-server.hsfiles new file mode 100644 index 00000000..9aa33616 --- /dev/null +++ b/templates/graphql-server.hsfiles @@ -0,0 +1,96 @@ +{-# 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}}2020{{/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 + ghc-options: -Wall + default-language: Haskell2010 + build-depends: + base >=4.12 && <5 + , conduit + , mu-graphql >=0.4.1 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.1 + , text + , wai-extra + , warp + + +{-# START_FILE stack.yaml #-} +resolver: lts-16.22 +allow-newer: true +extra-deps: +- mu-schema-0.3.1.1 +- mu-rpc-0.4.0.1 +- mu-graphql-0.4.1.0 +- graphql-0.11.0.0 +- primitive-extras-0.8 +- primitive-unlifted-0.1.3.0 +- stm-hamt-1.2.0.4 +- stm-containers-1.1.0.4 +- stm-lifted-2.5.0.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 schema.graphql #-} +type Query { + hello: String +} + +{-# START_FILE src/Main.hs #-} +{-# language DataKinds #-} +{-# language FlexibleContexts #-} +{-# language OverloadedStrings #-} +{-# language PartialTypeSignatures #-} +{-# language PolyKinds #-} +{-# language ScopedTypeVariables #-} +{-# language TemplateHaskell #-} +{-# language TypeApplications #-} +{-# language TypeFamilies #-} +{-# language TypeOperators #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Main where + +import Data.Proxy + +import Mu.GraphQL.Quasi +import Mu.GraphQL.Server +import Mu.Server + +graphql "ServiceDefinition" "schema.graphql" + +-- GraphQL App + +main :: IO () +main = do + putStrLn "starting GraphQL server on port 8080" + runGraphQLAppQuery 8080 server (Proxy @"Query") + +type ServiceMapping = '[] + +server :: MonadServer m => ServerT ServiceMapping i ServiceDefinition m _ +server = resolver ( object @"Query" ( method @"hello" $ error "not implemented" ) ) diff --git a/templates/grpc-server-avro.hsfiles b/templates/grpc-server-avro.hsfiles new file mode 100644 index 00000000..b94efe45 --- /dev/null +++ b/templates/grpc-server-avro.hsfiles @@ -0,0 +1,119 @@ +{-# 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}}2020{{/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 + ghc-options: -Wall + default-language: Haskell2010 + build-depends: + base >=4.12 && <5 + , mu-avro >=0.4.0 + , mu-grpc-server >=0.4.0 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.1 + , text + +{-# START_FILE stack.yaml #-} +resolver: lts-16.22 +allow-newer: true +extra-deps: +# mu +- mu-schema-0.3.1.1 +- mu-rpc-0.4.0.1 +- mu-optics-0.3.0.1 +- mu-avro-0.4.0.2 +- mu-protobuf-0.4.0.3 +- mu-grpc-server-0.4.0.0 +- mu-grpc-common-0.4.0.0 +- compendium-client-0.2.1.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.4.0.1 +- proto3-wire-1.2.0 +- parameterized-0.5.0.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}}.avdl #-} +@namespace("{{name}}") +protocol 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 TypeFamilies #-} +{-# language TypeOperators #-} + +module Schema where + +-- import Data.Text as T +-- import GHC.Generics + +import Mu.Quasi.Avro +import Mu.Schema + +avdl "TheSchema" "TheService" "." "{{name}}.avdl" + +-- A. Map to Haskell types +-- data Message +-- = Message { ... } +-- deriving ( Eq, Show, Generic +-- , ToSchema TheSchema "Message" +-- , FromSchema TheSchema "Message" ) + +-- B. Use optics +type Message = Term TheSchema (TheSchema :/: "Message") + +{-# START_FILE src/Main.hs #-} +{-# language FlexibleContexts #-} +{-# language PartialTypeSignatures #-} +{-# language OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Main where + +import Mu.GRpc.Server +import Mu.Server + +import Schema + +main :: IO () +main = runGRpcApp msgAvro 8080 server + +server :: MonadServer m => SingleServerT i TheService m _ +server = singleService () diff --git a/templates/grpc-server-protobuf.hsfiles b/templates/grpc-server-protobuf.hsfiles new file mode 100644 index 00000000..a6143207 --- /dev/null +++ b/templates/grpc-server-protobuf.hsfiles @@ -0,0 +1,124 @@ +{-# 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}}2020{{/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 + ghc-options: -Wall + default-language: Haskell2010 + build-depends: + base >=4.12 && <5 + , mu-grpc-server >=0.4.0 + , mu-protobuf >=0.4.0 + , mu-rpc >=0.4.0 + , mu-schema >=0.3.1 + , text + +{-# START_FILE stack.yaml #-} +resolver: lts-16.22 +allow-newer: true +extra-deps: +# mu +- mu-schema-0.3.1.1 +- mu-rpc-0.4.0.1 +- mu-optics-0.3.0.1 +- mu-avro-0.4.0.2 +- mu-protobuf-0.4.0.3 +- mu-grpc-server-0.4.0.0 +- mu-grpc-common-0.4.0.0 +- compendium-client-0.2.1.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.4.0.1 +- proto3-wire-1.2.0 +- parameterized-0.5.0.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 TypeFamilies #-} +{-# language TypeOperators #-} + +module Schema where + +-- import Data.Text as T +-- import GHC.Generics + +import Mu.Quasi.GRpc +import Mu.Schema + +grpc "TheSchema" id "{{name}}.proto" + +-- A. Map to Haskell types +-- data Message +-- = Message { ... } +-- deriving ( Eq, Show, Generic +-- , ToSchema TheSchema "Message" +-- , FromSchema TheSchema "Message" ) + +-- B. Use optics +type Message = Term TheSchema (TheSchema :/: "Message") + +{-# START_FILE src/Main.hs #-} +{-# language FlexibleContexts #-} +{-# language PartialTypeSignatures #-} +{-# language OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} + +module Main where + +import Mu.GRpc.Server +import Mu.Server + +import Schema + +main :: IO () +main = runGRpcApp msgProtoBuf 8080 server + +server :: MonadServer m => SingleServerT i Service m _ +server = singleService () diff --git a/test-schema.sh b/test-schema.sh index ffe8cb8c..587fdcd6 100755 --- a/test-schema.sh +++ b/test-schema.sh @@ -1,24 +1,19 @@ #!/bin/sh - -# In order to run this script you need -# - avro for Python 3 https://avro.apache.org/releases.html -# - protobuf for Python 2 https://github.com/protocolbuffers/protobuf/releases/ -# 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 -stack exec test-avro dist/avro-haskell.avro dist/avro-python.avro +python3 adapter/avro/test/avro/generate.py adapter/avro/test/avro/example.avsc dist/avro-python.avro +stack 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 +# if protobuf is not installed, do so with 'pip install protobuf' echo "\nPROTOBUF\n========\n" echo "python/generate" -python schema/test/protobuf/generate.py dist/protobuf-python.pbuf +python2 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 +python2 adapter/protobuf/test/protobuf/consume.py dist/protobuf-haskell.pbuf diff --git a/test-templates.sh b/test-templates.sh new file mode 100755 index 00000000..6cd867d6 --- /dev/null +++ b/test-templates.sh @@ -0,0 +1,25 @@ +#!/bin/sh + +mkdir template-check +cd template-check + +# copy files (cannot use .. in Stack) +cp ../templates/*.hsfiles . + +stack new muavro grpc-server-avro.hsfiles -p "author-email:haskell.curry@47deg.com" -p "author-name:Haskell Curry" +cd muavro +stack build +cd .. + +stack new muprotobuf grpc-server-protobuf.hsfiles -p "author-email:haskell.curry@47deg.com" -p "author-name:Haskell Curry" +cd muprotobuf +stack build +cd .. + +stack new mugraphql graphql-server.hsfiles -p "author-email:haskell.curry@47deg.com" -p "author-name:Haskell Curry" +cd mugraphql +stack build +cd .. + +cd .. +rm -rf template-check