jordan-openapi (empty) → 0.1.0.0
raw patch · 7 files changed
+476/−0 lines, 7 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, containers, contravariant, hspec, insert-ordered-containers, jordan, jordan-openapi, openapi3, optics-core, text
Files
- CHANGELOG.md +5/−0
- LICENSE +20/−0
- jordan-openapi.cabal +60/−0
- lib/Jordan/OpenAPI.hs +41/−0
- lib/Jordan/OpenAPI/Internal.hs +231/−0
- test/Jordan/OpenAPI/SpecDefs.hs +51/−0
- test/JordanOpenApiSpec.hs +68/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for jordan-openapi++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2021 Anthony Super++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ jordan-openapi.cabal view
@@ -0,0 +1,60 @@+cabal-version: 3.0+name: jordan-openapi+version: 0.1.0.0+synopsis: OpenAPI Definitions for Jordan, Automatically++-- A longer description of the package.+-- description:+homepage:++-- A URL where users can report bugs.+-- bug-reports:+license: MIT+license-file: LICENSE+author: Anthony Super+maintainer: anthony@noided.media++-- A copyright notice.+-- copyright:+category: Network+extra-source-files: CHANGELOG.md++common build-deps+ build-depends:+ aeson >= 1.5.6 && <1.6+ , bytestring >= 0.10.12 && <0.11+ , containers >= 0.6.2 && <0.7+ , contravariant >= 1.5.5 && <1.6+ , insert-ordered-containers >= 0.2.5 && <0.3+ , jordan >= 0.1.0.0 && <0.2+ , openapi3 >= 3.1.0 && <3.2+ , optics-core >= 0.4 && <0.5+ , text >= 1.2.4 && <1.3++library+ import: build-deps+ exposed-modules:+ Jordan.OpenAPI.Internal+ , Jordan.OpenAPI++ -- Modules included in this library but not exported.+ -- other-modules:++ -- LANGUAGE extensions used by modules in this package.+ -- other-extensions:+ build-depends: base ^>=4.14.1.0+ hs-source-dirs: lib+ default-language: Haskell2010++test-suite jordan-openapi-test+ import: build-deps+ build-depends: jordan-openapi+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: JordanOpenApiSpec.hs + other-modules:+ Jordan.OpenAPI.SpecDefs+ build-depends:+ base ^>=4.14.1.0+ , hspec
+ lib/Jordan/OpenAPI.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Jordan.OpenAPI+ ( getFromNamed+ , getToNamed+ , JordanFromJSONSchema (..)+ ) where++import Data.Functor.Contravariant (contramap)+import Data.OpenApi.Schema (ToSchema(..))+import Data.Proxy (Proxy(..))+import Data.Typeable (Typeable(..))+import Jordan.FromJSON.Class (FromJSON(..))+import Jordan.OpenAPI.Internal (getFromNamed, getToNamed)+import Jordan.ToJSON.Class (ToJSON(..))++-- | Newtype for use with DerivingVia.+--+-- Allows deriving 'Data.OpenApi.Schema.ToSchema' via DerivingVia, using the Jordan+-- defintion of 'Jordan.ToJSON.Class.ToJSON'.+newtype JordanFromJSONSchema a+ = JordanFromJSONSchema { getJordanFromJSONSchema :: a }++instance (FromJSON a) => FromJSON (JordanFromJSONSchema a) where+ fromJSON = JordanFromJSONSchema <$> fromJSON++instance (Typeable a, FromJSON a) => ToSchema (JordanFromJSONSchema a) where+ declareNamedSchema (Proxy :: Proxy (JordanFromJSONSchema a)) = getFromNamed (Proxy :: Proxy a)++-- | Newtype for use with DerivingVia.+--+-- Allows deriving 'Data.OpenApi.Schema.ToSchema' via DerivingVia, using the Jordan+-- defintion of 'Jordan.ToJSON.Class.ToJSON'.+newtype JordanToJSONSchema a+ = JordanToJSONSchema { getJordanToJSONSchema :: a }++instance (ToJSON a) => ToJSON (JordanToJSONSchema a) where+ toJSON = contramap getJordanToJSONSchema toJSON++instance (Typeable a, ToJSON a) => ToSchema (JordanToJSONSchema a) where+ declareNamedSchema (Proxy :: Proxy (JordanToJSONSchema a)) = getToNamed (Proxy :: Proxy a)
+ lib/Jordan/OpenAPI/Internal.hs view
@@ -0,0 +1,231 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+module Jordan.OpenAPI.Internal+ where++import Control.Applicative (Alternative(..))+import Control.Monad (unless)+import qualified Data.Aeson.Types as Aeson+import Data.Functor (void)+import Data.Functor.Const+import Data.Functor.Contravariant+import Data.Functor.Contravariant.Divisible+import qualified Data.HashMap.Strict.InsOrd as InsOrd+import Data.Maybe (fromMaybe)+import Data.OpenApi.Declare+import Data.OpenApi.Internal+import Data.OpenApi.Internal.Schema (rename, unname, unnamed)+import Data.OpenApi.Optics+import Data.Proxy (Proxy(..))+import qualified Data.Text as T+import Jordan.FromJSON.Class+import Jordan.ToJSON.Class+import Optics.At.Core+import Optics.Operators+import Optics.Optic ((%))++newtype ConstDeclare env r a+ = ConstDeclare { runConstDeclare :: Declare env r }++instance Functor (ConstDeclare env r) where+ fmap _ (ConstDeclare d) = ConstDeclare d++instance (Monoid r, Monoid env) => Applicative (ConstDeclare env r) where+ pure _ = ConstDeclare $ pure mempty+ (ConstDeclare f) <*> (ConstDeclare a) = ConstDeclare $ do+ f' <- f+ a' <- a+ pure $ f' <> a'++instance Contravariant (ConstDeclare env r) where+ contramap _ (ConstDeclare d) = ConstDeclare d++instance (Monoid r, Monoid env) => Divisible (ConstDeclare env r) where+ divide _ (ConstDeclare l) (ConstDeclare r) = ConstDeclare $ do+ l' <- l+ r' <- r+ pure $ l' <> r'+ conquer = ConstDeclare $ pure mempty++newtype ObjectSchema a+ = ObjectSchema+ { getObjectSchema+ :: Declare (Definitions Schema) Schema+ } deriving (Functor, Applicative, Contravariant, Divisible) via (ConstDeclare (Definitions Schema) Schema)++instance JSONObjectParser ObjectSchema where+ parseFieldWith t p = ObjectSchema $ do+ r <- getRefDef (getJSONSchema p)+ pure $ (#_schemaProperties % at t ?~ r) mempty+ parseField+ :: forall a. FromJSON a+ => T.Text+ -> ObjectSchema a+ parseField label = ObjectSchema $ do+ ref <- getJSONRef (Proxy :: Proxy a)+ pure $ (#_schemaProperties % at label ?~ ref) mempty++instance JSONObjectSerializer ObjectSchema where+ writeField f w = ObjectSchema $ do+ r <- getRefDef (getJSONSchema w)+ pure $ (#_schemaProperties % at f ?~ r) mempty++newtype TupleSchema a+ = TupleSchema+ { getTupleSchema+ :: Declare (Definitions Schema) [Referenced Schema]+ } deriving (Functor, Applicative, Contravariant, Divisible) via (ConstDeclare (Definitions Schema) [Referenced Schema])++instance JSONTupleParser TupleSchema where+ consumeItemWith p = TupleSchema $ do+ r <- getRefDef $ getJSONSchema p+ pure [r]++newtype JSONSchema a+ = JSONSchema+ { getJSONSchema :: Declare (Definitions Schema) NamedSchema+ } deriving (Functor, Contravariant) via (ConstDeclare (Definitions Schema) NamedSchema)++instance Semigroup (JSONSchema a) where+ a <> b = JSONSchema . fmap unnamed $+ combineSchemas <$> getRefDef (getJSONSchema a) <*> getRefDef (getJSONSchema b)++instance Selectable JSONSchema where+ giveUp = mempty+ select _ (JSONSchema lhs) (JSONSchema rhs) = JSONSchema lhs <> JSONSchema rhs++combineSchemas :: Referenced Schema -> Referenced Schema -> Schema+combineSchemas = curry $ \case+ (Inline a, Inline b) ->+ (#_schemaOneOf ?~ fromMaybe [Inline a] (_schemaOneOf a) <> fromMaybe [Inline b] (_schemaOneOf b)) mempty+ (Inline a, Ref b) ->+ (#_schemaOneOf ?~ fromMaybe [Inline a] (_schemaOneOf a) <> [Ref b]) mempty+ (Ref a, Inline b) ->+ (#_schemaOneOf ?~ [Ref a] <> fromMaybe [Inline b] (_schemaOneOf b)) mempty+ (Ref a, Ref b) -> (#_schemaOneOf ?~ [Ref a, Ref b]) mempty++-- | Empty instance: must be both a boolean and a text value, which is not possible (obviously!)+instance Monoid (JSONSchema a) where+ mempty = JSONSchema $ do+ t <- getJSONSchema parseText+ b <- getJSONSchema parseBool+ pure $ unnamed $ (#_schemaAllOf ?~ [Inline $ _namedSchemaSchema t, Inline $ _namedSchemaSchema b]) mempty++getJSONRef+ :: forall a. FromJSON a+ => Proxy a+ -> Declare (Definitions Schema) (Referenced Schema)+getJSONRef = getRefDef . getFromNamed++getRefDef+ :: Declare (Definitions Schema) NamedSchema+ -> Declare (Definitions Schema) (Referenced Schema)+getRefDef decl = case undeclare decl of+ NamedSchema (Just name) schema -> do+ known <- looks (InsOrd.member name)+ unless known $ do+ declare [(name, schema)]+ void decl+ return $ Ref (Reference name)+ _ -> Inline . _namedSchemaSchema <$> decl++onlyUnnamed :: Schema -> JSONSchema a+onlyUnnamed a = JSONSchema $ pure $ NamedSchema Nothing a++instance JSONTupleSerializer TupleSchema where+ writeItem s = TupleSchema $ do+ r <- getRefDef $ getJSONSchema s+ pure [r]++instance JSONParser JSONSchema where+ parseObject n f = JSONSchema $ do+ d <- getObjectSchema f+ pure $ NamedSchema (Just n) d+ parseDictionary inner = JSONSchema $ do+ r <- getRefDef (getJSONSchema inner)+ pure $ unnamed $+ ( (#_schemaType ?~ OpenApiObject)+ . (#_schemaAdditionalProperties ?~ AdditionalPropertiesSchema r)+ ) mempty+ parseTuple parser = JSONSchema $ do+ items <- getTupleSchema parser+ pure $+ ( unnamed+ . (#_schemaType ?~ OpenApiArray)+ . (#_schemaItems ?~ OpenApiItemsArray items)+ ) mempty+ parseArrayWith p = JSONSchema $ do+ itemRef <- getRefDef (getJSONSchema p)+ pure $+ ( unnamed+ . (#_schemaType ?~ OpenApiArray)+ . (#_schemaItems ?~ OpenApiItemsObject itemRef)+ ) mempty+ parseArray+ :: forall a. (FromJSON a)+ => JSONSchema [a]+ parseArray = JSONSchema $ do+ itemRef <- getRefDef $ getFromNamed (Proxy :: Proxy a)+ pure $+ ( unnamed+ . (#_schemaType ?~ OpenApiArray)+ . (#_schemaItems ?~ OpenApiItemsObject itemRef)+ ) mempty+ parseNumber = onlyUnnamed $ (#_schemaType ?~ OpenApiNumber) mempty+ parseTextConstant t+ = void+ . onlyUnnamed+ . (#_schemaType ?~ OpenApiString)+ . (#_schemaEnum ?~ [Aeson.String t])+ $ mempty+ parseNull = onlyUnnamed $ (#_schemaType ?~ OpenApiNull) mempty+ parseText = onlyUnnamed $ (#_schemaType ?~ OpenApiString) mempty+ parseBool = onlyUnnamed $ (#_schemaType ?~ OpenApiBoolean) mempty+ validateJSON (JSONSchema d) = JSONSchema d++instance JSONSerializer JSONSchema where+ serializeObject t f = JSONSchema $ do+ d <- getObjectSchema f+ pure $ NamedSchema (Just t) d+ serializeTuple t = JSONSchema $ do+ items <- getTupleSchema t+ pure $+ ( unnamed+ . (#_schemaType ?~ OpenApiArray)+ . (#_schemaItems ?~ OpenApiItemsArray items)+ ) mempty+ serializeArray :: forall a. (ToJSON a) => JSONSchema [a]+ serializeArray = JSONSchema $ do+ itemRef <- getRefDef $ getToNamed (Proxy :: Proxy a)+ pure $+ ( unnamed+ . (#_schemaType ?~ OpenApiArray)+ . (#_schemaItems ?~ OpenApiItemsObject itemRef)+ ) mempty+ serializeText = parseText+ serializeBool = parseBool+ serializeNumber = parseNumber+ serializeDictionary ser = JSONSchema $ do+ r <- getRefDef (getJSONSchema ser)+ pure $ unnamed $+ ( (#_schemaType ?~ OpenApiObject)+ . (#_schemaAdditionalProperties ?~ AdditionalPropertiesSchema r)+ ) mempty+ serializeNull =+ case parseNull of+ JSONSchema a -> JSONSchema a+ serializeTextConstant t = let (JSONSchema a) = parseTextConstant t in JSONSchema a++-- | Get documentation for a type that implements FromJSON+getFromNamed :: forall a. (FromJSON a) => Proxy a -> Declare (Definitions Schema) NamedSchema+getFromNamed p = getJSONSchema (fromJSON :: JSONSchema a)++-- | Get documentation for a type that implements ToJSON+getToNamed :: forall a. (ToJSON a) => Proxy a -> Declare (Definitions Schema) NamedSchema+getToNamed p = getJSONSchema (toJSON :: JSONSchema a)
+ test/Jordan/OpenAPI/SpecDefs.hs view
@@ -0,0 +1,51 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE OverloadedStrings #-}+module Jordan.OpenAPI.SpecDefs+ where++import qualified Data.Map as Map+import qualified Data.Text as T+import GHC.Generics (Generic)+import Jordan (FromJSON(..), ToJSON(..))++data Person+ = Person+ { firstName :: T.Text+ , lastName :: T.Text+ } deriving (Show, Generic)+ deriving anyclass (ToJSON, FromJSON)+++data Managership+ = Managership+ { manager :: Person+ , underlings :: [Managership]+ , feelings :: Map.Map T.Text T.Text+ }+ deriving (Show, Generic)+ deriving anyclass (ToJSON, FromJSON)++data Rank+ = RankNested { top :: T.Text, nest :: Rank }+ | RankSplit { left :: Rank, right :: Rank }+ | RankBottom { label :: T.Text }+ deriving (Show, Generic)+ deriving anyclass (ToJSON, FromJSON)++data FileEntry+ = FileEntry+ { name :: T.Text+ , contents :: Either File Directory+ }+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass (ToJSON, FromJSON)++newtype File = File { getFile :: T.Text }+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass (ToJSON, FromJSON)++newtype Directory = Directory { getEntries :: [FileEntry] }+ deriving (Show, Eq, Ord, Generic)+ deriving anyclass (ToJSON, FromJSON)
+ test/JordanOpenApiSpec.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+module Main+ where++import qualified Data.HashMap.Strict.InsOrd as I+import Data.OpenApi.Declare (Declare, evalDeclare, execDeclare)+import Data.OpenApi.Internal+import Data.Proxy (Proxy(..))+import Data.Text (Text)+import Jordan (FromJSON(..), ToJSON(..))+import Jordan.OpenAPI (getFromNamed, getToNamed)+import Jordan.OpenAPI.SpecDefs+import Optics.Operators ((^.))+import Test.Hspec (Expectation, SpecWith, before, describe, hspec, it, shouldBe, shouldContain)++main = hspec $ do+ fileScenarios+ entryScenarios+ recursiveScenarios+ topLevelScenarios++shouldMakeNamedTo+ :: (ToJSON a)+ => Proxy a+ -> Text+ -> Expectation+shouldMakeNamedTo p@Proxy name =+ (evalDeclare (getToNamed p) mempty ^. #_namedSchemaName) `shouldBe` Just name++shouldMakeUnnamed+ :: (ToJSON a)+ => Proxy a+ -> Expectation+shouldMakeUnnamed p@Proxy =+ (evalDeclare (getToNamed p) mempty ^. #_namedSchemaName) `shouldBe` Nothing++shouldDeclareTo+ :: (ToJSON a)+ => Proxy a+ -> Text+ -> Expectation+shouldDeclareTo p@Proxy name =+ I.keys (execDeclare (getToNamed p) mempty) `shouldContain` [name]++fileScenarios = describe "basic scenarios with file-like types" $ do+ it "works with file" $ do+ (Proxy @File) `shouldMakeNamedTo` "Jordan.OpenAPI.SpecDefs.File.File.Output"+ it "works with directory" $ do+ (Proxy @Directory) `shouldMakeNamedTo` "Jordan.OpenAPI.SpecDefs.Directory.Directory.Output"++entryScenarios = describe "bsaic scenarios with a directory-entry-like type" $ do+ it "includes definition for a file" $ do+ (Proxy @FileEntry) `shouldDeclareTo` "Jordan.OpenAPI.SpecDefs.File.File.Output"+ it "includes definition for a directory" $ do+ (Proxy @FileEntry) `shouldDeclareTo` "Jordan.OpenAPI.SpecDefs.Directory.Directory.Output"++recursiveScenarios = describe "scenarios with a recursive data type" $ do+ it "contains the top-level type" $ do+ (Proxy @Managership) `shouldDeclareTo` "Jordan.OpenAPI.SpecDefs.Managership.Managership.Output"+ it "contains a nested type" $ do+ (Proxy @Managership) `shouldDeclareTo` "Jordan.OpenAPI.SpecDefs.Person.Person.Output"++topLevelScenarios = describe "scenarios with some top-level sum type" $ do+ it "is not named" $ do+ shouldMakeUnnamed (Proxy @Rank)+