diff options
Diffstat (limited to 'testclient/client.hs')
-rw-r--r-- | testclient/client.hs | 187 |
1 files changed, 187 insertions, 0 deletions
diff --git a/testclient/client.hs b/testclient/client.hs new file mode 100644 index 0000000..236320c --- /dev/null +++ b/testclient/client.hs | |||
@@ -0,0 +1,187 @@ | |||
1 | {-# LANGUAGE PackageImports, LambdaCase, OverloadedStrings, RecordWildCards #-} | ||
2 | |||
3 | import Control.Concurrent | ||
4 | import Control.Concurrent.MVar | ||
5 | import Control.Monad | ||
6 | import Control.Monad.Catch | ||
7 | import Data.Text (Text) | ||
8 | import Data.Vector (Vector,(!)) | ||
9 | import Data.ByteString.Char8 (unpack,pack) | ||
10 | import qualified Data.ByteString as SB | ||
11 | import qualified Data.Vector as V | ||
12 | import qualified Data.Map as Map | ||
13 | import qualified Data.ByteString.Base64 as B64 | ||
14 | |||
15 | import System.Exit | ||
16 | import Data.Time.Clock | ||
17 | import Data.Aeson | ||
18 | import Foreign | ||
19 | |||
20 | import qualified Network.WebSockets as WS | ||
21 | import Network.Socket | ||
22 | |||
23 | import "GLFW-b" Graphics.UI.GLFW as GLFW | ||
24 | import "OpenGLRaw" Graphics.GL.Core33 | ||
25 | import Codec.Picture as Juicy | ||
26 | |||
27 | import LambdaCube.IR | ||
28 | import LambdaCube.PipelineSchema | ||
29 | import LambdaCube.Mesh | ||
30 | import LambdaCube.GL | ||
31 | import LambdaCube.GL.Mesh | ||
32 | import TestData | ||
33 | |||
34 | main = do | ||
35 | win <- initWindow "LambdaCube 3D OpenGL 3.3 Backend" 256 256 | ||
36 | |||
37 | GLFW.setWindowCloseCallback win $ Just $ \_ -> do | ||
38 | GLFW.destroyWindow win | ||
39 | GLFW.terminate | ||
40 | exitSuccess | ||
41 | |||
42 | -- connect to the test server | ||
43 | forever $ catchAll (setupConnection win) $ \_ -> do | ||
44 | GLFW.pollEvents | ||
45 | threadDelay 100000 | ||
46 | |||
47 | setupConnection win = withSocketsDo $ WS.runClient "192.168.0.12" 9160 "/" $ \conn -> do | ||
48 | putStrLn "Connected!" | ||
49 | -- register backend | ||
50 | WS.sendTextData conn . encode $ ClientInfo | ||
51 | { clientName = "Haskell OpenGL 3.3" | ||
52 | , clientBackend = OpenGL33 | ||
53 | } | ||
54 | chan <- newEmptyMVar :: IO (MVar RenderJob) | ||
55 | -- wait for incoming render jobs | ||
56 | _ <- forkIO $ forever $ do | ||
57 | -- get the pipeline from the server | ||
58 | decodeStrict <$> WS.receiveData conn >>= \case | ||
59 | Nothing -> putStrLn "unknown message" | ||
60 | Just renderJob -> putMVar chan renderJob | ||
61 | -- process render jobs | ||
62 | forever $ do | ||
63 | tryTakeMVar chan >>= \case | ||
64 | Nothing -> return () | ||
65 | Just rj -> processRenderJob win conn rj | ||
66 | WS.sendPing conn ("hello" :: Text) | ||
67 | GLFW.pollEvents | ||
68 | threadDelay 100000 | ||
69 | putStrLn "disconnected" | ||
70 | WS.sendClose conn ("Bye!" :: Text) | ||
71 | |||
72 | doAfter = flip (>>) | ||
73 | |||
74 | processRenderJob win conn renderJob@RenderJob{..} = do | ||
75 | putStrLn "got render job" | ||
76 | gpuData@GPUData{..} <- allocateGPUData renderJob | ||
77 | -- foreach pipeline | ||
78 | doAfter (disposeGPUData gpuData) $ forM_ pipelines $ \pipelineDesc -> do | ||
79 | renderer <- allocRenderer pipelineDesc | ||
80 | -- foreach scene | ||
81 | doAfter (disposeRenderer renderer) $ forM_ scenes $ \Scene{..} -> do | ||
82 | storage <- allocStorage schema | ||
83 | -- add objects | ||
84 | forM_ (Map.toList objectArrays) $ \(name,objs) -> forM_ objs $ addMeshToObjectArray storage name [] . (gpuMeshes !) | ||
85 | -- set render target size | ||
86 | GLFW.setWindowSize win renderTargetWidth renderTargetHeight | ||
87 | setScreenSize storage (fromIntegral renderTargetWidth) (fromIntegral renderTargetHeight) | ||
88 | -- connect renderer with storage | ||
89 | doAfter (disposeStorage storage) $ setStorage renderer storage >>= \case | ||
90 | Just err -> putStrLn err | ||
91 | Nothing -> do | ||
92 | -- foreach frame | ||
93 | forM_ frames $ \Frame{..} -> do | ||
94 | -- setup uniforms | ||
95 | updateUniforms storage $ do | ||
96 | forM_ (Map.toList frameTextures) $ \(name,tex) -> pack name @= return (gpuTextures ! tex) | ||
97 | forM_ (Map.toList frameUniforms) $ uncurry setUniformValue | ||
98 | -- rendering | ||
99 | renderTimes <- V.replicateM renderCount . timeDiff $ do | ||
100 | renderFrame renderer | ||
101 | GLFW.swapBuffers win | ||
102 | GLFW.pollEvents | ||
103 | -- send render job result to server | ||
104 | WS.sendTextData conn . encode . RenderJobResult $ FrameResult | ||
105 | { frRenderTimes = renderTimes | ||
106 | , frImageWidth = renderTargetWidth | ||
107 | , frImageHeight = renderTargetHeight | ||
108 | } | ||
109 | -- send the last render result using Base64 encoding | ||
110 | WS.sendBinaryData conn . B64.encode =<< getFrameBuffer renderTargetWidth renderTargetHeight | ||
111 | |||
112 | -- utility code | ||
113 | |||
114 | initWindow :: String -> Int -> Int -> IO Window | ||
115 | initWindow title width height = do | ||
116 | GLFW.init | ||
117 | GLFW.defaultWindowHints | ||
118 | mapM_ GLFW.windowHint | ||
119 | [ WindowHint'ContextVersionMajor 3 | ||
120 | , WindowHint'ContextVersionMinor 3 | ||
121 | , WindowHint'OpenGLProfile OpenGLProfile'Core | ||
122 | , WindowHint'OpenGLForwardCompat True | ||
123 | ] | ||
124 | Just win <- GLFW.createWindow width height title Nothing Nothing | ||
125 | GLFW.makeContextCurrent $ Just win | ||
126 | return win | ||
127 | |||
128 | getFrameBuffer w h = do | ||
129 | glFinish | ||
130 | glBindFramebuffer GL_READ_FRAMEBUFFER 0 | ||
131 | glReadBuffer GL_FRONT_LEFT | ||
132 | glBlitFramebuffer 0 0 (fromIntegral w) (fromIntegral h) 0 (fromIntegral h) (fromIntegral w) 0 GL_COLOR_BUFFER_BIT GL_NEAREST | ||
133 | glReadBuffer GL_BACK_LEFT | ||
134 | withFrameBuffer 0 0 w h $ \p -> SB.packCStringLen (castPtr p,w*h*4) | ||
135 | |||
136 | withFrameBuffer :: Int -> Int -> Int -> Int -> (Ptr Word8 -> IO a) -> IO a | ||
137 | withFrameBuffer x y w h fn = allocaBytes (w*h*4) $ \p -> do | ||
138 | glPixelStorei GL_UNPACK_LSB_FIRST 0 | ||
139 | glPixelStorei GL_UNPACK_SWAP_BYTES 0 | ||
140 | glPixelStorei GL_UNPACK_ROW_LENGTH 0 | ||
141 | glPixelStorei GL_UNPACK_IMAGE_HEIGHT 0 | ||
142 | glPixelStorei GL_UNPACK_SKIP_ROWS 0 | ||
143 | glPixelStorei GL_UNPACK_SKIP_PIXELS 0 | ||
144 | glPixelStorei GL_UNPACK_SKIP_IMAGES 0 | ||
145 | glPixelStorei GL_UNPACK_ALIGNMENT 1 -- normally 4! | ||
146 | glReadPixels (fromIntegral x) (fromIntegral y) (fromIntegral w) (fromIntegral h) GL_RGBA GL_UNSIGNED_BYTE $ castPtr p | ||
147 | fn p | ||
148 | |||
149 | data GPUData | ||
150 | = GPUData | ||
151 | { gpuTextures :: Vector TextureData | ||
152 | , gpuMeshes :: Vector GPUMesh | ||
153 | } | ||
154 | |||
155 | allocateGPUData RenderJob{..} = GPUData <$> mapM uploadTex2D textures <*> mapM uploadMeshToGPU meshes | ||
156 | where uploadTex2D = uploadTexture2DToGPU . either error id . decodeImage . either error id . B64.decode . pack | ||
157 | |||
158 | disposeGPUData GPUData{..} = mapM_ disposeTexture gpuTextures >> mapM_ disposeMesh gpuMeshes | ||
159 | |||
160 | timeDiff m = (\s e -> realToFrac $ diffUTCTime e s) <$> getCurrentTime <* m <*> getCurrentTime | ||
161 | |||
162 | setUniformValue name = \case | ||
163 | VBool v -> pack name @= return v | ||
164 | VV2B v -> pack name @= return v | ||
165 | VV3B v -> pack name @= return v | ||
166 | VV4B v -> pack name @= return v | ||
167 | VWord v -> pack name @= return v | ||
168 | VV2U v -> pack name @= return v | ||
169 | VV3U v -> pack name @= return v | ||
170 | VV4U v -> pack name @= return v | ||
171 | VInt v -> pack name @= return v | ||
172 | VV2I v -> pack name @= return v | ||
173 | VV3I v -> pack name @= return v | ||
174 | VV4I v -> pack name @= return v | ||
175 | VFloat v -> pack name @= return v | ||
176 | VV2F v -> pack name @= return v | ||
177 | VV3F v -> pack name @= return v | ||
178 | VV4F v -> pack name @= return v | ||
179 | VM22F v -> pack name @= return v | ||
180 | VM23F v -> pack name @= return v | ||
181 | VM24F v -> pack name @= return v | ||
182 | VM32F v -> pack name @= return v | ||
183 | VM33F v -> pack name @= return v | ||
184 | VM34F v -> pack name @= return v | ||
185 | VM42F v -> pack name @= return v | ||
186 | VM43F v -> pack name @= return v | ||
187 | VM44F v -> pack name @= return v | ||