Merge pull request #1 from jbgour/validate-not_-case

Rebase forked lib on current biocad master

src/Data/OpenApi/Internal/Schema.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedLists #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE PackageImports #-}
@@ -19,12 +20,13 @@
 {-# OPTIONS_GHC -Wno-redundant-constraints #-}
 -- For TypeErrors
 {-# OPTIONS_GHC -Wno-unticked-promoted-constructors #-}
+{-# LANGUAGE LambdaCase #-}
 module Data.OpenApi.Internal.Schema where
 
 import Prelude ()
 import Prelude.Compat
 
-import Control.Lens hiding (allOf)
+import Control.Lens hiding (allOf, anyOf)
 import Data.Data.Lens (template)
 
 import Control.Applicative ((<|>))
@@ -357,14 +359,16 @@ inlineNonRecursiveSchemas defs = inlineSchemasWhen nonRecursive defs
 --         "Jack",
 --         25
 --     ],
---     "items": [
---         {
---             "type": "string"
---         },
---         {
---             "type": "number"
---         }
---     ],
+--     "items": {
+--         "anyOf": [
+--             {
+--                 "type": "string"
+--             },
+--             {
+--                 "type": "number"
+--             }
+--         ]
+--     },
 --     "type": "array"
 -- }
 --
@@ -405,7 +409,7 @@ sketchSchema = sketch . toJSON
       & type_   ?~ OpenApiArray
       & items ?~ case ischema of
           Just s -> OpenApiItemsObject (Inline s)
-          _      -> OpenApiItemsArray (map Inline ys)
+          _      -> OpenApiItemsObject (Inline $ mempty & anyOf ?~ (map Inline ys))
       where
         ys = map go (V.toList xs)
         allSame = and ((zipWith (==)) ys (tail ys))
@@ -441,35 +445,37 @@ sketchSchema = sketch . toJSON
 --             3
 --         ]
 --     ],
---     "items": [
---         {
---             "enum": [
---                 1
---             ],
---             "maximum": 1,
---             "minimum": 1,
---             "multipleOf": 1,
---             "type": "number"
---         },
---         {
---             "enum": [
---                 2
---             ],
---             "maximum": 2,
---             "minimum": 2,
---             "multipleOf": 2,
---             "type": "number"
---         },
---         {
---             "enum": [
---                 3
---             ],
---             "maximum": 3,
---             "minimum": 3,
---             "multipleOf": 3,
---             "type": "number"
---         }
---     ],
+--     "items": {
+--         "anyOf": [
+--             {
+--                 "enum": [
+--                     1
+--                 ],
+--                 "maximum": 1,
+--                 "minimum": 1,
+--                 "multipleOf": 1,
+--                 "type": "number"
+--             },
+--             {
+--                 "enum": [
+--                     2
+--                 ],
+--                 "maximum": 2,
+--                 "minimum": 2,
+--                 "multipleOf": 2,
+--                 "type": "number"
+--             },
+--             {
+--                 "enum": [
+--                     3
+--                 ],
+--                 "maximum": 3,
+--                 "minimum": 3,
+--                 "multipleOf": 3,
+--                 "type": "number"
+--             }
+--         ]
+--     },
 --     "maxItems": 3,
 --     "minItems": 3,
 --     "type": "array",
@@ -484,26 +490,28 @@ sketchSchema = sketch . toJSON
 --             25
 --         ]
 --     ],
---     "items": [
---         {
---             "enum": [
---                 "Jack"
---             ],
---             "maxLength": 4,
---             "minLength": 4,
---             "pattern": "Jack",
---             "type": "string"
---         },
---         {
---             "enum": [
---                 25
---             ],
---             "maximum": 25,
---             "minimum": 25,
---             "multipleOf": 25,
---             "type": "number"
---         }
---     ],
+--     "items": {
+--         "anyOf": [
+--             {
+--                 "enum": [
+--                     "Jack"
+--                 ],
+--                 "maxLength": 4,
+--                 "minLength": 4,
+--                 "pattern": "Jack",
+--                 "type": "string"
+--             },
+--             {
+--                 "enum": [
+--                     25
+--                 ],
+--                 "maximum": 25,
+--                 "minimum": 25,
+--                 "multipleOf": 25,
+--                 "type": "number"
+--             }
+--         ]
+--     },
 --     "maxItems": 2,
 --     "minItems": 2,
 --     "type": "array",
