{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

-- |
-- SPDX-License-Identifier: BSD-3-Clause
--
-- 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 Brick.BChan
import Commonmark qualified as Mark (commonmark, renderHtml)
import Control.Arrow (left)
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.ByteString.Lazy (ByteString)
import Data.Foldable (toList)
import Data.IntMap qualified as IM
import Data.Maybe (fromMaybe)
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Lazy.Encoding (encodeUtf8)
import Data.Tree (Tree (Node), drawTree)
import Network.HTTP.Types (ok200)
import Network.Wai (responseLBS)
import Network.Wai qualified
import Network.Wai.Handler.Warp qualified as Warp
import Servant
import Servant.Docs (ToCapture)
import Servant.Docs qualified as SD
import Swarm.Game.Robot
import Swarm.Game.Scenario.Objective
import Swarm.Game.Scenario.Objective.Graph
import Swarm.Game.Scenario.Objective.WinCheck
import Swarm.Game.State
import Swarm.Language.Module
import Swarm.Language.Pipeline
import Swarm.Language.Pretty (prettyString)
import Swarm.Language.Syntax
import Swarm.ReadableIORef
import Swarm.TUI.Model
import Swarm.TUI.Model.Goal
import Swarm.TUI.Model.UI
import System.Timeout (timeout)
import Text.Read (readEither)
import Witch (into)

newtype RobotID = RobotID Int

instance FromHttpApiData RobotID where
  parseUrlPiece :: Text -> Either Text RobotID
parseUrlPiece = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Port -> RobotID
RobotID forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Read a => String -> Either String a
readEither forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack

instance SD.ToSample T.Text where
  toSamples :: Proxy Text -> [(Text, Text)]
toSamples Proxy Text
_ = forall a. [(Text, a)]
SD.noSamples

type SwarmAPI =
  "robots" :> Get '[JSON] [Robot]
    :<|> "robot" :> Capture "id" RobotID :> 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
    :<|> "code" :> "render" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text
    :<|> "code" :> "run" :> ReqBody '[PlainText] T.Text :> Post '[PlainText] T.Text
    :<|> "repl" :> "history" :> "full" :> Get '[JSON] [REPLHistItem]

instance ToCapture (Capture "id" RobotID) where
  toCapture :: Proxy (Capture "id" RobotID) -> DocCapture
toCapture Proxy (Capture "id" RobotID)
_ =
    String -> String -> DocCapture
SD.DocCapture
      String
"id" -- name
      String
"(integer) robot ID" -- description

swarmApi :: Proxy SwarmAPI
swarmApi :: Proxy SwarmAPI
swarmApi = forall {k} (t :: k). Proxy t
Proxy

type ToplevelAPI = SwarmAPI :<|> Raw

api :: Proxy ToplevelAPI
api :: Proxy ToplevelAPI
api = forall {k} (t :: k). Proxy t
Proxy

docsBS :: ByteString
docsBS :: ByteString
docsBS =
  Text -> ByteString
encodeUtf8
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a. HasCallStack => String -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) (forall a. Html a -> Text
Mark.renderHtml @())
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall il bl.
IsBlock il bl =>
String -> Text -> Either ParseError bl
Mark.commonmark String
""
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
T.pack
    forall b c a. (b -> c) -> (a -> b) -> a -> c
. RenderingOptions -> API -> String
SD.markdownWith
      ( RenderingOptions
SD.defRenderingOptions
          forall a b. a -> (a -> b) -> b
& Lens' RenderingOptions ShowContentTypes
SD.requestExamples forall s t a b. ASetter s t a b -> b -> s -> t
.~ ShowContentTypes
SD.FirstContentType
          forall a b. a -> (a -> b) -> b
& Lens' RenderingOptions ShowContentTypes
SD.responseExamples forall s t a b. ASetter s t a b -> b -> s -> t
.~ ShowContentTypes
SD.FirstContentType
      )
    forall a b. (a -> b) -> a -> b
