calamity 0.1.9.3 → 0.1.9.4

raw patch · 14 files changed

+203/−50 lines, 14 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• calamity.cabal +3/−2
• src/Calamity/Client.hs +38/−1
• src/Calamity/Client/Client.hs +20/−16
• src/Calamity/Commands.hs +29/−1
• src/Calamity/Commands/CommandUtils.hs +13/−1
• src/Calamity/Commands/Help.hs +5/−11
• src/Calamity/Commands/Utils.hs +6/−2
• src/Calamity/Gateway.hs +15/−1
• src/Calamity/Gateway/DispatchEvents.hs +8/−3
• src/Calamity/Gateway/Shard.hs +1/−6
• src/Calamity/HTTP.hs +30/−1
• src/Calamity/HTTP/Internal/Request.hs +0/−4
• src/Calamity/Internal/ConstructorName.hs +24/−0
• src/Calamity/Types.hs +11/−1

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: f88c96cab00a86482d236a3a5f86d11d093b8179d8390725eabf46a12e054881+-- hash: d09b5d61b03cb493c415218e661c595c070b5c50807b090c8689f0cbe15a9782  name:           calamity-version:        0.1.9.3+version:        0.1.9.4 synopsis:       A library for writing discord bots description:    Please see the README on GitHub at <https://github.com/nitros12/calamity#readme> category:       Network, Web@@ -73,6 +73,7 @@       Calamity.HTTP.Webhook       Calamity.Internal.AesonThings       Calamity.Internal.BoundedStore+      Calamity.Internal.ConstructorName       Calamity.Internal.GenericCurry       Calamity.Internal.LocalWriter       Calamity.Internal.RunIntoIO

@@ -1,7 +1,44 @@ -- | Module containing the core client stuff module Calamity.Client     ( module Calamity.Client.Client-    , module Calamity.Client.Types ) where+    , module Calamity.Client.Types+    -- * Client stuff+    -- $clientDocs+    ) where  import           Calamity.Client.Client import           Calamity.Client.Types++-- $clientDocs+--+-- This module provides the core components for running a discord client, along+-- with abstractions for registering event handlers, firing custom events, and+-- waiting on events.+--+--+-- ==== Registered Metrics+--+--     1. Counter: @"events_recieved" [type, shard]@+--+--         Incremented for each event received, the @type@ parameter is the type+--         of event (the name of the constructor in+--         'Calamity.Gateway.DispatchEvents.DispatchData'), and @shard@ is the+--         ID of the shard that received the event.+--+--     2. Histogram: @"cache_update"@+--+--         Tracks how long it takes to update the cache after recieving an event.+--+--     3. Histogram: @"event_handle"@+--+--         Tracks how long it takes to process an event handler for an event.+--+--+-- ==== Examples+--+-- A simple client that prints every message recieved:+--+-- @+-- 'Control.Monad.void' . 'Polysemy.runFinal' . 'Polysemy.embedToFinal' . 'Calamity.Cache.InMemory.runCacheInMemory' . 'Calamity.Metrics.Noop.runMetricsNoop' $ 'runBotIO' ('Calamity.Types.Token.BotToken' token) $ do+--   'react' \@\''MessageCreateEvt' (\msg -> 'Polysemy.embed' $ 'print' msg)+-- @

