git.iko.soy/typeable/compaREST
on master help sign in
monad is done
496563bAleksey Uymanov
openapi-diff.cabal+3
compare with master
unifiedsplit
@@ -35,8 +35,11 @@ common common-options
35 , containers
35 , containers
36 , generic-monoid
36 , generic-monoid
37 , insert-ordered-containers
37 , insert-ordered-containers
38+ , lens
39+ , mtl
38 , openapi3
40 , openapi3
39 , text
41 , text
42+ , transformers
40
43
41 default-extensions: ConstraintKinds
44 default-extensions: ConstraintKinds
42 , DataKinds
45 , DataKinds
src/OpenAPI/Checker/Aux.hs+1−1
@@ -4,4 +4,4 @@ import Data.OpenApi.Internal
4
4
5-- | Megre servers from parent (like PathItem) and child (like Operation)
5-- | Megre servers from parent (like PathItem) and child (like Operation)
6mergeServers :: [Server] -> [Server] -> [Server]
6mergeServers :: [Server] -> [Server] -> [Server]
7−mergeServers = (error "FIXME: not implemented")
7+mergeServers parent child = (error "FIXME: not implemented")
src/OpenAPI/Checker/Report.hs+8−2
@@ -20,9 +20,9 @@ data Status = Success | Fail Text
20
20
21type Path = FilePath -- From the library
21type Path = FilePath -- From the library
22
22
23−data ReportTree = ReportTree
23+newtype ReportTree = ReportTree
24 { paths :: Map Path (Errorable PathItemTree)
24 { paths :: Map Path (Errorable PathItemTree)
25− } deriving (Eq, Ord, Show, Generic)
25+ } deriving (Eq, Ord, Show, Generic, Semigroup, Monoid)
26
26
27data PathItemTree = PathItemTree
27data PathItemTree = PathItemTree
28 { operations :: Map OperationName (Errorable OperationTree)
28 { operations :: Map OperationName (Errorable OperationTree)
@@ -47,6 +47,12 @@ data OperationName
47data OperationTree = OperationTree
47data OperationTree = OperationTree
48 deriving (Eq, Ord, Show, Generic)
48 deriving (Eq, Ord, Show, Generic)
49
49
50+instance Semigroup OperationTree where
51+ _ <> _ = OperationTree
52+
53+instance Monoid OperationTree where
54+ mempty = OperationTree
55+
50instance Nested OperationTree where
56instance Nested OperationTree where
51 type Parent OperationTree = PathItemTree
57 type Parent OperationTree = PathItemTree
52 type Key OperationTree = OperationName
58 type Key OperationTree = OperationName
src/OpenAPI/Checker/Validate.hs+40−24
@@ -1,6 +1,7 @@
1module OpenAPI.Checker.Validate where
1module OpenAPI.Checker.Validate where
2
2
3import Control.Monad
3import Control.Monad
4+import Control.Monad.Reader
4import Data.Functor
5import Data.Functor
5import Data.HashMap.Strict.InsOrd as InsMap
6import Data.HashMap.Strict.InsOrd as InsMap
6import Data.HashSet.InsOrd as InsSet
7import Data.HashSet.InsOrd as InsSet
@@ -14,38 +15,52 @@ import OpenAPI.Checker.Validate.Monad
14reportCompat :: OpenApi -> OpenApi -> Report
15reportCompat :: OpenApi -> OpenApi -> Report
15reportCompat = error "FIXME: reportCompat not implemented"
16reportCompat = error "FIXME: reportCompat not implemented"
16
17
17−forwardCompatible :: OpenApi -> OpenApi -> ReportTree
18+forwardCompatible :: OpenApi -> OpenApi -> Errorable ReportTree
18−forwardCompatible old new = fst $ runTreeM $ openApiCompatible old new
19+forwardCompatible old new
20+ = fmap snd
21+ $ runTreeM emptyEnv
22+ $ openApiCompatible old new
19
23
20openApiCompatible :: OpenApi -> OpenApi -> TreeM ReportTree ()
24openApiCompatible :: OpenApi -> OpenApi -> TreeM ReportTree ()
21−openApiCompatible old new = void $ follow $
25+openApiCompatible old new = do
26+ local (const servers) $ do
22− (InsMap.toList $ _openApiPaths old) <&> \(path, oldItem) ->
27+ follow $ (InsMap.toList $ _openApiPaths old) <&> \(path, oldItem) ->
23− (path, checkItem path oldItem)
28+ (path, checkItem path oldItem)
24 where
29 where
30+ servers = Env
25− oldServers = _openApiServers old
31+ { oldServers = _openApiServers old
26− newServers = _openApiServers new
32+ , newServers = _openApiServers new }
27 checkItem path oldItem = do
33 checkItem path oldItem = do
28 case (InsMap.lookup path $ _openApiPaths new) of
34 case (InsMap.lookup path $ _openApiPaths new) of
29 Nothing -> treeError $ "Path deleted"
35 Nothing -> treeError $ "Path deleted"
30 Just newItem ->
36 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 }
32
46
33pathItemsCompatible
47pathItemsCompatible
34− :: ([Server], PathItem)
48+ :: PathItem
35− -> ([Server], PathItem)
49+ -> PathItem
36 -> TreeM PathItemTree ()
50 -> TreeM PathItemTree ()
37−pathItemsCompatible (oldServers' , old) (newServers' , new) = void $ follow
51+pathItemsCompatible old new = do
52+ newEnv <- mergeEnvServers (_pathItemServers old) (_pathItemServers new)
53+ local (const newEnv) $ do
54+ follow
38− [ (Get, go _pathItemGet)
55+ [ (Get, go _pathItemGet)
39− , (Put, go _pathItemPut)
56+ , (Put, go _pathItemPut)
40− , (Post, go _pathItemPost)
57+ , (Post, go _pathItemPost)
41− , (Delete, go _pathItemDelete)
58+ , (Delete, go _pathItemDelete)
42− , (Options, go _pathItemOptions)
59+ , (Options, go _pathItemOptions)
43− , (Head, go _pathItemHead)
60+ , (Head, go _pathItemHead)
44− , (Patch, go _pathItemPatch)
61+ , (Patch, go _pathItemPatch)
45− , (Trace, go _pathItemTrace) ]
62+ , (Trace, go _pathItemTrace) ]
46 where
63 where
47− oldServers = mergeServers oldServers' (_pathItemServers old)
48− newServers = mergeServers newServers' (_pathItemServers new)
49 go :: (PathItem -> Maybe Operation) -> TreeM OperationTree ()
64 go :: (PathItem -> Maybe Operation) -> TreeM OperationTree ()
50 go getOp = case getOp old of
65 go getOp = case getOp old of
51 Nothing -> return ()
66 Nothing -> return ()
@@ -54,10 +69,11 @@ pathItemsCompatible (oldServers' , old) (newServers' , new) = void $ follow
54 Nothing -> do
69 Nothing -> do
55 -- Operation was in old schema, but no in new one.
70 -- Operation was in old schema, but no in new one.
56 treeError "Operation was deleted. Old client may try to use it."
71 treeError "Operation was deleted. Old client may try to use it."
72+ Just newOp ->
57− Just newOp -> operationsCompatible (oldServers, oldOp) (newServers, newOp)
73+ operationsCompatible oldOp newOp
58
74
59operationsCompatible
75operationsCompatible
60− :: ([Server], Operation)
76+ :: Operation
61− -> ([Server], Operation)
77+ -> Operation
62 -> TreeM OperationTree ()
78 -> TreeM OperationTree ()
63operationsCompatible = error "FIXME: operationsCompatible not implemented"
79operationsCompatible = error "FIXME: operationsCompatible not implemented"
src/OpenAPI/Checker/Validate/Monad.hs+33−14
@@ -1,32 +1,51 @@
1module OpenAPI.Checker.Validate.Monad where
1module OpenAPI.Checker.Validate.Monad where
2
2
3+import Control.Lens
4+import Control.Monad.Except
5+import Control.Monad.Trans.Except
6+import Control.Monad.Trans.Reader
7+import Control.Monad.Trans.State.Strict
8+import Data.Foldable
9+import Data.Functor.Identity
10+import Data.OpenApi.Internal
3−import Data.Text (Text)
11+import Data.Text (Text)
12+import Data.Traversable
13+import GHC.Generics (Generic)
4
14
15+type TreeM t = ReaderT Env (StateT t Errorable)
5
16
6−data TreeM t a = TreeM
17+data Env = Env
18+ { oldServers :: [Server]
19+ , newServers :: [Server]
20+ } deriving (Eq, Generic)
7
21
8−instance Functor (TreeM t)
22+emptyEnv :: Env
9−instance Applicative (TreeM t)
23+emptyEnv = Env [] []
10−instance Monad (TreeM t)
11
24
12−type Errorable = Either Text
25+type Errorable = Either Err
26+
27+type Err = Text
13
28
14-- | Class of trees nested into another trees
29-- | Class of trees nested into another trees
15−class Nested t where
30+class (Monoid (Parent t)) => Nested t where
16 type Parent t
31 type Parent t
17 type Key t
32 type Key t
18 nest :: Key t -> Errorable t -> Parent t
33 nest :: Key t -> Errorable t -> Parent t
19
34
20−runTreeM :: TreeM t a -> (t, a)
35+runTreeM :: (Monoid t) => Env -> TreeM t a -> Errorable (a, t)
21−runTreeM = error "FIXME: runReportTree not implemented"
36+runTreeM env ma = runStateT (runReaderT ma env) mempty
22
37
23-- | Throws error in current tree
38-- | Throws error in current tree
24−treeError :: Text -> TreeM t a
39+treeError :: Err -> TreeM t a
25−treeError = error "FIXME: treeError not implemented"
40+treeError = throwError
26
41
27-- | Runs several computations in different paths in subtrees
42-- | Runs several computations in different paths in subtrees
28follow
43follow
29− :: (Traversable f, Nested t)
44+ :: (Foldable f, Nested t, Monoid t)
30 => f (Key t, TreeM t a)
45 => f (Key t, TreeM t a)
31− -> TreeM (Parent t) (f a)
46+ -> TreeM (Parent t) ()
32−follow = error "FIXME: follow not implemented"
47+follow tree = do
48+ env <- ask
49+ for_ tree $ \(key, sub) -> do
50+ let p = nest key $ fmap snd $ runTreeM env sub
51+ id <>= p