diff --git a/src/Haboli/Euphoria/Api.hs b/src/Haboli/Euphoria/Api.hs index c1736b5..be19ced 100644 --- a/src/Haboli/Euphoria/Api.hs +++ b/src/Haboli/Euphoria/Api.hs @@ -5,7 +5,7 @@ module Haboli.Euphoria.Api -- * Basic types , AuthOption(..) , Message(..) - , PersonalAccountView + , PersonalAccountView(..) , SessionView(..) , Snowflake , UserType(..) @@ -36,6 +36,9 @@ module Haboli.Euphoria.Api -- ** nick , NickCommand(..) , NickReply(..) + -- ** send + , SendCommand(..) + , SendReply(..) ) where import Control.Monad @@ -201,6 +204,10 @@ data JoinEvent = JoinEvent { joinSession :: SessionView } deriving (Show) +instance FromJSON JoinEvent where + parseJSON = fromPacket "join-event" $ \o -> JoinEvent + <$> parseJSON (Object o) + data LoginEvent = LoginEvent { loginAccountId :: Snowflake } deriving (Show) @@ -230,6 +237,10 @@ data PartEvent = PartEvent { partSession :: SessionView } deriving (Show) +instance FromJSON PartEvent where + parseJSON = fromPacket "part-event" $ \o -> PartEvent + <$> parseJSON (Object o) + data PingEvent = PingEvent { pingTime :: UTCTime , pingNext :: UTCTime @@ -251,6 +262,10 @@ data SendEvent = SendEvent { sendMessage :: Message } deriving (Show) +instance FromJSON SendEvent where + parseJSON = fromPacket "send-event" $ \o -> SendEvent + <$> parseJSON (Object o) + {- snapshot-event -} data SnapshotEvent = SnapshotEvent @@ -315,9 +330,8 @@ data NickCommand = NickCommand T.Text deriving (Show) instance ToJSONObject NickCommand where - toJSONObject (NickCommand nick) = HMap.fromList - [ "type" .= String "nick" - , "data" .= object ["name" .= nick] + toJSONObject (NickCommand nick) = toPacket "nick" $ object + [ "name" .= nick ] data NickReply = NickReply @@ -333,3 +347,21 @@ instance FromJSON NickReply where <*> o .: "id" <*> o .: "from" <*> o .: "to" + +{- send -} + +data SendCommand = SendCommand T.Text (Maybe Snowflake) + deriving (Show) + +instance ToJSONObject SendCommand where + toJSONObject (SendCommand content Nothing) = + toPacket "send" $ object ["content" .= content] + toJSONObject (SendCommand content (Just parent)) = + toPacket "send" $ object ["content" .= content, "parent" .= parent] + +data SendReply = SendReply Message + deriving (Show) + +instance FromJSON SendReply where + parseJSON = fromPacket "send-reply" $ \o -> SendReply + <$> parseJSON (Object o) diff --git a/src/Haboli/Euphoria/Client.hs b/src/Haboli/Euphoria/Client.hs index cd9177d..d64e98f 100644 --- a/src/Haboli/Euphoria/Client.hs +++ b/src/Haboli/Euphoria/Client.hs @@ -22,11 +22,19 @@ module Haboli.Euphoria.Client , ClientException(..) , Haboli.Euphoria.Client.throw , Haboli.Euphoria.Client.catch + , Haboli.Euphoria.Client.handle + -- ** Threading + , Thread + , fork + , wait -- ** Euphoria commands -- *** Session commands , pingReply -- *** Chat room commands , nick + , Haboli.Euphoria.Client.send + , reply + , reply' ) where import Control.Applicative @@ -54,14 +62,28 @@ import Haboli.Euphoria.Api --TODO: Add all the events data Event - = EventPing PingEvent + = EventBounce BounceEvent + | EventDisconnect DisconnectEvent + | EventHello HelloEvent + | EventJoin JoinEvent + | EventLogin LoginEvent + | EventLogout LogoutEvent + | EventNetwork NetworkEvent + | EventNick NickEvent + | EventEditMessage EditMessageEvent + | EventPart PartEvent + | EventPing PingEvent + | EventPmInitiate PmInitiateEvent + | EventSend SendEvent | EventSnapshot SnapshotEvent - | PlaceholderEvent --TODO: remove this event deriving (Show) instance FromJSON Event where parseJSON v = foldr (<|>) mempty - [ EventPing <$> parseJSON v + [ EventJoin <$> parseJSON v + , EventPart <$> parseJSON v + , EventPing <$> parseJSON v + , EventSend <$> parseJSON v , EventSnapshot <$> parseJSON v ] @@ -74,6 +96,9 @@ data ClientException e | StoppedException | DecodeException T.Text -- ^ At some point during decoding a websocket packet, something went wrong. + | UnexpectedException SomeException + -- ^ While a forked thread was executed, an unexpected exception was thrown in + -- the IO monad. | CustomException e deriving (Show) @@ -160,10 +185,10 @@ parseAndSendReply msg awaiting = do runWebsocketThread :: ClientInfo e -> IO () runWebsocketThread info = WS.withPingThread (ciConnection info) pingInterval (pure ()) - $ handle (cancellingAllReplies info) $ forever - $ handle ignoringInvalidMessages $ do + $ Control.Exception.handle (cancellingAllReplies info) $ forever + $ Control.Exception.handle ignoringInvalidMessages $ do msg <- WS.receiveData (ciConnection info) - -- print msg + print msg parseAndSendEvent msg (ciEventChan info) parseAndSendReply msg (ciAwaiting info) where @@ -210,7 +235,8 @@ runClient details (Client stack) result <- runReaderT (runExceptT stack) info -- Close the connection if it is not already closed, and wait until the -- websocket thread stops - handle ignoreAllExceptions $ WS.sendClose connection $ T.pack "Goodbye :D" + Control.Exception.handle ignoreAllExceptions + $ WS.sendClose connection $ T.pack "Goodbye :D" takeMVar wsThreadFinished pure result where @@ -238,7 +264,7 @@ newPacketId = do safeSend :: ToJSON a => WS.Connection -> a -> Client e () safeSend connection packet = do result <- liftIO - $ handle convertToException + $ Control.Exception.handle convertToException $ Nothing <$ WS.sendTextData connection (encode packet) case result of Nothing -> pure () @@ -280,8 +306,8 @@ sendPacketWithReply packet = do case maybeReplyVar of Nothing -> throwRaw StoppedException Just replyVar -> do - reply <- liftIO $ atomically $ readTMVar replyVar - case reply of + answer <- liftIO $ atomically $ readTMVar replyVar + case answer of Left e -> throwRaw e Right r -> pure r @@ -298,7 +324,7 @@ getPort = cdPort . ciDetails <$> getClientInfo getPath :: Client e String getPath = cdPath . ciDetails <$> getClientInfo -{- Special operations -} +{- Event handling -} nextEvent :: Client e Event nextEvent = do @@ -330,6 +356,30 @@ catch c f = Client $ catchE (unclient c) (unclient . f) where unclient (Client m) = m +handle :: (ClientException e -> Client e a) -> Client e a -> Client e a +handle = flip Haboli.Euphoria.Client.catch + +{- Threading -} + +data Thread e a = Thread (MVar (Either (ClientException e) a)) + +fork :: Client e a -> Client e (Thread e a) +fork (Client f) = do + info <- getClientInfo + waitVar <- liftIO newEmptyMVar + let thread = runReaderT (runExceptT f) info + andThen (Left e) = putMVar waitVar $ Left $ UnexpectedException e + andThen (Right r) = putMVar waitVar r + void $ liftIO $ forkFinally thread andThen + pure $ Thread waitVar + +wait :: Thread e a -> Client e a +wait (Thread waitVar) = do + result <- liftIO $ readMVar waitVar + case result of + (Left e) -> throwRaw e + (Right a) -> pure a + {- Euphoria commands -} {- Session commands -} @@ -341,5 +391,18 @@ pingReply = void . sendPacket . PingReply nick :: T.Text -> Client e T.Text nick targetNick = do - reply <- sendPacketWithReply $ NickCommand targetNick - pure $ nickReplyTo reply + answer <- sendPacketWithReply $ NickCommand targetNick + pure $ nickReplyTo answer + +send :: T.Text -> Client e Message +send content = do + (SendReply msg) <- sendPacketWithReply $ SendCommand content Nothing + pure msg + +reply' :: Snowflake -> T.Text -> Client e Message +reply' messageId content = do + (SendReply msg) <- sendPacketWithReply $ SendCommand content (Just messageId) + pure msg + +reply :: Message -> T.Text -> Client e Message +reply = reply' . msgId diff --git a/src/Haboli/Euphoria/Example.hs b/src/Haboli/Euphoria/Example.hs index 604a3ba..a0f6f79 100644 --- a/src/Haboli/Euphoria/Example.hs +++ b/src/Haboli/Euphoria/Example.hs @@ -9,7 +9,7 @@ import Haboli.Euphoria.Client printAllEventsBot :: Client () () printAllEventsBot = forever $ do - liftIO $ putStrLn "Waiting for the next event" + liftIO $ putStrLn "\nWaiting for the next event...\n" liftIO . print =<< respondingToPing nextEvent setNickAndThenWaitBot :: Client () () @@ -24,3 +24,14 @@ throwCustomExceptionBot = throw "Hello world" immediatelyDisconnectBot :: Client () () immediatelyDisconnectBot = pure () + +sendMessagesUntilThrottledBot :: Client () () +sendMessagesUntilThrottledBot = forever $ do + event <- respondingToPing nextEvent + case event of + EventSnapshot _ -> do + void $ nick "SpamBot" + msg <- send "start thread" + void $ fork $ handle (\_ -> reply msg "got throttled") $ + forever $ reply msg "continue thread" + _ -> pure ()