diff --git a/App/Behaviours/HTTP.hs b/App/Behaviours/HTTP.hs new file mode 100644 --- /dev/null +++ b/App/Behaviours/HTTP.hs @@ -0,0 +1,60 @@ +{-# 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) (takeWhile (/='?') . show $ uri) Persistent [ EByteString contents] + (2,_,_) -> produce "HTTPResponse" ("httpBehaviour/" ++ show method) (takeWhile (/='?') . 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/Behaviours/XmlRpc.hs b/App/Behaviours/XmlRpc.hs new file mode 100644 --- /dev/null +++ b/App/Behaviours/XmlRpc.hs @@ -0,0 +1,100 @@ +module App.Behaviours.XmlRpc where + +import Control.Monad.Error +import Network.XmlRpc.Client +import Network.XmlRpc.Internals +import Control.Applicative +import App.EventBus +import qualified Codec.Binary.Base64 +import qualified Data.ByteString as SB +import qualified Data.ByteString.Lazy as LB +import Data.Maybe + +edata2value :: XmlRpcType a => EData a -> Value +edata2value (EString x) = ValueString x +edata2value (EStringL x) = ValueArray $ ValueString <$> x +edata2value (EByteString x) = ValueBase64 . Codec.Binary.Base64.encode . SB.unpack $ x +edata2value (EByteStringL x) = ValueArray $ ValueBase64 . Codec.Binary.Base64.encode . SB.unpack <$> x +edata2value (ELByteString x) = ValueBase64 . Codec.Binary.Base64.encode . LB.unpack $ x +edata2value (ELByteStringL x) = ValueArray $ ValueBase64 . Codec.Binary.Base64.encode . LB.unpack <$> x +edata2value (EChar x) = ValueString [x] +edata2value (EDouble x) = ValueDouble x +edata2value (EDoubleL x) = ValueArray $ ValueDouble <$> x +edata2value (EInt x) = ValueInt x +edata2value (EIntL x) = ValueArray $ ValueInt <$> x +edata2value (EBool x) = ValueBool x +edata2value (EBoolL x) = ValueArray $ ValueBool <$> x +edata2value (EOther x) = toValue x +edata2value (EOtherL x) = ValueArray $ toValue <$> x +edata2value (EAssoc (k,v)) = ValueStruct [(k, edata2value v)] +edata2value (EAssocL xs) = ValueStruct $ (\(k,v) -> (k, edata2value v)) <$> xs + +edata2valueNX :: EData a -> Value +edata2valueNX (EString x) = ValueString x +edata2valueNX (EStringL x) = ValueArray $ ValueString <$> x +edata2valueNX (EByteString x) = ValueBase64 . Codec.Binary.Base64.encode . SB.unpack $ x +edata2valueNX (EByteStringL x) = ValueArray $ ValueBase64 . Codec.Binary.Base64.encode . SB.unpack <$> x +edata2valueNX (ELByteString x) = ValueBase64 . Codec.Binary.Base64.encode . LB.unpack $ x +edata2valueNX (ELByteStringL x) = ValueArray $ ValueBase64 . Codec.Binary.Base64.encode . LB.unpack <$> x +edata2valueNX (EChar x) = ValueString [x] +edata2valueNX (EDouble x) = ValueDouble x +edata2valueNX (EDoubleL x) = ValueArray $ ValueDouble <$> x +edata2valueNX (EInt x) = ValueInt x +edata2valueNX (EIntL x) = ValueArray $ ValueInt <$> x +edata2valueNX (EBool x) = ValueBool x +edata2valueNX (EBoolL x) = ValueArray $ ValueBool <$> x +edata2valueNX (EAssoc (k,v)) = ValueStruct [(k, edata2valueNX v)] +edata2valueNX (EAssocL xs) = ValueStruct $ (\(k,v) -> (k, edata2valueNX v)) <$> xs + +value2edata :: Value -> EData a +value2edata (ValueInt x) = EInt x +value2edata (ValueBool x) = EBool x +value2edata (ValueString x) = EString x +value2edata (ValueDateTime x) = EString (show x) +value2edata (ValueBase64 x) = EByteString . SB.pack . fromJust . Codec.Binary.Base64.decode $ x +value2edata (ValueStruct xs) = EAssocL $ (\(x,y) -> (x, value2edata y)) <$> xs +value2edata (ValueArray xs) = EAssocL . zip (show<$>[0..]) $ value2edata <$> xs + + + +xmlrpcMethodBehaviour :: XmlRpcType a => String -> String -> Behaviour [EData a] +xmlrpcMethodBehaviour service method b = consumeEventGroupWith b (service ++ "/" ++ method) $ \evt -> do + let parms = map edata2value . eventdata $ evt + exceptionEvent errmsg = produce "Exception" (service ++ "/" ++ method) "XmlRpcException" once [EString errmsg] + responseEvent val = produce "XmlRpcResponse" (service ++ "/" ++ method) (concat . map (safeShow Nothing) $ eventdata evt) once [value2edata val] + r <- runErrorT $ call service method parms + case r of + Left err -> listM $ exceptionEvent err + Right res -> listM $ responseEvent res + +xmlrpcServiceBehaviour :: XmlRpcType a => String -> Behaviour [EData a] +xmlrpcServiceBehaviour service b = consumeEventGroupWith b service $ \evt -> do + let parms = map edata2value . tail . eventdata $ evt + EString method = head . eventdata $ evt + exceptionEvent errmsg = produce "Exception" (service ++ "/" ++ method) "XmlRpcException" once [EString errmsg] + responseEvent val = produce "XmlRpcResponse" (service ++ "/" ++ method) (concat . map (safeShow Nothing) $ eventdata evt) once [value2edata val] + r <- runErrorT $ call service method parms + case r of + Left err -> listM $ exceptionEvent err + Right res -> listM $ responseEvent res + +xmlrpcMethodBehaviourNX :: String -> String -> Behaviour [EData a] +xmlrpcMethodBehaviourNX service method b = consumeEventGroupWith b (service ++ "/" ++ method) $ \evt -> do + let parms = map edata2valueNX . eventdata $ evt + exceptionEvent errmsg = produce "Exception" (service ++ "/" ++ method) "XmlRpcException" once [EString errmsg] + responseEvent val = produce "XmlRpcResponse" (service ++ "/" ++ method) (concat . map (safeShow Nothing) $ eventdata evt) once [value2edata val] + r <- runErrorT $ call service method parms + case r of + Left err -> listM $ exceptionEvent err + Right res -> listM $ responseEvent res + +xmlrpcServiceBehaviourNX :: String -> Behaviour [EData a] +xmlrpcServiceBehaviourNX service b = consumeEventGroupWith b service $ \evt -> do + let parms = map edata2valueNX . tail . eventdata $ evt + EString method = head . eventdata $ evt + exceptionEvent errmsg = produce "Exception" (service ++ "/" ++ method) "XmlRpcException" once [EString errmsg] + responseEvent val = produce "XmlRpcResponse" (service ++ "/" ++ method) (concat . map (safeShow Nothing) $ eventdata evt) once [value2edata val] + r <- runErrorT $ call service method parms + case r of + Left err -> listM $ exceptionEvent err + Right res -> listM $ responseEvent res diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/buster-network.cabal b/buster-network.cabal new file mode 100644 --- /dev/null +++ b/buster-network.cabal @@ -0,0 +1,57 @@ +name: buster-network +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.0, buster >= 1.0, haxr -any, binary -any, 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: +bug-reports: +synopsis: Almost but not quite entirely unlike FRP +description: Buster is best described by the following blog post: http:\/\/vis.renci.org\/jeff\/2009\/03\/31\/almost-but-not-quite-entirely-like-frp\/ + . + It is an engine for orchestrating large, complex, and multifaceted applications by couching them in terms of time, events, a bus, + behaviours, and widgets. Time is continuous and infininte. Events are discrete and exist for a particular time. The bus is a + discrete sample of time made available to behaviours. Behaviours are continuous and exist for all time, but sample time via + the bus. They filter Events to determine what is on the bus at future times. Widgets are input-only objects that sample the + outside world and assign events to discrete portions of time. + . + Buster is designed to be flexible, with a flexible event model and the ability to add custom data to events, and designed to be + high performance. It is simple to integrate with Gtk while at the same time able to handle other kinds of resources, like files + and sockets. +category: FRP +author: Jeff Heard +tested-with: +data-files: +data-dir: "" +extra-source-files: +extra-tmp-files: +exposed-modules: App.Behaviours.HTTP App.Behaviours.XmlRpc + +exposed: True +buildable: True +build-tools: +cpp-options: +cc-options: +ld-options: +pkgconfig-depends: +frameworks: +c-sources: +extensions: +extra-libraries: +extra-lib-dirs: +includes: +install-includes: +include-dirs: +hs-source-dirs: . +other-modules: +ghc-prof-options: +ghc-shared-options: +ghc-options: +hugs-options: +nhc98-options: +jhc-options: