bdo (empty) → 0.1.0.0
raw patch · 5 files changed
+277/−0 lines, 5 filesdep +aesondep +basedep +networksetup-changed
Dependencies added: aeson, base, network, text, url
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- bdo.cabal +18/−0
- bdo.js +81/−0
- src/Main.hs +146/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2013, Chris Done++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 Chris Done 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bdo.cabal view
@@ -0,0 +1,18 @@+name: bdo+version: 0.1.0.0+synopsis: Update CSS in the browser without reloading the page.+description: Update CSS in the browser without reloading the page.+license: BSD3+license-file: LICENSE+author: Chris Done+maintainer: chrisdone@gmail.com+category: Web+build-type: Simple+cabal-version: >=1.8+data-files: bdo.js++executable bdo+ main-is: Main.hs+ build-depends: base >= 4 && < 5,+ url, text, network, aeson+ hs-source-dirs: src
+ bdo.js view
@@ -0,0 +1,81 @@+/// bdo.el+/// Do things to a browser page from Emacs.++// Copyright (c) 2012 Chris Done. All rights reserved.++// 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+// Chris Done 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.++var bdo = {};++/*******************************************************************************+ * Initialize everything.+ */+bdo.init = function(){+ $(document).ready(function(){+ bdo.sendLinks();+ bdo.poll();+ });+};++/*******************************************************************************+ * Send the hrefs of all the CSS link elements in the page.+ */+bdo.sendLinks = function(){+ var hrefs = [];+ $('link[type="text/css"]').each(function(){+ if($(this).attr('rel') == 'stylesheet') {+ hrefs.push($(this).attr('href'));+ }+ });+ $.post(bdo.host + 'links',{links:hrefs.join('\n')},function(response){+ bdo.log("Posted links: " + JSON.stringify(hrefs));+ bdo.log("Links reply: %s",response);+ });+};++/*******************************************************************************+ * Poll for link element updates, given by the href, from Emacs.+ */+bdo.poll = function(){+ bdo.log("Polling...");+ $.get(bdo.host + 'poll' + '?reload=' + Math.random(),function(href){+ bdo.refresh(href);+ bdo.poll();+ });+};++/*******************************************************************************+ * Refresh the link with the given `href' attribute.+ */+bdo.refresh = function(href){+ bdo.log("Refreshing '%s'...",href);+ $('link').each(function(){+ if($(this).attr('href').indexOf(href) == 0) {+ // I don't know of any other way to “refresh” an element while+ // preserving ordering such that CSS demands.+ $(this).attr('href',href + "?reload=" + Math.random());+ }+ });+};++/*******************************************************************************+ * Log something if there is a console available.+ */+bdo.log = function(){+ return window.console && window.console.log.apply(window.console,arguments);+}++/*******************************************************************************+ * Below the bdo.host value is filled in and bdo.init is called.+ */
+ src/Main.hs view
@@ -0,0 +1,146 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Main bdo server. Accepts polling requests and such. Possibly the+-- worst code I've ever written. I want a prize.++module Main where++import Control.Concurrent+import Control.Exception+import Control.Monad+import Data.Aeson+import Data.List+import Data.Maybe+import Data.Monoid+import Data.Text.Lazy (Text)+import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as T+import Http+import Network+import Network.URL+import Paths_bdo+import Prelude hiding (catch)+import System.Environment+import System.IO++-- | Main entry point.+main :: IO ()+main = do+ (listenPort:_) <- getArgs+ hSetBuffering stdout NoBuffering+ clients <- newMVar []+ listener <- listenOn (PortNumber (fromIntegral (read listenPort :: Int)))+ currentClient <- newMVar Nothing+ let printCurrentClient h = do+ cur <- readMVar currentClient+ case cur of+ Nothing -> T.hPutStrLn h "No current client"+ Just (client,link) -> T.hPutStrLn h $ "Current client is: " <> client <> ", updating link: " <> link+ update h client link = do+ clients <- readMVar clients+ case lookup client clients of+ Nothing -> T.hPutStrLn h "Unknown client. To see list of clients: clients"+ Just (links,Just h')+ | link `elem` links -> do T.hPutStrLn h "Sending link update ..."+ reply h' [] link+ hClose h'+ | otherwise -> T.hPutStrLn h "That link doesn't exist in the page. To see the page's links: clients"+ _ -> T.hPutStrLn h "That client isn't connected right now."+ updateCurrentClient h = do client <- readMVar currentClient+ case client of+ Nothing -> hPutStrLn h "No current client!"+ Just (client,link) -> update h client link+ printClients h = do clients <- readMVar clients+ mapM_ (\(referer,(links,_)) -> do+ T.hPutStrLn h (referer <> ":\n" <>+ T.intercalate "\n" (map (" "<>) links) <>+ "\n"))+ clients+ printCurrentClient h+ setClient h client link = do+ clients <- readMVar clients+ case lookup client clients of+ Nothing -> T.hPutStrLn h "No such client"+ Just{} -> do modifyMVar_ currentClient (const (return (Just (client,link))))+ printCurrentClient h+ void $ forkIO $ flip finally (sClose listener) $ forever $ do+ (h,_,_) <- accept listener+ let closing m = finally m (hClose h)+ forkIO $ do+ hSetBuffering h NoBuffering+ headers <- getHeaders h+ case headers of+ ["update"] -> closing (updateCurrentClient h)+ [T.words -> ["update",client,link]] -> update h client link+ ["clients"] -> closing $ printClients h+ [T.words -> ["set",client,link]] -> closing $ setClient h client link+ [T.words -> [(importURL . T.unpack) -> Just client,(importURL . T.unpack) -> Just link]] -> closing $ do+ T.putStrLn "Updating from socket request."+ update h (T.pack (exportURL client))+ (T.pack (exportURL link))+ _ -> do+ case requestMethod headers of+ Just (method,url) -> dispatch h clients method url headers+ _ -> closing $ T.putStrLn $ "Request ignored: " <> T.pack (show headers)++ forever $ do+ line <- T.getLine+ case T.words line of+ ["clients"] -> printClients stdout+ ["update",client,link] -> update stdout client link+ ["update"] -> updateCurrentClient stdout+ ["set",client,link] -> setClient stdout client link+ _ -> T.putStrLn $ "Unknown command. Commands: clients, update <client> <stylesheet>, set <client> <stylesheet> (sets the current client/stylesheet), update (no args, uses current client)"++dispatch :: Handle -> MVar [(Text,([Text],Maybe Handle))] -> Text -> URL -> [Text] -> IO ()+dispatch h cs method url headers = do+ logLn $ T.pack (show h) <> ": Client connected."+ go [("bdo",bdo)+ ,("links",links)+ ,("poll",poll)]++ where bdo = do+ getJs (fromMaybe "localhost" (lookupHeader "host" headers)) >>= replyJs h+ hClose h++ poll = modifyClient (\(links,_) -> (links,Just h))++ links = do+ rest <- T.hGetContents h+ case requestBody headers rest of+ Nothing -> return ()+ Just body -> case parsePost body of+ Nothing -> return ()+ Just params -> case lookup "links" params of+ Nothing -> return ()+ Just links -> do modifyClient (\(_links,handle) -> (T.lines links,handle))+ logLn $ T.pack (show h) <> ": Links updated."+ reply h [] "Links updated."+ hClose h++ go handlers =+ case find ((`isPrefixOf` (url_path url)).fst) handlers of+ Just (_,handle) -> handle+ Nothing -> do+ logLn $ T.pack (show h) <> ": Unhandled request: " <> T.pack (show url)+ hClose h+ referer = fromMaybe "any" $ lookupHeader "referer" headers+ modifyClient f = modifyMVar_ cs (return . modify) where+ modify xs = case lookup referer xs of+ Nothing -> (referer,f (mempty,Nothing)) : xs+ Just x -> (referer,f x) : filter ((/=referer).fst) xs++logLn :: Text -> IO ()+logLn = T.hPutStrLn stderr++getJs :: Text -> IO Text+getJs host = do+ js <- getDataFileName "bdo.js" >>= T.readFile+ return $+ T.unlines [js+ ,"bdo.host = " <> T.pack (show ("http://" <> host <> "/" :: Text)) <> ";"+ ,"bdo.init();"+ ]++replyJs h = reply h [("Content-Type","text/javascript; charset=utf-8")]