-- Copyright 2024 United States Government as represented by the Administrator
-- of the National Aeronautics and Space Administration. All Rights Reserved.
--
-- Disclaimers
--
-- Licensed under the Apache License, Version 2.0 (the "License"); you may
-- not use this file except in compliance with the License. You may obtain a
-- copy of the License at
--
--      https://www.apache.org/licenses/LICENSE-2.0
--
-- Unless required by applicable law or agreed to in writing, software
-- distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
-- WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
-- License for the specific language governing permissions and limitations
-- under the License.
--

-- | Parser for Ogma specs stored in JSON files.
module Language.JSONSpec.Parser where

-- External imports
import           Control.Monad.Except  (ExceptT (..), runExceptT)
import           Data.Aeson            (FromJSON (..), Value (..), decode, (.:))
import           Data.Aeson.Key        (toString)
import qualified Data.Aeson.KeyMap     as M
import           Data.Aeson.Types      (prependFailure, typeMismatch)
import           Data.Bifunctor        (first)
import           Data.ByteString.Lazy  (fromStrict)
import           Data.JSONPath.Execute
import           Data.JSONPath.Parser
import           Data.JSONPath.Types
import           Data.Text             (pack, unpack)
import qualified Data.Text             as T
import qualified Data.Text.Encoding    as T
import qualified Data.Text.IO          as T
import           Text.Megaparsec       (eof, errorBundlePretty, parse)

-- External imports: ogma-spec
import Data.OgmaSpec

data JSONFormat = JSONFormat
    { JSONFormat -> Maybe String
specInternalVars          :: Maybe String
    , JSONFormat -> String
specInternalVarId         :: String
    , JSONFormat -> String
specInternalVarExpr       :: String
    , JSONFormat -> Maybe String
specInternalVarType       :: Maybe String
    , JSONFormat -> Maybe String
specExternalVars          :: Maybe String
    , JSONFormat -> String
specExternalVarId         :: String
    , JSONFormat -> Maybe String
specExternalVarType       :: Maybe String
    , JSONFormat -> String
specRequirements          :: String
    , JSONFormat -> String
specRequirementId         :: String
    , JSONFormat -> Maybe String
specRequirementDesc       :: Maybe String
    , JSONFormat -> String
specRequirementExpr       :: String
    , JSONFormat -> Maybe String
specRequirementResultType :: Maybe String
    , JSONFormat -> Maybe String
specRequirementResultExpr :: Maybe String
    }
  deriving (ReadPrec [JSONFormat]
ReadPrec JSONFormat
Int -> ReadS JSONFormat
ReadS [JSONFormat]
(Int -> ReadS JSONFormat)
-> ReadS [JSONFormat]
-> ReadPrec JSONFormat
-> ReadPrec [JSONFormat]
-> Read JSONFormat
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
$creadsPrec :: Int -> ReadS JSONFormat
readsPrec :: Int -> ReadS JSONFormat
$creadList :: ReadS [JSONFormat]
readList :: ReadS [JSONFormat]
$creadPrec :: ReadPrec JSONFormat
readPrec :: ReadPrec JSONFormat
$creadListPrec :: ReadPrec [JSONFormat]
readListPrec :: ReadPrec [JSONFormat]
Read)

data JSONFormatInternal = JSONFormatInternal
  { JSONFormatInternal -> Maybe [JSONPathElement]
jfiInternalVars          :: Maybe [JSONPathElement]
  , JSONFormatInternal -> [JSONPathElement]
jfiInternalVarId         :: [JSONPathElement]
  , JSONFormatInternal -> [JSONPathElement]
jfiInternalVarExpr       :: [JSONPathElement]
  , JSONFormatInternal -> Maybe [JSONPathElement]
jfiInternalVarType       :: Maybe [JSONPathElement]
  , JSONFormatInternal -> Maybe [JSONPathElement]
jfiExternalVars          :: Maybe [JSONPathElement]
  , JSONFormatInternal -> [JSONPathElement]
jfiExternalVarId         :: [JSONPathElement]
  , JSONFormatInternal -> Maybe [JSONPathElement]
jfiExternalVarType       :: Maybe [JSONPathElement]
  , JSONFormatInternal -> [JSONPathElement]
jfiRequirements          :: [JSONPathElement]
  , JSONFormatInternal -> [JSONPathElement]
jfiRequirementId         :: [JSONPathElement]
  , JSONFormatInternal -> Maybe [JSONPathElement]
jfiRequirementDesc       :: Maybe [JSONPathElement]
  , JSONFormatInternal -> [JSONPathElement]
jfiRequirementExpr       :: [JSONPathElement]
  , JSONFormatInternal -> Maybe [JSONPathElement]
jfiRequirementResultType :: Maybe [JSONPathElement]
  , JSONFormatInternal -> Maybe [JSONPathElement]
jfiRequirementResultExpr :: Maybe [JSONPathElement]
  }

