{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Reanimate.Driver.Server
  ( daemon
  ) where

import           Control.Concurrent
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           (getDataFileName)
import           System.IO                 (hPutStrLn, stderr)
import           Web.Browser               (openBrowser)

opts :: ConnectionOptions
opts :: ConnectionOptions
opts = ConnectionOptions
defaultConnectionOptions
  { connectionCompressionOptions :: CompressionOptions
connectionCompressionOptions = PermessageDeflate -> CompressionOptions
PermessageDeflateCompression PermessageDeflate
defaultPermessageDeflate }



daemon :: IO ()
daemon :: IO ()
daemon = do
  MVar (Int, Map Int FilePath)
state <- (Int, Map Int FilePath) -> IO (MVar (Int, Map Int FilePath))
forall a. a -> IO (MVar a)
newMVar (Int
0, Map Int FilePath
forall k a. Map k a
Map.empty)
  MVar (Map ThreadId Connection)
connsRef <- Map ThreadId Connection -> IO (MVar (Map ThreadId Connection))
forall a. a -> IO (MVar a)
newMVar Map ThreadId Connection
forall k a. Map k a
Map.empty

  ThreadId
self <- IO ThreadId
myThreadId

  ThreadId
dTid <- ThreadId -> (WebMessage -> IO ()) -> IO ThreadId
daemonReceive ThreadId
self ((WebMessage -> IO ()) -> IO ThreadId)
-> (WebMessage -> IO ()) -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ \WebMessage
msg ->
    case WebMessage
msg of
      WebStatus FilePath
_status -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      WebError FilePath
_err -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      WebFrameCount Int
count -> do
        IO (Int, Map Int FilePath) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Int, Map Int FilePath) -> IO ())
-> IO (Int, Map Int FilePath) -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar (Int, Map Int FilePath)
-> (Int, Map Int FilePath) -> IO (Int, Map Int FilePath)
forall a. MVar a -> a -> IO a
swapMVar MVar (Int, Map Int FilePath)
state (Int
count, Map Int FilePath
forall k a. Map k a
Map.empty)
        Map ThreadId Connection
conns <- MVar (Map ThreadId Connection) -> IO (Map ThreadId Connection)
forall a. MVar a -> IO a
readMVar MVar (Map ThreadId Connection)
connsRef
        Map ThreadId Connection -> (Connection -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Map ThreadId Connection
conns ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Connection
conn) -> do
          Connection -> WebMessage -> IO ()
sendWebMessage Connection
conn (Int -> WebMessage
WebFrameCount Int
count)
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Map ThreadId Connection -> Bool
forall k a. Map k a -> Bool
Map.null Map ThreadId Connection
conns) IO ()
openViewer
      WebFrame Int
nth FilePath
path -> do
        MVar (Int, Map Int FilePath)
-> ((Int, Map Int FilePath) -> IO (Int, Map Int FilePath)) -> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Int, Map Int FilePath)
state (((Int, Map Int FilePath) -> IO (Int, Map Int FilePath)) -> IO ())
-> ((Int, Map Int FilePath) -> IO (Int, Map Int FilePath)) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
count, Map Int FilePath
frames) ->
          (Int, Map Int FilePath) -> IO (Int, Map Int FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Int
count, Int -> FilePath -> Map Int FilePath -> Map Int FilePath
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Int
nth FilePath
path Map Int FilePath
frames)
        Map ThreadId Connection
