blog/blog-meta/post-lists.hs

import qualified Data.ByteString.Lazy as LazyBS
import Data.Char (toLower)
import Data.Function ((&))
import Data.List (sortBy)
import Data.Ord (comparing)
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Time
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

main :: IO ()
main = do
  Opts title dir tag out <- 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 infoDate) is'
  val = YAML.obj [("title" ##= title), ("posts" ##= is)]


checkTag :: Maybe Text -> PostInfo -> Bool
checkTag Nothing  _ = True
checkTag (Just t) i = t `elem` infoTags i


data Options =
  Opts {
    optsTitle :: !Text,
    optsDir   :: !FilePath,
    optsTag   :: !(Maybe Text),
    optsOut   :: !(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 {optsTag = Just $ Text.pack t}) "TAG")
    "list only posts with the given tag",
   GetOpt.Option "o" ["out"]
    (GetOpt.ReqArg (\f o -> o {optsOut = Just f}) "FILE")
    "write output to FILE"]

defOpts :: [String] -> Maybe Options
defOpts [dir, title] =
  Just $ Opts {optsDir = dir, optsTitle = Text.pack title,
               optsTag = Nothing, optsOut = Nothing}
defOpts _ = Nothing


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"

-- | the front matter info we care about
data PostInfo =
  Info {
    infoFile  :: FilePath,
    infoTitle :: Text,
    infoDate  :: BlogDate,
    infoTags  :: [Text],
    infoSummary :: Maybe Text
  }

instance YAML.ToYAML PostInfo where
  toYAML (Info file title date tags summary) = YAML.obj
    [("date"     ##= date),
     ("date-rss" ##= toRss date),
     ("title"    ##= title),
     ("tags"     ##= tags),
     ("file"     ##= Text.pack (fixup file)),
     ("summary"  ##= summary)]
    where
      fixup f = Path.replaceExtension f "html"
      toRss (BD d) = RD d

newtype BlogDate = BD Day deriving (Eq, Ord)
newtype RssDate = RD Day deriving (Eq, Ord)

instance YAML.FromYAML RssDate where
  parseYAML = YAML.withStr "YYYY-MM-DD" $
    fmap RD . parseTimeM True defaultTimeLocale "%F" . Text.unpack

instance YAML.ToYAML RssDate where
  toYAML (RD d) = YAML.str $ Text.pack $
    formatTime defaultTimeLocale "%a, %d %b %Y 00:00:01 UT" d

instance YAML.FromYAML BlogDate where
  parseYAML = fmap (\(RD d) -> BD d) . YAML.parseYAML

instance YAML.ToYAML BlogDate where
  toYAML (BD d) = YAML.str $ Text.pack $ map toLower $
    formatTime defaultTimeLocale "%a %-d %B %Y" d