From b5e16d6f70927cf425c3f8174fbdf954d0b76b29 Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Tue, 22 Aug 2023 12:49:23 +0200 Subject: [PATCH 1/2] Add export of 'Typ' to OpenAPI schema --- lib/fine-types/fine-types.cabal | 9 +- .../Language/FineTypes/Export/OpenAPI/Typ.hs | 270 ++++++++++++++++++ .../FineTypes/Export/OpenAPI/TypSpec.hs | 47 +++ lib/fine-types/test/data/JsonUTxO.fine | 67 +++++ 4 files changed, 391 insertions(+), 2 deletions(-) create mode 100644 lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Typ.hs create mode 100644 lib/fine-types/test/Language/FineTypes/Export/OpenAPI/TypSpec.hs create mode 100644 lib/fine-types/test/data/JsonUTxO.fine diff --git a/lib/fine-types/fine-types.cabal b/lib/fine-types/fine-types.cabal index 2197a43..415231a 100644 --- a/lib/fine-types/fine-types.cabal +++ b/lib/fine-types/fine-types.cabal @@ -48,18 +48,22 @@ library hs-source-dirs: src build-depends: + , aeson ^>= 2.1.2 , base >=4.14.3.0 , bytestring , containers + , deepseq >= 1.4.4 , megaparsec ^>= 9.2.1 , parser-combinators , pretty-simple + , prettyprinter , QuickCheck , text , transformers - , prettyprinter + , yaml exposed-modules: Language.FineTypes + Language.FineTypes.Export.OpenAPI.Typ Language.FineTypes.Module Language.FineTypes.Module.Gen Language.FineTypes.Module.PrettyPrinter @@ -79,6 +83,7 @@ test-suite unit build-depends: base , containers + , deepseq , fine-types , hspec ^>= 2.11.0 , QuickCheck @@ -86,6 +91,6 @@ test-suite unit main-is: Spec.hs other-modules: + Language.FineTypes.Export.OpenAPI.TypSpec Language.FineTypes.ParserSpec Language.FineTypes.ValueSpec - diff --git a/lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Typ.hs b/lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Typ.hs new file mode 100644 index 0000000..ded027a --- /dev/null +++ b/lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Typ.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Export type definitions to OpenAPI JSON schemas. +-- +-- https://www.openapis.org +module Language.FineTypes.Export.OpenAPI.Typ + ( OpenAPISchema (..) + , schemaFromModule + , supportsJSON + , convertToJSON + ) where + +import Prelude + +import Control.DeepSeq + ( NFData + ) +import Data.Aeson + ( (.=) + ) +import Data.Text + ( Text + ) +import GHC.Generics + ( Generic + ) +import Language.FineTypes.Module + ( Declarations + , Module (..) + , resolveVars + ) +import Language.FineTypes.Typ + ( ConstructorName + , FieldName + , OpOne (..) + , OpTwo (..) + , Typ (..) + , TypConst (..) + , everything + , everywhere + ) + +import qualified Data.Aeson as JS +import qualified Data.Aeson.Key as JS.Key +import qualified Data.Aeson.Types as JS +import qualified Data.Map as Map +import qualified Data.Text as T + +{----------------------------------------------------------------------------- + OpenAPI +------------------------------------------------------------------------------} +newtype OpenAPISchema = OpenAPISchema {getOpenAPISchema :: JS.Value} + deriving (Eq, Ord, Show, Generic) + +instance NFData OpenAPISchema + +-- | Export +-- +-- Assumes that the argument satisfies 'supportsJSON'. +schemaFromModule :: Module -> OpenAPISchema +schemaFromModule m = + OpenAPISchema + $ wrapSchemasInHeader + (T.pack $ moduleName m) + [ (T.pack name, schemaFromTyp typ) + | (name, typ) <- Map.toList declarations + ] + where + declarations = moduleDeclarations m + +-- | Test whether a 'Module' only uses types supported by JSON. +-- +-- JSON does not support finite maps such as @↦@, @↦0@, @→∗@. +supportsJSON :: Module -> Bool +supportsJSON = + and . Map.map isSupportedTyp . moduleDeclarations + where + isSupportedTyp = everything (&&) isSupported + isSupported (Two fun _ _) = + fun `notElem` [PartialFunction, FiniteSupport] + isSupported _ = True + +-- | Convert 'Typ' definitions to JSON. +-- +-- The result satisfies 'supportsJSON'. +-- +-- Note: We don't recommend that you use this function, +-- because it does a lot of conversions under the hood. +-- Instead, if you want to export a 'Typ' to JSON, +-- we recommend that you explicitly define a second 'Typ' +-- which is apparently compatible with JSON, +-- and show that the first 'Typ' can be embedded into the second 'Typ'. +convertToJSON :: Declarations -> Declarations +convertToJSON declarations = Map.map (jsonify declarations) declarations + +{----------------------------------------------------------------------------- + Convert Typ to JSON schema +------------------------------------------------------------------------------} +wrapSchemasInHeader :: Text -> [(Text, JS.Value)] -> JS.Value +wrapSchemasInHeader title xs = + object + [ "openapi" .= s "3.0.3" + , "info" + .= object + [ "title" .= s title + , "version" .= s "1" + ] + , "components" + .= object + [ "schemas" + .= object + [ key name .= x + | (name, x) <- xs + ] + ] + , "paths" .= object [] + ] + +schemaFromTyp :: Typ -> JS.Value +schemaFromTyp = go + where + go Abstract = + object + ["type" .= s "object"] + go (Var name) = + object + ["$ref" .= s (T.pack $ "#/components/schemas/" <> name)] + go (Zero Bool) = + object + ["type" .= s "boolean"] + go (Zero Bytes) = + object + [ "type" .= s "string" + , "format" .= s "base16" + ] + go (Zero Integer) = + object + ["type" .= s "integer"] + go (Zero Natural) = + object + [ "type" .= s "integer" + , "minimum" .= JS.toJSON (0 :: Int) + ] + go (Zero Text) = + object + ["type" .= s "string"] + go (Zero Unit) = + object + ["type" .= s "null"] + go (One Option a) = + object + [ "type" .= s "object" + , "properties" .= object ["0" .= go a] + ] + go (One Sequence a) = + object + [ "type" .= s "array" + , "items" .= go a + ] + go (One PowerSet a) = + go (One Sequence a) + go (Two Sum2 a b) = + schemaFromSumN [("0", a), ("1", b)] + go (Two Product2 a b) = + object + [ "type" .= s "object" + , "properties" .= object ["0" .= go a, "1" .= go b] + , "required" .= array [s "0", s "1"] + , "additionalProperties" .= false + ] + go (Two PartialFunction _ _) = + error "PartialFunction is not supported by JSON schema" + go (Two FiniteSupport _ _) = + error "FiniteSupport is not supported by JSON schema" + go (ProductN fields) = + schemaFromProductN fields + go (SumN constructors) = + schemaFromSumN constructors + +-- | Map a record type to a JSON schema. +-- +-- Field that are option types (@?@) will be mapped to optional fields. +schemaFromProductN :: [(FieldName, Typ)] -> JS.Value +schemaFromProductN fields = + object + [ "type" .= s "object" + , "properties" + .= object + [ key (T.pack name) .= schemaFromTyp (stripOption typ) + | (name, typ) <- fields + ] + , "required" .= array required + , "additionalProperties" .= false + ] + where + required = + [ s (T.pack name) + | (name, typ) <- fields + , not (isOption typ) + ] + +stripOption :: Typ -> Typ +stripOption (One Option a) = a +stripOption a = a + +isOption :: Typ -> Bool +isOption (One Option _) = True +isOption _ = False + +-- | Map a union type to a JSON. +-- +-- The encoding corresponds to the 'ObjectWithSingleField' encoding. +schemaFromSumN :: [(ConstructorName, Typ)] -> JS.Value +schemaFromSumN constructors = + object ["oneOf" .= array (map fromConstructor constructors)] + where + fromConstructor (name, typ) = + object + [ "type" .= s "object" + , "title" .= s (T.pack name) + , "properties" + .= object [key (T.pack name) .= schemaFromTyp typ] + , "required" .= array [s (T.pack name)] + , "additionalProperties" .= false + ] + +{----------------------------------------------------------------------------- + Preprocessing +------------------------------------------------------------------------------} + +-- | Modify the 'Typ' to be closer to JSON. +jsonify :: Declarations -> Typ -> Typ +jsonify declarations = + mergeRecords . representFiniteMaps . resolveVars declarations + +representFiniteMaps :: Typ -> Typ +representFiniteMaps = everywhere represent + where + represent x@(Two op a b) + | op == FiniteSupport || op == PartialFunction = + One Sequence (Two Product2 a b) + | otherwise = + x + represent x = x + +mergeRecords :: Typ -> Typ +mergeRecords = everywhere merge + where + merge (Two Product2 (ProductN a) (ProductN b)) = + ProductN (a <> b) + merge x = x + +{----------------------------------------------------------------------------- + JSON helpers +------------------------------------------------------------------------------} +key :: Text -> JS.Key +key = JS.Key.fromText + +s :: Text -> JS.Value +s = JS.String + +object :: [JS.Pair] -> JS.Value +object = JS.object + +array :: [JS.Value] -> JS.Value +array = JS.toJSON + +false :: JS.Value +false = JS.toJSON False diff --git a/lib/fine-types/test/Language/FineTypes/Export/OpenAPI/TypSpec.hs b/lib/fine-types/test/Language/FineTypes/Export/OpenAPI/TypSpec.hs new file mode 100644 index 0000000..aadd186 --- /dev/null +++ b/lib/fine-types/test/Language/FineTypes/Export/OpenAPI/TypSpec.hs @@ -0,0 +1,47 @@ +module Language.FineTypes.Export.OpenAPI.TypSpec + ( spec + ) where + +import Prelude + +import Control.DeepSeq + ( NFData + , rnf + ) +import Language.FineTypes.Export.OpenAPI.Typ + ( schemaFromModule + , supportsJSON + ) +import Language.FineTypes.Parser + ( parseFineTypes + ) +import Test.Hspec + ( Expectation + , Spec + , describe + , it + , shouldBe + ) + +{----------------------------------------------------------------------------- + Tests +------------------------------------------------------------------------------} +spec :: Spec +spec = do + describe "OpenAPI export on JsonUTxO.fine" $ do + let readModule = do + file <- readFile "test/data/JsonUTxO.fine" + Just m <- pure $ parseFineTypes file + pure m + + it "has a 'Typ' that supports JSON" $ do + m <- readModule + supportsJSON m `shouldBe` True + + it "works, i.e. does not contain ⊥" $ do + m <- readModule + let schema = schemaFromModule m + hasNormalForm schema + +hasNormalForm :: NFData a => a -> Expectation +hasNormalForm x = rnf x `shouldBe` () diff --git a/lib/fine-types/test/data/JsonUTxO.fine b/lib/fine-types/test/data/JsonUTxO.fine new file mode 100644 index 0000000..d084259 --- /dev/null +++ b/lib/fine-types/test/data/JsonUTxO.fine @@ -0,0 +1,67 @@ +module JsonUTxO where + +{----------------------------------------------------------------------------- + UTxO type in the Babbage era + JSON-friendly +------------------------------------------------------------------------------} + +ByteString = Bytes; +ScriptHash = Bytes; + +Addr = Bytes; +Script = Bytes; +Datum = Bytes; +DataHash = Bytes; + +{----------------------------------------------------------------------------- + Value and Token Algebra +------------------------------------------------------------------------------} + +Quantity = ℤ; + +Value = + { ada : Quantity + , assets : Asset* + }; + +PolicyID = ScriptHash; +AssetName = ByteString; + +Asset = + { policyId : PolicyID + , assetName : AssetName + , quantity : Quantity + }; + +{----------------------------------------------------------------------------- + TxOut +------------------------------------------------------------------------------} +TxOut = + { address : Addr + , value : Value + , datum : DatumOrHash? + , scriptRef : Script? + }; + +DatumOrHash = + Σ{ datum : Datum + , dataHash : DataHash + }; + +{----------------------------------------------------------------------------- + Transactions + Shelley spec, Figure 10, filtered, annotated +------------------------------------------------------------------------------} +TxId = Bytes; +Ix = ℕ; + +UTxO_1 = + { id : TxId + , index : Ix + , address : Addr + , value : Value + , datum : DatumOrHash? + , scriptRef : Script? + }; + +UTxO = UTxO_1*; From 03d2d7fc461031bbb3cd42eb5fcfae0ec42cc15a Mon Sep 17 00:00:00 2001 From: Heinrich Apfelmus Date: Tue, 22 Aug 2023 13:05:00 +0200 Subject: [PATCH 2/2] Add export of 'Value' to JSON --- lib/fine-types/fine-types.cabal | 2 + .../FineTypes/Export/OpenAPI/Value.hs | 135 ++++++++++++++++++ 2 files changed, 137 insertions(+) create mode 100644 lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Value.hs diff --git a/lib/fine-types/fine-types.cabal b/lib/fine-types/fine-types.cabal index 415231a..af64997 100644 --- a/lib/fine-types/fine-types.cabal +++ b/lib/fine-types/fine-types.cabal @@ -50,6 +50,7 @@ library build-depends: , aeson ^>= 2.1.2 , base >=4.14.3.0 + , base16 >= 1.0 , bytestring , containers , deepseq >= 1.4.4 @@ -64,6 +65,7 @@ library exposed-modules: Language.FineTypes Language.FineTypes.Export.OpenAPI.Typ + Language.FineTypes.Export.OpenAPI.Value Language.FineTypes.Module Language.FineTypes.Module.Gen Language.FineTypes.Module.PrettyPrinter diff --git a/lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Value.hs b/lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Value.hs new file mode 100644 index 0000000..0dcd614 --- /dev/null +++ b/lib/fine-types/src/Language/FineTypes/Export/OpenAPI/Value.hs @@ -0,0 +1,135 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Language.FineTypes.Export.OpenAPI.Value + ( jsonFromValue + ) where + +import Prelude + +import Data.Aeson + ( (.=) + ) +import Data.Base16.Types + ( extractBase16 + ) +import Data.ByteString + ( ByteString + ) +import Data.Text + ( Text + ) +import Language.FineTypes.Typ + ( ConstructorName + , FieldName + , Typ + ) +import Language.FineTypes.Value + ( Ix + , OneF (..) + , TwoF (..) + , Value (..) + , ZeroF (..) + ) + +import qualified Data.Aeson as JS +import qualified Data.Aeson.Key as JS.Key +import qualified Data.ByteString.Base16 as B +import qualified Data.Set as Set +import qualified Data.Text as T +import qualified Language.FineTypes.Typ as Typ + +{----------------------------------------------------------------------------- + JSON export +------------------------------------------------------------------------------} + +-- | Convert a 'Value' with a 'Typ' to a JSON value. +-- +-- We need the 'Typ' of the 'Value' in order to add field names. +-- +-- Note: We assume that the 'Value' has the given 'Typ'. +jsonFromValue :: Typ -> Value -> JS.Value +jsonFromValue = go + where + go :: Typ -> Value -> JS.Value + go (Typ.Two Typ.Product2 ta tb) (Product [a, b]) = + JS.object ["0" .= go ta a, "1" .= go tb b] + go (Typ.ProductN fields) x@(Product _) = + jsonFromProduct fields + $ flattenBinaryProduct (length fields) x + -- TODO: Don't flatten automatically when Embedding get better. + + go (Typ.Two Typ.Sum2 ta _) (Sum 0 a) = + JS.object ["0" .= go ta a] + go (Typ.Two Typ.Sum2 _ tb) (Sum 1 b) = + JS.object ["1" .= go tb b] + go (Typ.SumN constructors) (Sum ix a) = + jsonFromSum constructors ix a + go Typ.Abstract _ = error "jsonFromValue: Typ may not be abstract." + go (Typ.Var _) (Zero v) = go0 v + go (Typ.One op t) (One v) = go1 op t v + go Typ.Two{} (Two v) = go2 v + go _ _ = error "jsonFromValue: Typ error" + + go0 :: ZeroF -> JS.Value + go0 (Bool b) = JS.toJSON b + go0 (Bytes s) = JS.toJSON $ toHex s + go0 (Integer i) = JS.toJSON i + go0 (Natural n) = JS.toJSON n + go0 (Text t) = JS.toJSON t + go0 Unit = JS.Null + + go1 :: Typ.OpOne -> Typ -> OneF Value -> JS.Value + go1 Typ.Option t (Option (Just x)) = JS.object ["0" .= go t x] + go1 Typ.Option _ (Option Nothing) = JS.object [] + go1 Typ.Sequence t (Sequence xs) = JS.toJSON $ map (go t) xs + go1 Typ.PowerSet t (PowerSet xs) = JS.toJSON $ map (go t) $ Set.toList xs + go1 _ _ _ = error "jsonFromValue: Typ error" + + go2 :: TwoF Value Value -> JS.Value + go2 (FiniteMap _) = + error "FiniteMapV is not supported by JSON" + +-- | Flatten a chain of @n@ binary products to a single 'Product'. +flattenBinaryProduct :: Int -> Value -> [Value] +flattenBinaryProduct = flatten + where + flatten :: Int -> Value -> [Value] + flatten 1 x = [x] + flatten n (Product [x, y]) = x : flatten (n - 1) y + flatten _ x = [x] + +jsonFromProduct :: [(FieldName, Typ)] -> [Value] -> JS.Value +jsonFromProduct fields xs + | length fields == length xs = + JS.object + [ key (T.pack field) .= jsonFromValue typ2 x2 + | ((field, typ), x) <- zip fields xs + , omitNothingOption x + , let (typ2, x2) = skipJustOption (typ, x) + ] + | otherwise = + error "jsonFromRecord: field count of Value does not match Typ" + where + omitNothingOption = (One (Option Nothing) /=) + + skipJustOption :: (Typ, Value) -> (Typ, Value) + skipJustOption (Typ.One Typ.Option typ, One (Option (Just x))) = (typ, x) + skipJustOption y = y + +jsonFromSum :: [(ConstructorName, Typ)] -> Ix -> Value -> JS.Value +jsonFromSum constructors ix a + | 0 <= ix && ix < length constructors = + JS.object [key (T.pack name) .= jsonFromValue typ a] + | otherwise = + error "jsonFromSum: index of Value does not match Typ" + where + (name, typ) = constructors !! ix + +{----------------------------------------------------------------------------- + Utilities +------------------------------------------------------------------------------} +toHex :: ByteString -> Text +toHex = extractBase16 . B.encodeBase16 + +key :: Text -> JS.Key +key = JS.Key.fromText