$ forall {k} (api :: k).
HasDocs api =>
[DocIntro] -> Proxy api -> API
SD.docsWithIntros [DocIntro
intro] Proxy SwarmAPI
swarmApi
 where
  intro :: DocIntro
intro = String -> [String] -> DocIntro
SD.DocIntro String
"Swarm Web API" [String
"All of the valid endpoints are documented below."]

mkApp ::
  ReadableIORef AppState ->
  -- | Writable
  BChan AppEvent ->
  Servant.Server SwarmAPI
mkApp :: ReadableIORef AppState -> BChan AppEvent -> Server SwarmAPI
mkApp ReadableIORef AppState
appStateRef BChan AppEvent
chan =
  Handler [Robot]
robotsHandler
    forall a b. a -> b -> a :<|> b
:<|> forall {m :: * -> *}. MonadIO m => RobotID -> 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
:<|> forall {m :: * -> *}. Monad m => Text -> m Text
codeRenderHandler
    forall a b. a -> b -> a :<|> b
:<|> forall {m :: * -> *}. MonadIO m => Text -> m Text
codeRunHandler
    forall a b. a -> b -> a :<|> b
:<|> Handler [REPLHistItem]
replHandler
 where
  robotsHandler :: Handler [Robot]
robotsHandler = do
    AppState
appState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. ReadableIORef a -> IO a
readIORef ReadableIORef 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 :: RobotID -> m (Maybe Robot)
robotHandler (RobotID Port
rid) = do
    AppState
appState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. ReadableIORef a -> IO a
readIORef ReadableIORef 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. ReadableIORef a -> IO a
readIORef ReadableIORef 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. ReadableIORef a -> IO a
readIORef ReadableIORef 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. ReadableIORef a -> IO a
readIORef ReadableIORef 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. ReadableIORef a -> IO a
readIORef ReadableIORef 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. ReadableIORef a -> IO a
readIORef ReadableIORef 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
  codeRenderHandler :: Text -> m Text
codeRenderHandler Text
contents = do
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Text -> Either Text ProcessedTerm
processTermEither Text
contents of
      Right (ProcessedTerm (Module stx :: Syntax' Polytype
stx@(Syntax' SrcLoc
_srcLoc Term' Polytype
_term Polytype
_) Ctx Polytype
_) Requirements
_ ReqCtx
_) ->
        forall target source. From source target => source -> target
into @Text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree String -> String
drawTree forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. PrettyPrec a => a -> String
prettyString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a r. Plated a => (a -> [r] -> r) -> a -> r
para forall a. a -> [Tree a] -> Tree a
Node forall a b. (a -> b) -> a -> b
$ Syntax' Polytype
stx
      Left Text
x -> Text
x
  codeRunHandler :: Text -> m Text
codeRunHandler Text
contents = do
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. BChan a -> a -> IO ()
writeBChan BChan AppEvent
chan forall b c a. (b -> c) -> (a -> b) -> a -> c
. WebCommand -> AppEvent
Web forall a b. (a -> b) -> a -> b
$ Text -> WebCommand
RunWebCode Text
contents
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
"Sent\n"
  replHandler :: Handler [REPLHistItem]
replHandler = do
    AppState
appState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. ReadableIORef a -> IO a
readIORef ReadableIORef 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 :: [REPLHistItem]
items = forall (t :: * -> *) a. Foldable t => t a -> [a]
toList Seq REPLHistItem
replHistorySeq
    forall (f :: * -> *) a. Applicative f => a -> f a
pure [REPLHistItem]
items

-- | Simple result type to report errors from forked startup thread.
data WebStartResult = WebStarted | WebStartError String

webMain ::
  Maybe (MVar WebStartResult) ->
  Warp.Port ->
  ReadableIORef AppState ->
  -- | Writable
  BChan AppEvent ->
  IO ()
