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.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

-- 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


-- 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.mapM (init_post tags) ^ PostV.list state >>= output_html

index_feed _ = do
  posts <- list
  posts.RSSV.rss "" "" .output_html

blog env = do
  let id = env .uri .Post.uri_to_id
  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) ^ PostV.view state comments >>= output_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 }
  StaticV.view state static_page .output_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 (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.TagV.view state.output_html
      
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 get ^ map (Tag.fill_tag tags)
      posts.RSSV.rss G.tag_id tag_name .output_html
                
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