{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}

-- | Rollback and replay based game networking
module Alpaca.NetCode.Advanced
  ( -- * Server
    runServerWith,
    module Alpaca.NetCode.Internal.Server,
    -- * Client
    runClientWith,
    module Alpaca.NetCode.Internal.Client,
    -- * Common Types
    SimNetConditions (..),
    Tick (..),
    PlayerId (..),
    NetMsg,
    HostName,
    ServiceName,
  ) where

import Alpaca.NetCode.Internal.Common
import Alpaca.NetCode.Internal.Client
import Alpaca.NetCode.Internal.Server
import Control.Concurrent (
  Chan,
  forkIO,
  newChan,
  readChan,
  writeChan,
 )
import qualified Control.Exception as E
import Control.Monad
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Map as M
import Flat (
  DecodeException (BadEncoding),
  Flat,
  flat,
  unflat,
 )
import Network.Run.UDP (runUDPServer)
import Network.Socket (
  AddrInfo (
    addrAddress,
    addrFamily,
    addrFlags,
    addrProtocol,
    addrSocketType
  ),
  AddrInfoFlag (AI_PASSIVE),
  HostName,
  ServiceName,
  SockAddr,
  Socket,
  SocketType (Datagram),
  close,
  connect,
  defaultHints,
  getAddrInfo,
  socket,
  withSocketsDo,
 )
import qualified Network.Socket.ByteString as NBS

-- | Start a client. This blocks until the initial handshake with the server is
-- finished.
runClientWith ::
  forall world input.
  Flat input =>
  -- | The server's host name or IP address e.g. @"localhost"@.
  HostName ->
  -- | The server's port number e.g. @"8111"@.
  ServiceName ->
  -- | Optional simulation of network conditions. In production this should be
  -- `Nothing`. May differ between clients.
  Maybe SimNetConditions ->
  -- | The 'defaultClientConfig' works well for most cases.
  ClientConfig ->
  -- | Initial input for new players. Must be the same across all clients and
  -- the server. See 'Alpaca.NetCode.runClient'.
  input ->
  -- | Initial world state. Must be the same across all clients.
  world ->
  -- | A deterministic stepping function (for a single tick). Must be the same
  -- across all clients and the server. See 'Alpaca.NetCode.runClient'.
  ( M.Map PlayerId input ->
    Tick ->
    world ->
    world
  ) ->
  IO (Client world input)
runClientWith :: HostName
-> HostName
-> Maybe SimNetConditions
-> ClientConfig
-> input
-> world
-> (Map PlayerId input -> Tick -> world -> world)
-> IO (Client world input)
runClientWith
  HostName
serverHostName
  HostName
serverPort
  Maybe SimNetConditions
simNetConditionsMay
  ClientConfig
clientConfig
  input
input0
  world
world0
  Map PlayerId input -> Tick -> world -> world
stepOneTick = do
    Chan (NetMsg input)
sendChan <- IO (Chan (NetMsg input))
forall a. IO (Chan a)
newChan
    Chan (NetMsg input)
recvChan <- IO (Chan (NetMsg input))
forall a. IO (Chan a)
newChan

    -- UDP
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
      HostName -> HostName -> (Socket -> SockAddr -> IO ()) -> IO ()
