module Hbro.Core (
runK,
mapK,
mapK2,
with,
withK,
withTitle,
withURI,
getFaviconURI,
getLoadProgress,
getTitle,
getURI,
getState,
goBack,
goForward,
goHome,
loadURI,
reload,
reloadBypassCache,
stopLoading,
zoomIn,
zoomOut,
Axis(..),
Position(..),
scroll,
notify,
searchText,
toggleSourceMode,
printPage,
executeJSFile
) where
import Hbro.Types
import Hbro.Util
import Control.Monad.Reader hiding(forM_, mapM_)
import Data.Dynamic
import Data.Foldable
import Data.Functor
import Data.IORef
import qualified Data.Map as M
import Graphics.UI.Gtk.Display.Label
import Graphics.UI.Gtk.General.General
import Graphics.UI.Gtk.Misc.Adjustment
import Graphics.UI.Gtk.Scrolling.ScrolledWindow
import Graphics.UI.Gtk.WebKit.WebDataSource
import Graphics.UI.Gtk.WebKit.WebFrame
import Graphics.UI.Gtk.WebKit.WebView
import Network.URI
import Prelude hiding(mapM_)
import System.Console.CmdArgs
runK :: Environment -> KT m a -> m a
runK env (KT function) = runReaderT function env
mapK :: (m a -> n b) -> KT m a -> KT n b
mapK function (KT env) = KT $ mapReaderT function env
mapK2 :: ((c -> m a) -> n b) -> (c -> KT m a) -> KT n b
mapK2 f g = KT . ReaderT $ \b -> f (runK b . g)
with :: (Environment -> a) -> (a -> IO b) -> K b
with selector callback = withK selector $ io . callback
withK :: (Environment -> a) -> (a -> K b) -> K b
withK selector callback = callback =<< asks selector
withTitle :: (String -> K ()) -> K ()
withTitle callback = (mapM_ callback) =<< getTitle
withURI :: (URI -> K ()) -> K ()
withURI callback = (mapM_ callback) =<< getURI
getFaviconURI :: K (Maybe URI)
getFaviconURI = with (mWebView . mGUI) $ (return . (parseURI =<<)) <=< webViewGetIconUri
getLoadProgress :: K Double
getLoadProgress = with (mWebView . mGUI) webViewGetProgress
getURI :: K (Maybe URI)
getURI = with (mWebView . mGUI) $ (return . (parseURI =<<)) <=< webViewGetUri
getTitle :: K (Maybe String)
getTitle = with (mWebView . mGUI) webViewGetTitle
getState :: Typeable a => String -> a -> K (IORef a)
getState key defaultValue = with mState $ \state -> do
result <- (fromDynamic <=< M.lookup key) <$> readIORef state
case result of
Just value -> return value
_ -> do
value <- newIORef defaultValue
modifyIORef state . M.insert key . toDyn $ value
return value
goBack, goForward, goHome :: K ()
goBack = withK (mWebView . mGUI) $ \view -> do
canGoBack <- io . webViewCanGoBack $ view
unless canGoBack $ notify 5000 "Cannot go back anymore"
io . webViewGoBack $ view
goForward = withK (mWebView . mGUI) $ \view -> do
canGoForward <- io . webViewCanGoForward $ view
unless canGoForward $ notify 5000 "Cannot go forward anymore"
io . webViewGoForward $ view
goHome = withK (mHomePage . mConfig) $ mapM_ loadURI . parseURIReference
loadURI :: URI -> K ()
loadURI uri = do
io . whenLoud . putStrLn . ("Loading URI: " ++) . show $ uri'
with (mWebView . mGUI) (`webViewLoadUri` uri')
where
uri' = case uriScheme uri of
[] -> "http://" ++ show uri
_ -> show uri
reload, reloadBypassCache, stopLoading :: K ()
reload = with (mWebView . mGUI) webViewReload
reloadBypassCache = with (mWebView . mGUI) webViewReloadBypassCache
stopLoading = do
with (mWebView . mGUI) webViewStopLoading
notify 5000 "Stopped loading"
zoomIn, zoomOut :: K ()
zoomIn = with (mWebView . mGUI) webViewZoomIn
zoomOut = with (mWebView . mGUI) webViewZoomOut
data Axis = Horizontal | Vertical
data Position = Absolute Double | Relative Double
getAdjustment :: Axis -> (ScrolledWindow -> IO Adjustment)
getAdjustment Horizontal = scrolledWindowGetHAdjustment
getAdjustment Vertical = scrolledWindowGetVAdjustment
scroll :: Axis -> Position -> K ()
scroll axis percentage = with (mScrollWindow . mGUI) $ \window -> do
adj <- getAdjustment axis window
page <- adjustmentGetPageSize adj
current <- adjustmentGetValue adj
lower <- adjustmentGetLower adj
upper <- adjustmentGetUpper adj
let shift (Absolute x) = lower + x/100 * (upper page lower)
shift (Relative x) = current + x/100 * page
limit x = (x `max` lower) `min` (upper page)
adjustmentSetValue adj $ limit (shift percentage)
notify :: Int -> String -> K ()
notify duration text = with (mNotificationBar . mGUI) $ \notificationBar -> do
let label = mLabel notificationBar
labelSetMarkup label text
let timer = mTimer notificationBar
oldID <- readIORef timer
forM_ oldID timeoutRemove
newID <- timeoutAdd (labelSetMarkup label "" >> return False) duration
modifyIORef timer $ const . Just $ newID
searchText :: CaseSensitivity -> Direction -> Wrap -> String -> K Bool
searchText s d w text = with (mWebView . mGUI) $ \view ->
webViewSearchText view text (isCaseSensitive s) (isForward d) (isWrapped w)
toggleSourceMode :: K ()
toggleSourceMode = do
with (mWebView . mGUI) $ \view ->
webViewSetViewSourceMode view =<< (not <$> webViewGetViewSourceMode view)
reload
printPage :: K ()
printPage = with (mWebView . mGUI) $ webViewGetMainFrame >=> webFramePrint
executeJSFile :: FilePath -> WebView -> IO ()
executeJSFile filePath webView = do
whenNormal $ putStrLn ("Executing Javascript file: " ++ filePath)
script <- readFile filePath
let script' = unwords . map (\line -> line ++ "\n") . lines $ script
webViewExecuteScript webView script'
_savePage :: String -> WebView -> IO ()
_savePage _path webView = do
frame <- webViewGetMainFrame webView
dataSource <- webFrameGetDataSource frame
_mainResource <- webDataSourceGetMainResource dataSource
_subResources <- webDataSourceGetSubresources dataSource
return ()