@@ -1,579 +0,0 @@
1−{-# LANGUAGE OverloadedStrings #-}
2−
3−module Xsd.Parser
4−( parse
5−, parseFile
6−, parseLazyByteString
7−, ParseError(..)
8−, Config(..)
9−, defaultConfig
10−)
11−where
12−
13−import qualified Data.ByteString.Lazy as Lazy (ByteString)
14−import Data.Text (Text)
15−import qualified Data.Text as Text
16−import Data.Maybe
17−import qualified Data.Map as Map
18−import Control.Monad
19−import Control.Monad.Trans
20−import Control.Monad.Trans.Reader
21−import Control.Monad.Trans.Except
22−import Text.Read (readEither)
23−import Text.XML
24−import Text.XML.Cursor
25−
26−import Xsd.Types (Xsd(Xsd))
27−import qualified Xsd.Types as Xsd
28−
29−parseSchema :: Cursor -> P Xsd
30−parseSchema c = do
31− let targetNamespace = Xsd.Namespace <$> anAttribute "targetNamespace" c
32−
33− children <- local (\env -> env {envTargetNamespace = targetNamespace}) $
34− parseChildren c
35− return Xsd
36− { Xsd.targetNamespace = targetNamespace
37− , Xsd.children = children
38− }
39−
40−parseChildren :: Cursor -> P [Xsd.Child]
41−parseChildren c =
42− catMaybes <$> mapM parseChild (c $/ anyElement)
43−
44−-- | Parse top level schema node
45−--
46−-- Returns Nothing for unknown/unsupported nodes
47−parseChild :: Cursor -> P (Maybe Xsd.Child)
48−parseChild c = do
49− name <- getElementName c
50− case name of
51− "element" -> Just . Xsd.ChildElement <$> parseElementOrRef c
52− "simpleType" -> Just <$> parseTopSimpleType c
53− "complexType" -> Just <$> parseTopComplexType c
54− "include" -> Just . Xsd.ChildInclude <$> parseInclude c
55− "import" -> Just . Xsd.ChildImport <$> parseImport c
56− _ -> return Nothing
57−
58−parseInclude :: Cursor -> P Xsd.Include
59−parseInclude c = do
60− location <- theAttribute "schemaLocation" c
61− return Xsd.Include
62− { Xsd.includeLocation = location
63− }
64−
65−parseImport :: Cursor -> P Xsd.Import
66−parseImport c = do
67− let
68− location = anAttribute "schemaLocation" c
69− namespace = Xsd.Namespace <$> anAttribute "namespace" c
70−
71− tns <- asks envTargetNamespace
72− case (namespace, tns) of
73− (Nothing, Nothing) -> parseError c "Expected namespace"
74− (Just ns1, Just ns2)
75− | ns1 == ns2
76− -> parseError c "Namespace equals target namespace"
77− _ -> return ()
78−
79− return Xsd.Import
80− { Xsd.importLocation = location
81− , Xsd.importNamespace = namespace
82− }
83−
84−parseElementOrRef :: Cursor -> P (Xsd.RefOr Xsd.Element)
85−parseElementOrRef c = do
86− case anAttribute "ref" c of
87− Nothing -> Xsd.Inline <$> parseElement c
88− Just ref -> Xsd.Ref <$> makeQName c ref
89−
90−parseElement :: Cursor -> P Xsd.Element
91−parseElement c = handleNamespaces c $ do
92− name <- theAttribute "name" c
93−
94− tp <- case anAttribute "type" c of
95− Just t -> Xsd.Ref <$> makeQName c t
96− _ -> maybe (Xsd.Ref anyType) Xsd.Inline <$> parseType c
97−
98− minOccurs <- case anAttribute "minOccurs" c of
99− Nothing -> return 1
100− Just val -> case readEither (Text.unpack val) of
101− Left err -> parseError c ("Can't parse minOccurs: " <> Text.pack err)
102− Right v -> return v
103−
104− maxOccurs <- case anAttribute "maxOccurs" c of
105− Nothing -> return (Xsd.MaxOccurs 1)
106− Just "unbounded" -> return Xsd.MaxOccursUnbound
107− Just val -> case readEither (Text.unpack val) of
108− Left err -> parseError c ("Can't parse maxOccurs" <> Text.pack err)
109− Right v -> return (Xsd.MaxOccurs v)
110−
111− annotations <- parseAnnotations c
112−
113− qname <- makeTargetQName name
114−
115− nillable <- case anAttribute "nillable" c of
116− Nothing -> return False
117− Just "true" -> return True
118− Just "false" -> return False
119− _ -> parseError c "Unexpected value of nillable attribute"
120−
121− return Xsd.Element
122− { Xsd.elementName = qname
123− , Xsd.elementType = tp
124− , Xsd.elementAnnotations = annotations
125− , Xsd.elementOccurs = (minOccurs, maxOccurs)
126− , Xsd.elementNillable = nillable
127− }
128− where
129− anyType = Xsd.QName (Just (Xsd.Namespace Xsd.schemaNamespace)) "anyType"
130−
131−-- | Parse inline type, simple or complex
132−parseType :: Cursor -> P (Maybe Xsd.Type)
133−parseType c = do
134− simpleTypeAxis <- makeElemAxis "simpleType"
135− complexTypeAxis <- makeElemAxis "complexType"
136− case (c $/ simpleTypeAxis, c $/ complexTypeAxis) of
137− ([], []) -> return Nothing
138− ([t], []) -> Just . Xsd.TypeSimple <$> parseSimpleType t
139− ([], [t]) -> Just . Xsd.TypeComplex <$> parseComplexType t
140− _ -> parseError c "Multiple types"
141−
142−-- | Top level simple type
143−parseTopSimpleType :: Cursor -> P Xsd.Child
144−parseTopSimpleType c = do
145− name <- theAttribute "name" c >>= makeTargetQName
146− t <- parseSimpleType c
147− return $ Xsd.ChildType name (Xsd.TypeSimple t)
148−
149−-- | Top level complex type
150−parseTopComplexType :: Cursor -> P Xsd.Child
151−parseTopComplexType c = do
152− name <- theAttribute "name" c >>= makeTargetQName
153− t <- parseComplexType c
154− return $ Xsd.ChildType name (Xsd.TypeComplex t)
155−
156−parseSimpleType :: Cursor -> P Xsd.SimpleType
157−parseSimpleType c = do
158− restrictionAxis <- makeElemAxis "restriction"
159− listAxis <- makeElemAxis "list"
160− unionAxis <- makeElemAxis "union"
161− case (c $/ restrictionAxis, c $/ listAxis, c $/ unionAxis) of
162− ([e], [], []) -> Xsd.AtomicType
163− <$> parseSimpleRestriction e
164− <*> parseAnnotations c
165− ([], [l], []) -> Xsd.ListType
166− <$> parseList l
167− <*> parseAnnotations c
168− ([], [], [u]) -> Xsd.UnionType
169− <$> parseUnion u
170− <*> parseAnnotations c
171− _ -> parseError c "Expected exactly of of restriction, list or union"
172−
173−-- | Restriction for simple type
174−parseSimpleRestriction :: Cursor -> P Xsd.SimpleRestriction
175−parseSimpleRestriction c = do
176− -- XXX: generalaze RefOr parsing
177− tp <- case anAttribute "base" c of
178− Nothing -> do
179− simpleTypeAxis <- makeElemAxis "simpleType"
180− case c $/ simpleTypeAxis of
181− [] -> parseError c "Expected simpleType"
182− [s] -> Xsd.Inline <$> parseSimpleType s
183− _ -> parseError c "Multiple types"
184− Just t -> Xsd.Ref <$> makeQName c t
185−
186− constraints <- parseConstrains c
187−
188− return Xsd.SimpleRestriction
189− { Xsd.simpleRestrictionBase = tp
190− , Xsd.simpleRestrictionConstraints = constraints
191− }
192−
193−parseConstrains :: Cursor -> P [Xsd.Constraint]
194−parseConstrains c = do
195− enumerationAxis <- makeElemAxis "enumeration"
196− forM (c $/ enumerationAxis) $ \e -> do
197− Xsd.Enumeration <$> theAttribute "value" e
198−
199−parseList :: Cursor -> P (Xsd.RefOr Xsd.SimpleType)
200−parseList c =
201− -- XXX: generalaze RefOr parsing
202− case anAttribute "itemType" c of
203− Nothing -> do
204− simpleTypeAxis <- makeElemAxis "simpleType"
205− case c $/ simpleTypeAxis of
206− [] -> parseError c "Expected simpleType"
207− [s] -> Xsd.Inline <$> parseSimpleType s
208− _ -> parseError c "Multiple types"
209− Just t -> Xsd.Ref <$> makeQName c t
210−
211−parseUnion :: Cursor -> P [Xsd.RefOr Xsd.SimpleType]
212−parseUnion c =
213− case anAttribute "memberTypes" c of
214− Just list ->
215− mapM (fmap Xsd.Ref . makeQName c) (Text.splitOn " " list)
216− Nothing -> do
217− simpleTypeAxis <- makeElemAxis "simpleType"
218− mapM (fmap Xsd.Inline . parseSimpleType) (c $/ simpleTypeAxis)
219−
220−parseComplexType :: Cursor -> P Xsd.ComplexType
221−parseComplexType c = do
222− annotations <- parseAnnotations c
223− cont <- parseContent c
224− return Xsd.ComplexType
225− { Xsd.complexAnnotations = annotations
226− , Xsd.complexContent = cont
227− }
228−
229−parseContent :: Cursor -> P Xsd.Content
230−parseContent c = do
231− simpleContentAxis <- makeElemAxis "simpleContent"
232− complexContentAxis <- makeElemAxis "complexContent"
233− case (c $/ simpleContentAxis, c $/ complexContentAxis) of
234− ([], []) -> Xsd.ContentPlain <$> parsePlainContent c
235− ([s], []) -> Xsd.ContentSimple <$> parseSimpleContent s
236− ([], [s]) -> Xsd.ContentComplex <$> parseComplexContent s
237− _ -> parseError c
238− "Expected one of simpleContent, complextContent or model group"
239−
240−parsePlainContent :: Cursor -> P Xsd.PlainContent
241−parsePlainContent c = do
242− attributes <- parseAttributes c
243− model <- parseModelGroup c
244− return Xsd.PlainContent
245− { Xsd.plainContentModel = model
246− , Xsd.plainContentAttributes = attributes
247− }
248−
249−parseSimpleContent :: Cursor -> P Xsd.SimpleContent
250−parseSimpleContent c = do
251− restrictionAxis <- makeElemAxis "restriction"
252− extenstionAxis <- makeElemAxis "extension"
253− case (c $/ restrictionAxis, c $/ extenstionAxis) of
254− ([r], []) -> Xsd.SimpleContentRestriction <$> parseSimpleRestriction r
255− ([], [e]) -> Xsd.SimpleContentExtension <$> parseSimpleExtension e
256− _ -> parseError c "Expected one of restriction or extension"
257−
258−parseSimpleExtension :: Cursor -> P Xsd.SimpleExtension
259−parseSimpleExtension c = handleNamespaces c $ do
260− base <- theAttribute "base" c >>= makeQName c
261− attributes <- parseAttributes c
262− return Xsd.SimpleExtension
263− { Xsd.simpleExtensionBase = base
264− , Xsd.simpleExtensionAttributes = attributes
265− }
266−
267−parseComplexContent :: Cursor -> P Xsd.ComplexContent
268−parseComplexContent c = do
269− restrictionAxis <- makeElemAxis "restriction"
270− extenstionAxis <- makeElemAxis "extension"
271− case (c $/ restrictionAxis, c $/ extenstionAxis) of
272− ([r], []) -> Xsd.ComplexContentRestriction <$> parseComplexRestriction r
273− ([], [e]) -> Xsd.ComplexContentExtension <$> parseComplexExtension e
274− _ -> parseError c "Expected one of restriction or extension"
275−
276−parseComplexExtension :: Cursor -> P Xsd.ComplexExtension
277−parseComplexExtension c = handleNamespaces c $ do
278− base <- theAttribute "base" c >>= makeQName c
279− attributes <- parseAttributes c
280− model <- parseModelGroup c
281− return Xsd.ComplexExtension
282− { Xsd.complexExtensionBase = base
283− , Xsd.complexExtensionModel = model
284− , Xsd.complexExtensionAttributes = attributes
285− }
286−
287−parseComplexRestriction :: Cursor -> P Xsd.ComplexRestriction
288−parseComplexRestriction c = handleNamespaces c $ do
289− base <- theAttribute "base" c >>= makeQName c
290− attributes <- parseAttributes c
291− model <- parseModelGroup c
292− return Xsd.ComplexRestriction
293− { Xsd.complexRestrictionBase = base
294− , Xsd.complexRestrictionModel = model
295− , Xsd.complexRestrictionAttributes = attributes
296− }
297−
298−parseModelGroup :: Cursor -> P (Maybe Xsd.ModelGroup)
299−parseModelGroup c = do
300− sequenceAxis <- makeElemAxis "sequence"
301− choiceAxis <- makeElemAxis "choice"
302− allAxis <- makeElemAxis "all"
303− case (c $/ sequenceAxis, c $/ choiceAxis, c $/ allAxis) of
304− ([], [], []) -> return Nothing
305− ([g], [], []) -> Just <$> parseSequence g
306− ([], [g], []) -> Just <$> parseChoice g
307− ([], [], [g]) -> Just <$> parseAll g
308− _ -> parseError c "Multiple model groups"
309−
310−parseSequence :: Cursor -> P Xsd.ModelGroup
311−parseSequence c = Xsd.Sequence <$> parseElements c
312−
313−parseChoice :: Cursor -> P Xsd.ModelGroup
314−parseChoice c = Xsd.Choice <$> parseElements c
315−
316−parseAll :: Cursor -> P Xsd.ModelGroup
317−parseAll c = Xsd.All <$> parseElements c
318−
319−-- | Get all child elements
320−parseElements :: Cursor -> P [Xsd.RefOr Xsd.Element]
321−parseElements c = do
322− elementAxis <- makeElemAxis "element"
323− mapM parseElementOrRef (c $/ elementAxis)
324−
325−parseAttributes :: Cursor -> P [Xsd.Attribute]
326−parseAttributes c = do
327− attrAxis <- makeElemAxis "attribute"
328− mapM parseAttribute (c $/ attrAxis)
329−
330−parseAttribute :: Cursor -> P Xsd.Attribute
331−parseAttribute c = do
332− use <- parseUseAttribute c
333− case (anAttribute "name" c, anAttribute "ref" c) of
334− (Just n, Nothing) -> do
335− name <- makeTargetQName n
336− tp <- case anAttribute "type" c of
337− Nothing -> do
338− simpleTypeAxis <- makeElemAxis "simpleType"
339− case c $/ simpleTypeAxis of
340− [s] -> Xsd.Inline <$> parseSimpleType s
341− [] -> return (Xsd.Ref anySimpleType)
342− _ -> parseError c "Multiple simple types"
343− Just t -> Xsd.Ref <$> makeQName c t
344− return $ Xsd.InlineAttribute $ Xsd.AttributeInline
345− { Xsd.attributeInlineName = name
346− , Xsd.attributeInlineUse = use
347− , Xsd.attributeInlineType = tp
348− }
349− (Nothing, Just r) -> do
350− ref <- makeQName c r
351− return $ Xsd.RefAttribute $ Xsd.AttributeRef
352− { Xsd.attributeRefRef = ref
353− , Xsd.attributeRefUse = use
354− }
355− _ -> parseError c "Should be either name or ref"
356− where
357− anySimpleType =
358− Xsd.QName (Just (Xsd.Namespace Xsd.schemaNamespace)) "anySimpleType"
359−
360−parseUseAttribute :: Cursor -> P Xsd.Use
361−parseUseAttribute c = case anAttribute "use" c of
362− Nothing -> return Xsd.Optional
363− Just "optional" -> return Xsd.Optional
364− Just "required" -> return Xsd.Required
365− Just "prohibited" -> return Xsd.Prohibited
366− _ -> parseError c "Unknown attribute use"
367−
368−parseAnnotations :: Cursor -> P [Xsd.Annotation]
369−parseAnnotations c = do
370− annotationAxis <- makeElemAxis "annotation"
371− documentationAxis <- makeElemAxis "documentation"
372−
373− let
374− documentation = c
375− $/ annotationAxis
376− &// documentationAxis
377− &/ content
378− return $ Xsd.Documentation <$> documentation
379−
380−-- Section: parser entry points
381−
382−-- | Specifies modes of operation
383−data Config = Config
384− { configIgnoreSchemaNamespace :: Bool
385− -- ^ if not set, parser will check that all relevant xml nodes
386− -- live is the correct XMLSchema namespace
387− }
388− deriving (Show)
389−
390−-- | Default configuration
391−defaultConfig :: Config
392−defaultConfig = Config
393− { configIgnoreSchemaNamespace = False
394− }
395−
396−-- | Parse the whole document
397−--
398−-- Make sure the document is parsed with `psRetainNamespaces` enabled!
399−parse :: Config -> Document -> Either ParseError Xsd
400−parse conf doc = do
401− let
402− env = Env
403− { envConfig = conf
404− , envTargetNamespace = Nothing
405− , envPrefixes = []
406− }
407− c = fromDocument doc
408− runExcept $ flip runReaderT env $ handleNamespaces c $ do
409− schemaAxis <- makeElemAxis "schema"
410− case c $.// schemaAxis of
411− [] -> parseError c "Not schema found"
412− [s] -> parseSchema s
413− _ -> parseError c "Multiple schemata found"
414−
415−-- | Parse file
416−--
417−-- It uses the `defaultConfig`
418−parseFile :: FilePath -> IO (Either ParseError Xsd)
419−parseFile path = parse defaultConfig <$>
420− Text.XML.readFile def{psRetainNamespaces=True} path
421−
422−parseLazyByteString :: Lazy.ByteString -> Either ParseError Xsd
423−parseLazyByteString = parse defaultConfig
424− . parseLBS_ def{psRetainNamespaces=True}
425−
426−-- Section: parser environment
427−
428−-- | Namespace prefix, e.g. \"xs\" or \"tns\"
429−newtype Prefix = Prefix Text
430− deriving (Show, Eq)
431−
432−-- | Parser environment
433−data Env = Env
434− { envConfig :: Config
435− , envTargetNamespace :: Maybe Xsd.Namespace
436− -- ^ targetNamespace for the current schema
437− , envPrefixes :: [(Maybe Prefix, Xsd.Namespace)]
438− -- ^ all xmlns:prefix="namespace" things from the
439− -- schema element
440− }
441− deriving (Show)
442−
443−-- | Parser
444−type P a = ReaderT Env (Except ParseError) a
445−
446−-- Section: error handling
447−
448−-- | Describes what exactly went wrong
449−data ParseError = ParseError
450− { errorLocation :: Text
451− -- ^ e.g. schema.element[Person].attribute[firstName]
452− , errorMessage :: Text
453− }
454− deriving (Show)
455−
456−-- | Builds path to the current curson position
457−--
458−-- Goes through parents and collects their element names,
459−-- optionally adds value of "name" attribute
460−pprCursor :: Cursor -> Text
461−pprCursor = Text.intercalate "." . go []
462− where
463− go ctx c = case node c of
464− NodeElement e ->
465− let
466− ctx' = name : ctx
467− elemName = nameLocalName (elementName e)
468− name = case laxAttribute "name" c of
469− (n:_) -> elemName <> "[" <> n <> "]"
470− _ -> elemName
471− in case parent c of
472− (p:_) -> go ctx' p
473− _ -> ctx'
474− _ -> ctx
475−
476−-- | Fail with the location and message
477−parseError :: Cursor -> Text -> P a
478−parseError c msg = lift $ throwE ParseError
479− { errorLocation = pprCursor c
480− , errorMessage = msg
481− }
482−
483−-- Section: general utilities
484−
485−-- | Get value of an optional attribute
486−anAttribute :: Text -> Cursor -> Maybe Text
487−anAttribute name c = case c $| laxAttribute name of
488− (a:_) -> Just a
489− _ -> Nothing
490−
491−-- | Get value of the required attribute
492−theAttribute :: Text -> Cursor -> P Text
493−theAttribute name c = maybe err return (anAttribute name c)
494− where
495− err = parseError c ("Element should have attibute " <> name)
496−
497−-- | Select nodes with the specified name
498−--
499−-- Depending on the `configIgnoreSchemaNamespace`, it will or will not
500−-- check the namespace to be XMLSchema one
501−makeElemAxis :: Text -> P Axis
502−makeElemAxis name = do
503− ignore <- asks (configIgnoreSchemaNamespace . envConfig)
504− return $ if ignore
505− then laxElement name
506− else element (mkSchemaName name)
507−
508−-- | Parses reference to a type
509−--
510−-- Fails if it has a prefix which is not bound
511−makeQName :: Cursor -> Text -> P Xsd.QName
512−makeQName c t = case Text.splitOn ":" t of
513− [n] -> do
514− ns <- asks (lookup Nothing . envPrefixes)
515− return Xsd.QName
516− { Xsd.qnNamespace = ns
517− , Xsd.qnName = n
518− }
519− [p, n] -> do
520− known <- asks (lookup (Just (Prefix p)) . envPrefixes)
521− case known of
522− Nothing -> parseError c "Unbound prefix"
523− _ -> return ()
524− return Xsd.QName
525− { Xsd.qnNamespace = known
526− , Xsd.qnName = n
527− }
528− _ -> parseError c ("Can't parse name " <> t)
529−
530−makeTargetQName :: Text -> P Xsd.QName
531−makeTargetQName name = do
532− tns <- asks envTargetNamespace
533− return Xsd.QName
534− { Xsd.qnNamespace = tns
535− , Xsd.qnName = name
536− }
537−
538−-- | Get name of the current node
539−--
540−-- Depending on `configIgnoreSchemaNamespace` value, it will or will not
541−-- check the namespace to be XMLSchema one
542−getElementName :: Cursor -> P Text
543−getElementName c = do
544− case node c of
545− NodeElement e -> do
546− let name = elementName e
547− ignore <- asks (configIgnoreSchemaNamespace . envConfig)
548− unless ignore $ do
549− when (nameNamespace name /= Just Xsd.schemaNamespace) $ do
550− parseError c "Expected XMLSchema element"
551− return (nameLocalName name)
552− _ -> parseError c "Expected node element here"
553−
554−-- | Attaches xml schema namespace
555−mkSchemaName :: Text -> Name
556−mkSchemaName name = Name name (Just Xsd.schemaNamespace) Nothing
557−
558−-- | Add additional xmlns bindings into local scope
559−handleNamespaces :: Cursor -> P a -> P a
560−handleNamespaces c m = do
561− ns <- parsePrefixes c
562− local (\env -> env {envPrefixes = ns ++ envPrefixes env}) m
563−
564−-- | Parse namespace bindings
565−--
566−-- Cursor should point to schema node
567−parsePrefixes :: Cursor -> P [(Maybe Prefix, Xsd.Namespace)]
568−parsePrefixes c = case node c of
569− NodeElement e -> return
570− . concatMap toPrefix
571− . Map.toList
572− . elementAttributes
573− $ e
574− _ -> parseError c "Expected an element"
575− where
576− toPrefix (n, v) = case Text.splitOn ":" (nameLocalName n) of
577− ["xmlns"] -> [(Nothing, Xsd.Namespace v)]
578− ["xmlns", prefix] -> [(Just (Prefix prefix), Xsd.Namespace v)]
579− _ -> []