forall a.
HostName -> HostName -> (Socket -> SockAddr -> IO a) -> IO a
runUDPClient' HostName
serverHostName HostName
serverPort ((Socket -> SockAddr -> IO ()) -> IO ())
-> (Socket -> SockAddr -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock SockAddr
server -> do
        ThreadId
_ <-
          IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$
            Maybe SockAddr
-> ((NetMsg input, SockAddr) -> NetMsg input)
-> Chan (NetMsg input)
-> Socket
-> IO ()
forall input a.
Flat input =>
Maybe SockAddr
-> ((NetMsg input, SockAddr) -> a) -> Chan a -> Socket -> IO ()
writeDatagramContentsAsNetMsg (SockAddr -> Maybe SockAddr
forall a. a -> Maybe a
Just SockAddr
server) (NetMsg input, SockAddr) -> NetMsg input
forall a b. (a, b) -> a
fst Chan (NetMsg input)
recvChan Socket
sock
        IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          NetMsg input
msg <- Chan (NetMsg input) -> IO (NetMsg input)
forall a. Chan a -> IO a
readChan Chan (NetMsg input)
sendChan
          Socket -> ByteString -> SockAddr -> IO ()
NBS.sendAllTo Socket
sock (NetMsg input -> ByteString
forall a. Flat a => a -> ByteString
flat NetMsg input
msg) SockAddr
server

    (NetMsg input -> IO ())
-> IO (NetMsg input)
-> Maybe SimNetConditions
-> ClientConfig
-> input
-> world
-> (Map PlayerId input -> Tick -> world -> world)
-> IO (Client world input)
forall world input.
Flat input =>
(NetMsg input -> IO ())
-> IO (NetMsg input)
-> Maybe SimNetConditions
-> ClientConfig
-> input
-> world
-> (Map PlayerId input -> Tick -> world -> world)
-> IO (Client world input)
runClientWith'
      (Chan (NetMsg input) -> NetMsg input -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (NetMsg input)
sendChan)
      (Chan (NetMsg input) -> IO (NetMsg input)
forall a. Chan a -> IO a
readChan Chan (NetMsg input)
recvChan)
      Maybe SimNetConditions
simNetConditionsMay
      ClientConfig
clientConfig
      input
input0
      world
world0
      Map PlayerId input -> Tick -> world -> world
stepOneTick
 where
  --
  -- Coppied from network-run
  --

  runUDPClient' ::
    HostName -> ServiceName -> (Socket -> SockAddr -> IO a) -> IO a
  runUDPClient' :: HostName -> HostName -> (Socket -> SockAddr -> IO a) -> IO a
runUDPClient' HostName
host HostName
port Socket -> SockAddr -> IO a
client = IO a -> IO a
forall a. IO a -> IO a
withSocketsDo (IO a -> IO a) -> IO a -> IO a
forall a b. (a -> b) -> a -> b
$ do
    AddrInfo
addr <- SocketType -> Maybe HostName -> HostName -> Bool -> IO AddrInfo
resolve SocketType
Datagram (HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
host) HostName
port Bool
False
    let sockAddr :: SockAddr
sockAddr = AddrInfo -> SockAddr
addrAddress AddrInfo
addr
    IO Socket -> (Socket -> IO ()) -> (Socket -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (AddrInfo -> IO Socket
openSocket AddrInfo
addr) Socket -> IO ()
close ((Socket -> IO a) -> IO a) -> (Socket -> IO a) -> IO a
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> Socket -> SockAddr -> IO a
client Socket
sock SockAddr
sockAddr

  resolve :: SocketType -> Maybe HostName -> ServiceName -> Bool -> IO AddrInfo
  resolve :: SocketType -> Maybe HostName -> HostName -> Bool -> IO AddrInfo
resolve SocketType
socketType Maybe HostName
mhost HostName
port Bool
passive =
    [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 HostName -> Maybe HostName -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) Maybe HostName
mhost (HostName -> Maybe HostName
forall a. a -> Maybe a
Just HostName
port)
   where
    hints :: AddrInfo
hints =
      AddrInfo
defaultHints
        { addrSocketType :: SocketType
addrSocketType = SocketType
socketType
        , addrFlags :: [AddrInfoFlag]
addrFlags = if Bool
passive then [AddrInfoFlag
AI_PASSIVE] else []
        }

  openSocket :: AddrInfo -> IO Socket
  openSocket :: AddrInfo -> IO Socket
openSocket AddrInfo
addr = do
    Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr)
    Socket -> SockAddr -> IO ()
connect Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
addr)
    Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock

-- | Run a server for a single game. This will block until the game ends,
-- specifically when all players have disconnected.
runServerWith ::
  forall input.
  (Eq input, Flat input) =>
  -- | The server's port number e.g. @"8111"@.
  ServiceName ->
  -- | Optional simulation of network conditions. In production this should be
  -- `Nothing`.
  Maybe SimNetConditions ->
  -- | The 'defaultServerConfig' works well for most cases.
  ServerConfig ->
  -- | Initial input for new players. Must be the same across all clients and
  -- the server.
  input ->
  IO ()
runServerWith :: HostName
-> Maybe SimNetConditions -> ServerConfig -> input -> IO ()
runServerWith HostName
serverPort Maybe SimNetConditions
tickRate ServerConfig
netConfig input
input0 = do
  Chan (NetMsg input, SockAddr)
sendChan <- IO (Chan (NetMsg input, SockAddr))
forall a. IO (Chan a)
newChan
  Chan (NetMsg input, SockAddr)
recvChan <- IO (Chan (NetMsg input, SockAddr))
forall a. IO (Chan a)
newChan

  -- UDP
  ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ do
    Maybe HostName -> HostName -> (Socket -> IO ()) -> IO ()
