hablo/src/JSON.hs

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

import Article (Article)
import qualified Article (Article(..))
import Blog (Blog)
import qualified Blog (Blog(..), Path(..), Skin(..), Wording(..))
import Control.Monad.Reader (ReaderT, ask)
import Data.Aeson (ToJSON(..), genericToEncoding, defaultOptions, encode)
import Data.ByteString.Lazy (ByteString)
import Data.Map (Map, mapWithKey)
import qualified Data.Map as Map (filter, keys)
import qualified Data.Set as Set (elems, member)
import Data.Text (Text)
import Data.Text.Template (showTemplate)
import GHC.Generics

data ArticleExport = ArticleExport {
      title :: String
    , bodyOffset :: Int
    , metadata :: Map String String
    , tagged :: [String]
  } deriving (Generic)

instance ToJSON ArticleExport where
  toEncoding = genericToEncoding defaultOptions

data PathExport = PathExport {
      articlesPath :: FilePath
    , commentsAt :: Maybe String
    , pagesPath :: Maybe FilePath
  } deriving (Generic)

instance ToJSON PathExport where
  toEncoding = genericToEncoding defaultOptions

data SkinExport = SkinExport {
      previewArticlesCount :: Int
    , previewLinesCount :: Int
  } deriving (Generic)

instance ToJSON SkinExport where
  toEncoding = genericToEncoding defaultOptions

data WordingExport = WordingExport {
      allLink :: Text
    , allPage :: Text
    , allTaggedPage :: Text
    , latestLink :: Text
    , latestPage :: Text
    , latestTaggedPage :: Text
    , tagsList :: Text
  } deriving (Generic)

instance ToJSON WordingExport where
  toEncoding = genericToEncoding defaultOptions

data BlogDB = BlogDB {
      articles :: Map String ArticleExport
    , path :: PathExport
    , skin :: SkinExport
    , tags :: Map String [String]
    , wording :: WordingExport
  } deriving (Generic)

instance ToJSON BlogDB where
  toEncoding = genericToEncoding defaultOptions

export :: Blog -> String -> Article -> ArticleExport
export blog key article = ArticleExport {
      title = Article.title article
    , bodyOffset = Article.bodyOffset article
    , metadata = Article.metadata article
    , tagged = Map.keys . Map.filter (Set.member key) $ Blog.tags blog
  }

exportBlog :: ReaderT Blog IO ByteString
exportBlog = do
  blog <- ask
  return . encode $ BlogDB {
        articles = mapWithKey (export blog) $ Blog.articles blog
      , path = PathExport {
              articlesPath = Blog.articlesPath $ Blog.path blog
            , commentsAt = Blog.commentsAt $ Blog.path blog
            , pagesPath = Blog.pagesPath $ Blog.path blog
          }
      , skin = SkinExport {
              previewArticlesCount = Blog.previewArticlesCount $ Blog.skin blog
            , previewLinesCount = Blog.previewLinesCount $ Blog.skin blog
          }
      , tags = Set.elems <$> Blog.tags blog
      , wording = WordingExport {
              allLink = Blog.allLink $ Blog.wording blog
            , allPage = Blog.allPage $ Blog.wording blog
            , allTaggedPage = showTemplate . Blog.allTaggedPage $ Blog.wording blog
            , latestLink = Blog.latestLink $ Blog.wording blog
            , latestPage = Blog.latestPage $ Blog.wording blog
            , latestTaggedPage = showTemplate . Blog.latestTaggedPage $ Blog.wording blog
            , tagsList = Blog.tagsList $ Blog.wording blog
          }
    }