{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Hakyll.Convert.Blogger (FullPost (..), readPosts, distill) where
import Control.Monad
import qualified Data.Map as M
import Data.Maybe
import qualified Data.Text as T
import Data.Time.Format (defaultTimeLocale, parseTimeM)
import Data.XML.Types (Element (..), Name (..), Node (..), elementChildren)
import Hakyll.Convert.Common
import Text.Atom.Feed
import Text.Atom.Feed.Import
import qualified Text.XML as XML
data FullPost = FullPost
{ FullPost -> Entry
fpPost :: Entry,
:: [Entry],
FullPost -> URI
fpUri :: T.Text
}
deriving (Int -> FullPost -> ShowS
[FullPost] -> ShowS
FullPost -> String
(Int -> FullPost -> ShowS)
-> (FullPost -> String) -> ([FullPost] -> ShowS) -> Show FullPost
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FullPost -> ShowS
showsPrec :: Int -> FullPost -> ShowS
$cshow :: FullPost -> String
show :: FullPost -> String
$cshowList :: [FullPost] -> ShowS
showList :: [FullPost] -> ShowS
Show)
data BloggerEntry
= Post {BloggerEntry -> URI
beUri_ :: T.Text, BloggerEntry -> Entry
beEntry :: Entry}
| {beUri_ :: T.Text, beEntry :: Entry}
| Orphan {beEntry :: Entry}
deriving (Int -> BloggerEntry -> ShowS
[BloggerEntry] -> ShowS
BloggerEntry -> String
(Int -> BloggerEntry -> ShowS)
-> (BloggerEntry -> String)
-> ([BloggerEntry] -> ShowS)
-> Show BloggerEntry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BloggerEntry -> ShowS
showsPrec :: Int -> BloggerEntry -> ShowS
$cshow :: BloggerEntry -> String
show :: BloggerEntry -> String
$cshowList :: [BloggerEntry] -> ShowS
showList :: [BloggerEntry] -> ShowS
Show)
beUri :: BloggerEntry -> Maybe T.Text
beUri :: BloggerEntry -> Maybe URI
beUri (Orphan Entry
_) = Maybe URI
forall a. Maybe a
Nothing
beUri (Post URI
u Entry
_) = URI -> Maybe URI
forall a. a -> Maybe a
Just URI
u
beUri (Comment URI
u Entry
_) = URI -> Maybe URI
forall a. a -> Maybe a
Just URI
u
readPosts :: FilePath -> IO (Maybe [FullPost])
readPosts :: String -> IO (Maybe [FullPost])
readPosts String
f = do
Document
doc <- ParseSettings -> String -> IO Document
XML.readFile (ParseSettings
forall a. Default a => a
XML.def :: XML.ParseSettings) String
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 [FullPost] -> IO (Maybe [FullPost])
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [FullPost] -> IO (Maybe [FullPost]))
-> Maybe [FullPost] -> IO (Maybe [FullPost])
forall a b. (a -> b) -> a -> b
$ (Feed -> [FullPost]) -> Maybe Feed -> Maybe [FullPost]
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Entry] -> [FullPost]
extractPosts ([Entry] -> [FullPost]) -> (Feed -> [Entry]) -> Feed -> [FullPost]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Feed -> [Entry]
feedEntries) (Maybe Feed -> Maybe [FullPost]) -> Maybe Feed -> Maybe [FullPost]
forall a b. (a -> b) -> a -> b
$ Element -> Maybe Feed
elementFeed (Element -> Maybe Feed) -> Element -> Maybe Feed
forall a b. (a -> b) -> a -> b
$ Element -> Element
deleteDrafts Element
root
deleteDrafts :: Element -> Element
deleteDrafts :: Element -> Element
deleteDrafts Element
e =
Element
e {elementNodes = filter isInnocent (elementNodes e)}
where
isInnocent :: Node -> Bool
isInnocent (NodeElement Element
element) = Bool -> Bool
not (Element -> Bool
isDraft Element
element)
isInnocent Node
_ = Bool
True
isDraft :: Element -> Bool
isDraft :: Element -> Bool
isDraft Element
e =
Bool -> Bool
not (Bool -> Bool) -> ([Element] -> Bool) -> [Element] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Element] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Element] -> Bool) -> [Element] -> Bool
forall a b. (a -> b) -> a -> b
$ Name -> Element -> [Element]
findElements Name
draft Element
e
where
draft :: Name
draft =
Name
{ nameLocalName :: URI
nameLocalName = URI
"draft",
nameNamespace :: Maybe URI
nameNamespace = URI -> Maybe URI
forall a. a -> Maybe a
Just URI
"http://purl.org/atom/app#",
namePrefix :: Maybe URI
namePrefix = URI -> Maybe URI
forall a. a -> Maybe a
Just URI
"app"
}
extractPosts :: [Entry] -> [FullPost]
[Entry]
entries =
((URI, [BloggerEntry]) -> FullPost)
-> [(URI, [BloggerEntry])] -> [FullPost]
forall a b. (a -> b) -> [a] -> [b]
map (URI, [BloggerEntry]) -> FullPost
toFullPost [(URI, [BloggerEntry])]
blocks
where
toFullPost :: (URI, [BloggerEntry]) -> FullPost
toFullPost (URI
uri, [BloggerEntry]
blockEntries) =
FullPost
{ fpPost :: Entry
fpPost = Entry
post,
fpComments :: [Entry]
fpComments = [Entry]
comments,
fpUri :: URI
fpUri = URI
uri
}
where
post :: Entry
post = case [Entry
e | Post URI
_ Entry
e <- [BloggerEntry]
blockEntries] of
[] -> String -> Entry
forall {c}. String -> c
huh String
"Block of entries with no post?!"
[Entry
p] -> Entry
p
[Entry]
_ps -> String -> Entry
forall {c}. String -> c
huh String
"Block of entries with more than one post?!"
comments :: [Entry]
comments = [Entry
e | Comment URI
_ Entry
e <- [BloggerEntry]
blockEntries]
huh :: String -> c
huh String
msg = String -> c
forall a. HasCallStack => String -> a
error (String -> c) -> ([String] -> String) -> [String] -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [String] -> String
unlines ([String] -> c) -> [String] -> c
forall a b. (a -> b) -> a -> b
$ String
msg String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (BloggerEntry -> String) -> [BloggerEntry] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (TextContent -> String
txtToString (TextContent -> String)
-> (BloggerEntry -> TextContent) -> BloggerEntry -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> TextContent
entryTitle (Entry -> TextContent)
-> (BloggerEntry -> Entry) -> BloggerEntry -> TextContent
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BloggerEntry -> Entry
beEntry) [BloggerEntry]
blockEntries
blocks :: [(URI, [BloggerEntry])]
blocks = [(URI
u, [BloggerEntry]
xs) | (Just URI
u, [BloggerEntry]
xs) <- [(Maybe URI, [BloggerEntry])]
blocks_]
blocks_ :: [(Maybe URI, [BloggerEntry])]
blocks_ =
(BloggerEntry -> Maybe URI)
-> [BloggerEntry] -> [(Maybe URI, [BloggerEntry])]
forall b a. Ord b => (a -> b) -> [a] -> [(b, [a])]
buckets BloggerEntry -> Maybe URI
beUri ([BloggerEntry] -> [(Maybe URI, [BloggerEntry])])
-> [BloggerEntry] -> [(Maybe URI, [BloggerEntry])]
forall a b. (a -> b) -> a -> b
$
(Entry -> BloggerEntry) -> [Entry] -> [BloggerEntry]
forall a b. (a -> b) -> [a] -> [b]
map Entry -> BloggerEntry
identifyEntry ([Entry] -> [BloggerEntry]) -> [Entry] -> [BloggerEntry]
forall a b. (a -> b) -> a -> b
$
(Entry -> Bool) -> [Entry] -> [Entry]
forall a. (a -> Bool) -> [a] -> [a]
filter Entry -> Bool
isInteresting [Entry]
entries
isInteresting :: Entry -> Bool
isInteresting :: Entry -> Bool
isInteresting Entry
e =
Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Category -> Bool) -> [Category] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Category -> Bool
isBoring [Category]
cats
where
isBoring :: Category -> Bool
isBoring Category
c = (URI -> Bool) -> [URI] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\URI
t -> URI -> Category -> Bool
isBloggerCategoryOfType URI
t Category
c) [URI
"settings", URI
"template"]
cats :: [Category]
cats = Entry -> [Category]
entryCategories Entry
e
identifyEntry :: Entry -> BloggerEntry
identifyEntry :: Entry -> BloggerEntry
identifyEntry Entry
e =
if Entry -> Bool
isPost Entry
e
then case URI -> Maybe Link
getLink URI
"self" Maybe Link -> Maybe Link -> Maybe Link
forall a. Maybe a -> Maybe a -> Maybe a
forall (m :: * -> *) a. MonadPlus m => m a -> m a -> m a
`mplus` URI -> Maybe Link
getLink URI
"alternate" of
Just Link
l -> URI -> Entry -> BloggerEntry
Post (Link -> URI
postUrl Link
l) Entry
e
Maybe Link
Nothing -> Entry -> URI -> BloggerEntry
forall a. Entry -> URI -> a
entryError Entry
e URI
oopsSelf
else case URI -> Maybe Link
getLink URI
"alternate" of
Just Link
l -> URI -> Entry -> BloggerEntry
Comment (Link -> URI
postUrl Link
l) Entry
e
Maybe Link
Nothing -> Entry -> BloggerEntry
Orphan Entry
e
where
isPost :: Entry -> Bool
isPost = (Category -> Bool) -> [Category] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (URI -> Category -> Bool
isBloggerCategoryOfType URI
"post") ([Category] -> Bool) -> (Entry -> [Category]) -> Entry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> [Category]
entryCategories
postUrl :: Link -> URI
postUrl = (Char -> Bool) -> URI -> URI
T.takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'?') (URI -> URI) -> (Link -> URI) -> Link -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> URI
replaceSchema (URI -> URI) -> (Link -> URI) -> Link -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Link -> URI
linkHref
replaceSchema :: URI -> URI
replaceSchema URI
url = URI -> (URI -> URI) -> Maybe URI -> URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe URI
url (URI -> URI -> URI
T.append URI
"https://") (URI -> URI -> Maybe URI
T.stripPrefix URI
"http://" URI
url)
getLink :: URI -> Maybe Link
getLink URI
ty = case (Link -> Bool) -> [Link] -> [Link]
forall a. (a -> Bool) -> [a] -> [a]
filter (URI -> Link -> Bool
isLink URI
ty) ([Link] -> [Link]) -> [Link] -> [Link]
forall a b. (a -> b) -> a -> b
$ Entry -> [Link]
entryLinks Entry
e of
[] -> Maybe Link
forall a. Maybe a
Nothing
[Link
x] -> Link -> Maybe Link
forall a. a -> Maybe a
Just Link
x
[Link]
_xs -> Entry -> URI -> Maybe Link
forall a. Entry -> URI -> a
entryError Entry
e (URI -> URI
oopsLink URI
ty)
isLink :: URI -> Link -> Bool
isLink URI
ty Link
l = Link -> Maybe (Either URI URI)
linkRel Link
l Maybe (Either URI URI) -> Maybe (Either URI URI) -> Bool
forall a. Eq a => a -> a -> Bool
== Either URI URI -> Maybe (Either URI URI)
forall a. a -> Maybe a
Just (URI -> Either URI URI
forall a b. b -> Either a b
Right URI
ty) Bool -> Bool -> Bool
&& Link -> Maybe URI
linkType Link
l Maybe URI -> Maybe URI -> Bool
forall a. Eq a => a -> a -> Bool
== URI -> Maybe URI
forall a. a -> Maybe a
Just URI
"text/html"
oopsSelf :: URI
oopsSelf = URI
"Was expecting blog posts to have a self link"
oopsLink :: URI -> URI
oopsLink = URI -> URI -> URI
T.append URI
"Was expecting entries have at most one link of type "
isBloggerCategory :: Category -> Bool
isBloggerCategory :: Category -> Bool
isBloggerCategory =
(Maybe URI -> Maybe URI -> Bool
forall a. Eq a => a -> a -> Bool
== URI -> Maybe URI
forall a. a -> Maybe a
Just URI
"http://schemas.google.com/g/2005#kind")
(Maybe URI -> Bool) -> (Category -> Maybe URI) -> Category -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Category -> Maybe URI
catScheme
isBloggerCategoryOfType ::
T.Text ->
Category ->
Bool
isBloggerCategoryOfType :: URI -> Category -> Bool
isBloggerCategoryOfType URI
ty Category
c =
Category -> Bool
isBloggerCategory Category
c
Bool -> Bool -> Bool
&& Category -> URI
catTerm Category
c URI -> URI -> Bool
forall a. Eq a => a -> a -> Bool
== URI -> URI -> URI
T.append URI
"http://schemas.google.com/blogger/2008/kind#" URI
ty
distill :: Bool -> FullPost -> DistilledPost
distill :: Bool -> FullPost -> DistilledPost
distill Bool
extractComments FullPost
fp =
DistilledPost
{ dpBody :: URI
dpBody = Entry -> URI
body Entry
fpost,
dpUri :: URI
dpUri = FullPost -> URI
fpUri FullPost
fp,
dpTitle :: Maybe URI
dpTitle = Entry -> Maybe URI
title Entry
fpost,
dpTags :: [URI]
dpTags = Entry -> [URI]
tags Entry
fpost,
dpCategories :: [URI]
dpCategories = [],
dpDate :: UTCTime
dpDate = Entry -> UTCTime
forall {a}. ParseTime a => Entry -> a
date Entry
fpost
}
where
fpost :: Entry
fpost = FullPost -> Entry
fpPost FullPost
fp
fcomments :: [Entry]
fcomments = FullPost -> [Entry]
fpComments FullPost
fp
body :: Entry -> URI
body Entry
post =
let article :: URI
article = Maybe EntryContent -> URI
fromContent (Maybe EntryContent -> URI) -> Maybe EntryContent -> URI
forall a b. (a -> b) -> a -> b
$ Entry -> Maybe EntryContent
entryContent Entry
post
comments :: URI
comments = URI -> [URI] -> URI
T.intercalate URI
"\n" ([URI] -> URI) -> [URI] -> URI
forall a b. (a -> b) -> a -> b
$ (Entry -> URI) -> [Entry] -> [URI]
forall a b. (a -> b) -> [a] -> [b]
map Entry -> URI
formatComment [Entry]
fcomments
in if Bool
extractComments
then
URI -> [URI] -> URI
T.intercalate
URI
"\n"
[ URI
article,
URI
"",
URI
"<h3 id='hakyll-convert-comments-title'>Comments</h3>",
URI
comments
]
else URI
article
fromContent :: Maybe EntryContent -> URI
fromContent (Just (HTMLContent URI
x)) = URI
x
fromContent Maybe EntryContent
_ = String -> URI
forall a. HasCallStack => String -> a
error String
"Hakyll.Convert.Blogger.distill expecting HTML"
formatComment :: Entry -> URI
formatComment Entry
c =
URI -> [URI] -> URI
T.intercalate
URI
"\n"
[ URI
"<div class='hakyll-convert-comment'>",
[URI] -> URI
T.concat
[ URI
"<p class='hakyll-convert-comment-date'>",
URI
"On ",
URI
pubdate,
URI
", ",
URI
author,
URI
" wrote:",
URI
"</p>"
],
URI
"<div class='hakyll-convert-comment-body'>",
URI
comment,
URI
"</div>",
URI
"</div>"
]
where
pubdate :: URI
pubdate = URI -> Maybe URI -> URI
forall a. a -> Maybe a -> a
fromMaybe URI
"unknown date" (Entry -> Maybe URI
entryPublished Entry
c)
author :: URI
author = [URI] -> URI
T.unwords ([URI] -> URI) -> [URI] -> URI
forall a b. (a -> b) -> a -> b
$ (Person -> URI) -> [Person] -> [URI]
forall a b. (a -> b) -> [a] -> [b]
map Person -> URI
personName (Entry -> [Person]
entryAuthors Entry
c)
comment :: URI
comment = Maybe EntryContent -> URI
fromContent (Maybe EntryContent -> URI) -> Maybe EntryContent -> URI
forall a b. (a -> b) -> a -> b
$ Entry -> Maybe EntryContent
entryContent Entry
c
title :: Entry -> Maybe URI
title Entry
p = case TextContent -> String
txtToString (Entry -> TextContent
entryTitle Entry
p) of
String
"" -> Maybe URI
forall a. Maybe a
Nothing
String
t -> URI -> Maybe URI
forall a. a -> Maybe a
Just (String -> URI
T.pack String
t)
tags :: Entry -> [URI]
tags =
(Category -> URI) -> [Category] -> [URI]
forall a b. (a -> b) -> [a] -> [b]
map Category -> URI
catTerm
([Category] -> [URI]) -> (Entry -> [Category]) -> Entry -> [URI]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Category -> Bool) -> [Category] -> [Category]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Category -> Bool) -> Category -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Category -> Bool
isBloggerCategory)
([Category] -> [Category])
-> (Entry -> [Category]) -> Entry -> [Category]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Entry -> [Category]
entryCategories
date :: Entry -> a
date Entry
x = case URI -> Maybe a
forall {m :: * -> *} {a}.
(MonadPlus m, MonadFail m, ParseTime a) =>
URI -> m a
parseTime' (URI -> Maybe a) -> Maybe URI -> Maybe a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Entry -> Maybe URI
entryPublished Entry
x of
Maybe a
Nothing -> Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> Maybe a -> a
forall a b. (a -> b) -> a -> b
$ URI -> Maybe a
forall {m :: * -> *} {a}.
(MonadPlus m, MonadFail m, ParseTime a) =>
URI -> m a
parseTime' URI
"1970-01-01T00:00:00Z"
Just a
d -> a
d
parseTime' :: URI -> m a
parseTime' URI
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
$
(String -> m a) -> [String] -> [m a]
forall a b. (a -> b) -> [a] -> [b]
map
(\String
f -> Bool -> TimeLocale -> String -> String -> m a
forall (m :: * -> *) t.
(MonadFail m, ParseTime t) =>
Bool -> TimeLocale -> String -> String -> m t
parseTimeM Bool
True TimeLocale
defaultTimeLocale String
f (URI -> String
T.unpack URI
d))
[ String
"%FT%T%Q%z",
String
"%FT%T%QZ"
]
entryError :: forall a. Entry -> T.Text -> a
entryError :: forall a. Entry -> URI -> a
entryError Entry
e URI
msg =
String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ (URI -> String
T.unpack URI
msg) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" [on entry " String -> ShowS
forall a. [a] -> [a] -> [a]
++ (URI -> String
T.unpack (Entry -> URI
entryId Entry
e)) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"]\n" String -> ShowS
forall a. [a] -> [a] -> [a]
++ Entry -> String
forall a. Show a => a -> String
show Entry
e
buckets :: (Ord b) => (a -> b) -> [a] -> [(b, [a])]
buckets :: forall b a. Ord b => (a -> b) -> [a] -> [(b, [a])]
buckets a -> b
f = Map b [a] -> [(b, [a])]
forall k a. Map k a -> [(k, a)]
M.toList (Map b [a] -> [(b, [a])])
-> ([a] -> Map b [a]) -> [a] -> [(b, [a])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([a] -> [a] -> [a]) -> [(b, [a])] -> Map b [a]
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
M.fromListWith [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
(++) ([(b, [a])] -> Map b [a])
-> ([a] -> [(b, [a])]) -> [a] -> Map b [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((a -> (b, [a])) -> [a] -> [(b, [a])]
forall a b. (a -> b) -> [a] -> [b]
map (\a
x -> (a -> b
f a
x, [a
x])))
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)