never executed always true always false
1 {-# LANGUAGE OverloadedStrings #-}
2 {-# LANGUAGE ScopedTypeVariables #-}
3 module Reanimate.Driver.Server
4 ( serve
5 , findOwnSource
6 ) where
7
8 import Control.Concurrent
9 import Control.Exception (SomeException, catch, finally)
10 import Control.Monad
11 import Data.IORef
12 import Data.Text (Text)
13 import qualified Data.Text as T
14 import qualified Data.Text.Read as T
15 import Data.Time
16 import GHC.Environment (getFullArgs)
17 import Language.Haskell.Ghcid
18 import Network.WebSockets
19 import Paths_reanimate
20 import Reanimate.Misc (runCmdLazy, runCmd_)
21 import System.Directory (createDirectoryIfMissing,
22 doesFileExist, findFile, listDirectory,
23 makeAbsolute,
24 withCurrentDirectory)
25 import System.Environment (getProgName)
26 import System.Exit
27 import System.FilePath
28 import System.FSNotify
29 import System.IO
30 import System.IO.Temp
31 import System.Process
32 import Web.Browser (openBrowser)
33
34 opts :: ConnectionOptions
35 opts = defaultConnectionOptions
36 { connectionCompressionOptions = PermessageDeflateCompression defaultPermessageDeflate }
37
38 serve :: Bool -> Maybe FilePath -> [String] -> Maybe FilePath -> IO ()
39 serve verbose mbGHCPath extraGHCOpts mbSelfPath = withManager $ \watch -> do
40 hSetBuffering stdin NoBuffering
41 self <- maybe requireOwnSource pure mbSelfPath
42 when verbose $
43 logMsg $ "Found own source code at: " ++ self
44 hasConnectionVar <- newMVar False
45
46 ghci <- ghciBackend mbGHCPath self
47
48 -- There might already browser window open. Wait 2s to see if that window
49 -- connects to us. If not, open a new window.
50 _ <- forkIO $ do
51 threadDelay (2*10^(6::Int))
52 hasConn <- readMVar hasConnectionVar
53 unless hasConn openViewer
54 logMsg "Listening..."
55 let options = ServerOptions
56 { serverHost = "127.0.0.1"
57 , serverPort = 9161
58 , serverConnectionOptions = opts
59 , serverRequirePong = Nothing }
60 withSystemTempDirectory "reanimate-svgs" $ \tmpDir ->
61 runServerWithOptions options $ \pending -> do
62 logMsg "New connection received."
63 hasConn <- swapMVar hasConnectionVar True
64 if hasConn
65 then do
66 logMsg "Already connected to browser. Rejecting."
67 rejectRequestWith pending defaultRejectRequest
68 else do
69 createDirectoryIfMissing True tmpDir
70 conn <- acceptRequest pending
71 slave <- newEmptyMVar
72 let handler = modifyMVar_ slave $ \tid -> do
73 logMsg "Reloading code..."
74 killThread tid
75 forkIO $ ignoreErrors $ slaveHandler verbose mbGHCPath extraGHCOpts conn ghci self tmpDir
76 killSlave = do
77 tid <- takeMVar slave
78 killThread tid
79 stop <- watchFile watch self handler
80 putMVar slave =<< forkIO (return ())
81 handler
82 let loop = do
83 -- FIXME: We don't use msg here.
84 _msg <- receiveData conn :: IO T.Text
85 handler
86 loop
87 cleanup = do
88 stop
89 killSlave
90 _ <- swapMVar hasConnectionVar False
91 return ()
92 loop `finally` cleanup
93
94 ignoreErrors :: IO () -> IO ()
95 ignoreErrors action = action `catch` \(_::SomeException) -> return ()
96
97 openViewer :: IO ()
98 openViewer = do
99 url <- getDataFileName "viewer-elm/dist/index.html"
100 logMsg "Opening browser..."
101 bSucc <- openBrowser url
102 if bSucc
103 then logMsg "Browser opened."
104 else hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url
105
106 slaveHandler :: Bool -> Maybe FilePath -> [String] -> Connection -> GhciBackend
107 -> FilePath -> FilePath -> IO ()
108 slaveHandler verbose mbGHCPath extraGHCOpts conn ghci self svgDir =
109 withCurrentDirectory (takeDirectory self) $
110 withSystemTempDirectory "reanimate" $ \tmpDir ->
111 withTempFile tmpDir "reanimate.exe" $ \tmpExecutable handle -> do
112 outputFolder <- createTempDirectory svgDir "svgs"
113 let frameFileName frameIdx =
114 outputFolder </> show frameIdx <.> "svg"
115
116 sentFrameCount <- newMVar False
117 hClose handle
118 lock <- newMVar ()
119 sendWebMessage conn $ WebStatus "Compiling"
120 ghciThread <- forkIO $ do
121 firstFrame <- newIORef True
122 ghciReload ghci
123 logMsg "GHCi reload done."
124 ghciGenerate ghci outputFolder $ \frameIdx -> do
125 first <- readIORef firstFrame
126 writeIORef firstFrame False
127 if first
128 then
129 modifyMVar_ sentFrameCount $ \sent -> do
130 unless sent $
131 sendWebMessage conn $ WebFrameCount frameIdx
132 logMsg "Framecount sent."
133 return True
134 else
135 withMVar lock $ \_ ->
136 sendWebMessage conn $ WebFrame frameIdx (frameFileName frameIdx)
137 logMsg "GHCi render done."
138 ret <- case mbGHCPath of
139 Nothing -> do
140 let args = ["ghc", "--"] ++ ghcOptions tmpDir ++ extraGHCOpts ++ [takeFileName self, "-o", tmpExecutable]
141 when verbose $
142 logMsg $ "Running: " ++ showCommandForUser "stack" args
143 runCmd_ "stack" args
144 Just ghc -> do
145 let args = ghcOptions tmpDir ++ extraGHCOpts ++ [takeFileName self, "-o", tmpExecutable]
146 when verbose $
147 logMsg $ "Running: " ++ showCommandForUser ghc args
148 runCmd_ ghc args
149 logMsg "Compile done."
150 case ret of
151 Left err ->
152 sendWebMessage conn $ WebError $ unlines (lines err)
153 Right{} -> runCmdLazy tmpExecutable (execOpts outputFolder) $ \getFrame -> do
154 frameCount <- expectFrame =<< getFrame
155 modifyMVar_ sentFrameCount $ \sent -> do
156 unless sent $
157 sendWebMessage conn $ WebFrameCount frameCount
158 return True
159 replicateM_ frameCount $ do
160 frameIdx <- expectFrame =<< getFrame
161 withMVar lock $ \_ ->
162 sendWebMessage conn $ WebFrame frameIdx (frameFileName frameIdx)
163 logMsg "Optimized render done."
164 killThread ghciThread
165 where
166 execOpts output =
167 [ "raw", "--output", output, "--offset", "1"
168 , "+RTS", "-N", "-M2G", "-RTS"]
169 expectFrame :: Either String Text -> IO Int
170 expectFrame (Left "") = do
171 sendWebMessage conn $ WebStatus "Done"
172 exitSuccess
173 expectFrame (Left err) = do
174 sendWebMessage conn $ WebError err
175 exitWith (ExitFailure 1)
176 expectFrame (Right frame) =
177 case T.decimal frame of
178 Left err -> do
179 hPutStrLn stderr (T.unpack frame)
180 raiseError conn err
181 Right (frameNumber, "") ->
182 pure frameNumber
183 Right {} -> do
184 let err = "Unexpected output"
185 hPutStrLn stderr (T.unpack frame)
186 raiseError conn err
187
188 raiseError :: Connection -> String -> IO a
189 raiseError conn err = do
190 hPutStrLn stderr $ "expectFrame: " ++ err
191 sendWebMessage conn $ WebError err
192 exitWith (ExitFailure 1)
193
194 watchFile :: WatchManager -> FilePath -> IO () -> IO StopListening
195 watchFile watch file action = watchTree watch (takeDirectory file) check (const action)
196 where
197 check event =
198 takeFileName (eventPath event) == takeFileName file ||
199 takeExtension (eventPath event) `elem` sourceExtensions ||
200 takeExtension (eventPath event) `elem` dataExtensions
201 sourceExtensions = [".hs", ".lhs"]
202 dataExtensions = [".jpg", ".png", ".bmp", ".pov", ".tex", ".csv"]
203
204 ghcOptions :: FilePath -> [String]
205 ghcOptions tmpDir =
206 ["-rtsopts", "--make", "-threaded", "-O2"] ++
207 ["-odir", tmpDir, "-hidir", tmpDir]
208
209 -- FIXME: Move to a different module
210 requireOwnSource :: IO FilePath
211 requireOwnSource = do
212 mbSelf <- findOwnSource
213 case mbSelf of
214 Nothing -> do
215 hPutStrLn stderr
216 "Rendering in browser window is only available when interpreting.\n\
217 \To render a video file, use the 'render' command or run again with --help\n\
218 \to see all available options."
219 exitFailure
220 Just self -> pure self
221
222 findOwnSource :: IO (Maybe FilePath)
223 findOwnSource = do
224 fullArgs <- getFullArgs
225 stackSource <- makeAbsolute (last fullArgs)
226 exist <- doesFileExist stackSource
227 if exist && isHaskellFile stackSource
228 then return (Just stackSource)
229 else do
230 prog <- getProgName
231 let hsProg
232 | isHaskellFile prog = prog
233 | otherwise = replaceExtension prog "hs"
234 lst <- listDirectory "."
235 findFile ("." : lst) hsProg
236
237 isHaskellFile :: FilePath -> Bool
238 isHaskellFile path = takeExtension path `elem` [".hs", ".lhs"]
239
240 logMsg :: String -> IO ()
241 logMsg msg = do
242 now <- getCurrentTime
243 putStrLn $ formatTime defaultTimeLocale fmt now ++ ": " ++ msg
244 where
245 fmt = "%F %T%2Q"
246
247 -------------------------------------------------------------------------------
248 -- Ghci interface
249
250 -- stack
251 -- cabal
252 -- raw
253 -- none?
254 newtype GhciBackend = GhciBackend (MVar Ghci)
255
256 ghciBackend :: Maybe FilePath -> FilePath -> IO GhciBackend
257 ghciBackend mbGHCPath self = do
258 let ghciProc =
259 case mbGHCPath of
260 Just ghcPath ->
261 proc ghcPath $ ["--interactive", "+RTS"] ++ words memoryLimit ++ ["-RTS"]
262 Nothing ->
263 proc "stack" ["exec", "ghci", "--rts-options="++memoryLimit]
264 (ghci, _loads) <- startGhciProcess ghciProc $ \_stream _msg -> return ()
265 void $ exec ghci $ ":load " ++ self
266 ref <- newMVar ghci
267 return $ GhciBackend ref
268
269 ghciReload :: GhciBackend -> IO ()
270 ghciReload (GhciBackend ref) =
271 withMVar ref $ \ghci ->
272 void $ reload ghci
273
274 ghciGenerate :: GhciBackend -> FilePath -> (Int -> IO ()) -> IO ()
275 ghciGenerate (GhciBackend ref) target cb = withMVar ref $ \ghci ->
276 execStream ghci (":main raw --output=" ++ target ++ " --offset=1")
277 $ \_ msg ->
278 case reads msg of
279 [(frameIdx,"")] -> cb frameIdx
280 _ -> return ()
281
282 memoryLimit :: String
283 memoryLimit = "-M1G"
284
285 -------------------------------------------------------------------------------
286 -- Websocket API
287
288 data WebMessage
289 = WebStatus String
290 | WebError String
291 | WebFrameCount Int
292 | WebFrame Int FilePath
293
294 sendWebMessage :: Connection -> WebMessage -> IO ()
295 sendWebMessage conn msg = sendTextData conn $
296 case msg of
297 WebStatus txt -> T.pack "status\n" <> T.pack txt
298 WebError txt -> T.pack "error\n" <> T.pack txt
299 WebFrameCount n -> T.pack $ "frame_count\n" ++ show n
300 WebFrame n path -> T.pack $ "frame\n" ++ show n ++ "\n" ++ path