Event refactoring and schema instances (#1506)

* Add dispatch and bind to schema-profunctor

* Refactor Event and add schema instances

* Add failure test for TaggedObject

Co-authored-by: Matthias Fischmann <mf@zerobuzz.net>

libs/schema-profunctor/package.yaml

@@ -21,6 +21,7 @@ library:
     - profunctors
     - swagger2 >=2 && < 2.7
     - text
+    - transformers
     - vector
 tests:
   schemas-tests:

libs/schema-profunctor/schema-profunctor.cabal

@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 8ae5a0058207984f9fb5ad47e445b688a001620deff02fea29001f7fd2615967
+-- hash: 11ed18fc8f6fc6cc51f29a022f7695bc086b893b80a35ed8beb5f0840d1d8b45
 
 name:           schema-profunctor
 version:        0.1.0
@@ -36,6 +36,7 @@ library
     , profunctors
     , swagger2 >=2 && <2.7
     , text
+    , transformers
     , vector
   default-language: Haskell2010
 

libs/schema-profunctor/src/Data/Schema.hs

@@ -30,22 +30,29 @@ module Data.Schema
     ToSchema (..),
     Schema (..),
     mkSchema,
+    schemaDoc,
+    schemaIn,
+    schemaOut,
     HasDoc (..),
     withParser,
     SwaggerDoc,
     swaggerDoc,
     NamedSwaggerDoc,
     object,
     objectWithDocModifier,
+    objectOver,
     jsonObject,
     field,
     fieldWithDocModifier,
+    fieldOver,
     array,
     nonEmptyArray,
     enum,
     opt,
     optWithDefault,
     lax,
+    bind,
+    dispatch,
     text,
     parsedText,
     element,
@@ -64,6 +71,7 @@ where
 import Control.Applicative
 import Control.Comonad
 import Control.Lens hiding (element, enum, (.=))
+import Control.Monad.Trans.Cont
 import qualified Data.Aeson.Types as A
 import Data.Bifunctor.Joker
 import Data.List.NonEmpty (NonEmpty)
@@ -240,10 +248,30 @@ schemaOut :: SchemaP ss v m a b -> a -> Maybe m
 schemaOut (SchemaP _ _ (SchemaOut o)) = o
 
 -- | A schema for a one-field JSON object.
-field :: HasField doc' doc => Text -> ValueSchema doc' a -> ObjectSchema doc a
-field name sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w)
+field ::
+  forall doc' doc a b.
+  HasField doc' doc =>
+  Text ->
+  SchemaP doc' A.Value A.Value a b ->
+  SchemaP doc A.Object [A.Pair] a b
+field = fieldOver id
+
+-- | A version of 'field' for more general input values.
+--
+-- This can be used when the input type 'v' of the parser is not exactly a
+-- 'A.Object', but it contains one. The first argument is a lens that can
+-- extract the 'A.Object' contained in 'v'.
+fieldOver ::
+  HasField doc' doc =>
+  Lens v v' A.Object A.Value ->
+  Text ->
+  SchemaP doc' v' A.Value a b ->
+  SchemaP doc v [A.Pair] a b
+fieldOver l name sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w)
   where
-    r obj = A.explicitParseField (schemaIn sch) obj name
+    parseField obj = ContT $ \k -> A.explicitParseField k obj name
+    r obj = runContT (l parseField obj) (schemaIn sch)
+
     w x = do
       v <- schemaOut sch x
       pure [name A..= v]
@@ -272,10 +300,26 @@ tag f = rmap runIdentity . f . rmap Identity
 --
 -- This can be used to convert a combination of schemas obtained using
 -- 'field' into a single schema for a JSON object.
-object :: HasObject doc doc' => Text -> ObjectSchema doc a -> ValueSchema doc' a
-object name sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w)
+object ::
+  HasObject doc doc' =>
+  Text ->
+  SchemaP doc A.Object [A.Pair] a b ->
+  SchemaP doc' A.Value A.Value a b
+object = objectOver id
+
+-- | A version of 'object' for more general input values.
+--
+-- Just like 'fieldOver', but for 'object'.
+objectOver ::
+  HasObject doc doc' =>
+  Lens v v' A.Value A.Object ->
+  Text ->
+  SchemaP doc v' [A.Pair] a b ->
+  SchemaP doc' v A.Value a b
+objectOver l name sch = SchemaP (SchemaDoc s) (SchemaIn r) (SchemaOut w)
   where
-    r = A.withObject (T.unpack name) (schemaIn sch)
+    parseObject val = ContT $ \k -> A.withObject (T.unpack name) k val
+    r v = runContT (l parseObject v) (schemaIn sch)
     w x = A.object <$> schemaOut sch x
     s = mkObject name (schemaDoc sch)
 
@@ -398,6 +442,44 @@ optWithDefault w0 sch = SchemaP (SchemaDoc d) (SchemaIn i) (SchemaOut o)
 lax :: Alternative f => f (Maybe a) -> f (Maybe a)
 lax = fmap join . optional
 
