Archived
1
0
Fork 0

Got rid of the pseudo dynamic starting stuff, wrote a decent CLI parameters handling.

This commit is contained in:
Julien Dessaux 2010-07-16 00:55:50 +02:00
parent 116c655fdc
commit 5cb9f9ccfc
4 changed files with 68 additions and 56 deletions

View file

@ -1,2 +1,3 @@
.*.swp .*.swp
Session.vim Session.vim
dist

View file

@ -24,13 +24,13 @@ hsbot config txtResumeData= do
Just txtData -> read txtData :: BotResumeData -- TODO : catch exception Just txtData -> read txtData :: BotResumeData -- TODO : catch exception
Nothing -> M.empty :: BotResumeData Nothing -> M.empty :: BotResumeData
startTime <- case M.lookup "HSBOT" resumeData of startTime <- case M.lookup "HSBOT" resumeData of
Just hsbotData -> do Just hsbotData -> do
case M.lookup "STARTTIME" hsbotData of case M.lookup "STARTTIME" hsbotData of
Just txtStartTime -> do Just txtStartTime -> do
let gotStartTime = read txtStartTime :: UTCTime let gotStartTime = read txtStartTime :: UTCTime
return gotStartTime return gotStartTime
Nothing -> getCurrentTime Nothing -> getCurrentTime
Nothing -> getCurrentTime Nothing -> getCurrentTime
let resumeData' = M.insert "HSBOT" (M.singleton "STARTTIME" $ show startTime) resumeData let resumeData' = M.insert "HSBOT" (M.singleton "STARTTIME" $ show startTime) resumeData
putStrLn "[Hsbot] Opening communication channel... " putStrLn "[Hsbot] Opening communication channel... "
chan <- newChan :: IO (Chan BotMsg) chan <- newChan :: IO (Chan BotMsg)

View file

@ -2,57 +2,73 @@ module Main (main) where
import Control.Monad (when) import Control.Monad (when)
import Prelude hiding (catch) import Prelude hiding (catch)
import System.Directory import System.Console.GetOpt
import System.Environment import System.Environment
import System.Exit import System.Exit
import System.FilePath
import System.Info
import System.IO import System.IO
import System.Posix.Process (executeFile)
import System.Process
-- | Dynamic launching function -- | Main function
main :: IO () main :: IO ()
main = do main = do
args <- getArgs args <- getArgs
case args of -- Parse options, getting a list of option actions
[] -> buildLaunch let (actions, nonOptions, errors) = getOpt RequireOrder options args
["--help"] -> usage -- Here we thread startOptions through all supplied option actions
_ -> fail "unrecognized flags" opts <- case (nonOptions, errors) of
([], []) -> foldl (>>=) (return defaultOptions) actions
(_, _) -> do
hPutStrLn stderr $ concat errors ++ usageInfo header options
exitWith $ ExitFailure 1
when (optDebug opts) . putStrLn $ "Got options : " ++ (show opts)
usage :: IO () -- | CLI options
usage = do data Options = Options
self <- getProgName { optDebug :: Bool
putStr . unlines $ , optConfigFile :: Maybe String
concat ["Usage: ", self, " [OPTION]"] : , optGroup :: Maybe String
"Options:" : , optUser :: Maybe String
" --help : Print this message" : , optVerbose :: Bool
[] } deriving (Show)
buildLaunch :: IO () -- | CLI default options
buildLaunch = do defaultOptions :: Options
_ <- recompile defaultOptions = Options { optDebug = False
dir <- getAppUserDataDirectory "hsbot" , optConfigFile = Nothing
args <- getArgs , optGroup = Nothing
_ <- executeFile (dir ++ "/hsbot-" ++ arch ++ "-" ++ os) False args Nothing , optUser = Nothing
return () , optVerbose = False }
recompile :: IO (Bool) -- | CLI options logic
recompile = do options :: [ OptDescr (Options -> IO Options) ]
dir <- getAppUserDataDirectory "hsbot" options =
let binn = "hsbot-"++arch++"-"++os [ Option "d" ["debug"]
base = dir </> "hsbot" (NoArg (\opt -> return opt { optDebug = True, optVerbose = True }))
err = base ++ ".errors" "Enter verbose debug mode and prevents Hsbot from forking in background"
src = base ++ ".hs" , Option "f" ["file"]
errorHandle <- openFile err WriteMode (ReqArg (\arg opt -> return opt { optConfigFile = return arg }) "<config_file>")
exitCode <- waitForProcess =<< runProcess "ghc" ["--make", "hsbot.hs", "-fforce-recomp", "-XScopedTypeVariables", "-o", binn] (Just dir) "The config file to use"
Nothing Nothing Nothing (Just errorHandle) , Option "g" ["group"]
hClose errorHandle (ReqArg (\arg opt -> return opt { optGroup = return arg }) "<group>")
when (exitCode /= ExitSuccess) $ do "The group hsbot will run as"
ghcErr <- readFile err , Option "h" ["help"]
let msg = unlines $ (NoArg (\_ -> do
["Error detected while loading hsbot configuration file: " ++ src] putStrLn $ usageInfo header options
++ lines ghcErr ++ ["","Please check the file for errors."] exitWith ExitSuccess))
hPutStrLn stderr msg "Print this help message"
return (exitCode == ExitSuccess) , Option "u" ["user"]
(ReqArg (\arg opt -> return opt { optUser = return arg }) "<user>")
"The user hsbot will run as"
, Option "v" ["verbose"]
(NoArg (\opt -> return opt { optVerbose = True }))
"Enable verbose messages"
, Option "V" ["version"]
(NoArg (\_ -> do
putStrLn "Hsbot version 0.3"
exitWith ExitSuccess))
"Show version"
]
-- | Usage header
header :: String
header = "Usage: hsbot [-dhvV] [-f config_file] [-u user] [-g group]"

View file

@ -20,17 +20,12 @@ Executable hsbot
Main-is: Main.hs Main-is: Main.hs
Ghc-options: -Wall Ghc-options: -Wall
Extensions: DeriveDataTypeable ScopedTypeVariables Extensions: DeriveDataTypeable ScopedTypeVariables
Build-depends: base >= 4.1 && < 5, Build-depends: base >= 4.1 && < 5
directory >= 1.0,
filepath >= 1.1,
process >= 1.0,
unix >= 2.4
Library Library
Ghc-options: -Wall Ghc-options: -Wall
Extensions: DeriveDataTypeable ScopedTypeVariables Extensions: DeriveDataTypeable ScopedTypeVariables
Exposed-modules: Hsbot.Message, Exposed-modules: Hsbot.Message,
Hsbot.PluginUtils,
Hsbot.Types Hsbot.Types
Build-depends: base >= 4.1 && < 5, Build-depends: base >= 4.1 && < 5,
containers >= 0.3, containers >= 0.3,