@@ -19,23 +19,24 @@ import           Calamity.Gateway.DispatchEvents import           Calamity.Gateway.Types import           Calamity.HTTP.Internal.Ratelimit+import           Calamity.Internal.ConstructorName import           Calamity.Internal.GenericCurry import           Calamity.Internal.RunIntoIO-import qualified Calamity.Internal.SnowflakeMap   as SM+import qualified Calamity.Internal.SnowflakeMap    as SM import           Calamity.Internal.Updateable import           Calamity.Internal.Utils import           Calamity.Metrics.Eff import           Calamity.Types.Model.Channel import           Calamity.Types.Model.Guild-import           Calamity.Types.Model.Presence    ( Presence(..) )+import           Calamity.Types.Model.Presence     ( Presence(..) ) import           Calamity.Types.Snowflake import           Calamity.Types.Token  import           Control.Concurrent.Chan.Unagi import           Control.Concurrent.MVar import           Control.Concurrent.STM-import           Control.Exception                ( SomeException )-import           Control.Lens                     hiding ( (<.>) )+import           Control.Exception                 ( SomeException )+import           Control.Lens                      hiding ( (<.>) ) import           Control.Monad  import           Data.Default.Class@@ -44,21 +45,24 @@ import           Data.IORef import           Data.Maybe import           Data.Proxy+import qualified Data.Text                         as S import           Data.Time.Clock.POSIX import           Data.Traversable import           Data.Typeable -import qualified DiPolysemy                       as Di+import qualified DiPolysemy                        as Di  import           Fmt -import qualified Polysemy                         as P-import qualified Polysemy.Async                   as P-import qualified Polysemy.AtomicState             as P-import qualified Polysemy.Error                   as P-import qualified Polysemy.Fail                    as P-import qualified Polysemy.Reader                  as P+import qualified Polysemy                          as P+import qualified Polysemy.Async                    as P+import qualified Polysemy.AtomicState              as P+import qualified Polysemy.Error                    as P+import qualified Polysemy.Fail                     as P+import qualified Polysemy.Reader                   as P +import           TextShow                          ( TextShow(showt) )+ timeA :: P.Member (P.Embed IO) r => P.Sem r a -> P.Sem r (Double, a) timeA m = do   start <- P.embed getPOSIXTime@@ -294,7 +298,7 @@     evt' <- P.embed $ readChan outc     case evt' of       -- NOTE: these raise's are needed to raise into the Error effect-      Dispatch evt -> P.raise $ handleEvent evt+      Dispatch sid evt -> P.raise $ handleEvent sid evt       Custom s d   -> P.raise $ handleCustomEvent s d       ShutDown     -> P.throw ()   debug "leaving client loop"@@ -315,11 +319,13 @@     Right _ -> pure ()     Left e -> debug $ "got exception: " +|| e ||+ "" -handleEvent :: BotC r => DispatchData -> P.Sem r ()-handleEvent data' = do+handleEvent :: BotC r => Int -> DispatchData -> P.Sem r ()+handleEvent shardID data' = do   debug "handling an event"   eventHandlers <- P.atomicGet   actions <- P.runFail $ do+    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'     void $ observeHistogram time cacheUpdateHisto@@ -470,8 +476,6 @@   pure $ map (\f -> f guild role) (getEventHandlers @'GuildRoleDeleteEvt eh)  handleEvent' eh evt@(MessageCreate msg) = do-  messagesReceived <- registerCounter "messages_received" mempty-  void $ addCounter 1 messagesReceived   updateCache evt   pure $ map ($ msg) (getEventHandlers @'MessageCreateEvt eh) 

@@ -8,6 +8,7 @@     , module Calamity.Commands.ParsePrefix     , module Calamity.Commands.Parser     , module Calamity.Commands.Help+    , module Calamity.Commands.Context     -- * Commands     -- $commandDocs     ) where@@ -19,6 +20,7 @@ import           Calamity.Commands.ParsePrefix import           Calamity.Commands.Parser import           Calamity.Commands.Utils+import           Calamity.Commands.Context ( Context )  -- $commandDocs --@@ -35,6 +37,32 @@ -- A default help command is provided in 'Calamity.Commands.Help' which can be -- added just by using 'helpCommand' inside the command declaration DSL. --+--+-- ==== Custom Events+--+-- the event handler registered by 'addCommands' will fire the following custom events:+--+--     1. @"command-error" ('Context', 'CommandError')@+--+--         Fired when a command returns an error.+--+--     2. @"command-not-found" ['Data.Text.Lazy.Text']@+--+--         Fired when a valid prefix is used, but the command is not found.+--+--     3. @"command-invoked" 'Context'@+--+--         Fired when a command is successfully invoked.+--+--+-- ==== Registered Metrics+--+--     1. Counter: @"commands_invoked" [name]@+--+--         Incremented on each command invokation, the parameter @name@ is the+--         path/name of the invoked command.+--+-- -- ==== Examples -- -- An example of using commands:@@ -43,7 +71,7 @@ -- 'addCommands' $ do --   'helpCommand' --   'command' \@\'['Calamity.Types.Model.User.User'] "utest" $ \ctx u \-\> do---     'Control.Monad.void' $ 'Calamity.Tellable.tell' ctx $ "got user: " '<>' 'TextShow.showtl' u+--     'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx $ "got user: " '<>' 'TextShow.showtl' u --   'group' "admin" $ do --     'command' \@'[] "bye" $ \ctx -> do --       'Control.Monad.void' $ 'Calamity.Types.Tellable.tell' ctx "bye!"

@@ -7,7 +7,10 @@     , buildParser     , buildCallback     , runCommand-    , invokeCommand ) where+    , invokeCommand+    , groupPath+    , commandPath+    , commandParams ) where  import           Calamity.Commands.Check import           Calamity.Commands.Command@@ -30,6 +33,15 @@ import qualified Polysemy                    as P import qualified Polysemy.Error              as P import qualified Polysemy.Fail               as P++groupPath :: Group -> [S.Text]+groupPath grp = maybe [] groupPath (grp ^. #parent) ++ [grp ^. #name]++commandPath :: Command -> [S.Text]+commandPath Command { name, parent } = maybe [] groupPath parent ++ [name]++commandParams :: Command -> L.Text+commandParams Command { params } = L.fromStrict $ S.unwords 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

@@ -33,16 +33,10 @@ helpCommandHelp :: Context -> L.Text helpCommandHelp _ = "Show help for a command or group." -groupPath :: Group -> [S.Text]-groupPath grp = maybe [] groupPath (grp ^. #parent) ++ [grp ^. #name]--commandParams :: Command -> L.Text-commandParams Command { params } = L.fromStrict $ S.intercalate " " params- helpForCommand :: Context -> Command -> L.Text-helpForCommand ctx (cmd@Command { name, parent, help }) = "```\nUsage: " <> prefix' <> path' <> " " <> params' <> "\n\n" <> help ctx <> "\n```"+helpForCommand ctx (cmd@Command { help }) = "```\nUsage: " <> prefix' <> path' <> " " <> params' <> "\n\n" <> help ctx <> "\n```"   where prefix' = ctx ^. #prefix-        path'   = L.fromStrict . S.intercalate " " $ maybe [] groupPath parent ++ [name]+        path'   = L.fromStrict . S.unwords $ commandPath cmd         params' = commandParams cmd  fmtCommandWithParams :: Command -> L.Text@@ -50,7 +44,7 @@  helpForGroup :: Context -> Group -> L.Text helpForGroup ctx grp = "```\nGroup: " <> path' <> "\n\n" <> (grp ^. #help) ctx <> "\n" <> groupsMsg <> commandsMsg <> "\n```"-  where path' = L.fromStrict . S.intercalate " " $ groupPath grp+  where path' = L.fromStrict . S.unwords $ groupPath grp         groups = LH.keys $ grp ^. #children         commands = LH.elems $ grp ^. #commands         groupsMsg = if null groups then "" else "The following child groups exist:\n" <> L.fromStrict (S.unlines . map ("- " <>) $ groups)@@ -73,11 +67,11 @@     Just (Group' grp@Group { name } remainingPath) ->       let failedMsg = if null remainingPath             then ""-            else "No command or group with the path: `" <> L.fromStrict (S.intercalate " " path) <> "` exists for the group: `" <> L.fromStrict name <> "`\n"+            else "No command or group with the path: `" <> L.fromStrict (S.unwords path) <> "` exists for the group: `" <> L.fromStrict name <> "`\n"       in void $ tell @L.Text ctx $ failedMsg <> "Help for group `" <> L.fromStrict name <> "`: \n" <> helpForGroup ctx grp     Nothing -> let failedMsg = if null path                      then ""-                     else "No command or group with the path: `" <> L.fromStrict (S.intercalate " " path) <> "` was found.\n"+                     else "No command or group with the path: `" <> L.fromStrict (S.unwords path) <> "` was found.\n"                in void $ tell @L.Text ctx $ failedMsg <> rootHelp handler  -- | Given a 'CommandHandler', optionally a parent 'Group', and a list of 'Check's,

@@ -6,6 +6,7 @@     , buildContext ) where  import           Calamity.Cache.Eff+import           Calamity.Metrics.Eff import           Calamity.Client.Client import           Calamity.Client.Types import           Calamity.Commands.Command@@ -64,8 +65,11 @@     case err of       Left (ERR ctx e) -> fire $ customEvt @"command-error" (ctx, e)       Left (NF path)   -> fire $ customEvt @"command-not-found" path-      Left _           -> pure () -- "ignore if no prefix or if context couldn't be built"-      Right ctx        -> fire $ customEvt @"command-run" ctx+      Left _           -> pure () -- ignore if no prefix or if context couldn't be built+      Right ctx        -> do+        cmdInvoke <- registerCounter "commands_invoked" [("name", S.unwords $ commandPath (ctx ^. #command))]+        void $ addCounter 1 cmdInvoke+        fire $ customEvt @"command-invoked" ctx   pure (remove, handler, res)  

@@ -1,7 +1,21 @@ -- | module Calamity.Gateway     ( module Calamity.Gateway.Shard-    , module Calamity.Gateway.Types ) where+    , module Calamity.Gateway.Types+    -- * Gateway+    -- $gatewayDocs+    ) where  import           Calamity.Gateway.Shard import           Calamity.Gateway.Types++-- $gatewayDocs+--+-- This module contains all the gateway related things.+--+--+-- ==== Registered Metrics+--+--     1. Gauge: @"active_shards"@+--+--         Keeps track of how many shards are currently active.

