Garmelon/euph-api
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Make it work

Browse source
This commit is contained in:
Joscha 2018-02-07 16:12:28 +00:00
parent 615e74583e
commit e5fbc09f7b
3 changed files with 10 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/EuphApi.hs
View file

@ -1,5 +1,7 @@
module EuphApi module EuphApi
( module EuphApi.Types ( module EuphApi.Types
, module EuphApi.Threads
) where ) where
import EuphApi.Types import EuphApi.Types
import EuphApi.Threads

1
src/EuphApi/Controller.hs
View file

@ -1 +0,0 @@
module EuphApi.Controller where

15
src/EuphApi/Threads.hs
View file

@ -9,7 +9,7 @@
module EuphApi.Threads ( module EuphApi.Threads (
-- * Connecting to euphoria -- * Connecting to euphoria
Connection Connection
, euphApp , startEuphConnection
, getEvent , getEvent
-- * API functions -- * API functions
, disconnect , disconnect
@ -38,6 +38,7 @@ import qualified Data.Text as T
import Data.Time import Data.Time
import Data.Time.Clock.POSIX import Data.Time.Clock.POSIX
import qualified Network.WebSockets as WS import qualified Network.WebSockets as WS
import qualified Wuss as WSS
import qualified EuphApi.Types as E import qualified EuphApi.Types as E
@ -63,15 +64,15 @@ data Connection = Connection LockedFlag SendQueue EventQueue
getEvent :: Connection -> IO (Maybe Event) getEvent :: Connection -> IO (Maybe Event)
getEvent (Connection _ _ qEvent) = atomically $ readTBQueue qEvent getEvent (Connection _ _ qEvent) = atomically $ readTBQueue qEvent
-- | A 'WS.ClientApp' creating a 'Connection'. startEuphConnection :: String -> String -> IO Connection
euphApp :: WS.ClientApp Connection startEuphConnection host room = do
euphApp con = do
sendQueue <- atomically $ newTBQueue 10 sendQueue <- atomically $ newTBQueue 10
recvQueue <- atomically $ newTBQueue 10 recvQueue <- atomically $ newTBQueue 10
eventQueue <- atomically $ newTBQueue 10 eventQueue <- atomically $ newTBQueue 10
locked <- atomically $ newTVar False locked <- atomically $ newTVar False
let euphCon = Connection locked sendQueue eventQueue let euphCon = Connection locked sendQueue eventQueue
void $ forkIO $ recvThread euphCon recvQueue con -- TODO: catch failed connection and send note to qEvent
void $ async $ WSS.runSecureClient host 443 ("/room/" ++ room ++ "/ws") (recvClient euphCon recvQueue)
return euphCon return euphCon
{- {-
@ -228,8 +229,8 @@ cleanupRecv qRecv = do
RReply _ (ReplyMVar var) -> putMVar var (Left EuphDisconnected) RReply _ (ReplyMVar var) -> putMVar var (Left EuphDisconnected)
_ -> return () _ -> return ()
recvThread :: Connection -> RecvQueue -> WS.Connection -> IO () recvClient :: Connection -> RecvQueue -> WS.ClientApp ()
recvThread euphCon@(Connection locked qSend qEvent) qRecv con = do recvClient euphCon@(Connection locked qSend qEvent) qRecv con = do
tFetch <- async $ fetchThread qRecv con tFetch <- async $ fetchThread qRecv con
tSend <- async $ evalStateT (sendThread euphCon qRecv con) 0 tSend <- async $ evalStateT (sendThread euphCon qRecv con) 0
waitingReplies <- execStateT (processRecv qRecv qEvent) M.empty waitingReplies <- execStateT (processRecv qRecv qEvent) M.empty