@@ -1,6 +1,7 @@
11module OpenAPI.Checker.Validate where
22
33import Control.Monad
4+import Control.Monad.Reader
45import Data.Functor
56import Data.HashMap.Strict.InsOrd as InsMap
67import Data.HashSet.InsOrd as InsSet
@@ -14,38 +15,52 @@ import OpenAPI.Checker.Validate.Monad
1415reportCompat :: OpenApi -> OpenApi -> Report
1516reportCompat = error "FIXME: reportCompat not implemented"
1617
17−forwardCompatible :: OpenApi -> OpenApi -> ReportTree
18−forwardCompatible old new = fst $ runTreeM $ openApiCompatible old new
18+forwardCompatible :: OpenApi -> OpenApi -> Errorable ReportTree
19+forwardCompatible old new
20+ = fmap snd
21+ $ runTreeM emptyEnv
22+ $ openApiCompatible old new
1923
2024openApiCompatible :: OpenApi -> OpenApi -> TreeM ReportTree ()
21−openApiCompatible old new = void $ follow $
22− (InsMap.toList $ _openApiPaths old) <&> \(path, oldItem) ->
23− (path, checkItem path oldItem)
25+openApiCompatible old new = do
26+ local (const servers) $ do
27+ follow $ (InsMap.toList $ _openApiPaths old) <&> \(path, oldItem) ->
28+ (path, checkItem path oldItem)
2429 where
25− oldServers = _openApiServers old
26− newServers = _openApiServers new
30+ servers = Env
31+ { oldServers = _openApiServers old
32+ , newServers = _openApiServers new }
2733 checkItem path oldItem = do
2834 case (InsMap.lookup path $ _openApiPaths new) of
2935 Nothing -> treeError $ "Path deleted"
3036 Just newItem ->
31− pathItemsCompatible (oldServers, oldItem) (newServers, newItem)
37+ pathItemsCompatible oldItem newItem
38+
39+
40+mergeEnvServers :: [Server] -> [Server] -> TreeM t Env
41+mergeEnvServers olds news = do
42+ env <- ask
43+ return $ Env
44+ { oldServers = mergeServers (oldServers env) olds
45+ , newServers = mergeServers (newServers env) news }
3246
3347pathItemsCompatible
34− :: ([Server], PathItem)
35− -> ([Server], PathItem)
48+ :: PathItem
49+ -> PathItem
3650 -> TreeM PathItemTree ()
37−pathItemsCompatible (oldServers' , old) (newServers' , new) = void $ follow
38− [ (Get, go _pathItemGet)
39− , (Put, go _pathItemPut)
40− , (Post, go _pathItemPost)
41− , (Delete, go _pathItemDelete)
42− , (Options, go _pathItemOptions)
43− , (Head, go _pathItemHead)
44− , (Patch, go _pathItemPatch)
45− , (Trace, go _pathItemTrace) ]
51+pathItemsCompatible old new = do
52+ newEnv <- mergeEnvServers (_pathItemServers old) (_pathItemServers new)
53+ local (const newEnv) $ do
54+ follow
55+ [ (Get, go _pathItemGet)
56+ , (Put, go _pathItemPut)
57+ , (Post, go _pathItemPost)
58+ , (Delete, go _pathItemDelete)
59+ , (Options, go _pathItemOptions)
60+ , (Head, go _pathItemHead)
61+ , (Patch, go _pathItemPatch)
62+ , (Trace, go _pathItemTrace) ]
4663 where
47− oldServers = mergeServers oldServers' (_pathItemServers old)
48− newServers = mergeServers newServers' (_pathItemServers new)
4964 go :: (PathItem -> Maybe Operation) -> TreeM OperationTree ()
5065 go getOp = case getOp old of
5166 Nothing -> return ()
@@ -54,10 +69,11 @@ pathItemsCompatible (oldServers' , old) (newServers' , new) = void $ follow
5469 Nothing -> do
5570 -- Operation was in old schema, but no in new one.
5671 treeError "Operation was deleted. Old client may try to use it."
57− Just newOp -> operationsCompatible (oldServers, oldOp) (newServers, newOp)
72+ Just newOp ->
73+ operationsCompatible oldOp newOp
5874
5975operationsCompatible
60− :: ([Server], Operation)
61− -> ([Server], Operation)
76+ :: Operation
77+ -> Operation
6278 -> TreeM OperationTree ()
6379operationsCompatible = error "FIXME: operationsCompatible not implemented"