calamity 0.1.19.2 → 0.1.20.0

raw patch · 8 files changed

+137/−85 lines, 8 filesdep +di-coredep ~di-polysemyPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: di-core

Dependency ranges changed: di-polysemy

API changes (from Hackage documentation)

Files

• ChangeLog.md +4/−0
• README.md +53/−51
• calamity.cabal +4/−3
• src/Calamity/Client/Client.hs +25/−13
• src/Calamity/Client/Types.hs +4/−1
• src/Calamity/Commands/CommandUtils.hs +2/−1
• src/Calamity/Gateway/Shard.hs +9/−15
• src/Calamity/Internal/Utils.hs +36/−1

@@ -1,5 +1,9 @@ # Changelog for Calamity +## 0.1.20.0++* Migrate do di-polysemy 0.2, runBotIO no longer handles the Log effect.+ ## 0.1.19.2  * Fix broken `Float` parsing.

@@ -69,6 +69,7 @@ import           Data.Text.Lazy              ( Text, fromStrict ) import           Data.Text.Strict.Lens +import qualified Di import qualified DiPolysemy                  as DiP  import qualified Polysemy                    as P@@ -108,55 +109,56 @@ main :: IO () main = do   token <- view packed <$> getEnv "BOT_TOKEN"-  void . P.runFinal . P.embedToFinal . runCounterAtomic . runCacheInMemory . runMetricsNoop . useConstantPrefix "!"-    $ runBotIO (BotToken token) $ do-    addCommands $ do-      helpCommand-      command @'[User] "utest" $ \ctx u -> do-        void $ tellt ctx $ "got user: " <> showtl u-      command @'[Named "u" User, Named "u1" User] "utest2" $ \ctx u u1 -> do-        void $ tellt ctx $ "got user: " <> showtl u <> "\nand: " <> showtl u1-      command @'[L.Text, Snowflake User] "test" $ \ctx something aUser -> do-        info $ "something = " <> showt something <> ", aUser = " <> showt aUser-      command @'[] "hello" $ \ctx -> do-        void $ tellt ctx "heya"-      group "testgroup" $ do-        command @'[[L.Text]] "test" $ \ctx l -> do-          void $ tellt ctx ("you sent: " <> showtl l)-        command @'[] "count" $ \ctx -> do-          val <- getCounter-          void $ tellt ctx ("The value is: " <> showtl val)-        group "say" $ do-          command @'[KleenePlusConcat L.Text] "this" $ \ctx msg -> do-            void $ tellt ctx msg-      command @'[Snowflake Emoji] "etest" $ \ctx e -> do-        void $ tellt ctx $ "got emoji: " <> showtl e-      command @'[] "explode" $ \ctx -> do-        Just x <- pure Nothing-        debug "unreachable!"-      command @'[] "bye" $ \ctx -> do-        void $ tellt ctx "bye!"-        stopBot-      command @'[] "fire-evt" $ \ctx -> do-        fire $ customEvt @"my-event" ("aha" :: L.Text, ctx ^. #message)-      command @'[L.Text] "wait-for" $ \ctx s -> do-        void $ tellt ctx ("waiting for !" <> s)-        waitUntil @'MessageCreateEvt (\msg -> msg ^. #content == ("!" <> s))-        void $ tellt ctx ("got !" <> s)-    react @'MessageCreateEvt $ \msg -> handleFailByLogging $ case msg ^. #content of-      "!say hi" -> replicateM_ 3 . P.async $ do-        info "saying heya"-        Right msg' <- tellt msg "heya"-        info "sleeping"-        P.embed $ threadDelay (5 * 1000 * 1000)-        info "slept"-        void . invoke $ EditMessage (msg ^. #channelID) msg' (Just "lol") Nothing-        info "edited"-      _ -> pure ()-    react @('CustomEvt "command-error" (CommandContext.Context, CommandError)) $ \(ctx, e) -> do-      info $ "Command failed with reason: " <> showt e-      case e of-        ParseError n r -> void . tellt ctx $ "Failed to parse parameter: `" <> L.fromStrict n <> "`, with reason: ```\n" <> r <> "```"-    react @('CustomEvt "my-event" (L.Text, Message)) $ \(s, m) ->-      void $ tellt m ("Somebody told me to tell you about: " <> s)+  Di.new $ \di ->+    void . P.runFinal . P.embedToFinal . DiP.runDiToIO di . runCounterAtomic . runCacheInMemory . runMetricsNoop . useConstantPrefix "!"+      $ runBotIO (BotToken token) $ do+      addCommands $ do+        helpCommand+        command @'[User] "utest" $ \ctx u -> do+          void $ tellt ctx $ "got user: " <> showtl u+        command @'[Named "u" User, Named "u1" User] "utest2" $ \ctx u u1 -> do+          void $ tellt ctx $ "got user: " <> showtl u <> "\nand: " <> showtl u1+        command @'[L.Text, Snowflake User] "test" $ \ctx something aUser -> do+          info $ "something = " <> showt something <> ", aUser = " <> showt aUser+        command @'[] "hello" $ \ctx -> do+          void $ tellt ctx "heya"+        group "testgroup" $ do+          command @'[[L.Text]] "test" $ \ctx l -> do+            void $ tellt ctx ("you sent: " <> showtl l)+          command @'[] "count" $ \ctx -> do+            val <- getCounter+            void $ tellt ctx ("The value is: " <> showtl val)+          group "say" $ do+            command @'[KleenePlusConcat L.Text] "this" $ \ctx msg -> do+              void $ tellt ctx msg+        command @'[Snowflake Emoji] "etest" $ \ctx e -> do+          void $ tellt ctx $ "got emoji: " <> showtl e+        command @'[] "explode" $ \ctx -> do+          Just x <- pure Nothing+          debug "unreachable!"+        command @'[] "bye" $ \ctx -> do+          void $ tellt ctx "bye!"+          stopBot+        command @'[] "fire-evt" $ \ctx -> do+          fire $ customEvt @"my-event" ("aha" :: L.Text, ctx ^. #message)+        command @'[L.Text] "wait-for" $ \ctx s -> do+          void $ tellt ctx ("waiting for !" <> s)+          waitUntil @'MessageCreateEvt (\msg -> msg ^. #content == ("!" <> s))+          void $ tellt ctx ("got !" <> s)+      react @'MessageCreateEvt $ \msg -> handleFailByLogging $ case msg ^. #content of+        "!say hi" -> replicateM_ 3 . P.async $ do+          info "saying heya"+          Right msg' <- tellt msg "heya"+          info "sleeping"+          P.embed $ threadDelay (5 * 1000 * 1000)+          info "slept"+          void . invoke $ EditMessage (msg ^. #channelID) msg' (Just "lol") Nothing+          info "edited"+        _ -> pure ()+      react @('CustomEvt "command-error" (CommandContext.Context, CommandError)) $ \(ctx, e) -> do+        info $ "Command failed with reason: " <> showt e+        case e of+          ParseError n r -> void . tellt ctx $ "Failed to parse parameter: `" <> L.fromStrict n <> "`, with reason: ```\n" <> r <> "```"+      react @('CustomEvt "my-event" (L.Text, Message)) $ \(s, m) ->+        void $ tellt m ("Somebody told me to tell you about: " <> s) ```

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 16ef7c5601edfc65ae3b7b277d4c413b36765b77311b207855e4975c892dd8cb+-- hash: 0c8bab4fd581f5309d85bd6e640b7f1f3f953f8862ad5b5c607caabf95e1cb3e  name:           calamity-version:        0.1.19.2+version:        0.1.20.0 synopsis:       A library for writing discord bots in haskell description:    Please see the README on GitHub at <https://github.com/nitros12/calamity#readme> category:       Network, Web@@ -149,7 +149,8 @@     , deepseq >=1.4.4.0 && <2     , deque >=0.4 && <0.5     , df1 >=0.3 && <0.5-    , di-polysemy >=0.1.4 && <0.2+    , di-core >=1.0.4 && <1.1+    , di-polysemy >=0.2 && <0.3     , exceptions >=0.10 && <0.11     , fmt >=0.6 && <0.7     , focus >=1.0 && <2

