module Hbro.Core where
import Hbro.Gui
import Hbro.Socket
import Hbro.Util
import qualified Config.Dyre as Dyre
import Control.Concurrent
import Control.Monad.Trans(liftIO)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Graphics.UI.Gtk.Abstract.Container
import Graphics.UI.Gtk.Abstract.Widget
import Graphics.UI.Gtk.General.General
import Graphics.UI.Gtk.Gdk.EventM
import Graphics.UI.Gtk.WebKit.WebView
import Graphics.UI.Gtk.WebKit.WebFrame
import Graphics.UI.Gtk.WebKit.WebInspector
import Graphics.UI.Gtk.WebKit.WebSettings
import Network.URL
import Prelude
import System.Console.CmdArgs
import System.Glib.Signals
import System.Posix.Process
data Browser = Browser {
mOptions :: CliOptions,
mGUI :: GUI
}
data Configuration = Configuration {
mHomePage :: String,
mSocketDir :: String,
mUIFile :: String,
mKeyBindings :: KeyBindingsList,
mWebSettings :: IO WebSettings,
mAtStartUp :: GUI -> IO (),
mError :: Maybe String
}
type KeyBindingsList = [(([Modifier], String), (GUI -> IO ()))]
data CliOptions = CliOptions {
mURI :: Maybe String
} deriving (Data, Typeable, Show, Eq)
cliOptions :: CliOptions
cliOptions = CliOptions{
mURI = def &= help "URI to open at startup" &= explicit &= name "u" &= name "uri" &= typ "URI"
}
getOptions :: IO CliOptions
getOptions = cmdArgs $ cliOptions
&= verbosityArgs [explicit, name "Verbose", name "v"] []
&= versionArg [ignore]
&= help "A suckless minimal KISSy browser."
&= helpArg [explicit, name "help", name "h"]
&= program "hbro"
realMain :: Configuration -> IO ()
realMain configuration = do
options <- getOptions
initBrowser configuration options
initBrowser :: Configuration -> CliOptions -> IO ()
initBrowser configuration options = do
case (mError configuration) of
Just e -> putStrLn e
_ -> return ()
_ <- initGUI
gui <- loadGUI (mUIFile configuration)
pid <- getProcessID
_ <- forkIO $ createReplySocket ("ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ show pid) gui
settings <- mWebSettings configuration
webViewSetWebSettings (mWebView gui) settings
(mAtStartUp configuration) gui
let url = case (mURI options) of
Just x -> x
_ -> mHomePage configuration
loadURL url gui
let keyBindings = importKeyBindings (mKeyBindings configuration)
_ <- on (mWebView gui) createWebView $ \frame -> do
newUri <- webFrameGetUri frame
case newUri of
Just uri -> webViewLoadUri (mWebView gui) uri
Nothing -> return ()
return (mWebView gui)
inspector <- webViewGetInspector (mWebView gui)
_ <- on inspector inspectWebView $ \_ -> do
webView <- webViewNew
containerAdd (mInspectorWindow gui) webView
return webView
_ <- on inspector showWindow $ do
widgetShowAll (mInspectorWindow gui)
return True
widgetShowAll (mInspectorWindow gui)
return True
_ <- after (mWebView gui) keyPressEvent $ do
value <- eventKeyVal
modifiers <- eventModifier
let keyString = keyToString value
case keyString of
Just string -> do
case Map.lookup (Set.fromList modifiers, string) keyBindings of
Just callback -> liftIO $ callback gui
_ -> liftIO $ putStrLn string
_ -> return ()
return False
_ <- onDestroy (mWindow gui) mainQuit
widgetShowAll (mWindow gui)
widgetHide (mPromptLabel gui)
widgetHide (mPrompt gui)
mainGUI
showWebInspector :: GUI -> IO ()
showWebInspector gui = do
inspector <- webViewGetInspector (mWebView gui)
webInspectorInspectCoordinates inspector 0 0
loadURL :: String -> GUI -> IO ()
loadURL url gui =
case importURL url of
Just url' -> loadURL' url' gui
_ -> return ()
loadURL' :: URL -> GUI -> IO ()
loadURL' url@URL {url_type = Absolute _} gui =
webViewLoadUri (mWebView gui) (exportURL url)
loadURL' url@URL {url_type = HostRelative} gui =
webViewLoadUri (mWebView gui) ("file://" ++ exportURL url) >> putStrLn (show url)
loadURL' url@URL {url_type = _} gui =
webViewLoadUri (mWebView gui) ("http://" ++ exportURL url) >> print url
showError :: Configuration -> String -> Configuration
showError configuration message = configuration { mError = Just message }
hbro :: Configuration -> IO ()
hbro = Dyre.wrapMain Dyre.defaultParams {
Dyre.projectName = "hbro",
Dyre.showError = showError,
Dyre.realMain = realMain,
Dyre.ghcOpts = ["-threaded"]
}