diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) ``` diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -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 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 diff --git a/src/Calamity/Client/Client.hs b/src/Calamity/Client/Client.hs --- a/src/Calamity/Client/Client.hs +++ b/src/Calamity/Client/Client.hs @@ -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 diff --git a/src/Calamity/Client/Types.hs b/src/Calamity/Client/Types.hs --- a/src/Calamity/Client/Types.hs +++ b/src/Calamity/Client/Types.hs @@ -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 diff --git a/src/Calamity/Commands/CommandUtils.hs b/src/Calamity/Commands/CommandUtils.hs --- a/src/Calamity/Commands/CommandUtils.hs +++ b/src/Calamity/Commands/CommandUtils.hs @@ -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 diff --git a/src/Calamity/Gateway/Shard.hs b/src/Calamity/Gateway/Shard.hs --- a/src/Calamity/Gateway/Shard.hs +++ b/src/Calamity/Gateway/Shard.hs @@ -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 diff --git a/src/Calamity/Internal/Utils.hs b/src/Calamity/Internal/Utils.hs --- a/src/Calamity/Internal/Utils.hs +++ b/src/Calamity/Internal/Utils.hs @@ -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 ())