autodocodec-swagger2 (empty) → 0.0.0.0
raw patch · 6 files changed
+337/−0 lines, 6 filesdep +aesondep +autodocodecdep +base
Dependencies added: aeson, autodocodec, base, insert-ordered-containers, scientific, swagger2, text
Files
- CHANGELOG.md +5/−0
- LICENSE +21/−0
- autodocodec-swagger2.cabal +43/−0
- src/Autodocodec/Swagger.hs +14/−0
- src/Autodocodec/Swagger/DerivingVia.hs +15/−0
- src/Autodocodec/Swagger/Schema.hs +239/−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-swagger2.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-swagger2+version: 0.0.0.0+synopsis: Autodocodec interpreters for swagger2+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.Swagger+ Autodocodec.Swagger.DerivingVia+ Autodocodec.Swagger.Schema+ other-modules:+ Paths_autodocodec_swagger2+ hs-source-dirs:+ src+ build-depends:+ aeson+ , autodocodec+ , base >=4.7 && <5+ , insert-ordered-containers+ , scientific+ , swagger2+ , text+ default-language: Haskell2010
+ src/Autodocodec/Swagger.hs view
@@ -0,0 +1,14 @@+{-# OPTIONS_GHC -fno-warn-dodgy-exports -fno-warn-duplicate-exports #-}++module Autodocodec.Swagger+ ( declareNamedSchemaViaCodec,+ declareNamedSchemaVia,++ -- * To makes sure we definitely export everything.+ module Autodocodec.Swagger.Schema,+ module Autodocodec.Swagger.DerivingVia,+ )+where++import Autodocodec.Swagger.DerivingVia ()+import Autodocodec.Swagger.Schema
+ src/Autodocodec/Swagger/DerivingVia.hs view
@@ -0,0 +1,15 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Autodocodec.Swagger.DerivingVia where++import Autodocodec+import Autodocodec.Swagger.Schema+import Data.Proxy+import Data.Swagger as Swagger++-- | An instance for 'Autodocodec' that lets you use 'DerivingVia' to derive 'Swagger.ToSchema' if your type has a 'HasCodec' instance.+--+-- > deriving (Swagger.ToSchema) via (Autodocodec FooBar)+instance (HasCodec a) => Swagger.ToSchema (Autodocodec a) where+ declareNamedSchema (Proxy :: Proxy (Autodocodec a)) = declareNamedSchemaViaCodec (Proxy :: Proxy a)
+ src/Autodocodec/Swagger/Schema.hs view
@@ -0,0 +1,239 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLists #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Autodocodec.Swagger.Schema where++import Autodocodec+import Control.Monad+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap+import Data.List+import Data.Proxy+import Data.Scientific+import Data.Swagger as Swagger+import Data.Swagger.Declare as Swagger+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+ { _schemaParamSchema =+ mempty+ { _paramSchemaType = Just SwaggerNull+ }+ }+ 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_+ { _schemaParamSchema =+ (_schemaParamSchema s_)+ { _paramSchemaMinimum = Just numberBoundsLower,+ _paramSchemaMaximum = Just numberBoundsUpper+ }+ }+ pure $ NamedSchema mname $ maybe id addNumberBounds mBounds s+ HashMapCodec c -> do+ itemsSchema <- go c+ itemsSchemaRef <- declareSpecificNamedSchemaRef itemsSchema+ pure $+ NamedSchema Nothing $+ mempty+ { _schemaAdditionalProperties = Just $ AdditionalPropertiesSchema $ _namedSchemaSchema <$> itemsSchemaRef,+ _schemaParamSchema =+ mempty+ { _paramSchemaType = Just SwaggerObject+ }+ }+ MapCodec c -> do+ itemsSchema <- go c+ itemsSchemaRef <- declareSpecificNamedSchemaRef itemsSchema+ pure $+ NamedSchema Nothing $+ mempty+ { _schemaAdditionalProperties = Just $ AdditionalPropertiesSchema $ _namedSchemaSchema <$> itemsSchemaRef,+ _schemaParamSchema =+ mempty+ { _paramSchemaType = Just SwaggerObject+ }+ }+ ValueCodec ->+ pure $+ NamedSchema+ Nothing+ mempty+ { _schemaAdditionalProperties = Just $ AdditionalPropertiesAllowed True+ }+ ArrayOfCodec mname c -> do+ itemsSchema <- go c+ itemsSchemaRef <- declareSpecificNamedSchemaRef itemsSchema+ pure $+ NamedSchema mname $+ mempty+ { _schemaParamSchema =+ mempty+ { _paramSchemaType = Just SwaggerArray,+ _paramSchemaItems = Just $ SwaggerItemsObject $ _namedSchemaSchema <$> itemsSchemaRef+ }+ }+ ObjectOfCodec mname oc -> do+ ss <- goObject oc+ pure $ NamedSchema mname $ combineObjectSchemas ss+ EqCodec val valCodec ->+ pure $+ NamedSchema Nothing $+ mempty+ { _schemaParamSchema = mempty {_paramSchemaEnum = Just [toJSONVia valCodec val]}+ }+ BimapCodec _ _ c -> go c+ EitherCodec c1 c2 -> do+ ns1 <- go c1+ let s1 = _namedSchemaSchema ns1+ ns2 <- go c2+ let s2 = _namedSchemaSchema ns2+ pure $ NamedSchema Nothing $ combineSchemaOr s1 s2+ 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)],+ _schemaParamSchema = mempty {_paramSchemaType = Just SwaggerObject}+ }+ ]+ OptionalKeyCodec key vs mDoc -> do+ ns <- go vs+ ref <- declareSpecificNamedSchemaRef ns+ pure+ [ mempty+ { _schemaProperties = [(key, addMDoc mDoc . _namedSchemaSchema <$> ref)],+ _schemaParamSchema = mempty {_paramSchemaType = Just SwaggerObject}+ }+ ]+ OptionalKeyWithDefaultCodec key vs defaultValue mDoc -> do+ ns <- go vs+ ref <- declareSpecificNamedSchemaRef ns+ pure+ [ mempty+ { _schemaProperties = [(key, addMDoc mDoc . _namedSchemaSchema <$> ref)],+ _schemaParamSchema =+ mempty+ { _paramSchemaDefault = Just $ toJSONVia vs defaultValue,+ _paramSchemaType = Just SwaggerObject+ }+ }+ ]+ OptionalKeyWithOmittedDefaultCodec key vs defaultValue mDoc -> goObject (OptionalKeyWithDefaultCodec key vs defaultValue mDoc)+ PureCodec _ -> pure []+ EitherCodec oc1 oc2 -> do+ ss1 <- goObject oc1+ ss2 <- goObject oc2+ pure [combineSchemaOr (combineObjectSchemas ss1) (combineObjectSchemas ss2)]+ 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+ combineSchemaOr :: Schema -> Schema -> Schema+ combineSchemaOr s1 s2 =+ let ps1 = _schemaParamSchema s1+ ps2 = _schemaParamSchema s2+ -- Swagger 2 doesn't support sum types so we have to work around that here.+ --+ -- We support a few cases:+ --+ -- * Enum: If both of them have the enum field set+ -- * Two obects: If both of them have the object type set.+ --+ -- If none of these cases match, we just take an overapproximation of+ -- the schema: one which lets any value through.+ overApproximation =+ mempty+ { _schemaAdditionalProperties = Just $ AdditionalPropertiesAllowed True+ }+ in case (,) <$> _paramSchemaEnum ps1 <*> _paramSchemaEnum ps2 of+ (Just (es1, es2)) ->+ mempty+ { _schemaParamSchema =+ mempty+ { _paramSchemaEnum = Just $ es1 ++ es2,+ _paramSchemaType =+ case (,) <$> _paramSchemaType ps1 <*> _paramSchemaType ps2 of+ Just (t1, t2)+ | t1 == t2 -> Just t1+ | otherwise -> Nothing+ Nothing -> Nothing+ }+ }+ Nothing ->+ case (,) <$> _paramSchemaType ps1 <*> _paramSchemaType ps2 of+ Just (SwaggerObject, SwaggerObject) ->+ mempty+ { _schemaRequired = _schemaRequired s1 `intersect` _schemaRequired s2,+ _schemaProperties = InsOrdHashMap.union (_schemaProperties s1) (_schemaProperties s2),+ _schemaParamSchema = mempty {_paramSchemaType = Just SwaggerObject}+ }+ Just (a, b)+ | a == b -> mempty {_schemaParamSchema = mempty {_paramSchemaType = Just a}}+ | otherwise -> overApproximation+ _ -> overApproximation++declareSpecificNamedSchemaRef :: Swagger.NamedSchema -> Declare (Definitions Schema) (Referenced NamedSchema)+declareSpecificNamedSchemaRef namedSchema =+ fmap (NamedSchema (_namedSchemaName namedSchema))+ <$> declareSpecificSchemaRef (_namedSchemaName namedSchema) (_namedSchemaSchema namedSchema)++declareSpecificSchemaRef :: Maybe Text -> Swagger.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)