-- | The vacuum-opengl server. This compiles to the executable -- \"vacuum-opengl-server\", which you need to start to be able -- to use the client library. -- module System.Vacuum.OpenGL.Server where -------------------------------------------------------------------------------- import Control.Monad import Control.Concurrent import Control.Concurrent.MVar import Control.Exception import Data.Char import Graphics.Rendering.OpenGL import Graphics.UI.GLUT import Codec.Image.STB import Data.Bitmap.IO hiding (Size) import Data.Bitmap.OpenGL import System.Cmd import System.Directory import System.Environment import System.Exit import System.FilePath import System.IO import System.IO.Unsafe import Network import Foreign import Foreign.C -------------------------------------------------------------------------------- defaultPort :: PortID defaultPort = PortNumber VACUUM_OPENGL_DEFAULTPORT -------------------------------------------------------------------------------- theTexture :: MVar (Maybe (TextureObject,(Int,Int))) theTexture = unsafePerformIO $ newMVar Nothing theImage :: MVar (Maybe Image) theImage = unsafePerformIO $ newMVar Nothing -------------------------------------------------------------------------------- gl_max_texture_size :: CInt gl_max_texture_size = 0xd33 -- OpenGL does not export this... -------------------------------------------------------------------------------- showPort :: PortID -> String showPort p = case p of PortNumber n -> show n -- Service s -> s -- UnixSocket s -> s -- UnixSocket does not exists on Windows? _ -> "unknown port type" startServer :: PortID -> IO () startServer port = withSocketsDo $ do putStrLn "vacuum-opengl-server started - press ESC to exit." putStrLn $ "listening on port " ++ showPort port listen port listen port = do socket <- listenOn port sequence_ $ repeat $ acceptConnectionAndFork socket showConn :: (Handle, HostName, PortNumber) -> String showConn (handle, hostname, portnumber) = hostname ++ ":" ++ show portnumber acceptConnectionAndFork :: Socket -> IO () acceptConnectionAndFork socket = do conn <- accept socket forkIO (server conn) return () server conn@(handle, hostname, portnumber) = do text <- hGetContents handle length text `seq` view text hClose handle -------------------------------------------------------------------------------- graphvizPath :: MVar FilePath graphvizPath = unsafePerformIO $ do findExecutable "dot" >>= \m -> case m of Nothing -> error "graphviz executable \"dot\" not found" Just path -> newMVar path runGraphviz :: [String] -> IO () runGraphviz params = do path <- readMVar graphvizPath exitcode <- rawSystem path params when (exitcode /= ExitSuccess) $ error "error running graphviz" return () convertToPNG :: String -> IO Image convertToPNG input = do tmp <- getTemporaryDirectory let dot = tmp "vacuum-opengl-temp.dot" png = tmp "vacuum-opengl-temp.png" writeFile dot input -- print dot -- print png runGraphviz [ "-Tpng" , "-o"++png , dot ] img <- loadImage png >>= \m -> case m of Left err -> error err Right img -> return img removeFile dot removeFile png return img view :: String -> IO () view dot = do img <- convertToPNG dot swapMVar theImage (Just img) win <- readMVar theWindow postRedisplay (Just win) return () -------------------------------------------------------------------------------- setTexture :: IO () setTexture = do readMVar theImage >>= \m -> case m of Nothing -> return () Just img -> do swapMVar theImage Nothing takeMVar theTexture >>= \m -> case m of Just (old,_) -> deleteObjectNames [old] Nothing -> return () b <- readMVar npot {- let myWithImage = if b then withImage else withExtendedImage tex <- myWithImage img $ \p (x,y) c -> do let (pf,pif) = case c of { 1 -> ( Luminance, Luminance8 ) ; 2 -> ( LuminanceAlpha, Luminance8Alpha8 ) ; 3 -> ( RGB, RGB8 ) ; 4 -> ( RGBA, RGBA8 ) } let size = TextureSize2D (fromIntegral x) (fromIntegral y) pdata = PixelData pf UnsignedByte p [tex] <- genObjectNames 1 textureBinding Texture2D $= Just tex texImage2D Nothing NoProxy 0 pif size 0 pdata textureFilter Texture2D $= ((Linear',Nothing),Linear') return tex -} eimg <- if b then return img else extendImage img simg <- return eimg -- will be a "scaled image" when i write it tex <- makeSimpleBitmapTexture simg putMVar theTexture $ Just (tex, bitmapSize img) -------------------------------------------------------------------------------- vt :: Double -> Double -> IO () vt x y = vertex (Vertex2 (realToFrac x :: GLdouble) (realToFrac y :: GLdouble)) tc :: Double -> Double -> IO () tc x y = texCoord (TexCoord2 (realToFrac x :: GLdouble) (realToFrac y :: GLdouble)) -- display callback display :: IO () display = do win <- readMVar theWindow currentWindow $= Just win clearColor $= Color4 0.90 0.90 0.90 1 clear [ColorBuffer] setTexture readMVar theTexture >>= \m -> case m of Nothing -> return () Just (tex,(xsize,ysize)) -> do size@(Size xres yres) <- get windowSize viewport $= ( Position 0 0 , size ) let winaspect = fromIntegral xres / fromIntegral yres :: Double picaspect = fromIntegral xsize / fromIntegral ysize :: Double matrixMode $= Projection >> loadIdentity ortho (-1) 1 (-1) 1 (-1) 1 texture Texture2D $= Enabled textureBinding Texture2D $= Just tex b <- readMVar npot let (x,y) = if picaspect > winaspect then (1,winaspect/picaspect) else (picaspect/winaspect,1) myExtendDimension = if b then id else nextPowerOfTwo u = fromIntegral xsize / fromIntegral (myExtendDimension xsize) v = fromIntegral ysize / fromIntegral (myExtendDimension ysize) renderPrimitive Quads $ do tc 0 0 ; vt (-x) ( y) tc u 0 ; vt ( x) ( y) tc u v ; vt ( x) (-y) tc 0 v ; vt (-x) (-y) swapBuffers -------------------------------------------------------------------------------- log2 :: Int -> Int log2 n = case n of 0 -> -1 _ -> 1 + log2 (shiftR n 1) nextPowerOfTwo :: Int -> Int nextPowerOfTwo n = 2 ^ ( 1 + log2 (n-1) ) -- extend the image to have power-of-two sizes, for old videocards extendImage :: Image -> IO Image extendImage bm = do let (oldx,oldy) = bitmapSize bm (newx,newy) = (nextPowerOfTwo oldx, nextPowerOfTwo newx) copySubImage' bm (0,0) (oldx,oldy) (newx,newy) (0,0) {- -- extend the image to have power-of-two sizes withExtendedImage :: Image -> (Ptr Word8 -> (Int,Int) -> Int -> IO a) -> IO a withExtendedImage img action = withImage img $ \p (oldx,oldy) c -> do let (newx,newy) = (nextPowerOfTwo oldx, nextPowerOfTwo oldy) allocaArray (newx*newy*c) $ \q -> do forM_ [0..oldy-1] $ \i -> copyArray (q `advancePtr` (i*c*newx)) -- destination (p `advancePtr` (i*c*oldx)) -- source (oldx*c) -- number of bytes action q (newx,newy) c -} -------------------------------------------------------------------------------- -- reshape callback reshape _ = postRedisplay Nothing -- keyboard callback keyboard key keyState mod pos = case key of Char '\ESC' -> exitWith ExitSuccess _ -> return () -------------------------------------------------------------------------------- theWindow :: MVar Window theWindow = unsafePerformIO newEmptyMVar npot :: MVar Bool npot = unsafePerformIO newEmptyMVar idle :: IO () idle = do threadDelay 10000 ourInitialWinSize :: Size ourInitialWinSize = Size 640 400 initGLUT :: IO () initGLUT = do initialDisplayMode $= [ RGBAMode, DoubleBuffered ] initialWindowSize $= ourInitialWinSize prog <- getProgName initialize prog [] win <- createWindow "vacuum-opengl-server" exts <- get glExtensions putMVar npot ("GL_ARB_texture_non_power_of_two" `elem` exts) displayCallback $= display idleCallback $= Just idle reshapeCallback $= Just reshape keyboardMouseCallback $= Just keyboard drawBuffer $= BackBuffers postRedisplay (Just win) putMVar theWindow win mainLoop -------------------------------------------------------------------------------- serverMain :: IO () serverMain = do args <- getArgs let port = case args of [] -> defaultPort (x:_) -> PortNumber $ fromIntegral $ (read x :: Int) forkOS (startServer port) initGLUT --------------------------------------------------------------------------------