packages feed

buster 0.99.7 → 1.0

raw patch · 4 files changed

+67/−134 lines, 4 filesdep +dataencdep −HTTPdep −gtkdep −network

Dependencies added: dataenc

Dependencies removed: HTTP, gtk, network

Files

− App/Behaviours/HTTP.hs 
@@ -1,60 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}------------------------------------------------------------------------------------ Module      :  App.Behaviours.HTTP--- Copyright   :  2009 Renaissance Computing Institute--- License     :  BSD3------ Maintainer  :  Jeff Heard <jeff@renci.org>--- 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]------
App/EventBus.hs view
@@ -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 =
− App/Widgets/GtkMouseKeyboard.hs 
@@ -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 ()
buster.cabal view
@@ -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 <jeff@renci.org>-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: