Helper.hs

-- helper module is a central place for reusable functions
-- for this project, more general helpers are usually moved
-- to MPS package, for multi-project usage

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

module Bamboo.Helper.Helper where

import Bamboo.Helper.PreludeEnv
import Network.CGI (urlDecode)

import Text.XHtml.Strict hiding (p, meta, body)
import qualified Text.XHtml.Strict as Html
import Data.Maybe
import qualified Bamboo.Type.Pager as Pager
import Data.List hiding (length)
import qualified Data.List as L 
import Bamboo.Type.Reader
import System.FilePath.Posix hiding ((<.>))
import System.Time
import qualified Prelude as P
import Data.Default
import System.Directory
import Hack
import qualified Hack.Contrib.Request as Request
import Hack.Contrib.Response
import Hack.Contrib.Constants

gt = (P.>)

-- global
parse_config_io s = read_file s ^ (\x -> x.filter_comment.lines.map strip .map (split "\\s*=\\s*") .map fill_snd_blank .map tuple2)
  where fill_snd_blank [x] = [x,""]
        fill_snd_blank xs = xs

parse_config         = parse_config_io > purify
write_config_io s xs = xs.map(\(x, y) -> x ++ " = " ++ y) .join "\n" .write_file s

-- model
take_extension = takeExtension --  > split "\\." > last
take_known_extension s
  | ext.belongs_to exts = ext
  | otherwise = ""
  where 
    ext = s.take_extension
    exts = readers.only_snd.join'

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

meta = (++ ".meta")

image_extensions = ["jpg", "jpeg", "png", "gif"]
is_image x = image_extensions.any (suffix_of x)
suffix_of = flip isSuffixOf

-- controller
raw_uri env = ( env.script_name ++ env.path_info ) .(urlDecode > tail > remove_trailing_slash )

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

params = Request.params > map_fst b2u > map_snd b2u
inputs = Request.inputs > map_fst b2u > map_snd b2u

param_with_default s d env = env .get_param s .fromMaybe d
input_with_default s d env = env .get_input s .fromMaybe d

get_param s env = env .params .lookup s
get_input s env = env .inputs .lookup s

just_param s env = env .get_param s .fromJust
just_input s env = env .get_input s .fromJust

full_paginate per_page total env = Pager.Pager per_page current has_next has_previous next previous where
  current      = env.param_with_default "page" "1" .read
  has_next     = current * per_page < total.from_i
  has_previous = current `gt` 1
  next         = current + 1
  previous     = current + (-1)


for_current_page p xs = xs.drop ((p.Pager.current - 1) * p.Pager.length) .take (p.Pager.length)

no_navigation     = ""
home_nav          = "Home"

-- view
id               = identifier

css_link l       = itag "link" ! [rel "stylesheet", thetype "text/css", href l]
ie_tag x         = ("<!--[if IE]>" ++ x.show ++ "<![endif]-->").primHtml
ie6_tag x        = ("<!--[if lt IE 7]>" ++ x.show ++ "<![endif]-->").primHtml
ie7_tag x        = ("<!--[if IE 7]>" ++ x.show ++ "<![endif]-->").primHtml
js_link l        = itag "script" ! [thetype "text/javascript", src l]
js_src s         = tag "script" ! [thetype "text/javascript"] << s
rss_link l       = itag "link" ! [rel "alternate", thetype "application/rss+xml", href l, title "RSS 2.0"]
favicon_link l   = itag "link" ! [rel "icon", thetype "image/png", href l]
meta_tag         = Html.meta ! [httpequiv "Content-Type", content "text/html; charset=utf-8"]

div_id s         = thediv ! [id s]
div_class s      = thediv ! [theclass s]
div_class_id x y = thediv ! [theclass x, id y]

xml_header = "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n"
output_html x = 
  def 
    .set_status 200
    .set_body (x.show.unescape_unicode_xml.u2b)
    .set_content_type _TextHtmlUTF8
    .return

spaced_url = gsub "/" " / "

empty_html = toHtml ""
html_if p x = if p then x else empty_html

-- config
parse_list s = s.split "," .map strip .reject null
not_found = return $ def { status = 404 }


-- generic
show_data = show > snake_case
ifM p t f  = p >>= (\p' -> if p' then t else f)
parse_boolean = belongs_to ["true", "1", "y", "yes", "yeah"]
mkdir = u2b > createDirectory

-- class
class DataRenderer a where
  render_data :: a -> Html

-- id: /type/resoruce
id_to_type x     = x.split "/" .first
id_to_resource x = x.split "/" .tail.join "/"
  
class (Show a) => Resource a where
  resource_title :: a -> String
  resource_type :: a -> String
  resource_type = show_data

class Markable a where
  markup :: a -> Html
    
class Datable a where
  date :: a -> CalendarTime

class Addressable a where
  uri :: a -> String

-- class Pluggable a where
--   render_plugin :: a -> String

class Gettable a where
  get :: String -> IO a

type Assoc = [(String, String)]
  
class Mappable a where
  from_assoc :: Assoc -> IO a

class Creatable a where
  create :: a -> IO ()

class Listable a where
  list :: IO [a]
  list = return []
  
  list_for :: String -> IO [a]
  list_for = const list
  cheat_list :: IO [a]
  cheat_list = list

class FlatRead a where
  flat_read :: String -> IO a