Chitra 0.1 → 0.2
raw patch · 6 files changed
+48/−424 lines, 6 filesdep ~basedep ~binarydep ~bytestring
Dependency ranges changed: base, binary, bytestring, mtl, network
Files
- Chitra.cabal +48/−26
- Chitra/Canvas.hs +0/−27
- RFB/ClientToServer.hs +0/−109
- RFB/CommandLoop.hs +0/−129
- RFB/Handshake.hs +0/−77
- RFB/Server.hs +0/−56
Chitra.cabal view
@@ -1,41 +1,63 @@+-- Chitra.cabal auto-generated by cabal init. For additional options,+-- see+-- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.+-- The name of the package. Name: Chitra-Version: 0.1-Synopsis: Haskell library for platform independent graphics using VNC.-Homepage: http://github.com/ckkashyap/Chitra++-- The package version. See the Haskell package versioning policy+-- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for+-- standards guiding when and how versions should be incremented.+Version: 0.2++-- A short (one-line) description of the package.+Synopsis: A platform independent mechanism to render graphics using vnc.++-- A longer description of the package.+-- Description: ++-- URL for the project homepage or repository.+Homepage: https://github.com/ckkashyap/Chitra++-- The license under which the package is released. License: BSD3-License-file: LICENSE-Author: C K Kashyap-Maintainer: ckkashyap@gmail.com-synopsis: Simple, VNC based graphics rendering system-description: Chitra in most Indian languages means "Image". This aim of this project is to build an VNC library that can be used to develop interactive graphical application. What I think will be the strength of Chitra would be its "platform independence". So, the idea is, the library would have a "putpixel" function which when called would render a pixel on an image buffer that would be rendered via the vnc server. For viewing and interactive with the aplication, one would use a standard VNC client. Eventually, I might chose to do this using the RDP protocol that even has support for sound. - To try out -+-- The file containing the license text.+License-file: LICENSE - Just do a make and you should have the executable *Main* created. +-- The package author(s).+Author: C.K.Kashyap - Run ./Main <width> <height> <port> +-- An email address to which users can send suggestions, bug reports,+-- and patches.+Maintainer: ckkashyap@gmail.com - Now try connecting a vnc client to localhost:5900+-- A copyright notice.+-- Copyright: Category: Graphics Build-type: Simple +-- Extra files to be distributed with the package, such as examples or+-- a README.+-- Extra-source-files: ++-- Constraint on the version of Cabal needed to build this package. Cabal-version: >=1.2 -Library- Exposed-modules: Chitra.Canvas,- RFB.ClientToServer,- RFB.Handshake,- RFB.CommandLoop,- RFB.Server- Hs-source-dirs: ./- Build-depends: base >= 4.2 && < 4.3,- binary >= 0.5 && < 0.6,- bytestring >= 0.9 && < 1.0,- network >= 2.2 && < 2.3,- mtl >= 1.1 && < 1.2 Executable Chitra- Main-is: Main.hs- Build-depends: base >= 4.2 && < 4.3+ -- .hs or .lhs file containing the Main module.+ Main-is: Main.hs+ + -- Packages needed in order to build this package.+ Build-depends: base >= 3 && < 4 , mtl >= 2, binary >= 0.5, bytestring >= 0.5,+ network >= 2.3+ + + -- Modules not exported by this package.+ -- Other-modules: + + -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.+ -- Build-tools: +
− Chitra/Canvas.hs
@@ -1,27 +0,0 @@-module Chitra.Canvas where--import Control.Monad-import System.IO--import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as B-import Data.Char-import Data.Binary.Get-import Data.Binary.Put-import Data.Word--import qualified RFB.Constants as RFB-import qualified RFB.Server as SERVER-import qualified RFB.Handshake as Handshake-import qualified RFB.CommandLoop as CommandLoop----start w h p= do- SERVER.serve w h p doit--doit w h hnd = do- Handshake.handshake w h hnd- CommandLoop.commandLoop hnd w h- -
− RFB/ClientToServer.hs
@@ -1,109 +0,0 @@-module RFB.ClientToServer (- Command- (- SetPixelFormat ,- SetEncodings ,- FramebufferUpdate ,- KeyEvent ,- PointerEvent ,- ClientCutText ,- BadCommand- ),- CommandData- (- SetPixelFormatData ,- SetEncodingsData ,- FramebufferUpdateData ,- KeyEventData ,- PointerEventData ,- ClientCutTextData- ),- bytesToRead,- parseCommandByteString,- getCommandData,- word8ToCommand,-) where--import Data.Word--import qualified Utilities.ParseByteString as PBS-import qualified Data.ByteString.Lazy as BS---data Command = SetPixelFormat | SetEncodings | FramebufferUpdate | KeyEvent | PointerEvent | ClientCutText | BadCommand deriving (Show)--data CommandData = SetPixelFormatData {- bitsPerPixel :: Int,- depth :: Int,- bigEndian :: Int,- trueColor :: Int,- redMax :: Int,- greenMax :: Int,- blueMax :: Int,- redShift :: Int,- greenShift :: Int,- blueShift :: Int-} | ClientCutTextData {- length :: Int-} | SetEncodingsData {- count :: Int-} | FramebufferUpdateData {- incremental :: Int,- x :: Int,- y :: Int,- width :: Int,- height :: Int-} | KeyEventData {- downFlag :: Int,- key :: Int-} | PointerEventData {- buttonMask :: Int,- x :: Int,- y :: Int-} | BadCommandData deriving (Show)----bytesToRead :: Command -> Int-bytesToRead c = foldr (+) 0 (map (\x -> if x == 0 then 1 else x) (commandFormat c))--commandFormat :: Command -> [Int] -- 0 for padding bytes-commandFormat c = case c of- SetPixelFormat -> [0,0,0,1,1,1,1,2,2,2,1,1,1,0,0,0]- SetEncodings -> [0,2]- FramebufferUpdate -> [1,2,2,2,2]- KeyEvent -> [1,0,0,4]- PointerEvent -> [1,2,2]- ClientCutText -> [0,0,0,4]- BadCommand -> []---parseCommandByteString :: BS.ByteString -> Command -> [Int]-parseCommandByteString byteString command =- PBS.parseByteString list byteString- where - list = (commandFormat command)--getCommandData :: BS.ByteString -> Command -> CommandData-getCommandData byteString command = commandDataFromList list- where- list = PBS.parseByteString (commandFormat command) byteString- commandDataFromList xs = case command of- SetPixelFormat -> SetPixelFormatData (xs!!0) (xs!!1) (xs!!2) (xs!!3) (xs!!4) (xs!!5) (xs!!6) (xs!!7) (xs!!8) (xs!!9)- SetEncodings -> SetEncodingsData (xs!!0)- FramebufferUpdate -> FramebufferUpdateData (xs!!0) (xs!!1) (xs!!2) (xs!!3) (xs!!4)- KeyEvent -> KeyEventData (xs!!0) (xs!!1)- PointerEvent -> PointerEventData (xs!!0) (xs!!1) (xs!!2)- ClientCutText -> ClientCutTextData (xs!!0)- BadCommand -> BadCommandData---word8ToCommand :: Word8 -> Command-word8ToCommand w = case w of- 0 -> SetPixelFormat- 2 -> SetEncodings- 3 -> FramebufferUpdate- 4 -> KeyEvent- 5 -> PointerEvent- 6 -> ClientCutText- _ -> BadCommand
− RFB/CommandLoop.hs
@@ -1,129 +0,0 @@-{-# LANGUAGE NamedFieldPuns #-}-module RFB.CommandLoop (commandLoop) where--import System.IO-import qualified Data.ByteString.Lazy as BS--import Data.Char-import Data.Binary.Get-import Data.Binary.Put-import Data.Word--import qualified RFB.ClientToServer as RFBClient-import qualified RFB.Encoding as Encoding-import qualified RFB.State as RFBState--import Control.Monad.State---type MyState a = StateT RFBState.RFBState IO a--commandLoop :: Handle -> Int -> Int -> IO ()-commandLoop h width height= do- runStateT (commandLoop1 h) (RFBState.initialState width height)- return ()---commandLoop1 :: Handle -> MyState ()-commandLoop1 handle = do- commandByte <- liftIO$ BS.hGet handle 1- let command = RFBClient.word8ToCommand $ runGet (do {x<-getWord8;return(x);}) commandByte- byteStream <- liftIO $ BS.hGet handle (RFBClient.bytesToRead command)- let commandData = RFBClient.getCommandData byteStream command- --let commandData = RFBClient.parseCommandByteString byteStream command- liftIO $ putStrLn $ "Client said -> " ++ (show command)- liftIO $ putStrLn (show commandData)- case command of- RFBClient.SetPixelFormat -> processSetPixelFormat commandData- RFBClient.SetEncodings -> liftIO $ processSetEncodings handle commandData - RFBClient.FramebufferUpdate -> processFrameBufferUpdateRequest handle commandData- RFBClient.PointerEvent -> processPointerEvent handle commandData- RFBClient.ClientCutText -> processClientCutTextEvent handle commandData- RFBClient.KeyEvent -> processKeyEvent handle commandData- RFBClient.BadCommand -> liftIO $ putStrLn (show command)- commandLoop1 handle----processClientCutTextEvent handle (RFBClient.ClientCutTextData length) = do- x <- liftIO $ BS.hGet handle length- liftIO $ putStrLn (show x)-- --processKeyEvent handle commandData = do- return ()--processPointerEvent handle (RFBClient.PointerEventData buttonMask x y)= do- state@(RFBState.RFBState d i p pend u) <- get- let newState=if buttonMask == 1 then Encoding.putPixel state (x,y) else state- put newState- if pend && ((length u) > 0) then do- liftIO $ putStrLn $ "Updating -> " ++ (show u)- liftIO $ BS.hPutStr handle (updateRectangles state)- liftIO $ hFlush handle- put (RFBState.RFBState d i p False [])- return ()- else - return ()----processSetPixelFormat (RFBClient.SetPixelFormatData bitsPerPixel depth bigEndian trueColor redMax greenMax blueMax redShift greenShift blueShift)- = do- state <- get- let newState=RFBState.setPixelFormat state bitsPerPixel bigEndian redMax greenMax blueMax redShift greenShift blueShift- put newState- return ()----processSetEncodings handle (RFBClient.SetEncodingsData count) = do- x <- BS.hGet handle (4*count)- let e = runGet (do {x<-getWord32le; return x}) x- putStrLn (show e)- return ()---fullScreen :: Int -> Int -> Int -> Int -> RFBState.RFBState -> BS.ByteString-fullScreen x y width height state = runPut $ do- putWord8 0- putWord8 0- putWord16be 1- putWord16be (fromIntegral x)- putWord16be (fromIntegral y)- putWord16be (fromIntegral width)- putWord16be (fromIntegral height)- putWord32be 0- Encoding.getImageByteString state x y width height- return ()----updateRectangles state@(RFBState.RFBState _ _ (RFBState.PixelFormat bpp _ _ _ _ _ _ _) pend updateList) = runPut $ do- putWord8 0- putWord8 0- putWord16be (fromIntegral (length updateList))- Encoding.encodeRectagles bpp updateList- return ()--empty = runPut $ return ()--- --processFrameBufferUpdateRequest handle (RFBClient.FramebufferUpdateData incremental x y width height) = do -- this produces black- state@(RFBState.RFBState d i p pend u) <- get- let byteString=if incremental == 0 then fullScreen x y width height state else (if (length u > 0) then updateRectangles state else empty)- --let newState = if incremental == 0 then state else RFBState.RFBState d i p pend []- let newState = if incremental == 0 then RFBState.RFBState d i p False [] else RFBState.RFBState d i p (if (length u > 0) then False else True) [] - put newState- (RFBState.RFBState _ _ _ newPend _) <- get- liftIO $ putStrLn (show pend)- liftIO $ putStrLn (show newPend)- --liftIO $ putStrLn (show state)- --liftIO $ putStrLn (show newState)- liftIO $ BS.hPutStr handle byteString- liftIO $ hFlush handle--
− RFB/Handshake.hs
@@ -1,77 +0,0 @@-module RFB.Handshake (handshake) where--import System.IO-import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as B-import Data.Char-import Data.Binary.Get-import Data.Binary.Put-import Data.Word--import Control.Monad.State--type MyState a = StateT Int IO a----handshake :: Int -> Int -> Handle -> IO ()-handshake w h hnd = do- runStateT (handshake1 w h hnd) 0- return ()- --handshake1 :: Int -> Int -> Handle -> MyState ()-handshake1 width height handle = do- liftIO $ hPutStrLn handle "RFB 003.003"- liftIO $ hFlush handle-- byteStream <- liftIO $ hGetLine handle- liftIO $ putStrLn ("Client Said :: " ++ (show byteStream))- let majorVersion = read $ (take 3).(drop 4) $ byteStream :: Int- if majorVersion /= 3 then liftIO (fail ("Expected 3 but the Client sent " ++ (show majorVersion)))- else liftIO $ return () -- contiue down the function-- -- Send 1 to the client, meaning, no auth required- liftIO $ BS.hPutStr handle (BS.pack [0,0,0,1])- liftIO $ hFlush handle-- clientInitMessage <- liftIO $ BS.hGet handle 1-- let sharedOrNot = runGet (do {x<-getWord8;return(x);}) clientInitMessage-- if sharedOrNot==1 then liftIO $ putStrLn "Sharing enabled"- else liftIO $ putStrLn "Sharing disabled"-- liftIO $ BS.hPutStr handle (serverInitMessage width height)- liftIO $ hFlush handle-----serverInitMessage :: Int -> Int -> BS.ByteString-serverInitMessage width height = runPut $ do- putWord16be (fromIntegral width::Word16) -- width- putWord16be (fromIntegral height::Word16) -- height- --pixel format- putWord8 (32::Word8) -- bits per pixl- putWord8 (24::Word8) -- depth- putWord8 (1::Word8) -- big endian- putWord8 (1::Word8) -- true color- putWord16be (255::Word16) -- red max- putWord16be (255::Word16) -- green max- putWord16be (255::Word16) -- blue max- putWord8 (16::Word8) -- red shift- putWord8 (8::Word8) -- green shift- putWord8 (0::Word8) -- blue shift-- --padding- putWord8 (0::Word8)- putWord8 (0::Word8)- putWord8 (0::Word8)-- --name length- let name = "Haskell Framebuffer"- putWord32be (((fromIntegral.length) name)::Word32)- --mapM_ (putWord8.fromIntegral.ord) name --this works- putLazyByteString (B.pack name)- --putLazyByteString (stringToByteString name) --this works
− RFB/Server.hs
@@ -1,56 +0,0 @@-module RFB.Server (serve) where--import Data.Bits-import Network.Socket-import Network.BSD-import Data.List-import Control.Concurrent-import Control.Concurrent.MVar-import System.IO----- HandlerFunc Width Height-type HandlerFunc = Int -> Int -> Handle -> IO ()--serve :: Int -> Int -> String -> HandlerFunc -> IO ()-serve width height port handlerFunc = withSocketsDo $- do -- Look up the port. Either raises an exception or returns- -- a nonempty list. - addrinfos <- getAddrInfo - (Just (defaultHints {addrFlags = [AI_PASSIVE]}))- Nothing (Just port)- let serveraddr = head addrinfos-- -- Create a socket- sock <- socket (addrFamily serveraddr) Stream defaultProtocol-- -- Bind it to the address we're listening to- bindSocket sock (addrAddress serveraddr)-- -- Start listening for connection requests. Maximum queue size- -- of 5 connection requests waiting to be accepted.- listen sock 5-- -- Create a lock to use for synchronizing access to the handler- lock <- newMVar ()-- -- Loop forever waiting for connections. Ctrl-C to abort.- procRequests lock sock- where- -- | Process incoming connection requests- procRequests :: MVar () -> Socket -> IO ()- procRequests lock mastersock = - do (connsock, clientaddr) <- accept mastersock- forkIO $ procMessages lock connsock clientaddr- procRequests lock mastersock-- -- | Process incoming messages- procMessages :: MVar () -> Socket -> SockAddr -> IO ()- procMessages lock connsock clientaddr =- do connhdl <- socketToHandle connsock ReadWriteMode- --hSetBuffering connhdl LineBuffering- --messages <- hGetContents connhdl- --mapM_ (handle lock clientaddr) (lines messages)- handlerFunc width height connhdl- hClose connhdl-