@@ -33,6 +33,7 @@ import           Calamity.Types.Model.User import           Calamity.Types.Snowflake import           Calamity.Types.Token+import           Calamity.Types.LogEff  import           Control.Concurrent.Chan.Unagi import           Control.Concurrent.MVar@@ -52,6 +53,8 @@ import           Data.Time.Clock.POSIX import           Data.Typeable +import qualified Di.Core                           as DC+import qualified Df1 import qualified DiPolysemy                        as Di  import           Network.Wreq.Session            ( Session, newAPISession )@@ -77,8 +80,8 @@   pure (duration, res)  -newClient :: Token -> Session -> IO Client-newClient token session = do+newClient :: Token -> Session -> Maybe (DC.Di Df1.Level Df1.Path Df1.Message) -> IO Client+newClient token session initialDi = do   shards'        <- newTVarIO []   numShards'     <- newEmptyMVar   rlState'       <- newRateLimitState@@ -93,31 +96,41 @@                 outc                 ehidCounter                 session+                initialDi  -- | Create a bot, run your setup action, and then loop until the bot closes. runBotIO :: forall r a.-         (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff] r, Typeable (SetupEff r))+         (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r, Typeable (SetupEff r))          => Token          -> P.Sem (SetupEff r) a          -> P.Sem r (Maybe StartupError) runBotIO token setup = runBotIO' token Nothing Nothing Nothing setup +resetDi :: BotC r => P.Sem r a -> P.Sem r a+resetDi m = do+  initialDi <- P.asks (^. #initialDi)+  Di.local (flip fromMaybe initialDi) m+ -- | Create a bot, run your setup action, and then loop until the bot closes. ----- This version allows you to specify the session and initial status and intents.+-- This version allows you to specify the http session, initial status, and intents. runBotIO' :: forall r a.-          (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff] r, Typeable (SetupEff r))+          (P.Members '[P.Embed IO, P.Final IO, CacheEff, MetricEff, LogEff] r, Typeable (SetupEff r))           => Token           -> Maybe Session+          -- ^ The HTTP session to use, defaults to 'newAPISession'           -> Maybe StatusUpdateData+          -- ^ The initial status to send to the gateway           -> Maybe Intents+          -- ^ The intents to send to the gateway           -> P.Sem (SetupEff r) a           -> P.Sem r (Maybe StartupError) runBotIO' token session status intents setup = do+  initialDi <- Di.fetch   session' <- maybe (P.embed newAPISession) pure session-  client <- P.embed $ newClient token session'+  client <- P.embed $ newClient token session' initialDi   handlers <- P.embed $ newTVarIO def-  P.asyncToIOFinal . P.runAtomicStateTVar handlers . P.runReader client . Di.runDiToStderrIOFinal . Di.push "calamity" $ do+  P.asyncToIOFinal . P.runAtomicStateTVar handlers . P.runReader client . Di.push "calamity" $ do     void $ Di.push "calamity-setup" setup     r <- shardBot status intents     case r of@@ -316,13 +329,12 @@ clientLoop :: BotC r => P.Sem r () clientLoop = do   outc <- P.asks (^. #eventsOut)-  void . P.runError . forever $ do+  whileMFinalIO $ do     evt' <- P.embed $ readChan outc     case evt' of-      -- NOTE: these raise's are needed to raise into the Error effect-      Dispatch sid evt -> P.raise $ handleEvent sid evt-      Custom s d   -> P.raise $ handleCustomEvent s d-      ShutDown     -> P.throw ()+      Dispatch sid evt -> handleEvent sid evt >> pure True+      Custom s d       -> handleCustomEvent s d >> pure True+      ShutDown         -> pure False   debug "leaving client loop"  handleCustomEvent :: forall r. BotC r => TypeRep -> Dynamic -> P.Sem r ()@@ -349,7 +361,7 @@     evtCounter <- registerCounter "events_received" [("type", S.pack $ ctorName data'), ("shard", showt shardID)]     void $ addCounter 1 evtCounter     cacheUpdateHisto <- registerHistogram "cache_update" mempty [10, 20..100]-    (time, res) <- timeA $ Di.reset $ handleEvent' eventHandlers data'+    (time, res) <- timeA $ resetDi $ handleEvent' eventHandlers data'     void $ observeHistogram time cacheUpdateHisto     pure res 

@@ -57,6 +57,8 @@  import qualified TextShow.Generic                as TSG import TextShow+import qualified Df1 as Df1+import qualified Di.Core as DC  data Client = Client   { shards              :: TVar [(InChan ControlMessage, Async (Maybe ()))]@@ -67,6 +69,7 @@   , eventsOut           :: OutChan CalamityEvent   , ehidCounter         :: IORef Integer   , session             :: Session+  , initialDi           :: Maybe (DC.Di Df1.Level Df1.Path Df1.Message)   }   deriving ( Generic ) @@ -76,7 +79,7 @@   , Typeable r)  -- | A concrete effect stack used inside the bot-type SetupEff r = (LogEff ': P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r)+type SetupEff r = (P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r)  -- | Some constraints that 'Calamity.Client.Client.react' needs to work. Don't -- worry about these since they are satisfied for any type @s@ can be

@@ -42,8 +42,9 @@ commandPath :: Command -> [S.Text] commandPath Command { names, parent } = maybe [] groupPath parent ++ [NE.head names] +-- | Format a command's parameters commandParams :: Command -> L.Text-commandParams Command { params } = L.fromStrict $ S.unwords params+commandParams Command { params } = L.fromStrict $ S.intercalate ", " params  -- | Given the properties of a 'Command' with the @parser@ and @callback@ in the -- 'P.Sem' monad, build a command by transforming the Polysemy actions into IO

@@ -31,7 +31,6 @@ import           Data.IORef import           Data.Maybe import qualified Data.Text.Lazy                  as L-import           Data.Void  import           DiPolysemy                      hiding ( debug, error, info ) @@ -97,10 +96,6 @@       P.embed . sendTextData wsConn $ encodedData     Nothing -> debug "tried to send to closed WS" -fromEitherVoid :: Either a Void -> a-fromEitherVoid (Left a) = a-fromEitherVoid (Right a) = absurd a -- yeet- tryWriteTBMQueue' :: TBMQueue a -> a -> STM Bool tryWriteTBMQueue' q v = do   v' <- tryWriteTBMQueue q v@@ -161,11 +156,8 @@                 when r inner    -- | The outer loop, sets up the ws conn, etc handles reconnecting and such-  -- Currently if this goes to the error path we just exit the forever loop-  -- and the shard stops, maybe we might want to do some extra logic to reboot-  -- the shard, or maybe force a resharding-  outerloop :: ShardC r => Sem r (Either ShardFlowControl ())-  outerloop = P.runError . forever $ do+  outerloop :: ShardC r => Sem r ()+  outerloop = whileMFinalIO $ do     shard :: Shard <- P.atomicGets (^. #shardS)     let host = shard ^. #gateway     let host' =  fromMaybe host $ L.stripPrefix "wss://" host@@ -176,14 +168,16 @@     case innerLoopVal of       Just ShardFlowShutDown -> do         info "Shutting down shard"-        P.throw ShardFlowShutDown+        pure False -      Just ShardFlowRestart ->+      Just ShardFlowRestart -> do         info "Restaring shard"+        pure True         -- we restart normally when we loop -      Nothing -> -- won't happen unless innerloop starts using a non-deterministic effect+      Nothing -> do -- won't happen unless innerloop starts using a non-deterministic effect         info "Restarting shard (abnormal reasons?)"+        pure True    -- | The inner loop, handles receiving a message from discord or a command message   -- and then decides what to do with it@@ -227,7 +221,7 @@         debug "handling events now"         _controlThread <- P.async . P.embed $ controlStream shard q         _discordThread <- P.async $ discordStream ws q-        (fromEitherVoid <$>) . P.raise . P.runError . forever $ do+        P.raise . untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do           -- only we close the queue           msg <- P.embed . atomically $ readTBMQueue q           handleMsg =<< restartUnless "shard message stream closed by someone other than the sink" msg)@@ -315,7 +309,7 @@   P.atomicModify (#hbResponse .~ False)  heartBeatLoop :: ShardC r => Int -> Sem r ()-heartBeatLoop interval = void . P.runError . forever $ do+heartBeatLoop interval = untilJustFinalIO . (leftToMaybe <$>) . P.runError $ do   sendHeartBeat   P.embed . threadDelay $ interval * 1000   unlessM (P.atomicGets (^. #hbResponse)) $ do

@@ -2,7 +2,9 @@  -- | Internal utilities and instances module Calamity.Internal.Utils-    ( whenJust+    ( whileMFinalIO+    , untilJustFinalIO+    , whenJust     , whenM     , unlessM     , lastMaybe@@ -18,6 +20,7 @@     , swap ) where  import           Calamity.Types.LogEff+import           Calamity.Internal.RunIntoIO  import           Control.Applicative @@ -37,6 +40,38 @@  import           TextShow import Data.Colour (Colour)++-- | Like whileM, but stateful effects are not preserved to mitigate memory leaks+--+-- This means Polysemy.Error won't work to break the loop, etc.+-- Instead, Error/Alternative will just result in the loop quitting.+whileMFinalIO :: P.Member (P.Final IO) r => P.Sem r Bool -> P.Sem r ()+whileMFinalIO action = do+  action' <- runSemToIO action+  P.embedFinal $ go action'+  where go action' = do+          r <- action'+          case r of+            Just True ->+              go action'+            _ ->+              pure ()++-- | Like untilJust, but stateful effects are not preserved to mitigate memory leaks+--+-- This means Polysemy.Error won't work to break the loop, etc.+-- Instead, Error/Alternative will just result in another loop.+untilJustFinalIO :: P.Member (P.Final IO) r => P.Sem r (Maybe a) -> P.Sem r a+untilJustFinalIO action = do+  action' <- runSemToIO action+  P.embedFinal $ go action'+  where go action' = do+          r <- action'+          case r of+            Just (Just a) ->+              pure a+            _ ->+              go action'  whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m () whenJust = flip $ maybe (pure ())