{-# LANGUAGE OverloadedStrings #-}

module Hakyll.Convert.Wordpress (readPosts, distill) where

import Control.Monad
import Data.Maybe
import qualified Data.Text as T
import Data.Time.Format (defaultTimeLocale, parseTimeM, rfc822DateFormat)
import Data.XML.Types (Element (..), Name (..), elementChildren, elementText)
import Hakyll.Convert.Common
import Text.RSS.Import
import Text.RSS.Syntax
import qualified Text.XML as XML

-- | Returns only public posts
readPosts :: FilePath -> IO (Maybe [RSSItem])
readPosts :: FilePath -> IO (Maybe [RSSItem])
readPosts FilePath
f = do
  Document
doc <- ParseSettings -> FilePath -> IO Document
XML.readFile (ParseSettings
forall a. Default a => a
XML.def :: XML.ParseSettings) FilePath
f
  let root :: Element
root = Element -> Element
XML.toXMLElement (Element -> Element) -> Element -> Element
forall a b. (a -> b) -> a -> b
$ Document -> Element
XML.documentRoot Document
doc
  Maybe [RSSItem] -> IO (Maybe [RSSItem])
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [RSSItem] -> IO (Maybe [RSSItem]))
-> Maybe [RSSItem] -> IO (Maybe [RSSItem])
forall a b. (a -> b) -> a -> b
$ (RSS -> [RSSItem]) -> Maybe RSS -> Maybe [RSSItem]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap RSS -> [RSSItem]
select (Element -> Maybe RSS
elementToRSS Element
root)
  where
    select :: RSS -> [RSSItem]
