{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Swarm.Web (
startWebThread,
defaultPort,
SwarmAPI,
swarmApiHtml,
swarmApiMarkdown,
webMain,
) 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 Servant.Docs.Internal qualified as SD (renderCurlBasePath)
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 (prettyTextLine)
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
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]
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
swarmApiHtml :: ByteString
swarmApiHtml :: ByteString
swarmApiHtml =
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 a b. (a -> b) -> a -> b
$ String -> Text
T.pack String
swarmApiMarkdown
swarmApiMarkdown :: String
swarmApiMarkdown :: String
swarmApiMarkdown =
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 -> (a -> b) -> b
& Lens' RenderingOptions (Maybe String)
SD.renderCurlBasePath forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ String
"http://localhost:" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> String
show Port
defaultPort
)
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 ->
BChan AppEvent ->
Servant.Server SwarmAPI
mkApp :: ReadableIORef AppState -> BChan AppEvent -> Server SwarmAPI
mkApp ReadableIORef AppState
state BChan AppEvent
events =
ReadableIORef AppState -> Handler [Robot]
robotsHandler ReadableIORef AppState
state
forall a b. a -> b -> a :<|> b
:<|> ReadableIORef AppState -> RobotID -> Handler (Maybe Robot)
robotHandler ReadableIORef AppState
state
forall a b. a -> b -> a :<|> b
:<|> ReadableIORef AppState -> Handler [PrereqSatisfaction]
prereqsHandler ReadableIORef AppState
state
forall a b. a -> b -> a :<|> b
:<|> ReadableIORef AppState -> Handler [Objective]
activeGoalsHandler ReadableIORef AppState
state
forall a b. a -> b -> a :<|> b
:<|> ReadableIORef AppState -> Handler (Maybe GraphInfo)
goalsGraphHandler ReadableIORef AppState
state
forall a b. a -> b -> a :<|> b
:<|> ReadableIORef AppState -> Handler GoalTracking
uiGoalHandler ReadableIORef AppState
state
forall a b. a -> b -> a :<|> b
:<|> ReadableIORef AppState -> Handler WinCondition
goalsHandler ReadableIORef AppState
state
forall a b. a -> b -> a :<|> b
:<|> Text -> Handler Text
codeRenderHandler
forall a b. a -> b -> a :<|> b
:<|> BChan AppEvent -> Text -> Handler Text
codeRunHandler BChan AppEvent
events
forall a b. a -> b -> a :<|> b
:<|> ReadableIORef AppState -> Handler [REPLHistItem]
replHandler ReadableIORef AppState
state
robotsHandler :: ReadableIORef AppState -> Handler [Robot]
robotsHandler :: ReadableIORef AppState -> Handler [Robot]
robotsHandler ReadableIORef AppState
appStateRef = 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 :: ReadableIORef AppState -> RobotID -> Handler (Maybe Robot)
robotHandler :: ReadableIORef AppState -> RobotID -> Handler (Maybe Robot)
robotHandler ReadableIORef AppState
appStateRef (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 :: ReadableIORef AppState -> Handler [PrereqSatisfaction]
prereqsHandler :: ReadableIORef AppState -> Handler [PrereqSatisfaction]
prereqsHandler ReadableIORef AppState
appStateRef = 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 :: ReadableIORef AppState -> Handler [Objective]
activeGoalsHandler :: ReadableIORef AppState -> Handler [Objective]
activeGoalsHandler ReadableIORef AppState
appStateRef = 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 :: ReadableIORef AppState -> Handler (Maybe GraphInfo)
goalsGraphHandler :: ReadableIORef AppState -> Handler (Maybe GraphInfo)
goalsGraphHandler ReadableIORef AppState
appStateRef = 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 :: ReadableIORef AppState -> Handler GoalTracking
uiGoalHandler :: ReadableIORef AppState -> Handler GoalTracking
uiGoalHandler ReadableIORef AppState
appStateRef = 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 :: ReadableIORef AppState -> Handler WinCondition
goalsHandler :: ReadableIORef AppState -> Handler WinCondition
goalsHandler ReadableIORef AppState
appStateRef = 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 -> Handler Text
codeRenderHandler :: Text -> Handler 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 (Text -> String
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. PrettyPrec a => a -> Text
prettyTextLine) 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 :: BChan AppEvent -> Text -> Handler Text
codeRunHandler :: BChan AppEvent -> Text -> Handler Text
codeRunHandler BChan AppEvent
chan 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 :: ReadableIORef AppState -> Handler [REPLHistItem]
replHandler :: ReadableIORef AppState -> Handler [REPLHistItem]
replHandler ReadableIORef AppState
appStateRef = 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
data WebStartResult = WebStarted | WebStartError String
webMain ::
Maybe (MVar WebStartResult) ->
Warp.Port ->
ReadableIORef AppState ->
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
swarmApiHtml
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
startWebThread ::
Maybe Warp.Port ->
ReadableIORef AppState ->
BChan AppEvent ->
IO (Either String Warp.Port)
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
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)"
instance SD.ToSample T.Text where
toSamples :: Proxy Text -> [(Text, Text)]
toSamples Proxy Text
_ = forall a. [(Text, a)]
SD.noSamples
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 RobotID where
toSamples :: Proxy RobotID -> [(Text, RobotID)]
toSamples Proxy RobotID
_ = forall a. [a] -> [(Text, a)]
SD.samples [Port -> RobotID
RobotID Port
0, Port -> RobotID
RobotID Port
1]
instance ToCapture (Capture "id" RobotID) where
toCapture :: Proxy (Capture "id" RobotID) -> DocCapture
toCapture Proxy (Capture "id" RobotID)
_ =
String -> String -> DocCapture
SD.DocCapture
String
"id"
String
"(integer) robot ID"