6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederDescription : analyse xml update input
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederCopyright : (c) Christian Maeder, DFKI GmbH 2010
98890889ffb2e8f6f722b00e265a211f13b5a861Corneliu-Claudiu ProdescuLicense : GPLv2 or higher, see LICENSE.txt
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederMaintainer : Christian.Maeder@dfki.de
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederStability : provisional
96e54b22ad432d658ba790f3800ee8ea2657449fChristian MaederPortability : portable
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maedercollect xupdate information
9fec4874a9eea5693f75be0f5d7d62b2e988cd2fChristian Maeder<http://xmldb-org.sourceforge.net/xupdate/xupdate-wd.html>
9fec4874a9eea5693f75be0f5d7d62b2e988cd2fChristian Maeder<http://www.xmldatabases.org/projects/XUpdate-UseCases/>
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder-- | possible insertions
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederdata AddChange
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder = AddElem Element
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | AddAttr Attr
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | AddText String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | AddComment String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | AddPI String String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederinstance Show AddChange where
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder show c = case c of
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddElem e -> showElement e
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddAttr a -> showAttr a
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddText s -> show s
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddComment s -> "<!--" ++ s ++ "-->"
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddPI n s -> "<?" ++ n ++ " " ++ s ++ "?>"
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder ValueOf -> valueOfS
b82427a46050fa32553e722daedf6a364a14f217Christian MaedervalueOfS :: String
b82427a46050fa32553e722daedf6a364a14f217Christian MaedervalueOfS = "value-of"
5ae300e814e007abe45393ede34c0175b79a5c41Simon Ulbrichtdata Insert = Before | After | Append deriving (Eq, Show)
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian MaedershowInsert :: Insert -> String
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian MaedershowInsert i = let s = map toLower $ show i in case i of
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder _ -> "insert-" ++ s
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederdata ChangeSel
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder = Add Insert [AddChange]
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | Update String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | Rename String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder | Variable String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederinstance Show ChangeSel where
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder show c = case c of
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder Add i cs -> showInsert i ++ concatMap (('\n' :) . show) cs
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder Update s -> '=' : s
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder Rename s -> s
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder Variable s -> '$' : s
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederdata Change = Change ChangeSel Expr
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederinstance Show Change where
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder show (Change c p) =
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder show p ++ ":" ++ show c
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederanaXUpdates :: Monad m => String -> m [Change]
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederanaXUpdates input = case parseXMLDoc input of
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder Nothing -> fail "cannot parse xupdate file"
52da167c831dd8d69f3a376c5cfe71a4fe3e488aChristian Maeder Just e -> anaMods e
52da167c831dd8d69f3a376c5cfe71a4fe3e488aChristian MaederanaMods :: Monad m => Element -> m [Change]
52da167c831dd8d69f3a376c5cfe71a4fe3e488aChristian MaederanaMods = mapM anaXUpdate . elChildren
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder{- the input element is expected to be one of
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder xupdate:insert-before
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder xupdate:insert-after
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder xupdate:append
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder xupdate:remove
96e54b22ad432d658ba790f3800ee8ea2657449fChristian Maeder xupdate:update
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederxupdateS :: String
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederxupdateS = "xupdate"
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederupdateS :: String
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederupdateS = "update"
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederelementS :: String
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederelementS = "element"
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederattributeS :: String
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederattributeS = "attribute"
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaedertextS :: String
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaedertextS = "text"
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederappendS :: String
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederappendS = "append"
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederremoveS :: String
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederremoveS = "remove"
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederselectS :: String
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederselectS = "select"
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisXUpdateQN :: QName -> Bool
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederisXUpdateQN = (Just xupdateS ==) . qPrefix
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederhasLocalQN :: String -> QName -> Bool
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederhasLocalQN s = (== s) . qName
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisElementQN :: QName -> Bool
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederisElementQN = hasLocalQN elementS
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisAttributeQN :: QName -> Bool
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederisAttributeQN = hasLocalQN attributeS
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisTextQN :: QName -> Bool
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederisTextQN = hasLocalQN textS
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisAddQN :: QName -> Bool
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederisAddQN q = any (flip isPrefixOf $ qName q) ["insert", appendS]
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederisRemoveQN :: QName -> Bool
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaederisRemoveQN = hasLocalQN removeS
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder-- | extract the non-empty attribute value
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian MaedergetAttrVal :: Monad m => String -> Element -> m String
f318d03bd3eb55a9edfae36ffdc28737b71b4df5Simon UlbrichtgetAttrVal n e = case findAttr (unqual n) e of
f318d03bd3eb55a9edfae36ffdc28737b71b4df5Simon Ulbricht Nothing -> failX ("missing " ++ n ++ " attribute") $ elName e
f318d03bd3eb55a9edfae36ffdc28737b71b4df5Simon Ulbricht Just s -> return s
f9a67b01c18a9a09cb2fcf9d461e35b1afcef809Simon Ulbricht-- | apply a read operation to the extracted value
f9a67b01c18a9a09cb2fcf9d461e35b1afcef809Simon UlbrichtreadAttrVal :: (Read a, Monad m) => String -> String -> Element -> m a
f9a67b01c18a9a09cb2fcf9d461e35b1afcef809Simon UlbrichtreadAttrVal err attr = (>>= maybeF err . readMaybe) . getAttrVal attr
f9a67b01c18a9a09cb2fcf9d461e35b1afcef809Simon UlbrichtmaybeF :: Monad m => String -> Maybe a -> m a
f9a67b01c18a9a09cb2fcf9d461e35b1afcef809Simon UlbrichtmaybeF err = maybe (fail err) return
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian MaedergetSelectAttr :: Monad m => Element -> m String
57dc8a87418e235e3d0621fb90728054044a9ef9Christian MaedergetSelectAttr = getAttrVal selectS
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian MaedergetNameAttr :: Monad m => Element -> m String
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaedergetNameAttr = getAttrVal "name"
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder-- | convert a string to a qualified name by splitting at the colon
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederstr2QName :: String -> QName
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederstr2QName str = let (ft, rt) = break (== ':') str in
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder _ : l@(_ : _) -> (unqual l) { qPrefix = Just ft }
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder _ -> unqual str
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder-- | extract text and check for no other children
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian MaedergetText :: Monad m => Element -> m String
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian MaedergetText e = let s = trim $ strContent e in
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder case elChildren e of
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder [] -> return s
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder c : _ -> failX "unexpected child" $ elName c
143c0193dcb72bf9633b46ff976458fc8a6d3bf8Christian MaedergetXUpdateText :: Monad m => Element -> m String
143c0193dcb72bf9633b46ff976458fc8a6d3bf8Christian MaedergetXUpdateText e = let
143c0193dcb72bf9633b46ff976458fc8a6d3bf8Christian Maeder msg = fail "expected single <xupdate:text> element"
143c0193dcb72bf9633b46ff976458fc8a6d3bf8Christian Maeder in case elChildren e of
143c0193dcb72bf9633b46ff976458fc8a6d3bf8Christian Maeder [] -> getText e
143c0193dcb72bf9633b46ff976458fc8a6d3bf8Christian Maeder in if isXUpdateQN q && u == "text" then getText s else msg
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian MaederanaXUpdate :: Monad m => Element -> m Change
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian MaederanaXUpdate e = let
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder u = qName q in
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder if isXUpdateQN q then do
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder sel <- getSelectAttr e
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder case parseExpr sel of
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder Left _ -> fail $ "unparsable xpath: " ++ sel
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder Right p -> case () of
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder _ | isRemoveQN q -> noContent e $ Change Remove p
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder | hasLocalQN "variable" q -> do
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder vn <- getNameAttr e
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder noContent e $ Change (Variable vn) p
57dc8a87418e235e3d0621fb90728054044a9ef9Christian Maeder _ -> case lookup u [(updateS, Update), ("rename", Rename)] of
143c0193dcb72bf9633b46ff976458fc8a6d3bf8Christian Maeder s <- getXUpdateText e
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder return $ Change (c s) p
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder Nothing -> case lookup u $ map (\ i -> (showInsert i, i))
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder [Before, After, Append] of
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder cs <- mapM addXElem $ elChildren e
3082a2395c92f329060d39db1c96e6853e478454Simon Ulbricht return $ Change (Add i cs) p
fe4d24dddce1322bd8dd24debcca4fec950eb873Christian Maeder Nothing -> failX "no xupdate modification" q
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder else failX "no xupdate qualified element" q
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder-- | partitions additions and ignores comments, pi, and value-of
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederpartitionAddChanges :: [AddChange] -> ([Attr], [Content])
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederpartitionAddChanges = foldr (\ c (as, cs) -> case c of
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddAttr a -> (a : as, cs)
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddElem e -> (as, Elem e : cs)
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder AddText s -> (as, mkText s : cs)
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder _ -> (as, cs)) ([], [])
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederfailX :: Monad m => String -> QName -> m a
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederfailX str q = fail $ str ++ ": " ++ showQName q
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder-- | check if the element contains no other content
258c77f59c231bd3699ebab69bcde7644d3acfc4Christian MaedernoContent :: Monad m => Element -> a -> m a
b82427a46050fa32553e722daedf6a364a14f217Christian MaedernoContent e a = case elContent e of
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder [] -> return a
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder c : _ -> fail $ "unexpected content: " ++ showContent c
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederaddXElem :: Monad m => Element -> m AddChange
6596e6462e9356ac01f15a6dcada971e1f346b63Christian MaederaddXElem e = let q = elName e in
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder if isXUpdateQN q then case () of
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder _ | isTextQN q -> liftM AddText $ getText e
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder | hasLocalQN "comment" q -> liftM AddComment $ getText e
b82427a46050fa32553e722daedf6a364a14f217Christian Maeder | hasLocalQN valueOfS q -> noContent e ValueOf
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder n <- getNameAttr e
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder let qn = str2QName n
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder _ | isAttributeQN q ->
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder liftM (AddAttr . Attr qn) $ getText e
258c77f59c231bd3699ebab69bcde7644d3acfc4Christian Maeder | isElementQN q -> do
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder es <- mapM addXElem $ elChildren e
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder let (as, cs) = partitionAddChanges es
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder return $ AddElem $ add_attrs as $ node qn cs
bc8dfa8d893d6ba015300cba3960c061ff7a8760Christian Maeder | hasLocalQN pIS q -> liftM (AddPI n) $ getText e
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maeder _ -> failX "unknown change" q
c32f906c14b82754e1105a3a382ac81d343f33efChristian Maeder else return $ AddElem e
258c77f59c231bd3699ebab69bcde7644d3acfc4Christian Maederxupdate:element
258c77f59c231bd3699ebab69bcde7644d3acfc4Christian Maederxupdate:attribute
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederxupdate:element may contain xupdate:attribute elements and further
6596e6462e9356ac01f15a6dcada971e1f346b63Christian Maederxupdate:element or xupdate:text elements.
1ba51e89f63278f541a547315926a05f92c676ffChristian MaederemptyCData :: CData -> Bool
1ba51e89f63278f541a547315926a05f92c676ffChristian MaederemptyCData = all isSpace . cdData
4620e43bc9fa96506bd78ed6b3e5318b08de5996Christian MaedervalidContent :: Content -> Bool
4620e43bc9fa96506bd78ed6b3e5318b08de5996Christian MaedervalidContent c = case c of
1ba51e89f63278f541a547315926a05f92c676ffChristian Maeder XML.Text t | emptyCData t -> False
4620e43bc9fa96506bd78ed6b3e5318b08de5996Christian MaedercleanUpElem :: Element -> Element
4620e43bc9fa96506bd78ed6b3e5318b08de5996Christian MaedercleanUpElem e = e
4620e43bc9fa96506bd78ed6b3e5318b08de5996Christian Maeder { elContent = map (\ c -> case c of
4620e43bc9fa96506bd78ed6b3e5318b08de5996Christian Maeder Elem m -> Elem $ cleanUpElem m
4620e43bc9fa96506bd78ed6b3e5318b08de5996Christian Maeder _ -> c) $ filter validContent $ elContent e }