diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,20 @@ +Copyright (c) 2016 Brian W Bush + +Permission is hereby granted, free of charge, to any person obtaining +a copy of this software and associated documentation files (the +"Software"), to deal in the Software without restriction, including +without limitation the rights to use, copy, modify, merge, publish, +distribute, sublicense, and/or sell copies of the Software, and to +permit persons to whom the Software is furnished to do so, subject to +the following conditions: + +The above copyright notice and this permission notice shall be included +in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. diff --git a/ReadMe.md b/ReadMe.md new file mode 100644 --- /dev/null +++ b/ReadMe.md @@ -0,0 +1,24 @@ +UI device events via a Kafka message broker +=========================================== + + +This package contains functions passing UI device events to topics on a [Kafka message broker](https://kafka.apache.org/). + + +Clients +------- + +The simple Kafka client that produces events from the keyboard can be run, for example, as follows: + + cabal run kafka-device-keyboard -- keyboard-client localhost 9092 events keyboard + +The simple Kafka client that consumes events can be run, for example, as follows: + + cabal run kafka-device -- consumer-client localhost 9092 events + +See also + +* https://hackage.haskell.org/package/kafka-device-joystick/: events from Linux joysticks +* https://hackage.haskell.org/package/kafka-device-glut/: events from GLUT-compatible devices +* https://hackage.haskell.org/package/kafka-device-spacenav/: events from SpaceNavigator devices +* https://hackage.haskell.org/package/kafka-device-leap/: events from Leap Motion devices diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/kafka-device.cabal b/kafka-device.cabal new file mode 100644 --- /dev/null +++ b/kafka-device.cabal @@ -0,0 +1,63 @@ +name: kafka-device +version: 0.1.5.0 +synopsis: UI device events via a Kafka message broker +description: This package contains functions for passing UI device events to topics on a Kafka message broker \<\>. Also see \<\>, \<\>, \<\>, \<\>. +license: MIT +license-file: LICENSE +author: Brian W Bush +maintainer: Brian W Bush +copyright: (c) 2016 Brian W Bush +category: Hardware +build-type: Simple +cabal-version: >= 1.10 +stability: Experimental +homepage: https://bitbucket.org/functionally/kafka-device +bug-reports: https://bwbush.atlassian.net/projects/HKAFDEV/issues/ +package-url: https://bitbucket.org/functionally/kafka-device/downloads/kafka-device-0.1.5.0.tar.gz + +extra-source-files: ReadMe.md + +source-repository head + type: git + location: https://bitbucket.org/functionally/kafka-device + +library + exposed-modules: Network.UI.Kafka + Network.UI.Kafka.Keyboard + Network.UI.Kafka.Types + build-depends: base >= 4.8 && < 5 + , aeson + , binary + , bytestring + , cereal + , milena + , mtl + hs-source-dirs: src + ghc-options: -Wall + default-language: Haskell2010 + +executable kafka-device + main-is: Main.hs + build-depends: base + , aeson + , binary + , bytestring + , cereal + , milena + , mtl + hs-source-dirs: src + ghc-options: -Wall -threaded + default-language: Haskell2010 + +executable kafka-device-keyboard + main-is: MainKeyboard.hs + build-depends: base + , aeson + , binary + , bytestring + , cereal + , milena + , mtl + hs-source-dirs: src + ghc-options: -Wall -threaded + default-language: Haskell2010 diff --git a/src/Main.hs b/src/Main.hs new file mode 100644 --- /dev/null +++ b/src/Main.hs @@ -0,0 +1,43 @@ +{-| +Module : Main +Copyright : (c) 2016 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Experimental +Portability : Stable + +Simple consumer that echos UI events from a Kafka topic to the console. +-} + + +module Main ( +-- * Entry point + main +) where + + +import Data.String (IsString(fromString)) +import Network.UI.Kafka (consumerLoop) +import System.Environment (getArgs) + + +-- | The main action. +main :: IO () +main = + do + args <- getArgs + case args of + [client, host, port, topic] -> + do + putStrLn $ "Kafka client: " ++ client + putStrLn $ "Kafka address: (" ++ host ++ "," ++ port ++ ")" + putStrLn $ "Kafka topic: " ++ topic + (_, loop) <- + consumerLoop + (fromString client) + (fromString host, toEnum $ read port) + (fromString topic) + $ curry print + result <- loop + either print return result + _ -> putStrLn "USAGE: kafka-device client host port topic" diff --git a/src/MainKeyboard.hs b/src/MainKeyboard.hs new file mode 100644 --- /dev/null +++ b/src/MainKeyboard.hs @@ -0,0 +1,44 @@ +{-| +Module : Main +Copyright : (c) 2016 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Experimental +Portability : Stable + +Simple producer of keyboard events from standard input to a Kafka topic. +-} + + +module Main ( +-- * Entry point + main +) where + + +import Data.String (IsString(fromString)) +import Network.UI.Kafka.Keyboard (keyboardLoop) +import System.Environment (getArgs) + + +-- | The main action. +main :: IO () +main = + do + args <- getArgs + case args of + [client, host, port, topic, sensor] -> + do + putStrLn $ "Kafka client: " ++ client + putStrLn $ "Kafka address: (" ++ host ++ "," ++ port ++ ")" + putStrLn $ "Kafka topic: " ++ topic + putStrLn $ "Sensor name: " ++ sensor + (_, loop) <- + keyboardLoop + (fromString client) + (fromString host, toEnum $ read port) + (fromString topic) + sensor + result <- loop + either print return result + _ -> putStrLn "USAGE: kafka-device-keyboard client host port topic sensor" diff --git a/src/Network/UI/Kafka.hs b/src/Network/UI/Kafka.hs new file mode 100644 --- /dev/null +++ b/src/Network/UI/Kafka.hs @@ -0,0 +1,127 @@ +{-| +Module : Network.UI.Kafka +Copyright : (c) 2016 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Experimental +Portability : Stable + +Produce and consume events on Kafka topics. +-} + + +module Network.UI.Kafka ( +-- * Types + Sensor +, LoopAction +, ExitAction +-- * Consumption +, ConsumerCallback +, consumerLoop +-- * Production +, ProducerCallback +, producerLoop +) where + + +import Control.Concurrent (MVar, newEmptyMVar, isEmptyMVar, threadDelay, tryPutMVar) +import Control.Monad (void, when) +import Control.Monad.Except (liftIO) +import Data.Binary (decode, encode) +import Data.ByteString.Char8 (pack, unpack) +import Data.ByteString.Lazy (fromStrict, toStrict) +import Network.UI.Kafka.Types (Event) +import Network.Kafka (KafkaAddress, KafkaClientError, KafkaClientId, KafkaTime(..), TopicAndMessage(..), getLastOffset, mkKafkaState, runKafka, withAddressHandle) +import Network.Kafka.Consumer (fetch', fetchMessages, fetchRequest) +import Network.Kafka.Producer (makeKeyedMessage, produceMessages) +import Network.Kafka.Protocol (FetchResponse(..), KafkaBytes(..), Key(..), Message(..), TopicName, Value(..)) + + +-- | A name for a sensor. +type Sensor = String + + +-- | Action for iterating to produce or consume events. +type LoopAction = IO (Either KafkaClientError ()) + + +-- | Action for ending iteration. +type ExitAction = IO () + + +-- | Callback for consuming events from a sensor. +type ConsumerCallback = Sensor -- ^ The name of the sensor producing the event. + -> Event -- ^ The event. + -> IO () -- ^ The action for consuming the event. + + +-- | Consume events for a Kafka topic. +consumerLoop :: KafkaClientId -- ^ A Kafka client identifier for the consumer. + -> KafkaAddress -- ^ The address of the Kafka broker. + -> TopicName -- ^ The Kafka topic name. + -> ConsumerCallback -- ^ The consumer callback. + -> IO (ExitAction, LoopAction) -- ^ Action to create the exit and loop actions. +consumerLoop clientId address topic consumer = + do + exitFlag <- newEmptyMVar :: IO (MVar ()) + let + fromMessage :: Message -> (Sensor, Event) + fromMessage message = + let + (_, _, _, Key (Just (KBytes k)), Value (Just (KBytes v))) = _messageFields message + in + (unpack k, decode $ fromStrict v) + loop offset = + do + result <- withAddressHandle address $ \handle -> fetch' handle =<< fetchRequest offset 0 topic + let + (_, [(_, _, offset', _)]) : _ = _fetchResponseFields result + messages = fromMessage . _tamMessage <$> fetchMessages result + liftIO + $ do + mapM_ (uncurry consumer) messages + threadDelay 7500 -- FIXME: Is a thread delay really necessary in order not to miss messages? Why? + running <- liftIO $ isEmptyMVar exitFlag + when running + $ loop offset' + return + ( + void $ tryPutMVar exitFlag () + , fmap void $ runKafka (mkKafkaState clientId address) + $ do + offset <- getLastOffset LatestTime 0 topic + loop offset + ) + + +-- | Callback for producing events from a sensor. +type ProducerCallback = IO [Event] -- ^ Action for producing events. + + +-- | Produce events for a Kafka topic. +producerLoop :: KafkaClientId -- ^ A Kafka client identifier for the producer. + -> KafkaAddress -- ^ The address of the Kafka broker. + -> TopicName -- ^ The Kafka topic name. + -> Sensor -- ^ The name of the sensor producing the event. + -> ProducerCallback -- ^ The producer callback. + -> IO (ExitAction, LoopAction) -- ^ Action to create the exit and loop actions. +producerLoop clientId address topic sensor producer = + do + exitFlag <- newEmptyMVar :: IO (MVar ()) + let + loop = + do + events <- liftIO producer + void + $ produceMessages + $ map + (TopicAndMessage topic . makeKeyedMessage (pack sensor) . toStrict . encode) + events + running <- liftIO $ isEmptyMVar exitFlag + when running + loop + return + ( + void $ tryPutMVar exitFlag () + , void <$> runKafka (mkKafkaState clientId address) loop + ) diff --git a/src/Network/UI/Kafka/Keyboard.hs b/src/Network/UI/Kafka/Keyboard.hs new file mode 100644 --- /dev/null +++ b/src/Network/UI/Kafka/Keyboard.hs @@ -0,0 +1,42 @@ +{-| +Module : Network.UI.Kafka.Keyboard +Copyright : (c) 2016 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Experimental +Portability : Stable + +Produce events on a Kafka topic from standard input. +-} + + +module Network.UI.Kafka.Keyboard ( +-- * Event handling + keyboardLoop +) where + + +import Network.Kafka (KafkaAddress, KafkaClientId) +import Network.Kafka.Protocol (TopicName) +import Network.UI.Kafka (ExitAction, LoopAction, Sensor, producerLoop) +import Network.UI.Kafka.Types (Event(KeyEvent)) +import System.IO (BufferMode(NoBuffering), hSetBuffering, hSetEcho, stdin) + + +-- | Produce keyboard events on a Kafka topic from standard input. +keyboardLoop :: KafkaClientId -- ^ A Kafka client identifier for the producer. + -> KafkaAddress -- ^ The address of the Kafka broker. + -> TopicName -- ^ The Kafka topic name. + -> Sensor -- ^ The name of the sensor producing events. + -> IO (ExitAction, LoopAction) -- ^ Action to create the exit and loop actions. +keyboardLoop client address topic sensor = + do + hSetBuffering stdin NoBuffering + hSetEcho stdin False + producerLoop client address topic sensor + $ fmap (: []) + $ KeyEvent + <$> getChar + <*> return Nothing + <*> return Nothing + <*> return Nothing diff --git a/src/Network/UI/Kafka/Types.hs b/src/Network/UI/Kafka/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/UI/Kafka/Types.hs @@ -0,0 +1,324 @@ +{-| +Module : Network.UI.Kafka.Types +Copyright : (c) 2016 Brian W Bush +License : MIT +Maintainer : Brian W Bush +Stability : Experimental +Portability : Stable + +Event types. +-} + + +{-# LANGUAGE DeriveGeneric #-} + + +module Network.UI.Kafka.Types ( +-- * Types + Event(..) +, SpecialKey(..) +, Toggle(..) +, Modifiers(..) +, Button(..) +, ButtonState +, Hand(..) +, Finger(..) +) where + + +import Data.Aeson.Types (FromJSON, ToJSON) +import Data.Binary (Binary) +import Data.Serialize (Serialize) +import GHC.Generics (Generic) + + +-- | An event. +data Event = + -- | A character from a keyboard. + KeyEvent + { + key :: Char -- ^ The character. + , toggle :: Maybe Toggle -- ^ The state of the key. + , modifiers :: Maybe Modifiers -- ^ Modifiers for the key. + , mousePosition :: Maybe (Double, Double) -- ^ The position of the mouse pointer. + } + | -- | A special key from a keyboard. + SpecialKeyEvent + { + specialKey :: SpecialKey -- ^ The special key. + , toggle :: Maybe Toggle -- ^ The state of the key. + , modifiers :: Maybe Modifiers -- ^ Modifiers for the key. + , mousePosition :: Maybe (Double, Double) -- ^ The position of the mouse pointer. + } + | -- | A button press on a mouse. + MouseEvent + { + button :: ButtonState -- ^ The state of the mouse button. + , modifiers :: Maybe Modifiers -- ^ Modifiers on the keyboard. + , mousePosition :: Maybe (Double, Double) -- ^ The position of the mouse pointer. + } + | -- | The press of of a button. + ButtonEvent + { + button :: ButtonState -- ^ The state of the button. + } + | -- | The pressing of several buttons. + ButtonsEvent + { + buttons :: [ButtonState] -- ^ The states of the buttons. + } + | -- | The movement of a mouse. + PositionEvent + { + mousePosition :: Maybe (Double, Double) -- ^ The position of the mouse pointer. + } + | -- | Motion. + MotionEvent + { + motionRightward :: Double -- ^ Motion rightward (+1) to leftward (-1). + , motionUpward :: Double -- ^ Motion upward (+1) to downward (-1). + , motionBackward :: Double -- ^ Motion backward (+1) to forward (-1). + } + | -- | Rotation. + RotationEvent + { + rotationForward :: Double -- ^ Rotation forward (+1) to backward (-1). + , rotationClockwise :: Double -- ^ Rotation clockwise (+1) to counterclockwise (-1). + , rotationRightward :: Double -- ^ Rotation rightward (+1) to leftward (-1). + } + | -- | Joystick position. + JoystickEvent + { + joystickRightward :: Double -- ^ Positioning rigthward (+1) to leftward (-1). + , joystickForward :: Double -- ^ Positioning forward (+1) to backward (-1). + , joystickUpward :: Double -- ^ Positioning upward (+1) to downward (-1). + , buttons :: [ButtonState] -- ^ The states of joystick buttons. + } + | -- | Moving a finger. + FingerEvent + { + hand :: Hand -- ^ The hand of the finger. + , finger :: Finger -- ^ The finger. + , pointerPosition :: (Double, Double, Double) -- ^ The position of the finger. + } + | -- | Moving a pointer. + PointerEvent + { + pointerPosition :: (Double, Double, Double) -- ^ The position of the pointer. + } + | -- | An analog value. + AnalogEvent + { + axis :: Int -- ^ The axis for the value. + , analogValue :: Double -- ^ The value, between +1 and -1. + } + | -- | A dial value. + DialEvent + { + axis :: Int -- ^ The axis for the value. + , dialValue :: Double -- ^ The value, between 0 and +1. + } + | -- | Location in space. + LocationEvent { + location :: (Double, Double, Double) -- ^ The location vector in space. + } + | -- | Orientation in space. + OrientationEvent { + orientation :: (Double, Double, Double, Double) -- ^ The orientation quaternion in space. + } + | -- | An error. + EventError + { + message :: String -- ^ The error message. + } + deriving (Eq, Generic, Ord, Read, Show) + +instance FromJSON Event + +instance ToJSON Event + +instance Binary Event + +instance Serialize Event + + +-- | Keyboard modifiers. +data Modifiers = + Modifiers + { + shiftModifier :: Bool -- ^ Whether the shift key is down. + , ctrlModifier :: Bool -- ^ Whether the control key is down. + , altModifier :: Bool -- ^ Whether the alt key is down. + } + deriving (Eq, Generic, Ord, Read, Show) + +instance FromJSON Modifiers + +instance ToJSON Modifiers + +instance Binary Modifiers + +instance Serialize Modifiers + + +-- | A special key. +data SpecialKey = + -- | F1 + KeyF1 + | -- | F2 + KeyF2 + | -- | F3 + KeyF3 + | -- | F4 + KeyF4 + | -- | F5 + KeyF5 + | -- | F6 + KeyF6 + | -- | F7 + KeyF7 + | -- | F8 + KeyF8 + | -- | F9 + KeyF9 + | -- | F10 + KeyF10 + | -- | F11 + KeyF11 + | -- | F12 + KeyF12 + | -- | left arrow + KeyLeft + | -- | up arrow + KeyUp + | -- | right arrow + KeyRight + | -- | down arrow + KeyDown + | -- | page up + KeyPageUp + | -- | page down + KeyPageDown + | -- | home + KeyHome + | -- | end + KeyEnd + | -- | insert + KeyInsert + | -- | number lock + KeyNumLock + | -- | begin + KeyBegin + | -- | delete + KeyDelete + | -- | left shift + KeyShiftL + | -- | right shift + KeyShiftR + | -- | left control + KeyCtrlL + | -- | right control + KeyCtrlR + | -- | left alt + KeyAltL + | -- | right alt + KeyAltR + | -- | unknown, with a specified index + KeyUnknown Int + deriving (Eq, Generic, Ord, Read, Show) + +instance FromJSON SpecialKey + +instance ToJSON SpecialKey + +instance Binary SpecialKey + +instance Serialize SpecialKey + + +-- | A button and its state. +type ButtonState = (Button, Toggle) + + +-- | A button. +data Button = + -- | left mouse button + LeftButton + | -- | middle mouse button + MiddleButton + | -- | right mouse button + RightButton + | -- | mouse wheel upward + WheelUp + | -- | mouse wheel downward + WheelDown + | -- | button specified by an index + IndexButton Int + | -- | button specified by a letter + LetterButton Char + deriving (Eq, Generic, Ord, Read, Show) + +instance FromJSON Button + +instance ToJSON Button + +instance Binary Button + +instance Serialize Button + + +-- | The state of a button. +data Toggle = + -- | pressed down + Down + | -- | released and up + Up + deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show) + +instance FromJSON Toggle + +instance ToJSON Toggle + +instance Binary Toggle + +instance Serialize Toggle + + +-- | A hand. +data Hand = + -- | right hand + RightHand + | -- | left hand + LeftHand + deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show) + +instance FromJSON Hand + +instance ToJSON Hand + +instance Binary Hand + +instance Serialize Hand + + +-- | A finger. +data Finger = + -- | thumb + Thumb + | -- | first or index finger + IndexFinger + | -- | second or middle finger + MiddleFinger + | -- | third of ring finger + RingFinger + | -- | fourth finger or pinky + Pinky + deriving (Bounded, Enum, Eq, Generic, Ord, Read, Show) + +instance FromJSON Finger + +instance ToJSON Finger + +instance Binary Finger + +instance Serialize Finger