+-- | A schema depending on a parsed value.
+--
+-- Even though 'SchemaP' does not expose a monadic interface, it is possible to
+-- make the parser of a schema depend on the values parsed by a previous
+-- schema.
+--
+-- For example, a schema for an object containing a "type" field which
+-- determines how the rest of the object is parsed. To construct the schema to
+-- use as the second argument of 'bind', one can use 'dispatch'.
+bind ::
+  (Monoid d, Monoid w) =>
+  SchemaP d v w a b ->
+  SchemaP d (v, b) w a c ->
+  SchemaP d v w a (b, c)
+bind sch1 sch2 = mkSchema d i o
+  where
+    d = schemaDoc sch1 <> schemaDoc sch2
+    i v = do
+      b <- schemaIn sch1 v
+      c <- schemaIn sch2 (v, b)
+      pure (b, c)
+    o a = (<>) <$> schemaOut sch1 a <*> schemaOut sch2 a
+
+-- | A union of schemas over a finite type of "tags".
+--
+-- Normally used together with 'bind' to construct schemas that depend on some
+-- "tag" value.
+dispatch ::
+  (Bounded t, Enum t, Monoid d) =>
+  (t -> SchemaP d v w a b) ->
+  SchemaP d (v, t) w a b
+dispatch sch = mkSchema d i o
+  where
+    allSch = foldMap sch (enumFromTo minBound maxBound)
+    d = schemaDoc allSch
+    o = schemaOut allSch
+    i (v, t) = schemaIn (sch t) v
+
 -- | A schema for a textual value.
 text :: Text -> ValueSchema NamedSwaggerDoc Text
 text name =

libs/schema-profunctor/test/unit/Test/Data/Schema.hs

@@ -18,7 +18,8 @@
 module Test.Data.Schema where
 
 import Control.Applicative
-import Control.Lens (Prism', at, prism', (?~), (^.))
+import Control.Arrow ((&&&))
+import Control.Lens (Prism', at, prism', (?~), (^.), _1)
 import Data.Aeson (FromJSON (..), Result (..), ToJSON (..), Value, decode, encode, fromJSON)
 import Data.Aeson.QQ
 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
@@ -48,6 +49,11 @@ tests =
       testUser1FromJSON,
       testUser2ToJSON,
       testUser2FromJSON,
+      testTaggedObjectToJSON,
+      testTaggedObjectFromJSON,
+      testTaggedObject2ToJSON,
+      testTaggedObject2FromJSON,
+      testTaggedObject3FromJSON,
       testNonEmptyParseFailure,
       testNonEmptyParseSuccess,
       testNonEmptyToJSON,
@@ -178,6 +184,48 @@ testUser2FromJSON =
       (Just exampleUser2)
       (decode exampleUser2JSON)
 
+testTaggedObjectToJSON :: TestTree
+testTaggedObjectToJSON =
+  testCase "toJSON TaggedObject" $
+    assertEqual
+      "toJSON should match handwritten JSON"
+      exampleTaggedObjectJSON
+      (toJSON exampleTaggedObject)
+
+testTaggedObjectFromJSON :: TestTree
+testTaggedObjectFromJSON =
+  testCase "fromJSON TaggedObject" $
+    assertEqual
+      "fromJSON should match example"
+      (Success exampleTaggedObject)
+      (fromJSON exampleTaggedObjectJSON)
+
+testTaggedObject2ToJSON :: TestTree
+testTaggedObject2ToJSON =
+  testCase "toJSON TaggedObject 2" $
+    assertEqual
+      "toJSON should match handwritten JSON"
+      exampleTaggedObject2JSON
+      (toJSON exampleTaggedObject2)
+
+testTaggedObject2FromJSON :: TestTree
+testTaggedObject2FromJSON =
+  testCase "fromJSON TaggedObject 2" $
+    assertEqual
+      "fromJSON should match example"
+      (Success exampleTaggedObject2)
+      (fromJSON exampleTaggedObject2JSON)
+
+testTaggedObject3FromJSON :: TestTree
+testTaggedObject3FromJSON =
+  testCase "fromJSON TaggedObject failure" $
+    case fromJSON @TaggedObject exampleTaggedObject3JSON of
+      Success _ -> assertFailure "fromJSON should fail"
+      Error err -> do
+        assertBool
+          "fromJSON error should mention missing key"
+          ("\"tag1_data\"" `isInfixOf` err)
+
 testNonEmptyParseFailure :: TestTree
 testNonEmptyParseFailure =
   testCase "NonEmpty parse failure" $ do
@@ -343,6 +391,63 @@ exampleUser2 = User "Bob" Nothing (Just 100)
 exampleUser2JSON :: LByteString
 exampleUser2JSON = "{\"expire\":100,\"name\":\"Bob\"}"
 
