module Hbro.Core where
import Hbro.Gui
import Hbro.Socket
import Hbro.Types
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.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 Network.URL
import Prelude
import System.Console.CmdArgs
import System.Glib.Signals
import System.Posix.Process
import qualified System.ZMQ as ZMQ
cliOptions :: CliOptions
cliOptions = CliOptions{
mURI = def &= help "URI to open at start-up" &= 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
case (mError configuration) of
Just e -> putStrLn e
_ -> return ()
initBrowser configuration options
initBrowser :: Configuration -> CliOptions -> IO ()
initBrowser configuration options = do
_ <- initGUI
gui <- loadGUI (mUIFile configuration)
let browser = Browser options configuration gui
let webView = mWebView gui
pid <- getProcessID
context <- ZMQ.init 1
repSocket <- ZMQ.socket context ZMQ.Rep
let socketURI = "ipc://" ++ (mSocketDir configuration) ++ "/hbro." ++ show pid
ZMQ.bind repSocket socketURI
_ <- quitAdd 0 $ do
ZMQ.setOption repSocket (ZMQ.Linger 0)
ZMQ.close repSocket
ZMQ.term context
return False
_ <- forkIO $ listenToSocket repSocket browser
settings <- mWebSettings configuration
webViewSetWebSettings webView settings
(mAtStartUp configuration) browser
goHome browser
let keyBindings = importKeyBindings (mKeyBindings configuration)
_ <- on webView createWebView $ \frame -> do
newUri <- webFrameGetUri frame
putStrLn "NEW WINDOW"
case newUri of
Just uri -> webViewLoadUri webView uri
Nothing -> return ()
return webView
_ <- after webView 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 browser
_ -> liftIO $ putStrLn string
_ -> return ()
return False
_ <- onDestroy (mWindow gui) mainQuit
widgetShowAll (mWindow gui)
showPrompt False browser
mainGUI
goHome, goBack, goForward, stopLoading :: Browser -> IO ()
goBack browser = webViewGoBack (mWebView $ mGUI browser)
goForward browser = webViewGoForward (mWebView $ mGUI browser)
stopLoading browser = webViewStopLoading (mWebView $ mGUI browser)
goHome browser = case (mURI $ mOptions browser) of
Just uri -> loadURL uri browser
_ -> loadURL (mHomePage $ mConfiguration browser) browser
reload :: Bool -> Browser -> IO()
reload True browser = webViewReload (mWebView $ mGUI browser)
reload _ browser = webViewReloadBypassCache (mWebView $ mGUI browser)
zoomIn, zoomOut :: Browser -> IO()
zoomIn browser = webViewZoomIn (mWebView $ mGUI browser)
zoomOut browser = webViewZoomOut (mWebView $ mGUI browser)
printPage :: Browser -> IO()
printPage browser = do
frame <- webViewGetMainFrame (mWebView $ mGUI browser)
webFramePrint frame
loadURL :: String -> Browser -> IO ()
loadURL url browser =
case importURL url of
Just url' -> loadURL' url' browser
_ -> return ()
loadURL' :: URL -> Browser -> IO ()
loadURL' url@URL {url_type = Absolute _} browser =
webViewLoadUri (mWebView $ mGUI browser) (exportURL url)
loadURL' url@URL {url_type = HostRelative} browser =
webViewLoadUri (mWebView $ mGUI browser) ("file://" ++ exportURL url) >> putStrLn (show url)
loadURL' url@URL {url_type = _} browser =
webViewLoadUri (mWebView $ mGUI browser) ("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"]
}