autodocodec-openapi3 (empty) → 0.0.0.0
raw patch · 6 files changed
+288/−0 lines, 6 filesdep +aesondep +autodocodecdep +base
Dependencies added: aeson, autodocodec, base, insert-ordered-containers, openapi3, scientific, text
Files
- CHANGELOG.md +5/−0
- LICENSE +21/−0
- autodocodec-openapi3.cabal +43/−0
- src/Autodocodec/OpenAPI.hs +14/−0
- src/Autodocodec/OpenAPI/DerivingVia.hs +16/−0
- src/Autodocodec/OpenAPI/Schema.hs +189/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog++## [0.0.0.0] - 2021-11-19++First release.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2021 Tom Sydney Kerckhove++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.
+ autodocodec-openapi3.cabal view
@@ -0,0 +1,43 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: autodocodec-openapi3+version: 0.0.0.0+synopsis: Autodocodec interpreters for openapi3+homepage: https://github.com/NorfairKing/autodocodec#readme+bug-reports: https://github.com/NorfairKing/autodocodec/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+copyright: 2021 Tom Sydney Kerckhove+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ LICENSE+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/NorfairKing/autodocodec++library+ exposed-modules:+ Autodocodec.OpenAPI+ Autodocodec.OpenAPI.DerivingVia+ Autodocodec.OpenAPI.Schema+ other-modules:+ Paths_autodocodec_openapi3+ hs-source-dirs:+ src+ build-depends:+ aeson+ , autodocodec+ , base >=4.7 && <5+ , insert-ordered-containers+ , openapi3+ , scientific+ , text+ default-language: Haskell2010
+ src/Autodocodec/OpenAPI.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -fno-warn-dodgy-exports -fno-warn-duplicate-exports #-}++module Autodocodec.OpenAPI+ ( declareNamedSchemaViaCodec,+ declareNamedSchemaVia,++ -- * To makes sure we definitely export everything.+ module Autodocodec.OpenAPI.Schema,+ module Autodocodec.OpenAPI.DerivingVia,+ )+where++import Autodocodec.OpenAPI.DerivingVia ()+import Autodocodec.OpenAPI.Schema
+ src/Autodocodec/OpenAPI/DerivingVia.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Autodocodec.OpenAPI.DerivingVia where++import Autodocodec+import Autodocodec.OpenAPI.Schema+import Data.OpenApi as OpenAPI+import Data.Proxy+import Data.Typeable++-- | An instance for 'Autodocodec' that lets you use 'DerivingVia' to derive 'OpenAPI.ToSchema' if your type has a 'HasCodec' instance.+--+-- > deriving (OpenAPI.ToSchema) via (Autodocodec FooBar)+instance (Typeable a, HasCodec a) => OpenAPI.ToSchema (Autodocodec a) where+ declareNamedSchema (Proxy :: Proxy (Autodocodec a)) = declareNamedSchemaViaCodec (Proxy :: Proxy a)
+ src/Autodocodec/OpenAPI/Schema.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Autodocodec.OpenAPI.Schema where++import Autodocodec+import Control.Monad+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap+import Data.OpenApi as OpenAPI+import Data.OpenApi.Declare as OpenAPI+import Data.Proxy+import Data.Scientific+import Data.Text (Text)++-- | Use a type's 'codec' to implement 'declareNamedSchema'.+declareNamedSchemaViaCodec :: HasCodec value => Proxy value -> Declare (Definitions Schema) NamedSchema+declareNamedSchemaViaCodec proxy = declareNamedSchemaVia codec proxy++-- | Use a given 'codec' to implement 'declareNamedSchema'.+declareNamedSchemaVia :: JSONCodec value -> Proxy value -> Declare (Definitions Schema) NamedSchema+declareNamedSchemaVia c' Proxy = go c'+ where+ go :: ValueCodec input output -> Declare (Definitions Schema) NamedSchema+ go = \case+ NullCodec ->+ pure $+ NamedSchema Nothing $+ mempty+ { _schemaType = Just OpenApiNull+ }+ BoolCodec mname -> NamedSchema mname <$> declareSchema (Proxy :: Proxy Bool)+ StringCodec mname -> NamedSchema mname <$> declareSchema (Proxy :: Proxy Text)+ NumberCodec mname mBounds -> do+ s <- declareSchema (Proxy :: Proxy Scientific)+ let addNumberBounds NumberBounds {..} s_ =+ s_+ { _schemaMinimum = Just numberBoundsLower,+ _schemaMaximum = Just numberBoundsUpper+ }+ pure $ NamedSchema mname $ maybe id addNumberBounds mBounds s+ ArrayOfCodec mname c -> do+ itemsSchema <- go c+ itemsSchemaRef <- declareSpecificNamedSchemaRef itemsSchema+ pure $+ NamedSchema mname $+ mempty+ { _schemaItems = Just $ OpenApiItemsObject $ _namedSchemaSchema <$> itemsSchemaRef,+ _schemaType = Just OpenApiArray+ }+ HashMapCodec c -> do+ itemsSchema <- go c+ itemsSchemaRef <- declareSpecificNamedSchemaRef itemsSchema+ pure $+ NamedSchema Nothing $+ mempty+ { _schemaAdditionalProperties = Just $ AdditionalPropertiesSchema $ _namedSchemaSchema <$> itemsSchemaRef+ }+ MapCodec c -> do+ itemsSchema <- go c+ itemsSchemaRef <- declareSpecificNamedSchemaRef itemsSchema+ pure $+ NamedSchema Nothing $+ mempty+ { _schemaAdditionalProperties = Just $ AdditionalPropertiesSchema $ _namedSchemaSchema <$> itemsSchemaRef+ }+ ValueCodec ->+ pure $+ NamedSchema+ Nothing+ mempty+ { _schemaAdditionalProperties = Just $ AdditionalPropertiesAllowed True+ }+ EqCodec val valCodec ->+ pure $+ NamedSchema Nothing $+ mempty+ { _schemaEnum = Just [toJSONVia valCodec val]+ }+ BimapCodec _ _ c -> go c+ ObjectOfCodec mname oc -> do+ ss <- goObject oc+ pure $ NamedSchema mname $ combineObjectSchemas ss+ EitherCodec c1 c2 -> do+ ns1 <- go c1+ ns2 <- go c2+ combineSchemasOr ns1 ns2+ CommentCodec t c -> do+ NamedSchema mName s <- go c+ pure $ NamedSchema mName $ addDoc t s+ ReferenceCodec n c -> do+ d <- look+ case InsOrdHashMap.lookup n d of+ Nothing -> do+ -- Insert a dummy to prevent an infinite loop.+ let dummy = mempty+ let (d', ns) = runDeclare (go c) (InsOrdHashMap.insert n dummy d)+ -- Override the dummy once we actually know what the result will be.+ declare $ InsOrdHashMap.insert n (_namedSchemaSchema ns) d'+ pure ns+ Just s -> pure $ NamedSchema (Just n) s+ goObject :: ObjectCodec input output -> Declare (Definitions Schema) [Schema]+ goObject = \case+ RequiredKeyCodec key vs mDoc -> do+ ns <- go vs+ ref <- declareSpecificNamedSchemaRef ns+ pure+ [ mempty+ { _schemaRequired = [key],+ _schemaProperties = [(key, addMDoc mDoc . _namedSchemaSchema <$> ref)],+ _schemaType = Just OpenApiObject+ }+ ]+ OptionalKeyCodec key vs mDoc -> do+ ns <- go vs+ ref <- declareSpecificNamedSchemaRef ns+ pure+ [ mempty+ { _schemaProperties = [(key, addMDoc mDoc . _namedSchemaSchema <$> ref)],+ _schemaType = Just OpenApiObject+ }+ ]+ OptionalKeyWithDefaultCodec key vs defaultValue mDoc -> do+ ns <- go vs+ ref <- declareSpecificNamedSchemaRef ns+ pure+ [ mempty+ { _schemaProperties = [(key, addMDoc mDoc . _namedSchemaSchema <$> ref)],+ _schemaDefault = Just $ toJSONVia vs defaultValue,+ _schemaType = Just OpenApiObject+ }+ ]+ OptionalKeyWithOmittedDefaultCodec key vs defaultValue mDoc -> goObject (OptionalKeyWithDefaultCodec key vs defaultValue mDoc)+ PureCodec _ -> pure []+ EitherCodec oc1 oc2 -> do+ s1s <- goObject oc1+ s2s <- goObject oc2+ (: []) . _namedSchemaSchema+ <$> combineSchemasOr+ (NamedSchema Nothing (combineObjectSchemas s1s))+ (NamedSchema Nothing (combineObjectSchemas s2s))+ ApCodec oc1 oc2 -> do+ ss1 <- goObject oc1+ ss2 <- goObject oc2+ pure $ ss1 ++ ss2+ BimapCodec _ _ oc -> goObject oc+ addMDoc :: Maybe Text -> Schema -> Schema+ addMDoc = maybe id addDoc+ addDoc :: Text -> Schema -> Schema+ addDoc doc s =+ s+ { _schemaDescription = case _schemaDescription s of+ Nothing -> Just doc+ Just doc' -> Just $ doc <> "\n" <> doc'+ }+ combineObjectSchemas :: [Schema] -> Schema+ combineObjectSchemas = mconcat+ combineSchemasOr :: NamedSchema -> NamedSchema -> Declare (Definitions Schema) NamedSchema+ combineSchemasOr ns1 ns2 = do+ let s1 = _namedSchemaSchema ns1+ let s2 = _namedSchemaSchema ns2+ s1Ref <- fmap _namedSchemaSchema <$> declareSpecificNamedSchemaRef ns1+ s2Ref <- fmap _namedSchemaSchema <$> declareSpecificNamedSchemaRef ns2+ let prototype = mempty {_schemaAdditionalProperties = Just $ AdditionalPropertiesAllowed True}+ pure $+ NamedSchema Nothing $ case (_schemaAnyOf s1, _schemaAnyOf s2) of+ (Just s1s, Just s2s) -> prototype {_schemaAnyOf = Just $ s1s ++ s2s}+ (Just s1s, Nothing) -> prototype {_schemaAnyOf = Just $ s1s ++ [s2Ref]}+ (Nothing, Just s2s) -> prototype {_schemaAnyOf = Just $ s1Ref : s2s}+ (Nothing, Nothing) -> prototype {_schemaAnyOf = Just [s1Ref, s2Ref]}++declareSpecificNamedSchemaRef :: OpenAPI.NamedSchema -> Declare (Definitions Schema) (Referenced NamedSchema)+declareSpecificNamedSchemaRef namedSchema =+ fmap (NamedSchema (_namedSchemaName namedSchema))+ <$> declareSpecificSchemaRef (_namedSchemaName namedSchema) (_namedSchemaSchema namedSchema)++declareSpecificSchemaRef :: Maybe Text -> OpenAPI.Schema -> Declare (Definitions Schema) (Referenced Schema)+declareSpecificSchemaRef mName s =+ case mName of+ Nothing -> pure $ Inline s+ Just n -> do+ known <- looks (InsOrdHashMap.member n)+ when (not known) $ declare $ InsOrdHashMap.singleton n s+ pure $ Ref (Reference n)