parseJSONFormat :: JSONFormat -> Either String JSONFormatInternal
parseJSONFormat :: JSONFormat -> Either String JSONFormatInternal
parseJSONFormat JSONFormat
jsonFormat = do
  jfi2  <- Maybe (Either String [JSONPathElement])
-> Either String (Maybe [JSONPathElement])
forall a b. Show a => Maybe (Either a b) -> Either String (Maybe b)
showErrorsM (Maybe (Either String [JSONPathElement])
 -> Either String (Maybe [JSONPathElement]))
-> Maybe (Either String [JSONPathElement])
-> Either String (Maybe [JSONPathElement])
forall a b. (a -> b) -> a -> b
$ (String -> Either String [JSONPathElement])
-> Maybe String -> Maybe (Either String [JSONPathElement])
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> Either String [JSONPathElement]
parseJSONPath (Text -> Either String [JSONPathElement])
-> (String -> Text) -> String -> Either String [JSONPathElement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) (Maybe String -> Maybe (Either String [JSONPathElement]))
-> Maybe String -> Maybe (Either String [JSONPathElement])
forall a b. (a -> b) -> a -> b
$ JSONFormat -> Maybe String
specInternalVars    JSONFormat
jsonFormat
  jfi3  <- showErrors $ parseJSONPath $ pack $ specInternalVarId   jsonFormat
  jfi4  <- showErrors $ parseJSONPath $ pack $ specInternalVarExpr jsonFormat
  jfi5  <- showErrorsM $ fmap (parseJSONPath . pack) $ specInternalVarType jsonFormat
  jfi6  <- showErrorsM $ fmap (parseJSONPath . pack) $ specExternalVars    jsonFormat
  jfi7  <- showErrors $ parseJSONPath $ pack $ specExternalVarId   jsonFormat
  jfi8  <- showErrorsM $ fmap (parseJSONPath . pack) $ specExternalVarType jsonFormat
  jfi9  <- showErrors $ parseJSONPath $ pack $ specRequirements    jsonFormat
  jfi10 <- showErrors $ parseJSONPath $ pack $ specRequirementId   jsonFormat
  jfi11 <- showErrorsM $ fmap (parseJSONPath . pack) $ specRequirementDesc jsonFormat
  jfi12 <- showErrors $ parseJSONPath $ pack $ specRequirementExpr jsonFormat
  jfi13 <- showErrorsM $ fmap (parseJSONPath . pack) $ specRequirementResultType jsonFormat
  jfi14 <- showErrorsM $ fmap (parseJSONPath . pack) $ specRequirementResultExpr jsonFormat
  return $ JSONFormatInternal
             { jfiInternalVars          = jfi2
             , jfiInternalVarId         = jfi3
             , jfiInternalVarExpr       = jfi4
             , jfiInternalVarType       = jfi5
             , jfiExternalVars          = jfi6
             , jfiExternalVarId         = jfi7
             , jfiExternalVarType       = jfi8
             , jfiRequirements          = jfi9
             , jfiRequirementId         = jfi10
             , jfiRequirementDesc       = jfi11
             , jfiRequirementExpr       = jfi12
             , jfiRequirementResultType = jfi13
             , jfiRequirementResultExpr = jfi14
             }

parseJSONSpec :: (String -> IO (Either String a)) -> JSONFormat -> Value -> IO (Either String (Spec a))
parseJSONSpec :: forall a.
(String -> IO (Either String a))
-> JSONFormat -> Value -> IO (Either String (Spec a))
parseJSONSpec String -> IO (Either String a)
parseExpr JSONFormat
jsonFormat Value
value = ExceptT String IO (Spec a) -> IO (Either String (Spec a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT String IO (Spec a) -> IO (Either String (Spec a)))
-> ExceptT String IO (Spec a) -> IO (Either String (Spec a))
forall a b. (a -> b) -> a -> b
$ do
  jsonFormatInternal <- Either String JSONFormatInternal
-> ExceptT String IO JSONFormatInternal
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String JSONFormatInternal
 -> ExceptT String IO JSONFormatInternal)