select = (RSSItem -> Bool) -> [RSSItem] -> [RSSItem]
forall a. (a -> Bool) -> [a] -> [a]
filter RSSItem -> Bool
isPublished ([RSSItem] -> [RSSItem]) -> (RSS -> [RSSItem]) -> RSS -> [RSSItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RSSChannel -> [RSSItem]
rssItems (RSSChannel -> [RSSItem])
-> (RSS -> RSSChannel) -> RSS -> [RSSItem]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RSS -> RSSChannel
rssChannel

isPublished :: RSSItem -> Bool
isPublished :: RSSItem -> Bool
isPublished RSSItem
i = Text
"publish" Text -> [Text] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` RSSItem -> [Text]
getStatus RSSItem
i

distill :: Bool -> RSSItem -> DistilledPost
distill :: Bool -> RSSItem -> DistilledPost
distill Bool
extractComments RSSItem
item =
  DistilledPost :: Text
-> Text
-> Maybe Text
-> [Text]
-> [Text]
-> UTCTime
-> DistilledPost
DistilledPost
    { dpTitle :: Maybe Text
dpTitle = RSSItem -> Maybe Text
rssItemTitle RSSItem
item,
      dpBody :: Text
dpBody = Text
body,
      dpUri :: Text
dpUri = Text
link,
      dpTags :: [Text]
dpTags = [Text]
tags,
      dpCategories :: [Text]
dpCategories = [Text]
categories,
      dpDate :: UTCTime
dpDate = UTCTime
date
    }
  where
    body :: Text
body =
      if Bool
extractComments
        then
          Text -> [Text] -> Text
T.intercalate
            Text
"\n"
            [ Text
content,
              Text
"",
              Text
"<h3 id='hakyll-convert-comments-title'>Comments</h3>",
              Text
comments
            ]
        else Text
content
    link :: Text
link = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (RSSItem -> Maybe Text
rssItemLink RSSItem
item)
    content :: Text
content = [Text] -> Text
T.unlines ((Element -> Text) -> [Element] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Text
strContent [Element]
contentTags)
    categories :: [Text]
categories = Text -> [Text]
rssCategoriesOfType Text
"category"
    tags :: [Text]
tags = Text -> [Text]
rssCategoriesOfType Text
"post_tag"
    contentTags :: [Element]
contentTags = (Element -> [Element]) -> [Element] -> [Element]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Element -> [Element]
findElements Name
contentTag) (RSSItem -> [Element]
rssItemOther RSSItem
item)
    rssCategoriesOfType :: Text -> [Text]
rssCategoriesOfType Text
ty =
      [ RSSCategory -> Text
rssCategoryValue RSSCategory
c
        | RSSCategory
c <- RSSItem -> [RSSCategory]
rssItemCategories RSSItem
item,
          RSSCategory -> Maybe Text
rssCategoryDomain RSSCategory
c Maybe Text -> Maybe Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text -> Maybe Text
forall a. a -> Maybe a
Just Text
ty
      ]
    contentTag :: Name
contentTag =
      Name :: Text -> Maybe Text -> Maybe Text -> Name
Name
        { nameLocalName :: Text
nameLocalName = Text
"encoded",
          nameNamespace :: Maybe Text
nameNamespace = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"http://purl.org/rss/1.0/modules/content/",
          namePrefix :: Maybe Text
namePrefix = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"content"
        }
    comments :: Text
comments = Text -> [Text] -> Text
T.intercalate Text
"\n" ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ (Element -> Text) -> [Element] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Text
formatComment [Element]
commentTags
    commentTags :: [Element]
commentTags = RSSItem -> [Element]
rssItemOther RSSItem
item [Element] -> (Element -> [Element]) -> [Element]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Element -> [Element]
findElements Name
commentTag
    commentTag :: Name
commentTag = Text -> Name
wordpressTag Text
"comment"
    --
    date :: UTCTime
date = case Text -> Maybe UTCTime
forall (m :: * -> *) a.
(MonadPlus m, MonadFail m, ParseTime a) =>
Text -> m a
parseTime' (Text -> Maybe UTCTime) -> Maybe Text -> Maybe UTCTime
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< RSSItem -> Maybe Text
rssItemPubDate RSSItem
item of
      Maybe UTCTime
Nothing -> Maybe UTCTime -> UTCTime
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe UTCTime -> UTCTime) -> Maybe UTCTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Text -> Maybe UTCTime
forall (m :: * -> *) a.
(MonadPlus m, MonadFail m, ParseTime a) =>
Text -> m a
parseTime' Text
"Thu, 01 Jan 1970 00:00:00 UTC"
      Just UTCTime
d -> UTCTime
d
    parseTime' :: Text -> m a
parseTime' Text
d =
      [m a] -> m a
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([m a] -> m a) -> [m a] -> m a
forall a b. (a -> b) -> a -> b
$
        (FilePath -> m a) -> [FilePath] -> [m a]
forall a b. (a -> b) -> [a] -> [b]
map
          (\FilePath
f -> Bool -> TimeLocale -> FilePath -> FilePath -> m a
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> FilePath -> FilePath -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale FilePath
f (Text -> FilePath
T.unpack Text
d))
          [ FilePath
rfc822DateFormat
          ]

-- ---------------------------------------------------------------------
-- helpers
-- ---------------------------------------------------------------------

formatComment :: Element -> T.Text
formatComment :: Element -> Text
formatComment Element
commentElement =
  Text -> [Text] -> Text
T.intercalate
    Text
"\n"
    [ Text
"<div class='hakyll-convert-comment'>",
      [Text] -> Text
T.concat
        [ Text
"<p class='hakyll-convert-comment-date'>",
          Text
"On ",
          Text
pubdate,
          Text
", ",
          Text
author,
          Text
" wrote:",
          Text
"</p>"
        ],
      Text
"<div class='hakyll-convert-comment-body'>",
      Text
comment,
      Text
"</div>",
      Text
"</div>"
    ]
  where
    pubdate :: Text
pubdate = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"unknown date" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
findField Text
"comment_date"
    author :: Text
author = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"unknown author" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
findField Text
"comment_author"
    comment :: Text
comment = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text
findField Text
"comment_content"
    findField :: Text -> Maybe Text
findField Text
name =
      Element -> Text
strContent (Element -> Text) -> Maybe Element -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Element -> Maybe Element
findChild (Text -> Name
wordpressTag Text
name) Element
commentElement

wordpressTag :: T.Text -> Name
wordpressTag :: Text -> Name
wordpressTag Text
name =
  Name :: Text -> Maybe Text -> Maybe Text -> Name
Name
    { nameLocalName :: Text
nameLocalName = Text
name,
      nameNamespace :: Maybe Text
nameNamespace = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"http://wordpress.org/export/1.2/",
      namePrefix :: Maybe Text
namePrefix = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"wp"
    }

getStatus :: RSSItem -> [T.Text]
getStatus :: RSSItem -> [Text]
getStatus RSSItem
item =
  (Element -> Text) -> [Element] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
map Element -> Text
strContent [Element]
statusTags
  where
    statusTags :: [Element]
statusTags = (Element -> [Element]) -> [Element] -> [Element]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Element -> [Element]
findElements (Text -> Name
wordpressTag Text
"status")) (RSSItem -> [Element]
rssItemOther RSSItem
item)

-- | Find all non-nested elements which are named `name`, starting with `root`.
-- ("Non-nested" means we don't search sub-elements of an element that's named
-- `name`.)
findElements :: Name -> Element -> [Element]
findElements :: Name -> Element -> [Element]
findElements Name
name Element
element =
  if Element -> Name
elementName Element
element Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name
    then [Element
element]
    else (Element -> [Element]) -> [Element] -> [Element]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Element -> [Element]
findElements Name
name) (Element -> [Element]
elementChildren Element
element)

-- | Find first immediate child of `root` which is named `name`.
findChild :: Name -> Element -> Maybe Element
findChild :: Name -> Element -> Maybe Element
findChild Name
name Element
element =
  let subelements :: [Element]
subelements = Element -> [Element]
elementChildren Element
element
      matching :: [Element]
matching = (Element -> Bool) -> [Element] -> [Element]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Element
child -> Element -> Name
elementName Element
child Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
name) [Element]
subelements
   in [Element] -> Maybe Element
forall a. [a] -> Maybe a
listToMaybe [Element]
matching

-- | The contents of the element (ignoring non-text sub-elements).
strContent :: Element -> T.Text
strContent :: Element -> Text
strContent Element
element = [Text] -> Text
T.concat ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Element -> [Text]
elementText Element
element