sc2-lowlevel (empty) → 0.1.0.0

raw patch · 11 files changed

+886/−0 lines, 11 filesdep +basedep +bytestringdep +containers

Dependencies added: base, bytestring, containers, data-default-class, directory, filepath, freer-simple, lens, lens-labels, network, optparse-applicative, process, proto-lens, sc2-proto, sc2-support, text, websockets

Files

README.md +1/−0
sc2-lowlevel.cabal +58/−0
src/Network/SC2/LowLevel.hs +11/−0
src/Network/SC2/LowLevel/Convert.hs +78/−0
src/Network/SC2/LowLevel/Mainable.hs +36/−0
src/Network/SC2/LowLevel/Process.hs +118/−0
src/Network/SC2/LowLevel/Protocol.hs +105/−0
src/Network/SC2/LowLevel/Requestable.hs +35/−0
src/Network/SC2/LowLevel/Requests.hs +229/−0
src/Network/SC2/LowLevel/Split.hs +58/−0
src/Network/SC2/LowLevel/Types.hs +157/−0

+ README.md view

@@ -0,0 +1,1 @@+# sc2-lowlevel

+ sc2-lowlevel.cabal view

@@ -0,0 +1,58 @@+cabal-version: 1.12
++-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: 25400b98b796e0d25a9a8b131009076019ecd02d14cf44da0f7ce1fc2189d3a6++name:           sc2-lowlevel+version:        0.1.0.0+synopsis:       Low-level Starcraft II API+description:    This package is a wrapper around the sc2-proto library, handling things such as launching the process and sending and receiving messages over a websocket.+category:       Network, FFI, Game+homepage:       https://github.com/spacekitteh/sc2hs+maintainer:     Sophie Taylor <sophie@spacekitteh.moe>+license:        BSD3+build-type:     Simple+extra-source-files:+    README.md++source-repository head+  type: git+  location: https://gitlab.com/spacekitteh/sc2hs.git++library+  exposed-modules:+      Network.SC2.LowLevel+      Network.SC2.LowLevel.Convert+      Network.SC2.LowLevel.Mainable+      Network.SC2.LowLevel.Process+      Network.SC2.LowLevel.Protocol+      Network.SC2.LowLevel.Requestable+      Network.SC2.LowLevel.Requests+      Network.SC2.LowLevel.Split+      Network.SC2.LowLevel.Types+  other-modules:+      Paths_sc2_lowlevel+  hs-source-dirs:+      src+  build-depends:+      base >=4.7 && <5+    , bytestring >=0.10+    , containers >=0.6+    , data-default-class >=0.1.2+    , directory >=1.3+    , filepath >=1.4+    , freer-simple >=1.2+    , lens >=4.17+    , lens-labels >=0.3+    , network >=2.8+    , optparse-applicative >=0.14+    , process >=1.6+    , proto-lens >=0.4+    , sc2-proto+    , sc2-support+    , text >=1.2+    , websockets >=0.12+  default-language: Haskell2010

+ src/Network/SC2/LowLevel.hs view

@@ -0,0 +1,11 @@+module Network.SC2.LowLevel
+  ( module Network.SC2.LowLevel.Mainable
+  , module Network.SC2.LowLevel.Process
+  , module Network.SC2.LowLevel.Protocol
+  , module Network.SC2.LowLevel.Requests
+  ) where
+
+import Network.SC2.LowLevel.Mainable
+import Network.SC2.LowLevel.Process
+import Network.SC2.LowLevel.Protocol
+import Network.SC2.LowLevel.Requests

+ src/Network/SC2/LowLevel/Convert.hs view

