Application.hs

-- the controller is the most complex module for a reason:
-- models are made as simple and small as possible
-- views are pure functions.

-- a note on encoding:
-- uniform utf-8 enforced by custom io wrapper

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

module Bamboo.Controller.Application where

import qualified Data.Map as Map

-- env
import Bamboo.Helper.Env hiding (tag, uri)
import Bamboo.Helper.StateHelper hiding (only_for)
import qualified Bamboo.Type.State as S
import qualified Bamboo.Config.Global as G
import qualified Bamboo.Type.Pager as Pager
import Bamboo.Type.Cache
import Bamboo.Type.Extension
import Hack
import Hack.Contrib.Response (redirect)

-- model
import qualified Bamboo.Model.Post as Post
import qualified Bamboo.Model.Static as Static
import qualified Bamboo.Model.Tag as Tag
import qualified Bamboo.Model.Comment as Comment
import qualified Bamboo.Model.Counter as Counter

-- view
import qualified Bamboo.View.Control.Post as PostV
import qualified Bamboo.View.Control.Static as StaticV
import qualified Bamboo.View.Control.Tag as TagV
import qualified Bamboo.View.Control.Search as SearchV
import qualified Bamboo.View.Widget.RSS as RSSV

import qualified Data.ByteString.Lazy.Char8 as L


-- helpers
blog_regex       = G.url_date_matcher
init_post tags x = x.Tag.fill_tag tags.Comment.fill_comment_size
tag_list         = list

-- main controller
paths = 
  [ ("$"                  ,index                                  )
  , ("(\\?.+)?$"          ,index                                  )
  , ("rss.xml$"           ,index_feed                             )
  , (blog_regex           ,blog                                   )
  , ("static/."           ,static                                 )
  , ("tag/.*/rss.xml$"    ,tag_feed                               )
  , ("tag/."              ,tag                                    )
  , ("search"             ,only_for Search   $ search             )
  , ("comment/create"     ,only_for Comment  $ comment_create     )
  ] 
  .map_fst ((G.root /) > ("^" ++))

only_for ext x = if has_extension ext then x else const not_found

default_state = do
  latest_posts <- Post.latest G.number_of_latest_posts
  def { S.latest_posts = latest_posts } .return

index :: Application
index env = do
  posts <- list
  let p = posts.paginate env
  tags <- tag_list
  let nav = if p.Pager.current == 1 then home_nav else no_navigation
  s <- default_state
  let state = s { S.uid = G.post_id, S.tags = tags, S.pager = p, S.nav_location = nav }
  
  -- output_html "hi"
  posts.for_current_page p .mapM (init_post tags) 
    >>= cache (g tags) (f state)
    >>= output_plain_html
  where
    g tags xs = liftM2 L.append 
      (Post.etag_post_list xs) (Tag.etag_tag_list tags)
    f state = PostV.list state > render_html > return

index_feed _ = do
  posts <- list
  posts.take G.number_of_latest_posts .cache g f
    >>= output_plain_html
  where
    g = Post.etag_post_list
    f xs = xs.RSSV.rss "" "" .show.u2bs.return

blog env = do
  let id = env .uri .Post.uri_to_id
  if has_extension Counter then Counter.hit id else return ()
  blog <- get id
  comments <- list_for id
  tags <- tag_list

  test_data <- S.mk_human_test
  s <- default_state
  let state = s { S.uid = id, S.tags = tags, S.resource_title = blog.resource_title, S.human_test_data = test_data }
  blog.init_post tags 
    >>= cache (g tags) (f state comments)
    >>= output_plain_html
  where
    g tags x = liftM2 L.append 
      (Post.etag_post x) (Tag.etag_tag_list tags)
    f state comments x = x.return ^ PostV.view state comments ^ render_html

