{-# 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.Foldable (toList)
import Data.IORef (IORef, readIORef)
import Data.IntMap qualified as IM
import Data.Maybe (fromMaybe)
import Data.Text qualified as T
import Network.Wai qualified
import Network.Wai.Handler.Warp qualified as Warp
import Servant
import Swarm.Game.Robot
import Swarm.Game.Scenario.Objective
import Swarm.Game.Scenario.Objective.Graph
import Swarm.Game.Scenario.Objective.Presentation.Model
import Swarm.Game.Scenario.Objective.WinCheck
import Swarm.Game.State
import Swarm.TUI.Model
import Swarm.TUI.Model.UI
import System.Timeout (timeout)

type SwarmApi =
  "robots" :> Get '[JSON] [Robot]
    :<|> "robot" :> Capture "id" Int :> Get '[JSON] (Maybe Robot)
    :<|> "goals" :> "prereqs" :> Get '[JSON] [PrereqSatisfaction]
    :<|> "goals" :> "active" :> Get '[JSON] [Objective]
    :<|> "goals" :> "graph" :> Get '[JSON] (Maybe GraphInfo)
    :<|> "goals" :> "uigoal" :> Get '[JSON] GoalTracking
    :<|> "goals" :> Get '[JSON] WinCondition
    :<|> "repl" :> "history" :> "full" :> Get '[JSON] [T.Text]

mkApp :: IORef AppState -> Servant.Server SwarmApi
mkApp :: IORef AppState -> Server SwarmApi
mkApp IORef AppState
appStateRef =
  Handler [Robot]
robotsHandler
    forall a b. a -> b -> a :<|> b
:<|> forall {m :: * -> *}. MonadIO m => Port -> m (Maybe Robot)
robotHandler
    forall a b. a -> b -> a :<|> b
:<|> Handler [PrereqSatisfaction]
prereqsHandler
    forall a b. a -> b -> a :<|> b
:<|> Handler [Objective]
activeGoalsHandler
    forall a b. a -> b -> a :<|> b
:<|> Handler (Maybe GraphInfo)
goalsGraphHandler
    forall a b. a -> b -> a :<|> b
:<|> Handler GoalTracking
uiGoalHandler
    forall a b. a -> b -> a :<|> b
:<|> Handler WinCondition
goalsHandler
    forall a b. a -> b -> a :<|> b
:<|> Handler [Text]
replHandler
 where
  robotsHandler :: Handler [Robot]
robotsHandler = do
    AppState
appState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef AppState
appStateRef)
    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
$ AppState
appState forall s a. s -> Getting a s a -> a
^. Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState (IntMap Robot)
robotMap
  robotHandler :: Port -> m (Maybe Robot)
robotHandler Port
rid = do
    AppState
appState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef AppState
appStateRef)
    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 (AppState
appState forall s a. s -> Getting a s a -> a
^. Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState (IntMap Robot)
robotMap)
  prereqsHandler :: Handler [PrereqSatisfaction]
prereqsHandler = do
    AppState
appState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef AppState
appStateRef)
    case AppState
appState forall s a. s -> Getting a s a -> a
^. Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState WinCondition
winCondition of
      WinConditions WinStatus
_winState ObjectiveCompletion
oc -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ObjectiveCompletion -> [PrereqSatisfaction]
getSatisfaction ObjectiveCompletion
oc
      WinCondition
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
  activeGoalsHandler :: Handler [Objective]
activeGoalsHandler = do
    AppState
appState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef AppState
appStateRef)
    case AppState
appState forall s a. s -> Getting a s a -> a
^. Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState WinCondition
winCondition of
      WinConditions WinStatus
_winState ObjectiveCompletion
oc -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ObjectiveCompletion -> [Objective]
getActiveObjectives ObjectiveCompletion
oc
      WinCondition
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
  goalsGraphHandler :: Handler (Maybe GraphInfo)
goalsGraphHandler = do
    AppState
appState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef AppState
appStateRef)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case AppState
appState forall s a. s -> Getting a s a -> a
^. Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState WinCondition
winCondition of
      WinConditions WinStatus
_winState ObjectiveCompletion
oc -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ObjectiveCompletion -> GraphInfo
makeGraphInfo ObjectiveCompletion
oc
      WinCondition
_ -> forall a. Maybe a
Nothing
  uiGoalHandler :: Handler GoalTracking
uiGoalHandler = do
    AppState
appState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef AppState
appStateRef)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AppState
appState forall s a. s -> Getting a s a -> a
^. Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState GoalDisplay
uiGoal forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GoalDisplay GoalTracking
goalsContent
  goalsHandler :: Handler WinCondition
goalsHandler = do
    AppState
appState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef AppState
appStateRef)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ AppState
appState forall s a. s -> Getting a s a -> a
^. Lens' AppState GameState
gameState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' GameState WinCondition
winCondition
  replHandler :: Handler [Text]
replHandler = do
    AppState
appState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef AppState
appStateRef)
    let replHistorySeq :: Seq REPLHistItem
replHistorySeq = AppState
appState forall s a. s -> Getting a s a -> a
^. Lens' AppState UIState
uiState forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' UIState REPLState
uiREPL forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' REPLState REPLHistory
replHistory forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' REPLHistory (Seq REPLHistItem)
replSeq
        items :: [Text]
items = [Text
x | REPLEntry Text
x <- forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq REPLHistItem
replHistorySeq]
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [Text]
items

webMain :: Maybe (MVar (Either String ())) -> Warp.Port -> IORef AppState -> IO ()
webMain :: Maybe (MVar (Either String ())) -> Port -> IORef AppState -> IO ()
webMain Maybe (MVar (Either String ()))
baton Port
port IORef AppState
appStateRef = 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 AppState -> Server SwarmApi
mkApp IORef AppState
appStateRef)
  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 AppState -> IO (Either String Warp.Port)
-- User explicitly provided port '0': don't run the web server
startWebThread :: Maybe Port -> IORef AppState -> IO (Either String Port)
startWebThread (Just Port
0) IORef AppState
_ = 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 AppState
appStateRef = 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 AppState -> IO ()
webMain (forall a. a -> Maybe a
Just MVar (Either String ())
baton) Port
port IORef AppState
appStateRef
  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