diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,12 @@ # Changelog for Calamity +## 0.1.22.1 + ++ Bump some upper bounds ++ Fix parsing of members from GetGuildMember ++ Make game field in Presence correctly optional ++ Make roles field in Presence updates correctly optional (internal) + ## 0.1.22.0 * Update to gateway/http endpoint v8. 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: b3783e8d7e7db062a2aa10f4642564dea368efe4f9130957aaa0259e2f96e54e +-- hash: a5846981d4aa83053956a4f860e1145f8c044323b2d869cf4a670bad5106addf name: calamity -version: 0.1.22.0 +version: 0.1.22.1 synopsis: A library for writing discord bots in haskell description: Please see the README on GitHub at category: Network, Web @@ -140,7 +140,7 @@ aeson >=1.4 && <2 , async >=2.2 && <3 , base >=4.12 && <5 - , bytestring >=0.10 && <0.11 + , bytestring >=0.10 && <0.12 , colour >=2.3.5 && <2.4 , concurrent-extra >=0.7 && <0.8 , containers >=0.6 && <0.7 @@ -162,7 +162,7 @@ , http-types >=0.12 && <0.13 , lens >=4.18 && <5 , lens-aeson >=1.1 && <2 - , megaparsec >=8 && <9 + , megaparsec >=8 && <10 , mime-types >=0.1 && <0.2 , mtl >=2.2 && <3 , polysemy >=1.3 && <2 @@ -175,10 +175,10 @@ , stm-containers >=1.1 && <2 , text >=1.2 && <2 , text-show >=3.8 && <4 - , time >=1.8 && <1.11 + , time >=1.8 && <1.12 , typerep-map >=0.3 && <0.4 , unagi-chan >=0.4 && <0.5 - , unboxing-vector >=0.1 && <0.2 + , unboxing-vector >=0.2 && <0.3 , unordered-containers >=0.2 && <0.3 , vector >=0.12 && <0.13 , websockets >=0.12 && <0.13 diff --git a/src/Calamity/HTTP.hs b/src/Calamity/HTTP.hs --- a/src/Calamity/HTTP.hs +++ b/src/Calamity/HTTP.hs @@ -1,7 +1,7 @@ -- | Combined http request stuff module Calamity.HTTP - ( module Calamity.HTTP.AuditLog - , module Calamity.HTTP.Internal.Request + ( invoke + , module Calamity.HTTP.AuditLog , module Calamity.HTTP.Channel , module Calamity.HTTP.Emoji , module Calamity.HTTP.Guild diff --git a/src/Calamity/HTTP/Guild.hs b/src/Calamity/HTTP/Guild.hs --- a/src/Calamity/HTTP/Guild.hs +++ b/src/Calamity/HTTP/Guild.hs @@ -27,6 +27,7 @@ import Control.Lens hiding ( (.=) ) import Data.Aeson +import Data.Aeson.Lens import Data.Colour ( Colour ) import Data.Default.Class import Data.Maybe @@ -280,3 +281,9 @@ action (BeginGuildPrune _ d r) = postEmptyP (param "days" .~ [showt d] >>> param "compute_prune_count" .~ [showt r]) action (GetGuildVoiceRegions _) = getWith action (GetGuildInvites _) = getWith + + -- this is a bit of a hack + -- TODO: add something to allow for contextual parsing + modifyResponse (GetGuildMember (getID @Guild -> gid) _) = _Object . at "guild_id" ?~ _String # showt (fromSnowflake gid) + modifyResponse (ListGuildMembers (getID @Guild -> gid) _) = values . _Object . at "guild_id" ?~ _String # showt (fromSnowflake gid) + modifyResponse _ = Prelude.id diff --git a/src/Calamity/HTTP/Internal/Request.hs b/src/Calamity/HTTP/Internal/Request.hs --- a/src/Calamity/HTTP/Internal/Request.hs +++ b/src/Calamity/HTTP/Internal/Request.hs @@ -1,6 +1,7 @@ -- | Generic Request type module Calamity.HTTP.Internal.Request ( Request(..) + , invoke , postWith' , postWithP' , putWith' @@ -67,25 +68,30 @@ action :: a -> Options -> Session -> String -> IO (Response LB.ByteString) - invoke :: (BotC r, FromJSON (Calamity.HTTP.Internal.Request.Result a)) => a -> Sem r (Either RestError (Calamity.HTTP.Internal.Request.Result a)) - invoke a = do - rlState' <- P.asks (^. #rlState) - session <- P.asks (^. #session) - token' <- P.asks (^. #token) + modifyResponse :: a -> Value -> Value + modifyResponse _ = id - let route' = route a - inFlightRequests <- registerGauge "inflight_requests" [("route", route' ^. #path)] - totalRequests <- registerCounter "total_requests" [("route", route' ^. #path)] - void $ modifyGauge (+ 1) inFlightRequests - void $ addCounter 1 totalRequests +invoke :: (BotC r, Request a, FromJSON (Calamity.HTTP.Internal.Request.Result a)) => a -> Sem r (Either RestError (Calamity.HTTP.Internal.Request.Result a)) +invoke a = do + rlState' <- P.asks (^. #rlState) + session <- P.asks (^. #session) + token' <- P.asks (^. #token) - resp <- attr "route" (route' ^. #path) $ doRequest rlState' route' - (action a (requestOptions token') session (route' ^. #path . unpacked)) + let route' = route a - void $ modifyGauge (subtract 1) inFlightRequests + inFlightRequests <- registerGauge "inflight_requests" [("route", route' ^. #path)] + totalRequests <- registerCounter "total_requests" [("route", route' ^. #path)] + void $ modifyGauge (+ 1) inFlightRequests + void $ addCounter 1 totalRequests - P.runError $ (fromResult . fromJSON) =<< (fromJSONDecode . readResp) =<< extractRight resp + resp <- attr "route" (route' ^. #path) $ doRequest rlState' route' + (action a (requestOptions token') session (route' ^. #path . unpacked)) + + void $ modifyGauge (subtract 1) inFlightRequests + + P.runError $ (fromResult . fromJSON . modifyResponse a) =<< (fromJSONDecode . readResp) =<< extractRight resp + defaultRequestOptions :: Options defaultRequestOptions = defaults diff --git a/src/Calamity/Types/Model/Guild/Emoji.hs b/src/Calamity/Types/Model/Guild/Emoji.hs --- a/src/Calamity/Types/Model/Guild/Emoji.hs +++ b/src/Calamity/Types/Model/Guild/Emoji.hs @@ -34,7 +34,9 @@ deriving ( Eq, Show, Generic ) deriving ( TextShow ) via TSG.FromGeneric Emoji deriving ( ToJSON ) via CalamityJSON Emoji - deriving ( FromJSON ) via WithSpecialCases '["user" `ExtractFieldFrom` "id"] Emoji + deriving ( FromJSON ) via WithSpecialCases '["user" `ExtractFieldFrom` "id" + ,"roles" `IfNoneThen` DefaultToEmptyArray + ] Emoji deriving ( HasID Emoji ) via HasIDField "id" Emoji emojiAsRawEmoji :: Emoji -> RawEmoji diff --git a/src/Calamity/Types/Model/Presence/Presence.hs b/src/Calamity/Types/Model/Presence/Presence.hs --- a/src/Calamity/Types/Model/Presence/Presence.hs +++ b/src/Calamity/Types/Model/Presence/Presence.hs @@ -1,43 +1,49 @@ -- | User presences module Calamity.Types.Model.Presence.Presence - ( Presence(..) - , ClientStatus(..) ) where + ( Presence (..), + ClientStatus (..), + ) +where -import Calamity.Internal.AesonThings +import Calamity.Internal.AesonThings import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Presence.Activity -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson -import qualified Data.Override as O -import Data.Override.Aeson () -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG +import Calamity.Types.Model.Presence.Activity +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson +import qualified Data.Override as O +import Data.Override.Aeson () +import Data.Text.Lazy (Text) +import GHC.Generics +import TextShow +import qualified TextShow.Generic as TSG data Presence = Presence - { user :: Snowflake User - , game :: Maybe Activity - , guildID :: Snowflake Guild - , status :: StatusType - , clientStatus :: ClientStatus + { user :: Snowflake User, + game :: Maybe Activity, + guildID :: Snowflake Guild, + status :: StatusType, + clientStatus :: ClientStatus } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Presence - deriving ( ToJSON, FromJSON ) via CalamityJSON - (O.Override Presence '["user" `O.As` Partial User]) - deriving ( HasID User ) via HasIDField "user" Presence - deriving ( HasID Guild ) via HasIDField "guildID" Presence + deriving (Eq, Show, Generic) + deriving (TextShow) via TSG.FromGeneric Presence + deriving + (ToJSON) + via CalamityJSON + (O.Override Presence '["user" `O.As` Partial User]) + deriving + (FromJSON) + via WithSpecialCases + '["user" `ExtractFieldFrom` "user"] + Presence + deriving (HasID User) via HasIDField "user" Presence + deriving (HasID Guild) via HasIDField "guildID" Presence data ClientStatus = ClientStatus - { desktop :: Maybe Text - , mobile :: Maybe Text - , web :: Maybe Text + { desktop :: Maybe Text, + mobile :: Maybe Text, + web :: Maybe Text } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric ClientStatus - deriving ( ToJSON, FromJSON ) via CalamityJSON ClientStatus + deriving (Eq, Show, Generic) + deriving (TextShow) via TSG.FromGeneric ClientStatus + deriving (ToJSON, FromJSON) via CalamityJSON ClientStatus