diff --git a/.azure/azure-linux-template.yml b/.azure/azure-linux-template.yml index a343c5a..76a9748 100644 --- a/.azure/azure-linux-template.yml +++ b/.azure/azure-linux-template.yml @@ -17,9 +17,6 @@ jobs: stack-lts-14: BUILD: stack STACK_YAML: stack-lts-14.yaml - stack-lts-13: - BUILD: stack - STACK_YAML: stack-lts-13.yaml stack-nightly: BUILD: stack ARGS: --resolver nightly --no-run-tests diff --git a/.azure/azure-osx-template.yml b/.azure/azure-osx-template.yml index 0484a91..14d5ef6 100644 --- a/.azure/azure-osx-template.yml +++ b/.azure/azure-osx-template.yml @@ -17,9 +17,6 @@ jobs: stack-lts-14: BUILD: stack STACK_YAML: stack-lts-14.yaml - stack-lts-13: - BUILD: stack - STACK_YAML: stack-lts-13.yaml maxParallel: 6 steps: - task: Cache@2 diff --git a/.azure/azure-windows-template.yml b/.azure/azure-windows-template.yml index f4429e2..eca3764 100644 --- a/.azure/azure-windows-template.yml +++ b/.azure/azure-windows-template.yml @@ -20,10 +20,6 @@ jobs: BUILD: stack STACK_YAML: stack-lts-14.yaml ARGS: --no-run-tests - stack-lts-13: - BUILD: stack - STACK_YAML: stack-lts-13.yaml - ARGS: --no-run-tests maxParallel: 6 steps: - task: Cache@2 diff --git a/reanimate.cabal b/reanimate.cabal index 75c04d2..90bd567 100644 --- a/reanimate.cabal +++ b/reanimate.cabal @@ -39,6 +39,11 @@ Source-Repository head library hs-source-dirs: src + if os(windows) + hs-source-dirs: windows + else + hs-source-dirs: unix + build-depends: unix default-language: Haskell2010 default-extensions: PackageImports, PatternSynonyms exposed-modules: Reanimate @@ -91,13 +96,14 @@ library Reanimate.Driver.CLI Reanimate.Driver.Magick Reanimate.Driver.Server - Reanimate.Driver.Compile + Reanimate.Driver.Daemon Reanimate.Misc Paths_reanimate Reanimate.Scene.Core Reanimate.Scene.Var Reanimate.Scene.Sprite Reanimate.Scene.Object + Detach autogen-modules: Paths_reanimate build-depends: base >=4.10 && <5, @@ -119,7 +125,6 @@ library fingertree >=0.1.0.0, fsnotify >=0.3.0.1, geojson >=3.0.4, - ghcid >=0.7, hashable >=1.3.0.0, hgeometry >=0.11.0.0, hgeometry-combinatorial >=0.11.0.0, @@ -145,9 +150,11 @@ library websockets >=0.12.7.0, xml >=1.3.14, cryptohash-sha256, - base64-bytestring + base64-bytestring, + network >=3.1.0.0 ghc-options: -Wall -fno-ignore-asserts + test-suite spec type: exitcode-stdio-1.0 main-is: Spec.hs diff --git a/src/Reanimate.hs b/src/Reanimate.hs index 28de64b..ee8dfd2 100644 --- a/src/Reanimate.hs +++ b/src/Reanimate.hs @@ -35,6 +35,7 @@ no other parameters are given. Key features: -} module Reanimate ( reanimate, + reanimateLive, -- * Animations SVG, Time, @@ -196,6 +197,7 @@ import Reanimate.Blender import Reanimate.ColorMap import Reanimate.Constants import Reanimate.Driver +import Reanimate.Driver.Daemon import Reanimate.LaTeX import Reanimate.Parameters import Reanimate.Povray diff --git a/src/Reanimate/Driver.hs b/src/Reanimate/Driver.hs index a25e793..36fd2a5 100644 --- a/src/Reanimate/Driver.hs +++ b/src/Reanimate/Driver.hs @@ -5,16 +5,16 @@ module Reanimate.Driver where import Control.Applicative ((<|>)) +import Control.Concurrent import Control.Monad -import Data.Maybe import Data.Either -import Reanimate.Animation (Animation) -import Reanimate.Driver.Check +import Data.Maybe +import Reanimate.Animation (Animation, duration) import Reanimate.Driver.CLI -import Reanimate.Driver.Compile -import Reanimate.Driver.Server +import Reanimate.Driver.Check +import Reanimate.Driver.Daemon import Reanimate.Parameters -import Reanimate.Render (render, renderSnippets, renderSvgs, +import Reanimate.Render (render, renderSnippets, renderSvgs, renderSvgs_, selectRaster) import System.Directory import System.Exit @@ -116,7 +116,7 @@ reanimate animation = do -- hSetBinaryMode stdout True renderSnippets animation Check -> checkEnvironment - View {..} -> serve viewVerbose viewGHCPath viewGHCOpts viewOrigin + View {..} -> viewAnimation viewDetach animation Render {..} -> do let fmt = guessParameter renderFormat (fmap presetFormat renderPreset) @@ -132,7 +132,7 @@ reanimate animation = do target <- case renderTarget of Nothing -> do - mbSelf <- findOwnSource + mbSelf <- pure Nothing let ext = formatExtension fmt self = fromMaybe "output" mbSelf pure $ replaceExtension self ext @@ -161,47 +161,26 @@ reanimate animation = do exitWith (ExitFailure 1) return raster else selectRaster renderRaster + setRaster raster + setFPS fps + setWidth width + setHeight height + printf + "Animation options:\n\ + \ fps: %d\n\ + \ width: %d\n\ + \ height: %d\n\ + \ fmt: %s\n\ + \ target: %s\n\ + \ raster: %s\n" + fps + width + height + (showFormat fmt) + target + (show raster) - if renderCompile - then compile $ - [ "render" - , "--fps" - , show fps - , "--width" - , show width - , "--height" - , show height - , "--format" - , showFormat fmt - , "--raster" - , showRaster raster - , "--target" - , target - , "+RTS" - , "-N" - , "-RTS" - ] ++ [ "--partial" | renderPartial ] - else do - setRaster raster - setFPS fps - setWidth width - setHeight height - printf - "Animation options:\n\ - \ fps: %d\n\ - \ width: %d\n\ - \ height: %d\n\ - \ fmt: %s\n\ - \ target: %s\n\ - \ raster: %s\n" - fps - width - height - (showFormat fmt) - target - (show raster) - - render animation target raster fmt width height fps renderPartial + render animation target raster fmt width height fps renderPartial guessParameter :: Maybe a -> Maybe a -> a -> a guessParameter a b def = fromMaybe def (a <|> b) @@ -220,3 +199,20 @@ userPreferredDimensions Nothing Nothing = Nothing makeEven :: Int -> Int makeEven x | even x = x | otherwise = x - 1 + + +-- serve viewVerbose viewGHCPath viewGHCOpts viewOrigin +viewAnimation :: Bool -> Animation -> IO () +viewAnimation _detach animation = do + detached <- ensureDaemon + + let rate = 60 + count = round (duration animation * rate) :: Int + sendCommand $ DaemonCount count + renderSvgs_ animation $ \nth path -> do + sendCommand $ DaemonFrame nth path + + unless detached $ do + putStrLn "Daemon mode. Hit ctrl-c to terminate." + forever $ threadDelay (10^(6::Int)) + diff --git a/src/Reanimate/Driver/CLI.hs b/src/Reanimate/Driver/CLI.hs index 4a5b16a..f8976ec 100644 --- a/src/Reanimate/Driver/CLI.hs +++ b/src/Reanimate/Driver/CLI.hs @@ -27,10 +27,7 @@ data Command | Test | Check | View - { viewVerbose :: Bool - , viewGHCPath :: Maybe FilePath - , viewGHCOpts :: [String] - , viewOrigin :: Maybe FilePath + { viewDetach :: Bool } | Render { renderTarget :: Maybe String @@ -154,16 +151,7 @@ viewCommand = info parse where parse = View <$> switch - (long "verbose" <> short 'v') - <*> optional (strOption (long "ghc" - <> metavar "PATH" - <> help "Path to GHC binary")) - <*> many (strOption (long "ghc-opt" - <> short 'G' - <> help "Additional option to pass to ghc")) - <*> optional (strOption (long "self" - <> metavar "PATH" - <> help "Source file used for live-reloading")) + (long "detach" <> short 'd') renderCommand :: ParserInfo Command renderCommand = info parse diff --git a/src/Reanimate/Driver/Compile.hs b/src/Reanimate/Driver/Compile.hs deleted file mode 100644 index 272766d..0000000 --- a/src/Reanimate/Driver/Compile.hs +++ /dev/null @@ -1,35 +0,0 @@ -module Reanimate.Driver.Compile ( compile ) where - -import Reanimate.Driver.Server (findOwnSource) -import System.Directory -import System.Exit -import System.FilePath -import System.Process -import System.IO - -compile :: [String] -> IO () -compile opts = do - mbSelf <- findOwnSource - case mbSelf of - Nothing -> do - hPutStrLn stderr - "Failed to find source code. Did you already compile the animations?\n\ - \Try running again without the --compile flag." - exitFailure - Just self -> do - let selfDir = takeDirectory self - selfName = takeBaseName self - outDir = selfDir ".reanimate" selfName - target = outDir selfName - ghcOptions = - ["-rtsopts", "--make", "-threaded", "-O2"] ++ - ["-odir", outDir, "-hidir", outDir] ++ - [self, "-o", target] - createDirectoryIfMissing True outDir - withCurrentDirectory selfDir $ do - checkExitCode =<< rawSystem "stack" (["ghc", "--"] ++ ghcOptions) - checkExitCode =<< rawSystem target opts - -checkExitCode :: ExitCode -> IO () -checkExitCode ExitSuccess = return () -checkExitCode (ExitFailure n) = exitWith (ExitFailure n) diff --git a/src/Reanimate/Driver/Daemon.hs b/src/Reanimate/Driver/Daemon.hs new file mode 100644 index 0000000..c876273 --- /dev/null +++ b/src/Reanimate/Driver/Daemon.hs @@ -0,0 +1,154 @@ +module Reanimate.Driver.Daemon where + +import Control.Concurrent +import Control.Exception as E +import Control.Monad +import qualified Data.ByteString.Char8 as BS +import Network.Socket +import Network.Socket.ByteString +import qualified Reanimate.Driver.Server as Server +import System.FSNotify +import System.FilePath +import System.Environment + +import Detach + +{- +Main run message: + + Reanimate has gone into daemon mode and will block until you hit + ctrl-c. While Reanimate is in daemon mode, you can open a new + console or terminal and execute your animation code again. It'll + automatically send the new animation to the browser window. + + Linux users can pass --daemon to reanimate to run the process in + the background. Windows users have to use PowerShell and explicitly + fork the process: + Start-Process -NoNewWindow ./reanimate_exe + + Connection to the browser window will be lost if you hit ctrl-c. + + +Executing with daemon: + Send animation to daemon and exit. +Executing without daemon: + Run daemon locally. + Render animation once. + Wait without exiting. + Detach if given --daemon flag. Only for Linux. + +Executing on Linux: + Running 'main' will start the daemon if it isn't already running. + Then it'll render the animation and send it to the daemon. + The daemon will open a browser window. + Daemon stops after 30 minutes of inactivity. + +Executing on Windows: + 'main' will act as daemon and not return. + Powershell command for running in the background: + Start-Process -NoNewWindow ./reanimate_exe + + Subsequent runs will send animation to daemon and quit. + +In GHCi: + Start local daemon thread if necessary. + :cmd reanimateLive + 1. wait for changes + 2. ":r" + 3. ":main" + 4. ":cmd Reanimate.reanimateLive" + + + +Web port: 9161 +Daemon port: 9162? + +-} + +{- + Improvements over previous infrastructure: + - Multiple browser windows can be open. + - Browser window won't get stuck trying to open a connection. + - GHCi is robust and works with both cabal and stack. + - Refreshing the code will re-open closed browser windows. +-} + +reanimateLive :: IO String +reanimateLive = do + void ensureDaemon + args <- getArgs + case args of + ["primed"] -> waitForChanges + _ -> return () + return $ unlines + [ ":r" + , ":main" + , ":cmd System.Environment.withArgs [\"primed\"] Reanimate.reanimateLive" ] + +waitForChanges :: IO () +waitForChanges = withManager $ \mgr -> do + lock <- newEmptyMVar + stop <- watchTree mgr "." check (const $ putMVar lock ()) + takeMVar lock + stop + where + check event = + takeExtension (eventPath event) `elem` sourceExtensions || + takeExtension (eventPath event) `elem` dataExtensions + sourceExtensions = [".hs", ".lhs"] + dataExtensions = [".jpg", ".png", ".bmp", ".pov", ".tex", ".csv"] + + +data DaemonCommand + = DaemonCount Int + | DaemonFrame Int FilePath + | DaemonStop + deriving (Show) + +sendCommand :: DaemonCommand -> IO () +sendCommand cmd = withSocketsDo $ handle (\SomeException{} -> return ()) $ do + addr <- resolve + E.bracket (open addr) close $ \sock -> do + void $ send sock $ case cmd of + DaemonCount count -> BS.pack $ unwords ["frame_count", show count] + DaemonFrame nth path -> BS.pack $ unwords ["frame", show nth, path] + DaemonStop -> BS.pack $ unwords ["stop"] + return () + where + resolve = do + let hints = defaultHints { addrSocketType = Stream } + head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "9162") + open addr = E.bracketOnError (oSocket addr) close $ \sock -> do + connect sock $ addrAddress addr + return sock + +hasDaemon :: IO Bool +hasDaemon = withSocketsDo $ handle (\SomeException{} -> return False) $ do + addr <- resolve + E.bracket (open addr) close (const $ return True) + where + resolve = do + let hints = defaultHints { addrSocketType = Stream } + head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "9162") + open addr = E.bracketOnError (oSocket addr) close $ \sock -> do + connect sock $ addrAddress addr + return sock + +oSocket :: AddrInfo -> IO Socket +oSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + +ensureDaemon :: IO Bool +ensureDaemon = do + daemon <- hasDaemon + if daemon + then pure True + else localDaemon + +killDaemon :: IO () +killDaemon = sendCommand DaemonStop + +localDaemon :: IO Bool +localDaemon = do + killDaemon + detach Server.daemon + diff --git a/src/Reanimate/Driver/Server.hs b/src/Reanimate/Driver/Server.hs index 9f97d96..acd0727 100644 --- a/src/Reanimate/Driver/Server.hs +++ b/src/Reanimate/Driver/Server.hs @@ -1,286 +1,146 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} module Reanimate.Driver.Server - ( serve - , findOwnSource + ( daemon ) where import Control.Concurrent -import Control.Exception (SomeException, catch, finally) -import Control.Monad -import Data.IORef -import Data.Text (Text) -import qualified Data.Text as T -import qualified Data.Text.Read as T -import Data.Time -import GHC.Environment (getFullArgs) -import Language.Haskell.Ghcid +import Control.Exception (finally) +import qualified Control.Exception as E +import Control.Monad (forM_, forever, unless, void, when) +import qualified Data.ByteString.Char8 as BS +import qualified Data.Foldable as F +import qualified Data.Map as Map +import qualified Data.Text as T +import Network.Socket (AddrInfo (..), AddrInfoFlag (..), SocketOption (..), + SocketType (Stream), accept, bind, close, defaultHints, + getAddrInfo, gracefulClose, listen, socket, + setCloseOnExecIfNeeded, setSocketOption, withFdSocket, + withSocketsDo) +import Network.Socket.ByteString (recv) import Network.WebSockets -import Paths_reanimate -import Reanimate.Misc (runCmdLazy, runCmd_) -import System.Directory (createDirectoryIfMissing, - doesFileExist, findFile, listDirectory, - makeAbsolute, - withCurrentDirectory) -import System.Environment (getProgName) -import System.Exit -import System.FilePath -import System.FSNotify -import System.IO -import System.IO.Temp -import System.Process -import Web.Browser (openBrowser) +import Paths_reanimate (getDataFileName) +import System.IO (hPutStrLn, stderr) +import Web.Browser (openBrowser) opts :: ConnectionOptions opts = defaultConnectionOptions { connectionCompressionOptions = PermessageDeflateCompression defaultPermessageDeflate } -serve :: Bool -> Maybe FilePath -> [String] -> Maybe FilePath -> IO () -serve verbose mbGHCPath extraGHCOpts mbSelfPath = withManager $ \watch -> do - hSetBuffering stdin NoBuffering - self <- maybe requireOwnSource pure mbSelfPath - when verbose $ - logMsg $ "Found own source code at: " ++ self - hasConnectionVar <- newMVar False - ghci <- ghciBackend mbGHCPath self - -- There might already browser window open. Wait 2s to see if that window - -- connects to us. If not, open a new window. - _ <- forkIO $ do - threadDelay (2*10^(6::Int)) - hasConn <- readMVar hasConnectionVar - unless hasConn openViewer - logMsg "Listening..." +daemon :: IO () +daemon = do + state <- newMVar (0, Map.empty) + connsRef <- newMVar Map.empty + + self <- myThreadId + + dTid <- daemonReceive self $ \msg -> + case msg of + WebStatus _status -> return () + WebError _err -> return () + WebFrameCount count -> do + void $ swapMVar state (count, Map.empty) + conns <- readMVar connsRef + F.forM_ conns $ \(conn) -> do + sendWebMessage conn (WebFrameCount count) + when (Map.null conns) openViewer + WebFrame nth path -> do + modifyMVar_ state $ \(count, frames) -> + pure (count, Map.insert nth path frames) + conns <- readMVar connsRef + F.forM_ conns $ \conn -> do + sendWebMessage conn (WebFrame nth path) + + openViewer + let options = ServerOptions { serverHost = "127.0.0.1" , serverPort = 9161 , serverConnectionOptions = opts , serverRequirePong = Nothing } - withSystemTempDirectory "reanimate-svgs" $ \tmpDir -> - runServerWithOptions options $ \pending -> do - logMsg "New connection received." - hasConn <- swapMVar hasConnectionVar True - if hasConn - then do - logMsg "Already connected to browser. Rejecting." - rejectRequestWith pending defaultRejectRequest - else do - createDirectoryIfMissing True tmpDir - conn <- acceptRequest pending - slave <- newEmptyMVar - let handler = modifyMVar_ slave $ \tid -> do - logMsg "Reloading code..." - killThread tid - forkIO $ ignoreErrors $ slaveHandler verbose mbGHCPath extraGHCOpts conn ghci self tmpDir - killSlave = do - tid <- takeMVar slave - killThread tid - stop <- watchFile watch self handler - putMVar slave =<< forkIO (return ()) - handler - let loop = do - -- FIXME: We don't use msg here. - _msg <- receiveData conn :: IO T.Text - handler - loop - cleanup = do - stop - killSlave - _ <- swapMVar hasConnectionVar False - return () - loop `finally` cleanup -ignoreErrors :: IO () -> IO () -ignoreErrors action = action `catch` \(_::SomeException) -> return () + logMsg "WS server is running." + + + runServerWithOptions options (\pending -> do + tid <- myThreadId + + conn <- acceptRequest pending + + modifyMVar_ connsRef $ pure . Map.insert tid conn + + conns <- readMVar connsRef + logMsg $ "Browser connections: " ++ show (Map.size conns) + + (count, frames) <- readMVar state + when (count > 0) $ do + sendWebMessage conn (WebFrameCount count) + forM_ (Map.toList frames) $ \(nth, path) -> + sendWebMessage conn (WebFrame nth path) + + let loop = do + -- FIXME: We don't use msg here. + _msg <- receiveData conn :: IO T.Text + loop + cleanup = do + modifyMVar_ connsRef $ pure . Map.delete tid + nConns <- Map.size <$> readMVar connsRef + logMsg $ "Browser connections: " ++ show nConns + when (nConns == 0) $ do + threadDelay (second * 5) + nConns' <- Map.size <$> readMVar connsRef + logMsg $ "Browser connections (check): " ++ show nConns' + when (nConns'==0) $ killThread self + loop `finally` cleanup) + `finally` (killThread dTid >> logMsg "daemon server quit") + `E.catch` (\e@E.SomeException{} -> logMsg $ "Exception: " ++ show e) + +second :: Int +second = 10^(6::Int) + +logMsg :: String -> IO () +logMsg msg = appendFile "log" (msg++"\n") + +daemonReceive :: ThreadId -> (WebMessage -> IO ()) -> IO ThreadId +daemonReceive parent cb = withSocketsDo $ do + addr <- resolve + sock <- open addr + logMsg "daemon sock is open" + forkIO $ handler sock `finally` close sock + where + handler sock = forever $ E.bracketOnError (accept sock) (close . fst) $ \(conn, _peer) -> do + inp <- BS.unpack <$> recv conn 4096 + case words inp of + ["frame_count", n] -> cb $ WebFrameCount (read n) + ["frame", nth, path] -> cb $ WebFrame (read nth) path + ["stop"] -> do + logMsg "Received STOP" + killThread parent + [] -> return () + _ -> error $ "Bad message: " ++ inp + gracefulClose conn 5000 + resolve = do + let hints = defaultHints { + addrFlags = [AI_PASSIVE] + , addrSocketType = Stream + } + head <$> getAddrInfo (Just hints) (Just "127.0.0.1") (Just "9162") + oSocket addr = socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr) + open addr = E.bracketOnError (oSocket addr) close $ \sock -> do + setSocketOption sock ReuseAddr 1 + withFdSocket sock setCloseOnExecIfNeeded + bind sock $ addrAddress addr + listen sock 1024 + return sock openViewer :: IO () openViewer = do url <- getDataFileName "viewer-elm/dist/index.html" - logMsg "Opening browser..." bSucc <- openBrowser url - if bSucc - then logMsg "Browser opened." - else hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url - -slaveHandler :: Bool -> Maybe FilePath -> [String] -> Connection -> GhciBackend - -> FilePath -> FilePath -> IO () -slaveHandler verbose mbGHCPath extraGHCOpts conn ghci self svgDir = - withCurrentDirectory (takeDirectory self) $ - withSystemTempDirectory "reanimate" $ \tmpDir -> - withTempFile tmpDir "reanimate.exe" $ \tmpExecutable handle -> do - outputFolder <- createTempDirectory svgDir "svgs" - let frameFileName frameIdx = - outputFolder show frameIdx <.> "svg" - - sentFrameCount <- newMVar False - hClose handle - lock <- newMVar () - sendWebMessage conn $ WebStatus "Compiling" - ghciThread <- forkIO $ do - firstFrame <- newIORef True - ghciReload ghci - logMsg "GHCi reload done." - ghciGenerate ghci outputFolder $ \frameIdx -> do - first <- readIORef firstFrame - writeIORef firstFrame False - if first - then - modifyMVar_ sentFrameCount $ \sent -> do - unless sent $ - sendWebMessage conn $ WebFrameCount frameIdx - logMsg "Framecount sent." - return True - else - withMVar lock $ \_ -> - sendWebMessage conn $ WebFrame frameIdx (frameFileName frameIdx) - logMsg "GHCi render done." - ret <- case mbGHCPath of - Nothing -> do - let args = ["ghc", "--"] ++ ghcOptions tmpDir ++ extraGHCOpts ++ [takeFileName self, "-o", tmpExecutable] - when verbose $ - logMsg $ "Running: " ++ showCommandForUser "stack" args - runCmd_ "stack" args - Just ghc -> do - let args = ghcOptions tmpDir ++ extraGHCOpts ++ [takeFileName self, "-o", tmpExecutable] - when verbose $ - logMsg $ "Running: " ++ showCommandForUser ghc args - runCmd_ ghc args - logMsg "Compile done." - case ret of - Left err -> - sendWebMessage conn $ WebError $ unlines (lines err) - Right{} -> runCmdLazy tmpExecutable (execOpts outputFolder) $ \getFrame -> do - frameCount <- expectFrame =<< getFrame - modifyMVar_ sentFrameCount $ \sent -> do - unless sent $ - sendWebMessage conn $ WebFrameCount frameCount - return True - replicateM_ frameCount $ do - frameIdx <- expectFrame =<< getFrame - withMVar lock $ \_ -> - sendWebMessage conn $ WebFrame frameIdx (frameFileName frameIdx) - logMsg "Optimized render done." - killThread ghciThread - where - execOpts output = - [ "raw", "--output", output, "--offset", "1" - , "+RTS", "-N", "-M2G", "-RTS"] - expectFrame :: Either String Text -> IO Int - expectFrame (Left "") = do - sendWebMessage conn $ WebStatus "Done" - exitSuccess - expectFrame (Left err) = do - sendWebMessage conn $ WebError err - exitWith (ExitFailure 1) - expectFrame (Right frame) = - case T.decimal frame of - Left err -> do - hPutStrLn stderr (T.unpack frame) - raiseError conn err - Right (frameNumber, "") -> - pure frameNumber - Right {} -> do - let err = "Unexpected output" - hPutStrLn stderr (T.unpack frame) - raiseError conn err - -raiseError :: Connection -> String -> IO a -raiseError conn err = do - hPutStrLn stderr $ "expectFrame: " ++ err - sendWebMessage conn $ WebError err - exitWith (ExitFailure 1) - -watchFile :: WatchManager -> FilePath -> IO () -> IO StopListening -watchFile watch file action = watchTree watch (takeDirectory file) check (const action) - where - check event = - takeFileName (eventPath event) == takeFileName file || - takeExtension (eventPath event) `elem` sourceExtensions || - takeExtension (eventPath event) `elem` dataExtensions - sourceExtensions = [".hs", ".lhs"] - dataExtensions = [".jpg", ".png", ".bmp", ".pov", ".tex", ".csv"] - -ghcOptions :: FilePath -> [String] -ghcOptions tmpDir = - ["-rtsopts", "--make", "-threaded", "-O2"] ++ - ["-odir", tmpDir, "-hidir", tmpDir] - --- FIXME: Move to a different module -requireOwnSource :: IO FilePath -requireOwnSource = do - mbSelf <- findOwnSource - case mbSelf of - Nothing -> do - hPutStrLn stderr - "Rendering in browser window is only available when interpreting.\n\ - \To render a video file, use the 'render' command or run again with --help\n\ - \to see all available options." - exitFailure - Just self -> pure self - -findOwnSource :: IO (Maybe FilePath) -findOwnSource = do - fullArgs <- getFullArgs - stackSource <- makeAbsolute (last fullArgs) - exist <- doesFileExist stackSource - if exist && isHaskellFile stackSource - then return (Just stackSource) - else do - prog <- getProgName - let hsProg - | isHaskellFile prog = prog - | otherwise = replaceExtension prog "hs" - lst <- listDirectory "." - findFile ("." : lst) hsProg - -isHaskellFile :: FilePath -> Bool -isHaskellFile path = takeExtension path `elem` [".hs", ".lhs"] - -logMsg :: String -> IO () -logMsg msg = do - now <- getCurrentTime - putStrLn $ formatTime defaultTimeLocale fmt now ++ ": " ++ msg - where - fmt = "%F %T%2Q" - -------------------------------------------------------------------------------- --- Ghci interface - --- stack --- cabal --- raw --- none? -newtype GhciBackend = GhciBackend (MVar Ghci) - -ghciBackend :: Maybe FilePath -> FilePath -> IO GhciBackend -ghciBackend mbGHCPath self = do - let ghciProc = - case mbGHCPath of - Just ghcPath -> - proc ghcPath $ ["--interactive", "+RTS"] ++ words memoryLimit ++ ["-RTS"] - Nothing -> - proc "stack" ["exec", "ghci", "--rts-options="++memoryLimit] - (ghci, _loads) <- startGhciProcess ghciProc $ \_stream _msg -> return () - void $ exec ghci $ ":load " ++ self - ref <- newMVar ghci - return $ GhciBackend ref - -ghciReload :: GhciBackend -> IO () -ghciReload (GhciBackend ref) = - withMVar ref $ \ghci -> - void $ reload ghci - -ghciGenerate :: GhciBackend -> FilePath -> (Int -> IO ()) -> IO () -ghciGenerate (GhciBackend ref) target cb = withMVar ref $ \ghci -> - execStream ghci (":main raw --output=" ++ target ++ " --offset=1") - $ \_ msg -> - case reads msg of - [(frameIdx,"")] -> cb frameIdx - _ -> return () - -memoryLimit :: String -memoryLimit = "-M1G" + unless bSucc $ + hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url ------------------------------------------------------------------------------- -- Websocket API diff --git a/src/Reanimate/Render.hs b/src/Reanimate/Render.hs index bfb0629..ce62cd9 100644 --- a/src/Reanimate/Render.hs +++ b/src/Reanimate/Render.hs @@ -13,6 +13,7 @@ to ever directly use the functions in this module. module Reanimate.Render ( render , renderSvgs + , renderSvgs_ , renderSnippets -- :: Animation -> IO () , renderLimitedFrames , Format(..) @@ -44,6 +45,7 @@ import System.Exit (ExitCode (ExitFailure), exitWith) import System.FileLock (SharedExclusive (..), unlockFile, withTryFileLock) import System.FilePath (replaceExtension, (<.>), ()) import System.IO +import System.IO.Temp (createTempDirectory, getCanonicalTemporaryDirectory) import Text.Printf (printf) idempotentFile :: FilePath -> IO () -> IO () @@ -82,6 +84,28 @@ renderSvgs folder offset _prettyPrint ani = do hPutStrLn stderr msg exitWith (ExitFailure 1) +renderSvgs_ :: Animation -> (Int -> FilePath -> IO ()) -> IO () +renderSvgs_ ani cb = do + tmp <- getCanonicalTemporaryDirectory + tmpDir <- createTempDirectory tmp "reanimate" + lock <- newMVar () + handle errHandler $ concurrentForM_ (frameOrder rate frameCount) $ \nth' -> do + let nth = (nth') `mod` frameCount + now = (duration ani / (fromIntegral frameCount - 1)) * fromIntegral nth + frame = frameAt (if frameCount <= 1 then 0 else now) ani + path = tmpDir show nth <.> "svg" + svg = renderSvg Nothing Nothing frame + + idempotentFile path $ + writeFile path svg + withMVar lock $ \_ -> cb nth path + where + rate = 60 + frameCount = round (duration ani * fromIntegral rate) :: Int + errHandler (ErrorCall msg) = do + hPutStrLn stderr msg + exitWith (ExitFailure 1) + -- | Render as many frames as possible in 2 seconds. Limited to 20 frames. renderLimitedFrames :: FilePath -> Int -> Bool -> Int -> Animation -> IO () renderLimitedFrames folder offset _prettyPrint rate ani = do diff --git a/stack-lts-13.yaml b/stack-lts-13.yaml deleted file mode 100644 index 695e158..0000000 --- a/stack-lts-13.yaml +++ /dev/null @@ -1,23 +0,0 @@ -resolver: lts-13.19 - -allow-newer: true - -packages: -- . - -extra-deps: -- reanimate-svg-0.13.0.0 -- chiphunk-0.1.2.1 -- cubicbezier-0.6.0.6@sha256:2191ff47144d9a13a2784651a33d340cd31be1926a6c188925143103eb3c8db3 -- fast-math-1.0.2@sha256:91181eb836e54413cc5a841e797c42b2264954e893ea530b6fc4da0dccf6a8b7 -- matrices-0.5.0@sha256:b2761813f6a61c84224559619cc60a16a858ac671c8436bbac8ec89e85473058 -- hmatrix-0.20.0.0@sha256:d79a9218e314f1a2344457c3851bd1d2536518ecb5f1a2fcd81daa45e46cd025,4870 -- websockets-0.12.7.0@sha256:fc96169cc8268d3efb93bdc1e0b060dd88ce932237b837904118777a90d6db80,7863 -- clock-0.8@sha256:b4ae207e2d3761450060a0d0feb873269233898039c76fceef9cc1a544067767,4113 -- earcut-0.1.0.4@sha256:d5118b3eecf24d130263d81fb30f1ff56b1db43036582bfd1d8cc9ba3adae8be,1010 -- tasty-rerun-1.1.17@sha256:d4a3ccb0f63f499f36edc71b33c0f91c850eddb22dd92b928aa33b8459f3734a,1373 -- hgeometry-0.11.0.0@sha256:09ead201a6ac3492c0be8dda5a6b32792b9ae87cab730b8362d46ee8d5c2acb4,11714 -- hgeometry-combinatorial-0.11.0.0@sha256:03176f235a1c49a415fe1266274dafca84deb917cbcbf9a654452686b4cd2bfe,8286 -- vinyl-0.13.0@sha256:0f247cd3f8682b30881a07de18e6fec52d540646fbcb328420049cc8d63cd407,3724 -- data-clist-0.1.2.3@sha256:1e26251c8921821c8a1c7e168955449822f1bacf03d056cc59c84fd2863a0f8e,983 -- hashable-1.3.0.0@sha256:4c70f1407881059e93550d3742191254296b2737b793a742bd901348fb3e1fb1,5206 diff --git a/stack-lts-14.yaml b/stack-lts-14.yaml index 2b39b0a..ac962ee 100644 --- a/stack-lts-14.yaml +++ b/stack-lts-14.yaml @@ -18,3 +18,4 @@ extra-deps: - hgeometry-combinatorial-0.11.0.0@sha256:03176f235a1c49a415fe1266274dafca84deb917cbcbf9a654452686b4cd2bfe,8286 - vinyl-0.13.0@sha256:0f247cd3f8682b30881a07de18e6fec52d540646fbcb328420049cc8d63cd407,3724 - hashable-1.3.0.0@sha256:4c70f1407881059e93550d3742191254296b2737b793a742bd901348fb3e1fb1,5206 +- network-3.1.2.1@sha256:188d6daea8cd91bc3553efd5a90a1e7c6d0425fa66a53baa74db5b6d9fd75c8b,4968 diff --git a/stack.yaml b/stack.yaml index addd26d..6056cb6 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,4 +1,4 @@ -resolver: lts-16.12 +resolver: lts-16.27 allow-newer: false diff --git a/unix/Detach.hs b/unix/Detach.hs new file mode 100644 index 0000000..c38ba8f --- /dev/null +++ b/unix/Detach.hs @@ -0,0 +1,19 @@ +module Detach (detach) where + +import Control.Concurrent +import Control.Monad +import System.Posix.IO +import System.Posix.Process (createSession, forkProcess) + +detach :: IO () -> IO Bool +detach daemon = do + void $ forkProcess $ do + devnull <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags + void $ dupTo devnull stdInput + void $ dupTo devnull stdOutput + void $ dupTo devnull stdError + closeFd devnull + void createSession + void $ forkProcess daemon + threadDelay (10^(6::Int)) + return True diff --git a/windows/Detach.hs b/windows/Detach.hs new file mode 100644 index 0000000..90b3a10 --- /dev/null +++ b/windows/Detach.hs @@ -0,0 +1,10 @@ +module Detach (detach) where + +import Control.Monad +import Control.Concurrent + +detach :: IO () -> IO Bool +detach action = do + void $ forkIO action + threadDelay (10^(6::Int)) + return False