kibro 0.4.3 → 0.5.0
raw patch · 4 files changed
+8/−1035 lines, 4 filesdep −ConfigFiledep −basedep −cgi
Dependencies removed: ConfigFile, base, cgi, containers, data-default, directory, fastcgi, filepath, haskell98, mtl, process, random, regex-compat, regexpr, safe, strict, unix, xhtml
Files
- LICENSE +0/−0
- executable/Main.hs +0/−706
- kibro.cabal +8/−22
- library/Kibro.hs +0/−307
− LICENSE
− executable/Main.hs
@@ -1,706 +0,0 @@-{-# LANGUAGE FlexibleInstances, PostfixOperators #-}----------------------------------------------------------------------------------- Main Kibro executable--module Main where--import System.Posix.Signals (installHandler, sigPIPE, Handler(Ignore))-import Prelude hiding (catch)-import Control.Applicative-import Control.Arrow hiding ((<+>))-import Control.Concurrent-import Control.Exception-import Control.Monad.Error-import Control.Monad.State-import Control.Monad.Reader-import Data.Char-import Data.ConfigFile (CPError,ConfigParser)-import qualified Data.ConfigFile as C-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.Posix.Files-import System.Process-import Text.Printf-import Text.Regex----------------------------------------------------------------------------------- Main start-up functions---- | Wrapper for start-up in main executable-main :: IO ()-main = do- installHandler sigPIPE Ignore Nothing- getArgs >>= tryCommand---- | 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---- | 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- main' <- gets $ projMainIs . fromJust . kibProject- let main = dir </> main'- fcgi = out </> name ++ ".fcgi"- fcgiExists <- liftIO $ doesFileExist fcgi- if fcgiExists- then do [mainTime,fcgiTime] <- mapM modTime [main,fcgi]- if mainTime > fcgiTime- then build- else return ()- else build- where modTime p = liftIO $ modificationTime <$> getFileStatus p- build = cmdAct buildCmd []--------------------------------------------- `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- dirs <- projectDirs- let src = fromJust . lookup "src" $ dirs- public = fromJust . lookup "public" $ dirs- dir <- projectDir- main <- projectMain- name <- projectName- opts <- gets $ projGHCOpts . fromJust . kibProject- let cmd = "ghc --make " ++ dir </> main ++ " -o " ++ fcgi ++ " -threaded " ++ opts- fcgi = dir </> public </> name ++ ".fcgi"- curDir <- liftIO $ getCurrentDirectory- liftIO $ setCurrentDirectory $ dir </> src- runShellCmd cmd- liftIO $ setCurrentDirectory curDir--------------------------------------------- `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- , projGHCOpts = "" }- 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- name <- projectName- liftIO $ do- putStr $ "Writing " ++ name ++ ".kibro ... "- writeFile (dir </> name ++ ".kibro") $ C.to_string $ buildConfig name- 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' <- readConfig 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- , projGHCOpts :: String- } deriving (Eq,Show,Read)--------------------- Configuration parser and shower--buildConfig :: String -> ConfigParser-buildConfig name = fromEither $ foldM setOpt C.emptyCP (addName $ opts) where- setOpt cp (name,opt) = C.set cp "DEFAULT" name opt- fromEither (Right x) = x- addName = (("name",name) :) . filter ((/="name") . fst)--readConfig :: String -> Command KibroProject-readConfig config = do - rv <- runErrorT $- do cp <- join $ liftIO $ C.readfile C.emptyCP config- let x = cp- options <- mapM (\e -> (,) e <$> C.get x "DEFAULT" e) optNames- return (options :: [(String,String)])- case rv of- Left (C.NoOption entry, _) -> configError $ "`" ++ entry ++ "' was not provided in the config"- Left (e,_) -> configError $ show e- Right vs -> return $ optsToProject vs- where configError e = cmdError $ config ++ ": " ++ e--optsToProject :: [(String,String)] -> KibroProject-optsToProject ls = KibroProject - { projName = get "name"- , projDirs = [("fastcgi",get "fastcgi-dir")- ,("app", get "app-dir")- ,("lighttpd",get "lighttpd-dir")- ,("public", get "public-dir")- ,("src", get "src-dir")]- , projOutDir = get "fcgi-out-dir" - , projMainIs = get "main-is"- , projLighttpd = readBool $ get "manage-lighttpd" - , projGHCOpts = get "ghc-options" }- where get = fromJust . flip lookup ls- readBool = readBool' . map toLower- readBool' "yes" = True- readBool' "no" = False- readBool' "true" = True- readBool' "false" = False--optNames = map fst opts-opts = [("name","jboborei")- ,("app-dir","app")- ,("lighttpd-dir", "app/lighttpd")- ,("fastcgi-dir", "app/fastcgi")- ,("public-dir", "public")- ,("src-dir", "src")- ,("fcgi-out-dir", "public")- ,("main-is", "src/Main.hs")- ,("ghc-options", "")- ,("manage-lighttpd", "yes")]---------------------------------------------------------------------------------- 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 ()
kibro.cabal view
@@ -1,23 +1,9 @@-name: kibro-version: 0.4.3-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-+name: kibro+version: 0.5.0+synopsis: None+description: None+license: BSD3+author: None+build-type: Simple+cabal-version: >=1.2 library- build-depends: base==3.*,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==3.*,filepath,directory,haskell98,process,strict,unix,ConfigFile- hs-source-dirs: executable/
− library/Kibro.hs
@@ -1,307 +0,0 @@-{-# 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 <<$