module Remotion.Server
(
Server,
run,
wait,
countSlots,
runAndWait,
Settings,
P.UserProtocolSignature,
ListeningMode(..),
Port,
C.Authenticate,
P.Credentials,
P.Timeout,
MaxClients,
Log,
C.ProcessUserRequest,
C.State,
Failure(..),
)
where
import Remotion.Util.Prelude hiding (listen)
import qualified Remotion.Server.Connection as C
import qualified Remotion.Protocol as P
import qualified Remotion.Util.FileSystem as FS
import qualified Control.Concurrent.Async.Lifted as As
import qualified Network
import qualified Data.Set as Set
type Settings i o s =
(P.UserProtocolSignature, ListeningMode, P.Timeout, MaxClients, Log,
C.ProcessUserRequest i o s)
data ListeningMode =
Host Port C.Authenticate |
Socket FilePath
type Port = Int
type MaxClients = Int
type Log = Text -> IO ()
newtype Server m a =
Server { unServer :: ReaderT (Wait, CountSlots) m a }
deriving (Functor, Applicative, Monad, MonadIO, MonadTrans)
type Wait = IO ()
type CountSlots = IO Int
data Failure =
ListeningSocketIsBusy
deriving (Show, Eq, Generic, Typeable)
run ::
(Serializable IO i, Serializable IO o, MonadIO m) =>
Settings i o s -> Server m a -> m (Either Failure a)
run (userVersion, listeningMode, timeout, maxClients, log, processRequest) m = runEitherT $ do
let (portID, auth) = case listeningMode of
Host port auth -> (Network.PortNumber $ fromIntegral port, auth)
Socket path -> (Network.UnixSocket $ FS.encodeString path, const $ pure True)
listeningSocket <- Network.listenOn portID |> try |> liftIO >>= \case
Left e -> case ioeGetErrorType e of
ResourceBusy -> left ListeningSocketIsBusy
_ -> $bug $ "Unexpected IO error: " <> (packText . show) e
Right r -> return r
slotsVar <- liftIO $ newMVar maxClients
activeListenerLock <- liftIO $ newMVar ()
mainThreadID <- liftIO $ myThreadId
liftIO $ log "Listening"
listenerAsyncs <- liftIO $ forM [1..(maxClients + 1)] $ \i ->
let
log' = log . (("Listener " <> packText (show i) <> ": ") <>)
acquire = do
(connectionSocket, _, _) <- do
takeMVar activeListenerLock
log' $ "Waiting for connection"
Network.accept listeningSocket <* putMVar activeListenerLock ()
modifyMVar_ slotsVar $ return . pred
return connectionSocket
release connectionSocket = do
log' "Releasing session's resources"
hClose connectionSocket
modifyMVar_ slotsVar $ return . succ
process connectionSocket = do
log' "Running client session"
slots <- readMVar slotsVar
C.runConnection connectionSocket (slots >= 0) auth timeout userVersion processRequest >>=
either
(log' . ("Session failed: " <>) . packText . show)
(const $ log' "Session closed")
in As.async $ forever $ do
s <- acquire
r <- try $ process s
release s
case r of
Right r -> return r
Left se -> if
| Just ThreadKilled <- fromException se -> throwIO ThreadKilled
| otherwise -> throwTo mainThreadID se
let
wait = do
void $ As.waitAnyCancel listenerAsyncs
stop = do
log $ "Stopping server"
forM_ listenerAsyncs As.cancel
Network.sClose listeningSocket
case listeningMode of
Socket path -> FS.removeFile path
_ -> return ()
log $ "Stopped server"
countSlots = readMVar slotsVar
r <- lift $ runReaderT (unServer m) (wait, countSlots)
liftIO stop
return r
wait :: (MonadIO m) => Server m ()
wait = Server $ ask >>= \(x, _) -> liftIO $ x
countSlots :: (MonadIO m) => Server m Int
countSlots = Server $ ask >>= \(_, x) -> liftIO $ x
runAndWait :: (Serializable IO i, Serializable IO o) => Settings i o s -> IO (Either Failure ())
runAndWait settings = run settings $ wait
instance MonadBase IO m => MonadBase IO (Server m) where
liftBase = Server . liftBase
instance MonadTransControl Server where
newtype StT Server a = StT { unStT :: a }
liftWith runToM = do
wait <- Server $ ask
Server $ lift $ runToM $ liftM StT . flip runReaderT wait . unServer
restoreT m = do
StT r <- Server $ lift $ m
return r
instance (MonadBaseControl IO m) => MonadBaseControl IO (Server m) where
newtype StM (Server m) a = StMT { unStMT :: ComposeSt Server m a }
liftBaseWith = defaultLiftBaseWith StMT
restoreM = defaultRestoreM unStMT