module Hbro.Boot where
import Hbro.Core
import qualified Hbro.Gui as Gui
import qualified Hbro.Prompt as Prompt
import qualified Hbro.Socket as Socket
import Hbro.Types
import Hbro.Util
import Hbro.Webkit.WebView as WebView
import Control.Concurrent
import qualified Config.Dyre as D
import Config.Dyre.Compile
import Config.Dyre.Paths
import Control.Applicative
import Control.Monad
import Control.Monad.Error
import Control.Monad.Reader
import Data.IORef
import Graphics.UI.Gtk.General.General hiding(initGUI)
import Network.URI as N
import System.Console.CmdArgs
import System.Directory
import System.FilePath
import System.Exit
import System.IO
import System.Posix.Signals
import qualified System.ZMQ as ZMQ
baseOptions :: CliOptions
baseOptions = CliOptions {
__startURI = def &= explicit &= name "u" &= name "uri" &= typ "URI" &= help "URI to open at start-up",
__vanilla = def &= explicit &= name "1" &= name "vanilla" &= help "Do not read custom configuration file.",
__recompile = def &= explicit &= name "r" &= name "recompile" &= help "Force recompilation and do not launch browser.",
__denyReconf = def &= explicit &= name "deny-reconf" &= help "Deny recompilation even if the configuration file has changed.",
__forceReconf = def &= explicit &= name "force-reconf" &= help "Force recompilation even if the configuration file hasn't changed.",
__dyreDebug = def &= explicit &= name "dyre-debug" &= help "Force the application to use './cache/' as the cache directory, and ./ as the configuration directory. Useful to debug the program without installation.",
__masterBinary = def &= explicit &= name "dyre-master-binary"}
cliOptions :: Mode (CmdArgs CliOptions)
cliOptions = cmdArgsMode $ baseOptions
&= verbosityArgs [explicit, name "verbose", name "v"] []
&= versionArg [ignore]
&= help "A minimal KISS-compliant browser."
&= helpArg [explicit, name "help", name "h"]
&= program "hbro"
printDyrePaths :: IO ()
printDyrePaths = do
(a, b, c, d, e) <- getPaths dyreParameters
putStrLn $ unlines [
"Current binary: " ++ a,
"Custom binary: " ++ b,
"Config file: " ++ c,
"Cache directory: " ++ d,
"Lib directory: " ++ e, []]
dyreParameters :: D.Params (Either String (Config, Setup, CliOptions))
dyreParameters = D.defaultParams {
D.projectName = "hbro",
D.showError = \_ -> Left,
D.realMain = realMain,
D.ghcOpts = ["-threaded"],
D.statusOut = hPutStrLn stderr,
D.includeCurrentDirectory = False}
recompile :: IO (Maybe String)
recompile = do
customCompile dyreParameters
getErrorString dyreParameters
hbro :: Config -> Setup -> IO ()
hbro config startUp = do
options <- cmdArgsRun cliOptions
when (_recompile options) $
recompile >>= maybe exitSuccess (\e -> putStrLn e >> exitFailure)
D.wrapMain dyreParameters{ D.configCheck = not $ _vanilla options } $ Right (config, startUp, options)
realMain :: Either String (Config, Setup, CliOptions) -> IO ()
realMain (Left e) = putStrLn e
realMain (Right (config, Setup customSetup, options)) = do
void $ installHandler sigINT (Catch interruptHandler) Nothing
whenLoud printDyrePaths
gui <- runReaderT Gui.build' config
hooks <- Hooks <$> newIORef Nothing <*> newIORef Nothing <*> newIORef Nothing
startURI <- getStartURI options
keys <- newIORef ""
zmqContext <- ZMQ.init 1
result <- runErrorT . (`runReaderT` Context options config gui zmqContext hooks keys) $ do
threadSync <- fork Socket.open
Gui.setupWindow
Gui.setupScrollWindow
Prompt.setup
WebView.setup
customSetup
maybe goHome loadURI startURI
io mainGUI
Socket.close
io $ takeMVar threadSync
either print return result
ZMQ.term zmqContext
logNormal "Exiting..."
getStartURI :: CliOptions -> IO (Maybe URI)
getStartURI options = case (__startURI options) of
Just uri -> do
fileURI <- doesFileExist uri
case fileURI of
True -> getCurrentDirectory >>= return . N.parseURIReference . ("file://" ++) . (</> uri)
_ -> return $ N.parseURIReference uri
_ -> return Nothing
interruptHandler :: IO ()
interruptHandler = logVerbose "Received SIGINT." >> mainQuit