kibro-0.4.2: library/Kibro.hs

{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}

module Kibro
    ( -- * Start Kibro
      startKibro
    , startKibro'
      -- * Value which the Kibro monad holds
    , getValue
      -- * Input utilities
    , getURIMatch
    , getInputDef
    , readInputDef
      -- * Session utilities
    , getSess
    , putSess
    , deleteSess
    , modifySess
    , getSessDef
    , modifySessDef
    , readSess
    , writeSess
    , modifyRSess
    , modifyRSessDef
      -- * HTML utilities
    , stylesheet
    , (<<$)
    , PageAssign
    , ahref
      -- * Module re-exports
    , 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

---------------------------------------------------------------------------
-- Server start up 

-- | Same as startKibro', but with value as () and uses forkIO to fork
startKibro :: [PageAssign ()] -> IO ()
startKibro = startKibro' () forkOS

-- | Start Kibro FastCGI server
startKibro' :: v                       -- ^ The value to be passed to pages
            -> (IO () -> IO ThreadId)  -- ^ How to fork threads
            -> [PageAssign v]          -- ^ Page list of (regex,page action)
            -> 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

----------------------------------------------------------------------------
-- Page request handler

-- | Main CGI action for Kibro
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

-- | Run a Kibro action, returning the new session and 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)

-- | Match a uri against a regex, returning the parameters from the regex
--   and the page action
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)

-- | Simple 404 page
notFound :: Kibro v CGIResult
notFound = getVar "REQUEST_URI" >>= outputNotFound . fromMaybe ""

---------------------------------------------------------------------------
-- Session manager monad

-- | Manager monad
type Manager = ReaderT SessionState (CGIT IO)
-- | List of (regular expression,page action) pairs
type PageAssign v = (String,Page v)
-- | Page action
type Page v = Kibro v CGIResult
-- | Session state; session ids and associated data
type SessionState = MVar ([Integer],Map Integer Session)
-- | Browser instance session
data Session = Session
    { sessId     :: Integer
    , sessValues :: Map String String
    } deriving (Eq,Show)
sessionName = "KIBROSESSIONID"

---------------------------------------------------------------------------
-- Kibro monad

type Kibro = KibroT IO

-- | A state containing the current session and a database connection.
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

---------------------------------------------------------------------------
-- Sessions

-- | Update a session in the MVar
updateSession :: Session -> Manager ()
updateSession session@(Session id _) = do
  var <- ask
  liftIO $ modifyMVar_ var $ \(ids,sessions) -> do
    return (ids,M.insert id session sessions)

-- | Get the current session
getSession :: Manager (Maybe Session)
getSession = do
  var <- ask
  sId <- lift $ readCookie sessionName
  (ids,sessions) <- liftIO $ readMVar var
  return $ sId >>= flip M.lookup sessions
                       
-- | Generate an infinite list of session ids
genIds :: IO [SessionId]
genIds = nub . randomRs (1,1000^(20::Int)) <$> betterStdGen

-- | A better random number generator which uses /dev/random when entropy
--   is available
betterStdGen :: IO StdGen
betterStdGen = alloca $ \p -> do
    h <- openBinaryFile "/dev/urandom" ReadMode
    hGetBuf h p $ sizeOf (undefined :: Int)
    hClose h
    mkStdGen <$> peek p

-- | Session identity per browser instance
type SessionId = Integer

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

----------------------------------------
-- Value utilities

getValue :: Kibro v v
getValue = gets kibroValue

----------------------------------------
-- URL utilities

getURIMatch :: Kibro v MatchResult
getURIMatch = gets match

----------------------------------------
-- Input utilities

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

----------------------------------------
-- Session utilities

-- | Get session value or return default value
getSessDef :: String -> String -> Kibro v String
getSessDef k v = fromMaybe v <$> getSess k

-- | Read session value or return default value
readSessDef :: (Read a) => String -> a -> Kibro v a
readSessDef k v = fromMaybe v <$> readSess k

-- | Same as modifySessDef, but with Read/Show instance values
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'

-- | Same as modifySess, but with Read/Show instance values
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

-- | Read a session value
readSess :: (Read a) => String -> Kibro v (Maybe a)
readSess k = getSess k >>= return . (>>= readMay)

-- | Show a session value and put it
writeSess :: (Show a) => String -> a -> Kibro v ()
writeSess k v = putSess k (show v)

-- | Modify a session value, if the value does not exist, no change occurs
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'

-- | Modify a session value, if the value does not exist, the default value
--   is modified and inserted
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'

-- | Get a session value
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

-- | Put a session value
putSess :: String -> String -> Kibro v ()
putSess k v = sessMod (M.insert k v)

-- | Delete a session value
deleteSess :: String -> Kibro v ()
deleteSess = sessMod . M.delete

-- | Modify a session value
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 }

----------------------------------------
-- Some HTML utilities

-- | Simple stylesheet element
stylesheet :: String -> Html
stylesheet url = thelink ! [rel "stylesheet",thetype "text/css",href url] << ""

-- | <a href='x'>y</a>
ahref :: HTML a => String -> a -> HotLink
ahref url = hotlink url . toHtml

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