blog/blog-meta/post-lists.hs

import qualified Data.ByteString.Lazy as LazyBS
import Data.Function ((&))
import Data.List (sortBy)
import Data.Ord (comparing)
import Data.Text (Text)
import qualified Data.Text as Text
import Misc
import qualified YAML
import YAML ((.:), (.:?), (.!=), (##=))
import qualified System.Console.GetOpt as GetOpt
import qualified System.FilePath.Find as Find
import qualified System.FilePath as Path

-- | generates a yaml list for a list of posts; either for a given tag, or all
-- posts. the posts are in chronological order, newest first.
--
-- example (exact yaml layout not guaranteed; whatever @HsYAML@ feels
-- like doing):
--
-- @
-- ---
-- title: "posts tagged ‘ATS’"
-- posts:
--   - file: fib.html
--     title: fibonacci in maude and ats
--     date: mon 24 october 2022
--     date-rss: Mon, 24 Oct 2022 00:00:01 UT
--     tags: [computer, maude, ATS]
--     summary: fibonacci numbers in the languages maude and ATS.
--   - file: ats.html
--     title: a little ats program
--     date: fri 16 september 2022
--     date-rss: Fri, 16 Sep 2022 00:00:01 UT
--     tags: [computer, ATS, cool languages]
--     summary: >
--       a little program in a little-known, little-documented language
--       called ATS.
-- ...
-- @
main :: IO ()
main = do
  Opts {..} <- getOptions
  files <- Find.findL True (pure True) (Find.extension Find.==? ".md") dir
  infos <- filter (checkTag tag) <$> traverse (getInfo dir) files
  let content = makeContent title infos
  case out of
    Nothing -> LazyBS.putStr content
    Just fn -> LazyBS.writeFile fn content

makeContent :: Text -> [PostInfo] -> LazyBS.ByteString
makeContent title is' = "---\n" <> YAML.encode1 val <> "...\n" where
  is = sortBy (flip $ comparing date) is'
  val = YAML.obj [("title" ##= title), ("posts" ##= is)]


-- | whether a post has the given tag
checkTag :: Maybe Text -> PostInfo -> Bool
checkTag Nothing  _ = True
checkTag (Just t) i = t `elem` tags i


-- | command line options
data Options =
  Opts {
    -- | first argument: directory containing the .md files
    dir :: !FilePath,
    -- | second argument: title for the output page
    title :: !Text,
    -- | @-t, --tag@: filter by tag
    tag :: !(Maybe Text),
    -- | @-o, --out@: write output to file (otherwise stdout)
    out :: !(Maybe FilePath)
  }

getOptions :: IO Options
getOptions = getOptionsWith hdr defOpts optDescrs where
  hdr prog = "usage: " <> prog <> " [OPTION...] DIR TITLE\n\
             \  --- get info about posts in DIR and use given title"

  optDescrs :: [GetOpt.OptDescr (Options -> Options)]
  optDescrs =
    [GetOpt.Option "t" ["tag"]
      (GetOpt.ReqArg (\t o -> o {tag = Just $ Text.pack t}) "TAG")
      "list only posts with the given tag",
     GetOpt.Option "o" ["out"]
      (GetOpt.ReqArg (\f o -> o {out = Just f}) "FILE")
      "write output to FILE"]

  defOpts :: [String] -> Maybe Options
  defOpts [dir, Text.pack -> title] =
    Just $ Opts {dir, title, tag = Nothing, out = Nothing}
  defOpts _ = Nothing


-- | the front matter info we care about
data PostInfo =
  Info {
    -- | the (input) file name, relative to 'dir' in options
    file    :: FilePath,
    title   :: Text,      -- ^ post @title@
    date    :: IsoDate,   -- ^ post @date@
    tags    :: [Text],    -- ^ post @tags@
    summary :: Maybe Text -- ^ post @summary@ (optional)
  }

-- | @getInfo dir file@: read the front matter of @dir/file@
--
-- the 'file' field is just the filename, with @dir@ removed
getInfo :: FilePath -> FilePath -> IO PostInfo
getInfo dir file = do
  yaml <- YAML.readHeader file
  let dirs = Path.splitPath dir
  let file' = Path.joinPath $ drop (length dirs) $ Path.splitPath file
  unwrap file $ YAML.parseEither $
    yaml & YAML.withMap "title, date, tags, summary?" \m ->
      Info <$> pure file'
           <*> m .:  "title"
           <*> m .:  "date"
           <*> m .:  "tags" .!= []
           <*> m .:? "summary"

instance YAML.ToYAML PostInfo where
  toYAML (Info {..}) = YAML.obj
    ["date"     ##= showDate date,
     "date-rss" ##= rssDate date,
     "title"    ##= title,
     "tags"     ##= tags,
     "file"     ##= htmlFile file,
     "summary"  ##= summary]

-- | replace @.md@ (or whatever) extension with @.html@
htmlFile :: FilePath -> Text
htmlFile f = Text.pack $ Path.replaceExtension f "html"