mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-09-11 14:36:01 +03:00
Run stylish-haskell in all files! 💅🏼 (#23)
* Run stylish-haskell in all files! 💅🏼
This commit is contained in:
Flavio Corpa
GitHub
parent
2cd09028a2
commit
e0910afd5f
10
.editorconfig
Normal file
10
.editorconfig
Normal file
@ -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
|
||||
4
.gitignore
vendored
4
.gitignore
vendored
@ -1,5 +1,5 @@
|
||||
stack*.yaml.lock
|
||||
.*
|
||||
.stack-work
|
||||
*~
|
||||
dist
|
||||
*.pyc
|
||||
*.pyc
|
||||
|
||||
63
.stylish-haskell.yaml
Normal file
63
.stylish-haskell.yaml
Normal file
@ -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
|
||||
26
DEVELOPMENT.md
Normal file
26
DEVELOPMENT.md
Normal file
@ -0,0 +1,26 @@
|
||||
# Development recommendations
|
||||
|
||||
Before continuing, make sure you've read:
|
||||
|
||||
- [Alejandro's post on setting up a Haskell development environment](https://www.47deg.com/blog/setting-up-haskell/).
|
||||
|
||||
## VSCode extensions
|
||||
|
||||
To make our lives easier while developing in Haskell, we use the following extensions:
|
||||
|
||||
- [ghcide](https://marketplace.visualstudio.com/items?itemName=DigitalAssetHoldingsLLC.ghcide), the best thing that happened to Haskell for editors/IDEs! ❤️
|
||||
- [hlint](https://marketplace.visualstudio.com/items?itemName=hoovercj.haskell-linter), another great extension to have suggestions and refactors in Haskell 🛠
|
||||
- [stylish-haskell](https://marketplace.visualstudio.com/items?itemName=vigoo.stylish-haskell), the formatter we use to prettify the code 💅🏼
|
||||
- [editorconfig](https://marketplace.visualstudio.com/items?itemName=EditorConfig.EditorConfig), to have consistency between different editors and envs 🐀
|
||||
|
||||
## stylish-haskell 💅🏼
|
||||
|
||||
Regarding the formatter, we use the `master` version of [stylish-haskell](https://github.com/jaspervdj/stylish-haskell) to be able to use language pragmas with lowercase, so you'll need to do this locally:
|
||||
|
||||
```sh
|
||||
$ git clone https://github.com/jaspervdj/stylish-haskell
|
||||
$ ...
|
||||
$ cd stylish-haskell && stack install
|
||||
```
|
||||
|
||||
Happy hacking! 👏🏼
|
||||
@ -1,30 +1,35 @@
|
||||
{-# language PolyKinds, DataKinds, GADTs,
|
||||
FlexibleInstances, FlexibleContexts,
|
||||
TypeApplications, TypeOperators,
|
||||
ScopedTypeVariables, RankNTypes,
|
||||
MultiParamTypeClasses,
|
||||
UndecidableInstances #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language RankNTypes #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Mu.Adapter.Avro where
|
||||
|
||||
import Control.Arrow ((***))
|
||||
import qualified Data.Avro as A
|
||||
import qualified Data.Avro.Schema as ASch
|
||||
import qualified Data.Avro.Types.Value as AVal
|
||||
import Control.Arrow ((***))
|
||||
import qualified Data.Avro as A
|
||||
import qualified Data.Avro.Schema as ASch
|
||||
import qualified Data.Avro.Types.Value as AVal
|
||||
-- 'Tagged . unTagged' can be replaced by 'coerce'
|
||||
-- eliminating some run-time overhead
|
||||
import Data.Coerce (coerce)
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.List.NonEmpty (NonEmpty(..))
|
||||
import qualified Data.List.NonEmpty as NonEmptyList
|
||||
import qualified Data.Map as M
|
||||
import Data.SOP (NP(..), NS(..))
|
||||
import Data.Tagged
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
import GHC.TypeLits
|
||||
import Data.Coerce (coerce)
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.List.NonEmpty (NonEmpty (..))
|
||||
import qualified Data.List.NonEmpty as NonEmptyList
|
||||
import qualified Data.Map as M
|
||||
import Data.SOP (NP (..), NS (..))
|
||||
import Data.Tagged
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
import GHC.TypeLits
|
||||
|
||||
import Mu.Schema
|
||||
import Mu.Schema
|
||||
import qualified Mu.Schema.Interpretation.Schemaless as SLess
|
||||
|
||||
instance SLess.ToSchemalessTerm (AVal.Value t) where
|
||||
@ -69,7 +74,7 @@ instance HasAvroSchemas sch sch
|
||||
instance (HasSchema sch sty t, HasAvroSchemas sch sch, A.FromAvro (Term sch (sch :/: sty)))
|
||||
=> A.FromAvro (WithSchema sch sty t) where
|
||||
fromAvro (AVal.Union _ _ v) = WithSchema . fromSchema' @sch <$> A.fromAvro v
|
||||
fromAvro v = ASch.badValue v "top-level"
|
||||
fromAvro v = ASch.badValue v "top-level"
|
||||
instance (HasSchema sch sty t, HasAvroSchemas sch sch, A.ToAvro (Term sch (sch :/: sty)))
|
||||
=> A.ToAvro (WithSchema sch sty t) where
|
||||
toAvro (WithSchema v) = AVal.Union (schemas (Proxy @sch) (Proxy @sch))
|
||||
@ -164,11 +169,11 @@ instance (KnownName name, HasAvroSchemaEnum fs)
|
||||
instance (KnownName name, HasAvroSchemaFields sch args, FromAvroFields sch args)
|
||||
=> A.FromAvro (Term sch ('DRecord name anns args)) where
|
||||
fromAvro (AVal.Record _ fields) = TRecord <$> fromAvroF fields
|
||||
fromAvro v = A.badValue v "record"
|
||||
fromAvro v = A.badValue v "record"
|
||||
instance (KnownName name, HasAvroSchemaEnum choices, FromAvroEnum choices)
|
||||
=> A.FromAvro (Term sch ('DEnum name anns choices)) where
|
||||
fromAvro v@(AVal.Enum _ n _) = TEnum <$> fromAvroEnum v n
|
||||
fromAvro v = A.badValue v "enum"
|
||||
fromAvro v = A.badValue v "enum"
|
||||
instance A.FromAvro (FieldValue sch t)
|
||||
=> A.FromAvro (Term sch ('DSimple t)) where
|
||||
fromAvro v = TSimple <$> A.fromAvro v
|
||||
@ -184,7 +189,7 @@ instance (KnownName t, A.FromAvro (Term sch (sch :/: t)))
|
||||
instance (HasAvroSchemaUnion (FieldValue sch) choices, FromAvroUnion sch choices)
|
||||
=> A.FromAvro (FieldValue sch ('TUnion choices)) where
|
||||
fromAvro (AVal.Union _ branch v) = FUnion <$> fromAvroU branch v
|
||||
fromAvro v = A.badValue v "union"
|
||||
fromAvro v = A.badValue v "union"
|
||||
instance A.FromAvro (FieldValue sch t)
|
||||
=> A.FromAvro (FieldValue sch ('TOption t)) where
|
||||
fromAvro v = FOption <$> A.fromAvro v
|
||||
@ -258,7 +263,7 @@ instance forall sch choices.
|
||||
toAvro (FUnion v) = AVal.Union wholeSchema' chosenTy chosenVal
|
||||
where wholeSchema = schemaU (Proxy @(FieldValue sch)) (Proxy @choices)
|
||||
wholeSchema' = V.fromList (NonEmptyList.toList wholeSchema)
|
||||
(chosenTy, chosenVal) = toAvroU v
|
||||
(chosenTy, chosenVal) = toAvroU v
|
||||
instance A.ToAvro (FieldValue sch t)
|
||||
=> A.ToAvro (FieldValue sch ('TOption t)) where
|
||||
toAvro (FOption v) = A.toAvro v
|
||||
@ -306,4 +311,4 @@ instance (KnownName name, A.ToAvro (FieldValue sch t), ToAvroFields sch fs)
|
||||
nameText :: KnownName s => proxy s -> T.Text
|
||||
nameText = T.pack . nameVal
|
||||
nameTypeName :: KnownName s => proxy s -> ASch.TypeName
|
||||
nameTypeName = ASch.parseFullname . nameText
|
||||
nameTypeName = ASch.parseFullname . nameText
|
||||
|
||||
@ -3,7 +3,7 @@
|
||||
|
||||
module Mu.Adapter.Avro.Example where
|
||||
|
||||
import Mu.Quasi.Avro (avro, avroFile)
|
||||
import Mu.Quasi.Avro (avro, avroFile)
|
||||
|
||||
type Example = [avro|
|
||||
{
|
||||
|
||||
@ -12,13 +12,13 @@ module Mu.Quasi.Avro (
|
||||
, schemaFromAvroType
|
||||
) where
|
||||
|
||||
import Data.Aeson (decode)
|
||||
import qualified Data.Avro.Schema as A
|
||||
import qualified Data.ByteString as B
|
||||
import Data.ByteString.Lazy.Char8 (pack)
|
||||
import Data.Aeson (decode)
|
||||
import qualified Data.Avro.Schema as A
|
||||
import qualified Data.ByteString as B
|
||||
import Data.ByteString.Lazy.Char8 (pack)
|
||||
import Data.Int
|
||||
import qualified Data.Text as T
|
||||
import Data.Vector (fromList, toList)
|
||||
import qualified Data.Text as T
|
||||
import Data.Vector (fromList, toList)
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Quote
|
||||
|
||||
@ -43,66 +43,75 @@ schemaFromAvroString s =
|
||||
Nothing -> fail "could not parse avro spec!"
|
||||
Just (A.Union us) -> schemaFromAvro (toList us)
|
||||
Just t -> schemaFromAvro [t]
|
||||
where schemaFromAvro = (typesToList <$>) . mapM schemaDecFromAvroType . flattenAvroDecls
|
||||
where
|
||||
schemaFromAvro =
|
||||
(typesToList <$>) . mapM schemaDecFromAvroType . flattenAvroDecls
|
||||
|
||||
schemaDecFromAvroType :: A.Type -> Q Type
|
||||
schemaDecFromAvroType (A.Record name _ _ _ fields) =
|
||||
[t|'DRecord $(textToStrLit $ A.baseName name) '[] $(typesToList <$> mapM avroFieldToType fields)|]
|
||||
where
|
||||
[t|'DRecord $(textToStrLit $ A.baseName name) '[] $(typesToList <$>
|
||||
mapM
|
||||
avroFieldToType
|
||||
fields)|]
|
||||
where
|
||||
avroFieldToType :: A.Field -> Q Type
|
||||
avroFieldToType field =
|
||||
[t|'FieldDef $(textToStrLit $ A.fldName field) '[] $(schemaFromAvroType $ A.fldType field)|]
|
||||
[t|'FieldDef $(textToStrLit $ A.fldName field) '[] $(schemaFromAvroType $
|
||||
A.fldType field)|]
|
||||
schemaDecFromAvroType (A.Enum name _ _ symbols) =
|
||||
[t|'DEnum $(textToStrLit $ A.baseName name) '[] $(typesToList <$> mapM avChoiceToType (toList symbols))|]
|
||||
[t|'DEnum $(textToStrLit $ A.baseName name) '[] $(typesToList <$>
|
||||
mapM
|
||||
avChoiceToType
|
||||
(toList symbols))|]
|
||||
where
|
||||
avChoiceToType :: T.Text -> Q Type
|
||||
avChoiceToType c = [t|'ChoiceDef $(textToStrLit c) '[]|]
|
||||
schemaDecFromAvroType t = [t| 'DSimple $(schemaFromAvroType t) |]
|
||||
schemaDecFromAvroType t = [t|'DSimple $(schemaFromAvroType t)|]
|
||||
|
||||
schemaFromAvroType :: A.Type -> Q Type
|
||||
schemaFromAvroType = \case
|
||||
A.Null -> [t|'TPrimitive 'TNull|]
|
||||
A.Boolean -> [t|'TPrimitive Bool|]
|
||||
A.Int -> [t|'TPrimitive Int32|]
|
||||
A.Long -> [t|'TPrimitive Int64|]
|
||||
A.Float -> [t|'TPrimitive Float|]
|
||||
A.Double -> [t|'TPrimitive Double|]
|
||||
A.Bytes -> [t|'TPrimitive B.ByteString|]
|
||||
A.String -> [t|'TPrimitive T.Text|]
|
||||
A.Array item -> [t|'TList $(schemaFromAvroType item)|]
|
||||
A.Map values -> [t|'TMap T.Text $(schemaFromAvroType values)|]
|
||||
A.NamedType typeName ->
|
||||
[t|'TSchematic $(textToStrLit (A.baseName typeName))|]
|
||||
A.Enum {} -> fail "should never happen, please, file an issue"
|
||||
A.Record {} -> fail "should never happen, please, file an issue"
|
||||
A.Union options ->
|
||||
case toList options of
|
||||
[A.Null, x] -> toOption x
|
||||
[x, A.Null] -> toOption x
|
||||
_ -> [t|'TUnion $(typesToList <$> mapM schemaFromAvroType (toList options))|]
|
||||
where toOption x = [t|'TOption $(schemaFromAvroType x)|]
|
||||
A.Fixed {} -> fail "fixed integers are not currently supported"
|
||||
schemaFromAvroType =
|
||||
\case
|
||||
A.Null -> [t|'TPrimitive 'TNull|]
|
||||
A.Boolean -> [t|'TPrimitive Bool|]
|
||||
A.Int -> [t|'TPrimitive Int32|]
|
||||
A.Long -> [t|'TPrimitive Int64|]
|
||||
A.Float -> [t|'TPrimitive Float|]
|
||||
A.Double -> [t|'TPrimitive Double|]
|
||||
A.Bytes -> [t|'TPrimitive B.ByteString|]
|
||||
A.String -> [t|'TPrimitive T.Text|]
|
||||
A.Array item -> [t|'TList $(schemaFromAvroType item)|]
|
||||
A.Map values -> [t|'TMap T.Text $(schemaFromAvroType values)|]
|
||||
A.NamedType typeName ->
|
||||
[t|'TSchematic $(textToStrLit (A.baseName typeName))|]
|
||||
A.Enum {} -> fail "should never happen, please, file an issue"
|
||||
A.Record {} -> fail "should never happen, please, file an issue"
|
||||
A.Union options ->
|
||||
case toList options of
|
||||
[A.Null, x] -> toOption x
|
||||
[x, A.Null] -> toOption x
|
||||
_ ->
|
||||
[t|'TUnion $(typesToList <$> mapM schemaFromAvroType (toList options))|]
|
||||
where toOption x = [t|'TOption $(schemaFromAvroType x)|]
|
||||
A.Fixed {} -> fail "fixed integers are not currently supported"
|
||||
|
||||
flattenAvroDecls :: [A.Type] -> [A.Type]
|
||||
flattenAvroDecls = concatMap (uncurry (:) . flattenDecl)
|
||||
where
|
||||
flattenDecl :: A.Type -> (A.Type, [A.Type])
|
||||
flattenDecl (A.Record name a d o fields) =
|
||||
flattenDecl (A.Record name a d o fields) =
|
||||
let (flds, tts) = unzip (flattenAvroField <$> fields)
|
||||
in (A.Record name a d o flds, concat tts)
|
||||
flattenDecl (A.Union _) = error "should never happen, please, file an issue"
|
||||
in (A.Record name a d o flds, concat tts)
|
||||
flattenDecl (A.Union _) = error "should never happen, please, file an issue"
|
||||
flattenDecl t = (t, [])
|
||||
|
||||
flattenAvroType :: A.Type -> (A.Type, [A.Type])
|
||||
flattenAvroType (A.Record name a d o fields) =
|
||||
flattenAvroType (A.Record name a d o fields) =
|
||||
let (flds, tts) = unzip (flattenAvroField <$> fields)
|
||||
in (A.NamedType name, A.Record name a d o flds : concat tts)
|
||||
flattenAvroType (A.Union (toList -> ts)) =
|
||||
in (A.NamedType name, A.Record name a d o flds : concat tts)
|
||||
flattenAvroType (A.Union (toList -> ts)) =
|
||||
let (us, tts) = unzip (map flattenAvroType ts)
|
||||
in (A.Union $ fromList us, concat tts)
|
||||
in (A.Union $ fromList us, concat tts)
|
||||
flattenAvroType e@A.Enum {A.name} = (A.NamedType name, [e])
|
||||
flattenAvroType t = (t, [])
|
||||
|
||||
flattenAvroField :: A.Field -> (A.Field, [A.Type])
|
||||
flattenAvroField f =
|
||||
let (t, decs) = flattenAvroType (A.fldType f)
|
||||
|
||||
@ -1,16 +1,18 @@
|
||||
{-# language OverloadedStrings, TypeApplications,
|
||||
NamedFieldPuns, DataKinds,
|
||||
StandaloneDeriving, DerivingVia #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language DerivingVia #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language StandaloneDeriving #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# options_ghc -fno-warn-orphans #-}
|
||||
module Main where
|
||||
|
||||
import Data.Avro
|
||||
import Data.Avro
|
||||
import qualified Data.ByteString.Lazy as BS
|
||||
import System.Environment
|
||||
import System.Environment
|
||||
|
||||
import Mu.Schema (WithSchema(..))
|
||||
import Mu.Adapter.Avro ()
|
||||
import Mu.Schema.Examples
|
||||
import Mu.Adapter.Avro ()
|
||||
import Mu.Schema (WithSchema (..))
|
||||
import Mu.Schema.Examples
|
||||
|
||||
exampleAddress :: Address
|
||||
exampleAddress = Address "1111BB" "Spain"
|
||||
@ -20,19 +22,19 @@ examplePerson1 = Person "Haskellio" "Gómez" (Just 30) (Just Male) exampleAddres
|
||||
examplePerson2 = Person "Cuarenta" "Siete" Nothing Nothing exampleAddress
|
||||
|
||||
deriving via (WithSchema ExampleSchema "person" Person) instance HasAvroSchema Person
|
||||
deriving via (WithSchema ExampleSchema "person" Person) instance FromAvro Person
|
||||
deriving via (WithSchema ExampleSchema "person" Person) instance ToAvro Person
|
||||
deriving via (WithSchema ExampleSchema "person" Person) instance FromAvro Person
|
||||
deriving via (WithSchema ExampleSchema "person" Person) instance ToAvro Person
|
||||
|
||||
main :: IO ()
|
||||
main = do -- Obtain the filenames
|
||||
[genFile, conFile] <- getArgs
|
||||
-- Read the file produced by Python
|
||||
putStrLn "haskell/consume"
|
||||
cbs <- BS.readFile conFile
|
||||
let [people] = decodeContainer @Person cbs
|
||||
print people
|
||||
-- Encode a couple of values
|
||||
putStrLn "haskell/generate"
|
||||
print [examplePerson1, examplePerson2]
|
||||
gbs <- encodeContainer [[examplePerson1, examplePerson2]]
|
||||
BS.writeFile genFile gbs
|
||||
[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
|
||||
|
||||
@ -1,11 +1,17 @@
|
||||
{-# language PolyKinds, DataKinds, GADTs,
|
||||
TypeFamilies, TypeOperators,
|
||||
MultiParamTypeClasses,
|
||||
FlexibleInstances, FlexibleContexts,
|
||||
ScopedTypeVariables, TypeApplications,
|
||||
UndecidableInstances,
|
||||
OverloadedStrings, ConstraintKinds,
|
||||
AllowAmbiguousTypes #-}
|
||||
{-# language AllowAmbiguousTypes #-}
|
||||
{-# language ConstraintKinds #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Mu.Adapter.ProtoBuf (
|
||||
-- * Custom annotations
|
||||
@ -23,23 +29,23 @@ module Mu.Adapter.ProtoBuf (
|
||||
, parseProtoBufWithRegistry
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Int
|
||||
import Data.Kind
|
||||
import Data.SOP (All)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as LT
|
||||
import GHC.TypeLits
|
||||
import Proto3.Wire
|
||||
import qualified Proto3.Wire.Encode as PBEnc
|
||||
import qualified Proto3.Wire.Decode as PBDec
|
||||
import Control.Applicative
|
||||
import qualified Data.ByteString as BS
|
||||
import Data.Int
|
||||
import Data.Kind
|
||||
import Data.SOP (All)
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Lazy as LT
|
||||
import GHC.TypeLits
|
||||
import Proto3.Wire
|
||||
import qualified Proto3.Wire.Decode as PBDec
|
||||
import qualified Proto3.Wire.Encode as PBEnc
|
||||
|
||||
import Mu.Schema.Annotations
|
||||
import Mu.Schema.Definition
|
||||
import Mu.Schema.Interpretation
|
||||
import Mu.Schema.Class
|
||||
import qualified Mu.Schema.Registry as R
|
||||
import Mu.Schema.Annotations
|
||||
import Mu.Schema.Class
|
||||
import Mu.Schema.Definition
|
||||
import Mu.Schema.Interpretation
|
||||
import qualified Mu.Schema.Registry as R
|
||||
|
||||
type family FindProtoBufId (f :: fn) (xs :: [Type]) :: Nat where
|
||||
FindProtoBufId f '[]
|
||||
@ -51,7 +57,7 @@ type family FindProtoBufOneOfIds (f :: fn) (xs :: [Type]) :: [Nat] where
|
||||
FindProtoBufOneOfIds f '[]
|
||||
= TypeError ('Text "protocol buffers ids not available for oneof field " ':<>: 'ShowType f)
|
||||
FindProtoBufOneOfIds f (ProtoBufOneOfIds n ': rest) = n
|
||||
FindProtoBufOneOfIds f (other ': rest) = FindProtoBufOneOfIds f rest
|
||||
FindProtoBufOneOfIds f (other ': rest) = FindProtoBufOneOfIds f rest
|
||||
|
||||
-- CONVERSION USING SCHEMAS
|
||||
|
||||
@ -78,13 +84,13 @@ parseProtoViaSchema = PBDec.parse (fromProtoViaSchema @_ @_ @sch)
|
||||
-- CONVERSION USING REGISTRY
|
||||
|
||||
fromProtoBufWithRegistry
|
||||
:: forall (r :: R.Registry) t.
|
||||
:: forall (r :: R.Registry) t.
|
||||
FromProtoBufRegistry r t
|
||||
=> PBDec.Parser PBDec.RawMessage t
|
||||
fromProtoBufWithRegistry = fromProtoBufRegistry' (Proxy @r)
|
||||
|
||||
parseProtoBufWithRegistry
|
||||
:: forall (r :: R.Registry) t.
|
||||
:: forall (r :: R.Registry) t.
|
||||
FromProtoBufRegistry r t
|
||||
=> BS.ByteString -> Either PBDec.ParseError t
|
||||
parseProtoBufWithRegistry = PBDec.parse (fromProtoBufWithRegistry @r)
|
||||
@ -148,7 +154,7 @@ instance (All (ProtoBridgeField sch) args, ProtoBridgeFields sch args)
|
||||
termToProto (TRecord fields) = go fields
|
||||
where go :: forall fs. All (ProtoBridgeField sch) fs
|
||||
=> NP (Field sch) fs -> PBEnc.MessageBuilder
|
||||
go Nil = mempty
|
||||
go Nil = mempty
|
||||
go (f :* fs) = fieldToProto f <> go fs
|
||||
protoToTerm = TRecord <$> protoToFields
|
||||
|
||||
@ -361,4 +367,4 @@ instance ( ProtoBridgeFieldValue sch t, KnownNat thisId
|
||||
unionFieldValueToProto (S v) = unionFieldValueToProto @_ @_ @restIds v
|
||||
protoToUnionFieldValue
|
||||
= Z <$> protoToFieldValue `at` fieldId <|> S <$> protoToUnionFieldValue @_ @_ @restIds
|
||||
where fieldId = fromInteger $ natVal (Proxy @thisId)
|
||||
where fieldId = fromInteger $ natVal (Proxy @thisId)
|
||||
|
||||
@ -1,7 +1,8 @@
|
||||
{-# language QuasiQuotes, DataKinds #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language QuasiQuotes #-}
|
||||
module Mu.Adapter.ProtoBuf.Example where
|
||||
|
||||
import Mu.Quasi.ProtoBuf
|
||||
import Mu.Quasi.ProtoBuf
|
||||
|
||||
type ExampleProtoBufSchema = [protobuf|
|
||||
enum gender {
|
||||
@ -14,4 +15,4 @@ message person {
|
||||
int age = 2;
|
||||
gender gender = 3;
|
||||
}
|
||||
|]
|
||||
|]
|
||||
|
||||
@ -1,20 +1,23 @@
|
||||
{-# language PolyKinds, DataKinds,
|
||||
MultiParamTypeClasses,
|
||||
ScopedTypeVariables, TypeApplications,
|
||||
FlexibleInstances, FlexibleContexts,
|
||||
UndecidableInstances #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints -fno-warn-orphans #-}
|
||||
module Mu.Adapter.ProtoBuf.Via where
|
||||
|
||||
import Network.GRPC.HTTP2.Proto3Wire
|
||||
import qualified Proto3.Wire.Encode as PBEnc
|
||||
import qualified Proto3.Wire.Decode as PBDec
|
||||
import Network.GRPC.HTTP2.Proto3Wire
|
||||
import qualified Proto3.Wire.Decode as PBDec
|
||||
import qualified Proto3.Wire.Encode as PBEnc
|
||||
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
import Mu.Adapter.ProtoBuf
|
||||
import Mu.Adapter.ProtoBuf
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
|
||||
newtype ViaProtoBufTypeRef (ref :: TypeRef) t
|
||||
newtype ViaProtoBufTypeRef (ref :: TypeRef) t
|
||||
= ViaProtoBufTypeRef { unViaProtoBufTypeRef :: t }
|
||||
|
||||
instance ProtoBufTypeRef ref t
|
||||
@ -39,4 +42,4 @@ instance ( FromProtoBufRegistry r t
|
||||
, HasProtoSchema (MappingRight r last) sty t)
|
||||
=> ProtoBufTypeRef ('FromRegistry r t last) t where
|
||||
fromProtoBufTypeRef _ = fromProtoBufWithRegistry @r
|
||||
toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @(MappingRight r last)
|
||||
toProtoBufTypeRef _ = toProtoViaSchema @_ @_ @(MappingRight r last)
|
||||
|
||||
@ -1,21 +1,23 @@
|
||||
{-# language TemplateHaskell, DataKinds, OverloadedStrings #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language TemplateHaskell #-}
|
||||
-- | Read a @.proto@ file as a 'Service'
|
||||
module Mu.Quasi.GRpc (
|
||||
grpc
|
||||
, compendium
|
||||
) where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.Text as T
|
||||
import Language.Haskell.TH
|
||||
import qualified Language.ProtocolBuffers.Types as P
|
||||
import Language.ProtocolBuffers.Parser
|
||||
import Network.HTTP.Client
|
||||
import Servant.Client.Core.BaseUrl
|
||||
import Control.Monad.IO.Class
|
||||
import qualified Data.Text as T
|
||||
import Language.Haskell.TH
|
||||
import Language.ProtocolBuffers.Parser
|
||||
import qualified Language.ProtocolBuffers.Types as P
|
||||
import Network.HTTP.Client
|
||||
import Servant.Client.Core.BaseUrl
|
||||
|
||||
import Mu.Quasi.ProtoBuf
|
||||
import Mu.Rpc
|
||||
import Compendium.Client
|
||||
import Compendium.Client
|
||||
import Mu.Quasi.ProtoBuf
|
||||
import Mu.Rpc
|
||||
|
||||
-- | Reads a @.proto@ file and generates:
|
||||
-- * A 'Schema' with all the message types, using the
|
||||
@ -88,7 +90,7 @@ pbMethodToType s (P.Method nm vr v rr r _)
|
||||
= [t| 'RetStream ('FromSchema $(schemaTy s) $(textToStrLit (last a))) |]
|
||||
retToType _ _
|
||||
= fail "only message types may be used as results"
|
||||
|
||||
|
||||
schemaTy :: Name -> Q Type
|
||||
schemaTy schema = return $ ConT schema
|
||||
|
||||
@ -97,4 +99,4 @@ typesToList
|
||||
= foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
|
||||
textToStrLit :: T.Text -> Q Type
|
||||
textToStrLit s
|
||||
= return $ LitT $ StrTyLit $ T.unpack s
|
||||
= return $ LitT $ StrTyLit $ T.unpack s
|
||||
|
||||
@ -2,7 +2,6 @@
|
||||
{-# language LambdaCase #-}
|
||||
{-# language NamedFieldPuns #-}
|
||||
{-# language TemplateHaskell #-}
|
||||
{-# language ViewPatterns #-}
|
||||
|
||||
module Mu.Quasi.ProtoBuf (
|
||||
-- * Quasi-quoters for @.proto@ files
|
||||
@ -83,22 +82,22 @@ pbTypeDeclToType (P.DMessage name _ _ fields _) =
|
||||
= [t| 'FieldDef $(textToStrLit nm)
|
||||
'[ ProtoBufOneOfIds $(typesToList <$> mapM (intToLit . getFieldNumber) vs ) ]
|
||||
$(typesToList <$> mapM pbOneOfFieldToType vs ) |]
|
||||
|
||||
|
||||
pbFieldTypeToType :: P.FieldType -> Q Type
|
||||
pbFieldTypeToType P.TInt32 = [t|'TPrimitive Int32|]
|
||||
pbFieldTypeToType P.TUInt32 = fail "unsigned integers are not currently supported"
|
||||
pbFieldTypeToType P.TSInt32 = [t|'TPrimitive Int32|]
|
||||
pbFieldTypeToType P.TInt64 = [t|'TPrimitive Int64|]
|
||||
pbFieldTypeToType P.TUInt64 = fail "unsigned integers are not currently supported"
|
||||
pbFieldTypeToType P.TSInt64 = [t|'TPrimitive Int64|]
|
||||
pbFieldTypeToType P.TFixed32 = fail "fixed integers are not currently supported"
|
||||
pbFieldTypeToType P.TFixed64 = fail "fixed integers are not currently supported"
|
||||
pbFieldTypeToType P.TSFixed32 = fail "fixed integers are not currently supported"
|
||||
pbFieldTypeToType P.TSFixed64 = fail "fixed integers are not currently supported"
|
||||
pbFieldTypeToType P.TDouble = [t|'TPrimitive Double|]
|
||||
pbFieldTypeToType P.TBool = [t|'TPrimitive Bool|]
|
||||
pbFieldTypeToType P.TString = [t|'TPrimitive T.Text|]
|
||||
pbFieldTypeToType P.TBytes = [t|'TPrimitive B.ByteString|]
|
||||
pbFieldTypeToType P.TInt32 = [t|'TPrimitive Int32|]
|
||||
pbFieldTypeToType P.TUInt32 = fail "unsigned integers are not currently supported"
|
||||
pbFieldTypeToType P.TSInt32 = [t|'TPrimitive Int32|]
|
||||
pbFieldTypeToType P.TInt64 = [t|'TPrimitive Int64|]
|
||||
pbFieldTypeToType P.TUInt64 = fail "unsigned integers are not currently supported"
|
||||
pbFieldTypeToType P.TSInt64 = [t|'TPrimitive Int64|]
|
||||
pbFieldTypeToType P.TFixed32 = fail "fixed integers are not currently supported"
|
||||
pbFieldTypeToType P.TFixed64 = fail "fixed integers are not currently supported"
|
||||
pbFieldTypeToType P.TSFixed32 = fail "fixed integers are not currently supported"
|
||||
pbFieldTypeToType P.TSFixed64 = fail "fixed integers are not currently supported"
|
||||
pbFieldTypeToType P.TDouble = [t|'TPrimitive Double|]
|
||||
pbFieldTypeToType P.TBool = [t|'TPrimitive Bool|]
|
||||
pbFieldTypeToType P.TString = [t|'TPrimitive T.Text|]
|
||||
pbFieldTypeToType P.TBytes = [t|'TPrimitive B.ByteString|]
|
||||
pbFieldTypeToType (P.TOther t) = [t|'TSchematic $(textToStrLit (last t))|]
|
||||
|
||||
hasFieldNumber P.NormalField {} = True
|
||||
|
||||
@ -1,15 +1,17 @@
|
||||
{-# language OverloadedStrings, TypeApplications, ScopedTypeVariables #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
module Main where
|
||||
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString as BS
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
import qualified Proto3.Wire.Decode as PBDec
|
||||
import qualified Proto3.Wire.Encode as PBEnc
|
||||
import System.Environment
|
||||
import qualified Proto3.Wire.Decode as PBDec
|
||||
import qualified Proto3.Wire.Encode as PBEnc
|
||||
import System.Environment
|
||||
|
||||
import Mu.Schema ()
|
||||
import Mu.Adapter.ProtoBuf
|
||||
import Mu.Schema.Examples
|
||||
import Mu.Adapter.ProtoBuf
|
||||
import Mu.Schema ()
|
||||
import Mu.Schema.Examples
|
||||
|
||||
exampleAddress :: Address
|
||||
exampleAddress = Address "1111BB" "Spain"
|
||||
@ -20,14 +22,14 @@ examplePerson2 = Person "Cuarenta" "Siete" Nothing Nothing exampleAddress
|
||||
|
||||
main :: IO ()
|
||||
main = do -- Obtain the filenames
|
||||
[genFile, conFile] <- getArgs
|
||||
-- Read the file produced by Python
|
||||
putStrLn "haskell/consume"
|
||||
cbs <- BS.readFile conFile
|
||||
let Right people = PBDec.parse (fromProtoViaSchema @_ @_ @ExampleSchema) cbs
|
||||
print (people :: Person)
|
||||
-- Encode a couple of values
|
||||
putStrLn "haskell/generate"
|
||||
print examplePerson1
|
||||
let gbs = PBEnc.toLazyByteString (toProtoViaSchema @_ @_ @ExampleSchema examplePerson1)
|
||||
LBS.writeFile genFile gbs
|
||||
[genFile, conFile] <- getArgs
|
||||
-- Read the file produced by Python
|
||||
putStrLn "haskell/consume"
|
||||
cbs <- BS.readFile conFile
|
||||
let Right people = PBDec.parse (fromProtoViaSchema @_ @_ @ExampleSchema) cbs
|
||||
print (people :: Person)
|
||||
-- Encode a couple of values
|
||||
putStrLn "haskell/generate"
|
||||
print examplePerson1
|
||||
let gbs = PBEnc.toLazyByteString (toProtoViaSchema @_ @_ @ExampleSchema examplePerson1)
|
||||
LBS.writeFile genFile gbs
|
||||
|
||||
@ -12,17 +12,21 @@ maintainer: alejandro.serrano@47deg.com
|
||||
-- copyright:
|
||||
category: Network
|
||||
build-type: Simple
|
||||
-- extra-source-files: README.md, CHANGELOG.md
|
||||
extra-source-files: README.md, CHANGELOG.md
|
||||
|
||||
library
|
||||
exposed-modules: Compendium.Client
|
||||
-- other-modules:
|
||||
-- other-extensions:
|
||||
build-depends: base >=4.12 && <5,
|
||||
aeson, text,
|
||||
http-client,
|
||||
servant, servant-client,
|
||||
megaparsec, language-protobuf
|
||||
build-depends: base >=4.12 && <5
|
||||
, aeson
|
||||
, text
|
||||
, http-client
|
||||
, servant
|
||||
, servant-client
|
||||
, megaparsec
|
||||
, language-protobuf
|
||||
hs-source-dirs: src
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -fprint-potential-instances
|
||||
ghc-options: -Wall
|
||||
-fprint-potential-instances
|
||||
|
||||
@ -1,30 +1,33 @@
|
||||
{-# language DataKinds, TypeOperators,
|
||||
DeriveGeneric, DeriveAnyClass,
|
||||
ViewPatterns, TypeApplications #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language DeriveAnyClass #-}
|
||||
{-# language DeriveGeneric #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language ViewPatterns #-}
|
||||
module Compendium.Client where
|
||||
|
||||
import Data.Aeson
|
||||
import Data.Char
|
||||
import Data.Proxy
|
||||
import Data.Text
|
||||
import Language.ProtocolBuffers.Types
|
||||
import Language.ProtocolBuffers.Parser
|
||||
import Network.HTTP.Client (Manager)
|
||||
import Servant.API
|
||||
import Servant.Client
|
||||
import Text.Megaparsec
|
||||
import Data.Aeson
|
||||
import Data.Char
|
||||
import Data.Proxy
|
||||
import Data.Text
|
||||
import Language.ProtocolBuffers.Parser
|
||||
import Language.ProtocolBuffers.Types
|
||||
import Network.HTTP.Client (Manager)
|
||||
import Servant.API
|
||||
import Servant.Client
|
||||
import Text.Megaparsec
|
||||
|
||||
import GHC.Generics
|
||||
import GHC.Generics
|
||||
|
||||
newtype Protocol
|
||||
= Protocol { raw :: Text }
|
||||
deriving (Eq, Show, Generic, FromJSON)
|
||||
|
||||
|
||||
data IdlName
|
||||
= Avro | Protobuf | Mu | OpenApi | Scala
|
||||
deriving (Eq, Show, Generic)
|
||||
instance ToHttpApiData IdlName where
|
||||
toQueryParam (show -> x:xs)
|
||||
toQueryParam (show -> x:xs)
|
||||
= pack $ Data.Char.toLower x : xs
|
||||
toQueryParam _ = error "this should never happen"
|
||||
|
||||
@ -50,12 +53,12 @@ data ObtainProtoBufError
|
||||
|
||||
obtainProtoBuf :: Manager -> BaseUrl
|
||||
-> Text -> IO (Either ObtainProtoBufError ProtoBuf)
|
||||
obtainProtoBuf m url ident
|
||||
= do r <- transformation m url ident Protobuf
|
||||
case r of
|
||||
Left e
|
||||
-> return $ Left (OPEClient e)
|
||||
Right (Protocol p)
|
||||
-> case parseProtoBuf p of
|
||||
Left e -> return $ Left (OPEParse e)
|
||||
Right pb -> return $ Right pb
|
||||
obtainProtoBuf m url ident = do
|
||||
r <- transformation m url ident Protobuf
|
||||
case r of
|
||||
Left e
|
||||
-> return $ Left (OPEClient e)
|
||||
Right (Protocol p)
|
||||
-> case parseProtoBuf p of
|
||||
Left e -> return $ Left (OPEParse e)
|
||||
Right pb -> return $ Right pb
|
||||
|
||||
@ -1,8 +1,11 @@
|
||||
{-# language DataKinds, PolyKinds,
|
||||
GADTs, ExistentialQuantification,
|
||||
TypeFamilies, ConstraintKinds,
|
||||
TypeOperators,
|
||||
UndecidableInstances #-}
|
||||
{-# language ConstraintKinds #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language ExistentialQuantification #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
-- | Protocol-independent declaration of services
|
||||
module Mu.Rpc (
|
||||
Service', Service(..)
|
||||
@ -11,12 +14,12 @@ module Mu.Rpc (
|
||||
, TypeRef(..), Argument(..), Return(..)
|
||||
) where
|
||||
|
||||
import Data.Kind
|
||||
import GHC.TypeLits
|
||||
import Data.Kind
|
||||
import GHC.TypeLits
|
||||
import qualified Language.Haskell.TH as TH
|
||||
|
||||
import Mu.Schema
|
||||
import Mu.Schema.Registry
|
||||
import Mu.Schema
|
||||
import Mu.Schema.Registry
|
||||
|
||||
type Service' = Service Symbol Symbol
|
||||
|
||||
@ -74,4 +77,4 @@ data Return where
|
||||
RetThrows :: TypeRef -> TypeRef -> Return
|
||||
-- | Return a stream of values
|
||||
-- (this can be found in gRPC).
|
||||
RetStream :: TypeRef -> Return
|
||||
RetStream :: TypeRef -> Return
|
||||
|
||||
@ -1,19 +1,25 @@
|
||||
{-# language PolyKinds, DataKinds, GADTs,
|
||||
MultiParamTypeClasses,
|
||||
FlexibleInstances, OverloadedStrings,
|
||||
DeriveGeneric, DeriveAnyClass, TypeOperators,
|
||||
PartialTypeSignatures, TypeFamilies #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language DeriveAnyClass #-}
|
||||
{-# language DeriveGeneric #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language PartialTypeSignatures #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Mu.Rpc.Examples where
|
||||
|
||||
import Data.Conduit
|
||||
import Data.Conduit.Combinators as C
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
import Data.Conduit
|
||||
import Data.Conduit.Combinators as C
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
|
||||
import Mu.Schema
|
||||
import Mu.Rpc
|
||||
import Mu.Server
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
import Mu.Server
|
||||
|
||||
-- Defines the service from gRPC Quickstart
|
||||
-- https://grpc.io/docs/quickstart/python/
|
||||
@ -59,4 +65,4 @@ quickstartServer
|
||||
-> ConduitT HelloResponse Void IO ()
|
||||
-> IO ()
|
||||
sayManyHellos source sink
|
||||
= runConduit $ source .| C.mapM sayHello .| sink
|
||||
= runConduit $ source .| C.mapM sayHello .| sink
|
||||
|
||||
@ -1,12 +1,14 @@
|
||||
{-# language DataKinds, PolyKinds,
|
||||
GADTs, TypeFamilies,
|
||||
ExistentialQuantification,
|
||||
MultiParamTypeClasses,
|
||||
FlexibleInstances,
|
||||
UndecidableInstances,
|
||||
TypeOperators,
|
||||
ConstraintKinds,
|
||||
RankNTypes #-}
|
||||
{-# language ConstraintKinds #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language ExistentialQuantification #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language RankNTypes #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
-- | Protocol-independent declaration of servers.
|
||||
--
|
||||
-- A server (represented by 'ServerIO' and in general
|
||||
@ -29,11 +31,11 @@ module Mu.Server (
|
||||
, HandlersIO, HandlersT(..)
|
||||
) where
|
||||
|
||||
import Data.Conduit
|
||||
import Data.Kind
|
||||
import Data.Conduit
|
||||
import Data.Kind
|
||||
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
|
||||
data ServerT (s :: Service snm mnm) (m :: Type -> Type) (hs :: [Type]) where
|
||||
Server :: HandlersT methods m hs -> ServerT ('Service sname anns methods) m hs
|
||||
@ -67,4 +69,4 @@ instance (HandlesRef eref e, HandlesRef vref v, handler ~ m (Either e v))
|
||||
instance (HandlesRef ref v, handler ~ m v)
|
||||
=> Handles '[] ('RetSingle ref) m handler
|
||||
instance (HandlesRef ref v, handler ~ (ConduitT v Void m () -> m ()))
|
||||
=> Handles '[] ('RetStream ref) m handler
|
||||
=> Handles '[] ('RetStream ref) m handler
|
||||
|
||||
@ -1,22 +1,26 @@
|
||||
{-# language PolyKinds, DataKinds, GADTs,
|
||||
TypeOperators, ScopedTypeVariables,
|
||||
MultiParamTypeClasses,
|
||||
FlexibleInstances, FlexibleContexts,
|
||||
TypeApplications,
|
||||
UndecidableInstances #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Mu.Adapter.Json where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
import Data.Functor.Contravariant
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.SOP (NS(..), NP(..))
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.Aeson
|
||||
import Data.Aeson.Types
|
||||
import Data.Functor.Contravariant
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.SOP (NP (..), NS (..))
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
|
||||
import Mu.Schema
|
||||
import Mu.Schema
|
||||
import qualified Mu.Schema.Interpretation.Schemaless as SLess
|
||||
|
||||
instance SLess.ToSchemalessTerm Value where
|
||||
@ -46,7 +50,7 @@ instance ToJSONFields sch args => ToJSON (Term sch ('DRecord name anns args)) wh
|
||||
toJSON (TRecord fields) = Object (toJSONFields fields)
|
||||
instance FromJSONFields sch args => FromJSON (Term sch ('DRecord name anns args)) where
|
||||
parseJSON (Object v) = TRecord <$> parseJSONFields v
|
||||
parseJSON _ = fail "expected object"
|
||||
parseJSON _ = fail "expected object"
|
||||
|
||||
class ToJSONFields sch fields where
|
||||
toJSONFields :: NP (Field sch) fields -> Object
|
||||
@ -71,7 +75,7 @@ instance ToJSONEnum choices => ToJSON (Term sch ('DEnum name anns choices)) wher
|
||||
toJSON (TEnum choice) = String (toJSONEnum choice)
|
||||
instance FromJSONEnum choices => FromJSON (Term sch ('DEnum name anns choices)) where
|
||||
parseJSON (String s) = TEnum <$> parseJSONEnum s
|
||||
parseJSON _ = fail "expected string"
|
||||
parseJSON _ = fail "expected string"
|
||||
|
||||
class ToJSONEnum choices where
|
||||
toJSONEnum :: NS Proxy choices -> T.Text
|
||||
@ -132,7 +136,7 @@ instance (ToJSON (FieldValue sch u), ToJSONUnion sch us)
|
||||
|
||||
instance FromJSON (FieldValue sch 'TNull) where
|
||||
parseJSON Null = return FNull
|
||||
parseJSON _ = fail "expected null"
|
||||
parseJSON _ = fail "expected null"
|
||||
instance FromJSON t => FromJSON (FieldValue sch ('TPrimitive t)) where
|
||||
parseJSON v = FPrimitive <$> parseJSON v
|
||||
instance FromJSONKey t => FromJSONKey (FieldValue sch ('TPrimitive t)) where
|
||||
@ -161,4 +165,4 @@ instance FromJSONUnion sch '[] where
|
||||
unionFromJSON _ = fail "value does not match any of the types of the union"
|
||||
instance (FromJSON (FieldValue sch u), FromJSONUnion sch us)
|
||||
=> FromJSONUnion sch (u ': us) where
|
||||
unionFromJSON v = Z <$> parseJSON v <|> S <$> unionFromJSON v
|
||||
unionFromJSON v = Z <$> parseJSON v <|> S <$> unionFromJSON v
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# language DataKinds #-}
|
||||
{-# language DataKinds #-}
|
||||
-- | Schemas for Mu microservices
|
||||
module Mu.Schema (
|
||||
-- * Schema definition
|
||||
@ -21,7 +21,7 @@ module Mu.Schema (
|
||||
, ProtoBufId, ProtoBufOneOfIds
|
||||
) where
|
||||
|
||||
import Mu.Schema.Annotations
|
||||
import Mu.Schema.Definition
|
||||
import Mu.Schema.Interpretation
|
||||
import Mu.Schema.Class
|
||||
import Mu.Schema.Annotations
|
||||
import Mu.Schema.Class
|
||||
import Mu.Schema.Definition
|
||||
import Mu.Schema.Interpretation
|
||||
|
||||
@ -1,9 +1,10 @@
|
||||
{-# language DataKinds, KindSignatures #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language KindSignatures #-}
|
||||
module Mu.Schema.Annotations where
|
||||
|
||||
import GHC.TypeLits
|
||||
import GHC.TypeLits
|
||||
|
||||
-- ANNOTATION FOR CONVERSION
|
||||
|
||||
data ProtoBufId (n :: Nat)
|
||||
data ProtoBufOneOfIds (ns :: [Nat])
|
||||
data ProtoBufOneOfIds (ns :: [Nat])
|
||||
|
||||
@ -1,24 +1,30 @@
|
||||
{-# language PolyKinds, DataKinds, GADTs,
|
||||
TypeFamilies, TypeOperators,
|
||||
FunctionalDependencies,
|
||||
FlexibleInstances, FlexibleContexts,
|
||||
TypeApplications, ScopedTypeVariables,
|
||||
UndecidableInstances,
|
||||
DefaultSignatures #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language DefaultSignatures #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language FunctionalDependencies #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
-- | Conversion from types to schemas
|
||||
module Mu.Schema.Class (
|
||||
WithSchema(..), HasSchema(..), fromSchema', toSchema'
|
||||
, Mapping(..), Mappings, MappingRight, MappingLeft
|
||||
) where
|
||||
|
||||
import Data.Kind
|
||||
import Data.Map as M
|
||||
import Data.SOP
|
||||
import GHC.Generics
|
||||
import GHC.TypeLits
|
||||
import Data.Kind
|
||||
import Data.Map as M
|
||||
import Data.SOP
|
||||
import GHC.Generics
|
||||
import GHC.TypeLits
|
||||
|
||||
import Mu.Schema.Definition
|
||||
import Mu.Schema.Interpretation
|
||||
import Mu.Schema.Definition
|
||||
import Mu.Schema.Interpretation
|
||||
|
||||
-- | Tags a value with its schema.
|
||||
-- For usage with @deriving via@.
|
||||
@ -126,7 +132,7 @@ instance {-# OVERLAPPABLE #-}
|
||||
-- This instance removes unneeded metadata from the
|
||||
-- top of the type.
|
||||
instance {-# OVERLAPS #-}
|
||||
GSchemaTypeDef sch fmap ('DSimple t) f
|
||||
GSchemaTypeDef sch fmap ('DSimple t) f
|
||||
=> GSchemaTypeDef sch fmap ('DSimple t) (D1 meta f) where
|
||||
toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x
|
||||
fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x)
|
||||
@ -160,7 +166,7 @@ instance (GSchemaFieldType sch sk hk, GSchemaFieldType sch sv hv,
|
||||
Ord (FieldValue sch sk), Ord hk) -- Ord is required to build a map
|
||||
=> GSchemaFieldType sch ('TMap sk sv) (M.Map hk hv) where
|
||||
toSchemaFieldType x = FMap (M.mapKeys toSchemaFieldType (M.map toSchemaFieldType x))
|
||||
fromSchemaFieldType (FMap x) = M.mapKeys fromSchemaFieldType (M.map fromSchemaFieldType x)
|
||||
fromSchemaFieldType (FMap x) = M.mapKeys fromSchemaFieldType (M.map fromSchemaFieldType x)
|
||||
-- This assumes that a union is represented by
|
||||
-- a value of type 'NS', where types are in
|
||||
-- the same order.
|
||||
@ -173,7 +179,7 @@ instance AllZip (GSchemaFieldType sch) ts vs
|
||||
go (S n) = S (go n)
|
||||
fromSchemaFieldType (FUnion t) = go t
|
||||
where go :: AllZip (GSchemaFieldType sch) tss vss
|
||||
=> NS (FieldValue sch) tss -> NS I vss
|
||||
=> NS (FieldValue sch) tss -> NS I vss
|
||||
go (Z x) = Z (I (fromSchemaFieldType x))
|
||||
go (S n) = S (go n)
|
||||
|
||||
@ -189,7 +195,7 @@ instance {-# OVERLAPPABLE #-}
|
||||
-- This instance removes unneeded metadata from the
|
||||
-- top of the type.
|
||||
instance {-# OVERLAPS #-}
|
||||
GSchemaTypeDef sch fmap ('DEnum name anns choices) f
|
||||
GSchemaTypeDef sch fmap ('DEnum name anns choices) f
|
||||
=> GSchemaTypeDef sch fmap ('DEnum name anns choices) (D1 meta f) where
|
||||
toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x
|
||||
fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x)
|
||||
@ -261,12 +267,12 @@ instance {-# OVERLAPPABLE #-}
|
||||
-- This instance removes unneeded metadata from the
|
||||
-- top of the type.
|
||||
instance {-# OVERLAPS #-}
|
||||
GSchemaTypeDef sch fmap ('DRecord name anns args) f
|
||||
GSchemaTypeDef sch fmap ('DRecord name anns args) f
|
||||
=> GSchemaTypeDef sch fmap ('DRecord name anns args) (D1 meta f) where
|
||||
toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x
|
||||
fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x)
|
||||
instance {-# OVERLAPS #-}
|
||||
GSchemaTypeDef sch fmap ('DRecord name anns args) f
|
||||
GSchemaTypeDef sch fmap ('DRecord name anns args) f
|
||||
=> GSchemaTypeDef sch fmap ('DRecord name anns args) (C1 meta f) where
|
||||
toSchemaTypeDef p (M1 x) = toSchemaTypeDef p x
|
||||
fromSchemaTypeDef p x = M1 (fromSchemaTypeDef p x)
|
||||
@ -297,7 +303,7 @@ instance ( GToSchemaRecord sch fmap cs f
|
||||
|
||||
class GToSchemaRecordSearch (sch :: Schema ts fs) (t :: FieldType ts) (f :: * -> *) (w :: Where) where
|
||||
toSchemaRecordSearch :: Proxy w -> f a -> FieldValue sch t
|
||||
instance GSchemaFieldType sch t v
|
||||
instance GSchemaFieldType sch t v
|
||||
=> GToSchemaRecordSearch sch t (S1 m (K1 i v)) 'Here where
|
||||
toSchemaRecordSearch _ (M1 (K1 x)) = toSchemaFieldType x
|
||||
instance GSchemaFieldType sch t v
|
||||
@ -341,4 +347,4 @@ instance GSchemaFieldType sch t v => GFromSchemaRecordSearch sch v ('FieldDef na
|
||||
instance forall sch v other rest n.
|
||||
GFromSchemaRecordSearch sch v rest n
|
||||
=> GFromSchemaRecordSearch sch v (other ': rest) ('There n) where
|
||||
fromSchemaRecordSearch _ (_ :* xs) = fromSchemaRecordSearch (Proxy @n) xs
|
||||
fromSchemaRecordSearch _ (_ :* xs) = fromSchemaRecordSearch (Proxy @n) xs
|
||||
|
||||
@ -1,20 +1,23 @@
|
||||
{-# language CPP, TemplateHaskell, TypeOperators, DataKinds #-}
|
||||
{-# language CPP #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language TemplateHaskell #-}
|
||||
{-# language TypeOperators #-}
|
||||
-- | Generate a set of Haskell types from a 'Schema'.
|
||||
module Mu.Schema.Conversion.SchemaToTypes (
|
||||
generateTypesFromSchema
|
||||
, Namer
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Char
|
||||
import qualified Data.Map as M
|
||||
import Data.SOP
|
||||
import GHC.Generics (Generic)
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Datatype
|
||||
import Control.Applicative
|
||||
import Data.Char
|
||||
import qualified Data.Map as M
|
||||
import Data.SOP
|
||||
import GHC.Generics (Generic)
|
||||
import Language.Haskell.TH
|
||||
import Language.Haskell.TH.Datatype
|
||||
|
||||
import Mu.Schema.Definition
|
||||
import Mu.Schema.Class
|
||||
import Mu.Schema.Class
|
||||
import Mu.Schema.Definition
|
||||
|
||||
-- | Generate the name from each new Haskell type
|
||||
-- from the name given in the schema.
|
||||
@ -141,11 +144,11 @@ fieldName :: String -> String -> String
|
||||
fieldName complete fname = firstLower (complete ++ firstUpper fname)
|
||||
|
||||
firstUpper :: String -> String
|
||||
firstUpper [] = error "Empty names are not allowed"
|
||||
firstUpper [] = error "Empty names are not allowed"
|
||||
firstUpper (x:rest) = toUpper x : rest
|
||||
|
||||
firstLower :: String -> String
|
||||
firstLower [] = error "Empty names are not allowed"
|
||||
firstLower [] = error "Empty names are not allowed"
|
||||
firstLower (x:rest) = toLower x : rest
|
||||
|
||||
fieldTypeToDecl :: Namer -> FieldTypeB Type String -> Type
|
||||
@ -180,8 +183,8 @@ typeToSchemaDef toplevelty
|
||||
typeToSchemaDef' expanded
|
||||
= do types <- tyList expanded
|
||||
mapM typeToTypeDef types
|
||||
|
||||
typeToTypeDef, typeToRecordDef, typeToEnumDef, typeToSimpleType
|
||||
|
||||
typeToTypeDef, typeToRecordDef, typeToEnumDef, typeToSimpleType
|
||||
:: Type -> Maybe (TypeDefB Type String String)
|
||||
typeToTypeDef t
|
||||
= typeToRecordDef t <|> typeToEnumDef t <|> typeToSimpleType t
|
||||
@ -269,4 +272,4 @@ tyD3 name (SigT t _) = tyD3 name t
|
||||
tyD3 name (AppT (AppT (AppT (PromotedT c) x) y) z)
|
||||
| c == name = Just (x, y, z)
|
||||
| otherwise = Nothing
|
||||
tyD3 _ _ = Nothing
|
||||
tyD3 _ _ = Nothing
|
||||
|
||||
@ -1,8 +1,10 @@
|
||||
{-# language PolyKinds, DataKinds, TypeFamilies,
|
||||
TypeOperators,
|
||||
UndecidableInstances #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
-- | Obtains a 'Schema' from a set of Haskell types.
|
||||
--
|
||||
--
|
||||
-- Unfortunately, GHC does not allow type families
|
||||
-- to appear in instances, so you cannot use the
|
||||
-- resulting type directly. Instead, evaluate it
|
||||
@ -14,13 +16,13 @@ module Mu.Schema.Conversion.TypesToSchema (
|
||||
, FromTypes, FromType(..)
|
||||
) where
|
||||
|
||||
import Data.Kind
|
||||
import Data.Map as M
|
||||
import Data.SOP
|
||||
import GHC.Generics
|
||||
import GHC.TypeLits
|
||||
import Data.Kind
|
||||
import Data.Map as M
|
||||
import Data.SOP
|
||||
import GHC.Generics
|
||||
import GHC.TypeLits
|
||||
|
||||
import Mu.Schema.Definition
|
||||
import Mu.Schema.Definition
|
||||
|
||||
type FromTypes = [FromType Symbol Symbol]
|
||||
data FromType tn fn
|
||||
@ -101,4 +103,4 @@ type family ChoicesFromType (all :: [FromType tn fn]) (mp :: Mappings Symbol fn)
|
||||
ChoicesFromType all mp (C1 ('MetaCons cname p s) f)
|
||||
= TypeError ('Text "constructor " ':<>: 'ShowType cname ':<>: 'Text "has fields and cannot be turned into an enumeration schema")
|
||||
ChoicesFromType all mp v
|
||||
= TypeError ('Text "unsupported conversion from " ':<>: 'ShowType v ':<>: 'Text " to enumeration schema")
|
||||
= TypeError ('Text "unsupported conversion from " ':<>: 'ShowType v ':<>: 'Text " to enumeration schema")
|
||||
|
||||
@ -1,14 +1,18 @@
|
||||
{-# language PolyKinds, DataKinds,
|
||||
TypeFamilies, TypeOperators,
|
||||
UndecidableInstances, FlexibleInstances,
|
||||
ScopedTypeVariables, TypeApplications #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
-- | Schema definition
|
||||
module Mu.Schema.Definition where
|
||||
|
||||
import Data.Kind
|
||||
import Data.Proxy
|
||||
import Data.Typeable
|
||||
import GHC.TypeLits
|
||||
import Data.Kind
|
||||
import Data.Proxy
|
||||
import Data.Typeable
|
||||
import GHC.TypeLits
|
||||
|
||||
-- | A set of type definitions,
|
||||
-- where the names of types and fields are
|
||||
@ -40,7 +44,7 @@ type SchemaB builtin typeName fieldName
|
||||
= [TypeDefB builtin typeName fieldName]
|
||||
|
||||
-- | Libraries can define custom annotations
|
||||
-- to indicate additional information.
|
||||
-- to indicate additional information.
|
||||
type Annotation = Type
|
||||
|
||||
-- | Defines a type in a schema.
|
||||
@ -167,4 +171,4 @@ instance ReflectFieldTypes '[] where
|
||||
reflectFieldTypes _ = []
|
||||
instance (ReflectFieldType t, ReflectFieldTypes ts)
|
||||
=> ReflectFieldTypes (t ': ts) where
|
||||
reflectFieldTypes _ = reflectFieldType (Proxy @t) : reflectFieldTypes (Proxy @ts)
|
||||
reflectFieldTypes _ = reflectFieldType (Proxy @t) : reflectFieldTypes (Proxy @ts)
|
||||
|
||||
@ -1,23 +1,30 @@
|
||||
{-# language PolyKinds, DataKinds, GADTs,
|
||||
TypeFamilies, TypeOperators,
|
||||
MultiParamTypeClasses, FlexibleInstances,
|
||||
TypeApplications,
|
||||
DeriveGeneric, DerivingVia, DeriveAnyClass,
|
||||
TemplateHaskell, QuasiQuotes #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language DeriveAnyClass #-}
|
||||
{-# language DeriveGeneric #-}
|
||||
{-# language DerivingVia #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language QuasiQuotes #-}
|
||||
{-# language TemplateHaskell #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
-- | Look at my source code!
|
||||
module Mu.Schema.Examples where
|
||||
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
import qualified Data.Aeson as J
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics
|
||||
|
||||
import Mu.Schema
|
||||
import Mu.Schema.Conversion.SchemaToTypes
|
||||
import Mu.Adapter.Json ()
|
||||
import Mu.Adapter.Json ()
|
||||
import Mu.Schema
|
||||
import Mu.Schema.Conversion.SchemaToTypes
|
||||
|
||||
data Person
|
||||
= Person { firstName :: T.Text
|
||||
, lastName :: T.Text
|
||||
, lastName :: T.Text
|
||||
, age :: Maybe Int
|
||||
, gender :: Maybe Gender
|
||||
, address :: Address }
|
||||
@ -90,4 +97,4 @@ type ExampleSchema2
|
||||
]
|
||||
|
||||
type ExampleRegistry
|
||||
= '[ 2 ':-> ExampleSchema2, 1 ':-> ExampleSchema]
|
||||
= '[ 2 ':-> ExampleSchema2, 1 ':-> ExampleSchema]
|
||||
|
||||
@ -1,19 +1,24 @@
|
||||
{-# language PolyKinds, DataKinds, GADTs,
|
||||
TypeFamilies, TypeOperators,
|
||||
FlexibleInstances, FlexibleContexts,
|
||||
TypeApplications, ScopedTypeVariables,
|
||||
UndecidableInstances #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
-- | Interpretation of schemas
|
||||
module Mu.Schema.Interpretation (
|
||||
Term(..), Field(..), FieldValue(..)
|
||||
, NS(..), NP(..), Proxy(..)
|
||||
) where
|
||||
|
||||
import Data.Map
|
||||
import Data.Proxy
|
||||
import Data.SOP
|
||||
|
||||
import Mu.Schema.Definition
|
||||
import Data.Map
|
||||
import Data.Proxy
|
||||
import Data.SOP
|
||||
|
||||
import Mu.Schema.Definition
|
||||
|
||||
-- | Interpretation of a type in a schema.
|
||||
data Term (sch :: Schema typeName fieldName) (t :: TypeDef typeName fieldName) where
|
||||
|
||||
@ -1,14 +1,17 @@
|
||||
{-# language PolyKinds, DataKinds, GADTs,
|
||||
TypeOperators,
|
||||
MultiParamTypeClasses,
|
||||
FlexibleInstances, FlexibleContexts,
|
||||
UndecidableInstances,
|
||||
StandaloneDeriving #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language StandaloneDeriving #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
module Mu.Schema.Interpretation.Anonymous where
|
||||
|
||||
import Data.SOP
|
||||
import Data.SOP
|
||||
|
||||
import Mu.Schema
|
||||
import Mu.Schema
|
||||
|
||||
data V0 sch sty where
|
||||
V0 :: (sch :/: sty ~ 'DRecord nm anns '[])
|
||||
@ -67,4 +70,4 @@ instance (sch :/: sty ~ 'DRecord nm anns '[ 'FieldDef f fanns ('TPrimitive a)
|
||||
, 'FieldDef g ganns ('TPrimitive b) ])
|
||||
=> HasSchema sch sty (V2 sch sty) where
|
||||
toSchema (V2 x y) = TRecord (Field (FPrimitive x) :* Field (FPrimitive y) :* Nil)
|
||||
fromSchema (TRecord (Field (FPrimitive x) :* Field (FPrimitive y) :* Nil)) = V2 x y
|
||||
fromSchema (TRecord (Field (FPrimitive x) :* Field (FPrimitive y) :* Nil)) = V2 x y
|
||||
|
||||
@ -1,9 +1,15 @@
|
||||
{-# language PolyKinds, DataKinds, GADTs,
|
||||
ScopedTypeVariables,
|
||||
TypeApplications, TypeOperators,
|
||||
FlexibleContexts, MultiParamTypeClasses,
|
||||
AllowAmbiguousTypes, StandaloneDeriving,
|
||||
FlexibleInstances, UndecidableInstances #-}
|
||||
{-# language AllowAmbiguousTypes #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language StandaloneDeriving #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
module Mu.Schema.Interpretation.Schemaless (
|
||||
-- * Terms without an associated schema
|
||||
Term(..), Field(..), FieldValue(..)
|
||||
@ -13,16 +19,16 @@ module Mu.Schema.Interpretation.Schemaless (
|
||||
, ToSchemalessTerm(..), ToSchemalessValue(..)
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.List (find)
|
||||
import qualified Data.Map as M
|
||||
import Data.Proxy
|
||||
import Data.SOP
|
||||
import qualified Data.Text as T
|
||||
import Data.Typeable
|
||||
import Control.Applicative ((<|>))
|
||||
import Data.List (find)
|
||||
import qualified Data.Map as M
|
||||
import Data.Proxy
|
||||
import Data.SOP
|
||||
import qualified Data.Text as T
|
||||
import Data.Typeable
|
||||
|
||||
import Mu.Schema.Class
|
||||
import Mu.Schema.Definition
|
||||
import Mu.Schema.Class
|
||||
import Mu.Schema.Definition
|
||||
import qualified Mu.Schema.Interpretation as S
|
||||
|
||||
-- | Interpretation of a type in a schema.
|
||||
@ -77,7 +83,7 @@ class CheckSchemaUnion (s :: Schema tn fn) (ts :: [FieldType tn]) where
|
||||
|
||||
instance CheckSchemaFields s fields => CheckSchema s ('DRecord nm anns fields) where
|
||||
checkSchema' (TRecord fields) = S.TRecord <$> checkSchemaFields fields
|
||||
checkSchema' _ = Nothing
|
||||
checkSchema' _ = Nothing
|
||||
instance CheckSchemaFields s '[] where
|
||||
checkSchemaFields _ = pure Nil
|
||||
instance (KnownName nm, CheckSchemaValue s ty, CheckSchemaFields s rest)
|
||||
@ -96,7 +102,7 @@ instance CheckSchemaEnum choices => CheckSchema s ('DEnum nm anns choices) where
|
||||
(Just Refl, _, _) -> S.TEnum <$> checkSchemaEnumInt n
|
||||
(_, Just Refl, _) -> S.TEnum <$> checkSchemaEnumText n
|
||||
(_, _, Just Refl) -> S.TEnum <$> checkSchemaEnumText (T.pack n)
|
||||
_ -> Nothing
|
||||
_ -> Nothing
|
||||
checkSchema' _ = Nothing
|
||||
instance CheckSchemaEnum '[] where
|
||||
checkSchemaEnumInt _ = Nothing
|
||||
@ -125,7 +131,7 @@ instance Typeable t => CheckSchemaValue s ('TPrimitive t) where
|
||||
instance (CheckSchema s (s :/: t))
|
||||
=> CheckSchemaValue s ('TSchematic t) where
|
||||
checkSchemaValue (FSchematic t) = S.FSchematic <$> checkSchema' t
|
||||
checkSchemaValue _ = Nothing
|
||||
checkSchemaValue _ = Nothing
|
||||
instance CheckSchemaValue s t => CheckSchemaValue s ('TOption t) where
|
||||
checkSchemaValue (FOption x) = S.FOption <$> traverse checkSchemaValue x
|
||||
checkSchemaValue _ = Nothing
|
||||
@ -184,4 +190,4 @@ instance Ord FieldValue where
|
||||
FMap _ <= FOption _ = False
|
||||
FMap _ <= FList _ = False
|
||||
FMap x <= FMap y = x <= y
|
||||
-- FMap _ <= _ = True
|
||||
-- FMap _ <= _ = True
|
||||
|
||||
@ -1,8 +1,14 @@
|
||||
{-# language PolyKinds, DataKinds, TypeFamilies,
|
||||
ScopedTypeVariables, MultiParamTypeClasses,
|
||||
FlexibleInstances, FlexibleContexts,
|
||||
TypeOperators, UndecidableInstances,
|
||||
TypeApplications, AllowAmbiguousTypes #-}
|
||||
{-# language AllowAmbiguousTypes #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
module Mu.Schema.Registry (
|
||||
-- * Registry of schemas
|
||||
Registry, fromRegistry
|
||||
@ -10,18 +16,18 @@ module Mu.Schema.Registry (
|
||||
, SLess.Term(..), SLess.Field(..), SLess.FieldValue(..)
|
||||
) where
|
||||
|
||||
import Data.Proxy
|
||||
import Data.Kind
|
||||
import Control.Applicative
|
||||
import GHC.TypeLits
|
||||
import Control.Applicative
|
||||
import Data.Kind
|
||||
import Data.Proxy
|
||||
import GHC.TypeLits
|
||||
|
||||
import Mu.Schema.Definition
|
||||
import Mu.Schema.Class
|
||||
import Mu.Schema.Class
|
||||
import Mu.Schema.Definition
|
||||
import qualified Mu.Schema.Interpretation.Schemaless as SLess
|
||||
|
||||
type Registry = Mappings Nat Schema'
|
||||
|
||||
fromRegistry :: forall r t.
|
||||
fromRegistry :: forall r t.
|
||||
FromRegistry r t
|
||||
=> SLess.Term -> Maybe t
|
||||
fromRegistry = fromRegistry' (Proxy @r)
|
||||
@ -33,4 +39,4 @@ instance FromRegistry '[] t where
|
||||
fromRegistry' _ _ = Nothing
|
||||
instance (HasSchema s sty t, SLess.CheckSchema s (s :/: sty), FromRegistry ms t)
|
||||
=> FromRegistry ( (n ':-> s) ': ms) t where
|
||||
fromRegistry' _ t = SLess.fromSchemalessTerm @s t <|> fromRegistry' (Proxy @ms) t
|
||||
fromRegistry' _ t = SLess.fromSchemalessTerm @s t <|> fromRegistry' (Proxy @ms) t
|
||||
|
||||
@ -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
|
||||
runGRpcApp 8080 quickstartServer
|
||||
|
||||
@ -1,70 +1,72 @@
|
||||
{-# language DataKinds, ScopedTypeVariables,
|
||||
TypeOperators, OverloadedStrings,
|
||||
FlexibleContexts, AllowAmbiguousTypes,
|
||||
DeriveGeneric, TypeApplications #-}
|
||||
{-# language AllowAmbiguousTypes #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language DeriveGeneric #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
module Main where
|
||||
|
||||
import Data.Conduit
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics (Generic)
|
||||
import System.Environment
|
||||
import qualified Data.Text as T
|
||||
import GHC.Generics (Generic)
|
||||
import System.Environment
|
||||
|
||||
import Mu.GRpc.Client.Record
|
||||
import Mu.GRpc.Client.Record
|
||||
|
||||
import Definition
|
||||
import Definition
|
||||
|
||||
data HealthCall
|
||||
= HealthCall
|
||||
{ setStatus :: HealthStatusMsg -> IO (GRpcReply ())
|
||||
, check :: HealthCheckMsg -> IO (GRpcReply ServerStatusMsg)
|
||||
, clearStatus :: HealthCheckMsg -> IO (GRpcReply ())
|
||||
, checkAll :: IO (GRpcReply AllStatusMsg)
|
||||
, cleanAll :: IO (GRpcReply ())
|
||||
, watch :: HealthCheckMsg -> IO (ConduitT () (GRpcReply ServerStatusMsg) IO ()) }
|
||||
deriving (Generic)
|
||||
data HealthCall = HealthCall
|
||||
{ setStatus :: HealthStatusMsg -> IO (GRpcReply ())
|
||||
, check :: HealthCheckMsg -> IO (GRpcReply ServerStatusMsg)
|
||||
, clearStatus :: HealthCheckMsg -> IO (GRpcReply ())
|
||||
, checkAll :: IO (GRpcReply AllStatusMsg)
|
||||
, cleanAll :: IO (GRpcReply ())
|
||||
, watch :: HealthCheckMsg -> IO (ConduitT () (GRpcReply ServerStatusMsg) IO ())
|
||||
} deriving (Generic)
|
||||
|
||||
buildHealthCall :: GrpcClient -> HealthCall
|
||||
buildHealthCall = buildService @HealthCheckService @""
|
||||
|
||||
main :: IO ()
|
||||
main
|
||||
= do -- Setup the client
|
||||
let config = grpcClientConfigSimple "127.0.0.1" 8080 False
|
||||
Right grpcClient <- setupGrpcClient' config
|
||||
let client = buildHealthCall grpcClient
|
||||
-- Execute command
|
||||
args <- getArgs
|
||||
case args of
|
||||
["watch" , who] -> watching client who
|
||||
["simple", who] -> simple client who
|
||||
["update", who] -> update client who "SERVING"
|
||||
["update", who, newstatus] -> update client who newstatus
|
||||
_ -> putStrLn "unknown command"
|
||||
main = do -- Setup the client
|
||||
let config = grpcClientConfigSimple "127.0.0.1" 8080 False
|
||||
Right grpcClient <- setupGrpcClient' config
|
||||
let client = buildHealthCall grpcClient
|
||||
-- Execute command
|
||||
args <- getArgs
|
||||
case args of
|
||||
["watch" , who] -> watching client who
|
||||
["simple", who] -> simple client who
|
||||
["update", who] -> update client who "SERVING"
|
||||
["update", who, newstatus] -> update client who newstatus
|
||||
_ -> putStrLn "unknown command"
|
||||
|
||||
simple :: HealthCall -> String -> IO ()
|
||||
simple client who
|
||||
= do let hcm = HealthCheckMsg (T.pack who)
|
||||
putStrLn ("UNARY: Is there some server named " <> who <> "?")
|
||||
rknown <- check client hcm
|
||||
putStrLn ("UNARY: Actually the status is " <> show rknown)
|
||||
update client who "SERVING"
|
||||
r <- clearStatus client hcm
|
||||
putStrLn ("UNARY: Was clearing successful? " <> show r)
|
||||
runknown <- check client hcm
|
||||
putStrLn ("UNARY: Current status of " <> who <> ": " <> show runknown)
|
||||
simple client who = do
|
||||
let hcm = HealthCheckMsg (T.pack who)
|
||||
putStrLn ("UNARY: Is there some server named " <> who <> "?")
|
||||
rknown <- check client hcm
|
||||
putStrLn ("UNARY: Actually the status is " <> show rknown)
|
||||
update client who "SERVING"
|
||||
r <- clearStatus client hcm
|
||||
putStrLn ("UNARY: Was clearing successful? " <> show r)
|
||||
runknown <- check client hcm
|
||||
putStrLn ("UNARY: Current status of " <> who <> ": " <> show runknown)
|
||||
|
||||
update :: HealthCall -> String -> String -> IO ()
|
||||
update client who newstatus
|
||||
= do let hcm = HealthCheckMsg (T.pack who)
|
||||
putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus)
|
||||
r <- setStatus client (HealthStatusMsg hcm (ServerStatusMsg (T.pack newstatus)))
|
||||
putStrLn ("UNARY: Was setting successful? " <> show r)
|
||||
rstatus <- check client hcm
|
||||
putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus)
|
||||
update client who newstatus = do
|
||||
let hcm = HealthCheckMsg (T.pack who)
|
||||
putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus)
|
||||
r <- setStatus client (HealthStatusMsg hcm (ServerStatusMsg (T.pack newstatus)))
|
||||
putStrLn ("UNARY: Was setting successful? " <> show r)
|
||||
rstatus <- check client hcm
|
||||
putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus)
|
||||
|
||||
watching :: HealthCall -> String -> IO ()
|
||||
watching client who
|
||||
= do let hcm = HealthCheckMsg (T.pack who)
|
||||
stream <- watch client hcm
|
||||
runConduit $ stream .| C.mapM_ print
|
||||
watching client who = do
|
||||
let hcm = HealthCheckMsg (T.pack who)
|
||||
stream <- watch client hcm
|
||||
runConduit $ stream .| C.mapM_ print
|
||||
|
||||
@ -1,59 +1,61 @@
|
||||
{-# language DataKinds, ScopedTypeVariables,
|
||||
TypeApplications, TypeOperators,
|
||||
FlexibleContexts, AllowAmbiguousTypes,
|
||||
OverloadedStrings #-}
|
||||
{-# language AllowAmbiguousTypes #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
module Main where
|
||||
|
||||
import Data.Conduit
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
import qualified Data.Text as T
|
||||
import System.Environment
|
||||
import qualified Data.Text as T
|
||||
import System.Environment
|
||||
|
||||
import Mu.GRpc.Client.TyApps
|
||||
import Mu.GRpc.Client.TyApps
|
||||
|
||||
import Definition
|
||||
import Definition
|
||||
|
||||
main :: IO ()
|
||||
main
|
||||
= do -- Setup the client
|
||||
let config = grpcClientConfigSimple "127.0.0.1" 8080 False
|
||||
Right client <- setupGrpcClient' config
|
||||
-- Execute command
|
||||
args <- getArgs
|
||||
case args of
|
||||
["watch" , who] -> watching client who
|
||||
["simple", who] -> simple client who
|
||||
["update", who] -> update client who "SERVING"
|
||||
["update", who, newstatus] -> update client who newstatus
|
||||
_ -> putStrLn "unknown command"
|
||||
main = do -- Setup the client
|
||||
let config = grpcClientConfigSimple "127.0.0.1" 8080 False
|
||||
Right client <- setupGrpcClient' config
|
||||
-- Execute command
|
||||
args <- getArgs
|
||||
case args of
|
||||
["watch" , who] -> watching client who
|
||||
["simple", who] -> simple client who
|
||||
["update", who] -> update client who "SERVING"
|
||||
["update", who, newstatus] -> update client who newstatus
|
||||
_ -> putStrLn "unknown command"
|
||||
|
||||
simple :: GrpcClient -> String -> IO ()
|
||||
simple client who
|
||||
= do let hcm = HealthCheckMsg (T.pack who)
|
||||
putStrLn ("UNARY: Is there some server named " <> who <> "?")
|
||||
rknown :: GRpcReply ServerStatusMsg
|
||||
<- gRpcCall @HealthCheckService @"check" client hcm
|
||||
putStrLn ("UNARY: Actually the status is " <> show rknown)
|
||||
update client who "SERVING"
|
||||
r <- gRpcCall @HealthCheckService @"clearStatus" client hcm
|
||||
putStrLn ("UNARY: Was clearing successful? " <> show r)
|
||||
runknown :: GRpcReply ServerStatusMsg
|
||||
<- gRpcCall @HealthCheckService @"check" client hcm
|
||||
putStrLn ("UNARY: Current status of " <> who <> ": " <> show runknown)
|
||||
simple client who = do
|
||||
let hcm = HealthCheckMsg (T.pack who)
|
||||
putStrLn ("UNARY: Is there some server named " <> who <> "?")
|
||||
rknown :: GRpcReply ServerStatusMsg
|
||||
<- gRpcCall @HealthCheckService @"check" client hcm
|
||||
putStrLn ("UNARY: Actually the status is " <> show rknown)
|
||||
update client who "SERVING"
|
||||
r <- gRpcCall @HealthCheckService @"clearStatus" client hcm
|
||||
putStrLn ("UNARY: Was clearing successful? " <> show r)
|
||||
runknown :: GRpcReply ServerStatusMsg
|
||||
<- gRpcCall @HealthCheckService @"check" client hcm
|
||||
putStrLn ("UNARY: Current status of " <> who <> ": " <> show runknown)
|
||||
|
||||
update :: GrpcClient -> String -> String -> IO ()
|
||||
update client who newstatus
|
||||
= do let hcm = HealthCheckMsg (T.pack who)
|
||||
putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus)
|
||||
r <- gRpcCall @HealthCheckService @"setStatus" client
|
||||
(HealthStatusMsg hcm (ServerStatusMsg (T.pack newstatus)))
|
||||
putStrLn ("UNARY: Was setting successful? " <> show r)
|
||||
rstatus :: GRpcReply ServerStatusMsg
|
||||
<- gRpcCall @HealthCheckService @"check" client hcm
|
||||
putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus)
|
||||
update client who newstatus = do
|
||||
let hcm = HealthCheckMsg (T.pack who)
|
||||
putStrLn ("UNARY: Setting " <> who <> " service to " <> newstatus)
|
||||
r <- gRpcCall @HealthCheckService @"setStatus" client
|
||||
(HealthStatusMsg hcm (ServerStatusMsg (T.pack newstatus)))
|
||||
putStrLn ("UNARY: Was setting successful? " <> show r)
|
||||
rstatus :: GRpcReply ServerStatusMsg
|
||||
<- gRpcCall @HealthCheckService @"check" client hcm
|
||||
putStrLn ("UNARY: Checked the status of " <> who <> ". Obtained: " <> show rstatus)
|
||||
|
||||
watching :: GrpcClient -> String -> IO ()
|
||||
watching client who
|
||||
= do let hcm = HealthCheckMsg (T.pack who)
|
||||
replies <- gRpcCall @HealthCheckService @"watch" client hcm
|
||||
runConduit $ replies .| C.mapM_ (print :: GRpcReply ServerStatusMsg -> IO ())
|
||||
watching client who = do
|
||||
let hcm = HealthCheckMsg (T.pack who)
|
||||
replies <- gRpcCall @HealthCheckService @"watch" client hcm
|
||||
runConduit $ replies .| C.mapM_ (print :: GRpcReply ServerStatusMsg -> IO ())
|
||||
|
||||
@ -1,16 +1,22 @@
|
||||
{-# language PolyKinds, DataKinds, TypeOperators,
|
||||
MultiParamTypeClasses, TypeFamilies,
|
||||
FlexibleInstances, FlexibleContexts,
|
||||
DeriveGeneric, DeriveAnyClass,
|
||||
DuplicateRecordFields, OverloadedLabels,
|
||||
TemplateHaskell #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language DeriveAnyClass #-}
|
||||
{-# language DeriveGeneric #-}
|
||||
{-# language DuplicateRecordFields #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language OverloadedLabels #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language TemplateHaskell #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
module Definition where
|
||||
|
||||
import GHC.Generics
|
||||
import Data.Text as T
|
||||
import Data.Text as T
|
||||
import GHC.Generics
|
||||
|
||||
import Mu.Schema
|
||||
import Mu.Quasi.GRpc
|
||||
import Mu.Quasi.GRpc
|
||||
import Mu.Schema
|
||||
|
||||
$(grpc "HealthCheckSchema" id "healthcheck.proto")
|
||||
|
||||
@ -53,4 +59,4 @@ type HealthCheckService
|
||||
, 'Method "cleanAll" '[] '[ ] 'RetNothing
|
||||
, 'Method "watch" '[] '[ 'ArgSingle (HS "HealthCheck") ] ('RetStream (HS "ServerStatus"))
|
||||
]
|
||||
-}
|
||||
-}
|
||||
|
||||
@ -1,22 +1,23 @@
|
||||
{-# language OverloadedStrings, PartialTypeSignatures #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language PartialTypeSignatures #-}
|
||||
module Main where
|
||||
|
||||
import Control.Concurrent.STM
|
||||
import Data.Conduit
|
||||
import Control.Concurrent.STM
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
import Data.Conduit.TMChan
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import DeferredFolds.UnfoldlM
|
||||
import qualified StmContainers.Map as M
|
||||
import Data.Conduit.TMChan
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import DeferredFolds.UnfoldlM
|
||||
import qualified StmContainers.Map as M
|
||||
|
||||
import Mu.Server
|
||||
import Mu.GRpc.Server
|
||||
import Mu.GRpc.Server
|
||||
import Mu.Server
|
||||
|
||||
import Definition
|
||||
import Definition
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
main = do
|
||||
m <- M.newIO
|
||||
upd <- newTBMChanIO 100
|
||||
putStrLn "running health check application"
|
||||
@ -29,48 +30,45 @@ type StatusMap = M.Map T.Text T.Text
|
||||
type StatusUpdates = TBMChan HealthStatusMsg
|
||||
|
||||
server :: StatusMap -> StatusUpdates -> ServerIO HealthCheckService _
|
||||
server m upd
|
||||
= Server (setStatus_ m upd :<|>:
|
||||
checkH_ m :<|>:
|
||||
clearStatus_ m :<|>:
|
||||
checkAll_ m :<|>:
|
||||
cleanAll_ m :<|>:
|
||||
watch_ upd :<|>: H0)
|
||||
server m upd = Server (setStatus_ m upd :<|>: checkH_ m :<|>: clearStatus_ m :<|>:
|
||||
checkAll_ m :<|>: cleanAll_ m :<|>: watch_ upd :<|>: H0)
|
||||
|
||||
setStatus_ :: StatusMap -> StatusUpdates -> HealthStatusMsg -> IO ()
|
||||
setStatus_ m upd s@(HealthStatusMsg (HealthCheckMsg nm) (ServerStatusMsg ss))
|
||||
= do putStr "setStatus: " >> print (nm, ss)
|
||||
atomically $ do M.insert ss nm m
|
||||
writeTBMChan upd s
|
||||
setStatus_ m upd s@(HealthStatusMsg (HealthCheckMsg nm) (ServerStatusMsg ss)) = do
|
||||
putStr "setStatus: " >> print (nm, ss)
|
||||
atomically $ do
|
||||
M.insert ss nm m
|
||||
writeTBMChan upd s
|
||||
|
||||
checkH_ :: StatusMap -> HealthCheckMsg -> IO ServerStatusMsg
|
||||
checkH_ m (HealthCheckMsg nm)
|
||||
= do putStr "check: " >> print nm
|
||||
ss <- atomically $ M.lookup nm m
|
||||
return $ ServerStatusMsg (fromMaybe "UNKNOWN" ss)
|
||||
checkH_ m (HealthCheckMsg nm) = do
|
||||
putStr "check: " >> print nm
|
||||
ss <- atomically $ M.lookup nm m
|
||||
return $ ServerStatusMsg (fromMaybe "UNKNOWN" ss)
|
||||
|
||||
clearStatus_ :: StatusMap -> HealthCheckMsg -> IO ()
|
||||
clearStatus_ m (HealthCheckMsg nm)
|
||||
= do putStr "clearStatus: " >> print nm
|
||||
atomically $ M.delete nm m
|
||||
clearStatus_ m (HealthCheckMsg nm) = do
|
||||
putStr "clearStatus: " >> print nm
|
||||
atomically $ M.delete nm m
|
||||
|
||||
checkAll_ :: StatusMap -> IO AllStatusMsg
|
||||
checkAll_ m
|
||||
= do putStrLn "checkAll"
|
||||
AllStatusMsg <$> atomically (consumeValues kvToStatus (M.unfoldlM m))
|
||||
where consumeValues :: Monad m => (k -> v -> a) -> UnfoldlM m (k,v) -> m [a]
|
||||
consumeValues f = foldlM' (\xs (x,y) -> pure (f x y:xs)) []
|
||||
kvToStatus k v = HealthStatusMsg (HealthCheckMsg k) (ServerStatusMsg v)
|
||||
checkAll_ m = do
|
||||
putStrLn "checkAll"
|
||||
AllStatusMsg <$> atomically (consumeValues kvToStatus (M.unfoldlM m))
|
||||
where
|
||||
consumeValues :: Monad m => (k -> v -> a) -> UnfoldlM m (k,v) -> m [a]
|
||||
consumeValues f = foldlM' (\xs (x,y) -> pure (f x y:xs)) []
|
||||
kvToStatus k v = HealthStatusMsg (HealthCheckMsg k) (ServerStatusMsg v)
|
||||
|
||||
cleanAll_ :: StatusMap -> IO ()
|
||||
cleanAll_ m
|
||||
= do putStrLn "cleanAll"
|
||||
atomically $ M.reset m
|
||||
cleanAll_ m = do
|
||||
putStrLn "cleanAll"
|
||||
atomically $ M.reset m
|
||||
|
||||
watch_ :: StatusUpdates -> HealthCheckMsg -> ConduitT ServerStatusMsg Void IO () -> IO ()
|
||||
watch_ upd hcm@(HealthCheckMsg nm) sink
|
||||
= do putStr "watch: " >> print nm
|
||||
runConduit $ sourceTBMChan upd
|
||||
.| C.filter (\(HealthStatusMsg c _) -> hcm == c)
|
||||
.| C.map (\(HealthStatusMsg _ s) -> s)
|
||||
.| sink
|
||||
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
|
||||
|
||||
@ -1,17 +1,23 @@
|
||||
{-# language PolyKinds, DataKinds, TypeOperators,
|
||||
MultiParamTypeClasses, TypeFamilies,
|
||||
FlexibleInstances, FlexibleContexts,
|
||||
DeriveGeneric, DeriveAnyClass,
|
||||
DuplicateRecordFields, TemplateHaskell #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language DeriveAnyClass #-}
|
||||
{-# language DeriveGeneric #-}
|
||||
{-# language DuplicateRecordFields #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language TemplateHaskell #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
module Definition where
|
||||
|
||||
import GHC.Generics
|
||||
import Data.Hashable
|
||||
import Data.Int
|
||||
import Data.Text as T
|
||||
import Data.Hashable
|
||||
import Data.Int
|
||||
import Data.Text as T
|
||||
import GHC.Generics
|
||||
|
||||
import Mu.Schema
|
||||
import Mu.Quasi.GRpc
|
||||
import Mu.Quasi.GRpc
|
||||
import Mu.Schema
|
||||
|
||||
$(grpc "RouteGuideSchema" id "routeguide.proto")
|
||||
|
||||
@ -66,4 +72,4 @@ type RouteGuideSchema
|
||||
, 'FieldDef "distance" '[ProtoBufId 3] ('TPrimitive Int32)
|
||||
, 'FieldDef "elapsed_time" '[ProtoBufId 4] ('TPrimitive Int32) ]
|
||||
]
|
||||
-}
|
||||
-}
|
||||
|
||||
@ -1,28 +1,30 @@
|
||||
{-# language OverloadedStrings, PartialTypeSignatures,
|
||||
DuplicateRecordFields, ScopedTypeVariables #-}
|
||||
{-# language DuplicateRecordFields #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language PartialTypeSignatures #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
module Main where
|
||||
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Concurrent.STM.TBMChan
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Angle
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
import Data.Conduit.List (sourceList)
|
||||
import Data.Function ((&))
|
||||
import Data.Int
|
||||
import Data.List (find)
|
||||
import Data.Maybe
|
||||
import Data.Time.Clock
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM
|
||||
import Control.Concurrent.STM.TBMChan
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Data.Angle
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
import Data.Conduit.List (sourceList)
|
||||
import Data.Function ((&))
|
||||
import Data.Int
|
||||
import Data.List (find)
|
||||
import Data.Maybe
|
||||
import Data.Time.Clock
|
||||
|
||||
import Mu.Server
|
||||
import Mu.GRpc.Server
|
||||
import Mu.GRpc.Server
|
||||
import Mu.Server
|
||||
|
||||
import Definition
|
||||
import Definition
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
main = do
|
||||
putStrLn "running route guide application"
|
||||
let features = []
|
||||
routeNotes <- newTBMChanIO 100
|
||||
@ -34,16 +36,14 @@ main = do
|
||||
type Features = [Feature]
|
||||
|
||||
findFeatureIn :: Features -> Point -> Maybe Feature
|
||||
findFeatureIn features p
|
||||
= find (\(Feature _ loc) -> loc == p) features
|
||||
findFeatureIn features p = find (\(Feature _ loc) -> loc == p) features
|
||||
|
||||
withinBounds :: Rectangle -> Point -> Bool
|
||||
withinBounds (Rectangle (Point lox loy) (Point hix hiy)) (Point x y)
|
||||
= x >= lox && x <= hix && y >= loy && y <= hiy
|
||||
|
||||
featuresWithinBounds :: Features -> Rectangle -> Features
|
||||
featuresWithinBounds fs rect
|
||||
= filter (\(Feature _ loc) -> withinBounds rect loc) fs
|
||||
featuresWithinBounds fs rect = filter (\(Feature _ loc) -> withinBounds rect loc) fs
|
||||
|
||||
calcDistance :: Point -> Point -> Int32
|
||||
calcDistance (Point lat1 lon1) (Point lat2 lon2)
|
||||
@ -54,7 +54,7 @@ calcDistance (Point lat1 lon1) (Point lat2 lon2)
|
||||
Radians (deltaLambda :: Double) = radians (Degrees (int32ToDouble $ lon2 - lon1))
|
||||
a = sin (deltaPhi / 2) * sin (deltaPhi / 2)
|
||||
+ cos phi1 * cos phi2 * sin (deltaLambda / 2) * sin (deltaLambda / 2)
|
||||
c = 2 * atan2 (sqrt a) (sqrt (1 - a))
|
||||
c = 2 * atan2 (sqrt a) (sqrt (1 - a))
|
||||
in fromInteger $ r * ceiling c
|
||||
where int32ToDouble :: Int32 -> Double
|
||||
int32ToDouble = fromInteger . toInteger
|
||||
@ -63,49 +63,48 @@ calcDistance (Point lat1 lon1) (Point lat2 lon2)
|
||||
-- https://github.com/higherkindness/mu/blob/master/modules/examples/routeguide/server/src/main/scala/handlers/RouteGuideServiceHandler.scala
|
||||
|
||||
server :: Features -> TBMChan RouteNote -> ServerIO RouteGuideService _
|
||||
server f m
|
||||
= Server (getFeature f :<|>: listFeatures f
|
||||
:<|>: recordRoute f :<|>: routeChat m :<|>: H0)
|
||||
server f m = Server
|
||||
(getFeature f :<|>: listFeatures f :<|>: recordRoute f :<|>: routeChat m :<|>: H0)
|
||||
|
||||
getFeature :: Features -> Point -> IO Feature
|
||||
getFeature fs p
|
||||
= return $ fromMaybe (Feature "" (Point 0 0)) (findFeatureIn fs p)
|
||||
getFeature fs p = return $ fromMaybe (Feature "" (Point 0 0)) (findFeatureIn fs p)
|
||||
|
||||
listFeatures :: Features -> Rectangle -> ConduitT Feature Void IO () -> IO ()
|
||||
listFeatures fs rect result
|
||||
= runConduit $ sourceList (featuresWithinBounds fs rect) .| result
|
||||
listFeatures fs rect result = runConduit $ sourceList (featuresWithinBounds fs rect) .| result
|
||||
|
||||
recordRoute :: Features -> ConduitT () Point IO () -> IO RouteSummary
|
||||
recordRoute fs ps
|
||||
= do initialTime <- getCurrentTime
|
||||
(rs, _, _) <- runConduit $ ps .| C.foldM step (RouteSummary 0 0 0 0, Nothing, initialTime)
|
||||
return rs
|
||||
where step :: (RouteSummary, Maybe Point, UTCTime) -> Point -> IO (RouteSummary, Maybe Point, UTCTime)
|
||||
step (summary, previous, startTime) point
|
||||
= do currentTime <- getCurrentTime
|
||||
let feature = findFeatureIn fs point
|
||||
new_distance = fmap (`calcDistance` point) previous & fromMaybe 0
|
||||
new_elapsed = diffUTCTime currentTime startTime
|
||||
new_summary = RouteSummary (point_count summary + 1)
|
||||
(feature_count summary + if isJust feature then 1 else 0)
|
||||
(distance summary + new_distance)
|
||||
(floor new_elapsed)
|
||||
return (new_summary, Just point, startTime)
|
||||
recordRoute fs ps = do
|
||||
initialTime <- getCurrentTime
|
||||
(rs, _, _) <- runConduit $ ps .| C.foldM step (RouteSummary 0 0 0 0, Nothing, initialTime)
|
||||
return rs
|
||||
where
|
||||
step :: (RouteSummary, Maybe Point, UTCTime) -> Point -> IO (RouteSummary, Maybe Point, UTCTime)
|
||||
step (summary, previous, startTime) point = do
|
||||
currentTime <- getCurrentTime
|
||||
let feature = findFeatureIn fs point
|
||||
new_distance = fmap (`calcDistance` point) previous & fromMaybe 0
|
||||
new_elapsed = diffUTCTime currentTime startTime
|
||||
new_summary = RouteSummary (point_count summary + 1)
|
||||
(feature_count summary + if isJust feature then 1 else 0)
|
||||
(distance summary + new_distance)
|
||||
(floor new_elapsed)
|
||||
return (new_summary, Just point, startTime)
|
||||
|
||||
routeChat :: TBMChan RouteNote
|
||||
-> ConduitT () RouteNote IO () -> ConduitT RouteNote Void IO () -> IO ()
|
||||
routeChat notesMap inS outS
|
||||
= do toWatch <- newEmptyTMVarIO
|
||||
-- Start two threads, one to listen, one to send
|
||||
inA <- async $ runConduit $ inS .| C.mapM_ (addNoteToMap toWatch)
|
||||
outA <- async $ runConduit $ readStmMap (\l1 (RouteNote _ l2)-> l1 == l2) toWatch notesMap .| outS
|
||||
wait inA
|
||||
wait outA
|
||||
where addNoteToMap :: TMVar Point -> RouteNote -> IO ()
|
||||
addNoteToMap toWatch newNote@(RouteNote _ loc)
|
||||
= atomically $ do _ <- tryTakeTMVar toWatch
|
||||
putTMVar toWatch loc
|
||||
writeTBMChan notesMap newNote
|
||||
routeChat notesMap inS outS = do
|
||||
toWatch <- newEmptyTMVarIO
|
||||
-- Start two threads, one to listen, one to send
|
||||
inA <- async $ runConduit $ inS .| C.mapM_ (addNoteToMap toWatch)
|
||||
outA <- async $ runConduit $ readStmMap (\l1 (RouteNote _ l2)-> l1 == l2) toWatch notesMap .| outS
|
||||
wait inA
|
||||
wait outA
|
||||
where
|
||||
addNoteToMap :: TMVar Point -> RouteNote -> IO ()
|
||||
addNoteToMap toWatch newNote@(RouteNote _ loc) = atomically $ do
|
||||
_ <- tryTakeTMVar toWatch
|
||||
putTMVar toWatch loc
|
||||
writeTBMChan notesMap newNote
|
||||
|
||||
readStmMap :: Show b => (a -> b -> Bool) -> TMVar a -> TBMChan b -> ConduitT () b IO ()
|
||||
readStmMap p toWatch m = go
|
||||
@ -113,6 +112,6 @@ readStmMap p toWatch m = go
|
||||
go = do
|
||||
v <- liftIO $ atomically $ (,) <$> readTBMChan m <*> tryReadTMVar toWatch
|
||||
case v of
|
||||
(Nothing, _) -> return ()
|
||||
(Nothing, _) -> return ()
|
||||
(Just v', Just e') | p e' v' -> liftIO (print v') >> yield v' >> go
|
||||
_ -> go
|
||||
_ -> go
|
||||
|
||||
@ -1,14 +1,15 @@
|
||||
{-# language DataKinds, TypeApplications #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language TypeApplications #-}
|
||||
module Mu.GRpc.Client.Examples where
|
||||
|
||||
import Data.Conduit
|
||||
import Data.Conduit.Combinators as C
|
||||
import Data.Conduit.List (consume)
|
||||
import qualified Data.Text as T
|
||||
import Network.HTTP2.Client (HostName, PortNumber)
|
||||
import Data.Conduit
|
||||
import Data.Conduit.Combinators as C
|
||||
import Data.Conduit.List (consume)
|
||||
import qualified Data.Text as T
|
||||
import Network.HTTP2.Client (HostName, PortNumber)
|
||||
|
||||
import Mu.GRpc.Client.TyApps
|
||||
import Mu.Rpc.Examples
|
||||
import Mu.GRpc.Client.TyApps
|
||||
import Mu.Rpc.Examples
|
||||
|
||||
sayHello' :: HostName -> PortNumber -> T.Text -> IO (GRpcReply T.Text)
|
||||
sayHello' host port req
|
||||
@ -25,4 +26,4 @@ sayHi' host port n
|
||||
runConduit $ cndt .| C.map (fmap (\(HelloResponse r) -> r)) .| consume
|
||||
|
||||
sayHi :: GrpcClient -> HiRequest -> IO (ConduitT () (GRpcReply HelloResponse) IO ())
|
||||
sayHi = gRpcCall @QuickStartService @"SayHi"
|
||||
sayHi = gRpcCall @QuickStartService @"SayHi"
|
||||
|
||||
@ -1,33 +1,39 @@
|
||||
{-# language PolyKinds, DataKinds, GADTs,
|
||||
MultiParamTypeClasses,
|
||||
FlexibleInstances, FlexibleContexts,
|
||||
ScopedTypeVariables, TypeApplications,
|
||||
TypeOperators, DeriveFunctor,
|
||||
AllowAmbiguousTypes,
|
||||
TupleSections, UndecidableInstances #-}
|
||||
{-# language AllowAmbiguousTypes #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language DeriveFunctor #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
-- | Client for gRPC services defined using Mu 'Service'
|
||||
module Mu.GRpc.Client.Internal where
|
||||
|
||||
import Control.Monad.IO.Class
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM (atomically)
|
||||
import Control.Concurrent.STM.TMChan
|
||||
import Control.Concurrent.STM.TMVar
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
import Data.Conduit.TMChan
|
||||
import Network.HTTP2 (ErrorCode)
|
||||
import Network.HTTP2.Client (ClientIO, TooMuchConcurrency, ClientError, runExceptT)
|
||||
import Network.GRPC.HTTP2.Proto3Wire
|
||||
import Network.GRPC.Client (RawReply, CompressMode(..), StreamDone(..),
|
||||
IncomingEvent(..),OutgoingEvent(..))
|
||||
import Network.GRPC.Client.Helpers
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM (atomically)
|
||||
import Control.Concurrent.STM.TMChan
|
||||
import Control.Concurrent.STM.TMVar
|
||||
import Control.Monad.IO.Class
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Conduit
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
import Data.Conduit.TMChan
|
||||
import Network.GRPC.Client (CompressMode (..), IncomingEvent (..),
|
||||
OutgoingEvent (..), RawReply, StreamDone (..))
|
||||
import Network.GRPC.Client.Helpers
|
||||
import Network.GRPC.HTTP2.Proto3Wire
|
||||
import Network.HTTP2 (ErrorCode)
|
||||
import Network.HTTP2.Client (ClientError, ClientIO, TooMuchConcurrency,
|
||||
runExceptT)
|
||||
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
import Mu.Adapter.ProtoBuf.Via
|
||||
import Mu.Adapter.ProtoBuf.Via
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
|
||||
setupGrpcClient' :: GrpcClientConfig -> IO (Either ClientError GrpcClient)
|
||||
setupGrpcClient' = runExceptT . setupGrpcClient
|
||||
@ -49,16 +55,16 @@ data GRpcReply a
|
||||
deriving (Show, Functor)
|
||||
|
||||
buildGRpcReply1 :: Either TooMuchConcurrency (RawReply a) -> GRpcReply a
|
||||
buildGRpcReply1 (Left tmc) = GRpcTooMuchConcurrency tmc
|
||||
buildGRpcReply1 (Right (Left ec)) = GRpcErrorCode ec
|
||||
buildGRpcReply1 (Left tmc) = GRpcTooMuchConcurrency tmc
|
||||
buildGRpcReply1 (Right (Left ec)) = GRpcErrorCode ec
|
||||
buildGRpcReply1 (Right (Right (_, _, Left es))) = GRpcErrorString es
|
||||
buildGRpcReply1 (Right (Right (_, _, Right r))) = GRpcOk r
|
||||
|
||||
buildGRpcReply2 :: Either TooMuchConcurrency (r, (RawReply a)) -> GRpcReply a
|
||||
buildGRpcReply2 (Left tmc) = GRpcTooMuchConcurrency tmc
|
||||
buildGRpcReply2 (Right (_, (Left ec))) = GRpcErrorCode ec
|
||||
buildGRpcReply2 (Right (_, (Right (_, _, Left es)))) = GRpcErrorString es
|
||||
buildGRpcReply2 (Right (_, (Right (_, _, Right r)))) = GRpcOk r
|
||||
buildGRpcReply2 :: Either TooMuchConcurrency (r, RawReply a) -> GRpcReply a
|
||||
buildGRpcReply2 (Left tmc) = GRpcTooMuchConcurrency tmc
|
||||
buildGRpcReply2 (Right (_, Left ec)) = GRpcErrorCode ec
|
||||
buildGRpcReply2 (Right (_, Right (_, _, Left es))) = GRpcErrorString es
|
||||
buildGRpcReply2 (Right (_, Right (_, _, Right r))) = GRpcOk r
|
||||
|
||||
buildGRpcReply3 :: Either TooMuchConcurrency v -> GRpcReply ()
|
||||
buildGRpcReply3 (Left tmc) = GRpcTooMuchConcurrency tmc
|
||||
@ -77,7 +83,7 @@ class GRpcMethodCall method h where
|
||||
instance (KnownName name, handler ~ IO (GRpcReply ()))
|
||||
=> GRpcMethodCall ('Method name anns '[ ] 'RetNothing) handler where
|
||||
gRpcMethodCall pkgName srvName _ client
|
||||
= simplifyResponse $
|
||||
= simplifyResponse $
|
||||
buildGRpcReply1 <$>
|
||||
rawUnary rpc client ()
|
||||
where methodName = BS.pack (nameVal (Proxy @name))
|
||||
@ -88,7 +94,7 @@ instance ( KnownName name, ProtoBufTypeRef rref r
|
||||
=> GRpcMethodCall ('Method name anns '[ ] ('RetSingle rref)) handler where
|
||||
gRpcMethodCall pkgName srvName _ client
|
||||
= fmap (fmap unViaProtoBufTypeRef) $
|
||||
simplifyResponse $
|
||||
simplifyResponse $
|
||||
buildGRpcReply1 <$>
|
||||
rawUnary @_ @_ @(ViaProtoBufTypeRef rref _)rpc client ()
|
||||
where methodName = BS.pack (nameVal (Proxy @name))
|
||||
@ -98,7 +104,7 @@ instance ( KnownName name, ProtoBufTypeRef vref v
|
||||
, handler ~ (v -> IO (GRpcReply ())) )
|
||||
=> GRpcMethodCall ('Method name anns '[ 'ArgSingle vref ] 'RetNothing) handler where
|
||||
gRpcMethodCall pkgName srvName _ client x
|
||||
= simplifyResponse $
|
||||
= simplifyResponse $
|
||||
buildGRpcReply1 <$>
|
||||
rawUnary @_ @(ViaProtoBufTypeRef vref _) rpc client (ViaProtoBufTypeRef x)
|
||||
where methodName = BS.pack (nameVal (Proxy @name))
|
||||
@ -109,7 +115,7 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r
|
||||
=> GRpcMethodCall ('Method name anns '[ 'ArgSingle vref ] ('RetSingle rref)) handler where
|
||||
gRpcMethodCall pkgName srvName _ client x
|
||||
= fmap (fmap unViaProtoBufTypeRef) $
|
||||
simplifyResponse $
|
||||
simplifyResponse $
|
||||
buildGRpcReply1 <$>
|
||||
rawUnary @_ @(ViaProtoBufTypeRef vref _) @(ViaProtoBufTypeRef rref _)
|
||||
rpc client (ViaProtoBufTypeRef x)
|
||||
@ -123,9 +129,9 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r
|
||||
= do -- Create a new TMChan
|
||||
chan <- newTMChanIO :: IO (TMChan v)
|
||||
-- Start executing the client in another thread
|
||||
promise <- async $
|
||||
promise <- async $
|
||||
fmap (fmap unViaProtoBufTypeRef) $
|
||||
simplifyResponse $
|
||||
simplifyResponse $
|
||||
buildGRpcReply2 <$>
|
||||
rawStreamClient @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r) rpc client ()
|
||||
(\_ -> do nextVal <- liftIO $ atomically $ readTMChan chan
|
||||
@ -139,7 +145,7 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r
|
||||
go
|
||||
Nothing -> do liftIO $ atomically $ closeTMChan chan
|
||||
liftIO $ wait promise
|
||||
return go
|
||||
return go
|
||||
where methodName = BS.pack (nameVal (Proxy @name))
|
||||
rpc = RPC pkgName srvName methodName
|
||||
|
||||
@ -152,16 +158,16 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r
|
||||
var <- newEmptyTMVarIO -- if full, this means an error
|
||||
-- Start executing the client in another thread
|
||||
_ <- async $ do
|
||||
v <- simplifyResponse $
|
||||
v <- simplifyResponse $
|
||||
buildGRpcReply3 <$>
|
||||
rawStreamServer @_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r)
|
||||
rpc client () (ViaProtoBufTypeRef x)
|
||||
(\_ _ (ViaProtoBufTypeRef newVal) -> liftIO $ atomically $
|
||||
(\_ _ (ViaProtoBufTypeRef newVal) -> liftIO $ atomically $
|
||||
-- on the first iteration, say that everything is OK
|
||||
tryPutTMVar var (GRpcOk ()) >> writeTMChan chan newVal)
|
||||
case v of
|
||||
GRpcOk () -> liftIO $ atomically $ closeTMChan chan
|
||||
_ -> liftIO $ atomically $ putTMVar var v
|
||||
_ -> liftIO $ atomically $ putTMVar var v
|
||||
-- This conduit feeds information to the other thread
|
||||
let go = do firstResult <- liftIO $ atomically $ takeTMVar var
|
||||
case firstResult of
|
||||
@ -182,7 +188,7 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r
|
||||
var <- newEmptyTMVarIO -- if full, this means an error
|
||||
-- Start executing the client in another thread
|
||||
_ <- async $ do
|
||||
v <- simplifyResponse $
|
||||
v <- simplifyResponse $
|
||||
buildGRpcReply3 <$>
|
||||
rawGeneralStream
|
||||
@_ @(ViaProtoBufTypeRef vref v) @(ViaProtoBufTypeRef rref r)
|
||||
@ -200,21 +206,21 @@ instance ( KnownName name, ProtoBufTypeRef vref v, ProtoBufTypeRef rref r
|
||||
Just v -> return ((), SendMessage compress (ViaProtoBufTypeRef v)))
|
||||
case v of
|
||||
GRpcOk () -> liftIO $ atomically $ closeTMChan inchan
|
||||
_ -> liftIO $ atomically $ putTMVar var v
|
||||
_ -> liftIO $ atomically $ putTMVar var v
|
||||
-- This conduit feeds information to the other thread
|
||||
let go = do err <- liftIO $ atomically $ takeTMVar var
|
||||
case err of
|
||||
GRpcOk _ -> go2
|
||||
e -> yield $ (\_ -> error "this should never happen") <$> e
|
||||
e -> yield $ (\_ -> error "this should never happen") <$> e
|
||||
go2 = do nextOut <- await
|
||||
case nextOut of
|
||||
Just v -> do liftIO $ atomically $ writeTMChan outchan v
|
||||
go2
|
||||
Nothing -> do r <- liftIO $ atomically $ tryReadTMChan inchan
|
||||
case r of
|
||||
Nothing -> return () -- both are empty, end
|
||||
Just Nothing -> go2
|
||||
Nothing -> return () -- both are empty, end
|
||||
Just Nothing -> go2
|
||||
Just (Just nextIn) -> yield nextIn >> go2
|
||||
return go
|
||||
where methodName = BS.pack (nameVal (Proxy @name))
|
||||
rpc = RPC pkgName srvName methodName
|
||||
rpc = RPC pkgName srvName methodName
|
||||
|
||||
@ -1,9 +1,15 @@
|
||||
{-# language PolyKinds, DataKinds, TypeOperators,
|
||||
MultiParamTypeClasses, TypeFamilies,
|
||||
FlexibleInstances, FlexibleContexts,
|
||||
UndecidableInstances, TypeApplications,
|
||||
ScopedTypeVariables, AllowAmbiguousTypes,
|
||||
TemplateHaskell #-}
|
||||
{-# language AllowAmbiguousTypes #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TemplateHaskell #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
-- | Client for gRPC services defined using Mu 'Service'
|
||||
-- using plain Haskell records of functions
|
||||
module Mu.GRpc.Client.Record (
|
||||
@ -19,21 +25,21 @@ module Mu.GRpc.Client.Record (
|
||||
, generateRecordFromService
|
||||
) where
|
||||
|
||||
import Control.Applicative
|
||||
import Data.Char
|
||||
import Data.Conduit (ConduitT)
|
||||
import Data.Proxy
|
||||
import Data.Void
|
||||
import GHC.Generics hiding (NoSourceUnpackedness, NoSourceStrictness)
|
||||
import GHC.TypeLits
|
||||
import Language.Haskell.TH hiding (ppr)
|
||||
import Language.Haskell.TH.Datatype
|
||||
import Control.Applicative
|
||||
import Data.Char
|
||||
import Data.Conduit (ConduitT)
|
||||
import Data.Proxy
|
||||
import Data.Void
|
||||
import GHC.Generics hiding (NoSourceStrictness, NoSourceUnpackedness)
|
||||
import GHC.TypeLits
|
||||
import Language.Haskell.TH hiding (ppr)
|
||||
import Language.Haskell.TH.Datatype
|
||||
|
||||
import Network.GRPC.Client (CompressMode(..))
|
||||
import Network.GRPC.Client.Helpers
|
||||
import Network.GRPC.Client (CompressMode (..))
|
||||
import Network.GRPC.Client.Helpers
|
||||
|
||||
import Mu.GRpc.Client.Internal
|
||||
import Mu.Rpc
|
||||
import Mu.GRpc.Client.Internal
|
||||
import Mu.Rpc
|
||||
|
||||
-- | Fills in a Haskell record of functions with the corresponding
|
||||
-- calls to gRPC services from a Mu 'Service' declaration.
|
||||
@ -132,11 +138,11 @@ completeName :: Namer -> String -> String
|
||||
completeName namer name = firstUpper (namer (firstUpper name))
|
||||
|
||||
firstUpper :: String -> String
|
||||
firstUpper [] = error "Empty names are not allowed"
|
||||
firstUpper [] = error "Empty names are not allowed"
|
||||
firstUpper (x:rest) = toUpper x : rest
|
||||
|
||||
firstLower :: String -> String
|
||||
firstLower [] = error "Empty names are not allowed"
|
||||
firstLower [] = error "Empty names are not allowed"
|
||||
firstLower (x:rest) = toLower x : rest
|
||||
|
||||
-- Parsing
|
||||
@ -153,7 +159,7 @@ typeToServiceDef toplevelty
|
||||
Service <$> tyString sn
|
||||
<*> pure []
|
||||
<*> mapM typeToMethodDef methods'
|
||||
|
||||
|
||||
typeToMethodDef :: Type -> Maybe (Method String)
|
||||
typeToMethodDef ty
|
||||
= do (mn, _, args, ret) <- tyD4 'Method ty
|
||||
@ -233,4 +239,4 @@ tyD4 name (SigT t _) = tyD4 name t
|
||||
tyD4 name (AppT (AppT (AppT (AppT (PromotedT c) x) y) z) u)
|
||||
| c == name = Just (x, y, z, u)
|
||||
| otherwise = Nothing
|
||||
tyD4 _ _ = Nothing
|
||||
tyD4 _ _ = Nothing
|
||||
|
||||
@ -1,7 +1,12 @@
|
||||
{-# language PolyKinds, DataKinds, GADTs,
|
||||
MultiParamTypeClasses, FlexibleContexts,
|
||||
ScopedTypeVariables, TypeApplications,
|
||||
TypeOperators, AllowAmbiguousTypes #-}
|
||||
{-# language AllowAmbiguousTypes #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
-- | Client for gRPC services defined using Mu 'Service'
|
||||
-- using 'TypeApplications'
|
||||
module Mu.GRpc.Client.TyApps (
|
||||
@ -16,18 +21,18 @@ module Mu.GRpc.Client.TyApps (
|
||||
, GRpcReply(..)
|
||||
) where
|
||||
|
||||
import Network.GRPC.Client (CompressMode(..))
|
||||
import Network.GRPC.Client.Helpers
|
||||
import Network.GRPC.Client (CompressMode (..))
|
||||
import Network.GRPC.Client.Helpers
|
||||
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
|
||||
import Mu.GRpc.Client.Internal
|
||||
import Mu.GRpc.Client.Internal
|
||||
|
||||
-- | Call a method from a Mu definition.
|
||||
-- This method is thought to be used with @TypeApplications@:
|
||||
-- > gRpcCall @"packageName" @ServiceDeclaration @"method"
|
||||
--
|
||||
-- > gRpcCall @"packageName" @ServiceDeclaration @"method"
|
||||
--
|
||||
-- The additional arguments you must provide to 'grpcCall'
|
||||
-- depend on the signature of the method itself:
|
||||
-- * The resulting value is always wrapped in 'GRpcReply'.
|
||||
@ -36,4 +41,4 @@ import Mu.GRpc.Client.Internal
|
||||
gRpcCall :: forall s methodName h.
|
||||
(GRpcServiceMethodCall s (s :-->: methodName) h)
|
||||
=> GrpcClient -> h
|
||||
gRpcCall = gRpcServiceMethodCall (Proxy @s) (Proxy @(s :-->: methodName))
|
||||
gRpcCall = gRpcServiceMethodCall (Proxy @s) (Proxy @(s :-->: methodName))
|
||||
|
||||
@ -1,10 +1,10 @@
|
||||
{-# language OverloadedStrings #-}
|
||||
module Main where
|
||||
|
||||
import Mu.GRpc.Server
|
||||
import Mu.Rpc.Examples
|
||||
import Mu.GRpc.Server
|
||||
import Mu.Rpc.Examples
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
main = do
|
||||
putStrLn "running quickstart application"
|
||||
runGRpcApp 8080 quickstartServer
|
||||
runGRpcApp 8080 quickstartServer
|
||||
|
||||
@ -1,9 +1,13 @@
|
||||
{-# language PolyKinds, DataKinds, GADTs,
|
||||
MultiParamTypeClasses,
|
||||
FlexibleInstances, FlexibleContexts,
|
||||
UndecidableInstances,
|
||||
TypeApplications, TypeOperators,
|
||||
ScopedTypeVariables #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language FlexibleInstances #-}
|
||||
{-# language GADTs #-}
|
||||
{-# language MultiParamTypeClasses #-}
|
||||
{-# language PolyKinds #-}
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
-- | Execute a Mu 'Server' using gRPC as transport layer
|
||||
module Mu.GRpc.Server (
|
||||
-- * Run a 'Server' directly
|
||||
@ -14,29 +18,29 @@ module Mu.GRpc.Server (
|
||||
, gRpcApp
|
||||
) where
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM (atomically)
|
||||
import Control.Concurrent.STM.TMVar
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Conduit
|
||||
import Data.Conduit.TMChan
|
||||
import Data.Kind
|
||||
import Data.Proxy
|
||||
import Network.GRPC.HTTP2.Encoding (uncompressed, gzip)
|
||||
import Network.GRPC.HTTP2.Proto3Wire
|
||||
import Network.GRPC.Server.Wai (ServiceHandler)
|
||||
import Network.GRPC.Server.Handlers
|
||||
import Network.GRPC.Server.Wai as Wai
|
||||
import Network.Wai (Application)
|
||||
import Network.Wai.Handler.Warp (Port, Settings, run, runSettings)
|
||||
import Network.Wai.Handler.WarpTLS (TLSSettings, runTLS)
|
||||
import Control.Concurrent.Async
|
||||
import Control.Concurrent.STM (atomically)
|
||||
import Control.Concurrent.STM.TMVar
|
||||
import Control.Monad.IO.Class
|
||||
import Data.ByteString (ByteString)
|
||||
import qualified Data.ByteString.Char8 as BS
|
||||
import Data.Conduit
|
||||
import Data.Conduit.TMChan
|
||||
import Data.Kind
|
||||
import Data.Proxy
|
||||
import Network.GRPC.HTTP2.Encoding (gzip, uncompressed)
|
||||
import Network.GRPC.HTTP2.Proto3Wire
|
||||
import Network.GRPC.Server.Handlers
|
||||
import Network.GRPC.Server.Wai (ServiceHandler)
|
||||
import Network.GRPC.Server.Wai as Wai
|
||||
import Network.Wai (Application)
|
||||
import Network.Wai.Handler.Warp (Port, Settings, run, runSettings)
|
||||
import Network.Wai.Handler.WarpTLS (TLSSettings, runTLS)
|
||||
|
||||
import Mu.Rpc
|
||||
import Mu.Server
|
||||
import Mu.Schema
|
||||
import Mu.Adapter.ProtoBuf.Via
|
||||
import Mu.Adapter.ProtoBuf.Via
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
import Mu.Server
|
||||
|
||||
-- | Run a Mu 'Server' on the given port.
|
||||
runGRpcApp
|
||||
@ -47,8 +51,8 @@ runGRpcApp
|
||||
runGRpcApp port svr = run port (gRpcApp svr)
|
||||
|
||||
-- | Run a Mu 'Server' using the given 'Settings'.
|
||||
--
|
||||
-- Go to 'Network.Wai.Handler.Warp' to declare 'Settings'.
|
||||
--
|
||||
-- Go to 'Network.Wai.Handler.Warp' to declare 'Settings'.
|
||||
runGRpcAppSettings
|
||||
:: ( KnownName name, KnownName (FindPackageName anns)
|
||||
, GRpcMethodHandlers methods handlers )
|
||||
@ -88,7 +92,7 @@ gRpcServiceHandlers
|
||||
gRpcServiceHandlers (Server svr) = gRpcMethodHandlers packageName serviceName svr
|
||||
where packageName = BS.pack (nameVal (Proxy @(FindPackageName anns)))
|
||||
serviceName = BS.pack (nameVal (Proxy @name))
|
||||
|
||||
|
||||
class GRpcMethodHandlers (ms :: [Method mnm]) (hs :: [Type]) where
|
||||
gRpcMethodHandlers :: ByteString -> ByteString
|
||||
-> HandlersIO ms hs -> [ServiceHandler]
|
||||
@ -204,6 +208,7 @@ instance (ProtoBufTypeRef vref v, ProtoBufTypeRef rref r)
|
||||
return ((), IncomingStream cstreamHandler cstreamFinalizer, (), OutgoingStream readNext)
|
||||
|
||||
toTMVarConduit :: TMVar (Maybe r) -> ConduitT r Void IO ()
|
||||
toTMVarConduit var = do x <- await
|
||||
liftIO $ atomically $ putTMVar var x
|
||||
toTMVarConduit var
|
||||
toTMVarConduit var = do
|
||||
x <- await
|
||||
liftIO $ atomically $ putTMVar var x
|
||||
toTMVarConduit var
|
||||
|
||||
Loading…
Reference in New Issue
Block a user