static env = do
  let id = env.uri
  static_page <- get id
  tags <- tag_list
  let nav_id = static_page.Static.uid.id_to_resource
  let nav   = if nav_id.belongs_to G.navigation then nav_id else no_navigation
  s <- default_state
  let state = s { S.uid = id, S.tags = tags, S.nav_location = nav, S.resource_title = static_page.resource_title }
  static_page.cache (g tags) (f state) >>= output_plain_html
  where
    g tags x = liftM2 L.append 
      (etag_data (x.Static.uid)) (Tag.etag_tag_list tags)
    f state x = x.return ^ StaticV.view state ^ render_html


tag env = do
  let id = env.uri
  tags <- tag_list
  let tag_name = Tag.get_name id
  case Tag.tag_map' tags .Map.lookup tag_name of
    Nothing -> not_found
    Just post_set -> do
      posts <- post_set.to_list.rsort.mapM (bs2u > get) >>= mapM (init_post tags)
      let p = posts.paginate env
      s <- default_state
      let state = s { S.uid = id, S.tags = tags, S.pager = p, S.resource_title = tag_name.Tag.resource_title_from_name }
      posts.for_current_page p .return
        >>= cache (g tags) (f state)
        >>= output_plain_html
      where
        g tags xs = liftM2 L.append 
          (Post.etag_post_list xs) (Tag.etag_tag_list tags)
        f state xs = xs.TagV.view state.render_html.return
        
tag_feed env = do
  let id = env .uri .split "/" .init .join "/"
  tags <- tag_list
  let tag_name = Tag.get_name id
  case Tag.tag_map' tags .Map.lookup tag_name of
    Nothing -> not_found
    Just post_set -> do
      posts <- post_set.to_list.rsort.mapM (bs2u > get) ^ map (Tag.fill_tag tags)
      posts.take (G.number_of_latest_posts). cache g f >>= output_plain_html
      where
        g = Post.etag_post_list
        f xs = xs.RSSV.rss G.tag_id tag_name.show.u2bs.return
                
search env = do
  let s = env.param_with_default "s" ""
  posts <- Post.search s

  let p = posts.paginate env
  tags <- tag_list
  let query = env.uri
  s' <- default_state
  let state = s' { S.uid = query, S.pager = p, S.tags = tags, S.resource_title = query }

  posts.mapM (init_post tags) >>= \x -> x.SearchV.view state s.output_html


comment_create env = do
  let post_id = env.input_with_default (show_data Comment.PostId) (G.post_id / "nothing")
  exists <- (G.flat_uri / post_id) .file_exist
  let valid_path = equalFilePath G.post_id (takeDirectory post_id) 
  let checked = check_create env
  
  if [checked, valid_path, exists].and
      then
        env.inputs.Comment.create_comment
      else
        return ()
  return $ def.redirect ((post_id.Post.id_to_uri.u2b).urlEncode) Nothing

get_input_data s env = env.get_input (s.show_data)

check_human = do
  [l, r, op, h] <- [Comment.LeftNumber, Comment.RightNumber, Comment.Operator, Comment.HumanHack].mapM get_input_data ^ map fromJust
  return $ S.simple_eval (l.read) (r.read) (op.S.read_op) .is (h.read)

-- create helper, should be refactored to some common aspect
check_create env =
  [ validate Comment.Author       ( length > (`gt` 0))
  , validate Comment.AuthorLink   ( const True)
  , validate Comment.Body         ( length > (`gt` 0))
  , validate Comment.EmptyField   ( empty )
  , validate Comment.LeftNumber   ( belongs_to (S.nums.map show))
  , validate Comment.RightNumber  ( belongs_to (S.nums.map show))
  , validate Comment.Operator     ( belongs_to (S.ops.map S.display_op))
  , validate Comment.HumanHack    ( belongs_to (S.nums.map show))
  , check_human
  ] .map (send_to env) .and


validate s f env =
  let maybe_s = get_input_data s env in
  case maybe_s of
    Nothing -> False
    Just v  -> f v