conns <- MVar (Map ThreadId Connection) -> IO (Map ThreadId Connection)
forall a. MVar a -> IO a
readMVar MVar (Map ThreadId Connection)
connsRef
        Map ThreadId Connection -> (Connection -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
F.forM_ Map ThreadId Connection
conns ((Connection -> IO ()) -> IO ()) -> (Connection -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
          Connection -> WebMessage -> IO ()
sendWebMessage Connection
conn (Int -> FilePath -> WebMessage
WebFrame Int
nth FilePath
path)

  IO ()
openViewer

  let options :: ServerOptions
options = ServerOptions :: FilePath -> Int -> ConnectionOptions -> Maybe Int -> ServerOptions
ServerOptions
        { serverHost :: FilePath
serverHost = FilePath
"127.0.0.1"
        , serverPort :: Int
serverPort = Int
9161
        , serverConnectionOptions :: ConnectionOptions
serverConnectionOptions = ConnectionOptions
opts
        , serverRequirePong :: Maybe Int
serverRequirePong = Maybe Int
forall a. Maybe a
Nothing }

  ServerOptions -> ServerApp -> IO ()
forall a. ServerOptions -> ServerApp -> IO a
runServerWithOptions ServerOptions
options (\PendingConnection
pending -> do
        ThreadId
tid <- IO ThreadId
myThreadId

        Connection
conn <- PendingConnection -> IO Connection
acceptRequest PendingConnection
pending

        MVar (Map ThreadId Connection)
-> (Map ThreadId Connection -> IO (Map ThreadId Connection))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map ThreadId Connection)
connsRef ((Map ThreadId Connection -> IO (Map ThreadId Connection))
 -> IO ())
-> (Map ThreadId Connection -> IO (Map ThreadId Connection))
-> IO ()
forall a b. (a -> b) -> a -> b
$ Map ThreadId Connection -> IO (Map ThreadId Connection)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ThreadId Connection -> IO (Map ThreadId Connection))
-> (Map ThreadId Connection -> Map ThreadId Connection)
-> Map ThreadId Connection
-> IO (Map ThreadId Connection)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId
-> Connection -> Map ThreadId Connection -> Map ThreadId Connection
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ThreadId
tid Connection
conn

        (Int
count, Map Int FilePath
frames) <- MVar (Int, Map Int FilePath) -> IO (Int, Map Int FilePath)
forall a. MVar a -> IO a
readMVar MVar (Int, Map Int FilePath)
state
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
count Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Connection -> WebMessage -> IO ()
sendWebMessage Connection
conn (Int -> WebMessage
WebFrameCount Int
count)
          [(Int, FilePath)] -> ((Int, FilePath) -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Map Int FilePath -> [(Int, FilePath)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Int FilePath
frames) (((Int, FilePath) -> IO ()) -> IO ())
-> ((Int, FilePath) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Int
nth, FilePath
path) ->
            Connection -> WebMessage -> IO ()
sendWebMessage Connection
conn (Int -> FilePath -> WebMessage
WebFrame Int
nth FilePath
path)

        let loop :: IO b
loop = do
              -- FIXME: We don't use msg here.
              Text
_msg <- Connection -> IO Text
forall a. WebSocketsData a => Connection -> IO a
receiveData Connection
conn :: IO T.Text
              IO b
loop
            cleanup :: IO ()
cleanup = do
              MVar (Map ThreadId Connection)
-> (Map ThreadId Connection -> IO (Map ThreadId Connection))
-> IO ()
forall a. MVar a -> (a -> IO a) -> IO ()
modifyMVar_ MVar (Map ThreadId Connection)
connsRef ((Map ThreadId Connection -> IO (Map ThreadId Connection))
 -> IO ())
-> (Map ThreadId Connection -> IO (Map ThreadId Connection))
-> IO ()
forall a b. (a -> b) -> a -> b
$ Map ThreadId Connection -> IO (Map ThreadId Connection)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map ThreadId Connection -> IO (Map ThreadId Connection))
-> (Map ThreadId Connection -> Map ThreadId Connection)
-> Map ThreadId Connection
-> IO (Map ThreadId Connection)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ThreadId -> Map ThreadId Connection -> Map ThreadId Connection
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ThreadId
tid
              Int
nConns <- Map ThreadId Connection -> Int
forall k a. Map k a -> Int
Map.size (Map ThreadId Connection -> Int)
-> IO (Map ThreadId Connection) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Map ThreadId Connection) -> IO (Map ThreadId Connection)
forall a. MVar a -> IO a
readMVar MVar (Map ThreadId Connection)
connsRef
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nConns Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
                Int -> IO ()
threadDelay (Int
second Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
5)
                Int
nConns' <- Map ThreadId Connection -> Int
forall k a. Map k a -> Int
Map.size (Map ThreadId Connection -> Int)
-> IO (Map ThreadId Connection) -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MVar (Map ThreadId Connection) -> IO (Map ThreadId Connection)
forall a. MVar a -> IO a
readMVar MVar (Map ThreadId Connection)
connsRef
                Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
nConns'Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ ThreadId -> IO ()
killThread ThreadId
self
        IO ()
forall b. IO b
loop IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` IO ()
cleanup)
     IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` (ThreadId -> IO ()
killThread ThreadId
dTid)

second :: Int
second :: Int
second = Int
10Int -> Int -> Int
forall a b. (Num a, Integral b) => a -> b -> a
^(Int
6::Int)

daemonReceive :: ThreadId -> (WebMessage -> IO ()) -> IO ThreadId
daemonReceive :: ThreadId -> (WebMessage -> IO ()) -> IO ThreadId
daemonReceive ThreadId
parent WebMessage -> IO ()
cb = IO ThreadId -> IO ThreadId
forall a. IO a -> IO a
withSocketsDo (IO ThreadId -> IO ThreadId) -> IO ThreadId -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    AddrInfo
addr <- IO AddrInfo
resolve
    Socket
