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 do
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 hPutStrLn stderr $ "expectFrame: " ++ err
181 sendWebMessage conn $ WebError err
182 exitWith (ExitFailure 1)
183 Right (frameNumber, "") ->
184 pure frameNumber
185 Right {} -> do
186 let err = "Unexpected output"
187 hPutStrLn stderr (T.unpack frame)
188 hPutStrLn stderr $ "expectFrame: " ++ err
189 sendWebMessage conn $ WebError err
190 exitWith (ExitFailure 1)
191
192 watchFile :: WatchManager -> FilePath -> IO () -> IO StopListening
193 watchFile watch file action = watchTree watch (takeDirectory file) check (const action)
194 where
195 check event =
196 takeFileName (eventPath event) == takeFileName file ||
197 takeExtension (eventPath event) `elem` sourceExtensions ||
198 takeExtension (eventPath event) `elem` dataExtensions
199 sourceExtensions = [".hs", ".lhs"]
200 dataExtensions = [".jpg", ".png", ".bmp", ".pov", ".tex", ".csv"]
201
202 ghcOptions :: FilePath -> [String]
203 ghcOptions tmpDir =
204 ["-rtsopts", "--make", "-threaded", "-O2"] ++
205 ["-odir", tmpDir, "-hidir", tmpDir]
206
207 -- FIXME: Move to a different module
208 requireOwnSource :: IO FilePath
209 requireOwnSource = do
210 mbSelf <- findOwnSource
211 case mbSelf of
212 Nothing -> do
213 hPutStrLn stderr
214 "Rendering in browser window is only available when interpreting.\n\
215 \To render a video file, use the 'render' command or run again with --help\n\
216 \to see all available options."
217 exitFailure
218 Just self -> pure self
219
220 findOwnSource :: IO (Maybe FilePath)
221 findOwnSource = do
222 fullArgs <- getFullArgs
223 stackSource <- makeAbsolute (last fullArgs)
224 exist <- doesFileExist stackSource
225 if exist && isHaskellFile stackSource
226 then return (Just stackSource)
227 else do
228 prog <- getProgName
229 let hsProg
230 | isHaskellFile prog = prog
231 | otherwise = replaceExtension prog "hs"
232 lst <- listDirectory "."
233 findFile ("." : lst) hsProg
234
235 isHaskellFile :: FilePath -> Bool
236 isHaskellFile path = takeExtension path `elem` [".hs", ".lhs"]
237
238 logMsg :: String -> IO ()
239 logMsg msg = do
240 now <- getCurrentTime
241 putStrLn $ formatTime defaultTimeLocale fmt now ++ ": " ++ msg
242 where
243 fmt = "%F %T%2Q"
244
245 -------------------------------------------------------------------------------
246 -- Ghci interface
247
248 -- stack
249 -- cabal
250 -- raw
251 -- none?
252 data GhciBackend = GhciBackend (MVar Ghci)
253
254 ghciBackend :: Maybe FilePath -> FilePath -> IO GhciBackend
255 ghciBackend mbGHCPath self = do
256 let ghciProc =
257 case mbGHCPath of
258 Just ghcPath ->
259 proc ghcPath $ ["--interactive", "+RTS"] ++ words memoryLimit ++ ["-RTS"]
260 Nothing ->
261 proc "stack" ["exec", "ghci", "--rts-options="++memoryLimit]
262 (ghci, _loads) <- startGhciProcess ghciProc $ \_stream _msg -> return ()
263 void $ exec ghci $ ":load " ++ self
264 ref <- newMVar ghci
265 return $ GhciBackend ref
266
267 ghciReload :: GhciBackend -> IO ()
268 ghciReload (GhciBackend ref) =
269 withMVar ref $ \ghci ->
270 void $ reload ghci
271
272 ghciGenerate :: GhciBackend -> FilePath -> (Int -> IO ()) -> IO ()
273 ghciGenerate (GhciBackend ref) target cb = withMVar ref $ \ghci -> do
274 execStream ghci (":main raw --output=" ++ target ++ " --offset=1")
275 $ \_ msg ->
276 case reads msg of
277 [(frameIdx,"")] -> cb frameIdx
278 _ -> return ()
279
280 memoryLimit :: String
281 memoryLimit = "-M1G"
282
283 -------------------------------------------------------------------------------
284 -- Websocket API
285
286 data WebMessage
287 = WebStatus String
288 | WebError String
289 | WebFrameCount Int
290 | WebFrame Int FilePath
291
292 sendWebMessage :: Connection -> WebMessage -> IO ()
293 sendWebMessage conn msg = sendTextData conn $
294 case msg of
295 WebStatus txt -> T.pack "status\n" <> T.pack txt
296 WebError txt -> T.pack "error\n" <> T.pack txt
297 WebFrameCount n -> T.pack $ "frame_count\n" ++ show n
298 WebFrame n path -> T.pack $ "frame\n" ++ show n ++ "\n" ++ path