{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

-- |
-- A web service for Swarm.
--
-- The service can be started using the `--port 5357` command line argument,
-- or through the REPL by calling `Swarm.App.demoWeb`.
--
-- Once running, here are the available endpoints:
--
--   * /robots : return the list of robots
--   * /robot/ID : return a single robot identified by its id
--
-- Missing endpoints:
--
--   * TODO: #625 run endpoint to load definitions
--   * TODO: #493 export the whole game state
module Swarm.Web where

import Control.Concurrent (forkIO)
import Control.Concurrent.MVar
import Control.Exception (Exception (displayException), IOException, catch, throwIO)
import Control.Lens ((^.))
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import Data.IORef (IORef, readIORef)
import Data.IntMap qualified as IM
import Data.Maybe (fromMaybe)
import Network.Wai qualified
import Network.Wai.Handler.Warp qualified as Warp
import Servant
import Swarm.Game.Robot
import Swarm.Game.State
import System.Timeout (timeout)

type SwarmApi =
  "robots" :> Get '[JSON] [Robot]
    :<|> "robot" :> Capture "id" Int :> Get '[JSON] (Maybe Robot)

mkApp :: IORef GameState -> Servant.Server SwarmApi
mkApp :: IORef GameState -> Server SwarmApi
mkApp IORef GameState
gsRef =
  Handler [Robot]
robotsHandler
    forall a b. a -> b -> a :<|> b
:<|> forall {m :: * -> *}. MonadIO m => Port -> m (Maybe Robot)
robotHandler
 where
  robotsHandler :: Handler [Robot]
robotsHandler = do
    GameState
g <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef GameState
gsRef)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. IntMap a -> [a]
IM.elems forall a b. (a -> b) -> a -> b
$ GameState
g forall s a. s -> Getting a s a -> a
^. Lens' GameState (IntMap Robot)
robotMap
  robotHandler :: Port -> m (Maybe Robot)
robotHandler Port
rid = do
    GameState
g <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef GameState
gsRef)
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Port -> IntMap a -> Maybe a
IM.lookup Port
rid (GameState
g forall s a. s -> Getting a s a -> a
^. Lens' GameState (IntMap Robot)
robotMap)

webMain :: Maybe (MVar (Either String ())) -> Warp.Port -> IORef GameState -> IO ()
webMain :: Maybe (MVar (Either String ())) -> Port -> IORef GameState -> IO ()
webMain Maybe (MVar (Either String ()))
baton Port
port IORef GameState
gsRef = forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Settings -> Application -> IO ()
Warp.runSettings Settings
settings Application
app) IOException -> IO ()
handleErr
 where
  settings :: Settings
settings = Port -> Settings -> Settings
Warp.setPort Port
port forall a b. (a -> b) -> a -> b
$ Settings -> Settings
onReady Settings
Warp.defaultSettings
  onReady :: Settings -> Settings
onReady = case Maybe (MVar (Either String ()))
baton of
    Just MVar (Either String ())
mv -> IO () -> Settings -> Settings
Warp.setBeforeMainLoop forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar (Either String ())
mv (forall a b. b -> Either a b
Right ())
    Maybe (MVar (Either String ()))
Nothing -> forall a. a -> a
id
  app :: Network.Wai.Application
  app :: Application
app = forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
Servant.serve (forall {k} (t :: k). Proxy t
Proxy @SwarmApi) (IORef GameState -> Server SwarmApi
mkApp IORef GameState
gsRef)
  handleErr :: IOException -> IO ()
  handleErr :: IOException -> IO ()
handleErr IOException
e = case Maybe (MVar (Either String ()))
baton of
    Just MVar (Either String ())
mv -> forall a. MVar a -> a -> IO ()
putMVar MVar (Either String ())
mv (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException IOException
e)
    Maybe (MVar (Either String ()))
Nothing -> forall e a. Exception e => e -> IO a
throwIO IOException
e

defaultPort :: Warp.Port
defaultPort :: Port
defaultPort = Port
5357

-- | Attempt to start a web thread on the requested port, or a default
--   one if none is requested (or don't start a web thread if the
--   requested port is 0).  If an explicit port was requested, fail if
--   startup doesn't work.  Otherwise, ignore the failure.  In any
--   case, return a @Maybe Port@ value representing whether a web
--   server is actually running, and if so, what port it is on.
startWebThread :: Maybe Warp.Port -> IORef GameState -> IO (Either String Warp.Port)
-- User explicitly provided port '0': don't run the web server
startWebThread :: Maybe Port -> IORef GameState -> IO (Either String Port)
startWebThread (Just Port
0) IORef GameState
_ = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left String
"The web port has been turned off."
startWebThread Maybe Port
portM IORef GameState
gsRef = do
  MVar (Either String ())
baton <- forall a. IO (MVar a)
newEmptyMVar
  let port :: Port
port = forall a. a -> Maybe a -> a
fromMaybe Port
defaultPort Maybe Port
portM
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ Maybe (MVar (Either String ())) -> Port -> IORef GameState -> IO ()
webMain (forall a. a -> Maybe a
Just MVar (Either String ())
baton) Port
port IORef GameState
gsRef
  Maybe (Either String ())
res <- forall a. Port -> IO a -> IO (Maybe a)
timeout Port
500_000 (forall a. MVar a -> IO a
takeMVar MVar (Either String ())
baton)
  case (Maybe Port
portM, Maybe (Either String ())
res) of
    -- User requested explicit port but server didn't start: fail
    (Just Port
_, Maybe (Either String ())
Nothing) -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ forall {a}. Show a => a -> String
failMsg Port
port
    -- If we are using the default port, we just report the timeout
    (Maybe Port
Nothing, Maybe (Either String ())
Nothing) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall {a}. Show a => a -> String
failMsg Port
port forall a. Semigroup a => a -> a -> a
<> String
" (timeout)"
    (Maybe Port
_, Just (Left String
e)) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall {a}. Show a => a -> String
failMsg Port
port forall a. Semigroup a => a -> a -> a
<> String
" - " forall a. Semigroup a => a -> a -> a
<> String
e
    -- If all works, we report on what port the web server is running
    (Maybe Port
_, Just Either String ()
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Port
port)
 where
  failMsg :: a -> String
failMsg a
p = String
"Failed to start the web API on :" forall a. Semigroup a => a -> a -> a
<> forall {a}. Show a => a -> String
show a
p