@@ -571,7 +579,7 @@ sketchStrictSchema = go . toJSON
       & type_       ?~ OpenApiArray
       & maxItems    ?~ fromIntegral sz
       & minItems    ?~ fromIntegral sz
-      & items       ?~ OpenApiItemsArray (map (Inline . go) (V.toList xs))
+      & items       ?~ OpenApiItemsObject (Inline $ mempty & anyOf ?~ (map (Inline . go) (V.toList xs)))
       & uniqueItems ?~ allUnique
       & enum_       ?~ [js]
       where
@@ -983,20 +991,37 @@ gdeclareSchemaRef opts proxy = do
       return $ Ref (Reference name)
     _ -> Inline <$> gdeclareSchema opts proxy
 
-appendItem :: Referenced Schema -> Maybe OpenApiItems -> Maybe OpenApiItems
-appendItem x Nothing = Just (OpenApiItemsArray [x])
-appendItem x (Just (OpenApiItemsArray xs)) = Just (OpenApiItemsArray (xs ++ [x]))
-appendItem _ _ = error "GToSchema.appendItem: cannot append to OpenApiItemsObject"
+addItem :: Referenced Schema -> Maybe OpenApiItems -> Maybe OpenApiItems
+addItem x Nothing = Just (OpenApiItemsArray [x])
+addItem x (Just (OpenApiItemsArray xs)) = case xs of
+  []                 -> Just $ OpenApiItemsObject x
+  [x'] | x == x'     -> Just $ OpenApiItemsObject x
+  _    | x `elem` xs -> Just $ OpenApiItemsObject $ Inline $ mempty & anyOf ?~ xs
+  _                  -> Just $ OpenApiItemsObject $ Inline $ mempty & anyOf ?~ (xs ++ [x])
+addItem x (Just (OpenApiItemsObject (Inline s))) =
+  let appendMaybe = Just . maybe [x] (\xs -> if x `elem` xs then xs else xs ++ [x])
+  in Just $ OpenApiItemsObject $ Inline $ s & anyOf %~ appendMaybe
+addItem x j@(Just (OpenApiItemsObject ref))
+  | x == ref  = j
+  | otherwise = Just $ OpenApiItemsObject $ Inline $ mempty & anyOf ?~ [ref, x]
 
 withFieldSchema :: forall proxy s f. (Selector s, GToSchema f) =>
   SchemaOptions -> proxy s f -> Bool -> Schema -> Declare (Definitions Schema) Schema
 withFieldSchema opts _ isRequiredField schema = do
-  ref <- gdeclareSchemaRef opts (Proxy :: Proxy f)
+  let setNullable = if isRequiredField
+                    then id
+                    else \case
+                      ref@(Ref _) -> Inline $ mempty & anyOf ?~ [ ref
+                                                                , Inline $ mempty & nullable ?~ True
+                                                                                  & type_ ?~ OpenApiObject
+                                                                ]
+                      Inline s -> Inline $ s & nullable ?~ True
+  ref <- setNullable <$> gdeclareSchemaRef opts (Proxy :: Proxy f)
   return $
     if T.null fname
       then schema
         & type_ ?~ OpenApiArray
-        & items %~ appendItem ref
+        & items %~ addItem ref
         & maxItems %~ Just . maybe 1 (+1)   -- increment maxItems
         & minItems %~ Just . maybe 1 (+1)   -- increment minItems
       else schema

src/Data/OpenApi/Internal/Schema/Validation.hs

@@ -28,7 +28,7 @@ import           Prelude                             ()
 import           Prelude.Compat
 
 import           Control.Applicative
-import           Control.Lens                        hiding (allOf)
+import           Control.Lens                        hiding (allOf, anyOf)
 import           Control.Monad                       (forM, forM_, when)
 
 import           Data.Aeson                          hiding (Result)
@@ -491,19 +491,27 @@ validateSchemaType val = withSchema $ \sch ->
         1 -> valid
         _ -> invalid $ "Value matches more than one of 'oneOf' schemas: " ++ show val
     (view anyOf -> Just variants) -> do
-      res <- forM variants $ \var ->
-        (True <$ validateWithSchemaRef var val) <|> (return False)
-      case length $ filter id res of
-        0 -> invalid $ "Value not valid under any of 'anyOf' schemas: " ++ show val
-        _ -> valid
+      (asum $ (\var -> validateWithSchemaRef var val) <$> variants)
+      <|> (invalid $ "Value not valid under any of 'anyOf' schemas: " ++ show val)
     (view allOf -> Just variants) -> do
       -- Default semantics for Validation Monad will abort when at least one
       -- variant does not match.
       forM_ variants $ \var ->
         validateWithSchemaRef var val
-
+    (view not_ -> Just notVariant) -> do
+      -- Attempt to validate against `notVariant`, expecting it to fail.
+      -- `False <$ ...` ensures that a successful validation maps to `False`.
+      -- If the validation fails, `return True` ensures we catch this as the desired outcome.
+      validationResult <- (False <$ validateWithSchemaRef notVariant val) <|> return True
+      if validationResult
+        then valid  -- If the result is `True`, it means `validateWithSchemaRef` failed, which is correct.
+        else invalid $ "Value matches 'not' schema, which it shouldn't: " ++ show val
+
     _ ->
       case (sch ^. type_, val) of
+        -- Type must be set for nullable to have effect
+        -- See https://github.com/OAI/OpenAPI-Specification/blob/main/versions/3.0.3.md#fixed-fields-20
+        (Just _, Null) | sch ^. nullable == Just True -> valid
         (Just OpenApiNull,    Null)       -> valid
         (Just OpenApiBoolean, Bool _)     -> valid
         (Just OpenApiInteger, Number n)   -> validateInteger n
@@ -542,4 +550,4 @@ showType (Nothing, Bool _)   = "OpenApiBoolean"
 showType (Nothing, Number _) = "OpenApiNumber"
 showType (Nothing, String _) = "OpenApiString"
 showType (Nothing, Array _)  = "OpenApiArray"
-showType (Nothing, Object _) = "OpenApiObject"
+showType (Nothing, Object _) = "OpenApiObject"

src/Data/OpenApi/Schema/Validation.hs

@@ -75,7 +75,7 @@ import Data.OpenApi.Internal.Schema.Validation
 -- >>> validateToJSON ([Just "hello", Nothing] :: [Maybe String])
 -- ["expected JSON value of type OpenApiString"]
 -- >>> validateToJSON (123, Nothing :: Maybe String)
--- ["expected JSON value of type OpenApiString"]
+-- ["Value not valid under any of 'anyOf' schemas: Null"]
 --
 -- However, when @'Maybe' a@ is a type of a record field,
 -- validation takes @'required'@ property of the @'Schema'@

src/Data/OpenApi/SchemaOptions.hs

@@ -1,13 +1,19 @@
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE LambdaCase #-}
 -- |
 -- Module:      Data.OpenApi.SchemaOptions
 -- Maintainer:  Nickolay Kudasov <[email protected]>
 -- Stability:   experimental
 --
 -- Generic deriving options for @'ToParamSchema'@ and @'ToSchema'@.
-module Data.OpenApi.SchemaOptions where
+module Data.OpenApi.SchemaOptions (
+    SchemaOptions (..)
+  , defaultSchemaOptions
+  , fromAesonOptions
+) where
 
 import qualified Data.Aeson.Types as Aeson
+import Data.Char
 
 -- | Options that specify how to encode your type to Swagger schema.
 data SchemaOptions = SchemaOptions
@@ -40,14 +46,26 @@ data SchemaOptions = SchemaOptions
 -- @
 defaultSchemaOptions :: SchemaOptions
 defaultSchemaOptions = SchemaOptions
+  -- \x -> traceShowId x
   { fieldLabelModifier = id
   , constructorTagModifier = id
-  , datatypeNameModifier = id
+  , datatypeNameModifier = conformDatatypeNameModifier
   , allNullaryToStringTag = True
   , unwrapUnaryRecords = False
   , sumEncoding = Aeson.defaultTaggedObject
   }
 
+
+-- | According to spec https://github.com/OAI/OpenAPI-Specification/blob/main/versions/3.0.3.md#components-object 
+-- name must conform to ^[a-zA-Z0-9\.\-_]+$
+conformDatatypeNameModifier :: String -> String
+conformDatatypeNameModifier = 
+  foldl (\acc x -> acc ++ convertChar x) ""  
+  where 
+    convertChar = \case 
+      c | isAlphaNum c || elem c "-._" -> [c]
+      c -> "_" ++ (show $ ord c) ++ "_"
+
 -- | Convert 'Aeson.Options' to 'SchemaOptions'.
 --
 -- Specifically the following fields get copied: