kibro (empty) → 0.0

raw patch · 15 files changed

+601/−0 lines, 15 filesdep +HDBCdep +HDBC-sqlite3dep +basesetup-changed

Dependencies added: HDBC, HDBC-sqlite3, base, cgi, containers, directory, fastcgi, filepath, haskell98, mtl, process, random, regex-compat, safe, validate, xhtml

Files

• LICENSE +0/−0
• README +1/−0
• Setup.lhs +3/−0
• executable/Build.hs +21/−0
• executable/Data/Lighttpd.hs +62/−0
• executable/Help.hs +10/−0
• executable/Main.hs +40/−0
• executable/New.hs +107/−0
• executable/Restart.hs +19/−0
• executable/Start.hs +54/−0
• executable/Stop.hs +39/−0
• executable/Utils.hs +53/−0
• kibro.cabal +23/−0
• library/Kibro.hs +163/−0
• library/Kibro/DB/Sqlite3.hs +6/−0

@@ -0,0 +1,1 @@+Kibro is a tool set for creating and working with FastCGI and Lighttpd.

@@ -0,0 +1,3 @@+> import Distribution.Simple+> main :: IO ()+> main = defaultMain

@@ -0,0 +1,21 @@+module Build where++import Directory+import Control.Applicative+import Data.List+import System.Process+import System.FilePath+import System.Exit++import Utils++build :: [String] -> IO ()+build _ = inKibro $ \dir name -> do+            doing $ "Building " ++ name+            doBuild dir name+            return ()++doBuild :: String -> String -> IO ExitCode+doBuild dir name = do doing cmd; runCommand cmd >>= waitForProcess+      where cmd = "ghc --make src" ./. "Main.hs -o public" ./. fcgi ++ " -threaded"+            fcgi = name ++ ".fcgi"

