@@ -1,15 +1,129 @@
11{-# OPTIONS_GHC -Wno-orphans #-}
22
33module OpenAPI.Checker.Validate.Server
4− ( CheckIssue(..)
5− ) where
4+ ( CheckIssue (..)
5+ )
6+where
67
8+import Control.Applicative
9+import Control.Comonad
10+import Control.Monad
11+import Data.Attoparsec.Text
12+import Data.Either
13+import Data.Foldable
14+import Data.Function
15+import Data.Functor
16+import Data.HashMap.Strict.InsOrd as IOHM
17+import qualified Data.HashSet.InsOrd as IOHS
18+import Data.Maybe
719import Data.OpenApi
20+import Data.Text (Text)
21+import qualified Data.Text as T
22+import Data.Traversable
823import OpenAPI.Checker.Subtree
24+import OpenAPI.Checker.Trace
25+import Prelude as P
926
10−instance Subtree Server where
11− type CheckEnv Server = '[]
12− data CheckIssue Server
13− = ServerNotConsumed
27+tracedParsedServerUrlParts
28+ :: Traced' r [Server] Server
29+ -> Traced' r ProcessedServer (Either (CheckIssue ProcessedServer) ProcessedServer)
30+tracedParsedServerUrlParts s =
31+ let rawURL = _serverUrl $ extract s
32+ parsedUrl = parseServerUrl rawURL
33+ serverVariables = _serverVariables $ extract s
34+ in traced (ask s >>> step (ServerStep rawURL)) $
35+ parsedUrl
36+ & (traverse . traverse)
37+ (\var -> case IOHM.lookup var serverVariables of
38+ Nothing -> Left VariableNotDefined
39+ Just x -> Right x)
40+
41+instance Subtree [Server] where
42+ type CheckEnv [Server] = '[]
43+ data CheckIssue [Server]
44+ deriving (Eq, Ord, Show)
45+ checkCompatibility env pcServer = do
46+ let (ProdCons (pErrs, pUrls) (cErrs, cUrls)) =
47+ pcServer <&> partitionEithers . fmap (bicosequence . tracedParsedServerUrlParts) . sequence
48+ bicosequence :: Comonad f => f (Either a b) -> Either (f a) (f b)
49+ bicosequence x = case extract x of
50+ Left e -> Left $ x $> e
51+ Right a -> Right $ x $> a
52+ throwAllErrors = traverse_ tracedIssue
53+ throwAllErrors pErrs
54+ throwAllErrors cErrs
55+ for_ pUrls $ \cUrl -> do
56+ let potentiallyCompatible = P.filter ((staticCompatible `on` extract) cUrl) cUrls
57+ anyOfSubtreeAt cUrl ServerNotMatched $ potentiallyCompatible <&> (checkCompatibility env . ProdCons cUrl)
58+ pure ()
59+
60+type ProcessedServer = [ServerUrlPart ServerVariable]
61+
62+-- | Nothing means "open variable" – can have any value
63+unifyPart :: ServerUrlPart ServerVariable -> Maybe (IOHS.InsOrdHashSet Text)
64+unifyPart (ServerUrlVariable v) = _serverVariableEnum v
65+unifyPart (ServerUrlConstant c) = Just $ IOHS.singleton c
66+
67+zipAll :: [a] -> [b] -> Maybe [(a, b)]
68+zipAll [] [] = Just []
69+zipAll (x : xs) (y : ys) = ((x, y) :) <$> zipAll xs ys
70+zipAll (_ : _) [] = Nothing
71+zipAll [] (_ : _) = Nothing
72+
73+staticCompatiblePart :: ServerUrlPart x -> ServerUrlPart x -> Bool
74+staticCompatiblePart (ServerUrlConstant x) (ServerUrlConstant y) = x == y
75+staticCompatiblePart _ _ = True
76+
77+staticCompatible :: [ServerUrlPart x] -> [ServerUrlPart x] -> Bool
78+staticCompatible a b = maybe False (all $ uncurry staticCompatiblePart) $ zipAll a b
79+
80+data ServerUrlPart var
81+ = ServerUrlVariable var
82+ | ServerUrlConstant Text
83+ deriving stock (Show, Functor, Foldable, Traversable)
84+
85+-- | This is super rough. Things like @{a|b}c@ will not match @ac@.
86+-- FIXME: https://github.com/typeable/openapi-diff/issues/46
87+--
88+-- NOTE: syntax is defined vaguely in the spec.
89+parseServerUrl :: Text -> [ServerUrlPart Text]
90+-- There really is no way it can fail
91+parseServerUrl = fromRight undefined . parseOnly (serverUrlParser <* endOfInput)
92+ where
93+ serverUrlParser :: Parser [ServerUrlPart Text]
94+ serverUrlParser = many $ do
95+ variableUrlParser <|> do
96+ a <- anyChar
97+ aa <- takeTill (== '{')
98+ return (ServerUrlConstant $ T.cons a aa)
99+
100+ variableUrlParser :: Parser (ServerUrlPart Text)
101+ variableUrlParser = do
102+ char '{'
103+ res <- takeTill (== '}')
104+ char '}'
105+ return $ ServerUrlVariable res
106+
107+instance Steppable [Server] ProcessedServer where
108+ data Step [Server] ProcessedServer = ServerStep Text
109+ deriving (Eq, Ord, Show)
110+
111+instance Subtree ProcessedServer where
112+ type CheckEnv ProcessedServer = '[]
113+ data CheckIssue ProcessedServer
114+ = VariableNotDefined
115+ | ServerNotMatched
116+ | EnumValueNotConsumed Int Text
117+ | ConsumerNotOpen Int
14118 deriving (Eq, Ord, Show)
15− checkCompatibility = undefined
119+ checkCompatibility _ pc@(ProdCons p _) =
120+ -- traversing here is fine because we have already filtered for length
121+ for_ (zip [0 ..] $ zipProdCons . fmap (fmap unifyPart . extract) $ pc) $ \(i, pcPart) -> case pcPart of
122+ (Just x, Just y) -> for_ x $ \v -> unless (v `IOHS.member` y) (issueAt p $ EnumValueNotConsumed i v)
123+ -- Consumer can consume anything
124+ (_, Nothing) -> pure ()
125+ -- Producer can produce anythings, but consumer has a finite enum ;(
126+ (Nothing, Just _) -> issueAt p (ConsumerNotOpen i)
127+ where
128+ zipProdCons :: ProdCons [a] -> [(a, a)]
129+ zipProdCons (ProdCons x y) = zip x y