forall a. Maybe HostName -> HostName -> (Socket -> IO a) -> IO a
runUDPServer Maybe HostName
forall a. Maybe a
Nothing HostName
serverPort ((Socket -> IO ()) -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Socket
sock -> do
      ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Maybe SockAddr
-> ((NetMsg input, SockAddr) -> (NetMsg input, SockAddr))
-> Chan (NetMsg input, SockAddr)
-> Socket
-> IO ()
forall input a.
Flat input =>
Maybe SockAddr
-> ((NetMsg input, SockAddr) -> a) -> Chan a -> Socket -> IO ()
writeDatagramContentsAsNetMsg Maybe SockAddr
forall a. Maybe a
Nothing (NetMsg input, SockAddr) -> (NetMsg input, SockAddr)
forall a. a -> a
id Chan (NetMsg input, SockAddr)
recvChan Socket
sock
      IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        (NetMsg input
msg, SockAddr
addr) <- Chan (NetMsg input, SockAddr) -> IO (NetMsg input, SockAddr)
forall a. Chan a -> IO a
readChan Chan (NetMsg input, SockAddr)
sendChan
        Socket -> ByteString -> SockAddr -> IO ()
NBS.sendAllTo Socket
sock (NetMsg input -> ByteString
forall a. Flat a => a -> ByteString
flat NetMsg input
msg) SockAddr
addr

  (NetMsg input -> SockAddr -> IO ())
-> IO (NetMsg input, SockAddr)
-> Maybe SimNetConditions
-> ServerConfig
-> input
-> IO ()
forall input clientAddress.
(Eq input, Flat input, Show clientAddress, Ord clientAddress) =>
(NetMsg input -> clientAddress -> IO ())
-> IO (NetMsg input, clientAddress)
-> Maybe SimNetConditions
-> ServerConfig
-> input
-> IO ()
runServerWith'
    (((NetMsg input, SockAddr) -> IO ())
-> NetMsg input -> SockAddr -> IO ()
forall a b c. ((a, b) -> c) -> a -> b -> c
curry (Chan (NetMsg input, SockAddr) -> (NetMsg input, SockAddr) -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan (NetMsg input, SockAddr)
sendChan))
    (Chan (NetMsg input, SockAddr) -> IO (NetMsg input, SockAddr)
forall a. Chan a -> IO a
readChan Chan (NetMsg input, SockAddr)
recvChan)
    Maybe SimNetConditions
tickRate
    ServerConfig
netConfig
    input
input0

-- Forever decode messages from the input socket using the given decoding
-- function and writing it to the given chan. Loops forever.
writeDatagramContentsAsNetMsg ::
  forall input a.
  (Flat input) =>
  -- | Just the sender if alwalys receiving from the same address (used in the client case where we only receive from the server)
  (Maybe SockAddr) ->
  -- | Decode the messages
  ((NetMsg input, SockAddr) -> a) ->
  -- | Write decoded msgs to this chan
  Chan a ->
  -- | Read from this socket
  Socket ->
  IO ()
writeDatagramContentsAsNetMsg :: Maybe SockAddr
-> ((NetMsg input, SockAddr) -> a) -> Chan a -> Socket -> IO ()
writeDatagramContentsAsNetMsg Maybe SockAddr
constSenderMay (NetMsg input, SockAddr) -> a
f Chan a
chan Socket
sock = IO ()
go
 where
  go :: IO ()
go = do
    let maxBytes :: Int
maxBytes = Int
4096
    (ByteString
bs, SockAddr
sender) <- case Maybe SockAddr
constSenderMay of
      Maybe SockAddr
Nothing -> Socket -> Int -> IO (ByteString, SockAddr)
NBS.recvFrom Socket
sock Int
maxBytes
      Just SockAddr
s -> (,SockAddr
s) (ByteString -> (ByteString, SockAddr))
-> IO ByteString -> IO (ByteString, SockAddr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Socket -> Int -> IO ByteString
NBS.recv Socket
sock Int
maxBytes
    if ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
maxBytes
      then
        HostName -> IO ()
forall a. HasCallStack => HostName -> a
error (HostName -> IO ()) -> HostName -> IO ()
forall a b. (a -> b) -> a -> b
$
          HostName
"TODO support packets bigger than "
            HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ Int -> HostName
forall a. Show a => a -> HostName
show Int
maxBytes
            HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ HostName
" bytes."
      else
        if ByteString -> Int
BS.length ByteString
bs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
          then HostName -> IO ()
debugStrLn HostName
"Received 0 bytes from socket. Stopping."
          else do
            case ByteString -> Decoded (NetMsg input)
forall a b. (Flat a, AsByteString b) => b -> Decoded a
unflat @(NetMsg input) (ByteString -> ByteString
BSL.fromStrict ByteString
bs) of
              Left DecodeException
err -> do
                HostName -> IO ()
debugStrLn (HostName -> IO ()) -> HostName -> IO ()
forall a b. (a -> b) -> a -> b
$
                  HostName
"Error decoding message: " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ case DecodeException
err of
                    BadEncoding Env
env HostName
errStr ->
                      HostName
"BadEncoding " HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ Env -> HostName
forall a. Show a => a -> HostName
show Env
env HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ HostName
"\n" HostName -> HostName -> HostName
forall a. [a] -> [a] -> [a]
++ HostName
errStr
                    DecodeException
_ -> DecodeException -> HostName
forall a. Show a => a -> HostName
show DecodeException
err
              Right NetMsg input
msg -> Chan a -> a -> IO ()
forall a. Chan a -> a -> IO ()
writeChan Chan a
chan ((NetMsg input, SockAddr) -> a
f (NetMsg input
msg, SockAddr
sender))
            IO ()
go