module Data.OpenApi.Compare.Validate.PathFragment
  ( parsePath,
    PathFragment (..),
    PathFragmentParam,
  )
where

import qualified Data.Aeson as A
import Data.OpenApi
import Data.OpenApi.Compare.Behavior
import Data.OpenApi.Compare.Subtree
import Data.OpenApi.Compare.Validate.Param
import Data.Text (Text)
import qualified Data.Text as T

-- TODO: templates can be only part of the PathFragment. Currently only supports templates as full PathFragment.
-- #23
parsePath :: FilePath -> [PathFragment Text]
parsePath :: FilePath -> [PathFragment Text]
parsePath = (Text -> PathFragment Text) -> [Text] -> [PathFragment Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> PathFragment Text
partition ([Text] -> [PathFragment Text])
-> (FilePath -> [Text]) -> FilePath -> [PathFragment Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text -> [Text]
T.splitOn Text
"/" (Text -> [Text]) -> (FilePath -> Text) -> FilePath -> [Text]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Text
T.pack
  where
    partition :: Text -> PathFragment Text
    partition :: Text -> PathFragment Text
partition Text
t
      | Just (Char
'{', Text
rest) <- Text -> Maybe (Char, Text)
T.uncons Text
t
        , Just (Text
ref, Char
'}') <- Text -> Maybe (Text, Char)
T.unsnoc Text
rest =
        Text -> PathFragment Text
forall param. param -> PathFragment param
DynamicPath Text
ref
    partition Text
t = Text -> PathFragment Text
forall param. Text -> PathFragment param
StaticPath Text
t

-- | Fragment parameterized by parameter. The dynamic part may be either
-- reference to some parameter (in context of operation) or dereferenced
-- parameter itself.
data PathFragment param
  = StaticPath Text
  | DynamicPath param
  deriving stock (PathFragment param -> PathFragment param -> Bool
(PathFragment param -> PathFragment param -> Bool)
-> (PathFragment param -> PathFragment param -> Bool)
-> Eq (PathFragment param)
forall param.
Eq param =>
PathFragment param -> PathFragment param -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PathFragment param -> PathFragment param -> Bool
$c/= :: forall param.
Eq param =>
PathFragment param -> PathFragment param -> Bool
== :: PathFragment param -> PathFragment param -> Bool
$c== :: forall param.
Eq param =>
PathFragment param -> PathFragment param -> Bool
Eq, Eq (PathFragment param)
Eq (PathFragment param)
-> (PathFragment param -> PathFragment param -> Ordering)
-> (PathFragment param -> PathFragment param -> Bool)
-> (PathFragment param -> PathFragment param -> Bool)
-> (PathFragment param -> PathFragment param -> Bool)
-> (PathFragment param -> PathFragment param -> Bool)
-> (PathFragment param -> PathFragment param -> PathFragment param)
-> (PathFragment param -> PathFragment param -> PathFragment param)
-> Ord (PathFragment param)
PathFragment param -> PathFragment param -> Bool
PathFragment param -> PathFragment param -> Ordering
PathFragment param -> PathFragment param -> PathFragment param
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall param. Ord param => Eq (PathFragment param)
forall param.
Ord param =>
PathFragment param -> PathFragment param -> Bool
forall param.
Ord param =>
PathFragment param -> PathFragment param -> Ordering
forall param.
Ord param =>
PathFragment param -> PathFragment param -> PathFragment param
min :: PathFragment param -> PathFragment param -> PathFragment param
$cmin :: forall param.
Ord param =>
PathFragment param -> PathFragment param -> PathFragment param
max :: PathFragment param -> PathFragment param -> PathFragment param
$cmax :: forall param.
Ord param =>
PathFragment param -> PathFragment param -> PathFragment param
>= :: PathFragment param -> PathFragment param -> Bool
$c>= :: forall param.
Ord param =>
PathFragment param -> PathFragment param -> Bool
> :: PathFragment param -> PathFragment param -> Bool
$c> :: forall param.
Ord param =>
PathFragment param -> PathFragment param -> Bool
<= :: PathFragment param -> PathFragment param -> Bool
$c<= :: forall param.
Ord param =>
PathFragment param -> PathFragment param -> Bool
< :: PathFragment param -> PathFragment param -> Bool
$c< :: forall param.
Ord param =>
PathFragment param -> PathFragment param -> Bool
compare :: PathFragment param -> PathFragment param -> Ordering
$ccompare :: forall param.
Ord param =>
PathFragment param -> PathFragment param -> Ordering
$cp1Ord :: forall param. Ord param => Eq (PathFragment param)
Ord, Int -> PathFragment param -> ShowS
[PathFragment param] -> ShowS
PathFragment param -> FilePath
(Int -> PathFragment param -> ShowS)
-> (PathFragment param -> FilePath)
-> ([PathFragment param] -> ShowS)
-> Show (PathFragment param)
forall param. Show param => Int -> PathFragment param -> ShowS
forall param. Show param => [PathFragment param] -> ShowS
forall param. Show param => PathFragment param -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [PathFragment param] -> ShowS
$cshowList :: forall param. Show param => [PathFragment param] -> ShowS
show :: PathFragment param -> FilePath
$cshow :: forall param. Show param => PathFragment param -> FilePath
showsPrec :: Int -> PathFragment param -> ShowS
$cshowsPrec :: forall param. Show param => Int -> PathFragment param -> ShowS
Show, a -> PathFragment b -> PathFragment a
(a -> b) -> PathFragment a -> PathFragment b
(forall a b. (a -> b) -> PathFragment a -> PathFragment b)
-> (forall a b. a -> PathFragment b -> PathFragment a)
-> Functor PathFragment
forall a b. a -> PathFragment b -> PathFragment a
forall a b. (a -> b) -> PathFragment a -> PathFragment b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> PathFragment b -> PathFragment a
$c<$ :: forall a b. a -> PathFragment b -> PathFragment a
fmap :: (a -> b) -> PathFragment a -> PathFragment b
$cfmap :: forall a b. (a -> b) -> PathFragment a -> PathFragment b
Functor)

type PathFragmentParam = PathFragment (Traced Param)

instance (Typeable param) => Steppable (PathFragment param) Param where
  data Step (PathFragment param) Param = StaticPathParam Text
    deriving stock (Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
(Step (PathFragment param) Param
 -> Step (PathFragment param) Param -> Bool)
-> (Step (PathFragment param) Param
    -> Step (PathFragment param) Param -> Bool)
-> Eq (Step (PathFragment param) Param)
forall param.
Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
$c/= :: forall param.
Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
== :: Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
$c== :: forall param.
Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
Eq, Eq (Step (PathFragment param) Param)
Eq (Step (PathFragment param) Param)
-> (Step (PathFragment param) Param
    -> Step (PathFragment param) Param -> Ordering)
-> (Step (PathFragment param) Param
    -> Step (PathFragment param) Param -> Bool)
-> (Step (PathFragment param) Param
    -> Step (PathFragment param) Param -> Bool)
-> (Step (PathFragment param) Param
    -> Step (PathFragment param) Param -> Bool)
-> (Step (PathFragment param) Param
    -> Step (PathFragment param) Param -> Bool)
-> (Step (PathFragment param) Param
    -> Step (PathFragment param) Param
    -> Step (PathFragment param) Param)
-> (Step (PathFragment param) Param
    -> Step (PathFragment param) Param
    -> Step (PathFragment param) Param)
-> Ord (Step (PathFragment param) Param)
Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Ordering
Step (PathFragment param) Param
-> Step (PathFragment param) Param
-> Step (PathFragment param) Param
forall param. Eq (Step (PathFragment param) Param)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall param.
Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
forall param.
Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Ordering
forall param.
Step (PathFragment param) Param
-> Step (PathFragment param) Param
-> Step (PathFragment param) Param
min :: Step (PathFragment param) Param
-> Step (PathFragment param) Param
-> Step (PathFragment param) Param
$cmin :: forall param.
Step (PathFragment param) Param
-> Step (PathFragment param) Param
-> Step (PathFragment param) Param
max :: Step (PathFragment param) Param
-> Step (PathFragment param) Param
-> Step (PathFragment param) Param
$cmax :: forall param.
Step (PathFragment param) Param
-> Step (PathFragment param) Param
-> Step (PathFragment param) Param
>= :: Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
$c>= :: forall param.
Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
> :: Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
$c> :: forall param.
Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
<= :: Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
$c<= :: forall param.
Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
< :: Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
$c< :: forall param.
Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Bool
compare :: Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Ordering
$ccompare :: forall param.
Step (PathFragment param) Param
-> Step (PathFragment param) Param -> Ordering
$cp1Ord :: forall param. Eq (Step (PathFragment param) Param)
Ord, Int -> Step (PathFragment param) Param -> ShowS
[Step (PathFragment param) Param] -> ShowS
Step (PathFragment param) Param -> FilePath
(Int -> Step (PathFragment param) Param -> ShowS)
-> (Step (PathFragment param) Param -> FilePath)
-> ([Step (PathFragment param) Param] -> ShowS)
-> Show (Step (PathFragment param) Param)
forall param. Int -> Step (PathFragment param) Param -> ShowS
forall param. [Step (PathFragment param) Param] -> ShowS
forall param. Step (PathFragment param) Param -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Step (PathFragment param) Param] -> ShowS
$cshowList :: forall param. [Step (PathFragment param) Param] -> ShowS
show :: Step (PathFragment param) Param -> FilePath
$cshow :: forall param. Step (PathFragment param) Param -> FilePath
showsPrec :: Int -> Step (PathFragment param) Param -> ShowS
$cshowsPrec :: forall param. Int -> Step (PathFragment param) Param -> ShowS
Show)

tracedPathFragmentParam :: Traced PathFragmentParam -> Traced Param
tracedPathFragmentParam :: Traced PathFragmentParam -> Traced Param
tracedPathFragmentParam Traced PathFragmentParam
pfp = case Traced PathFragmentParam -> PathFragmentParam
forall (w :: * -> *) a. Comonad w => w a -> a
extract Traced PathFragmentParam
pfp of
  StaticPath Text
s ->
    Trace Param -> Param -> Traced Param
forall a. Trace a -> a -> Traced a
traced (Traced PathFragmentParam -> Paths Step TraceRoot PathFragmentParam
forall e (w :: * -> *) a. ComonadEnv e w => w a -> e
ask Traced PathFragmentParam
pfp Paths Step TraceRoot PathFragmentParam
-> Paths Step PathFragmentParam Param -> Trace Param
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Step PathFragmentParam Param -> Paths Step PathFragmentParam Param
forall k (q :: k -> k -> *) (a :: k) (b :: k).
NiceQuiver q a b =>
q a b -> Paths q a b
step (Text -> Step PathFragmentParam Param
forall param. Text -> Step (PathFragment param) Param
StaticPathParam Text
s)) (Param -> Traced Param) -> Param -> Traced Param
forall a b. (a -> b) -> a -> b
$
      Param
forall a. Monoid a => a
mempty
        { _paramRequired :: Maybe Bool
_paramRequired = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
        , _paramIn :: ParamLocation
_paramIn = ParamLocation
ParamPath
        , _paramAllowEmptyValue :: Maybe Bool
_paramAllowEmptyValue = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        , _paramAllowReserved :: Maybe Bool
_paramAllowReserved = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        , _paramSchema :: Maybe (Referenced Schema)
_paramSchema = Referenced Schema -> Maybe (Referenced Schema)
forall a. a -> Maybe a
Just (Referenced Schema -> Maybe (Referenced Schema))
-> Referenced Schema -> Maybe (Referenced Schema)
forall a b. (a -> b) -> a -> b
$ Schema -> Referenced Schema
forall a. a -> Referenced a
Inline (Schema -> Referenced Schema) -> Schema -> Referenced Schema
forall a b. (a -> b) -> a -> b
$ Text -> Schema
staticStringSchema Text
s
        }
  DynamicPath Traced Param
p -> Traced Param
p

staticStringSchema :: Text -> Schema
staticStringSchema :: Text -> Schema
staticStringSchema Text
t =
  Schema
forall a. Monoid a => a
mempty
    { _schemaNullable :: Maybe Bool
_schemaNullable = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
    , _schemaType :: Maybe OpenApiType
_schemaType = OpenApiType -> Maybe OpenApiType
forall a. a -> Maybe a
Just OpenApiType
OpenApiString
    , _schemaEnum :: Maybe [Value]
_schemaEnum = [Value] -> Maybe [Value]
forall a. a -> Maybe a
Just [Text -> Value
A.String Text
t]
    }

instance Subtree PathFragmentParam where
  type SubtreeLevel PathFragmentParam = 'PathFragmentLevel
  type
    CheckEnv PathFragmentParam =
      '[ProdCons (Traced (Definitions Schema))]

  -- Not much to compare at this level
  checkStructuralCompatibility :: HList (CheckEnv PathFragmentParam)
-> ProdCons (Traced PathFragmentParam)
-> StructuralCompatFormula ()
checkStructuralCompatibility HList (CheckEnv PathFragmentParam)
_ ProdCons (Traced PathFragmentParam)
_ = StructuralCompatFormula ()
forall a. StructuralCompatFormula a
structuralIssue

  -- This case isn't strictly needed. It is here for optimization.
  checkSemanticCompatibility :: HList (CheckEnv PathFragmentParam)
-> Behavior (SubtreeLevel PathFragmentParam)
-> ProdCons (Traced PathFragmentParam)
-> SemanticCompatFormula ()
checkSemanticCompatibility HList (CheckEnv PathFragmentParam)
_ Behavior (SubtreeLevel PathFragmentParam)
beh (ProdCons (Traced PathFragmentParam -> PathFragmentParam
forall (w :: * -> *) a. Comonad w => w a -> a
extract -> StaticPath Text
x) (Traced PathFragmentParam -> PathFragmentParam
forall (w :: * -> *) a. Comonad w => w a -> a
extract -> StaticPath Text
y)) =
    if Text
x Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
y
      then () -> SemanticCompatFormula ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
      else Paths Behave 'APILevel 'PathFragmentLevel
-> Issue 'PathFragmentLevel -> SemanticCompatFormula ()
forall (l :: BehaviorLevel)
       (q :: BehaviorLevel -> BehaviorLevel -> *) (r :: BehaviorLevel) a.
Issuable l =>
Paths q r l -> Issue l -> CompatFormula' q AnIssue r a
issueAt Paths Behave 'APILevel 'PathFragmentLevel
Behavior (SubtreeLevel PathFragmentParam)
beh (ProdCons Text -> Issue 'PathFragmentLevel
PathFragmentsDontMatch (Text -> Text -> ProdCons Text
forall a. a -> a -> ProdCons a
ProdCons Text
x Text
y))
  checkSemanticCompatibility HList (CheckEnv PathFragmentParam)
env Behavior (SubtreeLevel PathFragmentParam)
beh ProdCons (Traced PathFragmentParam)
prodCons = do
    Behavior (SubtreeLevel Param)
-> HList '[ProdCons (Traced (Definitions Schema))]
-> ProdCons (Traced Param)
-> SemanticCompatFormula ()
forall t (xs :: [*]).
(ReassembleHList xs (CheckEnv t), Subtree t) =>
Behavior (SubtreeLevel t)
-> HList xs -> ProdCons (Traced t) -> SemanticCompatFormula ()
checkCompatibility Behavior (SubtreeLevel Param)
Behavior (SubtreeLevel PathFragmentParam)
beh HList '[ProdCons (Traced (Definitions Schema))]
HList (CheckEnv PathFragmentParam)
env (Traced PathFragmentParam -> Traced Param
tracedPathFragmentParam (Traced PathFragmentParam -> Traced Param)
-> ProdCons (Traced PathFragmentParam) -> ProdCons (Traced Param)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProdCons (Traced PathFragmentParam)
prodCons)