module Kibro
(
startKibro
, startKibro'
, getValue
, getURIMatch
, getInputDef
, readInputDef
, getSess
, putSess
, deleteSess
, modifySess
, getSessDef
, modifySessDef
, readSess
, writeSess
, modifyRSess
, modifyRSessDef
, stylesheet
, (<<$)
, PageAssign
, ahref
, module Network.CGI)
where
import Control.Exception
import Control.Applicative
import Control.Arrow
import Control.Monad.Reader
import Control.Monad.State
import Control.Concurrent
import Data.List
import Data.Map (Map)
import Data.Maybe
import qualified Data.Map as M
import Foreign.Marshal.Alloc
import Foreign.Storable
import Network.FastCGI
import Network.CGI
import Network.CGI.Monad
import Safe
import System.IO
import System.Random
import Text.RegexPR
import Text.XHtml.Strict
startKibro :: [PageAssign ()] -> IO ()
startKibro = startKibro' () forkOS
startKibro' :: v
-> (IO () -> IO ThreadId)
-> [PageAssign v]
-> IO ()
startKibro' value fork pages = do
ids <- genIds
state <- newMVar (ids,M.empty)
let cgiMain = handleErrors $ runReaderT (kibroCGIMain value pages) state
runFastCGIConcurrent' fork 1000 cgiMain
kibroCGIMain :: v -> [PageAssign v] -> Manager CGIResult
kibroCGIMain value ps = do
var <- ask
(_,sessions) <- liftIO $ readMVar var
(params,page) <- lift $ pageMatch ps <$> fromMaybe "" <$> getVar "REQUEST_URI"
session <- getSession
(session',result) <- lift $ runKibro page (KibroSt session params value var)
maybe (return ()) updateSession session'
return result
runKibro :: Kibro v CGIResult -> KibroSt v -> CGI (Maybe Session,CGIResult)
runKibro p st = evalStateT (unKibro (getSess p)) st where
getSess a = do r <- a
ss <- gets session
return (ss,r)
pageMatch :: [PageAssign v] -> String -> (MatchResult,Page v)
pageMatch ps path = extract $ look $ map (first match) ps where
match regex = matchRegexPR regex path
look = find (isJust . fst)
extract = maybe (undefined,notFound) (first fromJust)
notFound :: Kibro v CGIResult
notFound = getVar "REQUEST_URI" >>= outputNotFound . fromMaybe ""
type Manager = ReaderT SessionState (CGIT IO)
type PageAssign v = (String,Page v)
type Page v = Kibro v CGIResult
type SessionState = MVar ([Integer],Map Integer Session)
data Session = Session
{ sessId :: Integer
, sessValues :: Map String String
} deriving (Eq,Show)
sessionName = "KIBROSESSIONID"
type Kibro = KibroT IO
data KibroSt v = KibroSt { session :: Maybe Session
, match :: MatchResult
, kibroValue :: v
, sessions :: SessionState }
type MatchResult = ((String, (String, String)), [(Int, String)])
newtype KibroT m v a = Kibro { unKibro :: (StateT (KibroSt v) (CGIT m) a) }
deriving (Monad, MonadIO, MonadState (KibroSt v), Functor)
instance Monad m => Applicative (KibroT m v) where
pure = return
(<*>) = ap
instance MonadCGI (KibroT IO v) where
cgiAddHeader n v = Kibro $ lift $ cgiAddHeader n v
cgiGet x = Kibro $ lift $ cgiGet x
updateSession :: Session -> Manager ()
updateSession session@(Session id _) = do
var <- ask
liftIO $ modifyMVar_ var $ \(ids,sessions) -> do
return (ids,M.insert id session sessions)
getSession :: Manager (Maybe Session)
getSession = do
var <- ask
sId <- lift $ readCookie sessionName
(ids,sessions) <- liftIO $ readMVar var
return $ sId >>= flip M.lookup sessions
genIds :: IO [SessionId]
genIds = nub . randomRs (1,1000^(20::Int)) <$> betterStdGen
betterStdGen :: IO StdGen
betterStdGen = alloca $ \p -> do
h <- openBinaryFile "/dev/urandom" ReadMode
hGetBuf h p $ sizeOf (undefined :: Int)
hClose h
mkStdGen <$> peek p
type SessionId = Integer
getValue :: Kibro v v
getValue = gets kibroValue
getURIMatch :: Kibro v MatchResult
getURIMatch = gets match
getInputDef :: String -> String -> Kibro v String
getInputDef k v = fromMaybe v <$> getInput k
readInputDef :: String -> String -> Kibro v String
readInputDef k v = fromMaybe v <$> readInput k
getSessDef :: String -> String -> Kibro v String
getSessDef k v = fromMaybe v <$> getSess k
readSessDef :: (Read a) => String -> a -> Kibro v a
readSessDef k v = fromMaybe v <$> readSess k
modifyRSessDef :: (Read a,Show a) => String -> (a -> a) -> a -> Kibro v a
modifyRSessDef k f v = do
v <- readSessDef k v
let v' = f v
writeSess k v'
return v'
modifyRSess :: (Read a,Show a) => String -> (a -> a) -> Kibro v (Maybe a)
modifyRSess k f = do
v <- readSess k
case v of
Nothing -> return Nothing
Just v -> do writeSess k $ f v; return $ Just v
readSess :: (Read a) => String -> Kibro v (Maybe a)
readSess k = getSess k >>= return . (>>= readMay)
writeSess :: (Show a) => String -> a -> Kibro v ()
writeSess k v = putSess k (show v)
modifySess :: String -> (String -> String) -> Kibro v (Maybe String)
modifySess k f = do
v <- getSess k
case v of
Nothing -> return Nothing
Just v -> do let v' = f v
putSess k v'
return $ Just v'
modifySessDef :: String -> (String -> String) -> String -> Kibro v String
modifySessDef k f v = do
v <- getSessDef k v
let v' = f v
putSess k v'
return $ v'
getSess :: String -> Kibro v (Maybe String)
getSess k = do
sess <- gets session
case sess of
Just (Session _ s) -> return $ M.lookup k s
Nothing -> return Nothing
putSess :: String -> String -> Kibro v ()
putSess k v = sessMod (M.insert k v)
deleteSess :: String -> Kibro v ()
deleteSess = sessMod . M.delete
sessMod :: (Map String String -> Map String String) -> Kibro v ()
sessMod mod = do
sess <- gets session
when (isNothing sess) makeSession
Just (Session id s) <- gets session
modify $ \state -> state { session = Just $ Session id (mod s) }
makeSession :: Kibro v ()
makeSession = do
var <- gets sessions
sess <- liftIO $ modifyMVar var $ \state@(id:ids,sessions) ->
let session = Session id M.empty
newState = (ids,M.insert id session sessions)
in return (newState,session)
setCookie (newCookie sessionName $ show $ sessId sess) { cookiePath = Just "/" }
modify $ \state -> state { session = Just sess }
stylesheet :: String -> Html
stylesheet url = thelink ! [rel "stylesheet",thetype "text/css",href url] << ""
ahref :: HTML a => String -> a -> HotLink
ahref url = hotlink url . toHtml
(<<$) :: (HTML a) => (Html -> b) -> a -> b
a <<$ b = a << b
infixr 0 <<$