-> Either String JSONFormatInternal
-> ExceptT String IO JSONFormatInternal
forall a b. (a -> b) -> a -> b
$ JSONFormat -> Either String JSONFormatInternal
parseJSONFormat JSONFormat
jsonFormat

  let values :: [Value]
      values = [Value]
-> ([JSONPathElement] -> [Value])
-> Maybe [JSONPathElement]
-> [Value]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([JSONPathElement] -> Value -> [Value]
`executeJSONPath` Value
value) (JSONFormatInternal -> Maybe [JSONPathElement]
jfiInternalVars JSONFormatInternal
jsonFormatInternal)

      internalVarDef :: Value -> Either String InternalVariableDef
      internalVarDef Value
value = do
        let msg :: String
msg = String
"internal variable name"
        varId   <- String -> Value -> Either String String
valueToString String
msg (Value -> Either String String)
-> Either String Value -> Either String String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> [Value] -> Either String Value
forall a. String -> [a] -> Either String a
listToEither String
msg ([JSONPathElement] -> Value -> [Value]
executeJSONPath (JSONFormatInternal -> [JSONPathElement]
jfiInternalVarId JSONFormatInternal
jsonFormatInternal) Value
value))

        let msg = String
"internal variable type"
        varType <- maybe (Right "") (\[JSONPathElement]
e -> String -> Value -> Either String String
valueToString String
msg (Value -> Either String String)
-> Either String Value -> Either String String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> [Value] -> Either String Value
forall a. String -> [a] -> Either String a
listToEither String
msg ([JSONPathElement] -> Value -> [Value]
executeJSONPath [JSONPathElement]
e Value
value))) (jfiInternalVarType jsonFormatInternal)

        let msg = String
"internal variable expr"
        varExpr <- valueToString msg =<< (listToEither msg (executeJSONPath (jfiInternalVarExpr jsonFormatInternal) value))

        return $ InternalVariableDef
                   { internalVariableName    = varId
                   , internalVariableType    = varType
                   , internalVariableExpr    = varExpr
                   }

  internalVariableDefs <- except $ mapM internalVarDef values

  let values :: [Value]
      values = [Value]
-> ([JSONPathElement] -> [Value])
-> Maybe [JSONPathElement]
-> [Value]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] ([JSONPathElement] -> Value -> [Value]
`executeJSONPath` Value
value) (JSONFormatInternal -> Maybe [JSONPathElement]
jfiExternalVars JSONFormatInternal
jsonFormatInternal)

      externalVarDef :: Value -> Either String ExternalVariableDef
      externalVarDef Value
value = do

        let msg :: String
msg = String
"external variable name"
        varId   <- String -> Value -> Either String String
valueToString String
msg (Value -> Either String String)
-> Either String Value -> Either String String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> [Value] -> Either String Value
forall a. String -> [a] -> Either String a
listToEither String
msg ([JSONPathElement] -> Value -> [Value]
executeJSONPath (JSONFormatInternal -> [JSONPathElement]
jfiExternalVarId JSONFormatInternal
jsonFormatInternal) Value
value))

        let msg = String
"external variable type"
        varType <- maybe (Right "") (\[JSONPathElement]
e -> String -> Value -> Either String String
valueToString String
msg (Value -> Either String String)
-> Either String Value -> Either String String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> [Value] -> Either String Value
forall a. String -> [a] -> Either String a
listToEither String
msg ([JSONPathElement] -> Value -> [Value]
executeJSONPath [JSONPathElement]
e Value
value))) (jfiExternalVarType jsonFormatInternal)

        return $ ExternalVariableDef
                   { externalVariableName    = varId
                   , externalVariableType    = varType
                   }

  externalVariableDefs <- except $ mapM externalVarDef values

  let values :: [Value]
      values = [JSONPathElement] -> Value -> [Value]
executeJSONPath (JSONFormatInternal -> [JSONPathElement]
jfiRequirements JSONFormatInternal
jsonFormatInternal) Value
value

      -- requirementDef :: Value -> Either String (Requirement a)
      requirementDef Value
