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
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))
kibroMain :: IConnection c => (IO c) -> SessionsVar -> IdsVar -> PageList c -> CGI CGIResult
kibroMain getDb ssvar ids ps = do
db <- io $ getDb
(id,session) <- getSession ids ssvar
(params,page) <- pageMatch ps <$> fromMaybe "" <$> getVar "REQUEST_URI"
(session',result) <- runKibro page (KibroSt db session params)
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
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]
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
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)
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 <<$
stylesheet url = thelink ! [rel "stylesheet",thetype "text/css",href url] << ""
io :: MonadIO m => IO a -> m a
io = liftIO