Chitra (empty) → 0.1

raw patch · 9 files changed

+481/−0 lines, 9 filesdep +basedep +binarydep +bytestringsetup-changed

Dependencies added: base, binary, bytestring, mtl, network

Files

Chitra.cabal +41/−0
Chitra/Canvas.hs +27/−0
LICENSE +29/−0
Main.hs +11/−0
RFB/ClientToServer.hs +109/−0
RFB/CommandLoop.hs +129/−0
RFB/Handshake.hs +77/−0
RFB/Server.hs +56/−0
Setup.hs +2/−0

+ Chitra.cabal view

@@ -0,0 +1,41 @@+Name:                Chitra+Version:             0.1+Synopsis:            Haskell library for platform independent graphics using VNC.+Homepage:            http://github.com/ckkashyap/Chitra+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 -++	Just do a make and you should have the executable *Main* created. ++	Run ./Main <width> <height> <port> ++	Now try connecting a vnc client to localhost:5900++Category:            Graphics++Build-type:          Simple++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

+ Chitra/Canvas.hs view

@@ -0,0 +1,27 @@+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+	+

+ LICENSE view

@@ -0,0 +1,29 @@+Copyright 2002, C.K.Kashyap+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++ * Redistributions of source code must retain the above copyright notice,+   this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.++ * Neither the name of the copyright holder(s) nor the names of+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Main.hs view

@@ -0,0 +1,11 @@+import qualified Chitra.Canvas as C+import System.Environment++main = do+	args <- getArgs+	case args of+		[w,h,port] -> C.start width height port+			where+				width = read w :: Int+				height = read h :: Int+		_ -> putStrLn "Usage: ./Main width height port"

+ RFB/ClientToServer.hs view

@@ -0,0 +1,109 @@+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 view

@@ -0,0 +1,129 @@+{-# 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 view

@@ -0,0 +1,77 @@+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 view

@@ -0,0 +1,56 @@+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+

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain