--------------------------------------------------------------------
-- |
-- Module    : Text.Atom.Feed.Import
-- Copyright : (c) Galois, Inc. 2007-2008,
--             (c) Sigbjorn Finne 2009-
-- License   : BSD3
--
-- Maintainer: Sigbjorn Finne <sof@forkIO.com>
-- Stability : provisional
-- Portability:: portable
-- Description: Convert from XML to Atom
--
-- Convert from XML to Atom
--
--------------------------------------------------------------------
module Text.Atom.Feed.Import
  ( pNodes
  , pQNodes
  , pNode
  , pQNode
  , pLeaf
  , pQLeaf
  , pAttr
  , pAttrs
  , pQAttr
  , pMany
  , children
  , elementFeed
  , pTextContent
  , pPerson
  , pCategory
  , pGenerator
  , pSource
  , pLink
  , pEntry
  , pContent
  , pInReplyTotal
  , pInReplyTo
  ) where

import Prelude.Compat

import Control.Monad.Compat (guard, mplus)
import Data.List.Compat (find)
import Data.Maybe (isNothing, listToMaybe, mapMaybe)
import Data.Text (Text)
import Data.Text.Read
import Data.XML.Types as XML

import Text.Atom.Feed
import Text.Atom.Feed.Export (atomName, atomThreadName)

import qualified Data.Text as T

pNodes :: Text -> [XML.Element] -> [XML.Element]
pNodes :: Text -> [Element] -> [Element]
pNodes Text
x = (Element -> Bool) -> [Element] -> [Element]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Text -> Name
atomName Text
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
==) (Name -> Bool) -> (Element -> Name) -> Element -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Name
elementName)

pQNodes :: Name -> [XML.Element] -> [XML.Element]
pQNodes :: Name -> [Element] -> [Element]
pQNodes Name
x = (Element -> Bool) -> [Element] -> [Element]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
==) (Name -> Bool) -> (Element -> Name) -> Element -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Name
elementName)

pNode :: Text -> [XML.Element] -> Maybe XML.Element
pNode :: Text -> [Element] -> Maybe Element
pNode Text
x [Element]
es = [Element] -> Maybe Element
forall a. [a] -> Maybe a
listToMaybe (Text -> [Element] -> [Element]
pNodes Text
x [Element]
es)

pQNode :: Name -> [XML.Element] -> Maybe XML.Element
pQNode :: Name -> [Element] -> Maybe Element
pQNode Name
x [Element]
es = [Element] -> Maybe Element
forall a. [a] -> Maybe a
listToMaybe (Name -> [Element] -> [Element]
pQNodes Name
x [Element]
es)

pLeaf :: Text -> [XML.Element] -> Maybe Text
pLeaf :: Text -> [Element] -> Maybe Text
pLeaf Text
x [Element]
es = ([Text] -> Text
T.concat ([Text] -> Text) -> (Element -> [Text]) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Text]
elementText) (Element -> Text) -> Maybe Element -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Text -> [Element] -> Maybe Element
pNode Text
x [Element]
es

pQLeaf :: Name -> [XML.Element] -> Maybe Text
pQLeaf :: Name -> [Element] -> Maybe Text
pQLeaf Name
x [Element]
es = ([Text] -> Text
T.concat ([Text] -> Text) -> (Element -> [Text]) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Text]
elementText) (Element -> Text) -> Maybe Element -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Name -> [Element] -> Maybe Element
pQNode Name
x [Element]
es

pAttr :: Text -> XML.Element -> Maybe Text
pAttr :: Text -> Element -> Maybe Text
pAttr Text
x Element
e = (Name -> Element -> Maybe Text
`attributeText` Element
e) (Name -> Maybe Text) -> Maybe Name -> Maybe Text
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Name -> Bool) -> [Name] -> Maybe Name
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find (Text -> Name -> Bool
sameAtomAttr Text
x) (((Name, [Content]) -> Name) -> [(Name, [Content])] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [Content]) -> Name
forall a b. (a, b) -> a
fst ([(Name, [Content])] -> [Name]) -> [(Name, [Content])] -> [Name]
forall a b. (a -> b) -> a -> b
$ Element -> [(Name, [Content])]
elementAttributes Element
e)

