kibro 0.0 → 0.1

raw patch · 14 files changed

+101/−391 lines, 14 filesdep +data-defaultPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default

API changes (from Hackage documentation)

Files

• README +0/−1
• executable/Build.hs +0/−21
• executable/Data/Lighttpd.hs +0/−62
• executable/Help.hs +0/−10
• executable/Main.hs +5/−1
• executable/New.hs +0/−107
• executable/Restart.hs +0/−19
• executable/Start.hs +0/−54
• executable/Stop.hs +0/−39
• executable/Utils.hs +0/−53
• kibro.cabal +3/−3
• library/Kibro.hs +55/−20
• library/Kibro/DB.hs +35/−0
• library/Kibro/DB/Sqlite3.hs +3/−1

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

@@ -1,21 +0,0 @@-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"

@@ -1,62 +0,0 @@-{-# 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 .=>.

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

@@ -18,6 +18,8 @@ import Start import Restart import Stop+import Configure+import Clean  import Utils @@ -37,4 +39,6 @@            ,("start",start)            ,("restart",restart)            ,("stop",stop)-           ,("refresh",refresh)]+           ,("refresh",refresh)+           ,("configure",configure)+           ,("clean",clean)]

@@ -1,107 +0,0 @@---------------------------------------------------------------------------------- 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! :-)\""

@@ -1,19 +0,0 @@-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

@@ -1,54 +0,0 @@-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"-

@@ -1,39 +0,0 @@-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"---

@@ -1,53 +0,0 @@-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 " ++)

@@ -1,5 +1,5 @@ name:          kibro-version:       0.0+version:       0.1 synopsis:      Web development framework. description:   Web development framework. category:      Web@@ -12,8 +12,8 @@ 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+   build-depends: base,HDBC,mtl,regex-compat,random,safe,xhtml,containers,fastcgi,cgi,HDBC-sqlite3,data-default+   exposed-modules: Kibro,Kibro.DB,Kibro.DB.Sqlite3    hs-source-dirs: library/    GHC-Prof-options: -auto-all 

@@ -2,10 +2,13 @@ module Kibro      (       module Network.CGI-    , module Database.HDBC-    , module Text.XHtml.Strict     , kibro-    , Kibro+    , Kibro, KibroT+    , Page+    , PageList+    , gets+    , con+    , getParams     , getSess     , readSess     , putSess@@ -14,8 +17,11 @@     , getInputDef     , readSessDef     , readInputDef+    , deleteSess     , outputHtml     , (<<$)+    , io+    , stylesheet     )     where @@ -33,6 +39,8 @@ import Safe import Text.XHtml.Strict import Control.Applicative+import Control.Arrow+import Data.Function  ------------------------------------------------------------------------------ -- Main Kibro entry point@@ -42,27 +50,36 @@ kibro getDb ps = do   ss  <- newMVar M.empty   ids <- newMVar [0..]-  db  <- getDb-  runFastCGIConcurrent' forkIO 1000 (kibroMain ss ids ps db)+  runFastCGIConcurrent' forkOS 1000 (handleErrors (kibroMain getDb ss ids ps)) -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)+-- TODO: use applicative on mvar+kibroMain :: IConnection c => (IO c) -> SessionsVar -> IdsVar -> PageList c -> CGI CGIResult+kibroMain getDb ssvar ids ps = do+  -- Connect to the database for this session+  db <- io $ getDb+  -- Get or create a new session+  (id,session) <- getSession ids ssvar+  -- Get the page to run+  (params,page) <- pageMatch ps <$> fromMaybe "" <$> getVar "REQUEST_URI"+  -- Run a page, returning a new session and result+  (session',result) <- runKibro page (KibroSt db session params)+  -- Update the session+  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) --- TODO: make proper 404 notFound :: IConnection c => Page c notFound = getVar "REQUEST_URI" >>= outputNotFound . fromMaybe "" @@ -105,6 +122,11 @@                  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)   @@ -118,15 +140,20 @@ -- | A state containing the current session and a database connection. data KibroSt c = KibroSt     { con     :: c-    , session :: Session }+    , 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))+    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@@ -137,12 +164,17 @@ -- Kibro utilities -- +getParams :: IConnection c => Kibro c [String] +getParams = gets params+ outputHtml :: (HTML a, IConnection c) => a -> Kibro c CGIResult-outputHtml = output . showHtml+outputHtml = output . html . showHtmlFragment where+    html c = "<html>" ++ c ++ "</html>" -defGet n = (fromMaybe n <$>)+defGet n = liftM (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@@ -156,8 +188,11 @@ a <<$ b = a << b infixr 0 <<$ +stylesheet url = thelink ! [rel "stylesheet",thetype "text/css",href url] << ""+ ------------------------------------------------------------------------------ -- Utilities for this file -- +io :: MonadIO m => IO a -> m a io = liftIO

@@ -0,0 +1,35 @@+module Kibro.DB+    (query,exec,Kibro.DB.commit+    ,module Database.HDBC)+    where++import Kibro hiding (handleErrors)+import Database.HDBC hiding (commit)+import qualified Database.HDBC as HDBC+import Control.Exception++runSql :: IConnection c +       => (c -> String -> [SqlValue] -> IO a) -- ^ SQL function.+       -> c                                   -- ^ SQL connection.+       -> String                              -- ^ Query.+       -> [SqlValue]                          -- ^ Parameters.+       -> Kibro c a                           -- ^ Result.+runSql f dbh s vs = io $ handleSql throwSqlError $ f dbh s vs where+    throwSqlError (SqlError _ _ e) =+        throwIO $ AssertionFailed $+                    "SQL error: " ++ show s ++ " " ++ show vs ++ e++query :: IConnection c => String -> [SqlValue] -> Kibro c [[SqlValue]]+query sql values = do+  dbh <- gets con+  runSql quickQuery' dbh sql values++exec :: IConnection c => String -> [SqlValue] -> Kibro c Integer+exec sql values = do+  dbh <- gets con+  runSql run dbh sql values++commit :: IConnection c => Kibro c ()+commit = do+  dbh <- gets con+  io $ HDBC.commit dbh

@@ -1,4 +1,6 @@-module Kibro.DB.Sqlite3 where+module Kibro.DB.Sqlite3 +    (db,Connection)+    where  import Database.HDBC.Sqlite3