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.
-}

-- | Load a reanimate program in GHCi and make sure 'main' is available.
--   Then run:
-- @
-- :cmd reanimateLive
-- @
--
-- This works by sending the commands ':r' and ':main' to your GHCi instance
-- when any source file is changed.
reanimateLive :: IO String
reanimateLive :: IO String
reanimateLive = do
  IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO Bool
ensureDaemon
  [String]
args <- IO [String]
getArgs
  case [String]
args of
    [String
"primed"] -> IO ()
waitForChanges
    [String]
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
        [ String
":r"
        , String
":main"
        , String
":cmd System.Environment.withArgs [\"primed\"] Reanimate.reanimateLive" ]

-- | Load an animation in GHCi. Anything of type 'Animation' can be live reloaded.
--
-- @
-- :cmd reanimateLiveEntry "drawCircle"
-- @
--
-- This works by sending the commands ':r' and 'Reanimate.reanimate {entry}' to your
-- GHCi instance when any source file is changed.
reanimateLiveEntry :: String -> IO String
reanimateLiveEntry :: String -> IO String
reanimateLiveEntry String
animation = do
  IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO Bool
ensureDaemon
  [String]
args <- IO [String]
getArgs
  case [String]
args of
    [String
"primed"] -> IO ()
waitForChanges
    [String]
_ -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  String -> IO String
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> IO String) -> String -> IO String
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
        [ String
":r"
        , String
"Reanimate.reanimate (" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
animation String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
        , String
":cmd System.Environment.withArgs [\"primed\"] Reanimate.reanimateLive" ]

waitForChanges :: IO ()
waitForChanges :: IO ()
waitForChanges = (WatchManager -> IO ()) -> IO ()
forall a. (WatchManager -> IO a) -> IO a
withManager ((WatchManager -> IO ()) -> IO ())
-> (WatchManager -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \WatchManager
mgr -> do
    MVar ()
lock <- IO (MVar ())
forall a. IO (MVar a)
newEmptyMVar
    IO ()
stop <- WatchManager -> String -> ActionPredicate -> Action -> IO (IO ())
watchTree WatchManager
mgr String
"." ActionPredicate
check (IO () -> Action
forall a b. a -> b -> a
const (IO () -> Action) -> IO () -> Action
forall a b. (a -> b) -> a -> b
$ MVar () -> () -> IO ()
forall a. MVar a -> a -> IO ()
putMVar MVar ()
lock ())
    MVar () -> IO ()
forall a. MVar a -> IO a
takeMVar MVar ()
lock
    IO ()
stop
  where
    check :: ActionPredicate
check Event
event =
      String -> String
takeExtension (Event -> String
eventPath Event
event) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
sourceExtensions Bool -> Bool -> Bool
||
      String -> String
takeExtension (Event -> String
eventPath Event
event) String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String]
dataExtensions
    sourceExtensions :: [String]
sourceExtensions = [String
".hs", String
".lhs"]
    dataExtensions :: [String]
dataExtensions = [String
".jpg", String
".png", String
".bmp", String
".pov", String
".tex", String
".csv"]
  

data DaemonCommand
  = DaemonCount Int
  | DaemonFrame Int FilePath
  | DaemonStop
  deriving (Int -> DaemonCommand -> String -> String
[DaemonCommand] -> String -> String
DaemonCommand -> String
(Int -> DaemonCommand -> String -> String)
-> (DaemonCommand -> String)
-> ([DaemonCommand] -> String -> String)
-> Show DaemonCommand
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [DaemonCommand] -> String -> String
$cshowList :: [DaemonCommand] -> String -> String
show :: DaemonCommand -> String
$cshow :: DaemonCommand -> String
showsPrec :: Int -> DaemonCommand -> String -> String
$cshowsPrec :: Int -> DaemonCommand -> String -> String
Show)

sendCommand :: DaemonCommand -> IO ()
sendCommand :: DaemonCommand -> IO ()
sendCommand DaemonCommand
cmd = IO () -> IO ()
forall a. IO a -> IO a
withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\SomeException{} -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
  AddrInfo
addr <- IO AddrInfo
resolve
  IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (AddrInfo -> IO Socket
open AddrInfo
addr) Socket -> IO ()
close ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
    IO Int -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Int -> IO ()) -> IO Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Socket -> ByteString -> IO Int
