diff --git a/Hakyll/Convert/Blogger.hs b/Hakyll/Convert/Blogger.hs new file mode 100644 --- /dev/null +++ b/Hakyll/Convert/Blogger.hs @@ -0,0 +1,206 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +module Hakyll.Convert.Blogger + (FullPost(..), readPosts, distill) + where + +import Control.Applicative +import Control.Arrow +import Control.Monad +import Data.Binary +import qualified Data.ByteString as B +import Data.Char +import Data.Data +import Data.Function +import Data.List +import Data.List +import Data.Maybe +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time (UTCTime) +import Data.Time.Format (parseTime, formatTime) +import System.Locale (defaultTimeLocale) + +import Hakyll.Core.Compiler +import Hakyll.Core.Item +import Hakyll.Web.Template.Context +import Text.Atom.Feed +import Text.Atom.Feed.Export +import Text.Atom.Feed.Import +import Text.XML.Light + +import Hakyll.Convert.Common + +-- | A post and its comments +data FullPost = FullPost + { fpPost :: Entry + , fpComments :: [Entry] + , fpUri :: String + } + +-- | An entry is assumed to be either a post, or a comment. +-- If it's a post, it should be associated with the URI +-- that visitors would use to read the post (on the old blog) +-- If it's a comment, it should be the URI for the corresponding +-- post. +data BloggerEntry = + Post { beUri_ :: String, beEntry :: Entry } + | Comment { beUri_ :: String, beEntry :: Entry } + | Orphan { beEntry :: Entry } + deriving (Show) + +beUri :: BloggerEntry -> Maybe String +beUri (Orphan _) = Nothing +beUri (Post u _) = Just u +beUri (Comment u _) = Just u + +-- --------------------------------------------------------------------- +-- Feed to helper type +-- --------------------------------------------------------------------- + +-- | Returns only published posts +readPosts :: FilePath -> IO (Maybe [FullPost]) +readPosts f = do + parseAtomDoc <$> B.readFile f + where + parseAtomDoc x = + select =<< parseXMLDoc (T.decodeUtf8 x) + select = + fmap (extractPosts . feedEntries) . elementFeed . deleteDrafts + +-- has to be done on the XML level as our atom lib doesn't understand +-- the blogger-specific XML for drafts +deleteDrafts :: Element -> Element +deleteDrafts e = + e { elContent = filter isInnocent (elContent e) } + where + isInnocent (Elem e) = not (isDraft e) + isInnocent _ = True + +isDraft :: Element -> Bool +isDraft e = + isJust $ findElement draft e + where + draft = QName + { qName = "draft" + , qURI = Just "http://purl.org/atom/app#" + , qPrefix = Just "app" + } + + + +-- | Warning: this silently ignores orphans, templates, settings +extractPosts :: [Entry] -> [FullPost] +extractPosts entries = + map toFullPost blocks + where + toFullPost (uri, entries) = FullPost + { fpPost = post + , fpComments = comments + , fpUri = uri + } + where + post = case [ e | Post _ e <- entries ] of + [] -> huh "Block of entries with no post?!" + [p] -> p + ps -> huh "Block of entries with more than one post?!" + comments = [ e | Comment _ e <- entries ] + huh msg = error . unlines $ msg : map (txtToString . entryTitle . beEntry) entries + blocks = [ (u,xs) | (Just u, xs) <- blocks_ ] -- drop orphans + blocks_ = buckets beUri + $ map identifyEntry + $ filter isInteresting entries + +-- | Contains actual meat (posts, comments; but not eg. templates) +isInteresting :: Entry -> Bool +isInteresting e = + not $ any isBoring cats + where + isBoring c = any (\t -> isBloggerCategoryOfType t c) ["settings", "template"] + cats = entryCategories e + + +-- | Tag an entry from the blogger feed as either being a post, +-- a comment, or an "orphan" (a comment without an associated post) +identifyEntry :: Entry -> BloggerEntry +identifyEntry e = + if isPost e + then case getLink "self" `mplus` getLink "alternate" of + Just l -> Post (postUrl l) e + Nothing -> entryError e oopsSelf + else case getLink "alternate" of + Just l -> Comment (postUrl l) e + Nothing -> Orphan e + where + isPost = any (isBloggerCategoryOfType "post") . entryCategories + postUrl = takeWhile (/= '?') . linkHref + getLink ty = case filter (isLink ty) $ entryLinks e of + [] -> Nothing + [x] -> Just x + xs -> entryError e (oopsLink ty) + isLink ty l = linkRel l == Just (Right ty) && linkType l == Just "text/html" + oopsSelf = "Was expecting blog posts to have a self link" + oopsLink ty = "Was expecting entries have at most one link of type " ++ ty + +isBloggerCategory :: Category -> Bool +isBloggerCategory = (== Just "http://schemas.google.com/g/2005#kind") + . catScheme + +isBloggerCategoryOfType :: String -- ^ \"comment\", \"post\", etc + -> Category + -> Bool +isBloggerCategoryOfType ty c = + isBloggerCategory c && + catTerm c == "http://schemas.google.com/blogger/2008/kind#" ++ ty + +-- --------------------------------------------------------------------- +-- +-- --------------------------------------------------------------------- + +distill :: FullPost -> DistilledPost +distill fp = DistilledPost + { dpBody = body fpost + , dpUri = fpUri fp + , dpTitle = title fpost + , dpTags = tags fpost + , dpCategories = [] + , dpDate = date fpost + } + where + fpost = fpPost fp + -- + body = fromContent . entryContent + fromContent (Just (HTMLContent x)) = T.pack x + fromContent _ = error "Hakyll.Convert.Blogger.distill expecting HTML" + -- + title p = case txtToString (entryTitle p) of + "" -> Nothing + t -> Just (T.pack t) + tags = map (T.pack . catTerm) + . filter (not . isBloggerCategory) + . entryCategories + date x = T.pack $ + case parseTime' =<< entryPublished x of + Nothing -> "1970-01-01" + Just d -> formatTime' d + parseTime' d = msum $ map (\f -> parseTime defaultTimeLocale f d) + [ "%FT%T%Q%z" -- with time zone + , "%FT%T%QZ" -- zulu time + ] + formatTime' :: UTCTime -> String + formatTime' = formatTime defaultTimeLocale "%FT%TZ" --for hakyll + +-- --------------------------------------------------------------------- +-- odds and ends +-- --------------------------------------------------------------------- + +entryError e msg = + error $ msg ++ " [on entry " ++ entryId e ++ "]\n" ++ show e + +buckets :: Ord b => (a -> b) -> [a] -> [ (b,[a]) ] +buckets f = map (first head . unzip) + . groupBy ((==) `on` fst) + . sortBy (compare `on` fst) + . map (\x -> (f x, x)) diff --git a/Hakyll/Convert/Common.hs b/Hakyll/Convert/Common.hs new file mode 100644 --- /dev/null +++ b/Hakyll/Convert/Common.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} + +module Hakyll.Convert.Common where + +import Data.Data +import Data.Text (Text) +import qualified Data.Text as T + +data DistilledPost = DistilledPost + { dpUri :: String + , dpBody :: Text + , dpTitle :: Maybe Text + , dpTags :: [Text] + -- | Categories are coarser-grained than tags; you might be + -- interested in ignoring tags and just focusing on categories + -- in cases where you have lots of little uninteresting tags. + , dpCategories :: [Text] + , dpDate :: Text + } + deriving (Show, Data, Typeable) diff --git a/Hakyll/Convert/Wordpress.hs b/Hakyll/Convert/Wordpress.hs new file mode 100644 --- /dev/null +++ b/Hakyll/Convert/Wordpress.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE OverloadedStrings #-} +module Hakyll.Convert.Wordpress + (readPosts, distill) + where + +import Control.Applicative +import Control.Monad +import qualified Data.ByteString as B +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time (UTCTime) +import Data.Time.Format (parseTime, formatTime) +import System.Locale (defaultTimeLocale, rfc822DateFormat) +import Text.XML.Light +import Text.RSS.Import +import Text.RSS.Syntax + +import Hakyll.Convert.Common + +-- | Returns only public posts +readPosts :: FilePath -> IO (Maybe [RSSItem]) +readPosts f = do + fmap select . parseRssDoc <$> B.readFile f + where + parseRssDoc x = elementToRSS =<< parseXMLDoc (T.decodeUtf8 x) + select = filter isPublished . rssItems . rssChannel + +isPublished :: RSSItem -> Bool +isPublished i = "publish" `elem` getStatus i + +distill :: RSSItem -> DistilledPost +distill item = DistilledPost + { dpTitle = T.pack <$> rssItemTitle item + , dpBody = content + , dpUri = link + , dpTags = tags + , dpCategories = categories + , dpDate = date + } + where + link = fromMaybe "" (rssItemLink item) + content = T.pack + $ unlines (map strContent contentTags) + categories = rssCategoriesOfType "category" + tags = rssCategoriesOfType "post_tag" + contentTags = concatMap (findElements contentTag) + (rssItemOther item) + rssCategoriesOfType ty = + [ T.pack (rssCategoryValue c) + | c <- rssItemCategories item + , rssCategoryDomain c == Just ty ] + contentTag = QName + { qName = "encoded" + , qURI = Just "http://purl.org/rss/1.0/modules/content/" + , qPrefix = Just "content" + } + -- + date = case parseTime' =<< rssItemPubDate item of + Nothing -> "1970-01-01" + Just d -> T.pack (formatTime' d) + parseTime' d = msum $ map (\f -> parseTime defaultTimeLocale f d) + [ rfc822DateFormat + ] + formatTime' :: UTCTime -> String + formatTime' = formatTime defaultTimeLocale "%FT%TZ" --for hakyll + +-- --------------------------------------------------------------------- +-- helpers +-- --------------------------------------------------------------------- + +getStatus :: RSSItem -> [String] +getStatus item = + map strContent statusTags + where + statusTags = concatMap (findElements (wpName "status")) + (rssItemOther item) + wpName n = QName + { qName = n + , qURI = Just "http://wordpress.org/export/1.2/" + , qPrefix = Just "wp" + } diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Eric Kow + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Eric Kow nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hakyll-convert.cabal b/hakyll-convert.cabal new file mode 100644 --- /dev/null +++ b/hakyll-convert.cabal @@ -0,0 +1,53 @@ +-- Initial hakyll-convert.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: hakyll-convert +version: 0.1.0.0 +synopsis: Convert from other blog engines to Hakyll. +-- description: +homepage: http://github.com/kowey/hakyll-convert +license: BSD3 +license-file: LICENSE +author: Eric Kow +maintainer: Eric Kow +-- copyright: +category: Web +build-type: Simple +cabal-version: >=1.8 + +library + exposed-modules: Hakyll.Convert.Blogger + , Hakyll.Convert.Common + , Hakyll.Convert.Wordpress + build-depends: base + , binary + , bytestring + , feed + , hakyll + , old-locale + , text + , time + , xml + +executable hakyll-convert + main-is: hakyll-convert.hs + hs-source-dirs: tools + -- other-modules: + build-depends: base < 5 + , bytestring + , cmdargs + , directory + , feed + , filepath + , hakyll-convert + , text + , xml + +executable hakyll-convert-demo + main-is: hakyll-convert-demo.hs + hs-source-dirs: tools + -- other-modules: + build-depends: base + , hakyll + , hakyll-convert + , filepath diff --git a/tools/hakyll-convert-demo.hs b/tools/hakyll-convert-demo.hs new file mode 100644 --- /dev/null +++ b/tools/hakyll-convert-demo.hs @@ -0,0 +1,151 @@ +-------------------------------------------------------------------------------- +{-# LANGUAGE OverloadedStrings #-} +import Control.Applicative ((<$>)) +import Data.Monoid ((<>),mappend,mconcat) +import Hakyll + +import Hakyll.Convert.Blogger +import Debug.Trace + +-------------------------------------------------------------------------------- +main :: IO () +main = hakyll $ do + match "images/*" $ do + route idRoute + compile copyFileCompiler + + match "css/*" $ do + route idRoute + compile compressCssCompiler + + match (fromList ["about.markdown"]) $ do + route $ setExtension "html" + compile $ pandocCompiler + >>= loadAndApplyTemplate "templates/default.html" defaultContext + >>= relativizeUrls + + -- distilled <- match koweycodePattern $ compile bloggerCompiler + + -- tags0 <- buildTags "posts/*" (fromCapture "tags/*.html") + tags <- buildTags koweycodePattern (fromCapture "tags/*.html") + +{- + match "posts/*" $ do + route $ setExtension "html" + compile $ pandocCompiler + >>= loadAndApplyTemplate "templates/post.html" (postCtx tags) + >>= loadAndApplyTemplate "templates/default.html" (postCtx tags) + >>= relativizeUrls +-} + + match koweycodePattern $ do + route $ setExtension "html" + compile $ pandocCompiler -- TODO shouldn't be needed + >>= loadAndApplyTemplate "templates/post.html" (postCtx tags) + >>= loadAndApplyTemplate "templates/default.html" (postCtx tags) + >>= relativizeUrls + + -- Post tags + tagsRules tags $ \tag pattern -> do + let title = "Posts tagged " ++ tag + archiveCtx = archiveContext "Posts tagged" tags pattern + + -- Copied from posts, need to refactor + route idRoute + compile $ do + list <- postList tags pattern recentFirst + makeItem "" + >>= loadAndApplyTemplate "templates/archive.html" archiveCtx + >>= loadAndApplyTemplate "templates/default.html" defaultContext + >>= relativizeUrls + +{- + -- Create RSS feed as well + version "rss" $ do + route $ setExtension "xml" + compile $ loadAllSnapshots pattern "content" + >>= fmap (take 10) . recentFirst + >>= renderAtom (feedConfiguration title) feedCtx +-} + + let plainPattern = "posts/*" + + create ["archive.html"] $ do + route idRoute + compile $ do + let archiveCtx = archiveContext "Archives" tags koweycodePattern + makeItem "" + >>= loadAndApplyTemplate "templates/archive.html" archiveCtx + >>= loadAndApplyTemplate "templates/default.html" archiveCtx + >>= relativizeUrls + + match "index.html" $ do + route idRoute + compile $ do + let indexCtx = field "posts" $ \_ -> postList tags koweycodePattern (fmap (take 3) . recentFirst) + + getResourceBody + >>= applyAsTemplate indexCtx + >>= loadAndApplyTemplate "templates/default.html" (postCtx tags) + >>= relativizeUrls + + match "templates/*" $ compile templateCompiler + where + koweycodePattern = "koweycode/**" + +archiveContext title tags pattern = + field "posts" (const getList) `mappend` + constField "title" title `mappend` + defaultContext + where + getList = postList tags pattern recentFirst + + +-------------------------------------------------------------------------------- +{- +postCtx :: Context String +postCtx = + dateField "date" "%e %B %Y" `mappend` + defaultContext +-} + +postCtx :: Tags -> Context String +postCtx tags = mconcat + [ modificationTimeField "mtime" "%U" + , dateField "date" "%e %B %Y" + , tagsField "tags" tags + , defaultContext + ] + +-------------------------------------------------------------------------------- + +postList :: Tags -> Pattern -> ([Item String] -> Compiler [Item String]) + -> Compiler String +postList tags pattern sortFilter = do + posts <- sortFilter =<< loadAll pattern + itemTpl <- loadBody "templates/post-item.html" + applyTemplateList itemTpl (postCtx tags) posts + +{- + +postList :: ([Item String] -> [Item String]) -> Compiler String +postList sortFilter = do + posts1_ <- loadAll "posts/*" + --posts2_ <- loadAll "koweycode/*/*/*" + let posts1 = posts1_ + posts2 = [] + let posts = sortFilter (posts1 ++ posts2) + itemTpl <- loadBody "templates/post-item.html" + list <- applyTemplateList itemTpl postCtx posts + return list + +-} + +{- +oldPostList :: ([Item String] -> [Item String]) -> Compiler String +oldPostList sortFilter = do + posts <- sortFilter <$> loadAll "koweycode/*/*/*" + itemTpl <- loadBody "templates/post-item.html" + list <- applyTemplateList itemTpl postCtx posts + return list +-} diff --git a/tools/hakyll-convert.hs b/tools/hakyll-convert.hs new file mode 100644 --- /dev/null +++ b/tools/hakyll-convert.hs @@ -0,0 +1,156 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +import Control.Applicative +import Control.Arrow +import Control.Monad +import qualified Data.ByteString as B +import Data.Char +import Data.Function +import Data.List +import Data.List +import Data.Maybe +import Data.Monoid +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import System.Directory +import System.Environment +import System.FilePath + +import System.Console.CmdArgs +import Text.RSS.Export +import Text.RSS.Import +import Text.RSS.Syntax +import Text.Atom.Feed +import Text.Atom.Feed.Export +import Text.Atom.Feed.Import +import Text.XML.Light + +import Hakyll.Convert.Common +import qualified Hakyll.Convert.Blogger as Blogger +import qualified Hakyll.Convert.Wordpress as Wordpress + +data InputFormat = Blogger | Wordpress + deriving (Data, Typeable, Enum, Show) + +data Config = Config + { feed :: FilePath + , outputDir :: FilePath + , format :: InputFormat + } + deriving (Show, Data, Typeable) + +parameters :: FilePath -> Config +parameters p = modes + [ Config + { feed = def &= argPos 0 &= typ "ATOM/RSS FILE" + , outputDir = def &= argPos 1 &= typDir + , format = Blogger &= help "blogger or wordpress" + } &= help "Save blog posts Blogger feed into individual posts" + ] &= program (takeFileName p) + +-- --------------------------------------------------------------------- +-- +-- --------------------------------------------------------------------- + +main = do + p <- getProgName + config <- cmdArgs (parameters p) + case format config of + Blogger -> mainBlogger config + Wordpress -> mainWordPress config + +mainBlogger :: Config -> IO () +mainBlogger config = do + mfeed <- Blogger.readPosts (feed config) + case mfeed of + Nothing -> fail $ "Could not understand Atom feed: " ++ feed config + Just fd -> mapM_ process fd + where + process = savePost config "html" . Blogger.distill + +mainWordPress :: Config -> IO () +mainWordPress config = do + mfeed <- Wordpress.readPosts (feed config) + case mfeed of + Nothing -> fail $ "Could not understand RSS feed: " ++ feed config + Just fd -> mapM_ process fd + where + process = savePost config "markdown" . Wordpress.distill + +-- --------------------------------------------------------------------- +-- To Hakyll (sort of) +-- Saving feed in bite-sized pieces +-- --------------------------------------------------------------------- + +-- | Save a post along with its comments as a mini atom feed +savePost :: Config -> String -> DistilledPost -> IO () +savePost cfg ext post = do + putStrLn fname + createDirectoryIfMissing True (takeDirectory fname) + B.writeFile fname . T.encodeUtf8 $ T.unlines + [ "---" + , metadata "title" (formatTitle (dpTitle post)) + , metadata "published" (formatDate (dpDate post)) + , metadata "categories" (formatTags (dpCategories post)) + , metadata "tags" (formatTags (dpTags post)) + , "---" + , "" + , formatBody (dpBody post) + ] + where + metadata k v = k <> ": " <> v + odir = outputDir cfg + -- + fname = odir postPath <.> ext + postPath = dropTrailingSlash + . dropExtensions + $ chopUri (dpUri post) + where + dropTrailingSlash = reverse . dropWhile (== '/') . reverse + chopUri (dropPrefix "http://" -> ("",rest)) = + -- carelessly assumes we can treat URIs like filepaths + joinPath $ drop 1 -- drop the domain + $ splitPath rest + chopUri u = error $ + "We've wrongly assumed that blog post URIs start with http://, but we got: " ++ u + -- + formatTitle (Just t) = t + formatTitle Nothing = + "untitled (" <> T.unwords firstFewWords <> "…)" + where + firstFewWords = T.splitOn "-" . T.pack $ takeFileName postPath + formatDate = id + formatTags = T.intercalate "," + formatBody = id + +{- +-- Ugh! convert br tags inside of pre tags +fixupBloggerHtml :: Content -> Content +fixupBloggerHtml = descendElem $ \e -> + if elName e == unqual "pre" + then Just . Elem $ + e { elContent = map (descendElem fixBr) (elContent e) } + else Nothing + where + fixBr e = + if elName e == unqual "br" + then Just (Text newline) + else Nothing + newline = CData CDataRaw "\n" Nothing + +descendElem pred (Elem e) = + case pred e of + Nothing -> Elem $ e { elContent = map (descendElem pred) (elContent e) } + Just e2 -> e2 +descendElem _ x = x +-} + +-- --------------------------------------------------------------------- +-- utilities +-- --------------------------------------------------------------------- + +dropPrefix :: Eq a => [a] -> [a] -> ([a],[a]) +dropPrefix (x:xs) (y:ys) | x == y = dropPrefix xs ys +dropPrefix left right = (left,right)