@@ -0,0 +1,78 @@+{-# LANGUAGE FlexibleInstances, TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedLabels #-}
+module Network.SC2.LowLevel.Convert where
+
+import Network.SC2.LowLevel.Types
+import qualified Proto.S2clientprotocol.Common as C
+import qualified Proto.S2clientprotocol.Sc2api as A
+import qualified Proto.S2clientprotocol.Raw as R
+import Data.ProtoLens (defMessage)
+import qualified Network.SC2.Constants.Units as Units
+import Lens.Labels.Unwrapped ()
+import Control.Lens
+import Data.Coerce
+
+
+convertRace :: Race' a -> C.Race
+convertRace Terran = C.Terran
+convertRace Zerg = C.Zerg
+convertRace Protoss = C.Protoss
+convertRace (Random _) = C.Random
+
+convertRaceBack :: C.Race -> a -> Race' a
+convertRaceBack C.Terran = const Terran
+convertRaceBack C.Zerg = const Zerg
+convertRaceBack C.Protoss = const Protoss
+convertRaceBack C.Random = Random
+
+convertPlayer :: Player (Race' a) -> A.PlayerSetup
+convertPlayer Observer = defMessage & #type' .~ A.Observer
+convertPlayer (Participant r) = defMessage & #type' .~ A.Participant & #race .~ convertRace r --A.playerSetup (Just A.Participant) (Just (convertRace r)) Nothing
+convertPlayer (Computer r d) = defMessage & #type' .~ A.Computer & #race .~ convertRace r & #difficulty .~ d--A.playerSetup (Just A.Computer) (Just (convertRace r)) (Just d)
+
+class ConvertProto a where
+  type Unproto a
+  convertTo :: Unproto a -> a
+  convertFrom :: a -> Maybe (Unproto a)
+
+instance ConvertProto C.PointI where
+  type Unproto C.PointI = (Int, Int)
+  convertTo (x, y) = defMessage & #x .~ fromIntegral x & #y .~ fromIntegral y 
+  convertFrom p = (,) <$> (fromIntegral <$> p^. #maybe'x) <*> (fromIntegral <$> p^. #maybe'y)--(fromIntegral p^.x, fromIntegral p^.y)
+
+instance ConvertProto C.RectangleI where
+  type Unproto C.RectangleI = ((Int, Int), (Int, Int))
+  convertTo (a, b) = defMessage & #p0 .~ (convertTo a) & #p1 .~ (convertTo b) 
+  convertFrom r = (,) <$> (convertFrom =<< r^. #maybe'p0) <*> (convertFrom =<< r^. #maybe'p1)
+
+instance ConvertProto C.Point2D where
+  type Unproto C.Point2D = Point
+  convertTo (x, y) = defMessage & #x .~ x & #y .~ y 
+  convertFrom p = (,) <$> p^. #maybe'x <*>  p^. #maybe'y
+
+instance ConvertProto C.Size2DI where
+  type Unproto C.Size2DI = (Int, Int)
+  convertTo (x, y) = defMessage & #x .~ fromIntegral x & #y .~ fromIntegral y 
+  convertFrom sz = (,) <$> (fromIntegral <$> sz^. #maybe'x) <*> (fromIntegral <$> sz^. #maybe'y)
+
+instance ConvertProto C.ImageData where
+  type Unproto C.ImageData = ImageData
+  convertTo (ImageData bits size dat) = defMessage & #bitsPerPixel .~ fromIntegral bits & #size .~ convertTo size & #data' .~ dat
+  convertFrom i = ImageData <$> (fromIntegral <$> i^. #maybe'bitsPerPixel) <*> (convertFrom =<< i^. #maybe'size) <*> i^. #maybe'data'
+
+instance ConvertProto R.Unit where
+  type Unproto R.Unit = Unit
+  convertTo _ = error "Why are you converting Unit back to proto"
+  convertFrom m = Just Unit {tag = tag', unitType = unitType', alliance = alliance', owner = owner'} where
+    tag' = UnitID (m ^. #tag) 
+    unitType' = Units.fromInt (m ^. #unitType)
+    alliance' = m ^. #alliance
+    owner' = PlayerID $fromIntegral (m ^. #owner)
+
+instance ConvertProto R.ActionRawUnitCommand'Target where
+  type Unproto R.ActionRawUnitCommand'Target = Target
+  convertTo (TargetPoint p) = R.ActionRawUnitCommand'TargetWorldSpacePos (convertTo p)
+  convertTo (TargetUnit u) = R.ActionRawUnitCommand'TargetUnitTag (coerce u)
+  convertFrom = error "ConvertFrom ActionRawUnitCommand'Target TODO" -- TODO
+

+ src/Network/SC2/LowLevel/Mainable.hs view

@@ -0,0 +1,36 @@+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+module Network.SC2.LowLevel.Mainable
+       ( module Options.Applicative
+       , (<>)
+       , OptParseable(..)
+       , Mainable(..)
+       , withMain
+       ) where
+
+import Options.Applicative
+import Data.Semigroup ((<>))
+import Data.Proxy
+
+class OptParseable a where
+    optParse :: Parser a
+
+class Mainable a where
+    type MainOpt a
+    mainParse :: Proxy a -> Parser (MainOpt a)
+    withMainArgs :: MainOpt a -> a -> IO ()
+
+withMain :: (Mainable a) => InfoMod (MainOpt a) -> a -> IO ()
+withMain im a = do
+  args <- execParser $ info (mainParse (pure a) <**> helper) im
+  withMainArgs args a
+
+instance (OptParseable a, Mainable b) => Mainable (a -> b) where
+    type MainOpt (a -> b) = (a, MainOpt b)
+    mainParse p = (,) <$> optParse <*> mainParse (p <*> Proxy)
+    withMainArgs (a, b) f = withMainArgs b (f a)
+
+instance Mainable (IO ()) where
+    type MainOpt (IO ()) = ()
+    mainParse _ = pure ()
+    withMainArgs _ = id

+ src/Network/SC2/LowLevel/Process.hs view

@@ -0,0 +1,118 @@+{-# 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)

+ src/Network/SC2/LowLevel/Protocol.hs view

@@ -0,0 +1,105 @@+{-# LANGUAGE ConstraintKinds, AllowAmbiguousTypes#-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE TypeOperators #-}
+{-#LANGUAGE OverloadedLabels #-}
+module Network.SC2.LowLevel.Protocol
+       ( module Control.Monad.Freer
+       , module Network.SC2.LowLevel.Split
+       , SC2Control(..)
+       , SC2
+       , SC2LowLevel
+       , unsafeRequest
+       , unsafeResponse
+       , getStatus
+       , request
+       , syncRequest'
+       , syncRequest
+       , runSC2Control
+       , runSC2
+       ) where
+
+import Control.Monad.Freer
+import Control.Monad.Freer.Internal
+import Control.Monad.Freer.Error
+import Data.Traversable
+import Data.Foldable
+import Control.Monad
+import Data.Text
+import qualified Proto.S2clientprotocol.Sc2api as A
+import Network.SC2.LowLevel.Requestable
+import Network.SC2.LowLevel.Process
+import Network.SC2.LowLevel.Split
+import Lens.Labels.Unwrapped ()
+import Control.Lens
+import Numeric.Natural
+import Data.ProtoLens (defMessage)
+
+data SC2Control a where
+  SC2Request :: A.Request -> SC2Control()
+  SC2Requests :: [A.Request] -> SC2Control()
+  SC2Response :: SC2Control(Either Text A.Response)
+  SC2Responses :: forall t. Traversable t => Natural -> SC2Control (t (Either Text A.Response)) -- TODO
+  SC2Status :: SC2Control A.Status
+
+unsafeRequest :: (Member SC2Control r) => A.Request -> Eff r ()
+unsafeRequest = send . SC2Request
+
+unsafeResponse :: (Member SC2Control r) => Eff r (Either Text A.Response)
+unsafeResponse = send SC2Response
+
+getStatus :: (Member SC2Control r) => Eff r A.Status
+getStatus = send SC2Status
+
+type SC2 r = (Member SC2Control r, Member Split r)
+
+request :: (SC2 r, Requestable a) => a -> Eff r ()
+request r = unsafeRequest (toRequest r) >> fork (void unsafeResponse)
+
+syncRequest' :: (SC2 r, Requestable a) => a -> Eff r () -> Eff r (Either Text (ResponseOf a))
+--FIXME: use Control.Monad.Freer.Error
+syncRequest' r act = do
+  unsafeRequest (toRequest r)
+  act
+  suspend
+  resp <- unsafeResponse
+  return (resp >>= fromResponse (pure r))
+
+syncRequest :: (SC2 r, Requestable a) => a -> Eff r (Either Text (ResponseOf a))
+syncRequest r = syncRequest' r (pure ())
+
+runSC2Control :: Member IO r => Eff (SC2Control ': r) a -> Starcraft ->  Eff r a
+runSC2Control m sc = runNatS A.Launched go m
+  where
+    go :: Member IO r =>  A.Status -> SC2Control a -> Eff r (A.Status, a)
+    go s (SC2Request r) = (s,) <$> sendRequest sc r
+    go s (SC2Requests rs) = do
+      responses <- traverse (sendRequest sc) rs
+      return (s, fold responses)
+    go s SC2Response = getResponse s
+    go s (SC2Responses n) = error "Network.SC2.LowLevel.Protocol.SC2Control.Responses: Not implemented" -- TODO
+    go s SC2Status = return (s, s)
+    getResponse :: Member IO r => A.Status -> Eff r (A.Status, Either Text A.Response)
+    getResponse s = do
+      resp <- readResponse sc
+      case resp of --TODO: horrible, lens it instead
+                   --FIXME: use Control.Monad.Freer.Error
+        Left _ -> return (s, resp)
+        Right r -> case r^. #maybe'status of
+          Nothing -> return (s, resp)
+          Just s' -> return (s', resp)
+    
+    
+
+    runNatS :: s -> (forall a. s -> eff a -> Eff effs (s, a)) -> Eff (eff ': effs) b -> Eff effs b
+    runNatS s0 f = handleRelayS s0 (const pure) $ \s e -> ((f s e) >>=) . uncurry
+
+
+--type SC2LowLevel' rest a = (Members '[SC2Control, Split] rest) => Eff rest a
+type SC2LowLevel' effs a = Eff ('[SC2Control, Split] :++: (effs )) a
+type SC2LowLevel effs a = SC2LowLevel' (effs :++: '[IO]) a
+runSC2:: Member IO effs => SC2LowLevel' ( effs) () -> Starcraft -> Eff (effs) ()--IO (Either Text ())
+runSC2 bot  s= runSplit $ runSC2Control bot s

+ src/Network/SC2/LowLevel/Requestable.hs view

@@ -0,0 +1,35 @@+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Network.SC2.LowLevel.Requestable
+  ( Requestable(..)
+  , extractResponse
+  , extractResponseErr
+  ) where
+
+import Data.Proxy
+import Data.Text
+import Data.Maybe
+import qualified Proto.S2clientprotocol.Sc2api as A
+import qualified Proto.S2clientprotocol.Sc2api_Fields as A
+import Data.Default.Class
+import Control.Lens
+
+class Requestable a where
+  type ResponseOf a
+  toRequest :: a -> A.Request
+  fromResponse :: Proxy a -> A.Response -> Either Text (ResponseOf a)
+
+instance Requestable A.Request where
+  type ResponseOf A.Request = A.Response
+  toRequest = id
+  fromResponse _ = Right
+
+extractResponse :: (A.Response -> Maybe a) -> A.Response -> Either Text a
+extractResponse f r = maybe (Left ( (intercalate (pack "\n") (r ^. A.error)))) Right (f r)
+
+extractResponseErr :: (A.Response -> Maybe a) -> (a -> Maybe b) -> (a -> Maybe Text) -> A.Response -> Either Text b
+extractResponseErr f v e r =
+  do x <- extractResponse f r
+     case e x of
+       Nothing  -> maybe (Left "error parsing payload") Right (v x)
+       Just err -> Left (err)

+ src/Network/SC2/LowLevel/Requests.hs view

@@ -0,0 +1,229 @@+{-#LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeFamilies #-}
+{-#LANGUAGE OverloadedLabels #-}
+{-# LANGUAGE FlexibleContexts #-}
+module Network.SC2.LowLevel.Requests
+       ( module Network.SC2.LowLevel.Types
+       , Ping(..)
+       , PingResponse(..)
+       , Fog(..)
+       , Realtime(..)
+       , Seed(..)
+       , CreateGame(..)
+       , JoinGame(..)
+       , RestartGame(..)
+       -- , StartReplay(..)
+       , LeaveGame(..)
+       , QuickSave(..)
+       , QuickLoad(..)
+       , QuitGame(..)
+       , GameInfo(..)
+       , GameInfoResponse(..)
+       , Step(..)
+       , AvailableMaps(..)
+       ) where
+
+import qualified Proto.S2clientprotocol.Common as C
+import qualified Proto.S2clientprotocol.Sc2api as A
+import qualified Proto.S2clientprotocol.Raw as R
+import qualified Proto.S2clientprotocol.Raw_Fields as R
+
+import Control.Lens
+import Control.Monad
+import Data.Default.Class
+import qualified Data.Text as T
+import Data.Void
+import Network.SC2.LowLevel.Requestable
+import Network.SC2.LowLevel.Types
+import Network.SC2.LowLevel.Convert
+import Lens.Labels.Unwrapped ()
+import Data.ProtoLens (defMessage)
+
+data Ping = Ping
+          deriving (Show, Eq)
+
+data PingResponse =
+  PingResponse
+  { gameVersion :: T.Text
+  , dataVersion :: T.Text
+  , dataBuild :: Int
+  , baseBuild :: Int
+  } deriving (Show, Eq)
+
+instance Requestable Ping where
+  type ResponseOf Ping = PingResponse
+  toRequest _ = defMessage& #ping .~ defMessage
+  fromResponse _ = extractResponse (view #maybe'ping >=> convert)
+    where convert r = PingResponse <$> r^. #maybe'gameVersion <*> r^. #maybe'dataVersion <*> (fromIntegral <$> r^. #maybe'dataBuild ) <*> (fromIntegral <$> r^. #maybe'baseBuild)
+          
+
+data Fog = Fog | NoFog
+         deriving (Show, Eq, Enum)
+
+data Realtime = Stepped | Realtime
+              deriving (Show, Eq, Enum)
+
+data Seed = Seed Int | RandomSeed
+          deriving (Show, Eq)
+
+data CreateGame = CreateGame Map [Player Race]
+                | CreateGameFull Map [Player Race] Fog Seed Realtime
+                deriving (Show, Eq)
+
+instance Requestable CreateGame where
+  type ResponseOf CreateGame = ()
+  toRequest (CreateGame map players) = toRequest (CreateGameFull map players Fog RandomSeed Stepped)
+  toRequest (CreateGameFull map players fog seed rt) = defMessage& #createGame .~ mods defMessage
+    where
+      mods = mapmod map . playermod . fogmod . seedmod seed . rtmod
+
+      fogmod :: A.RequestCreateGame -> A.RequestCreateGame
+      fogmod = #disableFog .~ (fog == NoFog)
+
+      seedmod :: Seed -> A.RequestCreateGame -> A.RequestCreateGame
+      seedmod RandomSeed = id
+      seedmod (Seed s) = #randomSeed .~ fromIntegral s
+
+      rtmod :: A.RequestCreateGame -> A.RequestCreateGame
+      rtmod = #realtime .~ (rt == Realtime)
+
+      mapmod :: Map -> A.RequestCreateGame -> A.RequestCreateGame
+      mapmod (BattlenetMap m) = #battlenetMapName .~ m
+      mapmod (LocalMap m d) = #localMap .~ (defMessage & #mapPath .~ m & #maybe'mapData .~ d)
+
+      playermod :: A.RequestCreateGame -> A.RequestCreateGame
+      playermod = #playerSetup .~ fmap convertPlayer players
+  fromResponse _ = void . extractResponseErr (view #maybe'createGame) Just (view #maybe'errorDetails)
+
+
+-- FIXME as observer? ports? render / featurelayer interface?
+data JoinGame = JoinGame Race [Interface Void]
+              deriving (Show, Eq)
+
+instance Requestable JoinGame where
+  type ResponseOf JoinGame = PlayerID
+  toRequest (JoinGame r ifaces) = defMessage& #joinGame .~ mod defMessage
+    where
+      mod = racemod . foldr (.) id (fmap ifacemod ifaces)
+
+      racemod :: A.RequestJoinGame -> A.RequestJoinGame
+      racemod = #race .~ convertRace r
+
+      ifacemod :: Interface Void -> A.RequestJoinGame -> A.RequestJoinGame
+      ifacemod Raw = #options . #raw .~ True
+      ifacemod Score = #options . #score .~ True
+  fromResponse _ = fmap (PlayerID . fromIntegral) . extractResponseErr (view #maybe'joinGame) (view #maybe'playerId) (view #maybe'errorDetails)
+
+data RestartGame = RestartGame
+                 deriving (Show, Eq)
+
+
+instance Requestable RestartGame where
+  type ResponseOf RestartGame = ()
+  toRequest _ = defMessage& #restartGame .~ defMessage
+  fromResponse _ = void . extractResponseErr (view #maybe'restartGame) Just (view #maybe'errorDetails)
+
+-- StartReplay
+
+data LeaveGame = LeaveGame
+               deriving (Show, Eq)
+
+instance Requestable LeaveGame where
+  type ResponseOf LeaveGame = ()
+  toRequest _ = defMessage& #leaveGame .~ defMessage
+  fromResponse _ = void . extractResponse (view #maybe'leaveGame)
+
+data QuickSave = QuickSave
+               deriving (Show, Eq)
+
+instance Requestable QuickSave where
+  type ResponseOf QuickSave = ()
+  toRequest _ = defMessage& #quickSave .~ defMessage
+  fromResponse _ = void . extractResponse (view #maybe'quickSave)
+
+data QuickLoad = QuickLoad
+               deriving (Show, Eq)
+
+instance Requestable QuickLoad where
+  type ResponseOf QuickLoad = ()
+  toRequest _ = defMessage& #quickLoad .~ defMessage
+  fromResponse _ = void . extractResponse (view #maybe'quickLoad)
+
+data QuitGame = QuitGame
+          deriving (Show, Eq)
+
+instance Requestable QuitGame where
+  type ResponseOf QuitGame = ()
+  toRequest _ = defMessage& #quit .~ defMessage
+  fromResponse _ = void . extractResponse (view #maybe'quit)
+
+
+
+instance Requestable GameInfo where
+  type ResponseOf GameInfo = GameInfoResponse
+  toRequest _ = defMessage& #gameInfo .~ defMessage
+  fromResponse _ = extractResponse (view #maybe'gameInfo >=> convert)
+    where
+      convert gi = do
+        mname <- gi^. #maybe'mapName
+        let mods = gi^. #modNames
+        localpath <- T.unpack <$> (gi ^. #maybe'localMapPath) 
+        players <- traverse convertPlayer (gi^. #playerInfo) -- TODO: Lensify this wholefunction
+        let raw = convertRaw =<< gi ^. #maybe'startRaw
+        let ifaces = (snd . iface #maybe'raw id Raw . iface #maybe'score id Score . iface #maybe'featureLayer (const True) (FeatureLayer ()) . iface #maybe'render (const True) (Render ())) (gi, [])
+        return (GameInfoResponse mname mods localpath players raw ifaces)
+      iface :: Lens' A.InterfaceOptions (Maybe b) -> (b -> Bool) -> a -> (A.ResponseGameInfo, [a]) -> (A.ResponseGameInfo, [a])
+      iface l t x (gi, xs) = case gi ^. #options . l of
+        Just b | t b -> (gi, x : xs)
+        _            -> (gi, xs)
+      convertPlayer p = do
+        pid <- PlayerID . fromIntegral <$> (p ^. #maybe'playerId)
+        typ <- p ^. #maybe'type'
+        ourtyp <- case typ of
+          A.Observer -> return Observer
+          A.Participant -> do
+            race <- convertRace p
+            return (Participant race)
+          A.Computer -> do
+            race <- convertRace p
+            diff <- p ^. #maybe'difficulty
+            return (Computer race diff)
+        return (pid, ourtyp)
+      convertRace p = do
+        req <-  p ^. #maybe'raceRequested
+        let act =  p ^. #maybe'raceActual
+        return (convertRaceBack req (flip convertRaceBack (error "convertRace") <$> act))
+      convertRaw :: R.StartRaw -> Maybe StartRaw
+      convertRaw r = do
+        msize <- convertFrom =<< (r^. #maybe'mapSize)
+        pagrid <- convertFrom =<< (r^. #maybe'pathingGrid)
+        theight <- convertFrom =<< (r^. #maybe'terrainHeight)
+        plgrid <- convertFrom =<< (r^. #maybe'placementGrid)
+        parea <- convertFrom =<< (r^. #maybe'playableArea)
+        starts <- traverse convertFrom (r^. #startLocations)
+        return (StartRaw msize pagrid theight plgrid parea starts)
+
+-- FIXME RequestObservation
+
+-- FIXME RequestAction
+
+data Step = Step
+          | StepMany Word
+
+instance Requestable Step where
+  type ResponseOf Step = ()
+  toRequest Step = toRequest (StepMany 1)
+  toRequest (StepMany i) = defMessage& #step . #count .~ fromIntegral i
+  fromResponse _ = void . extractResponse (view #maybe'step)
+
+data AvailableMaps = AvailableMaps
+                   deriving (Show, Eq)
+
+instance Requestable AvailableMaps where
+  type ResponseOf AvailableMaps = [Map]
+  toRequest _ = defMessage& #availableMaps .~ defMessage
+  fromResponse _ = extractResponse (fmap makeMaps . view #maybe'availableMaps) -- TODO: Lensify fmap
+    where makeMaps :: A.ResponseAvailableMaps -> [Map]
+          makeMaps m = (LocalMap  <$> m ^. #localMapPaths <*> pure Nothing)
+                       ++ (BattlenetMap  <$> m ^. #battlenetMapNames)

+ src/Network/SC2/LowLevel/Split.hs view

@@ -0,0 +1,58 @@+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE GADTs #-}
+module Network.SC2.LowLevel.Split
+       ( module Control.Monad.Freer
+       , Split(..)
+       , suspend
+       , fork
+       , halt
+       , stepSplit
+       , runSplit
+       ) where
+
+import Control.Monad.Freer
+import Control.Monad.Freer.Internal (handleRelay)
+import Data.Maybe
+import Data.Sequence
+
+data Split a where
+  Split :: Maybe a -> Maybe a -> Split a
+
+suspend :: (Member Split r) => Eff r ()
+suspend = send (Split Nothing (Just ()))
+
+fork :: (Member Split r) => Eff r () -> Eff r ()
+fork t = do
+  side <- send (Split (Just False) (Just True))
+  case side of
+    False -> return ()
+    True  -> t >> halt
+
+halt :: (Member Split r) => Eff r a
+halt = send (Split Nothing Nothing)
+
+-- threads to run now, and threads to run later
+data Status r = Status (Maybe (Eff r (Status r))) (Maybe (Eff r (Status r)))
+
+stepSplit :: Eff (Split ': r) () -> Eff r (Status r)
+stepSplit = handleRelay (\_ -> pure (Status Nothing Nothing)) go
+  where
+    go (Split now later) next = pure (Status (fmap next now) (fmap next later))
+
+runSplit :: Eff (Split ': r) () -> Eff r ()
+runSplit = go empty . stepSplit
+  where
+    go :: Seq (Eff r (Status r)) -> Eff r (Status r) -> Eff r ()
+    go threads act = do
+      Status now later <- act
+      let newthreads = catMaybe now threads later
+      case viewl newthreads of
+        EmptyL  -> pure ()
+        t :< ts -> go ts t
+
+    catMaybe :: Maybe a -> Seq a -> Maybe a -> Seq a
+    catMaybe mx t my = (maybe id (flip (|>)) my . maybe id (<|) mx) t

+ src/Network/SC2/LowLevel/Types.hs view

@@ -0,0 +1,157 @@+{-#LANGUAGE RankNTypes, DataKinds, ConstraintKinds, FlexibleContexts, GADTs, StandaloneDeriving, GeneralisedNewtypeDeriving, TypeSynonymInstances, FlexibleInstances#-}
+module Network.SC2.LowLevel.Types
+  ( module Network.SC2.LowLevel.Types
+  , A.Difficulty(..)
+  , A.Status(..)
+--  , R.Alliance(..)
+  , R.CloakState(..)
+  ,
+  ) where
+
+import Data.Void
+import qualified Proto.S2clientprotocol.Sc2api as A
+import qualified Proto.S2clientprotocol.Raw as R
+import qualified Data.ByteString as BS
+import Lens.Labels (HasLens')
+import Data.Text
+import Data.Word
+import Data.Functor.Identity
+import Network.SC2.Constants.Entities
+import Data.Coerce
+type Point = (Float, Float)
+type PointI = (Int,Int)
+-- FIXME better image format
+data ImageData = ImageData Int (Int, Int) BS.ByteString
+  deriving (Show, Eq)
+
+data Race' a = Terran
+             | Zerg
+             | Protoss
+             | Random a
+             deriving (Show, Eq)
+
+type Race = Race' ()
+type RaceResolved = Race' (Maybe (Race' Void))
+
+data Interface c = Raw | Score | FeatureLayer c | Render c
+                 deriving (Show, Eq)
+
+newtype PlayerID = PlayerID Int
+                 deriving (Show, Eq)
+
+data Player r = Observer
+              | Participant r
+              | Computer r A.Difficulty
+              deriving (Show, Eq)
+
+data Map = BattlenetMap Text
+         | LocalMap Text (Maybe BS.ByteString)
+         deriving (Show, Eq)
+
+
+data ChatChannel = Broadcast | Team deriving (Eq, Show)
+
+type RawTag = Word64
+
+newtype UnitID = UnitID {unRawTag :: RawTag} deriving (Eq, Show)
+type Alliance = R.Alliance
+data Unit = Unit {
+    tag :: UnitID,
+    unitType :: UnitType,
+    alliance :: Alliance,
+    owner :: PlayerID
+} deriving (Eq, Show)
+
+type IdentifiesUnit a = Lens.Labels.HasLens' a "unitTag" RawTag
+
+
+data Target where
+  TargetPoint :: Point -> Target
+--  TargetScreen :: PointI -> Target
+--  TargetMinimap :: PointI -> Target
+  TargetUnit :: UnitID -> Target
+
+deriving instance Eq Target
+deriving instance Show Target
+
+class Targetable a where
+  asTarget :: a -> Target
+
+instance Targetable Point where
+  asTarget = TargetPoint
+
+instance Targetable Unit where
+  asTarget = TargetUnit . tag
+
+instance Targetable Target where
+  asTarget = id
+
+data GameInfo = GameInfo
+              deriving (Show, Eq)
+
+data GameInfoResponse =
+  GameInfoResponse
+  { mapName :: Text
+  , modNames :: [Text]
+  , localMapPath :: FilePath
+  , playerInfo :: [(PlayerID, Player RaceResolved)]
+  , startRaw :: Maybe StartRaw
+  , interfaces :: [Interface ()]
+  } deriving (Eq, Show)
+
+data StartRaw =
+  StartRaw
+  { mapSize :: (Int, Int)
+  , pathingGrid :: ImageData
+  , terrainHeight :: ImageData
+  , placementGrid :: ImageData
+  , playableArea :: ((Int, Int), (Int, Int))
+  , startLocations :: [Point]
+  } deriving (Eq, Show)
+data PlayerCommon = PlayerCommon 
+  {
+    playerID :: Int,
+    minerals :: Int,
+    vespene :: Int
+
+ --TODO
+  }
+
+data PlayerResources = PlayerResources
+
+type UnitContainer = [Unit]
+
+data Units where
+      ControlGroup :: GroupID ->  Units
+      Ungrouped :: UnitContainer -> Units
+  
+
+
+unitsToTags :: Units -> [RawTag]
+unitsToTags (Ungrouped u) = fmap (coerce . tag) u
+
+individualUnit :: Unit -> Units
+individualUnit u = Ungrouped ([u])
+  
+  
+data MapInfo = MapInfo
+data Order = Order {
+    abilityID :: AbilityType,
+    target :: Target,
+    queue :: Bool
+}
+
+class Orderable a where
+  toIDs :: a -> [UnitID]
+
+instance Orderable Units where
+  toIDs (Ungrouped u) = fmap tag u
+instance Orderable Unit where
+  toIDs u = [tag u]
+instance Orderable UnitContainer where
+  toIDs = fmap tag
+
+toTags :: Orderable a => a -> [RawTag]
+toTags = fmap (coerce) . toIDs
+
+newtype GroupID = GroupID Word deriving (Eq, Show, Enum, Bounded)