pAttrs :: Text -> XML.Element -> [Text]
pAttrs :: Text -> Element -> [Text]
pAttrs Text
x Element
e = [Text
t | ContentText Text
t <- [Content]
cnts]
  where
    cnts :: [Content]
cnts = [[Content]] -> [Content]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Content]
v | (Name
k, [Content]
v) <- Element -> [(Name, [Content])]
elementAttributes Element
e, Text -> Name -> Bool
sameAtomAttr Text
x Name
k]

sameAtomAttr :: Text -> Name -> Bool
sameAtomAttr :: Text -> Name -> Bool
sameAtomAttr Text
x Name
k = Name
k Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
ax Bool -> Bool -> Bool
|| (Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Name -> Maybe Text
nameNamespace Name
k) Bool -> Bool -> Bool
&& Name -> Text
nameLocalName Name
k Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
x)
  where
    ax :: Name
ax = Text -> Name
atomName Text
x

pQAttr :: Name -> XML.Element -> Maybe Text
pQAttr :: Name -> Element -> Maybe Text
pQAttr = Name -> Element -> Maybe Text
attributeText

pMany :: Text -> (XML.Element -> Maybe a) -> [XML.Element] -> [a]
pMany :: forall a. Text -> (Element -> Maybe a) -> [Element] -> [a]
pMany Text
p Element -> Maybe a
f [Element]
es = (Element -> Maybe a) -> [Element] -> [a]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Element -> Maybe a
f (Text -> [Element] -> [Element]
pNodes Text
p [Element]
es)

children :: XML.Element -> [XML.Element]
children :: Element -> [Element]
children = Element -> [Element]
elementChildren

elementTexts :: Element -> Text
elementTexts :: Element -> Text
elementTexts = [Text] -> Text
T.concat ([Text] -> Text) -> (Element -> [Text]) -> Element -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> [Text]
elementText

elementFeed :: XML.Element -> Maybe Feed
elementFeed :: Element -> Maybe Feed
elementFeed Element
e = do
  Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Element -> Name
elementName Element
e Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Name
atomName Text
"feed")
  let es :: [Element]
es = Element -> [Element]
children Element
e
  i <- Text -> [Element] -> Maybe Text
pLeaf Text
"id" [Element]
es
  t <- pTextContent "title" es `mplus` return (TextString "<no-title>")
  u <- pLeaf "updated" es
  return
    Feed
      { feedId = i
      , feedTitle = t
      , feedSubtitle = pTextContent "subtitle" es
      , feedUpdated = u
      , feedAuthors = pMany "author" pPerson es
      , feedContributors = pMany "contributor" pPerson es
      , feedCategories = pMany "category" pCategory es
      , feedGenerator = pGenerator `fmap` pNode "generator" es
      , feedIcon = pLeaf "icon" es
      , feedLogo = pLeaf "logo" es
      , feedRights = pTextContent "rights" es
      , feedLinks = pMany "link" pLink es
      , feedEntries = pMany "entry" pEntry es
      , feedOther = other_es es
      , feedAttrs = other_as (elementAttributes e)
      }
  where
    other_es :: [Element] -> [Element]
other_es = (Element -> Bool) -> [Element] -> [Element]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
known_elts) (Name -> Bool) -> (Element -> Name) -> Element -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Element -> Name
elementName)
    other_as :: [(Name, b)] -> [(Name, b)]
other_as = ((Name, b) -> Bool) -> [(Name, b)] -> [(Name, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
forall {a}. [a]
known_attrs) (Name -> Bool) -> ((Name, b) -> Name) -> (Name, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, b) -> Name
forall a b. (a, b) -> a
fst)
    -- let's have them all (including xml:base and xml:lang + xmlns: stuff)
    known_attrs :: [a]
