hablo-1.0.0.0: src/Blog/Skin.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
module Blog.Skin (
      Skin(..)
    , build
  ) where

import Arguments (Arguments)
import qualified Arguments (bannerPath, favicon, cardImage, headPath, previewArticlesCount, previewLinesCount)
import Control.Monad (filterM)
import Data.Aeson (ToJSON(..), (.=), pairs)
import Data.Maybe (listToMaybe)
import Data.Monoid ((<>))
import Files (absoluteLink)
import GHC.Generics (Generic)
import Prelude hiding (head)
import System.Directory (doesFileExist)
import System.FilePath ((</>), (<.>))

data Skin = Skin {
      banner :: Maybe String
    , cardImage :: Maybe FilePath
    , favicon :: Maybe FilePath
    , head :: Maybe String
    , previewArticlesCount :: Int
    , previewLinesCount :: Int
  } deriving Generic

instance ToJSON Skin where
  toEncoding (Skin {previewArticlesCount, previewLinesCount}) = pairs (
        "previewArticlesCount" .= previewArticlesCount
      <> "previewLinesCount" .= previewLinesCount
    )

findImage :: String -> Maybe FilePath -> IO (Maybe FilePath)
findImage _ (Just path) = return . Just $ absoluteLink path
findImage name Nothing =
  fmap absoluteLink . listToMaybe <$> filterM doesFileExist pathsToCheck
  where
    directories = [".", "image", "images", "pictures", "skin", "static"]
    extensions = ["ico", "gif", "jpeg", "jpg", "png", "svg"]
    pathsToCheck = [ dir </> name <.> ext | dir <- directories, ext <- extensions ]

build :: String -> Arguments -> IO Skin
build blogName arguments = do
  banner <- mapM readFile $ Arguments.bannerPath arguments
  cardImage <- findImage blogName $ Arguments.cardImage arguments
  favicon <- findImage "favicon" $ Arguments.favicon arguments
  head <- mapM readFile $ Arguments.headPath arguments
  return $ Skin {
        banner
      , cardImage
      , favicon
      , head
      , previewArticlesCount = Arguments.previewArticlesCount arguments
      , previewLinesCount = Arguments.previewLinesCount arguments
    }