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 date) is'
  val = YAML.obj [("title" ##= title), ("posts" ##= is)]


checkTag :: Maybe Text -> PostInfo -> Bool
checkTag Nothing  _ = True
checkTag (Just t) i = t `elem` tags 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



newtype IsoDate = ID Day deriving (Eq, Ord)

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

-- | the front matter info we care about
data PostInfo =
  Info {
    file    :: FilePath,
    title   :: Text,
    date    :: IsoDate,
    tags    :: [Text],
    summary :: Maybe Text
  }

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]

htmlFile :: FilePath -> Text
htmlFile f = Text.pack $ Path.replaceExtension f "html"

rssDate :: IsoDate -> Text
rssDate (ID d) =
  Text.pack $ formatTime defaultTimeLocale "%a, %d %b %Y 00:00:01 UT" d

showDate :: IsoDate -> Text
showDate (ID d) =
  Text.pack $ toLower <$> formatTime defaultTimeLocale "%a %-d %B %Y" d