+-- bind schemas
+
+data TaggedObject = TO
+  { toTag :: Tag,
+    toObj :: UntaggedObject
+  }
+  deriving (Eq, Show)
+  deriving (FromJSON, ToJSON, S.ToSchema) via Schema TaggedObject
+
+data UntaggedObject = Obj1 String | Obj2 Int
+  deriving (Eq, Show)
+
+data Tag = Tag1 | Tag2
+  deriving (Eq, Show, Enum, Bounded)
+
+_Obj1 :: Prism' UntaggedObject String
+_Obj1 = prism' Obj1 $ \case
+  Obj1 a -> Just a
+  _ -> Nothing
+
+_Obj2 :: Prism' UntaggedObject Int
+_Obj2 = prism' Obj2 $ \case
+  Obj2 b -> Just b
+  _ -> Nothing
+
+instance ToSchema Tag where
+  schema = enum @Text "Tag" (element "tag1" Tag1 <> element "tag2" Tag2)
+
+instance ToSchema TaggedObject where
+  schema =
+    object "TaggedObject" $
+      uncurry TO <$> (toTag &&& toObj)
+        .= bind
+          (fst .= field "tag" schema)
+          (snd .= fieldOver _1 "obj" (objectOver _1 "UntaggedObject" untaggedSchema))
+    where
+      untaggedSchema = dispatch $ \case
+        Tag1 -> tag _Obj1 (field "tag1_data" schema)
+        Tag2 -> tag _Obj2 (field "tag2_data" schema)
+
+exampleTaggedObject :: TaggedObject
+exampleTaggedObject = TO Tag1 (Obj1 "foo")
+
+exampleTaggedObjectJSON :: Value
+exampleTaggedObjectJSON = [aesonQQ| {"tag": "tag1", "obj": { "tag1_data": "foo" } } |]
+
+exampleTaggedObject2 :: TaggedObject
+exampleTaggedObject2 = TO Tag2 (Obj2 44)
+
+exampleTaggedObject2JSON :: Value
+exampleTaggedObject2JSON = [aesonQQ| {"tag": "tag2", "obj": { "tag2_data": 44 } } |]
+
+exampleTaggedObject3JSON :: Value
+exampleTaggedObject3JSON = [aesonQQ| {"tag": "tag1", "obj": { "tag2_data": 44 } } |]
+
+-- non empty
+
 newtype NonEmptyTest = NonEmptyTest {nl :: NonEmpty Text}
   deriving stock (Eq, Show)
   deriving (ToJSON, FromJSON, S.ToSchema) via Schema NonEmptyTest

libs/types-common/src/Data/Code.hs

@@ -31,7 +31,9 @@ import Data.Aeson.TH
 import Data.ByteString.Conversion
 import Data.Json.Util
 import Data.Range
+import Data.Schema
 import Data.Scientific (toBoundedInteger)
+import qualified Data.Swagger as S
 import Data.Text.Ascii
 import Data.Time.Clock
 import Imports
@@ -40,12 +42,28 @@ import Test.QuickCheck (Arbitrary (arbitrary))
 -- | A scoped identifier for a 'Value' with an associated 'Timeout'.
 newtype Key = Key {asciiKey :: Range 20 20 AsciiBase64Url}
   deriving (Eq, Show)
-  deriving newtype (FromJSON, ToJSON, FromByteString, ToByteString, Arbitrary)
+  deriving newtype
+    ( FromJSON,
+      ToJSON,
+      ToSchema,
+      S.ToSchema,
+      FromByteString,
+      ToByteString,
+      Arbitrary
+    )
 
 -- | A secret value bound to a 'Key' and a 'Timeout'.
 newtype Value = Value {asciiValue :: Range 6 20 AsciiBase64Url}
   deriving (Eq, Show)
-  deriving newtype (FromJSON, ToJSON, FromByteString, ToByteString, Arbitrary)
+  deriving newtype
+    ( FromJSON,
+      ToJSON,
+      ToSchema,
+      S.ToSchema,
+      FromByteString,
+      ToByteString,
+      Arbitrary
+    )
 
 newtype Timeout = Timeout
   {timeoutDiffTime :: NominalDiffTime}

libs/types-common/src/Data/Misc.hs

@@ -255,6 +255,7 @@ newtype HttpsUrl = HttpsUrl
   { httpsUrl :: URIRef Absolute
   }
   deriving stock (Eq, Ord, Generic)
+  deriving (FromJSON, ToJSON, S.ToSchema) via Schema HttpsUrl
 
 mkHttpsUrl :: URIRef Absolute -> Either String HttpsUrl
 mkHttpsUrl uri =
@@ -274,13 +275,10 @@ instance ToByteString HttpsUrl where
 instance FromByteString HttpsUrl where
   parser = either fail pure . mkHttpsUrl =<< uriParser strictURIParserOptions
 
-instance FromJSON HttpsUrl where
-  parseJSON =
-    A.withText "HttpsUrl" $
-      either fail return . runParser parser . encodeUtf8
-
-instance ToJSON HttpsUrl where
-  toJSON = toJSON . decodeUtf8 . toByteString'
+instance ToSchema HttpsUrl where
+  schema =
+    (decodeUtf8 . toByteString')
+      .= parsedText "HttpsUrl" (runParser parser . encodeUtf8)
 
 instance Cql HttpsUrl where
   ctype = Tagged BlobColumn