kibro-0.4.1: executable/Main.hs
{-# LANGUAGE FlexibleInstances #-}
------------------------------------------------------------------------------
-- 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 ()