Helper.hs

{-# LANGUAGE NoMonomorphismRestriction#-}
{-# LANGUAGE NoImplicitPrelude #-}

module Bamboo.Helper where

import Bamboo.Helper.ByteString
import Bamboo.Helper.PreludeEnv hiding (at)
import Bamboo.Helper.Translation
import Bamboo.Type
import Bamboo.Type.Reader
import Bamboo.Type.StaticWidget hiding (name, body, reader)
import Control.Monad (liftM2)
import Data.Default
import Data.Maybe
import System.Directory
import System.FilePath.Posix hiding ((<.>))
import System.IO as IO
import Text.XHtml.Strict hiding (p, meta, body, select, name)
import qualified Bamboo.Type.Theme as Theme
import qualified Prelude as P
import qualified Text.XHtml.Strict as Html

gt :: (Ord a) => a -> a -> Bool
gt = (P.>)

ffmap :: (Functor f, Functor f1) => (a -> b) -> f1 (f a) -> f1 (f b)
ffmap f = fmap (fmap f)
(^^) :: (Functor f, Functor f1) => f1 (f a) -> (a -> b) -> f1 (f b)
(^^) x f = fmap (fmap f) x

parse_config :: String -> IO Assoc
parse_config x = do
  s <- read_file x
  s
    .filter_comment
    .lines.map strip
    .map (split "\\s*=\\s*")
    .map fill_snd_blank
    .map tuple2
    .return
  where
    fill_snd_blank [y] = [y,""]
    fill_snd_blank xs = xs


write_config :: FilePath -> Assoc -> IO ()
write_config s xs = 
  xs.map(\(x, y) -> x ++ " = " ++ y) .join "\n" .write_file s

-- html
empty_html :: Html
empty_html = toHtml ""

-- generic
show_data :: (Show a) => a -> [Char]
show_data = show > snake_case

ifM :: (Monad m) => m Bool -> m b -> m b -> m b
ifM p t f  = p >>= (\p' -> if p' then t else f)

parse_boolean :: String -> Bool
parse_boolean = belongs_to ["true", "1", "y", "yes", "yeah"]

mkdir :: String -> IO ()
mkdir = u2b > createDirectory

-- type SC = String -> String
type SIO = String -> IO ()

take_directory :: SC
take_directory = u2b > takeDirectory > b2u

with_file :: String -> IOMode -> (Handle -> IO a) -> IO a
with_file s m f = IO.withFile (s.u2b) m f

id_to_type :: SC
id_to_type x     = x.split "/" .first

id_to_resource :: SC
id_to_resource x = x.split "/" .tail.join "/"

read_data :: (Read a) => String -> a
read_data s   = s.camel_case.read

read_data_list :: (Read a) => [String] -> [a]
read_data_list xs = xs.map read_data

take_extension :: SC
take_extension = takeExtension --  > split "\\." > last

take_known_extension :: SC
take_known_extension s
  | ext.belongs_to exts = ext
  | otherwise = ""
  where 
    ext = s.take_extension
    exts = readers.only_snd.join'

drop_known_extension :: SC
drop_known_extension s
  | s.take_extension.belongs_to exts = dropExtension s
  | otherwise = s
  where exts = readers.only_snd.join'

remove_trailing_slash :: SC
remove_trailing_slash s = if s.last.is '/' then s.init else s

-- config
parse_list :: String -> [String]
parse_list s = s.split "," .map strip .reject null

static_config :: Config
static_config = purify $ do
  return def
  >>= set_blog_title               ( for_s BlogTitle                       )
  >>= set_blog_subtitle            ( for_s BlogSubtitle                    )
  >>= set_host_name                ( for_s HostName                        )
  >>= set_author_email             ( for_s AuthorEmail                     )
  >>= set_per_page                 ( for_i PerPage                         )
  >>= set_root                     ( for_s Root ^^ clean_path              )
  >>= set_navigation               ( for_l Navigation ^^ (home_nav :)      )
  >>= set_bamboo_url               ( for_s BambooUrl                       )
  >>= set_sidebar                  ( for_l Sidebar ^^ load_sidebar         )
  >>= set_footer                   ( for_s Footer ^^ load_footer           )
  >>= set_favicon                  ( for_s Favicon                         )
  >>= set_analytics_account_id     ( for_s AnalyticsAccountId              )
  >>= set_extensions               ( for_l Extensions ^^ read_data_list    )
  >>= set_theme                    ( for_s Theme >>= get_theme             )
  >>= set_post_date_format         ( for_s PostDateFormat                  )
  >>= set_comment_date_format      ( for_s CommentDateFormat               )
  >>= set_url_date_format          ( for_s UrlDateFormat                   )
  >>= set_url_date_matcher         ( for_s UrlDateMatcher                  )
  >>= set_url_title_subs           ( for_s UrlTitleSubs ^^ (as_l > read)   )
  >>= set_url_date_title_seperator ( for_s UrlDateTitleSeperator           )
  >>= set_cut                      ( for_s Cut                             )
  >>= set_summary_for_root         ( for_b SummaryForRoot                  )
  >>= set_summary_for_tag          ( for_b SummaryForTag                   )
  >>= set_summary_for_rss          ( for_b SummaryForRss                   )
  >>= set_picture_prefix           ( for_s PicturePrefix                   )
  >>= set_number_of_latest_posts   ( for_i NumberOfLatestPosts             )
  >>= set_use_cache                ( for_b UseCache                        )
  where
    user_config = parse_config $ def.config_uri
    
    for x = user_config ^ lookup (x.show_data)
    
    for_s = for
    for_i = for > (^^ read)
    for_l = for > (^^ parse_list)
    for_b = for > (^^ parse_boolean)
    
    clean_path user_root
      | user_root.belongs_to ["/", ""]  = "/"
      | otherwise =  user_root.("/" /).remove_trailing_slash
    
    load_sidebar xs = xs
      .map (def.sidebar_uri /)
      .select (file_exist > purify )
      .map load_widget
    
    load_widget = read_static_widget def > purify

    load_footer s = s
      .(def.footer_uri / ) 
      .(\x -> if x.file_exist.purify then Just $ load_widget x else Nothing)
    
    as_l s = "[" ++ s ++ "]"

    get_theme Nothing = return Nothing
    get_theme (Just user_theme_name) =
      let user_theme_uri  = (def.theme_uri / user_theme_name) ++ ".txt"
      in
      
      if user_theme_uri.file_exist.purify
        then
          parse_config user_theme_uri 
            ^ (("name", user_theme_name) : )
            ^ to_theme
            ^ Just
        else return Nothing

    -- helper
    c (Just _) _ y = y
    c Nothing x _ = x

    p = fromJust
    r = return
    
    set_analytics_account_id     v' x = v' >>= \v -> r $ c v x $ x { analytics_account_id     = p v}
    set_author_email             v' x = v' >>= \v -> r $ c v x $ x { author_email             = p v}
    set_bamboo_url               v' x = v' >>= \v -> r $ c v x $ x { bamboo_url               = p v}
    set_blog_subtitle            v' x = v' >>= \v -> r $ c v x $ x { blog_subtitle            = p v}
    set_blog_title               v' x = v' >>= \v -> r $ c v x $ x { blog_title               = p v}
    set_comment_date_format      v' x = v' >>= \v -> r $ c v x $ x { comment_date_format      = p v}
    set_cut                      v' x = v' >>= \v -> r $ c v x $ x { cut                      = p v}
    set_extensions               v' x = v' >>= \v -> r $ c v x $ x { extensions               = p v}
    set_favicon                  v' x = v' >>= \v -> r $ c v x $ x { favicon                  = p v}
    set_footer                   v' x = v' >>= \v -> r $ c v x $ x { footer                   = p v}
    set_host_name                v' x = v' >>= \v -> r $ c v x $ x { host_name                = p v}
    set_navigation               v' x = v' >>= \v -> r $ c v x $ x { navigation               = p v}
    set_number_of_latest_posts   v' x = v' >>= \v -> r $ c v x $ x { number_of_latest_posts   = p v}
    set_per_page                 v' x = v' >>= \v -> r $ c v x $ x { per_page                 = p v}
    set_picture_prefix           v' x = v' >>= \v -> r $ c v x $ x { picture_prefix           = p v}
    set_post_date_format         v' x = v' >>= \v -> r $ c v x $ x { post_date_format         = p v}
    set_root                     v' x = v' >>= \v -> r $ c v x $ x { root                     = p v}
    set_sidebar                  v' x = v' >>= \v -> r $ c v x $ x { sidebar                  = p v}
    set_summary_for_root         v' x = v' >>= \v -> r $ c v x $ x { summary_for_root         = p v}
    set_summary_for_rss          v' x = v' >>= \v -> r $ c v x $ x { summary_for_rss          = p v}
    set_summary_for_tag          v' x = v' >>= \v -> r $ c v x $ x { summary_for_tag          = p v}
    set_theme                    v' x = v' >>= \v -> r $ c v x $ x { theme                    = p v}
    set_url_date_format          v' x = v' >>= \v -> r $ c v x $ x { url_date_format          = p v}
    set_url_date_matcher         v' x = v' >>= \v -> r $ c v x $ x { url_date_matcher         = p v}
    set_url_date_title_seperator v' x = v' >>= \v -> r $ c v x $ x { url_date_title_seperator = p v}
    set_url_title_subs           v' x = v' >>= \v -> r $ c v x $ x { url_title_subs           = p v}
    set_use_cache                v' x = v' >>= \v -> r $ c v x $ x { use_cache                = p v}

db_uri       :: Config -> String
flat_uri     :: Config -> String
public_uri   :: Config -> String
image_uri    :: Config -> String
config_uri   :: Config -> String
sidebar_uri  :: Config -> String
footer_uri   :: Config -> String
post_uri     :: Config -> String
tag_uri      :: Config -> String
comment_uri  :: Config -> String
theme_uri    :: Config -> String
album_uri    :: Config -> String
topic_uri    :: Config -> String
stat_uri     :: Config -> String
cache_uri    :: Config -> String

db_uri      x   =   x.db_id
flat_uri    x   =   x.db_uri        / x.flat_id
public_uri  x   =   x.db_uri        / x.public_id
image_uri   x   =   x.public_uri    / x.image_id
config_uri  x   =   x.flat_uri      / x.config_id     / x.config_file_id
sidebar_uri x   =   x.flat_uri      / x.config_id     / x.sidebar_id
footer_uri  x   =   x.flat_uri      / x.config_id
post_uri    x   =   x.flat_uri      / x.post_id
tag_uri     x   =   x.flat_uri      / x.tag_id
comment_uri x   =   x.flat_uri      / x.comment_id
theme_uri   x   =   x.flat_uri      / x.config_id     / x.theme_id
album_uri   x   =   x.image_uri     / x.album_id
topic_uri   x   =   x.flat_uri      / x.topic_id
stat_uri    x   =   x.flat_uri      / x.stat_id
cache_uri   x   =   x.flat_uri      / x.cache_id


-- Widget
read_static_widget :: Reader -> String -> IO StaticWidget
read_static_widget user_reader s = liftM2 (StaticWidget name) body (return reader) where
  body = s.read_bytestring
  reader = s.take_extension.guess_reader.fromMaybe user_reader
  name = s.takeFileName.drop_known_extension


-- Theme
to_theme :: Assoc -> Theme.Theme
to_theme xs = Theme.Theme
  { Theme.name        = at Theme.Name
  , Theme.container   = at Theme.Container
  , Theme.header      = at Theme.Header
  , Theme.navigation  = at Theme.Navigation
  , Theme.main        = at Theme.Main
  , Theme.sidebar     = at Theme.Sidebar
  , Theme.footer      = at Theme.Footer
  , Theme.css         = at Theme.Css .css_list
  , Theme.js          = at Theme.Js  .js_list
  }
  where
    at s = xs.lookup (s.show_data) .fromJust
    css_list s = s.parse_list.map (\x -> "/theme/" ++ at Theme.Name ++ "/css/" ++ x ++ ".css")
    js_list s  = s.parse_list.map (\x -> "/theme/" ++ at Theme.Name ++ "/js/" ++ x ++ ".js")