diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Changelog + +## [0.0.0.0] - 2021-11-19 + +First release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/autodocodec-swagger2.cabal b/autodocodec-swagger2.cabal new file mode 100644 --- /dev/null +++ b/autodocodec-swagger2.cabal @@ -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 diff --git a/src/Autodocodec/Swagger.hs b/src/Autodocodec/Swagger.hs new file mode 100644 --- /dev/null +++ b/src/Autodocodec/Swagger.hs @@ -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 diff --git a/src/Autodocodec/Swagger/DerivingVia.hs b/src/Autodocodec/Swagger/DerivingVia.hs new file mode 100644 --- /dev/null +++ b/src/Autodocodec/Swagger/DerivingVia.hs @@ -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) diff --git a/src/Autodocodec/Swagger/Schema.hs b/src/Autodocodec/Swagger/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Autodocodec/Swagger/Schema.hs @@ -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)