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
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)
notFound :: IConnection c => Page c
notFound = getVar "REQUEST_URI" >>= outputNotFound . fromMaybe ""
type PageList c = [(String, Page c)]
type Page c = Kibro c CGIResult
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]
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
outputHtml :: (HTML a, IConnection c) => a -> Kibro c CGIResult
outputHtml = output . showHtml
defGet n = (fromMaybe n <$>)
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
ahref url = hotlink url . toHtml
(<<$) :: (HTML a) => (Html -> b) -> a -> b
a <<$ b = a << b
infixr 0 <<$
io = liftIO