packages feed

bdo 0.1.0.0 → 1.0.0

raw patch · 4 files changed

+225/−119 lines, 4 files

Files

bdo.cabal view
@@ -1,5 +1,5 @@ name:                bdo-version:             0.1.0.0+version:             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@@ -11,8 +11,16 @@ cabal-version:       >=1.8 data-files: bdo.js +library+  exposed-modules:  Bdo+  other-modules:    Http+  build-depends:    base >= 4 && < 5,+                    url, text, network, aeson+  hs-source-dirs:   src+ executable bdo   main-is:          Main.hs+  other-modules:    Bdo, Http   build-depends:    base >= 4 && < 5,                     url, text, network, aeson-  hs-source-dirs: src+  hs-source-dirs:   src
+ src/Bdo.hs view
@@ -0,0 +1,144 @@+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Accepts polling requests and such.++module Bdo+  (startServer)+  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++startServer :: Int -> IO ()+startServer listenPort = do+  clients <- newMVar []+  listener <- listenOn (PortNumber (fromIntegral listenPort))+  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")]
+ src/Http.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++-- | HTTP utilities.++module Http where++import           Control.Arrow+import           Control.Exception+import           Control.Monad+import           Data.Char+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           Network.URL+import           Numeric+import           Prelude hiding (catch)+import           System.IO++-- | Parse a POST request's parameters.+parsePost :: Text -> Maybe [(Text,Text)]+parsePost body = fmap (map (T.pack *** T.pack) . url_params)+                      (importURL ("http://x/x?" ++ T.unpack body))++-- | Get the request method.+requestMethod :: [Text] -> Maybe (Text,URL)+requestMethod headers =+   case T.words (T.concat (take 1 headers)) of+     [method,(importURL . T.unpack) -> Just url,_] ->+       return (method,url)+     _ -> Nothing++-- | Get the request body.+requestBody :: [Text] -> Text -> Maybe Text+requestBody headers body = do+  len <- lookup "content-length:" (map (T.break (==' ') . T.map toLower) headers)+  case readDec (T.unpack (T.unwords (T.words len))) of+    [(l,"")] -> return (T.take l body)+    _ -> Nothing++-- | Read up to the headers.+getHeaders :: Handle -> IO [Text]+getHeaders h = go [] where+  go ls = do+    l <- catch (T.hGetLine h)+               (\(e::IOException) -> return "\r")+    if l == "\r"+       then return (reverse ls)+       else go (T.filter (/='\r') l : ls)++-- | Make a HTTP reply.+reply :: Handle -> [(Text,Text)] -> Text -> IO ()+reply h headers body = T.hPutStrLn h resp where+  resp = T.unlines ["HTTP/1.1 200 OK"+                   ,"Content-Length: " <> T.pack (show (T.length body))+                   ,"Access-Control-Allow-Origin: *"+                   ,T.unlines (map (\(key,value) -> key <> ": " <> value) headers)] <>+         body++-- | Lookup the given header from the headers list.+lookupHeader :: Text -> [Text] -> Maybe Text+lookupHeader key headers =+  fmap (T.drop 2 . T.dropWhile (/=':'))+       (lookup key (map (T.break (==':') . T.map toLower) headers))
src/Main.hs view
@@ -1,11 +1,11 @@ {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} --- | Main bdo server. Accepts polling requests and such. Possibly the--- worst code I've ever written. I want a prize.+-- | Main bdo server.  module Main where +import Bdo import           Control.Concurrent import           Control.Exception import           Control.Monad@@ -29,118 +29,4 @@ 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")]+  startServer (read listenPort)