send Socket
sock (ByteString -> IO Int) -> ByteString -> IO Int
forall a b. (a -> b) -> a -> b
$ case DaemonCommand
cmd of
      DaemonCount Int
count    -> String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"frame_count", Int -> String
forall a. Show a => a -> String
show Int
count]
      DaemonFrame Int
nth String
path -> String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"frame", Int -> String
forall a. Show a => a -> String
show Int
nth, String
path]
      DaemonCommand
DaemonStop           -> String -> ByteString
BS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ [String] -> String
unwords [String
"stop"]
    () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    resolve :: IO AddrInfo
resolve = do
        let hints :: AddrInfo
hints = AddrInfo
defaultHints { addrSocketType :: SocketType
addrSocketType = SocketType
Stream }
        [AddrInfo] -> AddrInfo
forall a. [a] -> a
head ([AddrInfo] -> AddrInfo) -> IO [AddrInfo] -> IO AddrInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
"127.0.0.1") (String -> Maybe String
forall a. a -> Maybe a
Just String
"9162")
    open :: AddrInfo -> IO Socket
open AddrInfo
addr = IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError (AddrInfo -> IO Socket
oSocket AddrInfo
addr) Socket -> IO ()
close ((Socket -> IO Socket) -> IO Socket)
-> (Socket -> IO Socket) -> IO Socket
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
      Socket -> SockAddr -> IO ()
connect Socket
sock (SockAddr -> IO ()) -> SockAddr -> IO ()
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
addrAddress AddrInfo
addr
      Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock

hasDaemon :: IO Bool
hasDaemon :: IO Bool
hasDaemon = IO Bool -> IO Bool
forall a. IO a -> IO a
withSocketsDo (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ (SomeException -> IO Bool) -> IO Bool -> IO Bool
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (\SomeException{} -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False) (IO Bool -> IO Bool) -> IO Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
  AddrInfo
addr <- IO AddrInfo
resolve
  IO Socket -> (Socket -> IO ()) -> (Socket -> IO Bool) -> IO Bool
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (AddrInfo -> IO Socket
open AddrInfo
addr) Socket -> IO ()
close (IO Bool -> Socket -> IO Bool
forall a b. a -> b -> a
const (IO Bool -> Socket -> IO Bool) -> IO Bool -> Socket -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True)
  where
    resolve :: IO AddrInfo
resolve = do
        let hints :: AddrInfo
hints = AddrInfo
defaultHints { addrSocketType :: SocketType
addrSocketType = SocketType
Stream }
        [AddrInfo] -> AddrInfo
forall a. [a] -> a
head ([AddrInfo] -> AddrInfo) -> IO [AddrInfo] -> IO AddrInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (String -> Maybe String
forall a. a -> Maybe a
Just String
"127.0.0.1") (String -> Maybe String
forall a. a -> Maybe a
Just String
"9162")
    open :: AddrInfo -> IO Socket
open AddrInfo
addr = IO Socket
-> (Socket -> IO ()) -> (Socket -> IO Socket) -> IO Socket
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError (AddrInfo -> IO Socket
oSocket AddrInfo
addr) Socket -> IO ()
close ((Socket -> IO Socket) -> IO Socket)
-> (Socket -> IO Socket) -> IO Socket
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
      Socket -> SockAddr -> IO ()
connect Socket
sock (SockAddr -> IO ()) -> SockAddr -> IO ()
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
addrAddress AddrInfo
addr
      Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock

oSocket :: AddrInfo -> IO Socket
oSocket :: AddrInfo -> IO Socket
oSocket AddrInfo
addr = Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr)

ensureDaemon :: IO Bool
ensureDaemon :: IO Bool
ensureDaemon = do
  Bool
daemon <- IO Bool
hasDaemon
  if Bool
daemon
    then Bool -> IO Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
    else IO Bool
localDaemon

killDaemon :: IO ()
killDaemon :: IO ()
killDaemon = DaemonCommand -> IO ()
sendCommand DaemonCommand
DaemonStop

localDaemon :: IO Bool
localDaemon :: IO Bool
localDaemon = do
  IO ()
killDaemon
  IO () -> IO Bool
detach IO ()
Server.daemon