@@ -2,6 +2,7 @@ module Calamity.Gateway.DispatchEvents where  import           Calamity.Internal.AesonThings+import           Calamity.Internal.ConstructorName import           Calamity.Internal.Utils                     () import           Calamity.Types.Model.Channel import           Calamity.Types.Model.Channel.Message@@ -26,8 +27,12 @@ import           GHC.Generics  data CalamityEvent-  = Dispatch DispatchData-  | Custom TypeRep Dynamic+  = Dispatch+    Int -- ^ The shard that pushed this event+    DispatchData -- ^ The attached data+  | Custom+    TypeRep -- ^ The name of the custom event+    Dynamic -- ^ The data sent to the custom event   | ShutDown   deriving ( Show, Generic ) @@ -65,7 +70,7 @@   | VoiceStateUpdate VoiceStateUpdateData   | VoiceServerUpdate VoiceServerUpdateData   | WebhooksUpdate WebhooksUpdateData-  deriving ( Show, Generic )+  deriving ( Show, Generic, CtorName )  data ReadyData = ReadyData   { v         :: Integer

@@ -48,8 +48,6 @@  import           Prelude                         hiding ( error ) -import           TextShow- import           Wuss  data Websocket m a where@@ -223,8 +221,6 @@                   , presence = Nothing                   }) -    receivedMessages <- registerCounter "received_messages" [("shard", showt $ shard ^. #shardID)]-     result <- P.resourceToIOFinal $ P.bracket (P.embed $ newTBMQueueIO 1)       (P.embed . atomically . closeTBMQueue)       (\q -> do@@ -233,7 +229,6 @@         _discordThread <- P.async $ discordStream ws q         (fromEitherVoid <$>) . P.raise . P.runError . forever $ do           -- only we close the queue-          void $ addCounter 1 receivedMessages           msg <- P.embed . atomically $ readTBMQueue q           handleMsg $ fromJust msg) @@ -257,7 +252,7 @@         _ -> pure ()        shard <- P.atomicGets (^. #shardS)-      P.embed $ UC.writeChan (shard ^. #evtIn) (Dispatch data')+      P.embed $ UC.writeChan (shard ^. #evtIn) (Dispatch (shard ^. #shardID) data')      HeartBeatReq -> do       debug "Received heartbeat request"

@@ -10,7 +10,10 @@     , module Calamity.HTTP.User     , module Calamity.HTTP.Reason     , module Calamity.HTTP.Internal.Types-    , module Calamity.HTTP.Webhook ) where+    , module Calamity.HTTP.Webhook+    -- * HTTP+    -- $httpDocs+    ) where  import           Calamity.HTTP.AuditLog import           Calamity.HTTP.Channel@@ -23,3 +26,29 @@ import           Calamity.HTTP.Reason import           Calamity.HTTP.User import           Calamity.HTTP.Webhook++-- $httpDocs+--+-- This module contains all the http related things+--+--+-- ==== Registered Metrics+--+--     1. Gauge: @"inflight_requests" [route]@+--+--         Keeps track of how many requests are currently in-flight, the @route@+--         parameter will be the route that is currently active.+--+--     2. Counter: @"total_requests" [route]@+--+--         Incremented on every request, the @route@ parameter is the route that+--         the request was made on.+--+--+-- ==== Examples+--+-- Editing a message:+--+-- @+-- 'invoke' $ 'EditMessage' someChannel someMessage ('Just' "new content") 'Nothing'+-- @

