diff --git a/App/Behaviours/HTTP.hs b/App/Behaviours/HTTP.hs deleted file mode 100644 --- a/App/Behaviours/HTTP.hs +++ /dev/null @@ -1,60 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- --- Module : App.Behaviours.HTTP --- Copyright : 2009 Renaissance Computing Institute --- License : BSD3 --- --- Maintainer : Jeff Heard --- Stability : Experimental --- Portability : --- --- | Behaviours for HTTP requests. Looks for Events named --- HTTP\//MethodName/ with event data of [EString uri, EByteString senddata, EStringL headers] and consumes them. Produces --- Events named HTTPResponse with source httpBehaviour\//MethodName/ and the contents of the response as the event data in a ByteString. --- They also produce Exceptions with the same source and name ConnectionError if there is no network connection or HTTP Service --- or HTTPErrorResponseCode if the Server sent back an error code or ParseFailure if the URI didn't parse. --- ------------------------------------------------------------------------------ - -module App.Behaviours.HTTP ( - - -) where - -import Control.Applicative ((<$>)) -import App.EventBus -import Network.HTTP.HandleStream -import Network.HTTP -import Network.URI -import Network.Stream -import qualified Data.ByteString as BS - -maybeHead (x:xs) = Just x -maybeHead [] = Nothing - -httpBehaviour :: RequestMethod -> Behaviour [EData a] -httpBehaviour method b = consumeNamedEventsWith b ("HTTP/" ++ show method) $ \evt -> - let EString uriS = head . eventdata $ evt - postdata = maybe BS.empty (\(EByteString getdata) -> getdata) . maybeHead . tail . eventdata $ evt - postheaders = headers . tail . tail . eventdata $ evt - - headers (EString nm:EString val:hs) = Header (HdrCustom nm) val : headers hs - headers [] = [] - - httpGet uri = (Network.HTTP.HandleStream.simpleHTTP $ Request uri method postheaders postdata) >>= - either (\_ -> produce "Exception" ("httpBehaviour" ++ show method) "ConnectionError" once []) - (\(Response code reason rspheaders contents) -> - case code of - (1,_,_) -> produce "HTTPResponse" ("httpBehaviour/" ++ show method) (show uri) Persistent [EByteString contents] - (2,_,_) -> produce "HTTPResponse" ("httpBehaviour/" ++ show method) (show uri) Persistent [EByteString contents] - _ -> produce "Exception" ("httpBehaviour/" ++ show method) "HTTPErrorResponseCode" once [EString (show code), EStringL . map show $ rspheaders, EByteString contents]) - in case parseURI uriS of - Just uri -> listM $ httpGet uri - Nothing -> listM $ produce "Exception" ("httpBehaviour" ++ show method) "ParseFailure" once [EString uriS] - - - - - - diff --git a/App/EventBus.hs b/App/EventBus.hs --- a/App/EventBus.hs +++ b/App/EventBus.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE TypeSynonymInstances, ScopedTypeVariables #-} -- | Not exactly the FRP model, but rather a model of a large application with -- heterogenous data and many inputs and outputs. An application is in its -- essence a collection of widgets and behaviours and events with a bus. @@ -86,6 +86,8 @@ | EIntL [Int] | EBoolL [Bool] | EOther a + | EAssoc (String,EData a) + | EAssocL [(String,EData a)] | EOtherL [a] deriving (Eq, Show, Read) @@ -103,6 +105,8 @@ safeShow n (EIntL x) = maybe (show x) ((flip take) (show x)) n safeShow n (EBool x) = maybe (show x) ((flip take) (show x)) n safeShow n (EBoolL x) = maybe (show x) ((flip take) (show x)) n +safeShow n (EAssoc (x,y)) = x ++ " -> " ++ safeShow n y +safeShow n (EAssocL xs) = concat $ (\(a,b) -> a ++ " -> " ++ safeShow n b) <$> xs safeShow n (EOther _) = "Other data" safeShow n (EOtherL _) = "Other data list" @@ -134,6 +138,32 @@ , groupMap :: Map.Map String (Set.Set (Event a)) -- ^ The map of just Event.group to events. , fullyQualifiedMap :: Map.Map (String,String,String) (Event a) } -- ^ The map of FQNs to events. +eventsByName :: String -> Bus a -> Set.Set (Event a) +eventsByName n = fromMaybe Set.empty . Map.lookup n . nameMap + +eventsBySource :: String -> Bus a -> Set.Set (Event a) +eventsBySource s = fromMaybe Set.empty . Map.lookup s . srcMap + +eventsByGroup :: String -> Bus a -> Set.Set (Event a) +eventsByGroup g = fromMaybe Set.empty . Map.lookup g . groupMap + +eventByQName:: String -> String -> String -> Bus a -> Maybe (Event a) +eventByQName g s n = Map.lookup (g,s,n) . fullyQualifiedMap + +eventsFor (Just g) Nothing Nothing b = eventsByGroup g b +eventsFor Nothing (Just s) Nothing b = eventsBySource s b +eventsFor Nothing Nothing (Just n) b = eventsByName n b +eventsFor (Just g) (Just s) (Just n) b = maybe Set.empty (Set.singleton) (eventByQName g s n b) +eventsFor g s n b = persection gset . persection sset $ nset + where gset = fromMaybe Set.empty $ (flip eventsByGroup) b <$> g + sset = fromMaybe Set.empty $ (flip eventsBySource) b <$> s + nset = fromMaybe Set.empty $ (flip eventsByName) b <$> n + persection a b | a == Set.empty = b + | b == Set.empty = a + | otherwise = Set.intersection a b + +topEvent = head . Set.toList + instance Monoid (Bus a) where mempty = emptyBus mappend (Bus n0 s0 g0 f0) (Bus n1 s1 g1 f1) = Bus (Map.union n0 n1) (Map.union s0 s1) (Map.union g0 g1) (Map.union f0 f1) @@ -241,6 +271,36 @@ maybe (future . return $ []) (\ev -> future $ (map Deletion (Set.toList ev) ++) <$> f ev) (Map.lookup nm (nameMap em)) + +consumeNamedEvents :: String -> Behaviour a +consumeNamedEvents nm b = + maybe (future . return $ []) + (\ev -> future . return $ Deletion <$> Set.toList ev) + (Map.lookup nm . nameMap $ b) + +consumeEventGroup :: String -> Behaviour a +consumeEventGroup g b = + maybe (future . return $ []) + (\ev -> future . return $ Deletion <$> Set.toList ev) + (Map.lookup g . groupMap $ b) + +consumeEventsFromSource :: String -> Behaviour a +consumeEventsFromSource s b = + maybe (future . return $ []) + (\ev -> future . return $ Deletion <$> Set.toList ev) + (Map.lookup s . srcMap $ b) + +consumeFullyQualifiedEvent :: String -> String -> String -> Behaviour a +consumeFullyQualifiedEvent g s n b = + maybe (future . return $ []) + (\ev -> future . return $ [Deletion ev]) + (Map.lookup (g, s, n) . fullyQualifiedMap $ b) + +modifyEventData :: Event a -> (a -> a) -> [Diff a] +modifyEventData ev f = [Insertion ev{ eventdata = f . eventdata $ ev }] + +modifyEvent :: Event a -> (Event a -> Event a) -> [Diff a] +modifyEvent ev f = let ev' = f ev in if ev==ev' then [Insertion ev'] else [Deletion ev, Insertion ev'] consumeNamedEventsWith :: Bus a -> String -> (Event a -> IO [Diff a]) -> Future [Diff a] consumeNamedEventsWith b n f = diff --git a/App/Widgets/GtkMouseKeyboard.hs b/App/Widgets/GtkMouseKeyboard.hs deleted file mode 100644 --- a/App/Widgets/GtkMouseKeyboard.hs +++ /dev/null @@ -1,66 +0,0 @@ --- | Gtk mouse keyboard widget. --- --- For a mouse button press or release, add events named SingleClick or ClickRelease respectively to the bus. --- For this widget, all events have source \"KeyboardMouseWidget\", and group \"Mouse\" --- Additionally, the data attached to the event follows the form [EString SingleClick|ClickRelease, EDouble x, EDouble y, EStringL [Gtk modifier names]] --- --- For a keyboard press or release, add events named KeyDown or KeyUp respectively to the bus. --- All keyboard events have group ''Keyboard'' and source ''WidgetName.KeyboardMouseWidget'' --- Additionally, the data attached to a keyboard event follows the form [EString keyName | EChar keyChar, EStringL [Gtk modifier names]] --- --- For a tablet proximity, add events named \"Proximity\" with source WidgetName.KeyboardMouseWidget, group \"Mouse\" and with attached data --- [EBool True] for the tablet is in proximity and [EBool False] for the tablet is out of proximity. --- --- For mouse motion, add events named \"Position\" with group \"Mouse\" and attached data [EDouble x, EDouble y, EStringL modifiers] --- -module App.Widgets.GtkMouseKeyboard where - -import Control.Applicative -import Control.Concurrent -import Data.Maybe -import qualified Graphics.UI.Gtk as Gtk -import qualified Graphics.UI.Gtk.Gdk.Events as Gtk -import App.EventBus - --- Gtk's button click event system is annoying, so we're ignoring it and only bothering with the single clicks. --- when we receive a click, fire off a thread (once) that waits for 100ms to see how many clicks we get total in that time. Then fire off that number. -buttonHandler _ _ (Gtk.Button _ Gtk.DoubleClick _ _ _ _ _ _ _) = return True -buttonHandler _ _ (Gtk.Button _ Gtk.TripleClick _ _ _ _ _ _ _) = return True -buttonHandler wname b (Gtk.Button sent click time x y modifiers button _ _) = do - produce' "Mouse" (wname ++ ".KeyboardMouseWidget") (show click) once [EString . show $ button, EDouble x, EDouble y, EStringL . map show $ modifiers] b - return True - -scrollWheelHandler wname b (Gtk.Scroll _ _ x y direction _ _) = do - produce' "Mouse" (wname ++ ".KeyboardMouseWidget") (show direction) once [EDouble x, EDouble y] b - return True - -keyboardHandler wname b (Gtk.Key released sent time modifiers withCapsLock withNumLock withScrollLock keyVal keyName keyChar) = do - produce' "Keyboard" (wname ++ "KeyboardMouseWidget") (if released then "KeyUp" else "KeyDown") once - [ fromMaybe (EString . show $ keyName) (EChar <$> keyChar) - , EStringL . map show $ modifiers ] b - return False - -motionHandler wname w b evt = do - produce' "Mouse" (wname ++ ".KeyboardMouseWidget") "Position" once [EDouble . Gtk.eventX $ evt, EDouble . Gtk.eventY $ evt, EStringL . map show . Gtk.eventModifier $ evt] b - dwin <- Gtk.widgetGetDrawWindow w - Gtk.drawWindowGetPointer dwin - return False - -proximityHandler wname b evt = do - produce' "Mouse" (wname ++ ".KeyboardMouseWidget") "Proximity" once [EBool . Gtk.eventInContact $ evt] b - return False - --- | Bind a keyboard mouse widget to the given Gtk widget. Se module documentation for description of events. -bindMouseKeyboardWidget :: Gtk.Widget -> Widget [EData a] -bindMouseKeyboardWidget w b = do - ref <- newEmptyMVar - wname <- Gtk.widgetGetName w - Gtk.onButtonPress w (buttonHandler wname b) - Gtk.onButtonRelease w (buttonHandler wname b) - Gtk.onScroll w (scrollWheelHandler wname b) - Gtk.onKeyPress w (keyboardHandler wname b) - Gtk.onKeyRelease w (keyboardHandler wname b) - Gtk.onMotionNotify w True (motionHandler wname w b) - Gtk.onProximityIn w (proximityHandler wname b) - Gtk.onProximityOut w (proximityHandler wname b) - return () diff --git a/buster.cabal b/buster.cabal --- a/buster.cabal +++ b/buster.cabal @@ -1,14 +1,12 @@ name: buster -version: 0.99.7 +version: 1.0 cabal-version: -any build-type: Simple license: BSD3 license-file: "" copyright: 2009 Renaissance Computing Institute maintainer: Jeff Heard -build-depends: network -any, HTTP >=4000.0, binary -any, - parsec >=3.0.0, pretty -any, mtl -any, gtk -any, bytestring -any, - base -any, containers -any, time -any, old-locale -any +build-depends: binary -any, parsec >=3.0.0, pretty -any, mtl -any, bytestring -any, base -any, containers -any, time -any, old-locale -any, dataenc -any stability: Experimental homepage: http://vis.renci.org/jeff/buster package-url: @@ -32,9 +30,10 @@ data-dir: "" extra-source-files: extra-tmp-files: -exposed-modules: App.EventBus App.Behaviours.PrintEvents - App.Behaviours.Exception App.Behaviours.FileOps App.Behaviours.HTTP - App.Widgets.GtkMouseKeyboard App.Widgets.Environment +exposed-modules: App.EventBus + App.Behaviours.PrintEvents App.Behaviours.Exception + App.Behaviours.FileOps + App.Widgets.Environment exposed: True buildable: True build-tools: