Add threading and more commands

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
+  toJSONObject (NickCommand nick) = toPacket "nick" $ object
-    [ "type" .= String "nick"
+    [ "name" .= nick
-    , "data" .= 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)

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
+  $ Control.Exception.handle (cancellingAllReplies info) $ forever
-  $ handle ignoringInvalidMessages $ do
+  $ 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
+      answer <- liftIO $ atomically $ readTMVar replyVar
-      case reply of
+      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
+  answer <- sendPacketWithReply $ NickCommand targetNick
-  pure $ nickReplyTo reply
+  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

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 ()