Handle stickers, properly handle exceptions in threads

2 files changed, 53 insertions, 48 deletions

diff --git a/fig-monitor-irc/fig-monitor-irc.cabal b/fig-monitor-irc/fig-monitor-irc.cabal
index 618b63b..5709399 100644
--- a/fig-monitor-irc/fig-monitor-irc.cabal
+++ b/fig-monitor-irc/fig-monitor-irc.cabal
@@ -11,6 +11,7 @@ common deps
   build-depends:
       base
     , aeson
+    , async
     , base64
     , binary
     , bytestring
@@ -47,4 +48,4 @@ executable fig-monitor-irc
   build-depends: fig-monitor-irc, optparse-applicative
   hs-source-dirs:
     main
-  main-is: Main.hs
\ No newline at end of file
+  main-is: Main.hs
diff --git a/fig-monitor-irc/src/Fig/Monitor/IRC.hs b/fig-monitor-irc/src/Fig/Monitor/IRC.hs
index 55d17e5..e9ee605 100644
--- a/fig-monitor-irc/src/Fig/Monitor/IRC.hs
+++ b/fig-monitor-irc/src/Fig/Monitor/IRC.hs
@@ -10,6 +10,7 @@ import qualified Data.ByteString.Base64 as BS.Base64
 import Lens.Micro ((%~), (.~), (^.))
 
 import qualified Control.Concurrent as Conc
+import qualified Control.Concurrent.Async as Async
 import qualified Control.Concurrent.Chan as Chan
 
 import qualified Network.IRC.Client as IRC
@@ -32,52 +33,55 @@ ircBot :: Config -> (Text, Text) -> IO ()
 ircBot cfg busAddr = do
   outgoing <- Chan.newChan @OutgoingMessage
   mircst <- Conc.newEmptyMVar
-  void . Conc.forkIO $ Conc.readMVar mircst >>= \ircst -> forever $ do
-    o <- liftIO $ Chan.readChan outgoing
-    log $ "Sending: " <> o.msg <> " (from " <> o.user <> ")"
-    let msg = IRC.Privmsg cfg.sendchannel . Right . Text.take 400 $ mconcat
-          [ "<", o.user, "> "
-          , Text.replace "\n" " " o.msg
-          ]
-    IRC.runIRCAction (IRC.send msg) ircst
-  busClient busAddr
-    (\cmds -> do
-        cmds.subscribe [sexp|(monitor irc chat outgoing)|]
-        let handler = IRC.EventHandler
-              ( \case
-                  ev
-                    | IRC.Privmsg _ (Right msg) <- ev ^. IRC.message -> Just msg
-                    | otherwise -> Nothing 
+  Async.concurrently_
+    ( Conc.readMVar mircst >>= \ircst -> forever $ do
+        o <- liftIO $ Chan.readChan outgoing
+        log $ "Sending: " <> o.msg <> " (from " <> o.user <> ")"
+        let msg = IRC.Privmsg cfg.sendchannel . Right . Text.take 400 $ mconcat
+              [ "<", o.user, "> "
+              , Text.replace "\n" " " o.msg
+              ]
+        IRC.runIRCAction (IRC.send msg) ircst
+    )
+    do
+      busClient busAddr
+        (\cmds -> do
+            cmds.subscribe [sexp|(monitor irc chat outgoing)|]
+            let handler = IRC.EventHandler
+                  ( \case
+                      ev
+                        | IRC.Privmsg _ (Right msg) <- ev ^. IRC.message -> Just msg
+                        | otherwise -> Nothing 
+                  )
+                  ( \src msg -> case srcUser src of
+                      Just user -> do
+                        log $ "Received: " <> msg <> " (from " <> user <> ")"
+                        liftIO $ cmds.publish [sexp|(monitor irc chat incoming)|]
+                          [ SExprString . BS.Base64.encodeBase64 . encodeUtf8 $ user
+                          , SExprList []
+                          , SExprString . BS.Base64.encodeBase64 . encodeUtf8 $ msg
+                          ]
+                      Nothing -> pure ()
+                  )
+            ircst <- IRC.newIRCState
+              ( IRC.tlsConnection (IRC.WithDefaultConfig (encodeUtf8 cfg.host) cfg.port)
+              -- ( IRC.plainConnection (encodeUtf8 cfg.host) cfg.port
               )
-              ( \src msg -> case srcUser src of
-                  Just user -> do
-                    log $ "Received: " <> msg <> " (from " <> user <> ")"
-                    liftIO $ cmds.publish [sexp|(monitor irc chat incoming)|]
-                      [ SExprString . BS.Base64.encodeBase64 . encodeUtf8 $ user
-                      , SExprList []
-                      , SExprString . BS.Base64.encodeBase64 . encodeUtf8 $ msg
-                      ]
-                  Nothing -> pure ()
+              ( IRC.defaultInstanceConfig cfg.nick
+                & IRC.handlers %~ (handler:)
+                & IRC.channels .~ cfg.channels 
               )
-        ircst <- IRC.newIRCState
-          ( IRC.tlsConnection (IRC.WithDefaultConfig (encodeUtf8 cfg.host) cfg.port)
-          -- ( IRC.plainConnection (encodeUtf8 cfg.host) cfg.port
-          )
-          ( IRC.defaultInstanceConfig cfg.nick
-            & IRC.handlers %~ (handler:)
-            & IRC.channels .~ cfg.channels 
-          )
-          ()
-        Conc.putMVar mircst ircst
-        IRC.runClientWith ircst
-    )
-    (\_cmds d -> do
-        case d of
-          SExprList [ev, SExprString euser, SExprString emsg]
-            | ev == [sexp|(monitor irc chat outgoing)|]
-            , Right user <- decodeUtf8 <$> BS.Base64.decodeBase64 (encodeUtf8 euser)
-            , Right msg <- decodeUtf8 <$> BS.Base64.decodeBase64 (encodeUtf8 emsg) -> do
-                Chan.writeChan outgoing OutgoingMessage { user = user, msg = msg }
-          _ -> log $ "Invalid outgoing message: " <> tshow d
-    )
-    (pure ())
+              ()
+            Conc.putMVar mircst ircst
+            IRC.runClientWith ircst
+        )
+        (\_cmds d -> do
+            case d of
+              SExprList [ev, SExprString euser, SExprString emsg]
+                | ev == [sexp|(monitor irc chat outgoing)|]
+                , Right user <- decodeUtf8 <$> BS.Base64.decodeBase64 (encodeUtf8 euser)
+                , Right msg <- decodeUtf8 <$> BS.Base64.decodeBase64 (encodeUtf8 emsg) -> do
+                    Chan.writeChan outgoing OutgoingMessage { user = user, msg = msg }
+              _ -> log $ "Invalid outgoing message: " <> tshow d
+        )
+        (pure ())