-- Copyright 2024 United States Government as represented by the Administrator
-- of the National Aeronautics and Space Administration. All Rights Reserved.
--
-- 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 XML files.
module Language.XMLSpec.Parser where
-- External imports
import Control.Monad.Except (ExceptT (..), liftEither, throwError, runExceptT)
import Control.Monad.IO.Class (liftIO)
import Data.List (isPrefixOf)
import Data.Maybe (fromMaybe, listToMaybe)
import Text.XML.HXT.Core (configSysVars, no, readString, runX,
withCanonicalize, withOutputPLAIN, withRedirect,
withRemoveWS, withSubstDTDEntities,
withSubstHTMLEntities, withValidate, yes, (>>>))
import Text.XML.HXT.XPath (getXPathTrees, parseXPathExpr)
-- External imports: ogma-spec
import Data.OgmaSpec (ExternalVariableDef (..), InternalVariableDef (..),
Requirement (..), Spec (Spec))
-- Internal imports
import Language.XMLSpec.PrintTrees (pretty, flattenDoc)
-- | List of XPath routes to the elements we need to parse.
--
-- The optional paths denote elements that may not exist. If they are nothing,
-- those elements are not parsed in the input file.
--
-- The subfields are applied on each string matching the parent element. That
-- is, the internal var ID XPath will be a applied to the strings returned when
-- applying the internal vars XPath (if it exists). Paths whose names are
-- plural denote expected lists of elements.
--
-- The components of a tuple (String, Maybe (String, String)) mean the
-- following: if a string is present but the second component is Nothing, then
-- the string is the XPath expression to be used. If a Just value is present,
-- the first element of its inner tuple represents a key, and the second
-- element represents an XPath expression that will produce a value when
-- evaluated globally in the file. After evaluating that expression, the key
-- must be found in the first string of the three and replaced with the result
-- of evaluating the expression.
data XMLFormat = XMLFormat
{ specInternalVars :: Maybe String
, specInternalVarId :: (String, Maybe (String, String))
, specInternalVarExpr :: (String, Maybe (String, String))
, specInternalVarType :: Maybe (String, Maybe (String, String))
, specExternalVars :: Maybe String
, specExternalVarId :: (String, Maybe (String, String))
, specExternalVarType :: Maybe (String, Maybe (String, String))
, specRequirements :: (String, Maybe (String, String))
, specRequirementId :: (String, Maybe (String, String))
, specRequirementDesc :: Maybe (String, Maybe (String, String))
, specRequirementExpr :: (String, Maybe (String, String))
, specRequirementResultType :: Maybe (String, Maybe (String, String))
, specRequirementResultExpr :: Maybe (String, Maybe (String, String))
}
deriving (Show, Read)
-- | Parse an XML file and extract a Spec from it.
--
-- An auxiliary function must be provided to parse the requirement expressions.
--
-- Fails if any of the XPaths in the argument XMLFormat are not valid
-- expressions, of the XML is malformed, or if the elements are not found with
-- the frequency expected (e.g., an external variable id is not found even
-- though external variables are found).
parseXMLSpec :: (String -> IO (Either String a)) -- ^ Parser for expressions.
-> a
-> XMLFormat -- ^ XPaths for spec locations.
-> String -- ^ String containing XML
-> IO (Either String (Spec a))
parseXMLSpec parseExpr defA xmlFormat value = runExceptT $ do
xmlFormatInternal <- parseXMLFormat xmlFormat value
-- Internal variables
-- intVarStrings :: [String]
intVarStrings <- liftIO $ maybe
(return [])
(`executeXPath` value)
(xfiInternalVars xmlFormatInternal)
let internalVarDef :: String -> ExceptT String IO InternalVariableDef
internalVarDef def = do
let msgI = "internal variable name"
varId <- ExceptT $
listToEither msgI <$>
executeXPath (xfiInternalVarId xmlFormatInternal) def
let msgT = "internal variable type"
varType <- maybe
(liftEither $ Right "")
(\e -> ExceptT $ listToEither msgT <$> executeXPath e def)
(xfiInternalVarType xmlFormatInternal)
let msgE = "internal variable expr"
varExpr <- ExceptT $
listToEither msgE <$>
executeXPath (xfiInternalVarExpr xmlFormatInternal) def
return $ InternalVariableDef
{ internalVariableName = varId
, internalVariableType = varType
, internalVariableExpr = varExpr
}
internalVariableDefs <- mapM internalVarDef intVarStrings
-- External variables
-- extVarStrings :: [String]
extVarStrings <- liftIO $ maybe
(return [])
(`executeXPath` value)
(xfiExternalVars xmlFormatInternal)
let externalVarDef :: String -> ExceptT String IO ExternalVariableDef
externalVarDef def = do
let msgI = "external variable name"
varId <- ExceptT $
listToEither msgI <$>
executeXPath (xfiExternalVarId xmlFormatInternal) def
let msgT = "external variable type"
varType <- maybe
(liftEither $ Right "")
(\e -> ExceptT $ listToEither msgT <$> executeXPath e def)
(xfiExternalVarType xmlFormatInternal)
return $ ExternalVariableDef
{ externalVariableName = varId
, externalVariableType = varType
}
externalVariableDefs <- mapM externalVarDef extVarStrings
-- Requirements
-- reqStrings :: [String]
reqStrings <- liftIO $ executeXPath (xfiRequirements xmlFormatInternal) value
let -- requirementDef :: String -> ExceptT String (Requirement a)
requirementDef def = do
-- let msgI = "Requirement name: " ++ take 160 def
reqId <- liftIO $ fromMaybe "" . listToMaybe <$>
executeXPath (xfiRequirementId xmlFormatInternal) def
-- let msgE = "Requirement expression: " ++ take 160 def
reqExpr <- liftIO $
listToMaybe <$>
concatMapM (`executeXPath` def) (xfiRequirementExpr xmlFormatInternal)
reqExpr' <- maybe (return defA)
(ExceptT . parseExpr . textUnescape)
reqExpr
-- let msgD = "Requirement description"
reqDesc <- maybe
(liftEither $ Right "")
(\e -> liftIO $ fromMaybe "" . listToMaybe <$> executeXPath e def)
(xfiRequirementDesc xmlFormatInternal)
reqResType <- case xfiRequirementResultType xmlFormatInternal of
Nothing -> return Nothing
Just e -> liftIO $ listToMaybe <$> executeXPath e def
reqResExpr <- case xfiRequirementResultExpr xmlFormatInternal of
Nothing -> return Nothing
Just e -> liftIO $ listToMaybe <$> executeXPath e def
reqResExpr' <- maybe (return Nothing)
(fmap Just . ExceptT . parseExpr . textUnescape)
reqResExpr
return $ Requirement
{ requirementName = reqId
, requirementExpr = reqExpr'
, requirementDescription = reqDesc
, requirementResultType = reqResType
, requirementResultExpr = reqResExpr'
}
requirements <- mapM requirementDef reqStrings
-- Complete spec
return $ Spec internalVariableDefs externalVariableDefs requirements
-- | Internal representation of an XML Format specification.
data XMLFormatInternal = XMLFormatInternal
{ xfiInternalVars :: Maybe XPathExpr
, xfiInternalVarId :: XPathExpr
, xfiInternalVarExpr :: XPathExpr
, xfiInternalVarType :: Maybe XPathExpr
, xfiExternalVars :: Maybe XPathExpr
, xfiExternalVarId :: XPathExpr
, xfiExternalVarType :: Maybe XPathExpr
, xfiRequirements :: XPathExpr
, xfiRequirementId :: XPathExpr
, xfiRequirementDesc :: Maybe XPathExpr
, xfiRequirementExpr :: [XPathExpr]
, xfiRequirementResultType :: Maybe XPathExpr
, xfiRequirementResultExpr :: Maybe XPathExpr
}
-- | Internal representation of an XPath expression.
type XPathExpr = String
-- | Resolve an indirect XPath query, returning an XPath expression.
resolveIndirectly :: String
-> (String, Maybe (String, String))
-> ExceptT String IO XPathExpr
resolveIndirectly _ (query, Nothing) =
liftEither $ checkXPathExpr query
resolveIndirectly xml (query, Just (key, val)) = do
-- Check that the given query string parses correctly.
_ <- liftEither $ checkXPathExpr val
v <- liftIO $ executeXPath val xml
case v of
(f:_) -> do let query' = replace query key f
liftEither $ checkXPathExpr query'
_ -> throwError $
"Substitution path " ++ show val ++ " not found in file."
-- | Resolve an indirect XPath query, returning a list of XPath expressions.
resolveIndirectly' :: String
-> (String, Maybe (String, String))
-> ExceptT String IO [XPathExpr]
resolveIndirectly' _ (query, Nothing) =
fmap (:[]) $ liftEither $ checkXPathExpr query
resolveIndirectly' xml (query, Just (key, val)) = do
-- Check that the given query string parses correctly.
_ <- liftEither $ checkXPathExpr val
v <- liftIO $ executeXPath val xml
case v of
[] -> throwError $ "Substitution path " ++ show val ++ " not found in file."
fs -> do let queries = map (replace query key) fs
liftEither $ mapM checkXPathExpr queries
-- | Check that an XPath expression is syntactically correct.
checkXPathExpr :: String -> Either String XPathExpr
checkXPathExpr s = s <$ parseXPathExpr s
-- | Check an XMLFormat and return an internal representation.
--
-- Fails with an error message if any of the given expressions are not a valid
-- XPath expression.
parseXMLFormat :: XMLFormat -> String -> ExceptT String IO XMLFormatInternal
parseXMLFormat xmlFormat file = do
xfi2 <- liftEither $ swapMaybeEither
$ checkXPathExpr <$> specInternalVars xmlFormat
xfi3 <- resolveIndirectly file $ specInternalVarId xmlFormat
xfi4 <- resolveIndirectly file $ specInternalVarExpr xmlFormat
xfi5 <- swapMaybeExceptT $
resolveIndirectly file <$> specInternalVarType xmlFormat
xfi6 <- liftEither $
swapMaybeEither $ checkXPathExpr <$> specExternalVars xmlFormat
xfi7 <- resolveIndirectly file $ specExternalVarId xmlFormat
xfi8 <- swapMaybeExceptT $
resolveIndirectly file <$> specExternalVarType xmlFormat
xfi9 <- resolveIndirectly file $ specRequirements xmlFormat
xfi10 <- resolveIndirectly file $ specRequirementId xmlFormat
xfi11 <- swapMaybeExceptT $
resolveIndirectly file <$> specRequirementDesc xmlFormat
xfi12 <- resolveIndirectly' file $ specRequirementExpr xmlFormat
xfi13 <- swapMaybeExceptT $
resolveIndirectly file <$> specRequirementResultType xmlFormat
xfi14 <- swapMaybeExceptT $
resolveIndirectly file <$> specRequirementResultExpr xmlFormat
return $ XMLFormatInternal
{ xfiInternalVars = xfi2
, xfiInternalVarId = xfi3
, xfiInternalVarExpr = xfi4
, xfiInternalVarType = xfi5
, xfiExternalVars = xfi6
, xfiExternalVarId = xfi7
, xfiExternalVarType = xfi8
, xfiRequirements = xfi9
, xfiRequirementId = xfi10
, xfiRequirementDesc = xfi11
, xfiRequirementExpr = xfi12
, xfiRequirementResultType = xfi13
, xfiRequirementResultExpr = xfi14
}
-- | Execute an XPath query in an XML string, returning the list of strings
-- that match the path.
executeXPath :: String -> String -> IO [String]
executeXPath query string = do
let config = [ withValidate no
, withRedirect no
, withCanonicalize no
, withRemoveWS yes
, withSubstDTDEntities no
, withOutputPLAIN
, withSubstHTMLEntities no
]
v <- runX $ configSysVars config
>>> (readString config string >>> getXPathTrees query)
let u = map (flattenDoc . pretty . (:[])) v
return u
-- * Auxiliary
-- | Unescape @'<'@, @'>'@ and @'&'@ in a string.
textUnescape :: String -> String
textUnescape ('&':'l':'t':';':xs) = '<' : textUnescape xs
textUnescape ('&':'g':'t':';':xs) = '>' : textUnescape xs
textUnescape ('&':'a':'m': 'p' : ';':xs) = '&' : textUnescape xs
textUnescape (x:xs) = x : textUnescape xs
textUnescape [] = []
-- | Swap the Maybe and Either layers of a value.
swapMaybeEither :: Maybe (Either a b) -> Either a (Maybe b)
swapMaybeEither Nothing = Right Nothing
swapMaybeEither (Just (Left s)) = Left s
swapMaybeEither (Just (Right x)) = Right $ Just x
-- | Swap the Maybe and Either layers of a value.
swapMaybeExceptT :: Monad m => Maybe (ExceptT a m b) -> ExceptT a m (Maybe b)
swapMaybeExceptT Nothing = return Nothing
swapMaybeExceptT (Just e) = Just <$> e
-- | Convert a list to an Either, failing if the list provided does not have
-- exactly one value.
listToEither :: String -> [String] -> Either String String
listToEither _ [x] = Right x
listToEither msg [] = Left $ "Failed to find a value for " ++ msg
listToEither msg _ = Left $ "Unexpectedly found multiple values for " ++ msg
-- | Replace a string by another string
replace :: String -> String -> String -> String
replace [] _k _v = []
replace string@(h:t) key value
| key `isPrefixOf` string
= value ++ replace (drop (length key) string) key value
| otherwise
= h : replace t key value
-- | Map a monadic action over the elements of a container and concatenate the
-- resulting lists.
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM f = fmap concat . mapM f