kibro 0.1 → 0.3

raw patch · 5 files changed

+872/−225 lines, 5 filesdep +regexprdep +strictdep +unixdep −HDBCdep −HDBC-sqlite3dep −validatePVP ok

version bump matches the API change (PVP)

Dependencies added: regexpr, strict, unix

Dependencies removed: HDBC, HDBC-sqlite3, validate

API changes (from Hackage documentation)

Files

• executable/Main.hs +623/−32
• kibro.cabal +4/−4
• library/Kibro.hs +245/−146
• library/Kibro/DB.hs +0/−35
• library/Kibro/DB/Sqlite3.hs +0/−8

@@ -1,44 +1,635 @@+{-# LANGUAGE FlexibleInstances #-}++------------------------------------------------------------------------------+-- Main Kibro executable+ module Main where +import System.Posix.Signals      (installHandler, sigPIPE, Handler(Ignore))++import Prelude hiding (catch)+import Control.Arrow hiding ((<+>))+import Control.Concurrent+import Control.Exception+import Control.Monad.Error+import Control.Monad.State+import Control.Monad.Reader+import Data.List+import Data.Maybe import System import System.IO+import qualified System.IO.Strict as SIO+import System.FilePath import System.Directory+import System.Process 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 Configure-import Clean+import Text.Regex -import Utils+------------------------------------------------------------------------------+-- Main start-up functions +-- | Wrapper for start-up in main executable main :: IO () main = do-  args <- getArgs-  case args of-    (cmd:opts) -> runCmd cmd opts-    _          -> showHelp+  installHandler sigPIPE Ignore Nothing+  getArgs >>= tryCommand -runCmd :: String -> [String] -> IO ()-runCmd cmd xs = fromMaybe showHelp $ lookup cmd commands >>= return . ($ xs)+-- | Tries the given command+tryCommand :: [String] -> IO ()+tryCommand [] = do name <- getProgName+                   error $ "no command given (try `" ++ name ++ " help')"+tryCommand (command:args) =+    case find ((==command) . cmdName) commands of+      Just cmd -> startCommand cmd args+      Nothing  -> error $ printf "No such command `%s'" command -commands :: [(String, [String] -> IO ())]-commands = [("new",new)-           ,("build",build)-           ,("start",start)-           ,("restart",restart)-           ,("stop",stop)-           ,("refresh",refresh)-           ,("configure",configure)-           ,("clean",clean)]+-- | Starts the Kibro program's first command+startCommand :: Cmd -> [String] -> IO ()+startCommand cmd args = do+  pwd <- getCurrentDirectory+  name <- getProgName+  let kibroSt = KibroSt { kibProject = Nothing+                        , kibProjDir = error "project directory not defined"+                        , kibCmd     = cmd+                        , kibArgs    = args +                        , kibAppName = name }+  hSetBuffering stdout NoBuffering+  status <- evalStateT (runErrorT (cmdAct cmd args)) kibroSt+  either error (const $ return ()) status++------------------------------------------------------------------------------+-- Kibro commands++-- | Command list+commands :: [Cmd]+commands = [startCmd,stopCmd,buildCmd,refreshCmd+           ,restartCmd,configureCmd,newCmd,helpCmd]++----------------------------------------+-- `configure' command+configureCmd :: Cmd+configureCmd = Cmd { cmdName = "configure"+                   , cmdDesc = "Use this to rewrite config files (lighttpd.conf, ..)"+                   , cmdFlags = []+                   , cmdAct  = action } where+    action :: [String] -> Command ()+    action _ = do initProject+                  configureProject++configureProject :: Command ()+configureProject = do+  writeLightyConf ++----------------------------------------+-- `refresh' command+refreshCmd :: Cmd+refreshCmd = Cmd { cmdName = "refresh"+                 , cmdDesc = "Rebuild source, if success, restart FastCGI/Lighttpd"+                 , cmdFlags = []+                 , cmdAct  = action } where+    action :: [String] -> Command ()+    action _ = do initProject+                  cmdAct buildCmd []+                  stopFastCGI+                  spawnFCGI++----------------------------------------+-- `restart' command+restartCmd :: Cmd+restartCmd = Cmd { cmdName = "restart"+                 , cmdDesc = "Stop and start Lighttpd and/or FastCGI server"+                 , cmdFlags = []+                 , cmdAct  = action } where+    action :: [String] -> Command ()+    action _ = do initProject+                  cmdAct stopCmd []+                  cmdAct startCmd []++----------------------------------------+-- `stop' command++stopCmd :: Cmd+stopCmd = Cmd { cmdName = "stop"+               , cmdDesc = "Stop Lighttpd and/or FastCGI server"+               , cmdFlags = []+               , cmdAct  = action } where+    action :: [String] -> Command ()+    action _ = do+      initProject+      stopProject++stopProject :: Command ()+stopProject = do stopFastCGI+                 stopLighttpd++stopLighttpd = onlyIfLighttpd $ stopDaemon "lighttpd" "Stopping Lighttpd ... "+stopFastCGI = stopDaemon "fastcgi"  "Stopping FastCGI ... "++stopDaemon :: String -> String -> Command ()+stopDaemon name caption = do+  dirs <- projectDirs+  let lighty = fromJust (lookup name dirs)+      pid = lighty </> (name ++ ".pid")+  exists <- liftIO $ doesFileExist pid+  if exists+     then do liftIO $ putStrLn caption+             endDaemon pid+     else liftIO $ putStrLn $ "no such file " ++ pid++----------------------------------------+-- `start' command++startCmd :: Cmd+startCmd = Cmd { cmdName = "start"+               , cmdDesc = "Start Lighttpd and FastCGI server"+               , cmdFlags = []+               , cmdAct  = action } where+    action :: [String] -> Command ()+    action _ = do+      initProject+      ensureBuilt+      startProject++startProject :: Command ()+startProject = do+  spawnFCGI+  startLighty++startLighty :: Command ()+startLighty = onlyIfLighttpd $ do+    dirs <- projectDirs+    let cmd = "lighttpd -f " ++ conf+        lighty = fromJust (lookup "lighttpd" dirs)+        conf = lighty </> "lighttpd.conf"+        pid = lighty </> "lighttpd.pid"+    performIfNotExists pid (Just "Lighttpd daemon already running.") $ do+      liftIO $ putStrLn "Spawning Lighttpd daemon ... "+      runShellCmd cmd+      liftIO $ putStrLn "Lighttpd daemon started."++spawnFCGI :: Command ()+spawnFCGI = do+  name <- projectName+  dirs <- projectDirs+  dir  <- projectDir+  out <- gets $ projOutDir . fromJust . kibProject+  let cmd = printf "spawn-fcgi -f %s -s %s -P %s" fcgi sock pid+      fpath = fromJust $ lookup "fastcgi" dirs+      ppath = fromJust $ lookup "public" dirs+      fcgi = dir </> out </> name ++ ".fcgi"+      sock = fpath </> name ++ ".sock"+      pid = fpath </> "fastcgi.pid"+  performIfNotExists pid (Just "FastCGI daemon already running.") $ do+    liftIO $ putStrLn "Spawning FastCGI daemon ... "+    runShellCmd cmd+    liftIO $ putStrLn "Done."++ensureBuilt :: Command ()+ensureBuilt = do+  name <- projectName+  dir  <- projectDir+  out <- gets $ projOutDir . fromJust . kibProject+  let fcgi = dir </> out </> name ++ ".fcgi"+  performIfNotExists fcgi Nothing $ do+    liftIO $ putStrLn "Not yet built, building ..."+    cmdAct buildCmd []+    liftIO $ putStrLn "Finished building."++----------------------------------------+-- `help' command++-- | Display help about commands+helpCmd :: Cmd+helpCmd = Cmd { cmdName = "help"+              , cmdDesc = "Help about commands (try `help <command>')"+              , cmdFlags = []+              , cmdAct  = action } where+    action :: [String] -> Command ()+    action []      = cmdList+    action (cmd:_) = cmdHelp cmd++-- | List all the commands+cmdList :: Command ()+cmdList = do+  let longest = foldr1 max $ map (length . cmdName) commands+  appName <- gets kibAppName+  liftIO $ do+    printf "Usage: %s COMMAND [FLAGS]\n\n" appName+    putStrLn "Commands:"+    mapM_ (showHelp longest) commands+    putStrLn "\nTypical step for creating Kibro project:"+    putStrLn "  kibro new [PROJECT_NAME]"+  where showHelp len (Cmd name desc _ _) = do+            printf "%s   %s\n" (fill ' ' len name) desc++-- | Show help for a command+cmdHelp :: String -> Command ()+cmdHelp command = +    case find ((==command) . cmdName) commands of+      Nothing  -> cmdError $ printf "No such command `%s'" command+      Just cmd -> do +        appName <- gets kibAppName+        liftIO $ do+          let longest = foldr1 max $ map (length . fst) (cmdFlags cmd)+          printf "Usage: %s %s [FLAGS]\n\n" appName command+          printf "Flags for %s:\n" command+          mapM_ (showFlag longest) (cmdFlags cmd)+          where showFlag len (name,desc) = do+                  printf " --%s   %s\n" (fill ' ' len name) desc++----------------------------------------+-- `build' command++-- | Build the current project+buildCmd :: Cmd+buildCmd = Cmd { cmdName  = "build"+               , cmdDesc  = "Build the current project"+               , cmdFlags = []+               , cmdAct   = action } where+    action :: [String] -> Command ()+    action _ = do+      initProject+      buildProject++buildProject :: Command ()+buildProject = do+  dir <- projectDir+  main <- projectMain+  name <- projectName+  let cmd = "ghc --make " ++ dir </> main ++ " -o public" </> fcgi ++ " -threaded"+      fcgi = name ++ ".fcgi"+  runShellCmd cmd++----------------------------------------+-- `new' command++-- | Create a new project+newCmd :: Cmd+newCmd = Cmd { cmdName  = "new"+             , cmdDesc  = "Create a new project"+                          -- TODO+             , cmdFlags = [("start","Start after creating")]+             , cmdAct   = action } where+    action :: [String] -> Command ()+    action []       = cmdError "`new' command needs a project name"+    action (name:_) = do+      case match regex name of+        Nothing -> cmdError $ "invalid project name, should be " ++ regex+        Just _  -> do newProject name; tryMakeProject+      where regex = "^[a-z][a-z0-9_-]+$"++-- | Try to make a project+tryMakeProject :: Command ()+tryMakeProject = do+  makeProjDir+  writeDefMain+  writeLightyConf+  writeProjConfig++-- | Make the project directory structure+makeProjDir :: Command ()+makeProjDir = do+  dir <- projectDir+  dirs <- map snd `fmap` projectDirs+  exists <- liftIO $ doesDirectoryExist dir+  if exists+     then do dir' <- liftIO $ makeRelativeToCurrentDirectory dir+             cmdError $ "directory `" ++ dir' ++ "' already exists"+     else liftIO $ do putStrLn "Creating directory structure ..."+                      mapM_ createDir dirs+                      putStrLn "Finished creating directory structure."+  where createDir dir = do putStrLn $ "  " ++ dir+                           createDirectoryIfMissing True dir++-- | Set the current project in the state+newProject :: String -> Command ()+newProject name = do+  pwd <- liftIO $ getCurrentDirectory+  let project = KibroProject { projName     = name+                             , projDirs     = defaultDirs +                             , projOutDir   = "public" +                             , projMainIs   = "src" </> "Main.hs"+                             , projLighttpd = True }+  modify $ \s -> s { kibProjDir = Just $ pwd </> name+                   , kibProject = Just project }++-- | Write default Main.hs file+writeDefMain :: Command ()+writeDefMain = do+  dir <- projectDir+  main <- projectMain+  liftIO $ do+    putStr $ "Writing Main.hs ... "+    writeFile (dir </> main) mainSrc+    putStrLn "done."++-- | Write the lighttpd.conf file+writeLightyConf :: Command ()+writeLightyConf = onlyIfLighttpd $ do+  dir <- projectDir+  dirs <- projectDirs+  conf <- lighttpdDotConf+  case lookup "lighttpd" dirs of+    Nothing   -> cmdError "lighttpd config path not found in project config"+    Just path -> do liftIO $ do+                      putStr $ "Writing lighttpd.conf ... "+                      writeFile (path </> "lighttpd.conf") conf+                      putStrLn "done."+                    writeCustom path++writeCustom :: FilePath -> Command ()+writeCustom path = onlyIfLighttpd $ liftIO $ do+  let custom = path </> "custom.conf"+  exists <- doesFileExist custom+  putStr "Writing custom.conf ... "+  if exists+     then putStrLn "already exists, skipping."+     else do writeFile custom customDotConf+             putStrLn "done."++-- | Write the Kibro configuration to .kibro file+writeProjConfig :: Command ()+writeProjConfig = do+  dir <- projectDir+  proj <- fromJust `fmap` gets kibProject+  let name = projName proj+  liftIO $ do+    putStr $ "Writing " ++ name ++ ".kibro ... "+    writeFile (dir </> name ++ ".kibro") $ show proj+    putStrLn "done."++-- | Initialise the Kibro project by reading the configuration file+initProject :: Command ()+initProject = do+  proj <- gets kibProject+  when (not $ isJust proj) $ do+    pwd <- liftIO $ getCurrentDirectory+    configs <- liftIO $ getDirectoryContents pwd+    let config = filter (isJust . match "^[a-z][a-z0-9_-]+\\.kibro$") configs+    case config of+      [config] -> do liftIO $ putStr $ "Reading config file " ++ config ++ " ... "+                     config_ <- liftIO $ SIO.readFile config+                     let config' = read config_ +                     modify $ \s -> s { kibProject = Just config' +                                      , kibProjDir = Just pwd }+                     liftIO $ putStrLn "done."+      -- TODO: --config option+      []       -> cmdError "no kibro file found. try the `new' command"+      _        -> cmdError "more than one kibro file found"++----------------+-- Command types++-- Throw an error, prefixing the command that threw it to the message+cmdError :: [Char] -> Command a+cmdError err = do+  name <- gets $ cmdName . kibCmd+  throwError $ name ++ ": " ++ err++data Cmd = Cmd +    { cmdName  :: String+    , cmdDesc  :: String+    , cmdFlags :: [(String,String)]+    , cmdAct   :: [String] -> Command ()+    }+instance Show Cmd where +    show (Cmd name desc _ _) = "Cmd { cmdName = " ++ show name +++                               ", cmdDesc = " ++ show desc ++ " }"++type Command = ErrorT String Kibro++----------------+-- Kibro types++-- | Kibro monad+type Kibro = StateT KibroSt IO++-- | Kibro running state+data KibroSt = KibroSt +    { kibProject :: Maybe KibroProject+    , kibProjDir :: Maybe FilePath+    , kibCmd     :: Cmd+    , kibArgs    :: [String]+    , kibAppName :: String+    } deriving Show++-- Helper functions+projectMain = gets $ projMainIs . fromJust . kibProject+projectName = gets $ projName . fromJust . kibProject+projectDir  = gets $ fromJust . kibProjDir+projectLighttpd = gets $ projLighttpd . fromJust . kibProject+onlyIfLighttpd :: Command () -> Command ()+onlyIfLighttpd m = do doIt <- projectLighttpd+                      when doIt m+projectDirs = do +  dir <- projectDir+  gets (map (second (dir </>)) . projDirs . fromJust . kibProject)++-- | Project type+data KibroProject = KibroProject +    { projName     :: String +    , projDirs     :: [(String,FilePath)]+    , projOutDir   :: FilePath+    , projMainIs   :: FilePath+    , projLighttpd :: Bool+    } deriving (Eq,Show,Read)++-----------------------------------------------------------------------------+-- Default values++mainSrc :: String+mainSrc = "module Main where\n\+          \\n\+          \import Kibro\n\+          \\n\+          \main = startKibro pages\n\+          \\n\+          \pages = [(\".\", example)]\n\+          \\n\+          \example = output \"Change me! :-)\"\n"++lighttpdDotConf :: Command String+lighttpdDotConf = do+  root <- projectDir+  name <- projectName+  dirs <- gets $ projDirs . fromJust . kibProject+  let appDir = fromJust $ lookup "app" dirs+      fastCGIDir = fromJust $ lookup "fastcgi" dirs+      lightDir = fromJust $ lookup "lighttpd" dirs+      pubDir = fromJust $ lookup "public" dirs+  return $ showSettings+    [("Do not modify this file. You should modify custom.conf" #)+    ,"var.k_base_dir"      .=. dir root+    ,"var.k_app_dir"       .=. var "k_base_dir" <+> dir appDir+    ,"var.k_fastcgi_dir"   .=. var "k_base_dir" <+> dir fastCGIDir+    ,"var.k_lighttpd_dir"  .=. var "k_base_dir" <+> dir lightDir+    ,"var.k_public_dir"    .=. var "k_base_dir" <+> dir pubDir+    ,"var.k_fcgi_filename" .=. name ++ ".fcgi"+    ,"var.k_fcgi_path"     .=. var "k_public_dir" <+> var "k_fcgi_filename"+    ,"var.k_socket_path"   .=. var "k_fastcgi_dir" <+> name ++ ".sock"+    ,"var.k_error_log"     .=. var "k_lighttpd_dir" <+> "error.log"+    ,"var.k_port"          .=. (3000 :: Int)+    ,("This value must not be changed, Kibro depends on it for stopping" #)+    ,"server.pid-file"     .=. var "k_lighttpd_dir" <+> "lighttpd.pid"+    ,include "custom.conf"]+                  where dir = init . (</> " ")++customDotConf :: String+customDotConf = showSettings+  [("Only change these if you know what you are doing" #)+  ,"fastcgi.server" .=. [var "k_fcgi_path" .=>. [["socket" .=>. var "k_socket_path"]]]+  ,"server.error-handler-404" .=. var "k_fcgi_filename"+  ,"index-file.names" .=. [var "k_fcgi_filename"]+  ,("Shouldn't need to change these" #)+  ,"server.document-root" .=. var "k_public_dir"+  ,"server.errorlog" .=. var "k_error_log"+  ,("Feel free" #)+  ,"server.modules" .=. ["mod_rewrite","mod_redirect","mod_fastcgi"]+  ,"server.port" .=. var "k_port"+  ,"server.dir-listing" .=."enable"+  ,"dir-listing.encoding" .=."utf-8"+  ,"mimetype.assign" .=. ["" .=>. "text/plain"]]++-- | Default directory structure+defaultDirs :: [(String,FilePath)]+defaultDirs =+    [("app","app")+    ,("lighttpd","app" </> "lighttpd")+    ,("fastcgi","app" </> "fastcgi")+    ,("public","public")+    ,("src","src")]++------------------------------------------------------------------------------+-- Lighttpd config++-- | 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+instance LightyProperty Prop where toProp = id++-- | A property.+data Prop = String String+          | Number Int+          | List [String]+          | Assign Prop Prop+          | Variable String+          | Props [Prop]+          | Concat Prop Prop+-- | A property "setting".+data LightyLine = Set String Prop | Comment String | Include String++instance Show Prop where+    show (String s) = show s+    show (Number n) = show n+    show (List xs)  = "(" ++ commasShow xs ++ ")" where+    show (Assign p v) = show p ++ " => " ++ show v+    show (Props ps) = "(" ++ commasShow ps ++ ")"+    show (Variable v) = v+    show (Concat p1 p2) = show p1 ++ " + " ++ show p2++instance Show LightyLine where+    show (Set s p) = s ++ " = " ++ show p+    show (Comment s) = "# " ++ s+    show (Include s) = "include " ++ show s++-- | Print a list of settings in the lighttpd config format.+showSettings :: [LightyLine] -> String+showSettings = unlines . map show++commasShow :: Show a => [a] -> String+commasShow = commas . map show++---------------------------------------+-- Combinators++-- | "Set" a property.+(.=.) :: LightyProperty a => String -> a -> LightyLine+p .=. v = Set p (toProp v)+infixr 0 .=.++-- | "Assign" a value to something.+(.=>.) :: (LightyProperty a,LightyProperty b) => a -> b -> Prop+(.=>.) a b = Assign (toProp a) (toProp b)+infixr 0 .=>.++var = Variable+(<+>) :: (LightyProperty a,LightyProperty b) => a -> b -> Prop+a <+> b = Concat (toProp a) (toProp b)+infixr 1 <+>+(#) = Comment+include = Include++------------------------------------------------------------------------------+-- Generic utilities++-- Perform some action if a given file doesn't exist, otherwise print message+performIfNotExists :: FilePath -> Maybe String -> Command () -> Command ()+performIfNotExists path msg m = do+  exists <- liftIO $ doesFileExist path+  if not exists then m else maybe (return ()) (liftIO . putStrLn) msg++-- Run shell command+runShellCmd :: String -> Command ()+runShellCmd cmd = do+  id <- liftIO $ runCommand cmd+  status <- liftIO $ waitForProcess id+  case status of+    ExitSuccess   -> return ()+    ExitFailure _ -> cmdError $ "the following command failed:\n  " ++ cmd++-- Stricter command runner+runShellCmd' :: String -> Command ()+runShellCmd' cmd = do+  out <- liftIO $ run cmd ""+  case out of+    Right (ExitSuccess,err,_) | null err  -> return ()+                              | otherwise -> fail err+    Right (_,err,_) -> fail err+    Left err -> fail err+  where fail err = cmdError $ "there were errors with the \+                              \following command:\n  " ++ cmd ++ "\n\n" ++ +                              err++-- Silent runner+runShellCmdSilent :: String -> Command ()+runShellCmdSilent cmd = do+  liftIO $ run cmd ""+  return ()++-- Big-ass-but-stable process launcher+run :: String -> String -> IO (Either String (ExitCode,String,String))+run cmd input = do+  pipe <- catch (Right `fmap` runInteractiveCommand cmd)+                (const $ return $ Left "")+  case pipe of+    Right (inp,out,err,pid) -> do+                  catch (do hSetBuffering inp NoBuffering+                            hPutStr inp input +                            hClose inp+                            errv <- newEmptyMVar+                            outv <- newEmptyMVar+                            output <- hGetContents out+                            errput <- hGetContents err+                            forkIO $ evaluate (length output) >> putMVar outv ()+                            forkIO $ evaluate (length errput) >> putMVar errv ()+                            takeMVar errv+                            takeMVar outv+                            e <- catch (waitForProcess pid)+                                       (const $ return $ ExitFailure 1)+                            return $ Right (e,errput,output))+                        (const $ return $ Left "Broken pipe")+    _ -> return $ Left "Unable to launch process"++fill c len text = take len $ text ++ repeat c+match = matchRegex . mkRegex+commas = concat . intersperse ","++endDaemon pid = do runShellCmdSilent $ "kill `cat \"" ++ pid ++ "\"`"+                   runShellCmdSilent $ "rm \"" ++ pid ++ "\""+                   return ()

@@ -1,5 +1,5 @@ name:          kibro-version:       0.1+version:       0.3 synopsis:      Web development framework. description:   Web development framework. category:      Web@@ -12,12 +12,12 @@ cabal-Version: >= 1.2  library-   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+   build-depends: base,mtl,regex-compat,regexpr,random,safe,xhtml,containers,fastcgi,cgi,data-default+   exposed-modules: Kibro    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+  build-depends: base,filepath,directory,haskell98,process,strict,unix   hs-source-dirs: executable/

@@ -1,198 +1,297 @@ {-# LANGUAGE GeneralizedNewtypeDeriving, FlexibleInstances #-}-module Kibro -    (-      module Network.CGI-    , kibro-    , Kibro, KibroT-    , Page-    , PageList-    , gets-    , con-    , getParams-    , getSess-    , readSess-    , putSess-    , writeSess-    , getSessDef++module Kibro+    ( -- * Start Kibro+      startKibro+    , startKibro'+      -- * Value which the Kibro monad holds+    , getValue+      -- * Input utilities+    , getURIMatch     , getInputDef-    , readSessDef     , readInputDef+      -- * Session utilities+    , getSess+    , putSess     , deleteSess-    , outputHtml-    , (<<$)-    , io+    , modifySess+    , getSessDef+    , modifySessDef+    , readSess+    , writeSess+    , modifyRSess+    , modifyRSessDef+      -- * HTML utilities     , stylesheet-    )-    where+    , (<<$)+    , PageAssign+      -- * Module re-exports+    , module Network.CGI)+ where -import Network.CGI hiding (Html)-import Network.FastCGI-import Network.CGI.Monad-import qualified Data.Map as M+import Control.Exception+import Control.Applicative+import Control.Arrow+import Control.Monad.Reader import Control.Monad.State-import Database.HDBC import Control.Concurrent-import Text.Regex-import Data.Maybe import Data.List-import System.Random+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-import Control.Applicative-import Control.Arrow-import Data.Function ---------------------------------------------------------------------------------- Main Kibro entry point---+---------------------------------------------------------------------------+-- Server start up -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))+-- | Same as startKibro', but with value as () and uses forkIO to fork+startKibro :: [PageAssign ()] -> IO ()+startKibro = startKibro' () forkOS --- 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+-- | 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 -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)+----------------------------------------------------------------------------+-- Page request handler -runKibro :: IConnection c => Kibro c CGIResult -> KibroSt c -> CGI (Session,CGIResult)+-- | 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)+  updateSession session'+  return result++-- | Run a Kibro action, returning the new session and result+runKibro :: Kibro v CGIResult -> KibroSt v -> 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+-- | 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 "" -type PageList c = [(String, Page c)]-type Page c = Kibro c CGIResult+---------------------------------------------------------------------------+-- 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)++---------------------------------------------------------------------------+-- Kibro monad++type Kibro = KibroT IO++-- | A state containing the current session and a database connection.+data KibroSt v = KibroSt { session    :: Session+                         , match      :: MatchResult +                         , kibroValue :: v }++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----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))+-- | 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) -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+-- | Get the current session or make a new one and return it+getSession :: Manager Session+getSession = do+  var <- ask+  sId <- lift $ readCookie "sid"+  sess <- liftIO $ modifyMVar var $ \state@(ids,sessions) -> do+    case sId >>= flip M.lookup sessions of+      Just session -> return (state,(False,session))+      Nothing      -> let sId' = head ids+                          session = Session sId' M.empty+                          newState = (tail ids,M.insert sId' session sessions)+                      in return (newState,(True,session))+  when (fst sess) $ lift $ setCookie (newCookie "sid" $ show (sessId $ snd sess)) { cookiePath = Just "/" }+  return $ snd sess+                          -getSess :: IConnection c => String -> Kibro c (Maybe String)-getSess k = do s <- gets session-               return $ M.lookup k s+-- | Generate an infinite list of session ids+genIds :: IO [SessionId]+genIds = nub . randomRs (1,1000^(20::Int)) <$> betterStdGen -readSess :: (IConnection c, Read a) => String -> Kibro c (Maybe a)-readSess k = getSess k >>= return . (>>= readMay)+-- | 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 -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 }+-- | Session identity per browser instance+type SessionId = Integer -deleteSess :: (IConnection c) => String -> Kibro c ()-deleteSess k = do st <- get-                  let news = M.delete k (session st)-                  put st { session = news }+---------------------------------------------------------------------------+-- Kibro utilities -writeSess :: (IConnection c, Show a) => String -> a -> Kibro c ()-writeSess k v = putSess k (show v)-  -type SessionsVar = MVar Sessions-type IdsVar = MVar [Integer]+----------------------------------------+-- Value utilities ---------------------------------------------------------------------------------- The Kibro monad---+getValue :: Kibro v v+getValue = gets kibroValue --- | A state containing the current session and a database connection.-data KibroSt c = KibroSt-    { con     :: c-    , session :: Session-    , params  :: [String] }+----------------------------------------+-- URL utilities -type Session = M.Map String String-type Sessions = M.Map SessID Session-type SessID = (Integer,Int)+getURIMatch :: Kibro v MatchResult+getURIMatch = gets match -newtype KibroT m c a = Kibro { unKibro :: (StateT (KibroSt c) (CGIT m) a) }-    deriving (Monad, MonadIO, MonadState (KibroSt c), Functor)+----------------------------------------+-- Input utilities -instance (Monad m, IConnection c) => Applicative (KibroT m c) where-    pure = return-    (<*>) = ap+getInputDef :: String -> String -> Kibro v String+getInputDef k v = fromMaybe v <$> getInput k -instance IConnection c => MonadCGI (KibroT IO c) where-    cgiAddHeader n v = Kibro $ lift $ cgiAddHeader n v-    cgiGet x = Kibro $ lift $ cgiGet x+readInputDef :: String -> String -> Kibro v String+readInputDef k v = fromMaybe v <$> readInput k -type Kibro c a = KibroT IO c a+----------------------------------------+-- Session utilities ---------------------------------------------------------------------------------- Kibro utilities---+-- | Get session value or return default value+getSessDef :: String -> String -> Kibro v String+getSessDef k v = fromMaybe v <$> getSess k -getParams :: IConnection c => Kibro c [String] -getParams = gets params+-- | Read session value or return default value+readSessDef :: (Read a) => String -> a -> Kibro v a+readSessDef k v = fromMaybe v <$> readSess k -outputHtml :: (HTML a, IConnection c) => a -> Kibro c CGIResult-outputHtml = output . html . showHtmlFragment where-    html c = "<html>" ++ c ++ "</html>"+-- | 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' -defGet n = liftM (fromMaybe n)+-- | 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+    Just v  -> do writeSess k $ f v+                  return $ Just v+    Nothing -> return Nothing --- Simply utilities+-- | Read a session value+readSess :: (Read a) => String -> Kibro v (Maybe a)+readSess k = getSess k >>= return . (>>= readMay) -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+-- | Show a session value and put it+writeSess :: (Show a) => String -> a -> Kibro v ()+writeSess k v = putSess k (show v) --- HTML utilities+-- | 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 (Session _ s) <- gets session+               return $ M.lookup k s++-- | 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 (Session id s) <- gets session+                 modify $ \state -> state { session = Session id (mod s) }++----------------------------------------+-- 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 <<$--stylesheet url = thelink ! [rel "stylesheet",thetype "text/css",href url] << ""----------------------------------------------------------------------------------- Utilities for this file-----io :: MonadIO m => IO a -> m a-io = liftIO

@@ -1,35 +0,0 @@-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,8 +0,0 @@-module Kibro.DB.Sqlite3 -    (db,Connection)-    where--import Database.HDBC.Sqlite3--db :: String -> IO Connection-db = connectSqlite3