sock <- AddrInfo -> IO Socket
open AddrInfo
addr
    IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Socket -> IO ()
forall b. Socket -> IO b
handler Socket
sock IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`finally` Socket -> IO ()
close Socket
sock
  where
    handler :: Socket -> IO b
handler Socket
sock = IO () -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO b) -> IO () -> IO b
forall a b. (a -> b) -> a -> b
$ IO (Socket, SockAddr)
-> ((Socket, SockAddr) -> IO ())
-> ((Socket, SockAddr) -> IO ())
-> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracketOnError (Socket -> IO (Socket, SockAddr)
accept Socket
sock) (Socket -> IO ()
close (Socket -> IO ())
-> ((Socket, SockAddr) -> Socket) -> (Socket, SockAddr) -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Socket, SockAddr) -> Socket
forall a b. (a, b) -> a
fst) (((Socket, SockAddr) -> IO ()) -> IO ())
-> ((Socket, SockAddr) -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \(Socket
conn, SockAddr
_peer) -> do
      FilePath
inp <- ByteString -> FilePath
BS.unpack (ByteString -> FilePath) -> IO ByteString -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> Int -> IO ByteString
recv Socket
conn Int
4096
      case FilePath -> [FilePath]
words FilePath
inp of
        [FilePath
"frame_count", FilePath
n]   -> WebMessage -> IO ()
cb (WebMessage -> IO ()) -> WebMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> WebMessage
WebFrameCount (FilePath -> Int
forall a. Read a => FilePath -> a
read FilePath
n)
        [FilePath
"frame", FilePath
nth, FilePath
path] -> WebMessage -> IO ()
cb (WebMessage -> IO ()) -> WebMessage -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> FilePath -> WebMessage
WebFrame (FilePath -> Int
forall a. Read a => FilePath -> a
read FilePath
nth) FilePath
path
        [FilePath
"stop"]             -> ThreadId -> IO ()
killThread ThreadId
parent
        []                   -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        [FilePath]
_                    -> FilePath -> IO ()
forall a. HasCallStack => FilePath -> a
error (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Bad message: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
inp
      Socket -> Int -> IO ()
gracefulClose Socket
conn Int
5000
    resolve :: IO AddrInfo
resolve = do
        let hints :: AddrInfo
hints = AddrInfo
defaultHints {
                addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_PASSIVE]
              , 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 FilePath -> Maybe FilePath -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"127.0.0.1") (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"9162")
    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)
    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 -> SocketOption -> Int -> IO ()
setSocketOption Socket
sock SocketOption
ReuseAddr Int
1
      Socket -> (ProtocolNumber -> IO ()) -> IO ()
forall r. Socket -> (ProtocolNumber -> IO r) -> IO r
withFdSocket Socket
sock ProtocolNumber -> IO ()
setCloseOnExecIfNeeded
      Socket -> SockAddr -> IO ()
bind Socket
sock (SockAddr -> IO ()) -> SockAddr -> IO ()
forall a b. (a -> b) -> a -> b
$ AddrInfo -> SockAddr
addrAddress AddrInfo
addr
      Socket -> Int -> IO ()
listen Socket
sock Int
1024
      Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock

openViewer :: IO ()
openViewer :: IO ()
openViewer = do
  FilePath
url <- FilePath -> IO FilePath
getDataFileName FilePath
"viewer-elm/dist/index.html"
  Bool
bSucc <- FilePath -> IO Bool
openBrowser FilePath
url
  Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
bSucc (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
    Handle -> FilePath -> IO ()
hPutStrLn Handle
stderr (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Failed to open browser. Manually visit: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
url

-------------------------------------------------------------------------------
-- Websocket API

data WebMessage
  = WebStatus String
  | WebError String
  | WebFrameCount Int
  | WebFrame Int FilePath

sendWebMessage :: Connection -> WebMessage -> IO ()
sendWebMessage :: Connection -> WebMessage -> IO ()
sendWebMessage Connection
conn WebMessage
msg = Connection -> Text -> IO ()
forall a. WebSocketsData a => Connection -> a -> IO ()
sendTextData Connection
conn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
  case WebMessage
msg of
    WebStatus FilePath
txt   -> FilePath -> Text
T.pack FilePath
"status\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
txt
    WebError FilePath
txt    -> FilePath -> Text
T.pack FilePath
"error\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
txt
    WebFrameCount Int
n -> FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"frame_count\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n
    WebFrame Int
n FilePath
path -> FilePath -> Text
T.pack (FilePath -> Text) -> FilePath -> Text
forall a b. (a -> b) -> a -> b
$ FilePath
"frame\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
n FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
path