calamity 0.1.0.0 → 0.1.2.0
raw patch · 14 files changed
+318/−200 lines, 14 filesdep +containersdep ~di-polysemy
Dependencies added: containers
Dependency ranges changed: di-polysemy
Files
- ChangeLog.md +6/−0
- README.md +29/−21
- cabal.project +1/−1
- calamity.cabal +134/−136
- src/Calamity/Client/Client.hs +11/−14
- src/Calamity/Client/ShardManager.hs +3/−6
- src/Calamity/Client/Types.hs +8/−1
- src/Calamity/Gateway/Shard.hs +3/−2
- src/Calamity/Gateway/Types.hs +4/−5
- src/Calamity/HTTP/Internal/Ratelimit.hs +6/−13
- src/Calamity/Internal/Utils.hs +11/−1
- src/Calamity/Metrics/Eff.hs +62/−0
- src/Calamity/Metrics/Internal.hs +20/−0
- src/Calamity/Metrics/Noop.hs +20/−0
ChangeLog.md view
@@ -1,3 +1,9 @@ # Changelog for Calamity +## 0.1.2.0++*2020-04-27*++* Calamity.Client: runBotIO now has a `Polysemy.Fail` effect+ ## Unreleased changes
README.md view
@@ -23,6 +23,7 @@ import Calamity import Calamity.Cache.InMemory+import Calamity.Metrics.Noop import Control.Concurrent import Control.Concurrent.STM.TVar@@ -55,35 +56,42 @@ P.runAtomicStateTVar var $ P.reinterpret (\case GetCounter -> P.atomicState (\v -> (v + 1, v))) m -handleErrorByLogging m = do+handleFailByLogging m = do r <- P.runFail m case r of Left e -> DiP.error (e ^. packed) _ -> pure () +handleFailByPrinting m = do+ r <- P.runFail m+ case r of+ Left e -> P.embed $ print (show e)+ _ -> pure ()+ info = DiP.info @Text debug = DiP.info @Text main :: IO () main = do- P.runFinal . P.embedToFinal . runCounterAtomic . runCacheInMemory $ runBotIO (BotToken "") $ do- react @"messagecreate" $ \msg -> handleErrorByLogging $ do- when (msg ^. #content == "!count") $ replicateM_ 3 $ do- val <- getCounter- info $ "the counter is: " <> fromStrict (showt val)- void . invokeRequest $ CreateMessage (msg ^. #channelID) ("The value is: " <> showt val)- when (msg ^. #content == "!say hi") $ replicateM_ 3 . P.async $ do- info "saying heya"- Right msg' <- invokeRequest $ CreateMessage (msg ^. #channelID) "heya"- info "sleeping"- P.embed $ threadDelay (5 * 1000 * 1000)- info "slept"- void . invokeRequest $ EditMessage (msg ^. #channelID) msg' (Just "lol") Nothing- info "edited"- when (msg ^. #content == "!explode") $ do- Just x <- pure Nothing- debug "unreachable!"- when (msg ^. #content == "!bye") $ do- void . invokeRequest $ CreateMessage (msg ^. #channelID) "bye!"- stopBot+ P.runFinal . P.embedToFinal . handleFailByPrinting . runCounterAtomic . runCacheInMemory . runMetricsNoop $ runBotIO+ (BotToken "") $ do+ react @"messagecreate" $ \msg -> handleFailByLogging $ do+ when (msg ^. #content == "!count") $ replicateM_ 3 $ do+ val <- getCounter+ info $ "the counter is: " <> fromStrict (showt val)+ void . invokeRequest $ CreateMessage (msg ^. #channelID) ("The value is: " <> showt val)+ when (msg ^. #content == "!say hi") $ replicateM_ 3 . P.async $ do+ info "saying heya"+ Right msg' <- invokeRequest $ CreateMessage (msg ^. #channelID) "heya"+ info "sleeping"+ P.embed $ threadDelay (5 * 1000 * 1000)+ info "slept"+ void . invokeRequest $ EditMessage (msg ^. #channelID) msg' (Just "lol") Nothing+ info "edited"+ when (msg ^. #content == "!explode") $ do+ Just x <- pure Nothing+ debug "unreachable!"+ when (msg ^. #content == "!bye") $ do+ void . invokeRequest $ CreateMessage (msg ^. #channelID) "bye!"+ stopBot ```
cabal.project view
@@ -1,6 +1,6 @@ -- Generated by stackage-to-hackage -with-compiler: ghc-8.6.5+with-compiler: ghc-8.8.3 packages: ./
calamity.cabal view
@@ -1,145 +1,143 @@ cabal-version: 1.18-name: calamity-version: 0.1.0.0-license: MIT-license-file: LICENSE-copyright: 2020 Ben Simms-maintainer: ben@bensimms.moe-author: Ben Simms-tested-with: ghc ==8.6.5-homepage: https://github.com/nitros12/calamity-bug-reports: https://github.com/nitros12/calamity/issues-synopsis: A library for writing discord bots-description:- Please see the README on GitHub at <https://github.com/nitros12/calamity#readme>-category: Network, Web-build-type: Simple++-- This file has been generated from package.yaml by hpack version 0.31.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: d58d4118390485680eba20c1d9dbc30df68a2f58ff358e7fd5f1a04be6a5b3c0++name: calamity+version: 0.1.2.0+synopsis: A library for writing discord bots+description: Please see the README on GitHub at <https://github.com/nitros12/calamity#readme>+category: Network, Web+homepage: https://github.com/nitros12/calamity+bug-reports: https://github.com/nitros12/calamity/issues+author: Ben Simms+maintainer: ben@bensimms.moe+copyright: 2020 Ben Simms+license: MIT+license-file: LICENSE+tested-with: GHC == 8.6.5, GHC == 8.8.3+build-type: Simple extra-source-files: README.md ChangeLog.md cabal.project-extra-doc-files: README.md+extra-doc-files:+ README.md source-repository head- type: git- location: https://github.com/nitros12/calamity+ type: git+ location: https://github.com/nitros12/calamity library- exposed-modules:- Calamity- Calamity.Cache.Eff- Calamity.Cache.InMemory- Calamity.Client- Calamity.Client.Client- Calamity.Client.ShardManager- Calamity.Client.Types- Calamity.Gateway- Calamity.Gateway.DispatchEvents- Calamity.Gateway.Shard- Calamity.Gateway.Types- Calamity.HTTP- Calamity.HTTP.Channel- Calamity.HTTP.Emoji- Calamity.HTTP.Guild- Calamity.HTTP.Internal.Ratelimit- Calamity.HTTP.Internal.Request- Calamity.HTTP.Internal.Route- Calamity.HTTP.Internal.Types- Calamity.HTTP.MiscRoutes- Calamity.Internal.AesonThings- Calamity.Internal.MessageStore- Calamity.Internal.SnowflakeMap- Calamity.Internal.Updateable- Calamity.Internal.Utils- Calamity.LogEff- Calamity.Types- Calamity.Types.Model- Calamity.Types.Model.Channel- Calamity.Types.Model.Channel.Attachment- Calamity.Types.Model.Channel.ChannelType- Calamity.Types.Model.Channel.DM- Calamity.Types.Model.Channel.Embed- Calamity.Types.Model.Channel.Group- Calamity.Types.Model.Channel.Guild- Calamity.Types.Model.Channel.Guild.Category- Calamity.Types.Model.Channel.Guild.Text- Calamity.Types.Model.Channel.Guild.Voice- Calamity.Types.Model.Channel.Message- Calamity.Types.Model.Channel.Reaction- Calamity.Types.Model.Guild- Calamity.Types.Model.Guild.Emoji- Calamity.Types.Model.Guild.Guild- Calamity.Types.Model.Guild.Invite- Calamity.Types.Model.Guild.Member- Calamity.Types.Model.Guild.Overwrite- Calamity.Types.Model.Guild.Role- Calamity.Types.Model.Guild.UnavailableGuild- Calamity.Types.Model.Presence- Calamity.Types.Model.Presence.Activity- Calamity.Types.Model.Presence.Presence- Calamity.Types.Model.User- Calamity.Types.Model.Voice- Calamity.Types.Model.Voice.VoiceState- Calamity.Types.Partial- Calamity.Types.Snowflake- Calamity.Types.Token- Calamity.Types.UnixTimestamp- hs-source-dirs: src- other-modules:- Paths_calamity- default-language: Haskell2010- default-extensions: CPP AllowAmbiguousTypes BlockArguments- NoMonomorphismRestriction AutoDeriveTypeable BangPatterns- BinaryLiterals UndecidableInstances ConstraintKinds DataKinds- DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor- DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls- ExistentialQuantification FlexibleContexts FlexibleInstances- FunctionalDependencies GADTs DerivingVia DerivingStrategies- GeneralizedNewtypeDeriving StandaloneDeriving DeriveAnyClass- InstanceSigs KindSignatures LambdaCase MonadFailDesugaring- MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings- OverloadedLabels PartialTypeSignatures PatternGuards PolyKinds- RankNTypes RecordWildCards ScopedTypeVariables TupleSections- TypeFamilies TypeSynonymInstances ViewPatterns- DuplicateRecordFields TypeOperators TypeApplications- RoleAnnotations- ghc-options: -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall- build-depends:- aeson >=1.4 && <2,- async >=2.2 && <3,- base >=4.12 && <5,- bytestring ==0.10.*,- concurrent-extra ==0.7.*,- data-default-class ==0.1.*,- deepseq >=1.4.4.0 && <2,- deque ==0.4.*,- df1 ==0.3.*,- di-polysemy ==0.1.*,- exceptions ==0.10.*,- fmt ==0.6.*,- focus >=1.0 && <2,- generic-lens >=2.0 && <3,- generic-override >=0.0.0.0 && <0.0.1,- generic-override-aeson >=0.0.0.0 && <0.0.1,- hashable >=1.2 && <2,- http-date >=0.0.8 && <0.1,- http-types ==0.12.*,- lens >=4.18 && <5,- lens-aeson >=1.1 && <2,- mtl >=2.2 && <3,- polysemy >=1.3 && <2,- polysemy-plugin ==0.2.*,- reflection >=2.1 && <3,- scientific ==0.3.*,- stm >=2.5 && <3,- stm-chans >=3.0 && <4,- stm-containers >=1.1 && <2,- text >=1.2 && <2,- text-show >=3.8 && <4,- time >=1.8 && <1.11,- typerep-map ==0.3.*,- unordered-containers ==0.2.*,- vector ==0.12.*,- websockets ==0.12.*,- wreq-patchable >=1.0 && <2,- wuss >=1.1 && <2+ exposed-modules:+ Calamity+ Calamity.Cache.Eff+ Calamity.Cache.InMemory+ Calamity.Client+ Calamity.Client.Client+ Calamity.Client.ShardManager+ Calamity.Client.Types+ Calamity.Gateway+ Calamity.Gateway.DispatchEvents+ Calamity.Gateway.Shard+ Calamity.Gateway.Types+ Calamity.HTTP+ Calamity.HTTP.Channel+ Calamity.HTTP.Emoji+ Calamity.HTTP.Guild+ Calamity.HTTP.Internal.Ratelimit+ Calamity.HTTP.Internal.Request+ Calamity.HTTP.Internal.Route+ Calamity.HTTP.Internal.Types+ Calamity.HTTP.MiscRoutes+ Calamity.Internal.AesonThings+ Calamity.Internal.MessageStore+ Calamity.Internal.SnowflakeMap+ Calamity.Internal.Updateable+ Calamity.Internal.Utils+ Calamity.LogEff+ Calamity.Metrics.Eff+ Calamity.Metrics.Internal+ Calamity.Metrics.Noop+ Calamity.Types+ Calamity.Types.Model+ Calamity.Types.Model.Channel+ Calamity.Types.Model.Channel.Attachment+ Calamity.Types.Model.Channel.ChannelType+ Calamity.Types.Model.Channel.DM+ Calamity.Types.Model.Channel.Embed+ Calamity.Types.Model.Channel.Group+ Calamity.Types.Model.Channel.Guild+ Calamity.Types.Model.Channel.Guild.Category+ Calamity.Types.Model.Channel.Guild.Text+ Calamity.Types.Model.Channel.Guild.Voice+ Calamity.Types.Model.Channel.Message+ Calamity.Types.Model.Channel.Reaction+ Calamity.Types.Model.Guild+ Calamity.Types.Model.Guild.Emoji+ Calamity.Types.Model.Guild.Guild+ Calamity.Types.Model.Guild.Invite+ Calamity.Types.Model.Guild.Member+ Calamity.Types.Model.Guild.Overwrite+ Calamity.Types.Model.Guild.Role+ Calamity.Types.Model.Guild.UnavailableGuild+ Calamity.Types.Model.Presence+ Calamity.Types.Model.Presence.Activity+ Calamity.Types.Model.Presence.Presence+ Calamity.Types.Model.User+ Calamity.Types.Model.Voice+ Calamity.Types.Model.Voice.VoiceState+ Calamity.Types.Partial+ Calamity.Types.Snowflake+ Calamity.Types.Token+ Calamity.Types.UnixTimestamp+ other-modules:+ Paths_calamity+ hs-source-dirs:+ src+ default-extensions: CPP AllowAmbiguousTypes BlockArguments NoMonomorphismRestriction BangPatterns BinaryLiterals UndecidableInstances ConstraintKinds DataKinds DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs DerivingVia DerivingStrategies GeneralizedNewtypeDeriving StandaloneDeriving DeriveAnyClass InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings OverloadedLabels PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables TupleSections TypeFamilies TypeSynonymInstances ViewPatterns DuplicateRecordFields TypeOperators TypeApplications RoleAnnotations+ ghc-options: -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall+ build-depends:+ aeson >=1.4 && <2+ , async >=2.2 && <3+ , base >=4.12 && <5+ , bytestring >=0.10 && <0.11+ , concurrent-extra >=0.7 && <0.8+ , containers >=0.6 && <0.7+ , data-default-class >=0.1 && <0.2+ , deepseq >=1.4.4.0 && <2+ , deque >=0.4 && <0.5+ , df1 >=0.3 && <0.4+ , di-polysemy >=0.1.1 && <0.2+ , exceptions >=0.10 && <0.11+ , fmt >=0.6 && <0.7+ , focus >=1.0 && <2+ , generic-lens >=2.0 && <3+ , generic-override >=0.0.0.0 && <0.0.1+ , generic-override-aeson >=0.0.0.0 && <0.0.1+ , hashable >=1.2 && <2+ , http-date >=0.0.8 && <0.1+ , http-types >=0.12 && <0.13+ , lens >=4.18 && <5+ , lens-aeson >=1.1 && <2+ , mtl >=2.2 && <3+ , polysemy >=1.3 && <2+ , polysemy-plugin >=0.2 && <0.3+ , reflection >=2.1 && <3+ , scientific >=0.3 && <0.4+ , stm >=2.5 && <3+ , stm-chans >=3.0 && <4+ , stm-containers >=1.1 && <2+ , text >=1.2 && <2+ , text-show >=3.8 && <4+ , time >=1.8 && <1.11+ , typerep-map >=0.3 && <0.4+ , unordered-containers >=0.2 && <0.3+ , vector >=0.12 && <0.13+ , websockets >=0.12 && <0.13+ , wreq-patchable >=1.0 && <2+ , wuss >=1.1 && <2+ default-language: Haskell2010
src/Calamity/Client/Client.hs view
@@ -14,7 +14,7 @@ import qualified Calamity.Internal.SnowflakeMap as SM import Calamity.Internal.Updateable import Calamity.Internal.Utils-import Calamity.LogEff+import Calamity.Metrics.Eff import Calamity.Types.Model.Channel import Calamity.Types.Model.Guild.UnavailableGuild import Calamity.Types.Model.Presence ( Presence(..) )@@ -39,7 +39,6 @@ import GHC.TypeLits -import Polysemy ( Sem ) import qualified Polysemy as P import qualified Polysemy.Async as P import qualified Polysemy.AtomicState as P@@ -61,9 +60,7 @@ rlState' eventQueue' -type SetupEff r = Sem (LogEff ': P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r) ()--runBotIO :: (P.Members '[P.Embed IO, P.Final IO, CacheEff] r, Typeable r) => Token -> SetupEff r -> Sem r ()+runBotIO :: (P.Members '[P.Embed IO, P.Final IO, P.Fail, CacheEff, MetricEff] r, Typeable r) => Token -> SetupEff r -> P.Sem r () runBotIO token setup = do client <- P.embed $ newClient token handlers <- P.embed $ newTVarIO def@@ -73,12 +70,12 @@ clientLoop finishUp -react :: forall (s :: Symbol) r. (KnownSymbol s, BotC r, EHType' s ~ Dynamic, Typeable (EHType s (Sem r))) => EHType s (Sem r) -> Sem r ()+react :: forall (s :: Symbol) r. (KnownSymbol s, BotC r, EHType' s ~ Dynamic, Typeable (EHType s (P.Sem r))) => EHType s (P.Sem r) -> P.Sem r () react f = let handlers = EventHandlers . TM.one $ EH @s [toDyn f] in P.atomicModify (handlers <>) -stopBot :: BotC r => Sem r ()+stopBot :: BotC r => P.Sem r () stopBot = do debug "stopping bot" shards <- P.asks (^. #shards) >>= P.embed . readTVarIO@@ -87,7 +84,7 @@ eventQueue <- P.asks (^. #eventQueue) P.embed . atomically $ writeTQueue eventQueue ShutDown -finishUp :: BotC r => Sem r ()+finishUp :: BotC r => P.Sem r () finishUp = do debug "finishing up" shards <- P.asks (^. #shards) >>= P.embed . readTVarIO@@ -96,7 +93,7 @@ -- | main loop of the client, handles fetching the next event, processing the event -- and invoking it's handler functions-clientLoop :: BotC r => Sem r ()+clientLoop :: BotC r => P.Sem r () clientLoop = do evtQueue <- P.asks (^. #eventQueue) void . P.runError . forever $ do@@ -106,7 +103,7 @@ ShutDown -> P.throw () debug "leaving client loop" -handleEvent :: BotC r => DispatchData -> Sem r ()+handleEvent :: BotC r => DispatchData -> P.Sem r () handleEvent data' = do debug "handling an event" eventHandlers <- P.atomicGet@@ -125,9 +122,9 @@ -- event handlers unwrapEvent :: forall s r.- (KnownSymbol s, EHType' s ~ Dynamic, Typeable r, Typeable (EHType s (Sem r)))+ (KnownSymbol s, EHType' s ~ Dynamic, Typeable r, Typeable (EHType s (P.Sem r))) => EventHandlers- -> [EHType s (Sem r)]+ -> [EHType s (P.Sem r)] unwrapEvent (EventHandlers eh) = map (fromJust . fromDynamic) . unwrapEventHandler @s . fromJust $ (TM.lookup eh :: Maybe (EventHandler s)) -- where unwrapEach handler =@@ -137,7 +134,7 @@ handleEvent' :: BotC r => EventHandlers -> DispatchData- -> Sem (P.Fail ': r) [Sem r ()]+ -> P.Sem (P.Fail ': r) [P.Sem r ()] handleEvent' eh evt@(Ready rd@ReadyData { user, guilds }) = do updateCache evt pure $ map ($ rd) (unwrapEvent @"ready" eh)@@ -333,7 +330,7 @@ handleEvent' _ e = fail $ "Unhandled event: " <> show e -updateCache :: P.Members '[CacheEff, P.Fail] r => DispatchData -> Sem r ()+updateCache :: P.Members '[CacheEff, P.Fail] r => DispatchData -> P.Sem r () updateCache (Ready ReadyData { user, guilds }) = do setBotUser user for_ (map getID guilds) setUnavailableGuild
src/Calamity/Client/ShardManager.hs view
@@ -17,15 +17,12 @@ import Fmt import Polysemy ( Sem )+import qualified Polysemy.Fail as P import qualified Polysemy as P import qualified Polysemy.Reader as P -aa :: (Show a, Monad m) => Either a b -> m b-aa (Right x) = pure x-aa (Left x) = fail $ show x- -- | Connects the bot to the gateway over n shards-shardBot :: BotC r => Sem r ()+shardBot :: (BotC r, P.Member P.Fail r) => Sem r () shardBot = do numShardsVar <- P.asks numShards shardsVar <- P.asks shards@@ -36,7 +33,7 @@ token <- P.asks Calamity.Client.Types.token eventQueue <- P.asks eventQueue - gateway <- aa =<< invokeRequest GetGatewayBot+ Right gateway <- invokeRequest GetGatewayBot let numShards' = gateway ^. #shards let host = gateway ^. #url
src/Calamity/Client/Types.hs view
@@ -2,11 +2,13 @@ module Calamity.Client.Types ( Client(..) , BotC+ , SetupEff , EHType , EHType' , EventHandlers(..) , EventHandler(..) ) where +import Calamity.Metrics.Eff import Calamity.Cache.Eff import Calamity.Gateway.DispatchEvents import Calamity.Gateway.Shard@@ -47,7 +49,12 @@ } deriving ( Generic ) -type BotC r = (LogC r, P.Members '[CacheEff, P.Reader Client, P.AtomicState EventHandlers, P.Embed IO, P.Final IO, P.Async] r, Typeable r)+type BotC r =+ ( P.Members '[LogEff, MetricEff, CacheEff, P.Reader Client,+ P.AtomicState EventHandlers, P.Embed IO, P.Final IO, P.Async] r+ , Typeable r)++type SetupEff r = P.Sem (LogEff ': P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r) () type family EHType d m where EHType "ready" m = ReadyData -> m ()
src/Calamity/Gateway/Shard.hs view
@@ -10,6 +10,7 @@ import Calamity.Gateway.Types import Calamity.Internal.Utils import Calamity.LogEff+import Calamity.Metrics.Eff import Calamity.Types.Token import Control.Concurrent@@ -72,7 +73,7 @@ newShardState shard = ShardState shard Nothing Nothing False Nothing Nothing Nothing -- | Creates and launches a shard-newShard :: P.Members '[LogEff, P.Embed IO, P.Final IO, P.Async] r+newShard :: P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO, P.Async] r => Text -> Int -> Int@@ -141,7 +142,7 @@ r <- atomically $ tryWriteTBMQueue' outqueue (Control v) when r inner - discordStream :: P.Members '[LogEff, P.Embed IO] r => Connection -> TBMQueue ShardMsg -> Sem r ()+ discordStream :: P.Members '[LogEff, MetricEff, P.Embed IO] r => Connection -> TBMQueue ShardMsg -> Sem r () discordStream ws outqueue = inner where inner = do msg <- P.embed . checkWSClose $ receiveData ws
src/Calamity/Gateway/Types.hs view
@@ -1,11 +1,10 @@-{-# OPTIONS_GHC -Wno-orphans #-}- -- | Types for shards module Calamity.Gateway.Types where import Calamity.Gateway.DispatchEvents import Calamity.Internal.AesonThings import Calamity.LogEff+import Calamity.Metrics.Eff import Calamity.Types.Model.Guild.Guild import Calamity.Types.Model.Voice import Calamity.Types.Snowflake@@ -14,7 +13,6 @@ import Control.Concurrent.STM.TQueue import Control.Concurrent.STM.TVar import Control.Exception-import Control.Monad ( fail ) import Data.Aeson import qualified Data.Aeson.Types as AT@@ -30,6 +28,9 @@ import qualified Polysemy.Async as P import qualified Polysemy.AtomicState as P +type ShardC r = P.Members '[LogEff, P.AtomicState ShardState, P.Embed IO, P.Final IO,+ P.Async, MetricEff] r+ data ShardMsg = Discord ReceivedDiscordMessage | Control ControlMessage@@ -243,5 +244,3 @@ , wsConn :: Maybe Connection } deriving ( Generic )--type ShardC r = (LogC r, P.Members '[P.AtomicState ShardState, P.Embed IO, P.Final IO, P.Async] r)
src/Calamity/HTTP/Internal/Ratelimit.hs view
@@ -54,14 +54,8 @@ getRateLimit :: RateLimitState -> Route -> STM Lock getRateLimit s h = SC.focus (lookupOrInsertDefaultM L.new) h (rateLimits s) -doDiscordRequest- :: BotC r- => IO (Response LB.ByteString)- -> Sem r DiscordResponseType+doDiscordRequest :: BotC r => IO (Response LB.ByteString) -> Sem r DiscordResponseType doDiscordRequest r = do- --debug "making request"- --maskState <- P.embed getMaskingState- --print maskState r' <- P.embed r let status = r' ^. responseStatus if@@ -69,11 +63,8 @@ let resp = r' ^. responseBody debug $ "Got good response from discord: " +|| r' ^. responseStatus ||+ "" pure $ if isExhausted r'- then ExhaustedBucket resp $ parseRateLimitHeader r'- else Good resp- | statusIsServerError status -> do- debug $ "Got server error from discord: " +| status ^. statusCode |+ ""- pure $ ServerError (status ^. statusCode)+ then ExhaustedBucket resp $ parseRateLimitHeader r'+ else Good resp | status == status429 -> do debug "Got 429 from discord, retrying." case asValue r' of@@ -83,7 +74,9 @@ let err = r' ^. responseBody error $ "You fucked up: " +|| err ||+ " response: " +|| r' ||+ "" pure $ ClientError (status ^. statusCode) err- | otherwise -> fail "Bogus response, discord fix your shit"+ | otherwise -> do+ debug $ "Got server error from discord: " +| status ^. statusCode |+ ""+ pure $ ServerError (status ^. statusCode) parseDiscordTime :: ByteString -> Maybe UTCTime parseDiscordTime s = httpDateToUTC <$> parseHTTPDate s
src/Calamity/Internal/Utils.hs view
@@ -1,3 +1,5 @@+{-# OPTIONS_GHC -Wno-orphans #-}+-- | Internal utilities and instances module Calamity.Internal.Utils ( whenJust , whenM@@ -11,7 +13,9 @@ import Calamity.LogEff +import Data.Default.Class import qualified Data.HashMap.Lazy as LH+import qualified Data.Map as M import Data.Semigroup ( Last(..) ) import Data.Text.Lazy import Data.Time@@ -61,6 +65,12 @@ instance (TextShow a, VU.Unbox a) => TextShow (Vector a) where showb = showbList . VU.toList --- lazy and strict use the same internal data structure+ -- lazy and strict use the same internal data structure instance (Show k, Show v) => TextShow (LH.HashMap k v) where showb = fromString . show++instance (Show k, Show v) => TextShow (M.Map k v) where+ showb = fromString . show++instance Default (M.Map k v) where+ def = M.empty
+ src/Calamity/Metrics/Eff.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Effect for handling metrics+module Calamity.Metrics.Eff+ ( Counter+ , Gauge+ , Histogram+ , HistogramSample+ , MetricEff(..)+ , registerCounter+ , registerGauge+ , registerHistogram+ , addCounter+ , modifyGauge+ , observeHistogram ) where++import Calamity.Internal.Utils ()+import Calamity.Metrics.Internal++import Data.Default.Class+import Data.Map+import Data.Text++import GHC.Generics++import Polysemy++import TextShow+import qualified TextShow.Generic as TSG++data HistogramSample = HistogramSample+ { buckets :: Map Double Double+ , sum :: Double+ , count :: Int+ }+ deriving ( Eq, Show, Generic, Default )+ deriving ( TextShow ) via TSG.FromGeneric HistogramSample++data MetricEff m a where+ -- | Register a 'Counter'+ RegisterCounter :: Text -- ^ Name+ -> [(Text, Text)] -- ^ Labels+ -> MetricEff m Counter++ -- | Register a 'Gauge'+ RegisterGauge :: Text -- ^ Name+ -> [(Text, Text)] -- ^ Labels+ -> MetricEff m Gauge++ -- | Register a 'Histogram'+ RegisterHistogram :: Text -- ^ Name+ -> [(Text, Text)] -- ^ Labels+ -> [Double] -- ^ Upper bounds+ -> MetricEff m Histogram++ AddCounter :: Int -> Counter -> MetricEff m Int++ ModifyGauge :: (Double -> Double) -> Gauge -> MetricEff m Double++ ObserveHistogram :: Double -> Histogram -> MetricEff m HistogramSample++makeSem ''MetricEff
+ src/Calamity/Metrics/Internal.hs view
@@ -0,0 +1,20 @@+-- | Internal data structures to the metrics effect+module Calamity.Metrics.Internal+ ( Counter(..)+ , Gauge(..)+ , Histogram(..) ) where++-- | A handle to a counter+newtype Counter = Counter+ { unCounter :: Int+ }++-- | A handle to a gauge+newtype Gauge = Gauge+ { unGauge :: Int+ }++-- | A handle to a histogram+newtype Histogram = Histogram+ { unHistogram :: Int+ }
+ src/Calamity/Metrics/Noop.hs view
@@ -0,0 +1,20 @@+-- | Noop handler for metrics+module Calamity.Metrics.Noop+ ( runMetricsNoop ) where++import Calamity.Metrics.Eff+import Calamity.Metrics.Internal++import Data.Default.Class++import Polysemy++runMetricsNoop :: Sem (MetricEff ': r) a -> Sem r a+runMetricsNoop = interpret $ \case+ RegisterCounter _ _ -> pure (Counter 0)+ RegisterGauge _ _ -> pure (Gauge 0)+ RegisterHistogram _ _ _ -> pure (Histogram 0)++ AddCounter _ _ -> pure def+ ModifyGauge _ _ -> pure def+ ObserveHistogram _ _ -> pure def