{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}
module Kibro 
    (
      module Network.CGI
    , module Database.HDBC
    , module Text.XHtml.Strict
    , kibro
    , Kibro
    , getSess
    , readSess
    , putSess
    , writeSess
    , getSessDef
    , getInputDef
    , readSessDef
    , readInputDef
    , outputHtml
    , (<<$)
    )
    where

import Network.CGI hiding (Html)
import Network.FastCGI
import Network.CGI.Monad
import qualified Data.Map as M
import Control.Monad.State
import Database.HDBC
import Control.Concurrent
import Text.Regex
import Data.Maybe
import Data.List
import System.Random
import Safe
import Text.XHtml.Strict
import Control.Applicative

------------------------------------------------------------------------------
-- Main Kibro entry point
--

kibro :: IConnection c => IO c -> PageList c -> IO ()
kibro getDb ps = do
  ss  <- newMVar M.empty
  ids <- newMVar [0..]
  db  <- getDb
  runFastCGIConcurrent' forkIO 1000 (kibroMain ss ids ps db)

kibroMain :: IConnection c => SessionsVar -> IdsVar -> PageList c -> c -> CGI CGIResult
kibroMain ssvar ids ps db = do
  (id,s) <- getSession ids ssvar
  path <- liftM (fromMaybe "") $ getVar "REQUEST_URI"
  let p = maybe notFound snd (find (see path) ps)
  (sess,res) <- runKibro p (KibroSt db s)
  liftIO $ modifyMVar_ ssvar (\s -> return $ M.insert id sess s)
  return res
      where see path = match . flip matchRegex path . mkRegex . fst
            match = maybe False (const True)

runKibro :: IConnection c => Kibro c CGIResult -> KibroSt c -> CGI (Session,CGIResult)
runKibro p st = evalStateT (unKibro (getSess p)) st where
    getSess a = do r <- a
                   ss <- gets session
                   return (ss,r)

-- TODO: make proper 404
notFound :: IConnection c => Page c
notFound = getVar "REQUEST_URI" >>= outputNotFound . fromMaybe ""

type PageList c = [(String, Page c)]
type Page c = Kibro c CGIResult

------------------------------------------------------------------------------
-- Sessions
--
getSession :: IdsVar -> SessionsVar -> CGI (SessID,Session)
getSession ids ssvar = readCookie "sid" >>= maybe new fromId where
    fromId id = do ss <- io $ readMVar ssvar
                   maybe new (\s -> return (id,s)) (M.lookup id ss)
    new = newSession ids ssvar

newSession :: IdsVar -> SessionsVar -> CGI (SessID,Session)
newSession ids ssvar = do
  id <- newId ids
  io $ modifyMVar ssvar $ \m ->
      let e = M.insert "key" (show id) M.empty 
      in return (M.insert id e m,(id,e))

newId :: IdsVar -> CGI SessID
newId ids = do
  id <- io $ modifyMVar ids $ \(x:xs) -> do
              r <- getStdRandom random
              return (xs,(x,r))
  setCookie (newCookie "sid" $ show id) { cookiePath = Just "/" }
  return id

getSess :: IConnection c => String -> Kibro c (Maybe String)
getSess k = do s <- gets session
               return $ M.lookup k s

readSess :: (IConnection c, Read a) => String -> Kibro c (Maybe a)
readSess k = getSess k >>= return . (>>= readMay)

putSess :: (IConnection c) => String -> String -> Kibro c ()
putSess k v = do st <- get
                 let news = M.insert k v (session st)
                 put st { session = news }

writeSess :: (IConnection c, Show a) => String -> a -> Kibro c ()
writeSess k v = putSess k (show v)
  
type SessionsVar = MVar Sessions
type IdsVar = MVar [Integer]

------------------------------------------------------------------------------
-- The Kibro monad
--

-- | A state containing the current session and a database connection.
data KibroSt c = KibroSt
    { con     :: c
    , session :: Session }

type Session = M.Map String String
type Sessions = M.Map SessID Session
type SessID = (Integer,Int)

newtype KibroT m c a = Kibro { unKibro :: (StateT (KibroSt c) (CGIT m) a) }
    deriving (Monad, MonadIO, MonadState (KibroSt c))

instance IConnection c => MonadCGI (KibroT IO c) where
    cgiAddHeader n v = Kibro $ lift $ cgiAddHeader n v
    cgiGet x = Kibro $ lift $ cgiGet x

type Kibro c a = KibroT IO c a

------------------------------------------------------------------------------
-- Kibro utilities
--

outputHtml :: (HTML a, IConnection c) => a -> Kibro c CGIResult
outputHtml = output . showHtml

defGet n = (fromMaybe n <$>)

-- Simply utilities
readSessDef  s v = defGet v $ readSess s
readInputDef s v = defGet v $ readInput s
getSessDef   s v = defGet v $ getSess s
getInputDef  s v = defGet v $ getInput s

-- HTML utilities
ahref url = hotlink url . toHtml

-- | Nice operator for removing parentheses.
(<<$) :: (HTML a) => (Html -> b) -> a -> b
a <<$ b = a << b
infixr 0 <<$

------------------------------------------------------------------------------
-- Utilities for this file
--

io = liftIO