diff --git a/Chitra.cabal b/Chitra.cabal --- a/Chitra.cabal +++ b/Chitra.cabal @@ -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 +-- 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: + diff --git a/Chitra/Canvas.hs b/Chitra/Canvas.hs deleted file mode 100644 --- a/Chitra/Canvas.hs +++ /dev/null @@ -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 - - diff --git a/RFB/ClientToServer.hs b/RFB/ClientToServer.hs deleted file mode 100644 --- a/RFB/ClientToServer.hs +++ /dev/null @@ -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 diff --git a/RFB/CommandLoop.hs b/RFB/CommandLoop.hs deleted file mode 100644 --- a/RFB/CommandLoop.hs +++ /dev/null @@ -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 - - diff --git a/RFB/Handshake.hs b/RFB/Handshake.hs deleted file mode 100644 --- a/RFB/Handshake.hs +++ /dev/null @@ -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 diff --git a/RFB/Server.hs b/RFB/Server.hs deleted file mode 100644 --- a/RFB/Server.hs +++ /dev/null @@ -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 -