packages feed

Chitra 0.2.1 → 0.2.2

raw patch · 10 files changed

+594/−2 lines, 10 files

Files

Chitra.cabal view
@@ -7,7 +7,7 @@ -- 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.1+Version:             0.2.2  -- A short (one-line) description of the package. Synopsis:            A platform independent mechanism to render graphics using vnc.@@ -56,7 +56,9 @@ 	      -- Modules not exported by this package.-  -- Other-modules:       +  Other-modules: Chitra.Canvas, RFB.ClientToServer, RFB.CommandLoop,+                 RFB.Constants, RFB.Encoding, RFB.Handshake, RFB.Server, +                 RFB.State, Utilities.ParseByteString      -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.   -- Build-tools:
+ 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+	+
+ 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/Constants.hs view
@@ -0,0 +1,11 @@+module RFB.Constants where++import Data.Word++-- Client to Server messages+setPixelFormat			= 0 :: Word8+setEncodings			= 2 :: Word8+framebufferUpdateRequest	= 3 :: Word8+keyEvent			= 4 :: Word8+pointerEvent			= 5 :: Word8+clientCutText			= 6 :: Word8
+ RFB/Encoding.hs view
@@ -0,0 +1,67 @@+module RFB.Encoding (getImageByteString,putPixel,encodeRectagles) where++import qualified Data.ByteString.Lazy as BS+import Data.Binary.Get+import Data.Binary.Put+import Data.Word+import Data.Bits++import qualified RFB.State as RFBState+++getImageByteString (RFBState.RFBState (totalWidth,_) imageData (RFBState.PixelFormat bpp _ _ _ _ _ _ _) pending updateList) x y width height =  encodeImage (clip imageData x y width height totalWidth) bpp+++++clip imageData x y width height totalWidth = horizontolClip verticalClip+	where+		verticalClip = take (height*totalWidth) (drop (y*totalWidth) imageData)+		horizontolClip [] = []+		horizontolClip image = (take width (drop x image)) ++ (horizontolClip (drop totalWidth image))++++encodeImage [] _ = return ()+encodeImage ((r,g,b):xs) bpp = do+	encode (r,g,b) bpp+	encodeImage xs bpp++++encode (r,g,b) bitsPerPixel = do+	case bitsPerPixel of+		RFBState.Bpp8	-> putWord8 z8+		RFBState.Bpp16	-> putWord16le z16+		RFBState.Bpp32	-> putWord32le z32+	where +		z8  = (fromIntegral $ nr + ng + nb) :: Word8+		z16 = (fromIntegral $ nr + ng + nb) :: Word16+		z32 = (fromIntegral $ nr + ng + nb) :: Word32+		nr = scale r (RFBState.r_max bitsPerPixel) (RFBState.r_shift bitsPerPixel)+		ng = scale g (RFBState.g_max bitsPerPixel) (RFBState.g_shift bitsPerPixel)+		nb = scale b (RFBState.b_max bitsPerPixel) (RFBState.b_shift bitsPerPixel)+		scale c cm cs = (c * cm `div` 255) `shift` cs+++encodeRectagles _ []  = return ()+encodeRectagles bpp ((RFBState.Rectangle x y w h):xs) = do+	putWord16be (fromIntegral x)+	putWord16be (fromIntegral y)+	putWord16be (fromIntegral w)+	putWord16be (fromIntegral h)+	putWord32be 0+	encode (r,g,b) bpp+	encodeRectagles bpp xs+		where+			r = 255 :: Word32+			g = 255 :: Word32+			b = 255 :: Word32++++putPixel (RFBState.RFBState dim@(width,_) imageData pf pending updateList) (x,y) = RFBState.RFBState dim newImgeData pf pending ((RFBState.Rectangle x y 1 1):updateList)+	where+		newImgeData = (take count imageData) ++ [(255,255,255)] ++ (drop (count+1) imageData)+		count = width*y + x+
+ 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+
+ RFB/State.hs view
@@ -0,0 +1,77 @@+module RFB.State (+	RFBState (RFBState),+	PixelFormat (PixelFormat),+	initialState,+	setPixelFormat,+	r_max,+	g_max,+	b_max,+	r_shift,+	g_shift,+	b_shift,+	BitsPerPixel( Bpp8, Bpp16, Bpp32),+	Rectangle (Rectangle)+	) where++type Red = Int+type Green = Int+type Blue = Int+type Color  = (Red,Green,Blue)++type ImageData = [Color]+type ImageDimension = (Int,Int)++type BigEndian = Int+type RedMax = Int+type GreenMax = Int+type BlueMax = Int+type RedShift = Int+type GreenShift = Int+type BlueShift = Int++type FrameBufferUpdatePending = Bool++data BitsPerPixel = Bpp8 | Bpp16 | Bpp32 deriving (Show)++data PixelFormat = PixelFormat BitsPerPixel BigEndian RedMax GreenMax BlueMax RedShift GreenShift BlueShift deriving (Show)++data Rectangle = Rectangle Int Int Int Int deriving (Show)++data RFBState = RFBState ImageDimension ImageData PixelFormat FrameBufferUpdatePending [Rectangle] deriving(Show)++initialState width height = RFBState (width,height) imageData pixelFormat False []+	where+		imageData = replicate (width*height) (0,0,255)+		pixelFormat = PixelFormat Bpp32 1 255 255 255 16 8 0++setPixelFormat (RFBState dim imageData _ pending updateList) bpp bigEndian rm gm bm rs gs bs = RFBState dim imageData (PixelFormat (int2bpp bpp) bigEndian rm gm bm rs gs bs) pending updateList++int2bpp i+	| i == 8 = Bpp8+	| i == 16 = Bpp16+	| otherwise = Bpp32+++r_max Bpp8 = 7+r_max Bpp16 = 31+r_max Bpp32 = 255++g_max Bpp8 = 7+g_max Bpp16 = 63+g_max Bpp32 = 255++b_max Bpp8 = 3+b_max Bpp16 = 31+b_max Bpp32 = 255++r_shift Bpp8 = 0+r_shift Bpp16 = 11+r_shift Bpp32 = 16++g_shift Bpp8 = 3+g_shift Bpp16 = 5+g_shift Bpp32 = 8++b_shift Bpp8 = 6+b_shift Bpp16 = 0+b_shift Bpp32 = 0
+ Utilities/ParseByteString.hs view
@@ -0,0 +1,37 @@+module Utilities.ParseByteString (parseByteString) where++import Control.Applicative ((<$>))+import Data.Word+import Data.Binary.Get+import qualified Data.ByteString.Lazy as BS++data Action m = A1 (m Word8) | A2 (m Word16) | A4 (m Word32)++action 1 = A1 getWord8+action 2 = A2 getWord16be+action 4 = A4 getWord32be+action _ = A1 getWord8+++getActionList xs = map action xs++newtype Id a = Id a++getAction :: Action Get -> Get (Action Id)+getAction (A1 act) = A1 . Id <$> act +getAction (A2 act) = A2 . Id <$> act+getAction (A4 act) = A4 . Id <$> act++getActions :: [Action Get] -> Get [Action Id]+getActions  = mapM getAction++toVal (A1 (Id v)) = fromIntegral v :: Int+toVal (A2 (Id v)) = fromIntegral v :: Int+toVal (A4 (Id v)) = fromIntegral v :: Int++parseByteString :: (Num a) => [a] -> BS.ByteString -> [Int]+parseByteString list byteString = cleanup solution+		where +			cleanup list1 = map snd . filter ((/= 0) . fst) $ zip list list1+			solution = map toVal $ runGet actionList byteString+			actionList = getActions (getActionList list)