{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}
module Kibro 
    (
      module Network.CGI
    , kibro
    , Kibro, KibroT
    , Page
    , PageList
    , gets
    , con
    , getParams
    , getSess
    , readSess
    , putSess
    , writeSess
    , getSessDef
    , getInputDef
    , readSessDef
    , readInputDef
    , deleteSess
    , outputHtml
    , (<<$)
    , io
    , stylesheet
    )
    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
import Control.Arrow
import Data.Function

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

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

-- TODO: use applicative on mvar
kibroMain :: IConnection c => (IO c) -> SessionsVar -> IdsVar -> PageList c -> CGI CGIResult
kibroMain getDb ssvar ids ps = do
  -- Connect to the database for this session
  db <- io $ getDb
  -- Get or create a new session
  (id,session) <- getSession ids ssvar
  -- Get the page to run
  (params,page) <- pageMatch ps <$> fromMaybe "" <$> getVar "REQUEST_URI"
  -- Run a page, returning a new session and result
  (session',result) <- runKibro page (KibroSt db session params)
  -- Update the session
  io $ modifyMVar_ ssvar (return . M.insert id session')
  --  ...
  return result

pageMatch :: IConnection c => PageList c -> String -> ([String],Page c)
pageMatch ps path = extract $ look $ map (first match) ps where
    match regex = matchRegex (mkRegex regex) path
    look = find (isJust . fst)
    extract = maybe ([],notFound) (first fromJust)

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)

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 }

deleteSess :: (IConnection c) => String -> Kibro c ()
deleteSess k = do st <- get
                  let news = M.delete k (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
    , params  :: [String] }

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), Functor)

instance (Monad m, IConnection c) => Applicative (KibroT m c) where
    pure = return
    (<*>) = ap

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

getParams :: IConnection c => Kibro c [String] 
getParams = gets params

outputHtml :: (HTML a, IConnection c) => a -> Kibro c CGIResult
outputHtml = output . html . showHtmlFragment where
    html c = "<html>" ++ c ++ "</html>"

defGet n = liftM (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 <<$

stylesheet url = thelink ! [rel "stylesheet",thetype "text/css",href url] << ""

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

io :: MonadIO m => IO a -> m a
io = liftIO