known_attrs = []
    known_elts :: [Name]
known_elts =
      (Text -> Name) -> [Text] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map
        Text -> Name
atomName
        [ Text
"author"
        , Text
"category"
        , Text
"contributor"
        , Text
"generator"
        , Text
"icon"
        , Text
"id"
        , Text
"link"
        , Text
"logo"
        , Text
"rights"
        , Text
"subtitle"
        , Text
"title"
        , Text
"updated"
        , Text
"entry"
        ]

pTextContent :: Text -> [XML.Element] -> Maybe TextContent
pTextContent :: Text -> [Element] -> Maybe TextContent
pTextContent Text
tag [Element]
es = do
  e <- Text -> [Element] -> Maybe Element
pNode Text
tag [Element]
es
  case pAttr "type" e of
    Maybe Text
Nothing -> TextContent -> Maybe TextContent
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> TextContent
TextString (Element -> Text
elementTexts Element
e))
    Just Text
"text" -> TextContent -> Maybe TextContent
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> TextContent
TextString (Element -> Text
elementTexts Element
e))
    Just Text
"html" -> TextContent -> Maybe TextContent
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> TextContent
HTMLString (Element -> Text
elementTexts Element
e))
    Just Text
"xhtml" ->
      case Element -> [Element]
children Element
e -- hmm...
            of
        [Element
c] -> TextContent -> Maybe TextContent
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> TextContent
XHTMLString Element
c)
        [Element]
_ -> Maybe TextContent
forall a. Maybe a
Nothing -- Multiple XHTML children.
    Maybe Text
_ -> Maybe TextContent
forall a. Maybe a
Nothing -- Unknown text content type.

pPerson :: XML.Element -> Maybe Person
pPerson :: Element -> Maybe Person
pPerson Element
e = do
  let es :: [Element]
es = Element -> [Element]
children Element
e
  name <- Text -> [Element] -> Maybe Text
pLeaf Text
"name" [Element]
es -- or missing "name"
  return
    Person
      { personName = name
      , personURI = pLeaf "uri" es
      , personEmail = pLeaf "email" es
      , personOther = [] -- XXX?
      }

pCategory :: XML.Element -> Maybe Category
pCategory :: Element -> Maybe Category
pCategory Element
e = do
  term <- Text -> Element -> Maybe Text
pAttr Text
"term" Element
e -- or missing "term" attribute
  return
    Category
      { catTerm = term
      , catScheme = pAttr "scheme" e
      , catLabel = pAttr "label" e
      , catOther = [] -- XXX?
      }

pGenerator :: XML.Element -> Generator
pGenerator :: Element -> Generator
pGenerator Element
e =
  Generator {genURI :: Maybe Text
genURI = Text -> Element -> Maybe Text
pAttr Text
"href" Element
e, genVersion :: Maybe Text
genVersion = Text -> Element -> Maybe Text
pAttr Text
"version" Element
e, genText :: Text
genText = Element -> Text
elementTexts Element
e}

pSource :: XML.Element -> Source
pSource :: Element -> Source
pSource Element
e =
  let es :: [Element]
