Requests.hs

{-#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)