value = do
        let msg :: String
msg = String
"Requirement name"
        reqId <- Either String String -> ExceptT String IO String
forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except (Either String String -> ExceptT String IO String)
-> Either String String -> ExceptT String IO String
forall a b. (a -> b) -> a -> b
$ String -> Value -> Either String String
valueToString String
msg (Value -> Either String String)
-> Either String Value -> Either String String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> [Value] -> Either String Value
forall a. String -> [a] -> Either String a
listToEither String
msg ([JSONPathElement] -> Value -> [Value]
executeJSONPath (JSONFormatInternal -> [JSONPathElement]
jfiRequirementId JSONFormatInternal
jsonFormatInternal) Value
value))

        let msg = String
"Requirement expression"
        reqExpr <- except $ valueToString msg =<< (listToEither msg (executeJSONPath (jfiRequirementExpr jsonFormatInternal) value))
        reqExpr' <- ExceptT $ parseExpr reqExpr

        let msg = String
"Requirement description"
        reqDesc <- except $ maybe (Right "") (\[JSONPathElement]
e -> String -> Value -> Either String String
valueToString String
msg (Value -> Either String String)
-> Either String Value -> Either String String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> [Value] -> Either String Value
forall a. String -> [a] -> Either String a
listToEither String
msg ([JSONPathElement] -> Value -> [Value]
executeJSONPath [JSONPathElement]
e Value
value))) (jfiRequirementDesc jsonFormatInternal)

        let msg = String
"Requirement result type"
            ty :: Maybe (Either String String)
            ty = (\[JSONPathElement]
e -> String -> Value -> Either String String
valueToString String
msg (Value -> Either String String)
-> Either String Value -> Either String String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> [Value] -> Either String Value
forall a. String -> [a] -> Either String a
listToEither String
msg ([JSONPathElement] -> Value -> [Value]
executeJSONPath [JSONPathElement]
e Value
value))) ([JSONPathElement] -> Either String String)
-> Maybe [JSONPathElement] -> Maybe (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JSONFormatInternal -> Maybe [JSONPathElement]
jfiRequirementResultType JSONFormatInternal
jsonFormatInternal)
        reqResType <- except $ maybeEither ty

        let msg = String
"Requirement result expression"
            resultExpr :: Maybe (Either String String)
            resultExpr = (\[JSONPathElement]
e -> String -> Value -> Either String String
valueToString String
msg (Value -> Either String String)
-> Either String Value -> Either String String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (String -> [Value] -> Either String Value
forall a. String -> [a] -> Either String a
listToEither String
msg ([JSONPathElement] -> Value -> [Value]
executeJSONPath [JSONPathElement]
e Value
value))) ([JSONPathElement] -> Either String String)
-> Maybe [JSONPathElement] -> Maybe (Either String String)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (JSONFormatInternal -> Maybe [JSONPathElement]
jfiRequirementResultExpr JSONFormatInternal
jsonFormatInternal)

        reqResExpr  <- except $ maybeEither resultExpr
        reqResExpr' <- ExceptT $ case reqResExpr of
                                   Maybe String
Nothing -> Either String (Maybe a) -> IO (Either String (Maybe a))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either String (Maybe a) -> IO (Either String (Maybe a)))
-> Either String (Maybe a) -> IO (Either String (Maybe a))
forall a b. (a -> b) -> a -> b
$ Maybe a -> Either String (Maybe a)
forall a b. b -> Either a b
Right Maybe a
forall a. Maybe a
Nothing
                                   Just String
