114 lines
3.1 KiB
Haskell
114 lines
3.1 KiB
Haskell
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
module Main where
|
|
|
|
import Control.Concurrent.STM
|
|
import Lens.Micro
|
|
import Lens.Micro.TH
|
|
import qualified Network.WebSockets as WS
|
|
import Options.Applicative
|
|
|
|
import Forest.Node
|
|
import Forest.Server.Branch.SharedEdit
|
|
import Forest.Server.Schema
|
|
import Forest.Server.TreeApp
|
|
|
|
{- Command line options -}
|
|
|
|
data ServerOptions = ServerOptions
|
|
{ serverPingDelay :: Int
|
|
, serverHost :: String
|
|
, serverPort :: Int
|
|
}
|
|
|
|
parser :: Parser ServerOptions
|
|
parser = ServerOptions
|
|
<$> option auto
|
|
( long "ping-delay"
|
|
<> help "How many seconds to wait between each ping sent to the client"
|
|
<> value 10
|
|
<> showDefault
|
|
<> metavar "SECONDS"
|
|
)
|
|
<*> strOption
|
|
( short 'h'
|
|
<> long "host"
|
|
<> help "The server's host"
|
|
<> value (WS.serverHost WS.defaultServerOptions)
|
|
<> showDefault
|
|
<> metavar "HOST"
|
|
)
|
|
<*> option auto
|
|
( short 'p'
|
|
<> long "port"
|
|
<> help "The port to listen for websocket connections on"
|
|
<> value (WS.serverPort WS.defaultServerOptions)
|
|
<> showDefault
|
|
<> metavar "PORT"
|
|
)
|
|
|
|
serverOptionsParserInfo :: ParserInfo ServerOptions
|
|
serverOptionsParserInfo = info (helper <*> parser) fullDesc
|
|
|
|
wsOptions :: ServerOptions -> WS.ServerOptions
|
|
wsOptions o = WS.defaultServerOptions
|
|
{ WS.serverHost = serverHost o
|
|
, WS.serverPort = serverPort o
|
|
, WS.serverRequirePong = Just $ serverPingDelay o * 2
|
|
}
|
|
|
|
{- The actual app -}
|
|
|
|
data AppEvent = UpdateSharedEdit
|
|
deriving (Show, Eq)
|
|
|
|
newtype AppState = AppState
|
|
{ _asSharedEdit :: SharedEditLocal
|
|
}
|
|
|
|
makeLenses ''AppState
|
|
|
|
schema :: AppState -> Schema (Branch AppState AppEvent)
|
|
schema s = fork' "Forest"
|
|
[ leaf $ schemaLift asSharedEdit sharedEditBranch s
|
|
]
|
|
|
|
draw :: AppState -> Node
|
|
draw = schemaDraw . schema
|
|
|
|
handleEvent :: AppState -> Event AppEvent -> IO (Next AppState)
|
|
handleEvent s (Custom UpdateSharedEdit) = do
|
|
sel' <- sharedEditUpdate $ s ^. asSharedEdit
|
|
pure $ continue $ s & asSharedEdit .~ sel'
|
|
handleEvent s e = case schemaHandleEvent (schema s) e of
|
|
Nothing -> pure $ continue s
|
|
Just s' -> continue <$> s'
|
|
|
|
constructor
|
|
:: TChan AppEvent
|
|
-> SharedEditGlobal
|
|
-> (AppState -> Maybe (TChan AppEvent) -> IO a)
|
|
-> IO a
|
|
constructor broadcastChan seg cont = do
|
|
sel <- sharedEditLocal seg
|
|
receiveChan <- atomically $ dupTChan broadcastChan
|
|
cont (AppState sel) (Just receiveChan)
|
|
|
|
main :: IO ()
|
|
main = do
|
|
opts <- execParser serverOptionsParserInfo
|
|
|
|
putStrLn "Preparing server"
|
|
broadcastChan <- atomically newBroadcastTChan
|
|
let onEditChange = atomically $ writeTChan broadcastChan UpdateSharedEdit
|
|
seg <- sharedEditGlobal onEditChange "Sandbox"
|
|
let app = TreeApp
|
|
{ appDraw = draw
|
|
, appHandleEvent = handleEvent
|
|
, appConstructor = constructor broadcastChan seg
|
|
}
|
|
|
|
putStrLn "Starting server"
|
|
WS.runServerWithOptions (wsOptions opts) $
|
|
runTreeApp (serverPingDelay opts) app
|