@@ -0,0 +1,62 @@+{-# LANGUAGE FlexibleInstances #-}+module Data.Lighttpd+    ((.=>.)+    ,(.=.)+    ,(./.)+    ,showSettings)+where++import System.FilePath+import Data.List+import Utils++------------------------------------------------------------------------------+-- Lighttpd configuration++-- | Class for generalising the properties.+class LightyProperty a where toProp :: a -> Prop++-- | Necessary instances.+instance LightyProperty [[Char]] where toProp = List+instance LightyProperty [Char] where toProp = String+instance LightyProperty Int where toProp = Number+instance LightyProperty [Prop] where toProp = Props+instance LightyProperty [[Prop]] where toProp = Props . map Props++-- | A property.+data Prop = String String+          | Number Int+          | List [String]+          | Assign String Prop+          | Props [Prop]+-- | A property "setting".+data Set = Set String Prop++instance Show Prop where+    show (String s) = show s+    show (Number n) = show n+    show (List xs)  = "(" ++ commas xs ++ ")" where+    show (Assign p v) = show p ++ " => " ++ show v+    show (Props ps) = "(" ++ commas ps ++ ")"++instance Show Set where show (Set s p) = s ++ " = " ++ show p++-- | Print a list of settings in the lighttpd config format.+showSettings :: [Set] -> String+showSettings = unlines . map show++commas :: Show a => [a] -> String+commas = concat . intersperse "," . map show++------------------------------------------------------------------------------+-- Combinators++-- | "Set" a property.+(.=.) :: LightyProperty a => String -> a -> Set+p .=. v = Set p (toProp v)+infixr 0 .=.++-- | "Assign" a value to something.+(.=>.) :: LightyProperty a => String -> a -> Prop+(.=>.) a b = Assign a (toProp b)+infixr 0 .=>.

@@ -0,0 +1,10 @@+module Help where++import Utils++------------------------------------------------------------------------------+-- Help command++showHelp :: IO ()+showHelp = todo "help"+

@@ -0,0 +1,40 @@+module Main where++import System+import System.IO+import System.Directory+import Text.Printf+import Data.Maybe+import Data.List+import System.FilePath+import Data.Validate+import Control.Applicative++import Data.Lighttpd++import New+import Help+import Build+import Start+import Restart+import Stop++import Utils++main :: IO ()+main = do+  args <- getArgs+  case args of+    (cmd:opts) -> runCmd cmd opts+    _          -> showHelp++runCmd :: String -> [String] -> IO ()+runCmd cmd xs = fromMaybe showHelp $ lookup cmd commands >>= return . ($ xs)++commands :: [(String, [String] -> IO ())]+commands = [("new",new)+           ,("build",build)+           ,("start",start)+           ,("restart",restart)+           ,("stop",stop)+           ,("refresh",refresh)]

@@ -0,0 +1,107 @@+------------------------------------------------------------------------------+-- New project command++module New where++import System+import System.IO+import System.Directory+import Text.Printf+import Data.Maybe+import Data.List+import System.FilePath+import Data.Validate+import Control.Applicative++import Utils+import Help+import Data.Lighttpd++new :: [String] -> IO ()+new []     = do todo "interactive mode"; showHelp+new [name] = name .->. validName $ do+               doing $ "Creating project " ++ name+               dir <- getCurrentDirectory+               exists <- any (==name) <$> getDirectoryContents dir+               exists .->. (test "project must not exist" (==False)) $ do+                 makeDirStructure dir name++-- | Valid project name.+validName = pattern "project name" "[a-z][a-z0-9]+"++-----------------------+-- Directory structure++makeDirStructure :: String -> String -> IO ()+makeDirStructure dir name = do+  doing $ "Creating directory structure"+  mapM_ create (dirs name)+  mapM_ ($ name) [writeLighttpd,writeMain]+  doing $ "Writing " ++ conf; touch $ conf+      where conf = name ./. (name ++ ".kibro")++touch p = openFile p WriteMode >>= hClose++create f = do doing $ "Creating " ++ f+              createDirectoryIfMissing True f++dirs = (.//. ("app" .//. ["lighttpd","fastcgi","memcached"]+              +++              ["db","public","src"]))+    where sup .//. sub = map (sup ./.) sub++-----------------------+-- Lighttpd config++writeLighttpd :: String -> IO ()+writeLighttpd name = do+  doing $ "Writing " ++ path+  root <- (./. name) <$> getCurrentDirectory+  h <- openFile path WriteMode+  hPutStrLn h (lighttpdconf root name)+  hClose h+  where path = name ./. "app" ./. "lighttpd" ./. "lighttpd.conf"++-----------------------+-- Default Main.hs++writeMain :: String -> IO ()+writeMain name = do+  doing $ "Writing " ++ path+  h <- openFile path WriteMode+  hPutStrLn h mainSrc+  hClose h+  where path = name ./. "src" ./. "Main.hs"++------------------------------------------------------------------------------+-- Lighttpd template++lighttpdconf :: String -> String -> String+lighttpdconf root name = showSettings+    ["server.modules"           .=. ["mod_rewrite","mod_redirect","mod_fastcgi"]+    ,"server.document-root"     .=. root ./. "public"+    ,"server.port"              .=. (3000 :: Int)+    ,"server.pid-file"          .=. root ./. "app" ./. "lighttpd" ./. "lighttpd.pid"+    ,"server.errorlog"          .=. root ./. "app" ./. "lighttpd" ./. "error.log"+    ,"server.dir-listing"       .=. "enable"+    ,"dir-listing.encoding"     .=. "utf-8"+    ,"mimetype.assign"          .=. ["" .=>. "text/plain"]+    ,"server.error-handler-404" .=. name ++ ".fcgi"+    ,"index-file.names"         .=. [name ++ ".fcgi"]+    ,"fastcgi.server"           .=.+     [(root ./. "public" ./. (name ++ ".fcgi")) .=>.+      [["socket" .=>. root ./. "app" ./. "fastcgi" ./. (name ++ ".sock")]]]+    ]++------------------------------------------------------------------------------+-- Main.hs template++mainSrc = "module Main where\n\+          \import Kibro\n\+          \import Kibro.DB.Sqlite3\n\+          \\n\+          \main = kibro (db \"\") pages\n\+          \\n\+          \pages = [(\".\", example)]\n\+          \\n\+          \example = output \"Change me! :-)\""

@@ -0,0 +1,19 @@+module Restart where++import Start+import Stop+import Build++import Utils++restart :: [String] -> IO ()+restart _ = do stop []+               start []++refresh :: [String] -> IO ()+refresh _ = inKibro $ \dir name -> do+              doing "Rebuilding"+              build []+              doing "Restarting fastcgi"+              stopFastCGI dir name+              startFastCGI dir name

@@ -0,0 +1,54 @@+module Start where++import Directory+import Control.Applicative+import Data.List+import System.Process+import System.FilePath+import System.Exit+import Control.Monad++import Build+import Utils++start :: [String] -> IO ()+start _ = inKibro $ \dir name -> do+  let fcgi = "public" ./. (name++".fcgi")+  d <- doesFileExist fcgi+  if d+     then doStart dir name+     else do doing "Not built. Building"+             e <- doBuild dir name+             case e of+               ExitSuccess -> doStart dir name+               _           -> appError "cannot start"++doStart :: String -> String -> IO ()+doStart dir name = do+  pid <- doesFileExist $ "app" ./. "lighttpd" ./. "lighttpd.pid"+  when (not pid) startLighty+  pid <- doesFileExist $ "app" ./. "fastcgi" ./. "fastcgi.pid"+  when (not pid) (startFastCGI dir name)++startLighty = do+  doing "Starting lighttpd"+  r <- runCommand lighttpd >>= waitForProcess+  case r of+    ExitSuccess -> return ()+    _ -> appError "unable to start lighttpd! \+                  \perhaps the port is already \+                  \in use. Do: kibro configure --port <myport>"+    where lighttpd = "lighttpd -f app/lighttpd/lighttpd.conf"++startFastCGI dir name = do+  doing "Starting fastcgi process"+  doing fastcgi+  r <- runCommand fastcgi >>= waitForProcess+  case r of+    ExitSuccess -> return ()+    _ -> appError "unable to start the fastcgi process! is spawn-fcgi installed?"+    where fastcgi = "spawn-fcgi -f " ++ fcgi ++ " -s " ++ sock ++ " -P " ++ pid+          fcgi = "public" ./. name ++ ".fcgi"+          sock = dir ./. "app" ./. "fastcgi" ./. name ++ ".sock"+          pid = "app" ./. "fastcgi" ./. "fastcgi.pid"+

@@ -0,0 +1,39 @@+module Stop where++import Directory+import System.Process+import Control.Applicative++import Utils++stop :: [String] -> IO ()+stop _ = inKibro $ \dir name -> do stopFastCGI dir name+                                   stopLighty dir name++-- TODO: abstract this++stopLighty dir name = do+  exists <- doesFileExist pid+  if exists+     then do doing "Stopping lighttpd"+             id <- readFile pid+             -- TODO: make this compatible with windows+             runCommand $ "kill " ++ id+             return ()+     else return ()+      where pid = dir ./. "app" ./. "lighttpd" ./. "lighttpd.pid"  ++stopFastCGI dir name = do+  exists <- doesFileExist pid+  if exists+     then do doing "Stopping fastcgi"+             id <- readFile pid+             -- TODO: make this compatible with windows+             runCommand $ "kill " ++ id+             deleteFile pid+             return ()+     else return ()+      where pid = dir ./. "app" ./. "fastcgi" ./. "fastcgi.pid"+++

@@ -0,0 +1,53 @@+module Utils where++import Data.Validate+import System.FilePath+import Control.Applicative+import System.Process+import System.FilePath+import System.Exit+import Directory+import Data.List++------------------------------------------------------------------------------+-- Output helpers++todo :: String -> IO ()+todo = putStrLn . ("TODO: "++)++doing :: String -> IO ()+doing = putStrLn . (++" ...")++appError :: String -> IO ()+appError err = error err++------------------------------------------------------------------------------+-- Input validation++-- | With a valid value, do an action, otherwise throw an error.+(.->.) :: Str e => a -> Test e a b -> IO () -> IO ()+(val .->. test) thunk =+    case validate test val of+      Just errs -> appError $ "invalid: " ++ (concat $ map strToString errs)+      Nothing   -> thunk++-- | Make a platform-independant path separator+(./.) :: String -> String -> FilePath+a ./. b = a ++ [pathSeparator] ++ b+infixl 9 ./.++inKibro :: (String -> String -> IO ()) -> IO ()+inKibro m = do+  dir <- getCurrentDirectory+  let name = dirName dir+  inKibro <- any (any (==".kibro") . tails) <$> getDirectoryContents dir+  if inKibro+     then m dir name+     else appError "not in a Kibro directory"++dirName :: String -> String+dirName = reverse . takeWhile (/=pathSeparator) . reverse++-- TODO: use something cross platform.. no idea why I can't find one like+-- this already. "~_~+deleteFile = runCommand . ("rm " ++)

@@ -0,0 +1,23 @@+name:          kibro+version:       0.0+synopsis:      Web development framework.+description:   Web development framework.+category:      Web+license:       BSD3+license-file:  LICENSE+author:        Chris Done <chrisdone@gmail.com>+maintainer:    Chris Done <chrisdone@gmail.com>+build-Depends: base,directory,haskell98+build-type:    Simple+cabal-Version: >= 1.2++library+   build-depends: base,HDBC,mtl,regex-compat,random,safe,xhtml,containers,fastcgi,cgi,HDBC-sqlite3+   exposed-modules: Kibro,Kibro.DB.Sqlite3+   hs-source-dirs: library/+   GHC-Prof-options: -auto-all++executable kibro+  main-is: Main.hs+  build-depends: base,regex-compat,directory,filepath,haskell98,validate,process+  hs-source-dirs: executable/

@@ -0,0 +1,163 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}+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++------------------------------------------------------------------------------+-- Main Kibro entry point+--++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)++-- TODO: make proper 404+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 }++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 }++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++------------------------------------------------------------------------------+-- Kibro utilities+--++outputHtml :: (HTML a, IConnection c) => a -> Kibro c CGIResult+outputHtml = output . showHtml++defGet n = (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 <<$++------------------------------------------------------------------------------+-- Utilities for this file+--++io = liftIO

@@ -0,0 +1,6 @@+module Kibro.DB.Sqlite3 where++import Database.HDBC.Sqlite3++db :: String -> IO Connection+db = connectSqlite3