{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
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
startWebThread :: Maybe Warp.Port -> IORef AppState -> IO (Either String Warp.Port)
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
(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
(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
(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