+license: BSD3
+license-file: LICENSE
+build-type: Simple
+extra-source-files:
+ CHANGELOG.md
+
+source-repository head
+ type: git
+ location: https://github.com/Minoru/hakyll-convert
+
library
- exposed-modules: Hakyll.Convert.Blogger
- , Hakyll.Convert.Common
- , Hakyll.Convert.Wordpress
- , Hakyll.Convert.OutputFormat
- build-depends: base
- , binary
- , bytestring
- , containers
- , data-default
- , feed
- , filepath
- , hakyll
- , text
- , time
- , xml
+ exposed-modules:
+ Hakyll.Convert.Blogger
+ Hakyll.Convert.Common
+ Hakyll.Convert.IO
+ Hakyll.Convert.OutputFormat
+ Hakyll.Convert.Wordpress
+ other-modules:
+ Paths_hakyll_convert
+ hs-source-dirs:
+ src
+ ghc-options: -Wall
+ build-depends:
+ base >=4.13 && <5
+ , bytestring >=0.10 && <0.11
+ , containers >=0.6 && <0.7
+ , data-default >=0.7 && <0.8
+ , directory >=1.3 && <1.4
+ , feed >=1.3 && <1.4
+ , filepath >=1.4 && <1.5
+ , text >=1.2 && <1.3
+ , time >=1.9 && <1.10
+ , xml-conduit >=1.9 && <1.10
+ , xml-types >=0.3 && <0.4
+ default-language: Haskell2010
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
- , time
- , xml
+ main-is: hakyll-convert.hs
+ other-modules:
+ Paths_hakyll_convert
+ hs-source-dirs:
+ app
+ ghc-options: -Wall
+ build-depends:
+ base >=4.13 && <5
+ , cmdargs >=0.10 && <0.11
+ , filepath >=1.4 && <1.5
+ , hakyll-convert
+ , text >=1.2 && <1.3
+ , xml-types >=0.3 && <0.4
+ default-language: Haskell2010
+
+test-suite golden
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ other-modules:
+ Golden.Blogger
+ Golden.GoldenTestHelpers
+ Golden.IO
+ Golden.Wordpress
+ Paths_hakyll_convert
+ hs-source-dirs:
+ test/golden
+ ghc-options: -Wall -Wno-orphans
+ build-depends:
+ base >=4.13 && <5
+ , bytestring >=0.10 && <0.11
+ , data-default >=0.7 && <0.8
+ , datetime >=0.3 && <0.4
+ , filepath >=1.4 && <1.5
+ , hakyll-convert
+ , tasty >=1.2 && <1.3
+ , tasty-golden >=2.3 && <2.4
+ , temporary >=1.3 && <1.4
+ , text >=1.2 && <1.3
+ , xml-types >=0.3 && <0.4
+ default-language: Haskell2010
+
+test-suite spec
+ type: exitcode-stdio-1.0
+ main-is: Main.hs
+ other-modules:
+ Spec.Blogger
+ Spec.IO
+ Spec.OutputFormat
+ Spec.Wordpress
+ Paths_hakyll_convert
+ hs-source-dirs:
+ test/spec
+ ghc-options: -Wall -Wno-orphans
+ build-depends:
+ base >=4.13 && <5
+ , data-default >=0.7 && <0.8
+ , datetime >=0.3 && <0.4
+ , directory >=1.3 && <1.4
+ , feed >=1.3 && <1.4
+ , filepath >=1.4 && <1.5
+ , hakyll-convert
+ , tasty >=1.2 && <1.3
+ , tasty-expected-failure >=0.11 && <0.12
+ , tasty-hunit >=0.10 && <0.11
+ , tasty-quickcheck >=0.10 && <0.11
+ , temporary >=1.3 && <1.4
+ , text >=1.2 && <1.3
+ , xml-types >=0.3 && <0.4
+ default-language: Haskell2010
diff --git a/src/Hakyll/Convert/Blogger.hs b/src/Hakyll/Convert/Blogger.hs
new file mode 100644
--- /dev/null
+++ b/src/Hakyll/Convert/Blogger.hs
@@ -0,0 +1,242 @@
+{-# LANGUAGE ExplicitForAll #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hakyll.Convert.Blogger (FullPost (..), readPosts, distill) where
+
+import Control.Arrow
+import Control.Monad
+import Data.Function
+import Data.List
+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
+
+-- | A post and its comments
+data FullPost = FullPost
+ { fpPost :: Entry,
+ fpComments :: [Entry],
+ fpUri :: T.Text
+ }
+ deriving (Show)
+
+-- | 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_ :: T.Text, beEntry :: Entry}
+ | Comment {beUri_ :: T.Text, beEntry :: Entry}
+ | Orphan {beEntry :: Entry}
+ deriving (Show)
+
+beUri :: BloggerEntry -> Maybe T.Text
+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
+ doc <- XML.readFile (XML.def :: XML.ParseSettings) f
+ let root = XML.toXMLElement $ XML.documentRoot doc
+ return $ fmap (extractPosts . feedEntries) $ elementFeed $ deleteDrafts root
+
+-- 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 {elementNodes = filter isInnocent (elementNodes e)}
+ where
+ isInnocent (NodeElement element) = not (isDraft element)
+ isInnocent _ = True
+
+isDraft :: Element -> Bool
+isDraft e =
+ not . null $ findElements draft e
+ where
+ draft =
+ Name
+ { nameLocalName = "draft",
+ nameNamespace = Just "http://purl.org/atom/app#",
+ namePrefix = Just "app"
+ }
+
+-- | Warning: this silently ignores orphans, templates, settings
+extractPosts :: [Entry] -> [FullPost]
+extractPosts entries =
+ map toFullPost blocks
+ where
+ toFullPost (uri, blockEntries) =
+ FullPost
+ { fpPost = post,
+ fpComments = comments,
+ fpUri = uri
+ }
+ where
+ post = case [e | Post _ e <- blockEntries] of
+ [] -> huh "Block of entries with no post?!"
+ [p] -> p
+ _ps -> huh "Block of entries with more than one post?!"
+ comments = [e | Comment _ e <- blockEntries]
+ huh msg = error . unlines $ msg : map (txtToString . entryTitle . beEntry) blockEntries
+ 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 = T.takeWhile (/= '?') . replaceSchema . linkHref
+ replaceSchema url = maybe url (T.append "https://") (T.stripPrefix "http://" url)
+ 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 = T.append "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 ::
+ -- | \"comment\", \"post\", etc
+ T.Text ->
+ Category ->
+ Bool
+isBloggerCategoryOfType ty c =
+ isBloggerCategory c
+ && catTerm c == T.append "http://schemas.google.com/blogger/2008/kind#" ty
+
+-- ---------------------------------------------------------------------
+--
+-- ---------------------------------------------------------------------
+
+distill :: Bool -> FullPost -> DistilledPost
+distill extractComments fp =
+ DistilledPost
+ { dpBody = body fpost,
+ dpUri = fpUri fp,
+ dpTitle = title fpost,
+ dpTags = tags fpost,
+ dpCategories = [],
+ dpDate = date fpost
+ }
+ where
+ fpost = fpPost fp
+ fcomments = fpComments fp
+ --
+ body post =
+ let article = fromContent $ entryContent post
+ comments = T.intercalate "\n" $ map formatComment fcomments
+ in if extractComments
+ then
+ T.intercalate
+ "\n"
+ [ article,
+ "",
+ "",
+ comments
+ ]
+ else article
+
+ fromContent (Just (HTMLContent x)) = x
+ fromContent _ = error "Hakyll.Convert.Blogger.distill expecting HTML"
+
+ formatComment c =
+ T.intercalate
+ "\n"
+ [ ""
+ ]
+ where
+ pubdate = fromMaybe "unknown date" (entryPublished c)
+ author = T.unwords $ map personName (entryAuthors c)
+ comment = fromContent $ entryContent c
+ --
+ title p = case txtToString (entryTitle p) of
+ "" -> Nothing
+ t -> Just (T.pack t)
+ tags =
+ map catTerm
+ . filter (not . isBloggerCategory)
+ . entryCategories
+ date x = case parseTime' =<< entryPublished x of
+ Nothing -> fromJust $ parseTime' "1970-01-01T00:00:00Z"
+ Just d -> d
+ parseTime' d =
+ msum $
+ map
+ (\f -> parseTimeM True defaultTimeLocale f (T.unpack d))
+ [ "%FT%T%Q%z", -- with time zone
+ "%FT%T%QZ" -- zulu time
+ ]
+
+-- ---------------------------------------------------------------------
+-- odds and ends
+-- ---------------------------------------------------------------------
+
+entryError :: forall a. Entry -> T.Text -> a
+entryError e msg =
+ error $ (T.unpack msg) ++ " [on entry " ++ (T.unpack (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))
+
+-- | 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 =
+ if elementName element == name
+ then [element]
+ else concatMap (findElements name) (elementChildren element)
diff --git a/src/Hakyll/Convert/Common.hs b/src/Hakyll/Convert/Common.hs
new file mode 100644
--- /dev/null
+++ b/src/Hakyll/Convert/Common.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hakyll.Convert.Common where
+
+import Data.Data
+import Data.Default
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Time.Clock (UTCTime)
+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
+
+data DistilledPost = DistilledPost
+ { dpUri :: T.Text,
+ 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 :: UTCTime
+ }
+ deriving (Data, Typeable)
+
+instance Default DistilledPost where
+ def =
+ DistilledPost
+ { dpUri = "",
+ dpBody = "",
+ dpTitle = Nothing,
+ dpTags = [],
+ dpCategories = [],
+ dpDate = posixSecondsToUTCTime 0
+ }
diff --git a/src/Hakyll/Convert/IO.hs b/src/Hakyll/Convert/IO.hs
new file mode 100644
--- /dev/null
+++ b/src/Hakyll/Convert/IO.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Hakyll.Convert.IO where
+
+import qualified Data.ByteString as B
+import Data.Maybe (fromJust)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Data.Time.Format (defaultTimeLocale, formatTime)
+import Hakyll.Convert.Common (DistilledPost (..))
+import Hakyll.Convert.OutputFormat (formatPath)
+import System.Directory (createDirectoryIfMissing)
+import System.FilePath (takeDirectory, takeFileName, (<.>), ())
+
+-- | Save a post along with its comments in a format that Hakyll understands.
+--
+-- Returns the filename of the file that was written.
+savePost :: FilePath -> T.Text -> T.Text -> DistilledPost -> IO FilePath
+savePost odir oformat ext post = do
+ 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)
+ ]
+
+ return fname
+ where
+ metadata k v = k <> ": " <> v
+ --
+ fname = odir postPath <.> (T.unpack ext)
+ postPath = T.unpack $ fromJust $ formatPath oformat post
+ --
+ formatTitle (Just t) = t
+ formatTitle Nothing =
+ "untitled (" <> T.unwords firstFewWords <> "…)"
+ where
+ firstFewWords = T.splitOn "-" . T.pack $ takeFileName postPath
+ formatDate = T.pack . formatTime defaultTimeLocale "%FT%TZ" --for hakyll
+ formatTags = T.intercalate ","
+ formatBody = id
diff --git a/src/Hakyll/Convert/OutputFormat.hs b/src/Hakyll/Convert/OutputFormat.hs
new file mode 100644
--- /dev/null
+++ b/src/Hakyll/Convert/OutputFormat.hs
@@ -0,0 +1,108 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+
+module Hakyll.Convert.OutputFormat (validOutputFormat, formatPath) where
+
+import Data.Default
+import qualified Data.Map.Strict as M
+import qualified Data.Text as T
+import Data.Time.Format (defaultTimeLocale, formatTime)
+import Hakyll.Convert.Common
+import System.FilePath
+
+validOutputFormat :: T.Text -> Bool
+validOutputFormat format
+ | T.null format = False
+ | otherwise =
+ case formatPath format def of
+ Just _ -> True
+ Nothing -> False
+
+formatPath :: T.Text -> DistilledPost -> Maybe T.Text
+formatPath format post = T.concat <$> helper [] format
+ where
+ helper acc input =
+ case T.uncons input of
+ Just ('%', rest) ->
+ case T.uncons rest of
+ Just (ch, rest2) ->
+ if ch `M.member` acceptableFormats
+ then
+ let formatter = acceptableFormats M.! ch
+ in helper ((formatter post) : acc) rest2
+ else Nothing
+ Nothing -> Nothing
+ Just (ch, rest) -> helper ((T.singleton ch) : acc) rest
+ Nothing -> Just $ reverse acc
+
+-- When adding a new format, don't forget to update the help message in
+-- tools/hakyll-convert.hs
+acceptableFormats :: M.Map Char (DistilledPost -> T.Text)
+acceptableFormats =
+ M.fromList
+ [ -- this lets users put literal percent sign in the format)
+ ('%', const $ T.singleton '%'),
+ ('o', fmtOriginalPath), -- original filepath, like 2016/01/02/blog-post.html
+ ('s', fmtSlug), -- original slug, i.e. "blog-post" from the example above
+ ('y', fmtYear2), -- publication year, 2 digits
+ ('Y', fmtYear4), -- publication year, 4 digits
+ ('m', fmtMonth), -- publication month
+ ('d', fmtDay), -- publication day
+ ('H', fmtHour), -- publication hour
+ ('M', fmtMinute), -- publication minute
+ ('S', fmtSecond) -- publication second
+ ]
+
+fmtOriginalPath :: DistilledPost -> T.Text
+fmtOriginalPath post =
+ T.pack
+ . dropTrailingSlash
+ . dropExtensions
+ $ chopUri $ T.unpack (dpUri post)
+ where
+ dropTrailingSlash = reverse . dropWhile (== '/') . reverse
+ dropDomain path =
+ -- carelessly assumes we can treat URIs like filepaths
+ joinPath $
+ drop 1 $ -- drop the domain
+ splitPath path
+ chopUri (dropPrefix "http://" -> ("", rest)) = dropDomain rest
+ chopUri (dropPrefix "https://" -> ("", rest)) = dropDomain rest
+ chopUri u =
+ error $
+ "We've wrongly assumed that blog post URIs start with http:// or https://, but we got: " ++ u
+
+ dropPrefix :: Eq a => [a] -> [a] -> ([a], [a])
+ dropPrefix (x : xs) (y : ys) | x == y = dropPrefix xs ys
+ dropPrefix left right = (left, right)
+
+fmtSlug :: DistilledPost -> T.Text
+fmtSlug post =
+ T.reverse
+ . (T.takeWhile (/= '/'))
+ . T.reverse
+ $ fmtOriginalPath post
+
+fmtDate :: String -> DistilledPost -> T.Text
+fmtDate format = T.pack . (formatTime defaultTimeLocale format) . dpDate
+
+fmtYear2 :: DistilledPost -> T.Text
+fmtYear2 = fmtDate "%y"
+
+fmtYear4 :: DistilledPost -> T.Text
+fmtYear4 = fmtDate "%Y"
+
+fmtMonth :: DistilledPost -> T.Text
+fmtMonth = fmtDate "%m"
+
+fmtDay :: DistilledPost -> T.Text
+fmtDay = fmtDate "%d"
+
+fmtHour :: DistilledPost -> T.Text
+fmtHour = fmtDate "%H"
+
+fmtMinute :: DistilledPost -> T.Text
+fmtMinute = fmtDate "%M"
+
+fmtSecond :: DistilledPost -> T.Text
+fmtSecond = fmtDate "%S"
diff --git a/src/Hakyll/Convert/Wordpress.hs b/src/Hakyll/Convert/Wordpress.hs
new file mode 100644
--- /dev/null
+++ b/src/Hakyll/Convert/Wordpress.hs
@@ -0,0 +1,141 @@
+{-# 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 f = do
+ doc <- XML.readFile (XML.def :: XML.ParseSettings) f
+ let root = XML.toXMLElement $ XML.documentRoot doc
+ return $ fmap select (elementToRSS root)
+ where
+ select = filter isPublished . rssItems . rssChannel
+
+isPublished :: RSSItem -> Bool
+isPublished i = "publish" `elem` getStatus i
+
+distill :: Bool -> RSSItem -> DistilledPost
+distill extractComments item =
+ DistilledPost
+ { dpTitle = rssItemTitle item,
+ dpBody = body,
+ dpUri = link,
+ dpTags = tags,
+ dpCategories = categories,
+ dpDate = date
+ }
+ where
+ body =
+ if extractComments
+ then
+ T.intercalate
+ "\n"
+ [ content,
+ "",
+ "",
+ comments
+ ]
+ else content
+ link = fromMaybe "" (rssItemLink item)
+ content = T.unlines (map strContent contentTags)
+ categories = rssCategoriesOfType "category"
+ tags = rssCategoriesOfType "post_tag"
+ contentTags = concatMap (findElements contentTag) (rssItemOther item)
+ rssCategoriesOfType ty =
+ [ rssCategoryValue c
+ | c <- rssItemCategories item,
+ rssCategoryDomain c == Just ty
+ ]
+ contentTag =
+ Name
+ { nameLocalName = "encoded",
+ nameNamespace = Just "http://purl.org/rss/1.0/modules/content/",
+ namePrefix = Just "content"
+ }
+ comments = T.intercalate "\n" $ map formatComment commentTags
+ commentTags = rssItemOther item >>= findElements commentTag
+ commentTag = wordpressTag "comment"
+ --
+ date = case parseTime' =<< rssItemPubDate item of
+ Nothing -> fromJust $ parseTime' "Thu, 01 Jan 1970 00:00:00 UTC"
+ Just d -> d
+ parseTime' d =
+ msum $
+ map
+ (\f -> parseTimeM True defaultTimeLocale f (T.unpack d))
+ [ rfc822DateFormat
+ ]
+
+-- ---------------------------------------------------------------------
+-- helpers
+-- ---------------------------------------------------------------------
+
+formatComment :: Element -> T.Text
+formatComment commentElement =
+ T.intercalate
+ "\n"
+ [ ""
+ ]
+ where
+ pubdate = fromMaybe "unknown date" $ findField "comment_date"
+ author = fromMaybe "unknown author" $ findField "comment_author"
+ comment = fromMaybe "" $ findField "comment_content"
+ findField name =
+ strContent <$> findChild (wordpressTag name) commentElement
+
+wordpressTag :: T.Text -> Name
+wordpressTag name =
+ Name
+ { nameLocalName = name,
+ nameNamespace = Just "http://wordpress.org/export/1.2/",
+ namePrefix = Just "wp"
+ }
+
+getStatus :: RSSItem -> [T.Text]
+getStatus item =
+ map strContent statusTags
+ where
+ statusTags = concatMap (findElements (wordpressTag "status")) (rssItemOther 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 =
+ if elementName element == name
+ then [element]
+ else concatMap (findElements name) (elementChildren element)
+
+-- | Find first immediate child of `root` which is named `name`.
+findChild :: Name -> Element -> Maybe Element
+findChild name element =
+ let subelements = elementChildren element
+ matching = filter (\child -> elementName child == name) subelements
+ in listToMaybe matching
+
+-- | The contents of the element (ignoring non-text sub-elements).
+strContent :: Element -> T.Text
+strContent element = T.concat $ elementText element
diff --git a/test/golden/Golden/Blogger.hs b/test/golden/Golden/Blogger.hs
new file mode 100644
--- /dev/null
+++ b/test/golden/Golden/Blogger.hs
@@ -0,0 +1,51 @@
+module Golden.Blogger where
+
+import Data.Maybe (listToMaybe)
+import Golden.GoldenTestHelpers
+import Hakyll.Convert.Blogger
+import Test.Tasty (TestTree, testGroup)
+
+goldenTests :: TestTree
+goldenTests =
+ testGroup
+ "Blogger"
+ [ blogger_000,
+ blogger_001,
+ blogger_002
+ ]
+
+blogger_000 :: TestTree
+blogger_000 =
+ testGroup
+ "readPosts"
+ [ helper
+ ("post No." ++ no)
+ (listToMaybe . (drop offset))
+ | (no, offset) <- map (\n -> (show n, n)) [0 .. 2]
+ ]
+ where
+ helper = readPostsHelper readPosts "test/golden/data/blogger-000/"
+
+blogger_001 :: TestTree
+blogger_001 =
+ testGroup
+ "distilled posts (blogger-001)"
+ [ helper
+ ("post No." ++ no)
+ (listToMaybe . (drop offset))
+ | (no, offset) <- map (\n -> (show n, n)) [0 .. 2]
+ ]
+ where
+ helper = readAndDistillHelper readPosts distill "test/golden/data/blogger-001/"
+
+blogger_002 :: TestTree
+blogger_002 =
+ testGroup
+ "distilled posts (blogger-002)"
+ [ helper
+ ("post No." ++ no)
+ (listToMaybe . (drop offset))
+ | (no, offset) <- map (\n -> (show n, n)) [0 .. 2]
+ ]
+ where
+ helper = readAndDistillHelper readPosts distill "test/golden/data/blogger-002/"
diff --git a/test/golden/Golden/GoldenTestHelpers.hs b/test/golden/Golden/GoldenTestHelpers.hs
new file mode 100644
--- /dev/null
+++ b/test/golden/Golden/GoldenTestHelpers.hs
@@ -0,0 +1,49 @@
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Golden.GoldenTestHelpers where
+
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import Data.Maybe (fromMaybe)
+import Hakyll.Convert.Common
+import Test.Tasty (TestTree)
+import Test.Tasty.Golden (goldenVsString)
+
+deriving instance Show DistilledPost
+
+readPostsHelper ::
+ Show a =>
+ (FilePath -> IO (Maybe [a])) ->
+ String ->
+ String ->
+ ([a] -> Maybe a) ->
+ TestTree
+readPostsHelper readPosts dir testName selector =
+ goldenVsString
+ testName
+ (dir ++ (map spaceToDash testName) ++ ".golden")
+ ( do
+ posts <- readPosts (dir ++ "input.xml")
+ return $
+ fromMaybe
+ LBS.empty
+ ( posts
+ >>= selector
+ >>= (return . LBS.pack . show)
+ )
+ )
+ where
+ spaceToDash = \c -> if c == ' ' then '-' else c
+
+readAndDistillHelper ::
+ (FilePath -> IO (Maybe [a])) ->
+ (Bool -> a -> DistilledPost) ->
+ String ->
+ String ->
+ ([DistilledPost] -> Maybe DistilledPost) ->
+ TestTree
+readAndDistillHelper readPosts distill dir testName selector =
+ let fut filepath = do
+ posts <- readPosts filepath
+ let extractComments = True
+ return $ fmap (map (distill extractComments)) posts
+ in readPostsHelper fut dir testName selector
diff --git a/test/golden/Golden/IO.hs b/test/golden/Golden/IO.hs
new file mode 100644
--- /dev/null
+++ b/test/golden/Golden/IO.hs
@@ -0,0 +1,72 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Golden.IO where
+
+import qualified Data.ByteString.Lazy.Char8 as LBS
+import Data.DateTime (fromGregorian)
+import Data.Default (def)
+import Hakyll.Convert.Common (DistilledPost (..))
+import Hakyll.Convert.IO (savePost)
+import System.FilePath (())
+import System.IO.Temp (withSystemTempDirectory)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.Golden (goldenVsString)
+
+goldenTests :: TestTree
+goldenTests =
+ testGroup
+ "IO.savePost"
+ [ writesUntitledPost,
+ writesPostWithTitle
+ ]
+
+writesUntitledPost :: TestTree
+writesUntitledPost =
+ goldenVsString
+ "Writes untitled post to a file"
+ "test/golden/data/io-000/untitled-post.golden"
+ ( withSystemTempDirectory "hakyll-convert" $ \tempDir -> do
+ let output_format = "output"
+ let file_extension = "html"
+ let post =
+ def
+ { dpUri = "https://example.com/~joe/2011/01/02/just-testing.php",
+ dpDate = fromGregorian 2011 1 2 3 14 59,
+ dpCategories = ["Category 1", "Category 2"],
+ dpTags = ["Tagged", "with", "<3"],
+ dpBody = "This tool is awesome!
"
+ }
+
+ -- Ignore the generated filename -- we'll just check if the file is at
+ -- the expected place instead.
+ _filename <- savePost tempDir output_format file_extension post
+
+ let filename = tempDir "output.html"
+ LBS.readFile filename
+ )
+
+writesPostWithTitle :: TestTree
+writesPostWithTitle =
+ goldenVsString
+ "Writes post with title to a file"
+ "test/golden/data/io-000/post-with-title.golden"
+ ( withSystemTempDirectory "hakyll-convert" $ \tempDir -> do
+ let output_format = "output"
+ let file_extension = "aspx"
+ let post =
+ def
+ { dpUri = "https://example.com/~joe/a%20joke.php",
+ dpDate = fromGregorian 1999 12 31 23 59 1,
+ dpCategories = ["jokes"],
+ dpTags = ["non-funny", "unoriginal"],
+ dpTitle = Just "And now for something completely different…",
+ dpBody = "Wonder what it is?"
+ }
+
+ -- Ignore the generated filename -- we'll just check if the file is at
+ -- the expected place instead.
+ _filename <- savePost tempDir output_format file_extension post
+
+ let filename = tempDir "output.aspx"
+ LBS.readFile filename
+ )
diff --git a/test/golden/Golden/Wordpress.hs b/test/golden/Golden/Wordpress.hs
new file mode 100644
--- /dev/null
+++ b/test/golden/Golden/Wordpress.hs
@@ -0,0 +1,38 @@
+module Golden.Wordpress where
+
+import Data.Maybe (listToMaybe)
+import Golden.GoldenTestHelpers
+import Hakyll.Convert.Wordpress
+import Test.Tasty (TestTree, testGroup)
+
+goldenTests :: TestTree
+goldenTests =
+ testGroup
+ "Wordpress"
+ [ wordpress_000,
+ wordpress_001
+ ]
+
+wordpress_000 :: TestTree
+wordpress_000 =
+ testGroup
+ "readPosts"
+ [ helper
+ ("post No. " ++ no)
+ (listToMaybe . (drop offset))
+ | (no, offset) <- map (\n -> (show n, n)) [0 .. 11]
+ ]
+ where
+ helper = readPostsHelper readPosts "test/golden/data/wordpress-000/"
+
+wordpress_001 :: TestTree
+wordpress_001 =
+ testGroup
+ "distilled posts"
+ [ helper
+ ("post No. " ++ no)
+ (listToMaybe . (drop offset))
+ | (no, offset) <- map (\n -> (show n, n)) [0 .. 11]
+ ]
+ where
+ helper = readAndDistillHelper readPosts distill "test/golden/data/wordpress-001/"
diff --git a/test/golden/Main.hs b/test/golden/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/golden/Main.hs
@@ -0,0 +1,18 @@
+module Main where
+
+import qualified Golden.Blogger as Blogger
+import qualified Golden.IO as IO
+import qualified Golden.Wordpress as Wordpress
+import Test.Tasty (TestTree, defaultMain, testGroup)
+
+main :: IO ()
+main = defaultMain goldenTests
+
+goldenTests :: TestTree
+goldenTests =
+ testGroup
+ "Golden tests"
+ [ Blogger.goldenTests,
+ IO.goldenTests,
+ Wordpress.goldenTests
+ ]
diff --git a/test/spec/Main.hs b/test/spec/Main.hs
new file mode 100644
--- /dev/null
+++ b/test/spec/Main.hs
@@ -0,0 +1,18 @@
+module Main where
+
+import qualified Spec.Blogger as Blogger
+import qualified Spec.IO as IO
+import qualified Spec.OutputFormat as OutputFormat
+import qualified Spec.Wordpress as Wordpress
+import Test.Tasty (defaultMain, testGroup)
+
+main :: IO ()
+main =
+ defaultMain $
+ testGroup
+ "Spec tests"
+ [ Blogger.tests,
+ Wordpress.tests,
+ OutputFormat.tests,
+ IO.tests
+ ]
diff --git a/test/spec/Spec/Blogger.hs b/test/spec/Spec/Blogger.hs
new file mode 100644
--- /dev/null
+++ b/test/spec/Spec/Blogger.hs
@@ -0,0 +1,449 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Spec.Blogger (tests) where
+
+import Data.DateTime (fromGregorian)
+import qualified Data.Text as T
+import Hakyll.Convert.Blogger
+import Hakyll.Convert.Common (DistilledPost (..))
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.ExpectedFailure (expectFail)
+import Test.Tasty.HUnit
+import qualified Text.Atom.Feed as Atom
+
+deriving instance Eq DistilledPost
+
+deriving instance Show DistilledPost
+
+tests :: TestTree
+tests =
+ testGroup
+ "Blogger.distill"
+ [ extractsPostUri,
+ extractsPostBody,
+ extractsPostTitle,
+ canSkipComments,
+ canExtractComments,
+ enumeratesAllCommentAuthors,
+ errorsOnNonHtmlPost,
+ errorsOnNonHtmlComment,
+ turnsIncorrectDatesIntoEpochStart,
+ parsesDates,
+ extractsPostTags
+ ]
+
+extractsPostUri :: TestTree
+extractsPostUri =
+ testGroup
+ "extracts post's URI"
+ [ testCase (T.unpack uri) (dpUri (distill False (createInput uri)) @?= uri)
+ | uri <-
+ [ "https://example.com/testing-post-uris",
+ "http://www.example.com/~joe/posts.atom"
+ ]
+ ]
+ where
+ createInput uri =
+ FullPost
+ { fpPost = entry,
+ fpComments = [],
+ fpUri = uri
+ }
+ entry =
+ Atom.nullEntry
+ "https://example.com/entry"
+ (Atom.TextString "Test post")
+ "2003-12-13T18:30:02Z"
+
+extractsPostBody :: TestTree
+extractsPostBody =
+ testGroup
+ "extracts post's body"
+ [ testCase (T.unpack body) (dpBody (distill False (createInput body)) @?= body)
+ | body <-
+ [ "Today was a snowy day, and I decided to...
",
+ "My opinion on current affairs
So you see, I...
"
+ ]
+ ]
+ where
+ createInput body =
+ FullPost
+ { fpPost = createEntry body,
+ fpComments = [],
+ fpUri = "https://example.com"
+ }
+ createEntry body =
+ ( Atom.nullEntry
+ "https://example.com/entry"
+ (Atom.TextString "Test post")
+ "2003-12-13T18:30:02Z"
+ )
+ { Atom.entryContent = Just (Atom.HTMLContent body)
+ }
+
+extractsPostTitle :: TestTree
+extractsPostTitle =
+ testGroup
+ "extracts post's title"
+ [ testCase (T.unpack title) (dpTitle (distill False (createInput title)) @?= Just (title))
+ | title <-
+ [ "First post",
+ "You won't believe what happened to me today",
+ "Trying out things…"
+ ]
+ ]
+ where
+ createInput title =
+ FullPost
+ { fpPost = createEntry title,
+ fpComments = [],
+ fpUri = "https://example.com/titles.atom"
+ }
+ createEntry title =
+ Atom.nullEntry
+ "https://example.com/entry"
+ (Atom.TextString title)
+ "2003-12-13T18:30:02Z"
+
+canSkipComments :: TestTree
+canSkipComments =
+ testCase
+ "does not extract comments if first argument is False"
+ (dpBody (distill False input) @?= expected)
+ where
+ input =
+ FullPost
+ { fpPost = entry,
+ fpComments = [comment],
+ fpUri = "https://example.com/feed"
+ }
+ entry =
+ ( Atom.nullEntry
+ "https://example.com/entry"
+ (Atom.TextString "First post")
+ "2003-12-13T18:30:02Z"
+ )
+ { Atom.entryContent = Just (Atom.HTMLContent "Hello, world!
"),
+ Atom.entryPublished = Just "2003-12-13T18:30:02Z"
+ }
+ comment =
+ ( Atom.nullEntry
+ "https://example.com/entry#comment1"
+ (Atom.TextString "Nice")
+ "2003-12-13T20:00:03Z"
+ )
+ { Atom.entryContent = Just (Atom.HTMLContent "Nice post.
")
+ }
+
+ expected = "Hello, world!
"
+
+canExtractComments :: TestTree
+canExtractComments =
+ testGroup
+ "extracts comments if first argument is True"
+ [ noDateNoAuthor,
+ dateNoAuthor,
+ noDateAuthor,
+ dateAuthor
+ ]
+ where
+ createInput comment =
+ FullPost
+ { fpPost = entry,
+ fpComments = [comment],
+ fpUri = "https://example.com/feed"
+ }
+
+ entry =
+ ( Atom.nullEntry
+ "https://example.com/entry"
+ (Atom.TextString "First post")
+ "2003-12-13T18:30:02Z"
+ )
+ { Atom.entryContent = Just (Atom.HTMLContent "Hello, world!
"),
+ Atom.entryPublished = Just "2003-12-13T18:30:02Z"
+ }
+
+ noDateNoAuthor =
+ testCase
+ "comments with no \"published\" date and no author"
+ (dpBody (distill True (createInput commentNoDateNoAuthor)) @?= expectedNoDateNoAuthor)
+ commentNoDateNoAuthor =
+ ( Atom.nullEntry
+ "https://example.com/entry#comment1"
+ (Atom.TextString "Nice")
+ "2003-12-13T20:00:03Z"
+ )
+ { Atom.entryContent = Just (Atom.HTMLContent "Nice post.
")
+ }
+ expectedNoDateNoAuthor =
+ "Hello, world!
\n\n\
+ \\n\
+ \"
+
+ dateNoAuthor =
+ testCase
+ "comments with a \"published\" date but no author"
+ (dpBody (distill True (createInput commentDateNoAuthor)) @?= expectedDateNoAuthor)
+ commentDateNoAuthor =
+ commentNoDateNoAuthor
+ { Atom.entryPublished = Just "2019-01-02T03:04:05Z"
+ }
+ expectedDateNoAuthor =
+ "Hello, world!
\n\n\
+ \\n\
+ \"
+
+ noDateAuthor =
+ testCase
+ "comments with no \"published\" date but with an author"
+ (dpBody (distill True (createInput commentNoDateAuthor)) @?= expectedNoDateAuthor)
+ commentNoDateAuthor =
+ commentNoDateNoAuthor
+ { Atom.entryAuthors = [Atom.nullPerson {Atom.personName = "John Doe"}]
+ }
+ expectedNoDateAuthor =
+ "Hello, world!
\n\n\
+ \\n\
+ \"
+
+ dateAuthor =
+ testCase
+ "comments with a \"published\" date and an author"
+ (dpBody (distill True (createInput commentDateAuthor)) @?= expectedDateAuthor)
+ commentDateAuthor =
+ commentNoDateNoAuthor
+ { Atom.entryPublished = Just "2019-01-02T03:04:05Z",
+ Atom.entryAuthors = [Atom.nullPerson {Atom.personName = "John Doe"}]
+ }
+ expectedDateAuthor =
+ "Hello, world!
\n\n\
+ \\n\
+ \"
+
+enumeratesAllCommentAuthors :: TestTree
+enumeratesAllCommentAuthors =
+ testCase
+ "enumerates all authors of a multi-author comment"
+ (dpBody (distill True input) @?= expected)
+ where
+ input =
+ FullPost
+ { fpPost = entry,
+ fpComments = [comment],
+ fpUri = "https://example.com/feed"
+ }
+ entry =
+ ( Atom.nullEntry
+ "https://example.com/entry"
+ (Atom.TextString "First post")
+ "2003-12-13T18:30:02Z"
+ )
+ { Atom.entryContent = Just (Atom.HTMLContent "Hello, world!
"),
+ Atom.entryPublished = Just "2003-12-13T18:30:02Z"
+ }
+ comment =
+ ( Atom.nullEntry
+ "https://example.com/entry#comment1"
+ (Atom.TextString "Nice")
+ "2103-05-11T18:37:49Z"
+ )
+ { Atom.entryContent = Just (Atom.HTMLContent "Nice post.
"),
+ Atom.entryAuthors =
+ [ Atom.nullPerson {Atom.personName = "First Author"},
+ Atom.nullPerson {Atom.personName = "Second Author"}
+ ]
+ }
+
+ expected =
+ "Hello, world!
\n\n\
+ \\n\
+ \"
+
+nullDistilledPost :: DistilledPost
+nullDistilledPost =
+ DistilledPost
+ { dpUri = "",
+ dpBody = "",
+ dpTitle = Nothing,
+ dpTags = [],
+ dpCategories = [],
+ dpDate = fromGregorian 2003 12 13 18 30 2
+ }
+
+errorsOnNonHtmlPost :: TestTree
+errorsOnNonHtmlPost =
+ expectFail $
+ testCase
+ "`error`s if post has non-HTML body"
+ (distill False input @?= nullDistilledPost)
+ where
+ input =
+ FullPost
+ { fpPost = entry,
+ fpComments = [],
+ fpUri = "https://example.com/feed"
+ }
+ entry =
+ ( Atom.nullEntry
+ "https://example.com/entry"
+ (Atom.TextString "First post")
+ "2003-12-13T18:30:02Z"
+ )
+ { Atom.entryContent = Just (Atom.TextContent "oops, this will fail")
+ }
+
+errorsOnNonHtmlComment :: TestTree
+errorsOnNonHtmlComment =
+ expectFail $
+ testCase
+ "`error`s if comment has non-HTML body"
+ (distill False input @?= nullDistilledPost)
+ where
+ input =
+ FullPost
+ { fpPost = entry,
+ fpComments = [comment],
+ fpUri = "https://example.com/feed"
+ }
+ entry =
+ ( Atom.nullEntry
+ "https://example.com/entry"
+ (Atom.TextString "First post")
+ "2003-12-13T18:30:02Z"
+ )
+ { Atom.entryContent = Just (Atom.TextContent "testing...")
+ }
+
+ comment =
+ ( Atom.nullEntry
+ "https://example.com/entry#2"
+ (Atom.TextString "test comment")
+ "2003-12-13T18:30:02Z"
+ )
+ { Atom.entryContent = Just (Atom.TextContent "oops, this will fail")
+ }
+
+turnsIncorrectDatesIntoEpochStart :: TestTree
+turnsIncorrectDatesIntoEpochStart =
+ testGroup
+ "turns incorrect \"published\" dates into Unix epoch start date"
+ [ testCase (T.unpack date) (dpDate (distill False (createInput date)) @?= expected)
+ | date <-
+ [ "First of April",
+ "2020.07.30",
+ "2020.07.30 00:01",
+ "2020-07-30 00:01",
+ "2020-07-30T00:01",
+ "2020-07-30T00:01Z",
+ "Sun, 31st July, 2020"
+ ]
+ ]
+ where
+ createInput date =
+ FullPost
+ { fpPost = createEntry date,
+ fpComments = [],
+ fpUri = "https://example.com/feed"
+ }
+ createEntry date =
+ ( Atom.nullEntry
+ "https://example.com/entry"
+ (Atom.TextString "First post")
+ date
+ )
+ { Atom.entryContent = Just (Atom.HTMLContent ""),
+ Atom.entryPublished = Just date
+ }
+
+ expected = fromGregorian 1970 1 1 0 0 0
+
+parsesDates :: TestTree
+parsesDates =
+ testGroup
+ "parses \"published\" dates"
+ [ testCase (T.unpack dateStr) (dpDate (distill False (createInput dateStr)) @?= expected)
+ | (dateStr, expected) <-
+ [ ("2020-07-30T15:50:21Z", fromGregorian 2020 7 30 15 50 21),
+ ("1015-02-18T01:04:13Z", fromGregorian 1015 2 18 1 4 13),
+ ("2020-07-30T15:50:21+0000", fromGregorian 2020 7 30 15 50 21),
+ ("1015-02-18T01:04:13+0000", fromGregorian 1015 2 18 1 4 13),
+ ("1015-02-18T01:04:13+0001", fromGregorian 1015 2 18 1 (4 -1) 13),
+ ("1015-02-18T01:04:13-0001", fromGregorian 1015 2 18 1 (4 + 1) 13),
+ ("1015-02-18T01:04:13+0100", fromGregorian 1015 2 18 (1 -1) 4 13),
+ ("1015-02-18T01:04:13-0100", fromGregorian 1015 2 18 (1 + 1) 4 13)
+ ]
+ ]
+ where
+ createInput date =
+ FullPost
+ { fpPost = createEntry date,
+ fpComments = [],
+ fpUri = "https://example.com/feed"
+ }
+ createEntry date =
+ ( Atom.nullEntry
+ "https://example.com/entry"
+ (Atom.TextString "First post")
+ date
+ )
+ { Atom.entryContent = Just (Atom.HTMLContent ""),
+ Atom.entryPublished = Just date
+ }
+
+extractsPostTags :: TestTree
+extractsPostTags =
+ testCase
+ "extracts post's tags"
+ (dpTags (distill False input) @?= expected)
+ where
+ input =
+ FullPost
+ { fpPost = entry,
+ fpComments = [],
+ fpUri = "https://example.com/feed"
+ }
+ entry =
+ ( Atom.nullEntry
+ "https://example.com/entry"
+ (Atom.TextString "First post")
+ "2003-12-13T18:30:02Z"
+ )
+ { Atom.entryContent = Just (Atom.HTMLContent ""),
+ Atom.entryCategories =
+ [ Atom.newCategory "first tag",
+ Atom.newCategory "second tag",
+ Atom.newCategory "third tag",
+ (Atom.newCategory "blogger category (should be ignored)")
+ { Atom.catScheme = Just "http://schemas.google.com/g/2005#kind"
+ }
+ ]
+ }
+
+ expected = ["first tag", "second tag", "third tag"]
diff --git a/test/spec/Spec/IO.hs b/test/spec/Spec/IO.hs
new file mode 100644
--- /dev/null
+++ b/test/spec/Spec/IO.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Spec.IO (tests) where
+
+import Data.DateTime (fromGregorian)
+import Data.Default (def)
+import Hakyll.Convert.Common (DistilledPost (..))
+import Hakyll.Convert.IO (savePost)
+import System.Directory (doesFileExist)
+import System.FilePath (())
+import System.IO.Temp (withSystemTempDirectory)
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+
+tests :: TestTree
+tests =
+ testGroup
+ "IO.savePost"
+ [ namesTheFileAccordingToFormat
+ ]
+
+namesTheFileAccordingToFormat :: TestTree
+namesTheFileAccordingToFormat =
+ testCase
+ "Names the output file according to the given filename format"
+ ( withSystemTempDirectory "hakyll-convert" $ \tempDir -> do
+ let output_format = "%o-%Y^%y%%_%s%dd & %m—%S%H%M"
+ let file_extension = "xyz"
+ let post =
+ def
+ { -- The slug, %s, is going to be "yet-another"
+ dpUri = "https://example.com/2020/yet-another.post.html",
+ dpDate = fromGregorian 2020 11 6 11 33 46
+ }
+
+ let expectedFilename = tempDir "2020/yet-another-2020^20%_yet-another06d & 11—461133.xyz"
+
+ filename <- savePost tempDir output_format file_extension post
+ expectedFilename @=? filename
+
+ exists <- doesFileExist expectedFilename
+ assertBool "The file with expected name doesn't exist" exists
+ )
diff --git a/test/spec/Spec/OutputFormat.hs b/test/spec/Spec/OutputFormat.hs
new file mode 100644
--- /dev/null
+++ b/test/spec/Spec/OutputFormat.hs
@@ -0,0 +1,157 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Spec.OutputFormat (tests) where
+
+import Data.DateTime (fromGregorian)
+import Data.Default
+import Data.Maybe (isJust)
+import qualified Data.Text as T
+import Hakyll.Convert.Common (DistilledPost (..))
+import Hakyll.Convert.OutputFormat
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import Test.Tasty.QuickCheck
+
+tests :: TestTree
+tests =
+ testGroup
+ "OutputFormat"
+ [ validOutputFormatTests,
+ formatPathTests
+ ]
+
+validOutputFormatTests :: TestTree
+validOutputFormatTests =
+ testGroup
+ "`validOutputFormat`"
+ [ falseOnEmptyFormat,
+ synchronyWithFormatPath
+ ]
+ where
+ falseOnEmptyFormat =
+ testCase
+ "returns False if format string is empty"
+ (validOutputFormat "" @?= False)
+
+ synchronyWithFormatPath =
+ testProperty
+ "returns False if `formatPath` returns `Nothing`, otherwise True"
+ ( \format ->
+ let format' = T.pack format
+ result = validOutputFormat format'
+ formatPathResult = isJust (formatPath format' def)
+ in not (null format) ==> (result && formatPathResult) || (not result && not formatPathResult)
+ )
+
+formatPathTests :: TestTree
+formatPathTests =
+ testGroup
+ "`formatPath`"
+ [ noChange,
+ lowercaseO,
+ lowercaseS,
+ lowercaseY,
+ uppercaseY,
+ lowercaseM,
+ lowercaseD,
+ uppercaseH,
+ uppercaseM,
+ uppercaseS,
+ complexExamples,
+ abortsProcessingOnUnknownFormat
+ ]
+ where
+ noChange =
+ let input = "Hello, world!/2020-09-03-test.markdown"
+ in testCase
+ "does not change text that has no percent signs in it"
+ (formatPath input def @?= Just input)
+
+ lowercaseO =
+ testGroup
+ "%o is replaced by the original filepath"
+ [ testCase
+ "works with HTTP schema"
+ (formatPath "%o" (def {dpUri = "http://example.com/post.html"}) @?= Just "post"),
+ testCase
+ "works with HTTPS schema"
+ (formatPath "%o" (def {dpUri = "https://example.com/post.html"}) @?= Just "post"),
+ testCase
+ "trailing slashes are removed"
+ (formatPath "%o" (def {dpUri = "https://example.com/2020-09-03-hello////"}) @?= Just "2020-09-03-hello"),
+ testCase
+ "file extension is removed"
+ (formatPath "%o" (def {dpUri = "https://example.com/first-post.html"}) @?= Just "first-post"),
+ testCase
+ "all file extensions are removed"
+ (formatPath "%o" (def {dpUri = "https://example.com/first-post.aspx.gz"}) @?= Just "first-post")
+ ]
+
+ lowercaseS =
+ testCase
+ "%s is replaced by the original slug"
+ (formatPath "%s" (def {dpUri = "https://example.com/today-is-my-birthday.php"}) @?= Just "today-is-my-birthday")
+
+ lowercaseY =
+ testCase
+ "%y is replaced by the two-digit publication year"
+ (formatPath "%y" (def {dpDate = fromGregorian 1917 01 01 0 0 0}) @?= Just "17")
+
+ uppercaseY =
+ testCase
+ "%Y is replaced by the four-digit publication year"
+ (formatPath "%Y" (def {dpDate = fromGregorian 1917 1 1 0 0 0}) @?= Just "1917")
+
+ lowercaseM =
+ testCase
+ "%m is replaced by the two-digit publication month"
+ (formatPath "%m" (def {dpDate = fromGregorian 2011 3 1 2 3 4}) @?= Just "03")
+
+ lowercaseD =
+ testCase
+ "%d is replaced by the two-digit publication day"
+ (formatPath "%d" (def {dpDate = fromGregorian 2013 1 31 0 0 0}) @?= Just "31")
+
+ uppercaseH =
+ testCase
+ "%H is replaced by the two-digit publication hour, 00 to 23"
+ (formatPath "%H" (def {dpDate = fromGregorian 2014 1 1 23 0 0}) @?= Just "23")
+
+ uppercaseM =
+ testCase
+ "%M is replaced by the two-digit publication minute"
+ (formatPath "%M" (def {dpDate = fromGregorian 2015 1 2 3 59 0}) @?= Just "59")
+
+ uppercaseS =
+ testCase
+ "%S is replaced by the two-digit publication second"
+ (formatPath "%S" (def {dpDate = fromGregorian 2016 1 2 3 4 0}) @?= Just "00")
+
+ complexExamples =
+ testGroup
+ "format string can contain multiple formats"
+ [ helper "%H:%M:%S" "18:30:02",
+ helper "old/%Y/%m/%d-%H%M%S-%s.html" "old/2003/12/13-183002-hello-world.html",
+ helper "/posts/%y-%m-%d-%H%M%S-%s/" "/posts/03-12-13-183002-hello-world/",
+ helper "/migrated/%o" "/migrated/~joe/hello-world",
+ helper "99.9%% true/%o" "99.9% true/~joe/hello-world"
+ ]
+ where
+ post =
+ DistilledPost
+ { dpUri = "https://example.com/~joe/hello-world.php",
+ dpBody = "",
+ dpTitle = Nothing,
+ dpTags = [],
+ dpCategories = [],
+ dpDate = fromGregorian 2003 12 13 18 30 2
+ }
+
+ helper format expected = testCase format (formatPath (T.pack format) post @?= Just expected)
+
+ abortsProcessingOnUnknownFormat =
+ testGroup
+ "returns Nothing upon encountering an unsupported format"
+ [ testCase "unknown format %x" (formatPath "%H%M%S-%x.html" def @?= Nothing),
+ testCase "no format specifier after percent sign" (formatPath "%H%M%" def @?= Nothing)
+ ]
diff --git a/test/spec/Spec/Wordpress.hs b/test/spec/Spec/Wordpress.hs
new file mode 100644
--- /dev/null
+++ b/test/spec/Spec/Wordpress.hs
@@ -0,0 +1,382 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE StandaloneDeriving #-}
+
+module Spec.Wordpress (tests) where
+
+import Data.DateTime (fromGregorian)
+import qualified Data.Text as T
+import qualified Data.XML.Types as XML
+import Hakyll.Convert.Common (DistilledPost (..))
+import Hakyll.Convert.Wordpress
+import Test.Tasty (TestTree, testGroup)
+import Test.Tasty.HUnit
+import qualified Text.RSS.Syntax as RSS
+
+deriving instance Eq DistilledPost
+
+deriving instance Show DistilledPost
+
+tests :: TestTree
+tests =
+ testGroup
+ "Wordpress.distill"
+ [ extractsPostUri,
+ extractsPostBody,
+ combinesMultipleContentTags,
+ extractsPostTitle,
+ canSkipComments,
+ canExtractComments,
+ usesTheFirstCommentAuthorTag,
+ turnsIncorrectDatesIntoEpochStart,
+ parsesDates,
+ extractsPostTags,
+ extractsPostCategories
+ ]
+
+extractsPostUri :: TestTree
+extractsPostUri =
+ testGroup
+ "extracts post's item link"
+ [ testCase (T.unpack uri) (dpUri (distill False (createInput uri)) @?= uri)
+ | uri <-
+ [ "https://example.com/testing-post-uris",
+ "http://www.example.com/~joe/posts.atom"
+ ]
+ ]
+ where
+ createInput uri =
+ (RSS.nullItem "First post")
+ { RSS.rssItemLink = Just uri
+ }
+
+contentTag :: XML.Name
+contentTag =
+ XML.Name
+ { XML.nameLocalName = "encoded",
+ XML.nameNamespace = Just "http://purl.org/rss/1.0/modules/content/",
+ XML.namePrefix = Just "content"
+ }
+
+namedElement :: XML.Name -> [XML.Node] -> XML.Element
+namedElement name nodes =
+ XML.Element
+ { XML.elementName = name,
+ XML.elementAttributes = [],
+ XML.elementNodes = nodes
+ }
+
+extractsPostBody :: TestTree
+extractsPostBody =
+ testGroup
+ "extracts post's body"
+ [ testCase (T.unpack body) (dpBody (distill False (createInput body)) @?= T.append body "\n")
+ | body <-
+ [ "Today was a snowy day, and I decided to...
",
+ "My opinion on current affairs
So you see, I...
"
+ ]
+ ]
+ where
+ createInput body =
+ (RSS.nullItem "Test post")
+ { RSS.rssItemOther =
+ [ namedElement contentTag [XML.NodeContent $ XML.ContentText body]
+ ]
+ }
+
+combinesMultipleContentTags :: TestTree
+combinesMultipleContentTags =
+ testCase
+ "combines multiple content:encoded tags into the post body"
+ (dpBody (distill False input) @?= T.unlines [body1, body2])
+ where
+ body1 = "Welcome!
"
+ body2 = "Hope you like my blog
"
+
+ input =
+ (RSS.nullItem "Just testing")
+ { RSS.rssItemOther =
+ [ createElement body1,
+ createElement body2
+ ]
+ }
+ createElement body = namedElement contentTag [XML.NodeContent $ XML.ContentText body]
+
+extractsPostTitle :: TestTree
+extractsPostTitle =
+ testGroup
+ "extracts post's title"
+ [ testCase (T.unpack title) (dpTitle (distill False (RSS.nullItem title)) @?= Just title)
+ | title <-
+ [ "First post",
+ "You won't believe what happened to me today",
+ "Trying out things…"
+ ]
+ ]
+
+commentTag :: XML.Name
+commentTag =
+ XML.Name
+ { XML.nameLocalName = "comment",
+ XML.nameNamespace = Just "http://wordpress.org/export/1.2/",
+ XML.namePrefix = Just "wp"
+ }
+
+commentContentTag :: XML.Name
+commentContentTag =
+ XML.Name
+ { XML.nameLocalName = "comment_content",
+ XML.nameNamespace = Just "http://wordpress.org/export/1.2/",
+ XML.namePrefix = Just "wp"
+ }
+
+commentDateTag :: XML.Name
+commentDateTag =
+ XML.Name
+ { XML.nameLocalName = "comment_date",
+ XML.nameNamespace = Just "http://wordpress.org/export/1.2/",
+ XML.namePrefix = Just "wp"
+ }
+
+commentAuthorTag :: XML.Name
+commentAuthorTag =
+ XML.Name
+ { XML.nameLocalName = "comment_author",
+ XML.nameNamespace = Just "http://wordpress.org/export/1.2/",
+ XML.namePrefix = Just "wp"
+ }
+
+canSkipComments :: TestTree
+canSkipComments =
+ testCase
+ "does not extract comments if first argument is False"
+ (dpBody (distill False input) @?= "Hello, world!
\n")
+ where
+ input =
+ (RSS.nullItem "Testing...")
+ { RSS.rssItemOther =
+ [ namedElement contentTag [XML.NodeContent $ XML.ContentText "Hello, world!
"],
+ namedElement
+ commentTag
+ [ XML.NodeContent $ XML.ContentText "I'd like to point out that...
"
+ ]
+ ]
+ }
+
+canExtractComments :: TestTree
+canExtractComments =
+ testGroup
+ "extracts comments if first argument is True"
+ [ noDateNoAuthor,
+ dateNoAuthor,
+ noDateAuthor,
+ dateAuthor
+ ]
+ where
+ createInput comment =
+ (RSS.nullItem "Testing...")
+ { RSS.rssItemOther =
+ [ namedElement contentTag [XML.NodeContent $ XML.ContentText "Is this thing on?
"],
+ comment
+ ]
+ }
+
+ noDateNoAuthor =
+ testCase
+ "comments with no \"published\" date and no author"
+ (dpBody (distill True (createInput noDateNoAuthorComment)) @?= expectedNoDateNoAuthor)
+ noDateNoAuthorComment =
+ namedElement
+ commentTag
+ [ XML.NodeElement $
+ namedElement commentContentTag [XML.NodeContent $ XML.ContentText "hi
"]
+ ]
+ expectedNoDateNoAuthor =
+ "Is this thing on?
\n\n\n\
+ \\n\
+ \"
+
+ dateNoAuthor =
+ testCase
+ "comments with a \"published\" date but no author"
+ (dpBody (distill True (createInput dateNoAuthorComment)) @?= expectedDateNoAuthor)
+ dateNoAuthorComment =
+ namedElement
+ commentTag
+ [ XML.NodeElement $ namedElement commentContentTag [XML.NodeContent $ XML.ContentText "hi
"],
+ XML.NodeElement $ namedElement commentDateTag [XML.NodeContent $ XML.ContentText "2017-09-02 21:28:46"]
+ ]
+ expectedDateNoAuthor =
+ "Is this thing on?
\n\n\n\
+ \\n\
+ \"
+
+ noDateAuthor =
+ testCase
+ "comments with no \"published\" date but with an author"
+ (dpBody (distill True (createInput commentNoDateAuthor)) @?= expectedNoDateAuthor)
+ commentNoDateAuthor =
+ namedElement
+ commentTag
+ [ XML.NodeElement $
+ namedElement
+ commentContentTag
+ [XML.NodeContent $ XML.ContentText "Here's the thing: …
"],
+ XML.NodeElement $
+ namedElement commentAuthorTag [XML.NodeContent $ XML.ContentText "Terry Jones"]
+ ]
+ expectedNoDateAuthor =
+ "Is this thing on?
\n\n\n\
+ \\n\
+ \"
+
+ dateAuthor =
+ testCase
+ "comments with a \"published\" date and an author"
+ (dpBody (distill True (createInput commentDateAuthor)) @?= expectedDateAuthor)
+ commentDateAuthor =
+ namedElement
+ commentTag
+ [ XML.NodeElement $
+ namedElement
+ commentContentTag
+ [XML.NodeContent $ XML.ContentText "It sure is!
"],
+ XML.NodeElement $
+ namedElement
+ commentDateTag
+ [XML.NodeContent $ XML.ContentText "2017-09-02 21:28:46"],
+ XML.NodeElement $
+ namedElement
+ commentAuthorTag
+ [XML.NodeContent $ XML.ContentText "Elizabeth Keyes"]
+ ]
+ expectedDateAuthor =
+ "Is this thing on?
\n\n\n\
+ \\n\
+ \"
+
+usesTheFirstCommentAuthorTag :: TestTree
+usesTheFirstCommentAuthorTag =
+ testCase
+ "uses the first wp:comment_author tag"
+ (dpBody (distill True input) @?= expected)
+ where
+ input =
+ (RSS.nullItem "Testing...")
+ { RSS.rssItemOther =
+ [ namedElement
+ contentTag
+ [XML.NodeContent $ XML.ContentText "Check this out!
"],
+ namedElement
+ commentTag
+ [ XML.NodeElement $ namedElement commentContentTag [XML.NodeContent $ XML.ContentText "Cool!
"],
+ XML.NodeElement $ namedElement commentAuthorTag [XML.NodeContent $ XML.ContentText "Alexander Batischev"],
+ XML.NodeElement $ namedElement commentAuthorTag [XML.NodeContent $ XML.ContentText "John Doe"]
+ ]
+ ]
+ }
+
+ expected =
+ "Check this out!
\n\n\n\
+ \\n\
+ \"
+
+turnsIncorrectDatesIntoEpochStart :: TestTree
+turnsIncorrectDatesIntoEpochStart =
+ testGroup
+ "turns incorrect \"published\" dates into Unix epoch start date"
+ [ testCase (T.unpack date) (dpDate (distill False (createInput date)) @?= expected)
+ | date <-
+ [ "First of April",
+ "2020.07.30",
+ "2020.07.30 00:01",
+ "2020-07-30 00:01",
+ "2020-07-30T00:01",
+ "2020-07-30T00:01Z",
+ "Sun, 31st July, 2020"
+ ]
+ ]
+ where
+ createInput date =
+ (RSS.nullItem "Testing...")
+ { RSS.rssItemPubDate = Just date
+ }
+
+ expected = fromGregorian 1970 1 1 0 0 0
+
+parsesDates :: TestTree
+parsesDates =
+ testGroup
+ "parses \"published\" dates"
+ [ testCase (T.unpack dateStr) (dpDate (distill False (createInput dateStr)) @?= expected)
+ | (dateStr, expected) <-
+ [ ("Sun, 06 Nov 1994 08:49:37 GMT", fromGregorian 1994 11 6 8 49 37),
+ ("Fri, 31 Jul 2020 22:21:59 EST", fromGregorian 2020 8 1 3 21 59)
+ ]
+ ]
+ where
+ createInput date =
+ (RSS.nullItem "Testing...")
+ { RSS.rssItemPubDate = Just date
+ }
+
+extractsPostTags :: TestTree
+extractsPostTags =
+ testCase
+ "extracts post's tags"
+ (dpTags (distill False input) @?= expected)
+ where
+ input =
+ (RSS.nullItem "Testing tags here")
+ { RSS.rssItemCategories =
+ [ (RSS.newCategory "first tag") {RSS.rssCategoryDomain = Just "post_tag"},
+ (RSS.newCategory "a non-tag") {RSS.rssCategoryDomain = Just "wrong domain"},
+ (RSS.newCategory "second tag") {RSS.rssCategoryDomain = Just "post_tag"},
+ (RSS.newCategory "another non-tag") {RSS.rssCategoryDomain = Nothing},
+ (RSS.newCategory "third tag") {RSS.rssCategoryDomain = Just "post_tag"}
+ ]
+ }
+
+ expected = ["first tag", "second tag", "third tag"]
+
+extractsPostCategories :: TestTree
+extractsPostCategories =
+ testCase
+ "extracts post's categories"
+ (dpCategories (distill False input) @?= expected)
+ where
+ input =
+ (RSS.nullItem "Testing categories here")
+ { RSS.rssItemCategories =
+ [ (RSS.newCategory "essays") {RSS.rssCategoryDomain = Just "category"},
+ (RSS.newCategory "a non-category") {RSS.rssCategoryDomain = Just "wrong domain"},
+ (RSS.newCategory "traveling") {RSS.rssCategoryDomain = Just "category"},
+ (RSS.newCategory "another non-category") {RSS.rssCategoryDomain = Nothing}
+ ]
+ }
+
+ expected = ["essays", "traveling"]
diff --git a/tools/hakyll-convert.hs b/tools/hakyll-convert.hs
deleted file mode 100644
--- a/tools/hakyll-convert.hs
+++ /dev/null
@@ -1,144 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE OverloadedStrings #-}
-
-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 Data.Time.Format (formatTime, defaultTimeLocale)
-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 Hakyll.Convert.OutputFormat
-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
- -- underscore will be turned into a dash when generating a commandline
- -- option
- , output_format :: T.Text
- , format :: InputFormat
- , extract_comments :: Bool
- }
- deriving (Show, Data, Typeable)
-
-parameters :: FilePath -> Config
-parameters p = modes
- [ Config
- { feed = def &= argPos 0 &= typ "ATOM/RSS FILE"
- , outputDir = def &= argPos 1 &= typDir
- , output_format = "%o" &= help outputFormatHelp
- , format = Blogger &= help "blogger or wordpress"
- , extract_comments = False &= help "Extract comments (Blogger only)"
- } &= help "Save blog posts Blogger feed into individual posts"
- ] &= program (takeFileName p)
-
-outputFormatHelp = unlines [
- "Output filenames format (without extension)"
- , "Default: %o"
- , "Available formats:"
- , " %% - literal percent sign"
- , " %o - original filename (e.g. 2016/01/02/blog-post)"
- , " %s - original slug (e.g. \"blog-post\")"
- , " %y - publication year, 2 digits"
- , " %Y - publication year, 4 digits"
- , " %m - publication month"
- , " %d - publication day"
- , " %H - publication hour"
- , " %M - publication minute"
- , " %S - publication second"
- ]
-
--- ---------------------------------------------------------------------
---
--- ---------------------------------------------------------------------
-
-main = do
- p <- getProgName
- config <- cmdArgs (parameters p)
-
- let ofmt = output_format config
-
- if not (T.null ofmt || validOutputFormat ofmt)
- then fail $ "Invalid output format string: `" ++ T.unpack (output_format config) ++ "'"
- else 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 (extract_comments config)
-
-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 = T.unpack $ fromJust $ formatPath (output_format cfg) post
- --
- formatTitle (Just t) = t
- formatTitle Nothing =
- "untitled (" <> T.unwords firstFewWords <> "…)"
- where
- firstFewWords = T.splitOn "-" . T.pack $ takeFileName postPath
- formatDate = T.pack . formatTime defaultTimeLocale "%FT%TZ" --for hakyll
- formatTags = T.intercalate ","
- formatBody = id
" - , "On ", pubdate, ", ", author, " wrote:" - , "
" ] - , "