x  -> (a -> Maybe a) -> Either String a -> Either String (Maybe a)
forall a b. (a -> b) -> Either String a -> Either String b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> Maybe a
forall a. a -> Maybe a
Just (Either String a -> Either String (Maybe a))
-> IO (Either String a) -> IO (Either String (Maybe a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Either String a)
parseExpr String
x

        return $ Requirement
                   { requirementName        = reqId
                   , requirementExpr        = reqExpr'
                   , requirementDescription = reqDesc
                   , requirementResultType  = reqResType
                   , requirementResultExpr  = reqResExpr'
                   }

  requirements <- mapM requirementDef values

  return $ Spec internalVariableDefs externalVariableDefs requirements

valueToString :: String -> Value -> Either String String
valueToString :: String -> Value -> Either String String
valueToString String
msg (String Text
x) = String -> Either String String
forall a b. b -> Either a b
Right (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
x
valueToString String
msg Value
_          = String -> Either String String
forall a b. a -> Either a b
Left (String -> Either String String) -> String -> Either String String
forall a b. (a -> b) -> a -> b
$ String
"The JSON value provided for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not contain a string"

listToEither :: String -> [a] -> Either String a
listToEither :: forall a. String -> [a] -> Either String a
listToEither String
_   [a
x] = a -> Either String a
forall a b. b -> Either a b
Right a
x
listToEither String
msg []  = String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ String
"Failed to find a value for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg
listToEither String
msg [a]
_   = String -> Either String a
forall a b. a -> Either a b
Left (String -> Either String a) -> String -> Either String a
forall a b. (a -> b) -> a -> b
$ String
"Unexpectedly found multiple values for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
msg

-- | Parse a JSONPath expression, returning its element components.
parseJSONPath :: T.Text -> Either String [JSONPathElement]
parseJSONPath :: Text -> Either String [JSONPathElement]
parseJSONPath = (ParseErrorBundle Text Void -> String)
-> Either (ParseErrorBundle Text Void) [JSONPathElement]
-> Either String [JSONPathElement]
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first ParseErrorBundle Text Void -> String
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> String
errorBundlePretty (Either (ParseErrorBundle Text Void) [JSONPathElement]
 -> Either String [JSONPathElement])
-> (Text -> Either (ParseErrorBundle Text Void) [JSONPathElement])
-> Text
-> Either String [JSONPathElement]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parsec Void Text [JSONPathElement]
-> String
-> Text
-> Either (ParseErrorBundle Text Void) [JSONPathElement]
forall e s a.
Parsec e s a -> String -> s -> Either (ParseErrorBundle s e) a
parse (Parser () -> Parsec Void Text [JSONPathElement]
forall a. Parser a -> Parsec Void Text [JSONPathElement]
jsonPath Parser ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
eof) String
""

showErrors :: Show a => Either a b -> Either String b
showErrors :: forall a b. Show a => Either a b -> Either String b
showErrors (Left a
s)  = String -> Either String b
forall a b. a -> Either a b
Left (a -> String
forall a. Show a => a -> String
show a
s)
showErrors (Right b
x) = b -> Either String b
forall a b. b -> Either a b
Right b
x

showErrorsM :: Show a => Maybe (Either a b) -> Either String (Maybe b)
showErrorsM :: forall a b. Show a => Maybe (Either a b) -> Either String (Maybe b)
showErrorsM Maybe (Either a b)
Nothing          = Maybe b -> Either String (Maybe b)
forall a b. b -> Either a b
Right Maybe b
forall a. Maybe a
Nothing
showErrorsM (Just (Left a
s))  = String -> Either String (Maybe b)
forall a b. a -> Either a b
Left (a -> String
forall a. Show a => a -> String
show a
s)
showErrorsM (Just (Right b
x)) = Maybe b -> Either String (Maybe b)
forall a b. b -> Either a b
Right (b -> Maybe b
forall a. a -> Maybe a
Just b
x)

-- | Wrap an 'Either' value in an @ExceptT m@ monad.
except :: Monad m => Either e a -> ExceptT e m a
except :: forall (m :: * -> *) e a. Monad m => Either e a -> ExceptT e m a
except = m (Either e a) -> ExceptT e m a
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either e a) -> ExceptT e m a)
-> (Either e a -> m (Either e a)) -> Either e a -> ExceptT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Either e a -> m (Either e a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Swap the order in a Maybe and an Either monad.
maybeEither :: Maybe (Either a b) -> Either a (Maybe b)
maybeEither :: forall a b. Maybe (Either a b) -> Either a (Maybe b)
maybeEither Maybe (Either a b)
Nothing  = Maybe b -> Either a (Maybe b)
forall a b. b -> Either a b
Right Maybe b
forall a. Maybe a
Nothing
maybeEither (Just Either a b
e) = (b -> Maybe b) -> Either a b -> Either a (Maybe b)
forall a b. (a -> b) -> Either a a -> Either a b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> Maybe b
forall a. a -> Maybe a
Just Either a b
e