hakyll-convert (empty) → 0.1.0.0
raw patch · 8 files changed
+701/−0 lines, 8 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, cmdargs, directory, feed, filepath, hakyll, hakyll-convert, old-locale, text, time, xml
Files
- Hakyll/Convert/Blogger.hs +206/−0
- Hakyll/Convert/Common.hs +21/−0
- Hakyll/Convert/Wordpress.hs +82/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- hakyll-convert.cabal +53/−0
- tools/hakyll-convert-demo.hs +151/−0
- tools/hakyll-convert.hs +156/−0
+ Hakyll/Convert/Blogger.hs view
@@ -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))
+ Hakyll/Convert/Common.hs view
@@ -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)
+ Hakyll/Convert/Wordpress.hs view
@@ -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"+ }
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Eric Kow <eric.kow@gmail.com>++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 <eric.kow@gmail.com> 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hakyll-convert.cabal view
@@ -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 <eric.kow@gmail.com>+maintainer: Eric Kow <eric.kow@gmail.com>+-- 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
+ tools/hakyll-convert-demo.hs view
@@ -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+-}
+ tools/hakyll-convert.hs view
@@ -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)