hablo/src/JSON.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
module JSON (
    generate
  ) where

import Article (Article)
import qualified Article (Article(..))
import Blog (Blog)
import qualified Blog (Blog(..), get)
import Control.Monad.IO.Class (MonadIO(..))
import Control.Monad.Reader (ReaderT, ask)
import Data.Aeson (ToJSON(..), genericToEncoding, defaultOptions, encode)
import Data.ByteString.Lazy (writeFile)
import Data.Map (Map, (!), foldlWithKey, mapKeys, mapWithKey)
import qualified Data.Map as Map (empty, filter, insert, keys)
import qualified Data.Set as Set (elems, member)
import System.FilePath.Posix ((</>), (<.>))
import System.Posix.Files (modificationTime)
import System.Posix.Types (EpochTime, FileID)
import Prelude hiding (writeFile)
import GHC.Generics

type ArticleID = Int

data ArticleExport = ArticleExport {
      source :: String
    , title :: String
    , date :: EpochTime
    , tagged :: [String]
  } deriving (Generic)

instance ToJSON ArticleExport where
  toEncoding = genericToEncoding defaultOptions

data BlogDB = BlogDB {
      articles :: Map ArticleID ArticleExport
    , tags :: Map String [ArticleID]
  } deriving (Generic)

instance ToJSON BlogDB where
  toEncoding = genericToEncoding defaultOptions

remap :: (Ord k1, Enum k2, Ord k2) => Map k1 a -> Map k1 k2
remap =
  snd . foldlWithKey (\(i, tempMap) key _ -> (succ i, Map.insert key i tempMap)) (toEnum 0, Map.empty)

export :: Blog -> FileID -> Article -> ArticleExport
export blog fileID article = ArticleExport {
      source = "/" </> Article.urlPath article <.> "md"
    , title = Article.title article
    , date = modificationTime $ Article.fileStatus article
    , tagged = Map.keys . Map.filter (Set.member fileID) $ Blog.tags blog
  }

exportBlog :: ReaderT Blog IO BlogDB
exportBlog = do
  blog <- ask
  let reindex = remap $ Blog.articles blog
  return $ BlogDB {
        articles = mapKeys (reindex !) $ mapWithKey (export blog) (Blog.articles blog)
      , tags = fmap (reindex !) . Set.elems <$> Blog.tags blog
    }

generate :: ReaderT Blog IO ()
generate = do
  path <- Blog.get Blog.root
  jsonContent <- exportBlog
  liftIO $ writeFile (path </> "articles.json") (encode jsonContent)