diff --git a/src/Forest/Server.hs b/src/Forest/Server.hs index f6710b0..f904e13 100644 --- a/src/Forest/Server.hs +++ b/src/Forest/Server.hs @@ -5,41 +5,14 @@ module Forest.Server , serverApp ) where -import Control.Monad -import Control.Concurrent.Async import Control.Concurrent.Chan -import Data.Aeson -import qualified Data.Text as T -import qualified Network.WebSockets as WS +import Control.Monad +import qualified Network.WebSockets as WS import Forest.Api import Forest.Tree import Forest.TreeModule - -{- Helper functions -} - -withThread :: IO () -> IO () -> IO () -withThread thread main = withAsync thread $ const main - -sendPacket :: WS.Connection -> ServerPacket -> IO () -sendPacket conn packet = WS.sendTextData conn $ encode packet - -closeWithErrorMessage :: WS.Connection -> T.Text -> IO () -closeWithErrorMessage conn = WS.sendCloseCode conn 1003 - -receivePacket :: WS.Connection -> IO (Maybe ClientPacket) -receivePacket conn = do - dataMessage <- WS.receiveDataMessage conn - closeOnErrorMessage $ case dataMessage of - WS.Binary _ -> Left "Invalid message format: Binary" - WS.Text bs _ -> case eitherDecode' bs of - Left errorMsg -> Left $ "Invalid packet: " <> T.pack errorMsg - Right packet -> Right packet - where - closeOnErrorMessage :: Either T.Text a -> IO (Maybe a) - closeOnErrorMessage (Right a) = pure $ Just a - closeOnErrorMessage (Left errorMsg) = - Nothing <$ closeWithErrorMessage conn errorMsg +import Forest.Util {- Thread that sends updates to the client -} diff --git a/src/Forest/Util.hs b/src/Forest/Util.hs new file mode 100644 index 0000000..cee9216 --- /dev/null +++ b/src/Forest/Util.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Forest.Util + ( withThread + , sendPacket + , receivePacket + , closeWithErrorMessage + ) where + +import Control.Concurrent.Async +import Data.Aeson +import qualified Data.Text as T +import qualified Network.WebSockets as WS + +withThread :: IO () -> IO () -> IO () +withThread thread main = withAsync thread $ const main + +sendPacket :: ToJSON a => WS.Connection -> a -> IO () +sendPacket conn packet = WS.sendTextData conn $ encode packet + +closeWithErrorMessage :: WS.Connection -> T.Text -> IO () +closeWithErrorMessage conn = WS.sendCloseCode conn 1003 + +receivePacket :: FromJSON a => WS.Connection -> IO (Maybe a) +receivePacket conn = do + dataMessage <- WS.receiveDataMessage conn + closeOnErrorMessage $ case dataMessage of + WS.Binary _ -> Left "Invalid message format: Binary" + WS.Text bs _ -> case eitherDecode' bs of + Left errorMsg -> Left $ "Invalid packet: " <> T.pack errorMsg + Right packet -> Right packet + where + closeOnErrorMessage :: Either T.Text a -> IO (Maybe a) + closeOnErrorMessage (Right a) = pure $ Just a + closeOnErrorMessage (Left errorMsg) = + Nothing <$ closeWithErrorMessage conn errorMsg