es = Element -> [Element]
children Element
e
   in Source
        { sourceAuthors :: [Person]
sourceAuthors = Text -> (Element -> Maybe Person) -> [Element] -> [Person]
forall a. Text -> (Element -> Maybe a) -> [Element] -> [a]
pMany Text
"author" Element -> Maybe Person
pPerson [Element]
es
        , sourceCategories :: [Category]
sourceCategories = Text -> (Element -> Maybe Category) -> [Element] -> [Category]
forall a. Text -> (Element -> Maybe a) -> [Element] -> [a]
pMany Text
"category" Element -> Maybe Category
pCategory [Element]
es
        , sourceGenerator :: Maybe Generator
sourceGenerator = Element -> Generator
pGenerator (Element -> Generator) -> Maybe Element -> Maybe Generator
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Text -> [Element] -> Maybe Element
pNode Text
"generator" [Element]
es
        , sourceIcon :: Maybe Text
sourceIcon = Text -> [Element] -> Maybe Text
pLeaf Text
"icon" [Element]
es
        , sourceId :: Maybe Text
sourceId = Text -> [Element] -> Maybe Text
pLeaf Text
"id" [Element]
es
        , sourceLinks :: [Link]
sourceLinks = Text -> (Element -> Maybe Link) -> [Element] -> [Link]
forall a. Text -> (Element -> Maybe a) -> [Element] -> [a]
pMany Text
"link" Element -> Maybe Link
pLink [Element]
es
        , sourceLogo :: Maybe Text
sourceLogo = Text -> [Element] -> Maybe Text
pLeaf Text
"logo" [Element]
es
        , sourceRights :: Maybe TextContent
sourceRights = Text -> [Element] -> Maybe TextContent
pTextContent Text
"rights" [Element]
es
        , sourceSubtitle :: Maybe TextContent
sourceSubtitle = Text -> [Element] -> Maybe TextContent
pTextContent Text
"subtitle" [Element]
es
        , sourceTitle :: Maybe TextContent
sourceTitle = Text -> [Element] -> Maybe TextContent
pTextContent Text
"title" [Element]
es
        , sourceUpdated :: Maybe Text
sourceUpdated = Text -> [Element] -> Maybe Text
pLeaf Text
"updated" [Element]
es
        , sourceOther :: [Element]
sourceOther = [] -- XXX ?
        }

pLink :: XML.Element -> Maybe Link
pLink :: Element -> Maybe Link
pLink Element
e = do
  uri <- Text -> Element -> Maybe Text
pAttr Text
"href" Element
e
  return
    Link
      { linkHref = uri
      , linkRel = Right `fmap` pAttr "rel" e
      , linkType = pAttr "type" e
      , linkHrefLang = pAttr "hreflang" e
      , linkTitle = pAttr "title" e
      , linkLength = pAttr "length" e
      , linkAttrs = other_as (elementAttributes e)
      , linkOther = []
      }
  where
    other_as :: [(Name, b)] -> [(Name, b)]
other_as = ((Name, b) -> Bool) -> [(Name, b)] -> [(Name, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
known_attrs) (Name -> Bool) -> ((Name, b) -> Name) -> (Name, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, b) -> Name
forall a b. (a, b) -> a
fst)
    known_attrs :: [Name]
known_attrs = (Text -> Name) -> [Text] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Text -> Name
atomName [Text
"href", Text
"rel", Text
"type", Text
"hreflang", Text
"title", Text
"length"]

pEntry :: XML.Element -> Maybe Entry
pEntry :: Element -> Maybe Entry
pEntry Element
e = do
  let es :: [Element]
es = Element -> [Element]
children Element
e
  i <- Text -> [Element] -> Maybe Text
pLeaf Text
"id" [Element]
es
  t <- pTextContent "title" es
  u <- pLeaf "updated" es `mplus` pLeaf "published" es
  return
    Entry
      { entryId = i
      , entryTitle = t
      , entryUpdated = u
      , entryAuthors = pMany "author" pPerson es
      , entryContributor = pMany "contributor" pPerson es
      , entryCategories = pMany "category" pCategory es
      , entryContent = pContent =<< pNode "content" es
      , entryLinks = pMany "link" pLink es
      , entryPublished = pLeaf "published" es
      , entryRights = pTextContent "rights" es
      , entrySource = pSource `fmap` pNode "source" es
      , entrySummary = pTextContent "summary" es
      , entryInReplyTo = pInReplyTo es
      , entryInReplyTotal = pInReplyTotal es
      , entryAttrs = other_as (elementAttributes e)
      , entryOther = [] -- ?
      }
  where
    other_as :: [(Name, b)] -> [(Name, b)]
