diff --git a/Calamity/Client/Client.hs b/Calamity/Client/Client.hs --- a/Calamity/Client/Client.hs +++ b/Calamity/Client/Client.hs @@ -486,7 +486,8 @@ handleEvent' eh evt@(GuildMembersChunk GuildMembersChunkData { members, guildID }) = do updateCache evt Just guild <- getGuild guildID - let members' = guild ^.. #members . foldMap (at . getID) members . _Just + let memberIDs = map (getID @Member) members + let members' = catMaybes $ map (\mid -> guild ^. #members . at mid) memberIDs pure $ map ($ (guild, members')) (getEventHandlers @'GuildMembersChunkEvt eh) handleEvent' eh evt@(GuildRoleCreate GuildRoleData { guildID, role }) = do diff --git a/Calamity/Client/Types.hs b/Calamity/Client/Types.hs --- a/Calamity/Client/Types.hs +++ b/Calamity/Client/Types.hs @@ -256,35 +256,35 @@ def = EventHandlers $ fromList - [ WrapTypeable $ EH @ 'ReadyEvt [] - , WrapTypeable $ EH @ 'ChannelCreateEvt [] - , WrapTypeable $ EH @ 'ChannelUpdateEvt [] - , WrapTypeable $ EH @ 'ChannelDeleteEvt [] - , WrapTypeable $ EH @ 'ChannelpinsUpdateEvt [] - , WrapTypeable $ EH @ 'GuildCreateEvt [] - , WrapTypeable $ EH @ 'GuildUpdateEvt [] - , WrapTypeable $ EH @ 'GuildDeleteEvt [] - , WrapTypeable $ EH @ 'GuildBanAddEvt [] - , WrapTypeable $ EH @ 'GuildBanRemoveEvt [] - , WrapTypeable $ EH @ 'GuildEmojisUpdateEvt [] - , WrapTypeable $ EH @ 'GuildIntegrationsUpdateEvt [] - , WrapTypeable $ EH @ 'GuildMemberAddEvt [] - , WrapTypeable $ EH @ 'GuildMemberRemoveEvt [] - , WrapTypeable $ EH @ 'GuildMemberUpdateEvt [] - , WrapTypeable $ EH @ 'GuildMembersChunkEvt [] - , WrapTypeable $ EH @ 'GuildRoleCreateEvt [] - , WrapTypeable $ EH @ 'GuildRoleUpdateEvt [] - , WrapTypeable $ EH @ 'GuildRoleDeleteEvt [] - , WrapTypeable $ EH @ 'MessageCreateEvt [] - , WrapTypeable $ EH @ 'MessageUpdateEvt [] - , WrapTypeable $ EH @ 'MessageDeleteEvt [] - , WrapTypeable $ EH @ 'MessageDeleteBulkEvt [] - , WrapTypeable $ EH @ 'MessageReactionAddEvt [] - , WrapTypeable $ EH @ 'MessageReactionRemoveEvt [] - , WrapTypeable $ EH @ 'MessageReactionRemoveAllEvt [] - , WrapTypeable $ EH @ 'TypingStartEvt [] - , WrapTypeable $ EH @ 'UserUpdateEvt [] - , WrapTypeable $ EH @( 'CustomEvt Void Dynamic) LH.empty + [ WrapTypeable $ EH @'ReadyEvt [] + , WrapTypeable $ EH @'ChannelCreateEvt [] + , WrapTypeable $ EH @'ChannelUpdateEvt [] + , WrapTypeable $ EH @'ChannelDeleteEvt [] + , WrapTypeable $ EH @'ChannelpinsUpdateEvt [] + , WrapTypeable $ EH @'GuildCreateEvt [] + , WrapTypeable $ EH @'GuildUpdateEvt [] + , WrapTypeable $ EH @'GuildDeleteEvt [] + , WrapTypeable $ EH @'GuildBanAddEvt [] + , WrapTypeable $ EH @'GuildBanRemoveEvt [] + , WrapTypeable $ EH @'GuildEmojisUpdateEvt [] + , WrapTypeable $ EH @'GuildIntegrationsUpdateEvt [] + , WrapTypeable $ EH @'GuildMemberAddEvt [] + , WrapTypeable $ EH @'GuildMemberRemoveEvt [] + , WrapTypeable $ EH @'GuildMemberUpdateEvt [] + , WrapTypeable $ EH @'GuildMembersChunkEvt [] + , WrapTypeable $ EH @'GuildRoleCreateEvt [] + , WrapTypeable $ EH @'GuildRoleUpdateEvt [] + , WrapTypeable $ EH @'GuildRoleDeleteEvt [] + , WrapTypeable $ EH @'MessageCreateEvt [] + , WrapTypeable $ EH @'MessageUpdateEvt [] + , WrapTypeable $ EH @'MessageDeleteEvt [] + , WrapTypeable $ EH @'MessageDeleteBulkEvt [] + , WrapTypeable $ EH @'MessageReactionAddEvt [] + , WrapTypeable $ EH @'MessageReactionRemoveEvt [] + , WrapTypeable $ EH @'MessageReactionRemoveAllEvt [] + , WrapTypeable $ EH @'TypingStartEvt [] + , WrapTypeable $ EH @'UserUpdateEvt [] + , WrapTypeable $ EH @('CustomEvt Void Dynamic) LH.empty ] instance Semigroup EventHandlers where diff --git a/Calamity/HTTP/Internal/Request.hs b/Calamity/HTTP/Internal/Request.hs --- a/Calamity/HTTP/Internal/Request.hs +++ b/Calamity/HTTP/Internal/Request.hs @@ -88,7 +88,7 @@ let r = action a (route' ^. #path) (requestOptions token') act = runReq reqConfig r - resp <- attr "route" (renderUrl $ route' ^. #path) $ doRequest rlState' route' act + resp <- push "calamity" . attr "route" (renderUrl $ route' ^. #path) $ doRequest rlState' route' act void $ modifyGauge (subtract 1) inFlightRequests diff --git a/Calamity/Utils/Permissions.hs b/Calamity/Utils/Permissions.hs --- a/Calamity/Utils/Permissions.hs +++ b/Calamity/Utils/Permissions.hs @@ -17,8 +17,10 @@ import Control.Lens +import Data.Maybe (catMaybes) import Data.Flags import qualified Data.Vector.Unboxing as V +import Data.Generics.Product.Fields import qualified Polysemy as P import Data.Foldable (Foldable(foldl')) @@ -29,7 +31,8 @@ | (g ^. #ownerID == getID m) = allFlags | otherwise = let everyoneRole = g ^. #roles . at (coerceSnowflake $ getID @Guild g) permsEveryone = maybe noFlags (^. #permissions) everyoneRole - rolePerms = g ^.. #roles . foldMap ix (V.toList $ m ^. #roles) . #permissions + roleIDs = V.toList $ m ^. #roles + rolePerms = catMaybes $ map (\rid -> g ^? #roles . ix rid . #permissions) roleIDs perms = foldl' andFlags noFlags (permsEveryone:rolePerms) in if perms .<=. administrator then allFlags @@ -40,16 +43,16 @@ applyOverwrites c m p | p .<=. administrator = allFlags | otherwise = - let everyoneOverwrite = c ^. #permissionOverwrites . at (coerceSnowflake $ getID @Guild c) + let everyoneOverwrite = c ^. field' @"permissionOverwrites" . at (coerceSnowflake $ getID @Guild c) everyoneAllow = maybe noFlags (^. #allow) everyoneOverwrite everyoneDeny = maybe noFlags (^. #deny) everyoneOverwrite p' = p .-. everyoneDeny .+. everyoneAllow - roleOverwrites = c ^.. #permissionOverwrites . foldMap ix - (map (coerceSnowflake @_ @Overwrite) . V.toList $ m ^. #roles) + roleOverwriteIDs = map (coerceSnowflake @_ @Overwrite) . V.toList $ m ^. #roles + roleOverwrites = catMaybes $ map (\oid -> c ^? field' @"permissionOverwrites" . ix oid) roleOverwriteIDs roleAllow = foldl' andFlags noFlags (roleOverwrites ^.. traverse . #allow) roleDeny = foldl' andFlags noFlags (roleOverwrites ^.. traverse . #deny) p'' = p' .-. roleDeny .+. roleAllow - memberOverwrite = c ^. #permissionOverwrites . at (coerceSnowflake @_ @Overwrite $ getID @Member m) + memberOverwrite = c ^. field' @"permissionOverwrites" . at (coerceSnowflake @_ @Overwrite $ getID @Member m) memberAllow = maybe noFlags (^. #allow) memberOverwrite memberDeny = maybe noFlags (^. #deny) memberOverwrite p''' = p'' .-. memberDeny .+. memberAllow diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Changelog for Calamity +## 0.1.29.0 + ++ The minimum version of `base` has been upped to `4.13` as the library fails to + build on ghc-8.6 ++ The minimum version of `polysemy` has been upped to 1.5 ++ The upper bound of `lens` has been bumped to 6 ++ The library now compiles with ghc-9 + ## 0.1.28.5 + Use the correct HTTP method for `ModifyChannel` diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -35,13 +35,42 @@ You can find documentation on hackage at: https://hackage.haskell.org/package/calamity +There's also a good blog post that covers the fundamentals of writing a bot with +the library, you can read it here: +https://morrowm.github.io/posts/2021-04-29-calamity.html + # Examples -Some example projects can be found at: +Here's a list of projects that use calamity: -- [simmsb/calamity-bot](https://github.com/simmsb/calamity-bot): Uses a database, showing modularisation of groups/commands. +- [simmsb/calamity-bot](https://github.com/simmsb/calamity-bot): Uses a database, showing modularization of groups/commands. +- [MorrowM/pandabot-discord](https://github.com/MorrowM/pandabot-discord): Uses a database, performs member role management, etc. +- [MorrowM/calamity-tutorial](https://github.com/MorrowM/calamity-tutorial): A bare minimum bot. +(Feel free to contact me via the discord server, or email me via +ben@bensimms.moe if you've written a bot using calamity, or don't want your +project listed here) + ``` haskell +#!/usr/bin/env cabal +{- cabal: + build-depends: + base >= 4.13 && < 5 + , calamity >= 0.1.28 + , text >= 1.2 && < 2 + , lens >= 4.18 && < 5 + , di-polysemy ^>= 0.2 + , di >= 1.3 && < 2 + , df1 >= 0.3 && < 0.5 + , di-core ^>= 1.0.4 + , polysemy ^>= 1.5 + , polysemy-plugin ^>= 0.3 + , stm ^>= 2.5 + , text-show ^>= 3.9 +-} + +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} + {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -61,7 +90,7 @@ import Calamity import Calamity.Cache.InMemory import Calamity.Commands -import qualified Calamity.Commands.Context as CommandContext +import qualified Calamity.Commands.Context as CommandContext import Calamity.Metrics.Noop import Control.Concurrent @@ -69,8 +98,7 @@ import Control.Lens import Control.Monad -import Data.Text.Lazy ( Text, fromStrict ) -import Data.Text.Strict.Lens +import qualified Data.Text.Lazy as L import qualified Di import qualified DiPolysemy as DiP @@ -83,6 +111,8 @@ import Prelude hiding ( error ) +import System.Environment (getEnv) + import TextShow data Counter m a where @@ -99,19 +129,19 @@ handleFailByLogging m = do r <- P.runFail m case r of - Left e -> DiP.error (e ^. packed) + Left e -> DiP.error $ L.pack e _ -> pure () -info, debug :: BotC r => Text -> P.Sem r () +info, debug :: BotC r => L.Text -> P.Sem r () info = DiP.info debug = DiP.info -tellt :: (BotC r, Tellable t) => t -> Text -> P.Sem r (Either RestError Message) +tellt :: (BotC r, Tellable t) => t -> L.Text -> P.Sem r (Either RestError Message) tellt t m = tell t $ L.toStrict m main :: IO () main = do - token <- view packed <$> getEnv "BOT_TOKEN" + token <- L.pack <$> getEnv "BOT_TOKEN" Di.new $ \di -> void . P.runFinal . P.embedToFinal . DiP.runDiToIO di . runCounterAtomic . runCacheInMemory . runMetricsNoop . useConstantPrefix "!" $ runBotIO (BotToken token) defaultIntents $ do @@ -122,7 +152,7 @@ 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 + info $ "something = " <> showtl something <> ", aUser = " <> showtl aUser command @'[] "hello" $ \ctx -> do void $ tellt ctx "heya" group "testgroup" $ do @@ -155,11 +185,11 @@ info "sleeping" P.embed $ threadDelay (5 * 1000 * 1000) info "slept" - void . invoke $ EditMessage (msg ^. #channelID) msg' (Just "lol") Nothing + void . invoke $ EditMessage (msg ^. #channelID) msg' (editMessageContent $ Just "lol") info "edited" _ -> pure () react @('CustomEvt "command-error" (CommandContext.Context, CommandError)) $ \(ctx, e) -> do - info $ "Command failed with reason: " <> showt e + info $ "Command failed with reason: " <> showtl 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) -> @@ -172,13 +202,20 @@ can do something along the lines of: ``` haskell +import qualified Di +import qualified Df1 +import qualified Di.Core +import qualified DiPolysemy + +filterDi :: Di.Core.Di l Di.Path m -> Di.Core.Di l Di.Path m +filterDi = Di.Core.filter (\_ p _ -> Df1.Push "calamity" `notElem` p) + Di.new $ \di -> -- ... . runDiToIO di - -- disable logs emitted inside calamity - . DiPolysemy.local (Di.Core.filter (\_ _ _ -> False)) - . runBotIO -- ... - -- re-enable logs emitted inside your bot's code - . DiPolysemy.local (const di) + -- disable logs emitted by calamity + . DiPolysemy.local filterDi + . runBotIO + -- ... ``` 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: e75edd6f528871c8867bbd8aa43ae458a8b7c3f45bb7b7b64456611f988244a3 +-- hash: 89740b43cb19ef8c4833319daf4096283256327512903f70f9f82463297c7d07 name: calamity -version: 0.1.28.5 +version: 0.1.29.0 synopsis: A library for writing discord bots in haskell description: Please see the README on GitHub at category: Network, Web @@ -138,7 +138,7 @@ build-depends: aeson >=1.4 && <2 , async >=2.2 && <3 - , base >=4.12 && <5 + , base >=4.13 && <5 , bytestring >=0.10 && <0.12 , colour >=2.3.5 && <2.4 , concurrent-extra >=0.7 && <0.8 @@ -148,7 +148,7 @@ , data-flags >=0.0.3 && <0.1 , deepseq >=1.4.4.0 && <2 , deque >=0.4 && <0.5 - , df1 >=0.3 && <0.5 + , df1 >=0.4 && <0.5 , di-core >=1.0.4 && <1.1 , di-polysemy >=0.2 && <0.3 , exceptions >=0.10 && <0.11 @@ -160,13 +160,13 @@ , http-client >=0.5 && <0.8 , http-date >=0.0.8 && <0.1 , http-types >=0.12 && <0.13 - , lens >=4.18 && <5 + , lens >=4.18 && <6 , lens-aeson >=1.1 && <2 , megaparsec >=8 && <10 , mime-types >=0.1 && <0.2 , mtl >=2.2 && <3 - , polysemy >=1.3 && <2 - , polysemy-plugin >=0.2 && <0.4 + , polysemy >=1.5 && <2 + , polysemy-plugin >=0.3 && <0.4 , reflection >=2.1 && <3 , req >=3.1 && <3.10 , safe-exceptions >=0.1 && <2