diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c)2011, Krzysztof Skrzętnicki + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Krzysztof Skrzętnicki nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/cbits.c b/cbits/cbits.c new file mode 100644 --- /dev/null +++ b/cbits/cbits.c @@ -0,0 +1,20 @@ +#include +#include +#include + +#include +#include +#include +#include + +void spike_setup_webkit_globals(char * web_database_path, char * cookie_jar_path) +{ + //eg. /tmp/spike.webkit.db + webkit_set_web_database_directory_path(web_database_path); + + + SoupSession * ses = webkit_get_default_session(); + //eg. /tmp/spike.webkit.cookie.db + SoupCookieJar * jar = soup_cookie_jar_sqlite_new(cookie_jar_path, 0); + soup_session_add_feature( ses, SOUP_SESSION_FEATURE (jar)); +} diff --git a/spike.cabal b/spike.cabal new file mode 100644 --- /dev/null +++ b/spike.cabal @@ -0,0 +1,26 @@ +Name: spike +Version: 0.1 +Synopsis: Experimental web browser +Description: Experimental web browser based on WebKit-Gtk+ +License: BSD3 +License-file: LICENSE +Author: Krzysztof Skrzętnicki +Maintainer: gtener@gmail.com +Category: Web +Build-type: Simple +Cabal-version: >=1.6 +Homepage: http://github.com/Tener/spike + +Source-repository head + type: git + location: git://github.com/Tener/spike.git + + +Executable spike + Main-is: spike.hs + Other-modules: Utils, VisualBrowseTree, Datatypes, Graphs, CFunctions, NotebookSimple + Hs-source-dirs: src + Build-depends: webkit == 0.12.*, containers, gtk, base == 4.*, stm, mtl > 2, rosezipper, process, directory, filepath + Ghc-options: -rtsopts + C-sources: cbits/cbits.c + pkgconfig-depends: libsoup-gnome-2.4 diff --git a/src/CFunctions.hs b/src/CFunctions.hs new file mode 100644 --- /dev/null +++ b/src/CFunctions.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE PackageImports, FlexibleInstances, DoRec, ForeignFunctionInterface #-} + +module CFunctions(spikeSetupWebkitGlobals) where + +import Foreign +import Foreign.C + +foreign import ccall "spike_setup_webkit_globals" spike_setup_webkit_globals :: CString -> CString -> IO () + +spikeSetupWebkitGlobals arg1 arg2 = + withCString arg1 $ \ arg1' -> + withCString arg2 $ \ arg2' -> spike_setup_webkit_globals arg1' arg2' diff --git a/src/Datatypes.hs b/src/Datatypes.hs new file mode 100644 --- /dev/null +++ b/src/Datatypes.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE PackageImports, FlexibleInstances, DoRec, ForeignFunctionInterface #-} +module Datatypes where + +import Graphics.UI.Gtk.WebKit.WebView +import Graphics.UI.Gtk.WebKit.WebNavigationAction +import System.IO.Unsafe +import Graphics.UI.Gtk +import Control.Concurrent.STM +import Data.Tree + +data History = Hist { hiNow :: String, hiPrev :: [String], hiNext :: [String] } deriving Show + +data Page = Page { pgWeb :: WebView, pgWidget :: Widget, pgHistory :: TVar History } + +instance Show Page where + show pg = "Page { pgWeb=?, pgWidget=?, pgHistory=" ++ show (unsafeDupablePerformIO (readTVarIO (pgHistory pg))) ++ "}" + +instance Eq Page where + p1 == p2 = pgWidget p1 == pgWidget p2 + +type BrowseTree = Forest Page +type BrowseTreeState = TVar BrowseTree + +-- wrapper newtype to avoid orphan instances +newtype MyShow a = MyShow a +instance Show (MyShow NavigationReason) where + show (MyShow WebNavigationReasonLinkClicked ) = "WebNavigationReasonLinkClicked" + show (MyShow WebNavigationReasonFormSubmitted ) = "WebNavigationReasonFormSubmitted" + show (MyShow WebNavigationReasonBackForward ) = "WebNavigationReasonBackForward" + show (MyShow WebNavigationReasonReload ) = "WebNavigationReasonReload" + show (MyShow WebNavigationReasonFormResubmitted) = "WebNavigationReasonFormResubmitted" + show (MyShow WebNavigationReasonOther ) = "WebNavigationReasonOther" diff --git a/src/Graphs.hs b/src/Graphs.hs new file mode 100644 --- /dev/null +++ b/src/Graphs.hs @@ -0,0 +1,28 @@ +module Graphs where + +import Data.Tree +import Data.Tree.Zipper +import Data.Graph.Inductive + +treeToGraph :: (Graph gr) => Tree a -> gr a () +treeToGraph tr = labelTree tr [1..] + +labelTree tr = let tr1 = fmap tr (\x -> (x,0)) + tp1 = fromTree tr1 + tp2 = go 0 tp1 + tr2 = toTree tp2 + + + go ix tp = let tp' = modifyLabel (\(l,_) -> (l,ix)) tp in + + + go tp = case next tp of + Nothing -> firstChild tp + Just tpN -> go tpN + +labelTree (Node a xs) (y:ys) = let (xs',ys') = labelTree' xs ys + n' = Node (a,y) xs' + in + (n',xs') + +labelTree' lst labs = diff --git a/src/NotebookSimple.hs b/src/NotebookSimple.hs new file mode 100644 --- /dev/null +++ b/src/NotebookSimple.hs @@ -0,0 +1,133 @@ +{-# LANGUAGE ViewPatterns #-} + +-- this module is a simple reimplementation of GTK Notebook widget. +-- I needed to be able to change the list of pages without receving a signal from it. +module NotebookSimple where + +import Graphics.UI.Gtk +import Control.Concurrent +import Control.Concurrent.STM + +import Data.List (elemIndex) + +import Utils +import Datatypes + +data NotebookSimple = NotebookSimple { ns_tabs :: HBox + , ns_widget :: Widget + , ns_pages :: TVar [Page] + , ns_currentPage :: TVar (Maybe Int) + , ns_refresh :: IO () + } + +newScrolledWindowWithViewPort :: WidgetClass child => child -> IO ScrolledWindow +newScrolledWindowWithViewPort child = do + sw <- scrolledWindowNew Nothing Nothing + scrolledWindowSetPolicy sw PolicyAutomatic PolicyAutomatic + scrolledWindowAddWithViewport sw child + (wx,wy) <- widgetGetSizeRequest child + widgetSetSizeRequest sw (wx+5) (wy+5) + return sw + +notebookSimpleNew :: (Page -> IO ()) -> IO NotebookSimple +notebookSimpleNew focusOnPage = do + buttonsBox <- hBoxNew False 1 + contentBox <- hBoxNew False 1 + vbox <- vBoxNew False 1 + + widgetSetSizeRequest buttonsBox (-1) 40 + + (\sw -> boxPackStart vbox sw PackNatural 1) =<< newScrolledWindowWithViewPort buttonsBox + boxPackStart vbox contentBox PackGrow 1 + + widgetShowAll vbox + + pgs <- newTVarIO [] :: IO (TVar [Page]) + curr <- newTVarIO Nothing + + let updateButtons = postGUIAsync $ do + pages <- readTVarIO pgs + listPagesBox focusOnPage pages buttonsBox + + updatePage = do + wg <- getCurrentWidget + case wg of + Just wg' -> postGUIAsync (do + containerForeach contentBox (containerRemove contentBox) + set contentBox [ containerChild := (pgWidget wg') ] >> widgetShowAll vbox) + Nothing -> print "strange stuff." + + getCurrentWidget = do + c <- readTVarIO curr + p <- readTVarIO pgs + case c of + Nothing -> return Nothing + Just c' -> return (if c' < length p then Just (p !! c') else Nothing) + + let watchdog page = do + page' <- waitTVarChangeFrom page curr + updatePage + watchdog page' + + let watchdog2 pages = do + pages' <- waitTVarChangeFrom pages pgs + updateButtons + watchdog2 pages' + + forkIO (watchdog2 =<< readTVarIO pgs) + forkIO (watchdog =<< readTVarIO curr) + + let updateAll = updateButtons >> updatePage + return (NotebookSimple { ns_tabs = contentBox + , ns_widget = (toWidget vbox) + , ns_pages = pgs + , ns_currentPage = curr + , ns_refresh = updateAll }) + +notebookSimpleAddPage :: NotebookSimple -> Page -> IO () +notebookSimpleAddPage ns@(ns_pages -> pages) page = do + atomically $ do + pages' <- readTVar pages + writeTVar pages (pages' ++ [page]) + notebookSimpleSelectPageIfNone ns + +notebookSimpleSelectPage :: NotebookSimple -> Page -> IO () +notebookSimpleSelectPage ns page = do + atomically $ do + current <- readTVar (ns_currentPage ns) + pages <- readTVar (ns_pages ns) + writeTVar (ns_currentPage ns) (elemIndex page pages) + +notebookSimpleSelectPageIfNone :: NotebookSimple -> IO () +notebookSimpleSelectPageIfNone ns = do + atomically $ do + current <- readTVar (ns_currentPage ns) + case current of + Nothing -> writeTVar (ns_currentPage ns) (Just 0) + Just _ -> return () + + +-- | list pages in a box +-- listPagesBox :: (BoxClass box) => [Page] -> box -> IO () +listPagesBox :: BoxClass box => (Page -> IO a) -> [Page] -> box -> IO () +listPagesBox focusOnPage pages box = do + containerForeach box (containerRemove box) + mapM_ (\p -> do + title <- getPageTitle p + l <- labelNew (Just title) -- TODO: use AccelLabel and shortcuts for specific pages + labelSetEllipsize l EllipsizeEnd + labelSetWidthChars l 20 + labelSetSingleLineMode l True + + b <- buttonNew + containerAdd b l + + boxPackStart box b PackNatural 1 + + on b buttonActivated $ do + print ("SIGNAL: on focus", title) + focusOnPage p + return () + ) pages + widgetShowAll box + return () diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,85 @@ +module Utils where + +import Control.Concurrent.STM +import Graphics.UI.Gtk.WebKit.WebView +import Graphics.UI.Gtk +import Data.Tree +import Data.Maybe +import Data.Tree.Zipper + +import Datatypes + +-- | wait until the TVar changes it's value from specified outer value +waitTVarChangeFrom :: (Eq a) => a -> (TVar a) -> IO a +waitTVarChangeFrom t tv = do + tNew <- atomically $ do + t' <- readTVar tv + if (t' /= t) then return t' else retry + return tNew + +-- | wait until the TVar changes it's value from it's current value +waitTVarChange :: (Eq a) => (TVar a) -> IO a +waitTVarChange tv = readTVarIO tv >>= flip waitTVarChangeFrom tv + +-- | block for two TVars to change their value from specified tuple value +waitTVarChangePairFrom :: (Eq a,Eq b) => (a,b) -> ((TVar a),(TVar b)) -> IO (a,b) +waitTVarChangePairFrom (ta,tb) (tva,tvb) = do + tt <- atomically $ do + ta' <- readTVar tva + tb' <- readTVar tvb + let tt' = (ta',tb') + if tt' /= (ta,tb) then return tt' else retry + return tt + +-- | block for two TVars to change their value from their current values +waitTVarChangePair :: (Eq a,Eq b) => ((TVar a),(TVar b)) -> IO (a,b) +waitTVarChangePair tt@(tva,tvb) = do + ta <- readTVarIO tva + tb <- readTVarIO tvb + waitTVarChangePairFrom (ta,tb) tt + + + +dontReenter :: TVar Bool -> IO a -> IO () +dontReenter var act = do + a' <- atomically $ do + v <- readTVar var + if v + then return (return ()) + else writeTVar var True >> return (act >> atomically (writeTVar var False)) + a' + +callDepthCount :: TVar Int -> (Int -> IO a) -> IO () +callDepthCount var act = do + v <- atomically $ do + v' <- readTVar var + writeTVar var (v'+1) + return v' + act v + atomically $ writeTVar var v + +---------------- + + +isWidgetPage :: Widget -> Page -> IO Bool +isWidgetPage w p = do + return (pgWidget p == w) + +isSamePage :: Page -> Page -> Bool +isSamePage p1 p2 = pgWidget p1 == pgWidget p2 + +getPageTitle :: Page -> IO String +getPageTitle p = do + mtit <- webViewGetTitle (pgWeb p) + h <- readTVarIO (pgHistory p) + case mtit of + Nothing -> return (hiNow h) + Just t -> return t + +flattenToZipper :: Tree a -> [TreePos Full a] +flattenToZipper n@(Node _ sub) = fromTree n : concatMap flattenToZipper sub + + +flattenToZipper' :: Tree a -> [TreePos Full a] +flattenToZipper' n = go (fromTree n) where + go z = [z] ++ (fromMaybe [] (fmap go (firstChild z))) ++ (fromMaybe [] (fmap go (next z))) diff --git a/src/VisualBrowseTree.hs b/src/VisualBrowseTree.hs new file mode 100644 --- /dev/null +++ b/src/VisualBrowseTree.hs @@ -0,0 +1,134 @@ +module VisualBrowseTree where + + + +import Graphics.UI.Gtk.WebKit.WebFrame +import Graphics.UI.Gtk.WebKit.WebView +import Graphics.UI.Gtk.WebKit.Download +import Graphics.UI.Gtk.WebKit.WebSettings +import Graphics.UI.Gtk.WebKit.NetworkRequest +import Graphics.UI.Gtk.WebKit.WebNavigationAction +-- import Graphics.UI.Gtk.WebKit.WebWindowFeatures + +import System.IO.Unsafe +import System.Process +import System.Exit + +import Graphics.UI.Gtk +import Text.Printf +import Control.Monad +import Control.Concurrent.STM +import Control.Concurrent + +import qualified Data.Foldable as F +import qualified Data.Traversable as T +import Data.Tree.Zipper +import Data.Maybe +import qualified Data.List + +import Utils +import NotebookSimple +import Datatypes + +import Data.Tree as Tree + + +browseTreeToSVG :: [Tree Page] -> IO String +browseTreeToSVG btree = do + let ellipsis t n | length t < n = t + | otherwise = take n t ++ "..." + + nodeID <- newTVarIO (0::Int) + btree' <- mapM (T.mapM (\p -> do + i <- atomically $ do + iden <- readTVar nodeID + writeTVar nodeID (iden+1) + return iden + t <- getPageTitle p + return (i,t))) btree + + let prelude = unlines ["digraph \"Browse tree\" {", + "graph [", + "fontname = \"Helvetica-Oblique\",", + "page = 10", + "size = 30", + " ];"] + -- labels = unlines [ printf "d%d [label=\"%s\"];" i t | (i,t) <- concatMap flatten btree' ] + footer = "}" + + btreeZip = concatMap flattenToZipper' btree' -- ellipsis t 15 + labels = unlines [ printf "d%d [URL=\"http://google.com\", shape=polygon, fixedsize=true, fontsize=8, width=1.25, height=0.25, tooltip=\"%s\", label=\"%s\"];" + i t (ellipsis t 10) | (i,t) <- map label btreeZip ] + edges = unlines [ printf "d%d -> d%d;" (fst . label . fromJust . parent $ z ) (fst . label $ z) + | z <- btreeZip, + parent z /= Nothing] + + edges2 = [ ((fst . label . fromJust . parent $ z ),(fst . label $ z)) + | z <- btreeZip, + parent z /= Nothing] + + + everything = prelude ++ edges ++ labels ++ footer + + print everything + print edges2 + tot@(code,svg,dotErr) <- readProcessWithExitCode "dot" ["-Tsvg"] everything + -- _ <- readProcessWithExitCode "dot" ["-Tsvg","-ograph.svg"] everything + -- _ <- readProcessWithExitCode "dot" ["-ograph.dot"] everything + print tot + case code of + ExitSuccess -> return svg + ExitFailure c -> return $ printf "Error running 'dot' command. Exit code: %s\n%s" (show c) dotErr + + +-- visualBrowseTreeWidget :: t -> IO Widget +visualBrowseTreeWidget :: TVar [Tree Page] -> IO Widget +visualBrowseTreeWidget btreeVar = do + -- webkit widget + web <- webViewNew + webViewSetTransparent web True + webViewSetFullContentZoom web True + + -- scrolled window to enclose the webkit + scrollWeb <- scrolledWindowNew Nothing Nothing + containerAdd scrollWeb web + + settings <- webViewGetWebSettings web + set settings [webSettingsEnablePlugins := False] + + let refreshSVG = do + svg <- browseTreeToSVG =<< readTVarIO btreeVar + webViewLoadString web svg (Just "image/svg+xml") Nothing "" + + on web navigationPolicyDecisionRequested $ \ webframe networkReq webNavAct webPolDec -> do + print "[navigationPolicyDecisionRequested]" + muri <- networkRequestGetUri networkReq + case muri of + Nothing -> return () + Just uri -> print ("visualBrowseTreeWidget",uri) + + return True + + -- watch btreeVar for changes, update + let watchdog page = do + page' <- waitTVarChangeFrom page btreeVar + postGUIAsync refreshSVG + watchdog page' + forkIO (watchdog =<< readTVarIO btreeVar) + forkIO (forever $ do + threadDelay (10^6) + postGUIAsync refreshSVG) + + refreshSVG + return (toWidget scrollWeb) + +visualBrowseTreeWindow btreeVar = do + window <- windowNew + visualBT <- visualBrowseTreeWidget btreeVar + set window [ containerBorderWidth := 10, + windowTitle := "Spike browser - visual browse tree", + containerChild := visualBT, + windowAllowGrow := True ] + widgetShowAll window + + return window diff --git a/src/spike.hs b/src/spike.hs new file mode 100644 --- /dev/null +++ b/src/spike.hs @@ -0,0 +1,418 @@ +{-# LANGUAGE PackageImports, FlexibleInstances, DoRec, ForeignFunctionInterface #-} +module Main where + +import Graphics.UI.Gtk.WebKit.WebFrame +import Graphics.UI.Gtk.WebKit.WebView +import Graphics.UI.Gtk.WebKit.Download +import Graphics.UI.Gtk.WebKit.WebSettings +import Graphics.UI.Gtk.WebKit.NetworkRequest +import Graphics.UI.Gtk.WebKit.WebNavigationAction + +import System.IO.Unsafe +import System.Process +import System.Directory +import System.FilePath +import System.Exit + +import Graphics.UI.Gtk +import Text.Printf +import Control.Monad +import Control.Concurrent.STM +import Control.Concurrent +import Control.Applicative +import Data.IORef + +import qualified Data.Foldable as F +import qualified Data.Traversable as T +import Data.Tree.Zipper +import Data.Maybe +import qualified Data.List + +import Utils +import NotebookSimple +import Datatypes +import VisualBrowseTree +import CFunctions + +import Data.Tree as Tree + +debugBTree :: [Tree Page] -> IO () +debugBTree btree = do + btree' <- mapM (T.mapM (\p -> fmap show $ getPageTitle p)) btree + putStrLn (drawForest btree') + + +-- operations on single page +-- | install listeners for various signals +hookupWebView :: WebViewClass object => object -> IO WebView -> IO () +hookupWebView web createSubPage = do + on web downloadRequested $ \ down -> do + uri <- downloadGetUri down + print ("Download uri",uri) + return True + + let foo str webFr netReq webNavAct _webPolDec = do + t0 <- return str + t1 <- webFrameGetName webFr + t2 <- webFrameGetUri webFr + t3 <- networkRequestGetUri netReq + t4 <- webNavigationActionGetReason webNavAct + print (t0,t1,t2,t3,MyShow t4) + return False + + on web newWindowPolicyDecisionRequested $ foo "newWindowPolicyDecisionRequested" +-- on web navigationPolicyDecisionRequested ... + + on web createWebView $ \ frame -> do + print "createWebView" + newWebView <- createSubPage + newUri <- webFrameGetUri frame + case newUri of + Just uri -> webViewLoadUri newWebView uri + Nothing -> return () + return newWebView + + -- on web downloadRequested $ \ _ -> print "downloadRequested" >> return False + + -- JavaScript stuff: TODO + -- scriptAlert + -- scriptConfirm + -- scriptPrompt + -- printRequested + -- statusBarTextChanged + on web consoleMessage $ \ s1 s2 i s3 -> print ("[JavaScript/Console message]: ",s1,s2,i,s3) >> return False + -- closeWebView + -- titleChanged + + hoveredLink <- newTVarIO Nothing + + on web hoveringOverLink $ \ title uri -> do + -- print ("[hoveringOverLink]: ",title,uri) + atomically $ writeTVar hoveredLink uri + + -- navigation + on web navigationPolicyDecisionRequested $ \ webframe networkReq webNavAct webPolDec -> do + print "[navigationPolicyDecisionRequested]" + navReason <- webNavigationActionGetReason webNavAct + case navReason of + WebNavigationReasonLinkClicked -> do + print (MyShow navReason) + muri <- networkRequestGetUri networkReq + kmod <- webNavigationActionGetModifierState webNavAct + mbut <- webNavigationActionGetButton webNavAct + print (muri,kmod,mbut) + -- midle click and ctrl+click will spawn child + -- shift+click spawn toplevel window + case (mbut,kmod,muri) of + -- middle click + (2,_,Just uri) -> do + print ("loading uri in sub [1]",uri) + wv <- createSubPage + webViewLoadRequest wv networkReq + return True + -- ctrl+click + (_,4,Just uri) -> do + print ("loading uri in sub [2]",uri) + wv <- createSubPage + webViewLoadRequest wv networkReq + return True + -- shift+click + (_,1,Just uri) -> do + print ("loading uri in sub [3]",uri) + wv <- createSubPage + webViewLoadRequest wv networkReq + return True + -- otherwise + _ -> return False + +-- print =<< webNavigationActionGetTargetFrame webNavAct +-- return False + _ -> do + print (MyShow navReason) + return False + + -- new window via JavaScript + on web newWindowPolicyDecisionRequested $ \ webframe networkReq webNavAct webPolDec -> do + return False + +-- on web Graphics.UI.Gtk.WebKit.WebView.populatePopup $ \ menu -> do +-- print ("[populate popup]") +-- hovered <- readTVarIO hoveredLink +-- case hovered of +-- Nothing -> return () +-- Just uri -> do +-- menuShellAppend menu =<< menuItemNewWithLabel ("1: " ++ uri) +-- menuShellAppend menu =<< menuItemNewWithLabel ("2: " ++ uri) +-- widgetShowAll menu + + -- statusBarTextChanged + + return () + +addressBarNew :: WebViewClass self => self -> IO Entry +addressBarNew web = do + ec <- entryNew + entrySetActivatesDefault ec True + on ec entryActivate $ do + text <- entryGetText ec + webViewLoadUri web text + on web loadCommitted $ \ frame -> do + uri <- webFrameGetUri frame + uri2 <- webViewGetUri web + when (uri /= uri2) (print $ "INFO: addressBar: uri/uri2 mismatch: " ++ show (uri,uri2)) + case catMaybes [uri,uri2] of + (x:_) -> entrySetText ec x + _ -> print ("INFO: addressBar: no text to set") + return () + return ec + +newWeb :: BrowseTreeState -> IO () -> String -> IO (Widget, WebView) +newWeb btreeSt refreshLayout url = do + -- webkit widget + web <- webViewNew + webViewSetTransparent web False + let loadHome = webViewLoadUri web url + loadHome + -- webViewSetMaintainsBackForwardList web False -- TODO: or maybe True? + on web titleChanged $ \ _ _ -> refreshLayout + + -- plugins are causing trouble. disable them. + settings <- webViewGetWebSettings web + set settings [webSettingsEnablePlugins := False] + + -- scrolled window to enclose the webkit + scrollWeb <- scrolledWindowNew Nothing Nothing + containerAdd scrollWeb web + + -- menu + addressBar <- addressBarNew web + menu <- hBoxNew False 1 + quit <- buttonNewWithLabel "Quit" + reload <- buttonNewWithLabel "Reload" + on reload buttonActivated $ webViewReload web + goHome <- buttonNewWithLabel "Home" + on goHome buttonActivated $ loadHome + boxPackEnd menu quit PackNatural 1 + boxPackStart menu reload PackNatural 1 + boxPackStart menu goHome PackNatural 1 + boxPackStart menu addressBar PackGrow 1 + + -- fill the page + page <- vPanedNew + containerAdd page menu + containerAdd page scrollWeb + + widgetShowAll page + + let widget = toWidget page + ww = (widget,web) + newChildPage = do + print "[newChildPage called]" + btree <- readTVarIO btreeSt + debugBTree btree + case findPageWidget btree widget of + Just p -> do + ww' <- newWeb btreeSt refreshLayout "about:blank" + p' <- newPage ww' "about:blank" -- TODO: win the battle over the power to navigate the web view. + let btree' = addChild btree p p' + atomically $ writeTVar btreeSt btree' + refreshLayout + return (pgWeb p') + Nothing -> do + error "findPageWidget returned Nothing, can't provide a new window" + + hookupWebView web newChildPage + + return ww + +-- move to new page, discard any hiNext out there +navigateToPage :: Page -> String -> IO () +navigateToPage page url = do + atomically $ do + hist <- readTVar (pgHistory page) + let h' = Hist url (hiNow hist : hiPrev hist) [] + writeTVar (pgHistory page) h' + + webViewLoadUri (pgWeb page) url + +-- operations on tree +newTopPage :: BrowseTreeState -> IO () -> String -> IO Page +newTopPage btvar refreshLayout url = do + ww <- newWeb btvar refreshLayout url + tp <- newLeafURL ww url + atomically $ do + bt <- readTVar btvar + writeTVar btvar (bt ++ [tp]) + return (rootLabel tp) + +newLeafURL :: (Widget, WebView) -> String -> IO (Tree Page) +newLeafURL ww url = do + page <- (newPage ww url) + return (newLeaf page) + +newPage :: (Widget, WebView) -> String -> IO Page +newPage (widget,webv) url = do + hist <- newTVarIO (Hist url [] []) + return (Page { pgWidget=widget, pgWeb=webv, pgHistory=hist}) + +newLeaf :: Page -> Tree Page +newLeaf page = Node page [] + +addChild :: BrowseTree -> Page -> Page -> BrowseTree +addChild btree parent child = let + aux (Node page sub) | isSamePage page parent = Node page (sub ++ [newLeaf child]) + | otherwise = Node page (map aux sub) + in map aux btree + +-- query functions + +findPageWidget :: BrowseTree -> Widget -> Maybe Page +findPageWidget btree w = let fun p = pgWidget p == w + flat = concatMap flatten btree + filt = filter fun flat + in + case filt of + [] -> Nothing + (x:_) -> Just x + +getPageSurrounds :: Eq a => [Tree a] -> a -> ([a], [a], [a]) +getPageSurrounds btree p | not (any (F.elem p) btree) = ([],[p],[]) + | otherwise = + let parent = getPageParent btree p + parents = case parent of + Nothing -> [] + Just x -> map rootLabel (getPageSiblings btree (rootLabel x)) + siblings = map rootLabel (getPageSiblings btree p) + children = map rootLabel (getPageChildren btree p) + in (parents,siblings,children) + +-- returns node's siblings +getPageSiblings :: Eq b => [Tree b] -> b -> [Tree b] +getPageSiblings btree p = case getPageParent btree p of + Nothing -> btree + Just x -> subForest x + +getPageChildren :: Eq b => [Tree b] -> b -> Forest b +getPageChildren btree p = case filter ((==p) . rootLabel) (concatMap subtrees btree) of + [] -> error "Element (page) not found in Forest" + (Node _ sub:_) -> sub + +getPageParent :: Eq b => [Tree b] -> b -> Maybe (Tree b) +getPageParent btree p = case (filter (any ((==p) . rootLabel) . subForest) (subtrees' btree)) of + [] -> Nothing + (x:_xs) -> Just x + +subtrees :: Tree t -> [Tree t] +subtrees t@(Node _ sub) = t : subtrees' sub + +subtrees' :: [Tree t] -> [Tree t] +subtrees' = concatMap subtrees + +-- notebook synchronization + +viewPagesSimpleNotebook :: [Page] -> NotebookSimple -> IO () +viewPagesSimpleNotebook pages nb = do + atomically $ writeTVar (ns_pages nb) pages + ns_refresh nb + +noEntriesInBox :: ContainerClass self => self -> IO () +noEntriesInBox box = do + containerForeach box (containerRemove box) + label <- labelNew Nothing + labelSetMarkup label "(no elements here)" + containerAdd box label + widgetShowAll box + +-------------- + +setupGlobals = do + appDir <- getAppUserDataDirectory "Spike" + createDirectoryIfMissing False appDir + + spikeSetupWebkitGlobals (appDir "spike.webkit.db") (appDir "spike.webkit.cookie.db") + +main :: IO () +main = do + initGUI + + setupGlobals + + -- glue together gui. yuck. + parentsBox <- hBoxNew False 1 :: IO HBox + + viewPageRef <- newIORef undefined + siblingsNotebookSimple <- notebookSimpleNew (\p -> do { fun <- readIORef viewPageRef; fun p}) :: IO NotebookSimple + childrenBox <- hBoxNew False 1 :: IO HBox + + widgetSetSizeRequest parentsBox (-1) 40 + widgetSetSizeRequest childrenBox (-1) 40 + + inside <- vBoxNew False 1 + (\sw -> boxPackStart inside sw PackNatural 1) =<< newScrolledWindowWithViewPort parentsBox + boxPackStart inside (ns_widget siblingsNotebookSimple) PackGrow 1 + (\sw -> boxPackStart inside sw PackNatural 1) =<< newScrolledWindowWithViewPort childrenBox + + + -- global state + + currentPage <- newTVarIO (error "current page is undefined for now...") + btreeVar <- newTVarIO [] + + -- define refresh layout and others + + let viewPage :: Page -> IO () + viewPage page = do + print "CALL: viewPage" + atomically $ writeTVar currentPage page + refreshLayout + + refreshLayout = do + print "CALL: refreshLayout" + + btree <- readTVarIO btreeVar + page <- readTVarIO currentPage + let (parents,siblings,children) = getPageSurrounds btree page + + viewPagesSimpleNotebook siblings siblingsNotebookSimple + notebookSimpleSelectPage siblingsNotebookSimple page + + case parents of + [] -> noEntriesInBox parentsBox + parents' -> listPagesBox viewPage parents' parentsBox -- update parents + case children of + [] -> noEntriesInBox childrenBox + children' -> listPagesBox viewPage children' childrenBox -- update children + + + spawnHomepage = do + let homepage = "https://google.com" + page <- newTopPage btreeVar refreshLayout homepage + atomically $ writeTVar currentPage page + notebookSimpleSelectPage siblingsNotebookSimple page + viewPage page + return () + + writeIORef viewPageRef viewPage + + -- create root page + + spawnHomepage + newTopPage btreeVar refreshLayout "http://news.google.com" + + -- show main window + window <- windowNew + onDestroy window mainQuit + set window [ containerBorderWidth := 10, + windowTitle := "Spike browser", + containerChild := inside, + windowAllowGrow := True ] + widgetShowAll window + + -- tree view window + visualBrowseTreeWindow btreeVar + + -- refresh layout once and run GTK loop + refreshLayout + mainGUI + + return ()