{-# LANGUAGE ScopedTypeVariables #-}
module Reanimate.Driver ( reanimate ) where
import Control.Concurrent (MVar, forkIO, forkOS, killThread,
modifyMVar_, newEmptyMVar,
putMVar, takeMVar)
import Control.Exception (SomeException, finally, handle)
import Control.Monad
import Control.Monad.Fix (fix)
import Data.Maybe
import qualified Data.Text as T
import qualified Data.Text.Read as T
import Data.Version
import GHC.Environment (getFullArgs)
import Network.WebSockets
import Paths_reanimate
import Reanimate.Misc (runCmdLazy, runCmd_)
import Reanimate.Monad (Animation)
import Reanimate.Render (render, renderSnippets,
renderSvgs)
import System.Directory (doesFileExist, findExecutable,
findFile, listDirectory, withCurrentDirectory)
import System.Environment (getArgs, getProgName)
import System.Exit
import System.FilePath
import System.FSNotify
import System.IO
import System.IO.Temp
import Text.ParserCombinators.ReadP
import qualified Text.PrettyPrint.ANSI.Leijen as Doc
import Text.Printf
import Web.Browser (openBrowser)
opts = defaultConnectionOptions
{ connectionCompressionOptions = PermessageDeflateCompression defaultPermessageDeflate }
reanimate :: Animation -> IO ()
reanimate animation = do
watch <- startManager
args <- getArgs
hSetBuffering stdin NoBuffering
case args of
["once"] -> renderSvgs animation
["snippets"] -> renderSnippets animation
["check"] -> checkEnvironment
["render", target] ->
render animation target
_ -> do
self <- findOwnSource
url <- getDataFileName "viewer/build/index.html"
putStrLn "Opening browser..."
bSucc <- openBrowser url
if bSucc
then putStrLn "Browser opened."
else hPutStrLn stderr $ "Failed to open browser. Manually visit: " ++ url
putStrLn "Listening..."
runServerWith "127.0.0.1" 9161 opts $ \pending -> do
putStrLn "New connection received."
conn <- acceptRequest pending
slave <- newEmptyMVar
let handler = modifyMVar_ slave $ \tid -> do
putStrLn "Reloading code..."
killThread tid
tid <- forkOS $ slaveHandler conn self
return tid
killSlave = do
tid <- takeMVar slave
killThread tid
stop <- watchFile watch self handler
putMVar slave =<< forkIO (return ())
let loop = do
fps <- receiveData conn :: IO T.Text
handler
loop
loop `finally` (stop >> killSlave)
slaveHandler conn self =
withCurrentDirectory (takeDirectory self) $
withSystemTempDirectory "reanimate" $ \tmpDir ->
withTempFile tmpDir "reanimate.exe" $ \tmpExecutable handle -> do
hClose handle
sendTextData conn (T.pack "Compiling")
ret <- runCmd_ "stack" $ ["ghc", "--"] ++ ghcOptions tmpDir ++ [takeFileName self, "-o", tmpExecutable]
case ret of
Left err ->
sendTextData conn $ T.pack $ "Error" ++ unlines (drop 3 (lines err))
Right{} -> do
getFrame <- runCmdLazy tmpExecutable ["once", "+RTS", "-N", "-M1G", "-RTS"]
(frameCount,_) <- expectFrame =<< getFrame
sendTextData conn (T.pack $ show frameCount)
fix $ \loop -> do
(frameIdx, frame) <- expectFrame =<< getFrame
sendTextData conn (T.pack $ show frameIdx)
sendTextData conn frame
loop
where
expectFrame (Left "") = do
sendTextData conn (T.pack "Done")
exitWith ExitSuccess
expectFrame (Left err) = do
sendTextData conn $ T.pack $ "Error" ++ err
exitWith (ExitFailure 1)
expectFrame (Right frame) =
case T.decimal frame of
Left err -> do
hPutStrLn stderr (T.unpack frame)
hPutStrLn stderr $ "expectFrame: " ++ err
sendTextData conn $ T.pack $ "Error" ++ err
exitWith (ExitFailure 1)
Right (frameNumber, rest) -> pure (frameNumber, rest)
watchFile watch file action = watchDir watch (takeDirectory file) check (const action)
where
check event = takeFileName (eventPath event) == takeFileName file
ghcOptions :: FilePath -> [String]
ghcOptions tmpDir =
["-rtsopts", "--make", "-threaded", "-O2"] ++
["-odir", tmpDir, "-hidir", tmpDir]
findOwnSource :: IO FilePath
findOwnSource = do
fullArgs <- getFullArgs
let stackSource = last fullArgs
exist <- doesFileExist stackSource
if exist
then return stackSource
else do
prog <- getProgName
lst <- listDirectory "."
mbSelf <- findFile ("." : lst) prog
case mbSelf of
Nothing -> do
hPutStrLn stderr "Failed to find own source code."
exitFailure
Just self -> pure self
checkEnvironment :: IO ()
checkEnvironment = do
putStrLn "reanimate checks:"
runCheck "Has ffmpeg" hasFFmpeg
runCheck "Has LaTeX" hasLaTeX
runCheck "Has XeLaTeX" hasXeLaTeX
runCheck "Has dvisvgm" hasDvisvgm
runCheck "Has povray" hasPovray
forM_ latexPackages $ \pkg ->
runCheck ("Has LaTeX package '"++ pkg ++ "'") $ hasTeXPackage "latex" $
"{"++pkg++"}"
forM_ xelatexPackages $ \pkg ->
runCheck ("Has XeLaTeX package '"++ pkg ++ "'") $ hasTeXPackage "xelatex" $
"{"++pkg++"}"
where
latexPackages =
["babel"
,"amsmath"
,"amssymb"
,"dsfont"
,"setspace"
,"relsize"
,"textcomp"
,"mathrsfs"
,"calligra"
,"wasysym"
,"ragged2e"
,"physics"
,"xcolor"
,"textcomp"
,"xfrac"
,"microtype"]
xelatexPackages =
["ctex"]
runCheck msg fn = do
printf " %-35s" (msg ++ ":")
val <- fn
case val of
Left err -> print $ Doc.red $ Doc.text err
Right ok -> print $ Doc.green $ Doc.text ok
hasLaTeX :: IO (Either String String)
hasLaTeX = hasProgram "latex"
hasXeLaTeX :: IO (Either String String)
hasXeLaTeX = hasProgram "xelatex"
hasDvisvgm :: IO (Either String String)
hasDvisvgm = hasProgram "dvisvgm"
hasPovray :: IO (Either String String)
hasPovray = hasProgram "povray"
hasFFmpeg :: IO (Either String String)
hasFFmpeg = do
mbVersion <- ffmpegVersion
return $ case mbVersion of
Nothing -> Left "no"
Just vs | vs < minVersion -> Left "too old"
| otherwise -> Right (showVersion vs)
where
minVersion = Version [4,1,3] []
ffmpegVersion :: IO (Maybe Version)
ffmpegVersion = do
mbPath <- findExecutable "ffmpeg"
case mbPath of
Nothing -> return Nothing
Just path -> do
ret <- runCmd_ path ["-version"]
case ret of
Left{} -> return Nothing
Right out ->
case map (take 3 . words) $ take 1 $ lines out of
[["ffmpeg", "version", vs]] ->
return $ parseVS vs
_ -> return Nothing
where
parseVS vs = listToMaybe
[ v | (v, "") <- readP_to_S parseVersion vs ]
hasTeXPackage :: FilePath -> String -> IO (Either String String)
hasTeXPackage exec pkg = handle (\(e::SomeException) -> return $ Left "n/a") $
withSystemTempDirectory "reanimate" $ \tmp_dir -> withTempFile tmp_dir "test.tex" $ \tex_file tex_handle -> do
hPutStr tex_handle tex_document
hPutStr tex_handle $ "\\usepackage" ++ pkg ++ "\n"
hPutStr tex_handle "\\begin{document}\n"
hPutStr tex_handle "blah\n"
hPutStr tex_handle tex_epilogue
hClose tex_handle
ret <- runCmd_ exec ["-interaction=batchmode", "-halt-on-error", "-output-directory="++tmp_dir, tex_file]
return $ case ret of
Right{} -> Right "OK"
Left{} -> Left "missing"
where
tex_document = "\\documentclass[preview]{standalone}\n"
tex_xelatex =
"\\usepackage[UTF8]{ctex}\n"
tex_prologue =
"\\usepackage[english]{babel}\n\
\\\usepackage{amsmath}\n\
\\\usepackage{amssymb}\n\
\\\usepackage{dsfont}\n\
\\\usepackage{setspace}\n\
\\\usepackage{relsize}\n\
\\\usepackage{textcomp}\n\
\\\usepackage{mathrsfs}\n\
\\\usepackage{calligra}\n\
\\\usepackage{wasysym}\n\
\\\usepackage{ragged2e}\n\
\\\usepackage{physics}\n\
\\\usepackage{xcolor}\n\
\\\usepackage{textcomp}\n\
\\\usepackage{xfrac}\n\
\\\usepackage{microtype}\n\
\\\linespread{1}\n\
\\\begin{document}\n"
tex_epilogue =
"\n\
\\\end{document}"
hasProgram :: String -> IO (Either String String)
hasProgram exec = do
mbPath <- findExecutable exec
return $ case mbPath of
Nothing -> Left $ "'" ++ exec ++ "'' not found"
Just path -> Right path