Server.hs

-- | The vacuum-opengl server. This compiles to the executable
-- \"vacuum-opengl-server\", which you need to start to be able
-- to use the 
--

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 System.Cmd
import System.Directory
import System.Environment
import System.Exit

import System.IO
import System.IO.Unsafe

import Network

import Foreign

--------------------------------------------------------------------------------

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

--------------------------------------------------------------------------------

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
      
      putMVar theTexture $ Just (tex,resolution img)
  

--------------------------------------------------------------------------------

vt :: Double -> Double -> IO ()
vt x y = vertex (Vertex2 x y)

tc :: Double -> Double -> IO ()
tc x y = texCoord (TexCoord2 x y)

-- 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
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 
    
--------------------------------------------------------------------------------