VNC server

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
module Main where

import Network.Server
import Network.Socket
import Control.Monad
import System.IO

import qualified Data.ByteString.Lazy as BS
import Data.Binary.Get
import Data.Word


main :: IO ()
main = do
	running <- serveOne (Just $ UserWithDefaultGroup "ckk") server
	putStrLn "server is accepting connections!!!"
	waitFor running

	where server = Server (SockAddrInet 5901 iNADDR_ANY) Stream doVNC



byteString2Number :: BS.ByteString -> Int
byteString2Number bs = _byteString2Number 1 (digits bs)
	where
		_byteString2Number _ [] = 0
		_byteString2Number n (x:xs) = (n*x) + (_byteString2Number (n*10) xs)
		digits bs = map ((+(-48)).fromIntegral) (BS.unpack(BS.reverse bs))


readClientHeader  = do
	getLazyByteString 4
	m <- getLazyByteString 3 
	getWord8
	n <- getLazyByteString 3
	getWord8
	let majorVersionNumber = byteString2Number m
	let minorVersionNumber = byteString2Number n
	if (majorVersionNumber /= 3) then 
		fail ("ERROR: Unsupported version " ++ (show majorVersionNumber))
		else 
		return (byteString2Number m,byteString2Number n)

startRFB :: Handle -> IO ()
startRFB h = do
		hPutStrLn h "RFB 003.003"
		hFlush h
		x <- BS.hGet h 12
		let (m,n) = ( runGet readClientHeader x)
		hPutStrLn h (show m)
		hFlush h
		return ()
			
-- |the simple echo server routine
doVNC :: ServerRoutine
doVNC (h,n,p) = do startRFB h