[WPB-11196] Generate schemas for <service>.yaml

libs/cassandra-util/src/Cassandra/Options.hs

@@ -12,7 +12,7 @@ data Endpoint = Endpoint
   { host :: !Text,
     port :: !Word16
   }
-  deriving (Show, Generic)
+  deriving (Show, Eq, Generic)
 
 deriveFromJSON defaultOptions ''Endpoint
 
@@ -27,6 +27,6 @@ data CassandraOpts = CassandraOpts
     filterNodesByDatacentre :: !(Maybe Text),
     tlsCa :: Maybe FilePath
   }
-  deriving (Show, Generic)
+  deriving (Show, Eq, Generic)
 
 deriveFromJSON defaultOptions ''CassandraOpts

libs/extended/default.nix

@@ -19,13 +19,15 @@
 , hspec-discover
 , http-client
 , http-client-tls
+, http-media
 , http-types
 , imports
 , lib
 , metrics-wai
 , monad-control
 , resourcet
 , retry
+, schema-profunctor
 , servant
 , servant-client
 , servant-client-core
@@ -40,6 +42,7 @@
 , transformers
 , unliftio
 , wai
+, yaml
 }:
 mkDerivation {
   pname = "extended";
@@ -59,12 +62,14 @@ mkDerivation {
     exceptions
     http-client
     http-client-tls
+    http-media
     http-types
     imports
     metrics-wai
     monad-control
     resourcet
     retry
+    schema-profunctor
     servant
     servant-client
     servant-client-core
@@ -77,6 +82,7 @@ mkDerivation {
     transformers
     unliftio
     wai
+    yaml
   ];
   testHaskellDepends = [
     aeson

libs/extended/extended.cabal

@@ -91,12 +91,14 @@ library
     , exceptions
     , http-client
     , http-client-tls
+    , http-media
     , http-types
     , imports
     , metrics-wai
     , monad-control
     , resourcet
     , retry
+    , schema-profunctor
     , servant
     , servant-client
     , servant-client-core
@@ -109,6 +111,7 @@ library
     , transformers
     , unliftio
     , wai
+    , yaml
 
   default-language:   GHC2021
 

libs/extended/src/Network/AMQP/Extended.hs

@@ -55,7 +55,7 @@ data RabbitMqTlsOpts = RabbitMqTlsOpts
   { caCert :: !(Maybe FilePath),
     insecureSkipVerifyTls :: Bool
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
 parseTlsJson :: Object -> Parser (Maybe RabbitMqTlsOpts)
 parseTlsJson v = do
@@ -111,7 +111,7 @@ data AmqpEndpoint = AmqpEndpoint
     vHost :: !Text,
     tls :: !(Maybe RabbitMqTlsOpts)
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
 instance FromJSON AmqpEndpoint where
   parseJSON = withObject "AmqpEndpoint" $ \v ->

libs/extended/src/Servant/API/Extended.hs

@@ -19,14 +19,18 @@
 -- errors instead of plaintext.
 module Servant.API.Extended where
 
+import Data.Bifunctor
 import Data.ByteString
 import Data.ByteString.Lazy qualified as BL
 import Data.EitherR (fmapL)
 import Data.Kind
+import Data.List.NonEmpty qualified as NE
 import Data.Metrics.Servant
 import Data.Typeable
+import Data.Yaml as Y
 import GHC.TypeLits
 import Imports
+import Network.HTTP.Media qualified as M
 import Network.HTTP.Types hiding (Header, ResponseHeaders)
 import Network.Wai
 import Servant.API
@@ -116,3 +120,18 @@ instance
 
 instance (RoutesToPaths rest) => RoutesToPaths (ReqBodyCustomError' mods list tag a :> rest) where
   getRoutes = getRoutes @rest
+
+data YAML
+
+instance Accept YAML where
+  contentTypes _ =
+    "application"
+      M.// "yaml"
+      M./: ("charset", "utf-8")
+      NE.:| ["application" M.// "yaml"]
+
+instance {-# OVERLAPPABLE #-} (ToJSON a) => MimeRender YAML a where
+  mimeRender _ = fromStrict . Y.encode
+
+instance {-# OVERLAPPABLE #-} (FromJSON a) => MimeUnrender YAML a where
+  mimeUnrender _ = first show . Y.decodeEither' . toStrict

libs/extended/src/System/Logger/Extended.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# OPTIONS_GHC -Wno-orphans #-}
 
@@ -41,6 +40,7 @@ import Data.ByteString (toStrict)
 import Data.ByteString.Builder qualified as B
 import Data.ByteString.Lazy.Char8 qualified as L
 import Data.Map.Lazy qualified as Map
+import Data.Schema qualified as S
 import Data.Text.Encoding
 import Data.Text.Encoding.Error
 import GHC.Generics
@@ -50,14 +50,36 @@ import System.Logger.Class qualified as LC
 
 deriving instance Generic LC.Level
 
-instance FromJSON LC.Level
+deriving via (S.Schema LC.Level) instance Aeson.FromJSON LC.Level
 
-instance ToJSON LC.Level
+deriving via (S.Schema LC.Level) instance Aeson.ToJSON LC.Level
+
+instance S.ToSchema LC.Level where
+  schema =
+    S.enum @Text "Level" $
+      mconcat
+        [ S.element "Trace" Trace,
+          S.element "Debug" Debug,
+          S.element "Info" Info,
+          S.element "Warn" Warn,
+          S.element "Error" LC.Error,
+          S.element "Fatal" Fatal
+        ]
 
 -- | The log formats supported
 data LogFormat = JSON | Plain | Netstring | StructuredJSON
-  deriving stock (Eq, Show, Generic)
-  deriving anyclass (ToJSON, FromJSON)
+  deriving stock (Eq, Show, Bounded, Enum, Generic)
+  deriving (ToJSON, FromJSON) via (S.Schema LogFormat)
+
+instance S.ToSchema LogFormat where
+  schema =
+    S.enum @Text "LogFormat" $
+      mconcat
+        [ S.element "JSON" JSON,
+          S.element "Plain" Plain,
+          S.element "Netstring" Netstring,
+          S.element "StructuredJSON" StructuredJSON
+        ]
 
 -- | We use this as an intermediate structure to ease the implementation of the
 -- ToJSON instance but we could just inline everything. I think this has

libs/extended/test/Test/System/Logger/ExtendedSpec.hs

@@ -28,6 +28,8 @@ import Test.Hspec (Spec, describe, it, shouldBe)
 spec :: Spec
 spec =
   describe "System.Loggger.Extended" $ do
+    it "instance {To,From}JSON LogFormat" $ do
+      Aeson.eitherDecode' "[\"JSON\", \"Plain\", \"Netstring\", \"StructuredJSON\"]" `shouldBe` Right [minBound @LogFormat ..]
     describe "LogFormat: StructuredJSON" $ do
       it "should encode logs as new line separated structured JSON with log level, messages and fields" $ do
         withSystemTempFile "structured-json" $ \f h -> do

libs/types-common/src/Data/Json/Util.hs

@@ -28,6 +28,9 @@ module Data.Json.Util
     toJSONFieldName,
     (#),
     ToJSONObject (..),
+    JsonObject,
+    mkJsonObject,
+    unJsonObject,
 
     -- * UTCTimeMillis
     UTCTimeMillis,
@@ -53,6 +56,7 @@ import Cassandra qualified as CQL
 import Control.Lens hiding ((#), (.=))
 import Data.Aeson (FromJSON (..), ToJSON (..))
 import Data.Aeson qualified as A
+import Data.Aeson.KeyMap qualified as A
 import Data.Aeson.Types qualified as A
 import Data.Attoparsec.Text qualified as Atto
 import Data.Attoparsec.Time qualified as Atto
@@ -63,8 +67,8 @@ import Data.ByteString.Conversion qualified as BS
 import Data.ByteString.Lazy qualified as L
 import Data.ByteString.UTF8 qualified as UTF8
 import Data.Fixed
-import Data.OpenApi qualified as S
-import Data.Schema
+import Data.OpenApi qualified as O
+import Data.Schema as S
 import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
 import Data.Text.Encoding.Error qualified as Text
@@ -99,24 +103,24 @@ infixr 5 #
 -- Unlike with 'UTCTime', 'Show' renders ISO string.
 newtype UTCTimeMillis = UTCTimeMillis {fromUTCTimeMillis :: UTCTime}
   deriving (Eq, Ord, Generic)
-  deriving (FromJSON, ToJSON, S.ToSchema) via Schema UTCTimeMillis
+  deriving (FromJSON, ToJSON, O.ToSchema) via Schema UTCTimeMillis
 
 instance ToSchema UTCTimeMillis where
   schema =
     UTCTimeMillis
       <$> showUTCTimeMillis
         .= ( utcTimeTextSchema "UTCTimeMillis"
-               & doc . S.schema
-                 %~ (S.format ?~ "yyyy-mm-ddThh:MM:ss.qqqZ")
-                   . (S.example ?~ "2021-05-12T10:52:02.671Z")
+               & doc . O.schema
+                 %~ (O.format ?~ "yyyy-mm-ddThh:MM:ss.qqqZ")
+                   . (O.example ?~ "2021-05-12T10:52:02.671Z")
            )
 
 utcTimeTextSchema :: Text -> ValueSchemaP NamedSwaggerDoc Text UTCTime
 utcTimeTextSchema name =
   parsedText name (Atto.parseOnly (Atto.utcTime <* Atto.endOfInput))
-    & doc . S.schema
-      %~ (S.format ?~ "yyyy-mm-ddThh:MM:ssZ")
-        . (S.example ?~ "2021-05-12T10:52:02Z")
+    & doc . O.schema
+      %~ (O.format ?~ "yyyy-mm-ddThh:MM:ssZ")
+        . (O.example ?~ "2021-05-12T10:52:02Z")
 
 utcTimeSchema :: ValueSchema NamedSwaggerDoc UTCTime
 utcTimeSchema = showUTCTime .= utcTimeTextSchema "UTCTime"
@@ -164,17 +168,33 @@ class ToJSONObject a where
 instance ToJSONObject A.Object where
   toJSONObject = id
 
+instance ToJSONObject [A.Pair] where
+  toJSONObject = A.fromList
+
 -----------------------------------------------------------------------------
 -- Aeson Object
 
-instance S.ToParamSchema A.Object where
-  toParamSchema _ =
-    mempty & S.type_ ?~ S.OpenApiString
+-- | Arbitrary aeson object value with helpful {to,from}json instances and schema.
+newtype JsonObject = JsonObject {unJsonObject :: A.Object}
+  deriving newtype (Eq, Ord, Show)
+  deriving (O.ToSchema) via (Schema JsonObject)
 
-instance ToSchema A.Object where
-  schema =
-    named "Object" $
-      id .= jsonObject
+mkJsonObject :: (ToJSONObject a) => a -> JsonObject
+mkJsonObject = JsonObject . toJSONObject
+
+instance A.FromJSON JsonObject where
+  parseJSON = A.withObject "Object" (pure . JsonObject)
+
+instance A.ToJSON JsonObject where
+  toJSON (JsonObject obj) = A.Object obj
+
+instance S.ToSchema JsonObject where
+  schema = named "Object" $ unJsonObject .= (JsonObject <$> S.jsonObject)
+
+-- | This instance is currently still used for 'Push' (in a `List1`).  Instead we could
+-- introduce a type `JsonObjectList1` that works analogously to `JsonObject`.
+instance S.ToSchema A.Object where
+  schema = named "Object" $ id .= S.jsonObject
 
 -----------------------------------------------------------------------------
 -- toJSONFieldName
@@ -204,7 +224,7 @@ toJSONFieldName = A.defaultOptions {A.fieldLabelModifier = A.camelTo2 '_'}
 -- Some related discussion: <https://github.com/bos/aeson/issues/126>.
 newtype Base64ByteString = Base64ByteString {fromBase64ByteString :: ByteString}
   deriving stock (Eq, Ord, Show)
-  deriving (FromJSON, ToJSON, S.ToSchema) via Schema Base64ByteString
+  deriving (FromJSON, ToJSON, O.ToSchema) via Schema Base64ByteString
   deriving newtype (Arbitrary, IsString)
 
 instance ToSchema Base64ByteString where
@@ -216,14 +236,14 @@ instance FromHttpApiData Base64ByteString where
 instance ToHttpApiData Base64ByteString where
   toUrlPiece = Text.decodeUtf8With Text.lenientDecode . B64U.encodeUnpadded . fromBase64ByteString
 
-instance S.ToParamSchema Base64ByteString where
-  toParamSchema _ = mempty & S.type_ ?~ S.OpenApiString
+instance O.ToParamSchema Base64ByteString where
+  toParamSchema _ = mempty & O.type_ ?~ O.OpenApiString
 
 -- base64("example") ~> "ZXhhbXBsZQo="
 base64SchemaN :: ValueSchema NamedSwaggerDoc ByteString
 base64SchemaN =
   (toBase64Text .= parsedText "Base64ByteString" fromBase64Text)
-    & doc %~ fmap (S.schema . S.example ?~ A.String "ZXhhbXBsZQo=")
+    & doc %~ fmap (O.schema . O.example ?~ A.String "ZXhhbXBsZQo=")
 
 base64Schema :: ValueSchema SwaggerDoc ByteString
 base64Schema = unnamed base64SchemaN
@@ -233,7 +253,7 @@ base64URLSchemaN =
   ( (Text.decodeUtf8 . B64U.encodeUnpadded)
       .= parsedText "Base64URLByteString" (B64U.decodeUnpadded . Text.encodeUtf8)
   )
-    & doc %~ fmap (S.schema . S.example ?~ A.String "ZXhhbXBsZQo=")
+    & doc %~ fmap (O.schema . O.example ?~ A.String "ZXhhbXBsZQo=")
 
 base64URLSchema :: ValueSchema SwaggerDoc ByteString
 base64URLSchema = unnamed base64URLSchemaN
@@ -262,8 +282,8 @@ instance FromHttpApiData Base64ByteStringL where
 instance ToHttpApiData Base64ByteStringL where
   toUrlPiece = toUrlPiece . base64ToStrict
 
-instance S.ToParamSchema Base64ByteStringL where
-  toParamSchema _ = mempty & S.type_ ?~ S.OpenApiString
+instance O.ToParamSchema Base64ByteStringL where
+  toParamSchema _ = mempty & O.type_ ?~ O.OpenApiString
 
 base64SchemaLN :: ValueSchema NamedSwaggerDoc LByteString
 base64SchemaLN = L.toStrict .= fmap L.fromStrict base64SchemaN

libs/types-common/src/Util/Options.hs

@@ -30,8 +30,12 @@ where
 
 import Cassandra.Options
 import Control.Lens
+import Data.Aeson qualified as A
 import Data.ByteString.Char8 qualified as BS
 import Data.ByteString.Conversion
+import Data.OpenApi qualified as O
+import Data.Schema qualified as S
+import Data.Text qualified as T
 import Data.Text.Encoding (encodeUtf8)
 import Data.Yaml hiding (Parser)
 import Imports
@@ -78,8 +82,12 @@ urlPort u = do
 
 makeLenses ''AWSEndpoint
 
-newtype FilePathSecrets = FilePathSecrets FilePath
-  deriving (Eq, Show, FromJSON, IsString)
+newtype FilePathSecrets = FilePathSecrets {unFilePathSecrets :: FilePath}
+  deriving (Eq, Show, IsString, Generic)
+  deriving (A.FromJSON, A.ToJSON, O.ToSchema) via (S.Schema FilePathSecrets)
+
+instance S.ToSchema FilePathSecrets where
+  schema = (T.pack . unFilePathSecrets) S..= (FilePathSecrets . T.unpack <$> S.text "FilePathSecrets")
 
 initCredentials :: (MonadIO m, FromJSON a) => FilePathSecrets -> m a
 initCredentials secretFile = do
@@ -151,14 +159,14 @@ parseAWSEndpoint = readerAsk >>= maybe (error "Could not parse AWS endpoint") pu
 data PasswordHashingOptions
   = PasswordHashingArgon2id Argon2idOptions
   | PasswordHashingScrypt
-  deriving (Show, Generic)
+  deriving (Show, Eq, Generic)
 
 data Argon2idOptions = Argon2idOptions
   { iterations :: !Word32,
     memory :: !Word32,
     parallelism :: !Word32
   }
-  deriving (Show, Generic)
+  deriving (Show, Eq, Generic)
 
 instance FromJSON PasswordHashingOptions where
   parseJSON =