Process.hs

{-# LANGUAGE ScopedTypeVariables, FlexibleContexts, DataKinds, MonoLocalBinds #-}
{-# LANGUAGE CPP #-}
module Network.SC2.LowLevel.Process
       ( ExecOptions(..)
       , ConnectOptions(..)
       , Starcraft
       , runRemote
       , runLocal
       , sendRequest
       , readResponse
       ) where

import Network.Socket (withSocketsDo)
import System.Process
import System.Directory (withCurrentDirectory, getHomeDirectory)
import qualified Network.WebSockets as WS
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Control.Concurrent
import Control.Exception
import qualified Proto.S2clientprotocol.Sc2api as A
import Data.ProtoLens
import Network.SC2.LowLevel.Mainable
import Network.SC2.LowLevel.Requestable
import Network.SC2.LowLevel.Requests
import Data.List(intercalate)
import System.FilePath
import System.Info
import Network.SC2.Internal.Directories
import Control.Monad.Freer



data ExecOptions = ExecOptions
    { executable :: Maybe FilePath
    , workingDirectory :: Maybe FilePath
    , windowWidth :: Word
    , windowHeight :: Word
    , connection :: ConnectOptions
    } deriving (Eq, Show)

data ConnectOptions =
  ConnectOptions
  { listenAddress :: String
  , listenPort :: Word
  } deriving (Eq, Show)

instance OptParseable ExecOptions where
  optParse = ExecOptions
             <$> optional (strOption (long "executable" <> short 'e' <> metavar "PATH" <> help "path to the starcraft 2 executable"))
             <*> optional (strOption (long "working-dir" <> short 'w' <> metavar "PATH" <> help "change to this directory before launching starcraft"))
             <*> option auto (long "window-width" <> metavar "WIDTH" <> help "width of starcraft 2 window" <> value 1024)
             <*> option auto (long "window-height" <> metavar "HEIGHT" <> help "height of starcraft 2 window" <> value 768)
             <*> optParse

instance OptParseable ConnectOptions where
  optParse = ConnectOptions
             <$> strOption (long "address" <> metavar "ADDR" <> help "address to use to talk to SC2" <> value "127.0.0.1")
             <*> option auto (long "port" <> metavar "PORT" <> help "port to use to talk to SC2" <> value 5000)

data Starcraft =
  Starcraft
  { processHandle :: Maybe ProcessHandle
  , processConn :: WS.Connection
  }

starcraftConnectIntern :: (WS.Connection -> IO ()) -> ConnectOptions -> IO ()
starcraftConnectIntern act opt = withSocketsDo $ do
  tryConnect 60
  runOurClient $ \conn -> do
    --WS.forkPingThread conn 10
    act conn
  where
    runOurClient = WS.runClient (listenAddress opt) (fromIntegral (listenPort opt)) "/sc2api"
    
    tryConnect i | i > 0 = runOurClient (const (pure ())) `catch` \(x :: SomeException) -> tryAgain i
                 | otherwise = runOurClient (const (pure ()))
    tryAgain i = threadDelay 1000000 >> tryConnect (i - 1)

runRemote :: (Starcraft -> IO ()) -> ConnectOptions -> IO ()
runRemote act = starcraftConnectIntern (act . Starcraft Nothing)

runLocal :: (Starcraft -> Eff '[IO] ()) -> ExecOptions -> IO ()
runLocal act opt = do              
  paths <- makeSC2Paths (executable opt)
  withCurrentDirectory (supportDir paths) $ withCreateProcess (procinfo paths) handler
  where
    handler stdin stdout stderr ph = do      
      starcraftConnectIntern (\conn ->
                                 let sc = Starcraft (Just ph) conn
                                     --unwrappedAct = runM (act sc)
                                 in runM $ act sc >> sendRequest sc (toRequest QuitGame))
        (connection opt)
      waitForProcess ph
      return ()

    
--Work around process lib's Windows bug
#ifdef mingw32_HOST_OS 
    procinfo paths = shell $ "\"" ++ (gameExecutable paths) ++ "\" " ++  (intercalate " "  args)
#else
    procinfo paths = proc (gameExecutable paths) args
#endif
    args = ["-listen", listenAddress $ connection opt, "-port", show (listenPort $ connection opt), "-displayMode", "0", "-windowwidth", show (windowWidth opt), "-windowheight", show (windowHeight opt)]


sendRequest :: Member IO r => Starcraft -> A.Request -> Eff r ()
sendRequest sc msg = send $ WS.sendBinaryData (processConn sc) $ encodeMessage msg

--TODO: Cache responses per Step
readResponse :: Member IO r => Starcraft -> Eff r (Either T.Text A.Response)
                     --FIXME: use Control.Monad.Freer.Error
readResponse sc = do -- Will this kill performance, deconstructing and reconstructing the Either each time?
  receivedData <- send $ WS.receiveData (processConn sc)    
  let resp = decodeMessage receivedData
  case resp of
    Left s -> return (Left (T.pack s))
    Right r -> return (Right r)