@@ -81,10 +81,6 @@       void $ modifyGauge succ inFlightRequests       void $ addCounter 1 totalRequests -      whenJust (route' ^. #guildID) $ \guildID -> do-        totalRequestsGuild <- registerCounter "total_requests" [("guild", showt guildID)]-        void $ addCounter 1 totalRequestsGuild-       resp <- attr "route" (route' ^. #path) $ doRequest rlState' route'         (action a (requestOptions token') (route' ^. #path . unpacked)) 

@@ -0,0 +1,24 @@+-- | Get the constructor name of something+module Calamity.Internal.ConstructorName+    ( CtorName(..)+    , GCtorName(..) ) where++import           GHC.Generics++class GCtorName f where+  gctorName :: f a -> String++instance Constructor c => GCtorName (C1 c f) where+  gctorName = conName++instance GCtorName f => GCtorName (D1 d f) where+  gctorName (M1 a) = gctorName a++instance (GCtorName f, GCtorName g) => GCtorName (f :+: g) where+  gctorName (L1 a) = gctorName a+  gctorName (R1 a) = gctorName a++class CtorName a where+  ctorName :: a -> String+  default ctorName :: (Generic a, GCtorName (Rep a)) => a -> String+  ctorName = gctorName . from

@@ -5,7 +5,10 @@     , module Calamity.Types.Snowflake     , module Calamity.Types.Token     , module Calamity.Types.Tellable-    , module Calamity.Types.UnixTimestamp ) where+    , module Calamity.Types.UnixTimestamp+    -- * Types+    -- $typesDocs+    ) where  import           Calamity.Types.Model import           Calamity.Types.Partial@@ -13,3 +16,10 @@ import           Calamity.Types.Token import           Calamity.Types.Tellable import           Calamity.Types.UnixTimestamp++-- $typesDocs+--+-- This module collects all discord models, and other useful types together.+--+-- The 'Tellable' class is also in here, which allows you to construct and send+-- messages to things to you can send messages to in a neat way.