other_as = ((Name, b) -> Bool) -> [(Name, b)] -> [(Name, b)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
forall {a}. [a]
known_attrs) (Name -> Bool) -> ((Name, b) -> Name) -> (Name, b) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, b) -> Name
forall a b. (a, b) -> a
fst)
    -- let's have them all (including xml:base and xml:lang + xmlns: stuff)
    known_attrs :: [a]
known_attrs = []

pContent :: XML.Element -> Maybe EntryContent
pContent :: Element -> Maybe EntryContent
pContent Element
e =
  case Text -> Element -> Maybe Text
pAttr Text
"type" Element
e of
    Maybe Text
Nothing -> EntryContent -> Maybe EntryContent
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> EntryContent
TextContent (Element -> Text
elementTexts Element
e))
    Just Text
"text" -> EntryContent -> Maybe EntryContent
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> EntryContent
TextContent (Element -> Text
elementTexts Element
e))
    Just Text
"html" -> EntryContent -> Maybe EntryContent
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> EntryContent
HTMLContent (Element -> Text
elementTexts Element
e))
    Just Text
"xhtml" ->
      case Element -> [Element]
children Element
e of
        [] -> EntryContent -> Maybe EntryContent
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> EntryContent
TextContent Text
"")
        [Element
c] -> EntryContent -> Maybe EntryContent
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Element -> EntryContent
XHTMLContent Element
c)
        [Element]
_ -> Maybe EntryContent
forall a. Maybe a
Nothing
    Just Text
ty ->
      case Text -> Element -> Maybe Text
pAttr Text
"src" Element
e of
        Maybe Text
Nothing -> EntryContent -> Maybe EntryContent
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> [Node] -> EntryContent
MixedContent (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ty) (Element -> [Node]
elementNodes Element
e))
        Just Text
uri -> EntryContent -> Maybe EntryContent
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Text -> Text -> EntryContent
ExternalContent (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ty) Text
uri)

pInReplyTotal :: [XML.Element] -> Maybe InReplyTotal
pInReplyTotal :: [Element] -> Maybe InReplyTotal
pInReplyTotal [Element]
es = do
  t <- Name -> [Element] -> Maybe Text
pQLeaf (Text -> Name
atomThreadName Text
"total") [Element]
es
  case decimal t of
    Right (Integer
x, Text
_) -> do
      n <- Name -> [Element] -> Maybe Element
pQNode (Text -> Name
atomThreadName Text
"total") [Element]
es
      return InReplyTotal {replyToTotal = x, replyToTotalOther = elementAttributes n}
    Either String (Integer, Text)
_ -> String -> Maybe InReplyTotal
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no parse"

pInReplyTo :: [XML.Element] -> Maybe InReplyTo
pInReplyTo :: [Element] -> Maybe InReplyTo
pInReplyTo [Element]
es = do
  t <- Name -> [Element] -> Maybe Element
pQNode (Text -> Name
atomThreadName Text
"reply-to") [Element]
es
  case pQAttr (atomThreadName "ref") t of
    Just Text
ref ->
      InReplyTo -> Maybe InReplyTo
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return
        InReplyTo
          { replyToRef :: Text
replyToRef = Text
ref
          , replyToHRef :: Maybe Text
replyToHRef = Name -> Element -> Maybe Text
pQAttr (Text -> Name
atomThreadName Text
"href") Element
t
          , replyToType :: Maybe Text
replyToType = Name -> Element -> Maybe Text
pQAttr (Text -> Name
atomThreadName Text
"type") Element
t
          , replyToSource :: Maybe Text
replyToSource = Name -> Element -> Maybe Text
pQAttr (Text -> Name
atomThreadName Text
"source") Element
t
          , replyToOther :: [(Name, [Content])]
replyToOther = Element -> [(Name, [Content])]
elementAttributes Element
t -- ToDo: snip out matched ones.
          , replyToContent :: [Node]
replyToContent = Element -> [Node]
elementNodes Element
t
          }
    Maybe Text
_ -> String -> Maybe InReplyTo
forall a. String -> Maybe a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no parse"