{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
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"
String
"(integer) robot ID"
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 ->
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
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
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
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)"