{-# 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.IORef (IORef, readIORef)
import Data.IntMap qualified as IM
import Data.Maybe (fromMaybe)
import Network.Wai qualified
import Network.Wai.Handler.Warp qualified as Warp
import Servant
import Swarm.Game.Robot
import Swarm.Game.State
import System.Timeout (timeout)
type SwarmApi =
"robots" :> Get '[JSON] [Robot]
:<|> "robot" :> Capture "id" Int :> Get '[JSON] (Maybe Robot)
mkApp :: IORef GameState -> Servant.Server SwarmApi
mkApp :: IORef GameState -> Server SwarmApi
mkApp IORef GameState
gsRef =
Handler [Robot]
robotsHandler
forall a b. a -> b -> a :<|> b
:<|> forall {m :: * -> *}. MonadIO m => Port -> m (Maybe Robot)
robotHandler
where
robotsHandler :: Handler [Robot]
robotsHandler = do
GameState
g <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef GameState
gsRef)
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
$ GameState
g forall s a. s -> Getting a s a -> a
^. Lens' GameState (IntMap Robot)
robotMap
robotHandler :: Port -> m (Maybe Robot)
robotHandler Port
rid = do
GameState
g <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall a. IORef a -> IO a
readIORef IORef GameState
gsRef)
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 (GameState
g forall s a. s -> Getting a s a -> a
^. Lens' GameState (IntMap Robot)
robotMap)
webMain :: Maybe (MVar (Either String ())) -> Warp.Port -> IORef GameState -> IO ()
webMain :: Maybe (MVar (Either String ())) -> Port -> IORef GameState -> IO ()
webMain Maybe (MVar (Either String ()))
baton Port
port IORef GameState
gsRef = 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 GameState -> Server SwarmApi
mkApp IORef GameState
gsRef)
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 GameState -> IO (Either String Warp.Port)
startWebThread :: Maybe Port -> IORef GameState -> IO (Either String Port)
startWebThread (Just Port
0) IORef GameState
_ = 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 GameState
gsRef = 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 GameState -> IO ()
webMain (forall a. a -> Maybe a
Just MVar (Either String ())
baton) Port
port IORef GameState
gsRef
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