webMain :: Maybe (MVar WebStartResult)
-> Port -> ReadableIORef AppState -> BChan AppEvent -> IO ()
webMain Maybe (MVar WebStartResult)
baton Port
port ReadableIORef AppState
appStateRef BChan AppEvent
chan = 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 WebStartResult)
baton of
    Just MVar WebStartResult
mv -> IO () -> Settings -> Settings
Warp.setBeforeMainLoop forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO ()
putMVar MVar WebStartResult
mv WebStartResult
WebStarted
    Maybe (MVar WebStartResult)
Nothing -> forall a. a -> a
id

  server :: Server ToplevelAPI
  server :: Server ToplevelAPI
server = ReadableIORef AppState -> BChan AppEvent -> Server SwarmAPI
mkApp ReadableIORef AppState
appStateRef BChan AppEvent
chan forall a b. a -> b -> a :<|> b
:<|> forall {k} (s :: k) b. b -> Tagged s b
Tagged forall {p} {b}. p -> (Response -> b) -> b
serveDocs
   where
    serveDocs :: p -> (Response -> b) -> b
serveDocs p
_ Response -> b
resp =
      Response -> b
resp forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS Status
ok200 [(HeaderName, ByteString)
plain] ByteString
docsBS
    plain :: (HeaderName, ByteString)
plain = (HeaderName
"Content-Type", ByteString
"text/html")

  app :: Network.Wai.Application
  app :: Application
app = forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
Servant.serve Proxy ToplevelAPI
api Server ToplevelAPI
server

  handleErr :: IOException -> IO ()
  handleErr :: IOException -> IO ()
handleErr IOException
e = case Maybe (MVar WebStartResult)
baton of
    Just MVar WebStartResult
mv -> forall a. MVar a -> a -> IO ()
putMVar MVar WebStartResult
mv (String -> WebStartResult
WebStartError forall a b. (a -> b) -> a -> b
$ forall e. Exception e => e -> String
displayException IOException
e)
    Maybe (MVar WebStartResult)
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 ->
  -- | Read-only reference to the application state.
  ReadableIORef AppState ->
  -- | Writable channel to send events to the game
  BChan AppEvent ->
  IO (Either String Warp.Port)
-- User explicitly provided port '0': don't run the web server
startWebThread :: Maybe Port
-> ReadableIORef AppState
-> BChan AppEvent
-> IO (Either String Port)
startWebThread (Just Port
0) ReadableIORef AppState
_ BChan AppEvent
_ = 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
userPort ReadableIORef AppState
appStateRef BChan AppEvent
chan = do
  MVar WebStartResult
baton <- forall a. IO (MVar a)
newEmptyMVar
  let port :: Port
port = forall a. a -> Maybe a -> a
fromMaybe Port
defaultPort Maybe Port
userPort
      failMsg :: String
failMsg = String
"Failed to start the web API on :" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Port
port
  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 WebStartResult)
-> Port -> ReadableIORef AppState -> BChan AppEvent -> IO ()
webMain (forall a. a -> Maybe a
Just MVar WebStartResult
baton) Port
port ReadableIORef AppState
appStateRef BChan AppEvent
chan
  Maybe WebStartResult
res <- forall a. Port -> IO a -> IO (Maybe a)
timeout Port
500_000 (forall a. MVar a -> IO a
takeMVar MVar WebStartResult
baton)
  case Maybe WebStartResult
res of
    Just WebStartResult
WebStarted -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. b -> Either a b
Right Port
port)
    Just (WebStartError 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
$ String
failMsg forall a. Semigroup a => a -> a -> a
<> String
" - " forall a. Semigroup a => a -> a -> a
<> String
e
    -- If user explicitly specified port exit, otherwise just report timeout
    Maybe WebStartResult
Nothing -> case Maybe Port
userPort of
      Just Port
_p -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
failMsg
      Maybe Port
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
$ String
failMsg forall a. Semigroup a => a -> a -> a
<> String
" (timeout)"