diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,9 @@ # Changelog for Calamity +## 0.1.24.1 + ++ Fix some memory leaks + ## 0.1.24.0 + Switch from using Wreq to Req 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: 00a40615c76f1d2bb08dcb114163494c4189aa1e755216a1553cacaeba8bb83f +-- hash: 9feeea689fb0b9d305f0fe00b6993523fb12bc6e272225ca890b5af595a2dde9 name: calamity -version: 0.1.24.0 +version: 0.1.24.1 synopsis: A library for writing discord bots in haskell description: Please see the README on GitHub at category: Network, Web @@ -143,6 +143,7 @@ , bytestring >=0.10 && <0.12 , colour >=2.3.5 && <2.4 , concurrent-extra >=0.7 && <0.8 + , connection >=0.2.6 && <0.4 , containers >=0.6 && <0.7 , data-default-class >=0.1 && <0.2 , data-flags >=0.0.3 && <0.1 @@ -178,11 +179,12 @@ , text >=1.2 && <2 , text-show >=3.8 && <4 , time >=1.8 && <1.12 + , tls >=1.4 && <2 , typerep-map >=0.3 && <0.4 , unagi-chan >=0.4 && <0.5 , unboxing-vector >=0.2 && <0.3 , unordered-containers >=0.2 && <0.3 , vector >=0.12 && <0.13 , websockets >=0.12 && <0.13 - , wuss >=1.1 && <2 + , x509-system >=1.6.6 && <1.7 default-language: Haskell2010 diff --git a/src/Calamity/Cache/InMemory.hs b/src/Calamity/Cache/InMemory.hs --- a/src/Calamity/Cache/InMemory.hs +++ b/src/Calamity/Cache/InMemory.hs @@ -1,53 +1,57 @@ -- | A 'Cache' handler that operates in memory -module Calamity.Cache.InMemory - ( runCacheInMemory - , runCacheInMemory' - , runCacheInMemoryNoMsg ) where +module Calamity.Cache.InMemory ( + runCacheInMemory, + runCacheInMemory', + runCacheInMemoryNoMsg, +) where -import Calamity.Cache.Eff +import Calamity.Cache.Eff import qualified Calamity.Internal.BoundedStore as BS import qualified Calamity.Internal.SnowflakeMap as SM -import Calamity.Internal.Utils -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake +import Calamity.Internal.Utils +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild +import Calamity.Types.Model.User +import Calamity.Types.Snowflake -import Control.Lens -import Control.Monad.State.Strict +import Control.Lens +import Control.Monad.State.Strict -import Data.Foldable -import qualified Data.HashMap.Lazy as LH -import qualified Data.HashSet as LS -import Data.IORef +import Data.Foldable +import qualified Data.HashMap.Strict as SH +import qualified Data.HashSet as HS +import Data.IORef -import GHC.Generics +import Control.DeepSeq +import GHC.Generics -import qualified Polysemy as P -import qualified Polysemy.AtomicState as P +import qualified Polysemy as P +import qualified Polysemy.AtomicState as P data Cache f = Cache - { user :: Maybe User - , guilds :: SM.SnowflakeMap Guild - , dms :: SM.SnowflakeMap DMChannel - , guildChannels :: LH.HashMap (Snowflake GuildChannel) Guild - , users :: SM.SnowflakeMap User - , unavailableGuilds :: LS.HashSet (Snowflake Guild) - , messages :: f (BS.BoundedStore Message) + { user :: Maybe User + , guilds :: SM.SnowflakeMap Guild + , dms :: SM.SnowflakeMap DMChannel + , guildChannels :: SH.HashMap (Snowflake GuildChannel) Guild + , users :: SM.SnowflakeMap User + , unavailableGuilds :: HS.HashSet (Snowflake Guild) + , messages :: f (BS.BoundedStore Message) } - deriving ( Generic ) + deriving (Generic) +instance NFData (f (BS.BoundedStore Message)) => NFData (Cache f) + type CacheWithMsg = Cache Identity type CacheNoMsg = Cache (Const ()) emptyCache :: CacheWithMsg -emptyCache = Cache Nothing SM.empty SM.empty LH.empty SM.empty LS.empty (Identity $ BS.empty 1000) +emptyCache = Cache Nothing SM.empty SM.empty SH.empty SM.empty HS.empty (Identity $ BS.empty 1000) emptyCacheNoMsg :: CacheNoMsg -emptyCacheNoMsg = Cache Nothing SM.empty SM.empty LH.empty SM.empty LS.empty (Const ()) +emptyCacheNoMsg = Cache Nothing SM.empty SM.empty SH.empty SM.empty HS.empty (Const ()) emptyCache' :: Int -> CacheWithMsg -emptyCache' msgLimit = Cache Nothing SM.empty SM.empty LH.empty SM.empty LS.empty (Identity $ BS.empty msgLimit) +emptyCache' msgLimit = Cache Nothing SM.empty SM.empty SH.empty SM.empty HS.empty (Identity $ BS.empty msgLimit) -- | Run the cache in memory with a default message cache size of 1000 runCacheInMemory :: P.Member (P.Embed IO) r => P.Sem (CacheEff ': r) a -> P.Sem r a @@ -68,7 +72,7 @@ P.runAtomicStateIORef var $ P.reinterpret runCache' m runCache' :: (MessageMod (Cache t), P.Member (P.AtomicState (Cache t)) r) => CacheEff m a -> P.Sem r a -runCache' act = P.atomicState' ((swap .) . runState $ runCache act) +runCache' act = P.atomicState' ((swap .) . force . runState $ runCache act) class MessageMod t where setMessage' :: Message -> State t () @@ -83,43 +87,37 @@ delMessage' mid = #messages . _Wrapped %= sans mid instance MessageMod CacheNoMsg where - setMessage' _ = pure () - getMessage' _ = pure Nothing + setMessage' !_ = pure () + getMessage' !_ = pure Nothing getMessages' = pure [] - delMessage' _ = pure () + delMessage' !_ = pure () runCache :: MessageMod (Cache t) => CacheEff m a -> State (Cache t) a - runCache (SetBotUser u) = #user ?= u -runCache GetBotUser = use #user - -runCache (SetGuild g) = do +runCache GetBotUser = use #user +runCache (SetGuild g) = do #guilds %= SM.insert g - #guildChannels %= LH.filter (\v -> getID @Guild v /= getID @Guild g) - #guildChannels %= LH.union (LH.fromList $ map (,g) (SM.keys (g ^. #channels))) + #guildChannels %= SH.filter (\v -> getID @Guild v /= getID @Guild g) + #guildChannels %= SH.union (SH.fromList $ map (,g) (SM.keys (g ^. #channels))) runCache (GetGuild gid) = use (#guilds . at gid) runCache (GetGuildChannel cid) = use (#guildChannels . at cid) <&> (>>= (^. #channels . at cid)) -runCache GetGuilds = SM.elems <$> use #guilds +runCache GetGuilds = SM.elems <$> use #guilds runCache (DelGuild gid) = do #guilds %= sans gid - #guildChannels %= LH.filter (\v -> getID @Guild v /= gid) - -runCache (SetDM dm) = #dms %= SM.insert dm + #guildChannels %= SH.filter (\v -> getID @Guild v /= gid) +runCache (SetDM dm) = #dms %= SM.insert dm runCache (GetDM did) = use (#dms . at did) -runCache GetDMs = SM.elems <$> use #dms +runCache GetDMs = SM.elems <$> use #dms runCache (DelDM did) = #dms %= sans did - -runCache (SetUser u) = #users %= SM.insert u +runCache (SetUser u) = #users %= SM.insert u runCache (GetUser uid) = use (#users . at uid) -runCache GetUsers = SM.elems <$> use #users +runCache GetUsers = SM.elems <$> use #users runCache (DelUser uid) = #users %= sans uid - -runCache (SetUnavailableGuild gid) = #unavailableGuilds %= LS.insert gid -runCache (IsUnavailableGuild gid) = use (#unavailableGuilds . contains gid) -runCache GetUnavailableGuilds = LS.toList <$> use #unavailableGuilds +runCache (SetUnavailableGuild gid) = #unavailableGuilds %= HS.insert gid +runCache (IsUnavailableGuild gid) = use (#unavailableGuilds . contains gid) +runCache GetUnavailableGuilds = HS.toList <$> use #unavailableGuilds runCache (DelUnavailableGuild gid) = #unavailableGuilds %= sans gid - -runCache (SetMessage m) = setMessage' m +runCache (SetMessage m) = setMessage' m runCache (GetMessage mid) = getMessage' mid -runCache GetMessages = getMessages' +runCache GetMessages = getMessages' runCache (DelMessage mid) = delMessage' mid 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 @@ -326,11 +326,11 @@ clientLoop = do outc <- P.asks (^. #eventsOut) whileMFinalIO $ do - evt' <- P.embed $ readChan outc + !evt' <- P.embed $ readChan outc case evt' of - Dispatch sid evt -> handleEvent sid evt >> pure True - Custom s d -> handleCustomEvent s d >> pure True - ShutDown -> pure False + 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 () @@ -671,9 +671,9 @@ updateCache (GuildRoleDelete GuildRoleDeleteData { guildID, roleID }) = updateGuild guildID (#roles %~ sans roleID) -updateCache (MessageCreate msg user) = do +updateCache (MessageCreate !msg !user) = do setMessage msg - forM_ user setUser + for_ user setUser updateCache (MessageUpdate msg) = updateMessage (getID msg) (update msg) diff --git a/src/Calamity/Gateway/DispatchEvents.hs b/src/Calamity/Gateway/DispatchEvents.hs --- a/src/Calamity/Gateway/DispatchEvents.hs +++ b/src/Calamity/Gateway/DispatchEvents.hs @@ -37,41 +37,41 @@ deriving ( Show, Generic ) data DispatchData - = Ready ReadyData + = Ready !ReadyData | Resumed - | ChannelCreate Channel - | ChannelUpdate Channel - | ChannelDelete Channel - | ChannelPinsUpdate ChannelPinsUpdateData - | GuildCreate Guild - | GuildUpdate UpdatedGuild - | GuildDelete UnavailableGuild - | GuildBanAdd BanData - | GuildBanRemove BanData - | GuildEmojisUpdate GuildEmojisUpdateData - | GuildIntegrationsUpdate GuildIntegrationsUpdateData - | GuildMemberAdd Member - | GuildMemberRemove GuildMemberRemoveData - | GuildMemberUpdate GuildMemberUpdateData - | GuildMembersChunk GuildMembersChunkData - | GuildRoleCreate GuildRoleData - | GuildRoleUpdate GuildRoleData - | GuildRoleDelete GuildRoleDeleteData - | InviteCreate InviteCreateData - | InviteDelete InviteDeleteData - | MessageCreate Message (Maybe User) - | MessageUpdate UpdatedMessage - | MessageDelete MessageDeleteData - | MessageDeleteBulk MessageDeleteBulkData - | MessageReactionAdd Reaction - | MessageReactionRemove Reaction - | MessageReactionRemoveAll MessageReactionRemoveAllData - | PresenceUpdate PresenceUpdateData - | TypingStart TypingStartData - | UserUpdate User - | VoiceStateUpdate VoiceStateUpdateData - | VoiceServerUpdate VoiceServerUpdateData - | WebhooksUpdate WebhooksUpdateData + | ChannelCreate !Channel + | ChannelUpdate !Channel + | ChannelDelete !Channel + | ChannelPinsUpdate !ChannelPinsUpdateData + | GuildCreate !Guild + | GuildUpdate !UpdatedGuild + | GuildDelete !UnavailableGuild + | GuildBanAdd !BanData + | GuildBanRemove !BanData + | GuildEmojisUpdate !GuildEmojisUpdateData + | GuildIntegrationsUpdate !GuildIntegrationsUpdateData + | GuildMemberAdd !Member + | GuildMemberRemove !GuildMemberRemoveData + | GuildMemberUpdate !GuildMemberUpdateData + | GuildMembersChunk !GuildMembersChunkData + | GuildRoleCreate !GuildRoleData + | GuildRoleUpdate !GuildRoleData + | GuildRoleDelete !GuildRoleDeleteData + | InviteCreate !InviteCreateData + | InviteDelete !InviteDeleteData + | MessageCreate !Message !(Maybe User) + | MessageUpdate !UpdatedMessage + | MessageDelete !MessageDeleteData + | MessageDeleteBulk !MessageDeleteBulkData + | MessageReactionAdd !Reaction + | MessageReactionRemove !Reaction + | MessageReactionRemoveAll !MessageReactionRemoveAllData + | PresenceUpdate !PresenceUpdateData + | TypingStart !TypingStartData + | UserUpdate !User + | VoiceStateUpdate !VoiceStateUpdateData + | VoiceServerUpdate !VoiceServerUpdateData + | WebhooksUpdate !WebhooksUpdateData deriving ( Show, Generic, CtorName ) data ReadyData = ReadyData 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 @@ -1,77 +1,119 @@ --- | The shard logic {-# LANGUAGE RecursiveDo #-} {-# LANGUAGE TemplateHaskell #-} -module Calamity.Gateway.Shard - ( Shard(..) - , newShard ) where +-- | The shard logic +module Calamity.Gateway.Shard ( + Shard (..), + newShard, +) where -import Calamity.Gateway.DispatchEvents -import Calamity.Gateway.Intents -import Calamity.Gateway.Types -import Calamity.Internal.Utils -import Calamity.Internal.RunIntoIO -import Calamity.Metrics.Eff -import Calamity.Types.LogEff -import Calamity.Types.Token +import Calamity.Gateway.DispatchEvents +import Calamity.Gateway.Intents +import Calamity.Gateway.Types +import Calamity.Internal.RunIntoIO +import Calamity.Internal.Utils +import Calamity.Metrics.Eff +import Calamity.Types.LogEff +import Calamity.Types.Token -import Control.Concurrent -import Control.Concurrent.Async -import qualified Control.Concurrent.Chan.Unagi as UC -import Control.Concurrent.STM -import Control.Concurrent.STM.TBMQueue -import Control.Exception -import qualified Control.Exception.Safe as Ex -import Control.Lens -import Control.Monad -import Control.Monad.State.Lazy +import Control.Concurrent +import Control.Concurrent.Async +import qualified Control.Concurrent.Chan.Unagi as UC +import Control.Concurrent.STM +import Control.Concurrent.STM.TBMQueue +import Control.Exception +import qualified Control.Exception.Safe as Ex +import Control.Lens +import Control.Monad +import Control.Monad.State.Lazy -import qualified Data.Aeson as A -import Data.Functor -import Data.IORef -import Data.Maybe -import qualified Data.Text.Lazy as L +import qualified Data.Aeson as A +import Data.Functor +import Data.IORef +import Data.Maybe +import qualified Data.Text.Lazy as L -import DiPolysemy hiding ( debug, error, info ) +import DiPolysemy hiding (debug, error, info) -import Fmt +import Fmt -import Network.WebSockets ( Connection, ConnectionException(..), receiveData, sendCloseCode - , sendTextData ) +import Network.WebSockets ( + Connection, + ConnectionException (..), + receiveData, + sendCloseCode, + sendTextData, + ) -import Polysemy ( Sem ) -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.Resource as P +import Polysemy (Sem) +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.Resource as P -import Prelude hiding ( error ) +import Prelude hiding (error) -import Wuss +import qualified Data.ByteString.Lazy as LBS +import Data.Default.Class (def) +import qualified Network.Connection as NC +import qualified Network.TLS as NT +import qualified Network.TLS.Extra as NT +import qualified Network.WebSockets as NW +import qualified Network.WebSockets.Stream as NW +import qualified System.X509 as X509 -runWebsocket :: P.Members '[P.Final IO, P.Embed IO] r - => L.Text - -> L.Text - -> (Connection -> P.Sem r a) - -> P.Sem r (Maybe a) +runWebsocket :: + P.Members '[P.Final IO, P.Embed IO] r => + L.Text -> + L.Text -> + (Connection -> P.Sem r a) -> + P.Sem r (Maybe a) runWebsocket host path ma = do inner <- bindSemToIO ma - P.embed $ runSecureClient (L.unpack host) 443 (L.unpack path) inner + -- We have to do this all ourself I think? + -- TODO: see if this isn't needed + + ctx <- P.embed NC.initConnectionContext + certStore <- P.embed X509.getSystemCertificateStore + let clientParams = + (NT.defaultParamsClient (L.unpack host) "443") + { NT.clientSupported = def{NT.supportedCiphers = NT.ciphersuite_default} + , NT.clientShared = + def + { NT.sharedCAStore = certStore + } + } + let tlsSettings = NC.TLSSettings clientParams + connParams = NC.ConnectionParams (L.unpack host) 443 (Just tlsSettings) Nothing + + P.embed $ + Ex.bracket + (NC.connectTo ctx connParams) + NC.connectionClose + ( \conn -> do + stream <- + NW.makeStream + (Just <$> NC.connectionGetChunk conn) + (maybe (pure ()) (NC.connectionPut conn . LBS.toStrict)) + NW.runClientWithStream stream (L.unpack host) (L.unpack path) NW.defaultConnectionOptions [] inner + ) + newShardState :: Shard -> ShardState newShardState shard = ShardState shard Nothing Nothing False Nothing Nothing Nothing -- | Creates and launches a shard -newShard :: P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO, P.Async] r - => L.Text - -> Int - -> Int - -> Token - -> Maybe StatusUpdateData - -> Intents - -> UC.InChan CalamityEvent - -> Sem r (UC.InChan ControlMessage, Async (Maybe ())) +newShard :: + P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO, P.Async] r => + L.Text -> + Int -> + Int -> + Token -> + Maybe StatusUpdateData -> + Intents -> + UC.InChan CalamityEvent -> + Sem r (UC.InChan ControlMessage, Async (Maybe ())) newShard gateway id count token presence intents evtIn = do (cmdIn, cmdOut) <- P.embed UC.newChan let shard = Shard id count gateway evtIn cmdOut (rawToken token) presence intents @@ -99,12 +141,12 @@ v' <- tryWriteTBMQueue q v case v' of Just False -> retry - Just True -> pure True - Nothing -> pure False + Just True -> pure True + Nothing -> pure False restartUnless :: P.Members '[LogEff, P.Error ShardFlowControl] r => L.Text -> Maybe a -> P.Sem r a -restartUnless _ (Just a) = pure a -restartUnless msg Nothing = do +restartUnless _ (Just a) = pure a +restartUnless msg Nothing = do error msg P.throw ShardFlowRestart @@ -119,12 +161,12 @@ where controlStream :: Shard -> TBMQueue ShardMsg -> IO () controlStream shard outqueue = inner - where - q = shard ^. #cmdOut - inner = do - v <- UC.readChan q - r <- atomically $ tryWriteTBMQueue' outqueue (Control v) - when r inner + where + q = shard ^. #cmdOut + inner = do + v <- UC.readChan q + r <- atomically $ tryWriteTBMQueue' outqueue (Control v) + when r inner handleWSException :: SomeException -> IO (Either (ControlMessage, Maybe L.Text) a) handleWSException e = pure $ case fromException e of @@ -135,31 +177,29 @@ discordStream :: P.Members '[LogEff, MetricEff, P.Embed IO, P.Final IO] r => Connection -> TBMQueue ShardMsg -> Sem r () discordStream ws outqueue = inner - where inner = do - msg <- P.embed $ Ex.catchAny (Right <$> receiveData ws) handleWSException - - case msg of - Left (c, reason) -> do - whenJust reason (\r -> error $ "Shard closed with reason: " <> r) - P.embed . atomically $ writeTBMQueue outqueue (Control c) - - Right msg' -> do - let decoded = A.eitherDecode msg' - r <- case decoded of - Right a -> - P.embed . atomically $ tryWriteTBMQueue' outqueue (Discord a) - Left e -> do - error $ "Failed to decode: "+|e|+"" - pure True - when r inner + where + inner = do + msg <- P.embed $ Ex.catchAny (Right <$> receiveData ws) handleWSException - -- | The outer loop, sets up the ws conn, etc handles reconnecting and such + case msg of + Left (c, reason) -> do + whenJust reason (\r -> error $ "Shard closed with reason: " <> r) + P.embed . atomically $ writeTBMQueue outqueue (Control c) + Right msg' -> do + let decoded = A.eitherDecode msg' + r <- case decoded of + Right a -> + P.embed . atomically $ tryWriteTBMQueue' outqueue (Discord a) + Left e -> do + error $ "Failed to decode: " +| e |+ "" + pure True + when r inner 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 - info $ "starting up shard "+| (shard ^. #shardID) |+" of "+| (shard ^. #shardCount) |+"" + let host' = fromMaybe host $ L.stripPrefix "wss://" host + info $ "starting up shard " +| (shard ^. #shardID) |+ " of " +| (shard ^. #shardCount) |+ "" innerLoopVal <- runWebsocket host' "/?v=8&encoding=json" innerloop @@ -167,18 +207,16 @@ Just ShardFlowShutDown -> do info "Shutting down shard" pure False - Just ShardFlowRestart -> do info "Restaring shard" pure True - -- we restart normally when we loop + -- we restart normally when we loop - Nothing -> do -- 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 innerloop :: ShardC r => Connection -> Sem r ShardFlowControl innerloop ws = do debug "Entering inner loop of shard" @@ -186,51 +224,62 @@ shard <- P.atomicGets (^. #shardS) P.atomicModify' (#wsConn ?~ ws) - seqNum' <- P.atomicGets (^. #seqNum) + seqNum' <- P.atomicGets (^. #seqNum) sessionID' <- P.atomicGets (^. #sessionID) case (seqNum', sessionID') of (Just n, Just s) -> do - debug $ "Resuming shard (sessionID: "+|s|+", seq: "+|n|+")" - sendToWs (Resume ResumeData - { token = shard ^. #token - , sessionID = s - , seq = n - }) + debug $ "Resuming shard (sessionID: " +| s |+ ", seq: " +| n |+ ")" + sendToWs + ( Resume + ResumeData + { token = shard ^. #token + , sessionID = s + , seq = n + } + ) _noActiveSession -> do debug "Identifying shard" - sendToWs (Identify IdentifyData - { token = shard ^. #token - , properties = IdentifyProps - { browser = "Calamity: https://github.com/nitros12/calamity" - , device = "Calamity: https://github.com/nitros12/calamity" - } - , compress = False - , largeThreshold = 250 - , shard = (shard ^. #shardID, - shard ^. #shardCount) - , presence = shard ^. #initialStatus - , intents = shard ^. #intents - }) + sendToWs + ( Identify + IdentifyData + { token = shard ^. #token + , properties = + IdentifyProps + { browser = "Calamity: https://github.com/nitros12/calamity" + , device = "Calamity: https://github.com/nitros12/calamity" + } + , compress = False + , largeThreshold = 250 + , shard = + ( shard ^. #shardID + , shard ^. #shardCount + ) + , presence = shard ^. #initialStatus + , intents = shard ^. #intents + } + ) - result <- P.resourceToIOFinal $ P.bracket (P.embed $ newTBMQueueIO 1) - (P.embed . atomically . closeTBMQueue) - (\q -> do - debug "handling events now" - _controlThread <- P.async . P.embed $ controlStream shard q - _discordThread <- P.async $ discordStream ws q - 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) + result <- + P.resourceToIOFinal $ + P.bracket + (P.embed $ newTBMQueueIO 1) + (P.embed . atomically . closeTBMQueue) + ( \q -> do + debug "handling events now" + _controlThread <- P.async . P.embed $ controlStream shard q + _discordThread <- P.async $ discordStream ws q + 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 + ) debug "Exiting inner loop of shard" P.atomicModify' (#wsConn .~ Nothing) haltHeartBeat pure result - - -- | Handlers for each message, not sure what they'll need to do exactly yet handleMsg :: (ShardC r, P.Member (P.Error ShardFlowControl) r) => ShardMsg -> Sem r () handleMsg (Discord msg) = case msg of EvtDispatch sn data' -> do @@ -240,46 +289,37 @@ case data' of Ready rdata' -> P.atomicModify' (#sessionID ?~ (rdata' ^. #sessionID)) - _NotReady -> pure () shard <- P.atomicGets (^. #shardS) P.embed $ UC.writeChan (shard ^. #evtIn) (Dispatch (shard ^. #shardID) data') - HeartBeatReq -> do debug "Received heartbeat request" sendHeartBeat - Reconnect -> do debug "Being asked to restart by Discord" P.throw ShardFlowRestart - InvalidSession resumable -> do if resumable - then - info "Received resumable invalid session" - else do - info "Received non-resumable invalid session, sleeping for 15 seconds then retrying" - P.atomicModify' (#sessionID .~ Nothing) - P.atomicModify' (#seqNum .~ Nothing) - P.embed $ threadDelay (15 * 1000 * 1000) + then info "Received resumable invalid session" + else do + info "Received non-resumable invalid session, sleeping for 15 seconds then retrying" + P.atomicModify' (#sessionID .~ Nothing) + P.atomicModify' (#seqNum .~ Nothing) + P.embed $ threadDelay (15 * 1000 * 1000) P.throw ShardFlowRestart - Hello interval -> do - info $ "Received hello, beginning to heartbeat at an interval of "+|interval|+"ms" + info $ "Received hello, beginning to heartbeat at an interval of " +| interval |+ "ms" startHeartBeatLoop interval - HeartBeatAck -> do debug "Received heartbeat ack" P.atomicModify' (#hbResponse .~ True) - handleMsg (Control msg) = case msg of SendPresence data' -> do - debug $ "Sending presence: ("+||data'||+")" + debug $ "Sending presence: (" +|| data' ||+ ")" sendToWs $ StatusUpdate data' - - RestartShard -> P.throw ShardFlowRestart - ShutDownShard -> P.throw ShardFlowShutDown + RestartShard -> P.throw ShardFlowRestart + ShutDownShard -> P.throw ShardFlowShutDown startHeartBeatLoop :: ShardC r => Int -> Sem r () startHeartBeatLoop interval = do @@ -294,7 +334,7 @@ #hbThread .= Nothing pure thread case thread of - Just t -> do + Just t -> do debug "Stopping heartbeat thread" P.embed (void $ cancel t) Nothing -> pure () diff --git a/src/Calamity/HTTP/Internal/Ratelimit.hs b/src/Calamity/HTTP/Internal/Ratelimit.hs --- a/src/Calamity/HTTP/Internal/Ratelimit.hs +++ b/src/Calamity/HTTP/Internal/Ratelimit.hs @@ -74,7 +74,7 @@ pure $ if isExhausted r' then case parseRateLimitHeader r' of - Just sleepTime -> ExhaustedBucket resp sleepTime + Just !sleepTime -> ExhaustedBucket resp sleepTime Nothing -> ServerError (statusCode status) else Good resp | status == status429 -> do @@ -98,9 +98,9 @@ parseDiscordTime s = httpDateToUTC <$> parseHTTPDate s computeDiscordTimeDiff :: Double -> UTCTime -> Int -computeDiscordTimeDiff end now = round . (* 1000.0) $ diffUTCTime end' now +computeDiscordTimeDiff end !now = round . (* 1000.0) $! diffUTCTime end' now where - end' = end & toRational & fromRational & posixSecondsToUTCTime + !end' = end & toRational & fromRational & posixSecondsToUTCTime -- | Parse a ratelimit header returning the number of milliseconds until it resets parseRateLimitHeader :: HttpResponse r => r -> Maybe Int diff --git a/src/Calamity/Internal/BoundedStore.hs b/src/Calamity/Internal/BoundedStore.hs --- a/src/Calamity/Internal/BoundedStore.hs +++ b/src/Calamity/Internal/BoundedStore.hs @@ -1,34 +1,31 @@ -- | A thing for storing the last N things with IDs -module Calamity.Internal.BoundedStore - ( BoundedStore - , empty - , addItem - , getItem - , dropItem ) where - -import Calamity.Internal.Utils -import Calamity.Types.Snowflake - -import Control.Lens -import Control.Monad.State.Lazy - -import Data.Default.Class -import Data.Generics.Labels () -import Data.HashMap.Lazy ( HashMap ) -import qualified Data.HashMap.Lazy as H - -import qualified Deque.Lazy as DQ -import Deque.Lazy ( Deque ) +module Calamity.Internal.BoundedStore ( + BoundedStore, + empty, + addItem, + getItem, + dropItem, +) where -import GHC.Generics +import Calamity.Internal.Utils +import Calamity.Types.Snowflake +import Control.Lens +import Control.Monad.State.Lazy +import Data.Default.Class +import Data.Generics.Labels () +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as H +import Deque.Lazy (Deque) +import qualified Deque.Lazy as DQ +import GHC.Generics data BoundedStore a = BoundedStore { itemQueue :: Deque (Snowflake a) - , items :: HashMap (Snowflake a) a - , limit :: Int - , size :: Int + , items :: HashMap (Snowflake a) a + , limit :: Int + , size :: Int } - deriving ( Show, Generic ) + deriving (Show, Generic) instance Foldable BoundedStore where foldr f i = foldr f i . H.elems . items @@ -39,19 +36,19 @@ empty :: Int -> BoundedStore a empty limit = BoundedStore mempty mempty limit 0 -type instance (Index (BoundedStore a)) = Snowflake a +type instance Index (BoundedStore a) = Snowflake a -type instance (IxValue (BoundedStore a)) = a +type instance IxValue (BoundedStore a) = a instance HasID' a => Ixed (BoundedStore a) instance HasID' a => At (BoundedStore a) where - at k f m = f mv <&> \case - Nothing -> maybe m (const (dropItem k m)) mv - Just v -> addItem v m - where - mv = getItem k m - + at k f m = + f mv <&> \case + Nothing -> maybe m (const (dropItem k m)) mv + Just v -> addItem v m + where + mv = getItem k m {-# INLINE at #-} addItem :: HasID' a => a -> BoundedStore a -> BoundedStore a @@ -71,12 +68,10 @@ #size -= 1 #items %= H.insert (getID m) m - {-# INLINE addItem #-} getItem :: Snowflake a -> BoundedStore a -> Maybe a getItem id s = H.lookup id (s ^. #items) - {-# INLINE getItem #-} dropItem :: Snowflake a -> BoundedStore a -> BoundedStore a @@ -86,5 +81,4 @@ #itemQueue %= DQ.filter (/= id) #items %= H.delete id - {-# INLINE dropItem #-} diff --git a/src/Calamity/Internal/SnowflakeMap.hs b/src/Calamity/Internal/SnowflakeMap.hs --- a/src/Calamity/Internal/SnowflakeMap.hs +++ b/src/Calamity/Internal/SnowflakeMap.hs @@ -1,36 +1,31 @@ --- | Module for custom instance of Data.HashMap.Lazy that decodes from any list of objects that have an id field +-- | Module for custom instance of Data.HashMap.Strict that decodes from any list of objects that have an id field module Calamity.Internal.SnowflakeMap where -import Calamity.Internal.Utils () -import Calamity.Types.Snowflake - -import Control.DeepSeq -import Control.Lens.At -import Control.Lens.Iso -import Control.Lens.Wrapped - -import Data.Aeson ( FromJSON(..), ToJSON(..), withArray ) -import Data.Data -import qualified Data.Foldable as F -import Data.HashMap.Lazy ( HashMap ) -import qualified Data.HashMap.Lazy as LH -import Data.Hashable - -import GHC.Exts ( IsList ) -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG - -import Unsafe.Coerce +import Calamity.Internal.Utils () +import Calamity.Types.Snowflake +import Control.DeepSeq +import Control.Lens.At +import Control.Lens.Iso +import Control.Lens.Wrapped +import Data.Aeson (FromJSON (..), ToJSON (..), withArray) +import Data.Data +import qualified Data.Foldable as F +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as SH +import Data.Hashable +import GHC.Exts (IsList) +import GHC.Generics +import TextShow +import qualified TextShow.Generic as TSG +import Unsafe.Coerce newtype SnowflakeMap a = SnowflakeMap { unSnowflakeMap :: HashMap (Snowflake a) a } - deriving ( Generic, Eq, Data, Ord, Show ) - deriving ( TextShow ) via TSG.FromGeneric (SnowflakeMap a) - deriving newtype ( IsList, Semigroup, Monoid ) - deriving newtype ( NFData, Hashable ) + deriving (Generic, Eq, Data, Ord, Show) + deriving (TextShow) via TSG.FromGeneric (SnowflakeMap a) + deriving newtype (IsList, Semigroup, Monoid) + deriving newtype (NFData, Hashable) -- instance At (SnowflakeMap a) where -- at k f m = at (unSnowflakeMap k) f m @@ -53,9 +48,9 @@ _Wrapped' = iso unSnowflakeMap SnowflakeMap -type instance (Index (SnowflakeMap a)) = Snowflake a +type instance Index (SnowflakeMap a) = Snowflake a -type instance (IxValue (SnowflakeMap a)) = a +type instance IxValue (SnowflakeMap a) = a instance SnowflakeMap a ~ t => Rewrapped (SnowflakeMap b) a @@ -66,171 +61,171 @@ at i = _Wrapped . at i over :: (HashMap (Snowflake a) a -> HashMap (Snowflake b) b) -> SnowflakeMap a -> SnowflakeMap b -over f = SnowflakeMap . f . unSnowflakeMap -{-# INLINABLE over #-} +over f = SnowflakeMap . f . unSnowflakeMap +{-# INLINEABLE over #-} -- SAFETY: 'Snowflake' always uses the underlying hash function (Word64) coerceSnowflakeMap :: HashMap (Snowflake a) v -> HashMap (Snowflake b) v coerceSnowflakeMap = unsafeCoerce -{-# INLINABLE coerceSnowflakeMap #-} +{-# INLINEABLE coerceSnowflakeMap #-} empty :: SnowflakeMap a -empty = SnowflakeMap LH.empty -{-# INLINABLE empty #-} +empty = SnowflakeMap SH.empty +{-# INLINEABLE empty #-} singleton :: HasID' a => a -> SnowflakeMap a -singleton v = SnowflakeMap $ LH.singleton (getID v) v -{-# INLINABLE singleton #-} +singleton v = SnowflakeMap $ SH.singleton (getID v) v +{-# INLINEABLE singleton #-} null :: SnowflakeMap a -> Bool -null = LH.null . unSnowflakeMap -{-# INLINABLE null #-} +null = SH.null . unSnowflakeMap +{-# INLINEABLE null #-} size :: SnowflakeMap a -> Int -size = LH.size . unSnowflakeMap -{-# INLINABLE size #-} +size = SH.size . unSnowflakeMap +{-# INLINEABLE size #-} member :: Snowflake a -> SnowflakeMap a -> Bool -member k = LH.member k . unSnowflakeMap -{-# INLINABLE member #-} +member k = SH.member k . unSnowflakeMap +{-# INLINEABLE member #-} lookup :: Snowflake a -> SnowflakeMap a -> Maybe a -lookup k = LH.lookup k . unSnowflakeMap -{-# INLINABLE lookup #-} +lookup k = SH.lookup k . unSnowflakeMap +{-# INLINEABLE lookup #-} lookupDefault :: a -> Snowflake a -> SnowflakeMap a -> a -lookupDefault d k = LH.lookupDefault d k . unSnowflakeMap -{-# INLINABLE lookupDefault #-} +lookupDefault d k = SH.lookupDefault d k . unSnowflakeMap +{-# INLINEABLE lookupDefault #-} (!) :: SnowflakeMap a -> Snowflake a -> a -(!) m k = unSnowflakeMap m LH.! k -{-# INLINABLE (!) #-} +(!) m k = unSnowflakeMap m SH.! k +{-# INLINEABLE (!) #-} infixl 9 ! insert :: HasID' a => a -> SnowflakeMap a -> SnowflakeMap a -insert v = over $ LH.insert (getID v) v -{-# INLINABLE insert #-} +insert v = over $ SH.insert (getID v) v +{-# INLINEABLE insert #-} insertWith :: HasID' a => (a -> a -> a) -> a -> SnowflakeMap a -> SnowflakeMap a -insertWith f v = over $ LH.insertWith f (getID v) v -{-# INLINABLE insertWith #-} +insertWith f v = over $ SH.insertWith f (getID v) v +{-# INLINEABLE insertWith #-} delete :: Snowflake a -> SnowflakeMap a -> SnowflakeMap a -delete k = over $ LH.delete k -{-# INLINABLE delete #-} +delete k = over $ SH.delete k +{-# INLINEABLE delete #-} adjust :: (a -> a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a -adjust f k = over $ LH.adjust f k -{-# INLINABLE adjust #-} +adjust f k = over $ SH.adjust f k +{-# INLINEABLE adjust #-} update :: (a -> Maybe a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a -update f k = over $ LH.update f k -{-# INLINABLE update #-} +update f k = over $ SH.update f k +{-# INLINEABLE update #-} alter :: (Maybe a -> Maybe a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a -alter f k = over $ LH.alter f k -{-# INLINABLE alter #-} +alter f k = over $ SH.alter f k +{-# INLINEABLE alter #-} union :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a -union m m' = SnowflakeMap $ LH.union (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE union #-} +union m m' = SnowflakeMap $ SH.union (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE union #-} unionWith :: (a -> a -> a) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a -unionWith f m m' = SnowflakeMap $ LH.unionWith f (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE unionWith #-} +unionWith f m m' = SnowflakeMap $ SH.unionWith f (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE unionWith #-} unionWithKey :: (Snowflake a -> a -> a -> a) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a -unionWithKey f m m' = SnowflakeMap $ LH.unionWithKey f (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE unionWithKey #-} +unionWithKey f m m' = SnowflakeMap $ SH.unionWithKey f (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE unionWithKey #-} unions :: [SnowflakeMap a] -> SnowflakeMap a -unions = SnowflakeMap . LH.unions . Prelude.map unSnowflakeMap -{-# INLINABLE unions #-} +unions = SnowflakeMap . SH.unions . Prelude.map unSnowflakeMap +{-# INLINEABLE unions #-} map :: (a1 -> a2) -> SnowflakeMap a1 -> SnowflakeMap a2 -map f = over $ coerceSnowflakeMap . LH.map f -{-# INLINABLE map #-} +map f = over $ coerceSnowflakeMap . SH.map f +{-# INLINEABLE map #-} mapWithKey :: (Snowflake a1 -> a1 -> a2) -> SnowflakeMap a1 -> SnowflakeMap a2 -mapWithKey f = over $ coerceSnowflakeMap . LH.mapWithKey f -{-# INLINABLE mapWithKey #-} +mapWithKey f = over $ coerceSnowflakeMap . SH.mapWithKey f +{-# INLINEABLE mapWithKey #-} traverseWithKey :: Applicative f => (Snowflake a1 -> a1 -> f a2) -> SnowflakeMap a1 -> f (SnowflakeMap a2) -traverseWithKey f = fmap (SnowflakeMap . coerceSnowflakeMap) . LH.traverseWithKey f . unSnowflakeMap -{-# INLINABLE traverseWithKey #-} +traverseWithKey f = fmap (SnowflakeMap . coerceSnowflakeMap) . SH.traverseWithKey f . unSnowflakeMap +{-# INLINEABLE traverseWithKey #-} difference :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a -difference m m' = SnowflakeMap $ LH.difference (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE difference #-} +difference m m' = SnowflakeMap $ SH.difference (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE difference #-} differenceWith :: (a -> a -> Maybe a) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a -differenceWith f m m' = SnowflakeMap $ LH.differenceWith f (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE differenceWith #-} +differenceWith f m m' = SnowflakeMap $ SH.differenceWith f (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE differenceWith #-} intersection :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a -intersection m m' = SnowflakeMap $ LH.intersection (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE intersection #-} +intersection m m' = SnowflakeMap $ SH.intersection (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE intersection #-} intersectionWith :: (a -> a -> b) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap b -intersectionWith f m m' = SnowflakeMap . coerceSnowflakeMap $ LH.intersectionWith f (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE intersectionWith #-} +intersectionWith f m m' = SnowflakeMap . coerceSnowflakeMap $ SH.intersectionWith f (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE intersectionWith #-} intersectionWithKey :: (Snowflake a -> a -> a -> b) -> SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap b -intersectionWithKey f m m' = SnowflakeMap . coerceSnowflakeMap $ LH.intersectionWithKey f (unSnowflakeMap m) (unSnowflakeMap m') -{-# INLINABLE intersectionWithKey #-} +intersectionWithKey f m m' = SnowflakeMap . coerceSnowflakeMap $ SH.intersectionWithKey f (unSnowflakeMap m) (unSnowflakeMap m') +{-# INLINEABLE intersectionWithKey #-} foldl' :: (a -> b -> a) -> a -> SnowflakeMap b -> a -foldl' f s m = LH.foldl' f s $ unSnowflakeMap m -{-# INLINABLE foldl' #-} +foldl' f s m = SH.foldl' f s $ unSnowflakeMap m +{-# INLINEABLE foldl' #-} foldlWithKey' :: (a -> Snowflake b -> b -> a) -> a -> SnowflakeMap b -> a -foldlWithKey' f s m = LH.foldlWithKey' f s $ unSnowflakeMap m -{-# INLINABLE foldlWithKey' #-} +foldlWithKey' f s m = SH.foldlWithKey' f s $ unSnowflakeMap m +{-# INLINEABLE foldlWithKey' #-} foldr :: (b -> a -> a) -> a -> SnowflakeMap b -> a -foldr f s m = LH.foldr f s $ unSnowflakeMap m -{-# INLINABLE foldr #-} +foldr f s m = SH.foldr f s $ unSnowflakeMap m +{-# INLINEABLE foldr #-} foldrWithKey :: (Snowflake b -> b -> a -> a) -> a -> SnowflakeMap b -> a -foldrWithKey f s m = LH.foldrWithKey f s $ unSnowflakeMap m -{-# INLINABLE foldrWithKey #-} +foldrWithKey f s m = SH.foldrWithKey f s $ unSnowflakeMap m +{-# INLINEABLE foldrWithKey #-} filter :: (a -> Bool) -> SnowflakeMap a -> SnowflakeMap a -filter f = over $ LH.filter f -{-# INLINABLE filter #-} +filter f = over $ SH.filter f +{-# INLINEABLE filter #-} filterWithKey :: (Snowflake a -> a -> Bool) -> SnowflakeMap a -> SnowflakeMap a -filterWithKey f = over $ LH.filterWithKey f -{-# INLINABLE filterWithKey #-} +filterWithKey f = over $ SH.filterWithKey f +{-# INLINEABLE filterWithKey #-} mapMaybe :: (a -> Maybe b) -> SnowflakeMap a -> SnowflakeMap b -mapMaybe f = over $ coerceSnowflakeMap . LH.mapMaybe f -{-# INLINABLE mapMaybe #-} +mapMaybe f = over $ coerceSnowflakeMap . SH.mapMaybe f +{-# INLINEABLE mapMaybe #-} mapMaybeWithKey :: (Snowflake a -> a -> Maybe b) -> SnowflakeMap a -> SnowflakeMap b -mapMaybeWithKey f = over $ coerceSnowflakeMap . LH.mapMaybeWithKey f -{-# INLINABLE mapMaybeWithKey #-} +mapMaybeWithKey f = over $ coerceSnowflakeMap . SH.mapMaybeWithKey f +{-# INLINEABLE mapMaybeWithKey #-} keys :: SnowflakeMap a -> [Snowflake a] -keys = LH.keys . unSnowflakeMap -{-# INLINABLE keys #-} +keys = SH.keys . unSnowflakeMap +{-# INLINEABLE keys #-} elems :: SnowflakeMap a -> [a] -elems = LH.elems . unSnowflakeMap -{-# INLINABLE elems #-} +elems = SH.elems . unSnowflakeMap +{-# INLINEABLE elems #-} toList :: SnowflakeMap a -> [(Snowflake a, a)] -toList = LH.toList . unSnowflakeMap -{-# INLINABLE toList #-} +toList = SH.toList . unSnowflakeMap +{-# INLINEABLE toList #-} fromList :: HasID' a => [a] -> SnowflakeMap a -fromList = SnowflakeMap . LH.fromList . Prelude.map (\v -> (getID v, v)) -{-# INLINABLE fromList #-} +fromList = SnowflakeMap . SH.fromList . Prelude.map (\v -> (getID v, v)) +{-# INLINEABLE fromList #-} fromListWith :: HasID' a => (a -> a -> a) -> [a] -> SnowflakeMap a -fromListWith f = SnowflakeMap . LH.fromListWith f . Prelude.map (\v -> (getID v, v)) -{-# INLINABLE fromListWith #-} +fromListWith f = SnowflakeMap . SH.fromListWith f . Prelude.map (\v -> (getID v, v)) +{-# INLINEABLE fromListWith #-} instance (FromJSON a, HasID' a) => FromJSON (SnowflakeMap a) where parseJSON = withArray "SnowflakeMap" $ \l -> do diff --git a/src/Calamity/Types/Model/Channel.hs b/src/Calamity/Types/Model/Channel.hs --- a/src/Calamity/Types/Model/Channel.hs +++ b/src/Calamity/Types/Model/Channel.hs @@ -59,7 +59,7 @@ data instance Partial Channel = PartialChannel { id :: Snowflake Channel , name :: Text - , type_ :: ChannelType + , type_ :: !ChannelType , parentID :: Maybe (Snowflake Category) } deriving ( Show, Eq, Generic ) diff --git a/src/Calamity/Types/Model/Channel/Attachment.hs b/src/Calamity/Types/Model/Channel/Attachment.hs --- a/src/Calamity/Types/Model/Channel/Attachment.hs +++ b/src/Calamity/Types/Model/Channel/Attachment.hs @@ -4,29 +4,26 @@ import Calamity.Internal.AesonThings () import Calamity.Types.Snowflake - import Data.Aeson import Data.Text.Lazy ( Text ) import Data.Word - import GHC.Generics - import TextShow import qualified TextShow.Generic as TSG fuseTup2 :: Monad f => (f a, f b) -> f (a, b) fuseTup2 (a, b) = do - a' <- a - b' <- b + !a' <- a + !b' <- b pure (a', b') data Attachment = Attachment { id :: Snowflake Attachment - , filename :: Text + , filename :: !Text , size :: Word64 - , url :: Text - , proxyUrl :: Text - , dimensions :: Maybe (Word64, Word64) + , url :: !Text + , proxyUrl :: !Text + , dimensions :: !(Maybe (Word64, Word64)) } deriving ( Eq, Show, Generic ) deriving ( TextShow ) via TSG.FromGeneric Attachment diff --git a/src/Calamity/Types/Model/Channel/ChannelType.hs b/src/Calamity/Types/Model/Channel/ChannelType.hs --- a/src/Calamity/Types/Model/Channel/ChannelType.hs +++ b/src/Calamity/Types/Model/Channel/ChannelType.hs @@ -25,7 +25,7 @@ instance FromJSON ChannelType where parseJSON = withScientific "ChannelType" $ \n -> case toBoundedInteger @Int n of - Just v -> case v of + Just !v -> case v of 0 -> pure GuildTextType 1 -> pure DMType 2 -> pure GuildVoiceType diff --git a/src/Calamity/Types/Model/Channel/DM.hs b/src/Calamity/Types/Model/Channel/DM.hs --- a/src/Calamity/Types/Model/Channel/DM.hs +++ b/src/Calamity/Types/Model/Channel/DM.hs @@ -1,32 +1,35 @@ -- | A DM channel with a single person -module Calamity.Types.Model.Channel.DM - ( DMChannel(..) ) where +module Calamity.Types.Model.Channel.DM (DMChannel (..)) where -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () +import Calamity.Internal.AesonThings +import Calamity.Internal.Utils () import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Channel.Message -import Calamity.Types.Model.User -import Calamity.Types.Snowflake +import Calamity.Types.Model.User +import Calamity.Types.Snowflake -import Data.Aeson -import Data.Time -import Data.Vector.Unboxing ( Vector ) +import Data.Aeson +import Data.Time +import Data.Vector.Unboxing (Vector) -import GHC.Generics +import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Control.DeepSeq (NFData) +import TextShow +import qualified TextShow.Generic as TSG data DMChannel = DMChannel - { id :: Snowflake DMChannel - , lastMessageID :: Maybe (Snowflake Message) + { id :: Snowflake DMChannel + , lastMessageID :: Maybe (Snowflake Message) , lastPinTimestamp :: Maybe UTCTime - , recipients :: Vector (Snowflake User) + , recipients :: Vector (Snowflake User) } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric DMChannel - deriving ( FromJSON ) via WithSpecialCases - '["recipients" `ExtractArrayField` "id"] DMChannel - deriving ( HasID DMChannel ) via HasIDField "id" DMChannel - deriving ( HasID Channel ) via HasIDFieldCoerce' "id" DMChannel + deriving (Show, Eq, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric DMChannel + deriving + (FromJSON) + via WithSpecialCases + '["recipients" `ExtractArrayField` "id"] + DMChannel + deriving (HasID DMChannel) via HasIDField "id" DMChannel + deriving (HasID Channel) via HasIDFieldCoerce' "id" DMChannel diff --git a/src/Calamity/Types/Model/Channel/Guild.hs b/src/Calamity/Types/Model/Channel/Guild.hs --- a/src/Calamity/Types/Model/Channel/Guild.hs +++ b/src/Calamity/Types/Model/Channel/Guild.hs @@ -1,47 +1,49 @@ -- | The generic guild channel type -module Calamity.Types.Model.Channel.Guild - ( GuildChannel(..) - , module Calamity.Types.Model.Channel.Guild.Category - , module Calamity.Types.Model.Channel.Guild.Text - , module Calamity.Types.Model.Channel.Guild.Voice ) where +module Calamity.Types.Model.Channel.Guild ( + GuildChannel (..), + module Calamity.Types.Model.Channel.Guild.Category, + module Calamity.Types.Model.Channel.Guild.Text, + module Calamity.Types.Model.Channel.Guild.Voice, +) where -import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) +import Calamity.Internal.SnowflakeMap (SnowflakeMap) import {-# SOURCE #-} Calamity.Types.Model.Channel -import Calamity.Types.Model.Channel.ChannelType -import Calamity.Types.Model.Channel.Guild.Category -import Calamity.Types.Model.Channel.Guild.Text -import Calamity.Types.Model.Channel.Guild.Voice +import Calamity.Types.Model.Channel.ChannelType +import Calamity.Types.Model.Channel.Guild.Category +import Calamity.Types.Model.Channel.Guild.Text +import Calamity.Types.Model.Channel.Guild.Voice import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Overwrite -import Calamity.Types.Snowflake +import Calamity.Types.Model.Guild.Overwrite +import Calamity.Types.Snowflake -import Control.Lens +import Control.Lens -import Data.Aeson -import Data.Generics.Product.Fields -import Data.Text.Lazy ( Text ) +import Data.Aeson +import Data.Generics.Product.Fields +import Data.Text.Lazy (Text) -import GHC.Generics +import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Control.DeepSeq (NFData) +import TextShow +import qualified TextShow.Generic as TSG data GuildChannel = GuildTextChannel TextChannel | GuildVoiceChannel VoiceChannel | GuildCategory Category - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric GuildChannel + deriving (Show, Eq, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric GuildChannel instance FromJSON GuildChannel where parseJSON = withObject "GuildChannel" $ \v -> do type_ <- v .: "type" case type_ of - GuildTextType -> GuildTextChannel <$> parseJSON (Object v) - GuildVoiceType -> GuildVoiceChannel <$> parseJSON (Object v) + GuildTextType -> GuildTextChannel <$> parseJSON (Object v) + GuildVoiceType -> GuildVoiceChannel <$> parseJSON (Object v) GuildCategoryType -> GuildCategory <$> parseJSON (Object v) - typ -> fail $ "Not a valid guild channel: " <> show typ + typ -> fail $ "Not a valid guild channel: " <> show typ instance HasID GuildChannel GuildChannel where getID (GuildTextChannel a) = coerceSnowflake $ a ^. field' @"id" @@ -56,35 +58,35 @@ getID (GuildVoiceChannel a) = coerceSnowflake $ a ^. field' @"guildID" getID (GuildCategory a) = coerceSnowflake $ a ^. field' @"guildID" -instance {-# OVERLAPS #-}HasField' "name" GuildChannel Text where +instance {-# OVERLAPS #-} HasField' "name" GuildChannel Text where field' = lens get set - where - get (GuildTextChannel (TextChannel { name })) = name - get (GuildVoiceChannel (VoiceChannel { name })) = name - get (GuildCategory (Category { name })) = name + where + get (GuildTextChannel (TextChannel{name})) = name + get (GuildVoiceChannel (VoiceChannel{name})) = name + get (GuildCategory (Category{name})) = name - set (GuildTextChannel t) v = GuildTextChannel (t { name = v }) - set (GuildVoiceChannel t) v = GuildVoiceChannel (t { name = v }) - set (GuildCategory t) v = GuildCategory (t { name = v }) + set (GuildTextChannel t) v = GuildTextChannel (t{name = v}) + set (GuildVoiceChannel t) v = GuildVoiceChannel (t{name = v}) + set (GuildCategory t) v = GuildCategory (t{name = v}) -instance {-# OVERLAPS #-}HasField' "permissionOverwrites" GuildChannel (SnowflakeMap Overwrite) where +instance {-# OVERLAPS #-} HasField' "permissionOverwrites" GuildChannel (SnowflakeMap Overwrite) where field' = lens get set - where - get (GuildTextChannel (TextChannel { permissionOverwrites })) = permissionOverwrites - get (GuildVoiceChannel (VoiceChannel { permissionOverwrites })) = permissionOverwrites - get (GuildCategory (Category { permissionOverwrites })) = permissionOverwrites + where + get (GuildTextChannel (TextChannel{permissionOverwrites})) = permissionOverwrites + get (GuildVoiceChannel (VoiceChannel{permissionOverwrites})) = permissionOverwrites + get (GuildCategory (Category{permissionOverwrites})) = permissionOverwrites - set (GuildTextChannel t) v = GuildTextChannel (t { permissionOverwrites = v }) - set (GuildVoiceChannel t) v = GuildVoiceChannel (t { permissionOverwrites = v }) - set (GuildCategory t) v = GuildCategory (t { permissionOverwrites = v }) + set (GuildTextChannel t) v = GuildTextChannel (t{permissionOverwrites = v}) + set (GuildVoiceChannel t) v = GuildVoiceChannel (t{permissionOverwrites = v}) + set (GuildCategory t) v = GuildCategory (t{permissionOverwrites = v}) -instance {-# OVERLAPS #-}HasField' "position" GuildChannel Int where +instance {-# OVERLAPS #-} HasField' "position" GuildChannel Int where field' = lens get set - where - get (GuildTextChannel (TextChannel { position })) = position - get (GuildVoiceChannel (VoiceChannel { position })) = position - get (GuildCategory (Category { position })) = position + where + get (GuildTextChannel (TextChannel{position})) = position + get (GuildVoiceChannel (VoiceChannel{position})) = position + get (GuildCategory (Category{position})) = position - set (GuildTextChannel t) v = GuildTextChannel (t { position = v }) - set (GuildVoiceChannel t) v = GuildVoiceChannel (t { position = v }) - set (GuildCategory t) v = GuildCategory (t { position = v }) + set (GuildTextChannel t) v = GuildTextChannel (t{position = v}) + set (GuildVoiceChannel t) v = GuildVoiceChannel (t{position = v}) + set (GuildCategory t) v = GuildCategory (t{position = v}) diff --git a/src/Calamity/Types/Model/Channel/Guild/Category.hs b/src/Calamity/Types/Model/Channel/Guild/Category.hs --- a/src/Calamity/Types/Model/Channel/Guild/Category.hs +++ b/src/Calamity/Types/Model/Channel/Guild/Category.hs @@ -1,33 +1,30 @@ -module Calamity.Types.Model.Channel.Guild.Category - ( Category(..) ) where +module Calamity.Types.Model.Channel.Guild.Category (Category (..)) where -import Calamity.Internal.AesonThings -import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) -import Calamity.Internal.Utils () +import Calamity.Internal.AesonThings +import Calamity.Internal.SnowflakeMap (SnowflakeMap) +import Calamity.Internal.Utils () import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Overwrite -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG +import Calamity.Types.Model.Guild.Overwrite +import Calamity.Types.Snowflake +import Control.DeepSeq (NFData) +import Data.Aeson +import Data.Text.Lazy (Text) +import GHC.Generics +import TextShow +import qualified TextShow.Generic as TSG data Category = Category - { id :: Snowflake Category + { id :: Snowflake Category , permissionOverwrites :: SnowflakeMap Overwrite - , name :: Text - , nsfw :: Bool - , position :: Int - , guildID :: Snowflake Guild + , name :: Text + , nsfw :: Bool + , position :: Int + , guildID :: Snowflake Guild } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Category - deriving ( ToJSON ) via CalamityJSON Category - deriving ( FromJSON ) via WithSpecialCases '[IfNoneThen "nsfw" DefaultToFalse] Category - deriving ( HasID Category ) via HasIDField "id" Category - deriving ( HasID Channel ) via HasIDFieldCoerce' "id" Category + deriving (Show, Eq, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric Category + deriving (ToJSON) via CalamityJSON Category + deriving (FromJSON) via WithSpecialCases '[IfNoneThen "nsfw" DefaultToFalse] Category + deriving (HasID Category) via HasIDField "id" Category + deriving (HasID Channel) via HasIDFieldCoerce' "id" Category diff --git a/src/Calamity/Types/Model/Channel/Guild/Text.hs b/src/Calamity/Types/Model/Channel/Guild/Text.hs --- a/src/Calamity/Types/Model/Channel/Guild/Text.hs +++ b/src/Calamity/Types/Model/Channel/Guild/Text.hs @@ -1,44 +1,44 @@ -- | Text channels -module Calamity.Types.Model.Channel.Guild.Text - ( TextChannel(..) ) where +module Calamity.Types.Model.Channel.Guild.Text (TextChannel (..)) where -import Calamity.Internal.AesonThings -import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) -import Calamity.Internal.Utils () +import Calamity.Internal.AesonThings +import Calamity.Internal.SnowflakeMap (SnowflakeMap) +import Calamity.Internal.Utils () import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Channel.Guild.Category import {-# SOURCE #-} Calamity.Types.Model.Channel.Message import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Overwrite -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) -import Data.Time - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG +import Calamity.Types.Model.Guild.Overwrite +import Calamity.Types.Snowflake +import Control.DeepSeq (NFData) +import Data.Aeson +import Data.Text.Lazy (Text) +import Data.Time +import GHC.Generics +import TextShow +import qualified TextShow.Generic as TSG data TextChannel = TextChannel - { id :: Snowflake TextChannel - , guildID :: Snowflake Guild - , position :: Int + { id :: Snowflake TextChannel + , guildID :: Snowflake Guild + , position :: Int , permissionOverwrites :: SnowflakeMap Overwrite - , name :: Text - , topic :: Maybe Text - , nsfw :: Bool - , lastMessageID :: Maybe (Snowflake Message) - , lastPinTimestamp :: Maybe UTCTime - , rateLimitPerUser :: Maybe Int - , parentID :: Maybe (Snowflake Category) + , name :: Text + , topic :: Maybe Text + , nsfw :: Bool + , lastMessageID :: Maybe (Snowflake Message) + , lastPinTimestamp :: Maybe UTCTime + , rateLimitPerUser :: Maybe Int + , parentID :: Maybe (Snowflake Category) } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric TextChannel - deriving ( ToJSON ) via CalamityJSON TextChannel - deriving ( FromJSON ) via WithSpecialCases '[IfNoneThen "nsfw" DefaultToFalse] - TextChannel - deriving ( HasID TextChannel ) via HasIDField "id" TextChannel - deriving ( HasID Channel ) via HasIDFieldCoerce' "id" TextChannel - deriving ( HasID Guild ) via HasIDField "guildID" TextChannel + deriving (Show, Eq, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric TextChannel + deriving (ToJSON) via CalamityJSON TextChannel + deriving + (FromJSON) + via WithSpecialCases + '[IfNoneThen "nsfw" DefaultToFalse] + TextChannel + deriving (HasID TextChannel) via HasIDField "id" TextChannel + deriving (HasID Channel) via HasIDFieldCoerce' "id" TextChannel + deriving (HasID Guild) via HasIDField "guildID" TextChannel diff --git a/src/Calamity/Types/Model/Channel/Guild/Voice.hs b/src/Calamity/Types/Model/Channel/Guild/Voice.hs --- a/src/Calamity/Types/Model/Channel/Guild/Voice.hs +++ b/src/Calamity/Types/Model/Channel/Guild/Voice.hs @@ -1,37 +1,34 @@ -- | Voice channels -module Calamity.Types.Model.Channel.Guild.Voice - ( VoiceChannel(..) ) where +module Calamity.Types.Model.Channel.Guild.Voice (VoiceChannel (..)) where -import Calamity.Internal.AesonThings -import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) -import Calamity.Internal.Utils () +import Calamity.Internal.AesonThings +import Calamity.Internal.SnowflakeMap (SnowflakeMap) +import Calamity.Internal.Utils () import {-# SOURCE #-} Calamity.Types.Model.Channel import {-# SOURCE #-} Calamity.Types.Model.Channel.Guild.Category import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Overwrite -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG +import Calamity.Types.Model.Guild.Overwrite +import Calamity.Types.Snowflake +import Control.DeepSeq (NFData) +import Data.Aeson +import Data.Text.Lazy (Text) +import GHC.Generics +import TextShow +import qualified TextShow.Generic as TSG data VoiceChannel = VoiceChannel - { id :: Snowflake VoiceChannel - , guildID :: Snowflake Guild - , position :: Int + { id :: Snowflake VoiceChannel + , guildID :: Snowflake Guild + , position :: Int , permissionOverwrites :: SnowflakeMap Overwrite - , name :: Text - , bitrate :: Int - , userLimit :: Int - , parentID :: Maybe (Snowflake Category) + , name :: Text + , bitrate :: Int + , userLimit :: Int + , parentID :: Maybe (Snowflake Category) } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric VoiceChannel - deriving ( ToJSON, FromJSON ) via CalamityJSON VoiceChannel - deriving ( HasID VoiceChannel ) via HasIDField "id" VoiceChannel - deriving ( HasID Channel ) via HasIDFieldCoerce' "id" VoiceChannel - deriving ( HasID Guild ) via HasIDField "guildID" VoiceChannel + deriving (Show, Eq, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric VoiceChannel + deriving (ToJSON, FromJSON) via CalamityJSON VoiceChannel + deriving (HasID VoiceChannel) via HasIDField "id" VoiceChannel + deriving (HasID Channel) via HasIDFieldCoerce' "id" VoiceChannel + deriving (HasID Guild) via HasIDField "guildID" VoiceChannel diff --git a/src/Calamity/Types/Model/Channel/Message.hs b/src/Calamity/Types/Model/Channel/Message.hs --- a/src/Calamity/Types/Model/Channel/Message.hs +++ b/src/Calamity/Types/Model/Channel/Message.hs @@ -36,13 +36,13 @@ , mentions :: UV.Vector (Snowflake User) , mentionRoles :: UV.Vector (Snowflake Role) , mentionChannels :: Maybe (UV.Vector (Snowflake Channel)) - , attachments :: [Attachment] - , embeds :: [Embed] - , reactions :: [Reaction] + , attachments :: ![Attachment] + , embeds :: ![Embed] + , reactions :: ![Reaction] , nonce :: Maybe (Snowflake Message) , pinned :: Bool , webhookID :: Maybe (Snowflake ()) - , type_ :: MessageType + , type_ :: !MessageType } deriving ( Eq, Show, Generic ) deriving ( TextShow ) via TSG.FromGeneric Message @@ -77,7 +77,7 @@ instance FromJSON MessageType where parseJSON = withScientific "MessageType" $ \n -> case toBoundedInteger @Int n of - Just v -> case v of + Just !v -> case v of 0 -> pure Default 1 -> pure RecipientAdd 2 -> pure RecipientRemove diff --git a/src/Calamity/Types/Model/Channel/UpdatedMessage.hs b/src/Calamity/Types/Model/Channel/UpdatedMessage.hs --- a/src/Calamity/Types/Model/Channel/UpdatedMessage.hs +++ b/src/Calamity/Types/Model/Channel/UpdatedMessage.hs @@ -1,45 +1,46 @@ -- | Updated messages -module Calamity.Types.Model.Channel.UpdatedMessage - ( UpdatedMessage(..) - ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild.Role -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - -import Data.Aeson -import Data.Text.Lazy ( Text ) -import Data.Time -import qualified Data.Vector.Unboxing as UV - -import GHC.Generics +module Calamity.Types.Model.Channel.UpdatedMessage ( + UpdatedMessage (..), +) where -import TextShow -import qualified TextShow.Generic as TSG +import Calamity.Internal.AesonThings +import Calamity.Internal.Utils () +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild.Role +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Data.Aeson +import Data.Text.Lazy (Text) +import Data.Time +import qualified Data.Vector.Unboxing as UV +import GHC.Generics +import TextShow +import qualified TextShow.Generic as TSG data UpdatedMessage = UpdatedMessage - { id :: Snowflake Message - , channelID :: Snowflake Channel - , content :: Maybe Text - , editedTimestamp :: Maybe UTCTime - , tts :: Maybe Bool - , mentionEveryone :: Maybe Bool - , mentions :: Maybe (UV.Vector (Snowflake User)) - , mentionRoles :: Maybe (UV.Vector (Snowflake Role)) - , mentionChannels :: Maybe (UV.Vector (Snowflake Channel)) - , attachments :: Maybe [Attachment] - , embeds :: Maybe [Embed] - , reactions :: Maybe [Reaction] - , pinned :: Maybe Bool - } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric UpdatedMessage - deriving ( FromJSON ) via WithSpecialCases - '["author" `ExtractFieldFrom` "id", "mentions" `ExtractArrayField` "id", - "mention_channels" `ExtractArrayField` "id"] - UpdatedMessage - deriving ( HasID Message ) via HasIDField "id" UpdatedMessage - deriving ( HasID Channel ) via HasIDField "channelID" UpdatedMessage + { id :: Snowflake Message + , channelID :: Snowflake Channel + , content :: Maybe Text + , editedTimestamp :: Maybe UTCTime + , tts :: Maybe Bool + , mentionEveryone :: Maybe Bool + , mentions :: Maybe (UV.Vector (Snowflake User)) + , mentionRoles :: Maybe (UV.Vector (Snowflake Role)) + , mentionChannels :: Maybe (UV.Vector (Snowflake Channel)) + , attachments :: !(Maybe [Attachment]) + , embeds :: Maybe [Embed] + , reactions :: Maybe [Reaction] + , pinned :: Maybe Bool + } + deriving (Eq, Show, Generic) + deriving (TextShow) via TSG.FromGeneric UpdatedMessage + deriving + (FromJSON) + via WithSpecialCases + '[ "author" `ExtractFieldFrom` "id" + , "mentions" `ExtractArrayField` "id" + , "mention_channels" `ExtractArrayField` "id" + ] + UpdatedMessage + deriving (HasID Message) via HasIDField "id" UpdatedMessage + deriving (HasID Channel) via HasIDField "channelID" UpdatedMessage diff --git a/src/Calamity/Types/Model/Guild/AuditLog.hs b/src/Calamity/Types/Model/Guild/AuditLog.hs --- a/src/Calamity/Types/Model/Guild/AuditLog.hs +++ b/src/Calamity/Types/Model/Guild/AuditLog.hs @@ -35,7 +35,7 @@ , changes :: [AuditLogChange] , userID :: Snowflake User , id :: Snowflake AuditLogEntry - , actionType :: AuditLogAction + , actionType :: !AuditLogAction , options :: Maybe AuditLogEntryInfo , reason :: Maybe Text } @@ -185,7 +185,7 @@ instance FromJSON AuditLogAction where parseJSON = withScientific "AuditLogAction" $ \n -> case toBoundedInteger @Int n of - Just v -> case v of -- no safe toEnum :S + Just !v -> case v of -- no safe toEnum :S 1 -> pure GUILD_UPDATE 10 -> pure CHANNEL_CREATE 11 -> pure CHANNEL_UPDATE 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 @@ -1,72 +1,83 @@ -- | Discord emojis -module Calamity.Types.Model.Guild.Emoji - ( Emoji(..) - , Partial(PartialEmoji) - , RawEmoji(..) - , emojiAsRawEmoji ) where +module Calamity.Types.Model.Guild.Emoji ( + Emoji (..), + Partial (PartialEmoji), + RawEmoji (..), + emojiAsRawEmoji, +) where -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () -import Calamity.Types.Model.Guild.Role -import Calamity.Types.Model.User -import Calamity.Types.Snowflake +import Calamity.Internal.AesonThings +import Calamity.Internal.Utils () +import Calamity.Types.Model.Guild.Role +import Calamity.Types.Model.User +import Calamity.Types.Snowflake -import Data.Aeson -import qualified Data.Text.Lazy as L -import Data.Text.Lazy ( Text ) -import Data.Vector.Unboxing ( Vector ) +import Data.Aeson +import Data.Text.Lazy (Text) +import qualified Data.Text.Lazy as L +import Data.Vector.Unboxing (Vector) -import GHC.Generics +import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Control.DeepSeq (NFData) import Data.Generics.Product +import TextShow +import qualified TextShow.Generic as TSG data Emoji = Emoji - { id :: Snowflake Emoji - , name :: Text - , roles :: Vector (Snowflake Role) - , user :: Maybe (Snowflake User) + { id :: Snowflake Emoji + , name :: Text + , roles :: Vector (Snowflake Role) + , user :: Maybe (Snowflake User) , requireColons :: Bool - , managed :: Bool - , animated :: Bool + , managed :: Bool + , animated :: Bool } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Emoji - deriving ( ToJSON ) via CalamityJSON Emoji - deriving ( FromJSON ) via WithSpecialCases '["user" `ExtractFieldFrom` "id" - ,"roles" `IfNoneThen` DefaultToEmptyArray - ] Emoji - deriving ( HasID Emoji ) via HasIDField "id" Emoji + deriving (Eq, Show, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric Emoji + deriving (ToJSON) via CalamityJSON Emoji + deriving + (FromJSON) + via WithSpecialCases + '[ "user" `ExtractFieldFrom` "id" + , "roles" `IfNoneThen` DefaultToEmptyArray + ] + Emoji + deriving (HasID Emoji) via HasIDField "id" Emoji emojiAsRawEmoji :: Emoji -> RawEmoji emojiAsRawEmoji = CustomEmoji . upcast data instance Partial Emoji = PartialEmoji - { id :: Snowflake Emoji + { id :: Snowflake Emoji , name :: Text , animated :: Bool } - deriving ( Eq, Generic ) - deriving ( ToJSON ) via CalamityJSON (Partial Emoji) - deriving ( FromJSON ) via WithSpecialCases - '["animated" `IfNoneThen` DefaultToFalse] (Partial Emoji) - deriving ( HasID Emoji ) via HasIDField "id" (Partial Emoji) + deriving (Eq, Generic) + deriving (ToJSON) via CalamityJSON (Partial Emoji) + deriving + (FromJSON) + via WithSpecialCases + '["animated" `IfNoneThen` DefaultToFalse] + (Partial Emoji) + deriving (HasID Emoji) via HasIDField "id" (Partial Emoji) instance Show (Partial Emoji) where - show PartialEmoji { id, name, animated } = + show PartialEmoji{id, name, animated} = "<" <> a <> ":" <> L.unpack name <> ":" <> show id <> ">" - where a = if animated then "a" else "" + where + a = if animated then "a" else "" instance TextShow (Partial Emoji) where - showb PartialEmoji { id, name, animated } = + showb PartialEmoji{id, name, animated} = "<" <> a <> ":" <> fromLazyText name <> ":" <> showb id <> ">" - where a = if animated then "a" else "" + where + a = if animated then "a" else "" data RawEmoji = UnicodeEmoji Text | CustomEmoji (Partial Emoji) - deriving ( Eq, Generic ) + deriving (Eq, Generic) instance Show RawEmoji where show (UnicodeEmoji v) = L.unpack v diff --git a/src/Calamity/Types/Model/Guild/Guild.hs b/src/Calamity/Types/Model/Guild/Guild.hs --- a/src/Calamity/Types/Model/Guild/Guild.hs +++ b/src/Calamity/Types/Model/Guild/Guild.hs @@ -1,74 +1,72 @@ -- | Discord Guilds -module Calamity.Types.Model.Guild.Guild - ( Guild(..) - , Partial(PartialGuild) - , UpdatedGuild(..) ) where +module Calamity.Types.Model.Guild.Guild ( + Guild (..), + Partial (PartialGuild), + UpdatedGuild (..), +) where -import Calamity.Internal.AesonThings -import qualified Calamity.Internal.SnowflakeMap as SM -import Calamity.Internal.SnowflakeMap ( SnowflakeMap ) -import Calamity.Internal.Utils () -import Calamity.Types.Model.Channel -import Calamity.Types.Model.Guild.Emoji +import Calamity.Internal.AesonThings +import Calamity.Internal.SnowflakeMap (SnowflakeMap) +import qualified Calamity.Internal.SnowflakeMap as SM +import Calamity.Internal.Utils () +import Calamity.Types.Model.Channel +import Calamity.Types.Model.Guild.Emoji import {-# SOURCE #-} Calamity.Types.Model.Guild.Member -import Calamity.Types.Model.Guild.Role -import Calamity.Types.Model.Presence.Presence -import Calamity.Types.Model.User -import Calamity.Types.Model.Voice.VoiceState -import Calamity.Types.Snowflake - -import Control.Lens ( (^.) ) - -import Data.Aeson -import Data.Generics.Product.Fields -import Data.HashMap.Lazy ( HashMap ) -import qualified Data.HashMap.Lazy as LH -import Data.Text.Lazy ( Text ) -import Data.Time -import Data.Word - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG +import Calamity.Types.Model.Guild.Role +import Calamity.Types.Model.Presence.Presence +import Calamity.Types.Model.User +import Calamity.Types.Model.Voice.VoiceState +import Calamity.Types.Snowflake +import Control.DeepSeq +import Control.Lens ((^.)) +import Data.Aeson +import Data.Generics.Product.Fields +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as LH +import Data.Text.Lazy (Text) +import Data.Time +import Data.Word +import GHC.Generics +import TextShow +import qualified TextShow.Generic as TSG data Guild = Guild - { id :: Snowflake Guild - , name :: Text - , icon :: Maybe Text - , splash :: Maybe Text - , owner :: Maybe Bool - , ownerID :: Snowflake User - , permissions :: Word64 - , region :: Text - , afkChannelID :: Maybe (Snowflake GuildChannel) - , afkTimeout :: Int - , embedEnabled :: Bool - , embedChannelID :: Maybe (Snowflake GuildChannel) - , verificationLevel :: Int + { id :: Snowflake Guild + , name :: Text + , icon :: Maybe Text + , splash :: Maybe Text + , owner :: Maybe Bool + , ownerID :: Snowflake User + , permissions :: Word64 + , region :: Text + , afkChannelID :: Maybe (Snowflake GuildChannel) + , afkTimeout :: Int + , embedEnabled :: Bool + , embedChannelID :: Maybe (Snowflake GuildChannel) + , verificationLevel :: Int , defaultMessageNotifications :: Int - , explicitContentFilter :: Int - , roles :: SnowflakeMap Role - , emojis :: SnowflakeMap Emoji - , features :: [Text] - , mfaLevel :: Int - , applicationID :: Maybe (Snowflake User) - , widgetEnabled :: Bool - , widgetChannelID :: Maybe (Snowflake GuildChannel) - , systemChannelID :: Maybe (Snowflake GuildChannel) - -- NOTE: Below are only sent on GuildCreate - , joinedAt :: Maybe UTCTime - , large :: Bool - , unavailable :: Bool - , memberCount :: Int - , voiceStates :: [VoiceState] - , members :: SnowflakeMap Member - , channels :: SnowflakeMap GuildChannel - , presences :: HashMap (Snowflake User) Presence + , explicitContentFilter :: Int + , roles :: SnowflakeMap Role + , emojis :: SnowflakeMap Emoji + , features :: [Text] + , mfaLevel :: Int + , applicationID :: Maybe (Snowflake User) + , widgetEnabled :: Bool + , widgetChannelID :: Maybe (Snowflake GuildChannel) + , systemChannelID :: Maybe (Snowflake GuildChannel) + , -- NOTE: Below are only sent on GuildCreate + joinedAt :: Maybe UTCTime + , large :: Bool + , unavailable :: Bool + , memberCount :: Int + , voiceStates :: [VoiceState] + , members :: SnowflakeMap Member + , channels :: SnowflakeMap GuildChannel + , presences :: HashMap (Snowflake User) Presence } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Guild - deriving ( HasID Guild ) via HasIDField "id" Guild + deriving (Eq, Show, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric Guild + deriving (HasID Guild) via HasIDField "id" Guild instance FromJSON Guild where parseJSON = withObject "Guild" $ \v -> do @@ -84,9 +82,13 @@ presences' <- do presences' <- v .: "presences" - LH.fromList <$> traverse (\m -> do - p <- parseJSON $ Object (m <> "guild_id" .= id) - pure (getID $ p ^. field @"user", p)) presences' + LH.fromList + <$> traverse + ( \m -> do + p <- parseJSON $ Object (m <> "guild_id" .= id) + pure (getID $ p ^. field @"user", p) + ) + presences' Guild id <$> v .: "name" @@ -94,11 +96,11 @@ <*> v .:? "splash" <*> v .:? "owner" <*> v .: "owner_id" - <*> v .:? "permissions" .!= 0 + <*> v .:? "permissions" .!= 0 <*> v .: "region" <*> v .:? "afk_channel_id" <*> v .: "afk_timeout" - <*> v .:? "embed_enabled" .!= False + <*> v .:? "embed_enabled" .!= False <*> v .:? "embed_channel_id" <*> v .: "verification_level" <*> v .: "default_message_notifications" @@ -121,40 +123,40 @@ <*> pure presences' data instance Partial Guild = PartialGuild - { id :: Snowflake Guild + { id :: Snowflake Guild , name :: Text } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric (Partial Guild) - deriving ( ToJSON, FromJSON ) via CalamityJSON (Partial Guild) - deriving ( HasID Guild ) via HasIDField "id" (Partial Guild) + deriving (Eq, Show, Generic) + deriving (TextShow) via TSG.FromGeneric (Partial Guild) + deriving (ToJSON, FromJSON) via CalamityJSON (Partial Guild) + deriving (HasID Guild) via HasIDField "id" (Partial Guild) data UpdatedGuild = UpdatedGuild - { id :: Snowflake Guild - , name :: Text - , icon :: Maybe Text - , splash :: Maybe Text - , owner :: Maybe Bool - , ownerID :: Snowflake User - , permissions :: Maybe Word64 - , region :: Text - , afkChannelID :: Maybe (Snowflake GuildChannel) - , afkTimeout :: Int - , embedEnabled :: Maybe Bool - , embedChannelID :: Maybe (Snowflake GuildChannel) - , verificationLevel :: Int + { id :: Snowflake Guild + , name :: Text + , icon :: Maybe Text + , splash :: Maybe Text + , owner :: Maybe Bool + , ownerID :: Snowflake User + , permissions :: Maybe Word64 + , region :: Text + , afkChannelID :: Maybe (Snowflake GuildChannel) + , afkTimeout :: Int + , embedEnabled :: Maybe Bool + , embedChannelID :: Maybe (Snowflake GuildChannel) + , verificationLevel :: Int , defaultMessageNotifications :: Int - , explicitContentFilter :: Int - , roles :: SnowflakeMap Role - , emojis :: SnowflakeMap Emoji - , features :: [Text] - , mfaLevel :: Int - , applicationID :: Maybe (Snowflake User) - , widgetEnabled :: Maybe Bool - , widgetChannelID :: Maybe (Snowflake GuildChannel) - , systemChannelID :: Maybe (Snowflake GuildChannel) + , explicitContentFilter :: Int + , roles :: SnowflakeMap Role + , emojis :: SnowflakeMap Emoji + , features :: [Text] + , mfaLevel :: Int + , applicationID :: Maybe (Snowflake User) + , widgetEnabled :: Maybe Bool + , widgetChannelID :: Maybe (Snowflake GuildChannel) + , systemChannelID :: Maybe (Snowflake GuildChannel) } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric UpdatedGuild - deriving ( FromJSON ) via CalamityJSON UpdatedGuild - deriving ( HasID Guild ) via HasIDField "id" UpdatedGuild + deriving (Eq, Show, Generic) + deriving (TextShow) via TSG.FromGeneric UpdatedGuild + deriving (FromJSON) via CalamityJSON UpdatedGuild + deriving (HasID Guild) via HasIDField "id" UpdatedGuild diff --git a/src/Calamity/Types/Model/Guild/Member.hs b/src/Calamity/Types/Model/Guild/Member.hs --- a/src/Calamity/Types/Model/Guild/Member.hs +++ b/src/Calamity/Types/Model/Guild/Member.hs @@ -1,50 +1,59 @@ -- | Guild Members -module Calamity.Types.Model.Guild.Member - ( Member(..) ) where +module Calamity.Types.Model.Guild.Member (Member (..)) where -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils () +import Calamity.Internal.AesonThings +import Calamity.Internal.Utils () import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.Guild.Role -import Calamity.Types.Model.User -import Calamity.Types.Snowflake - - -import Data.Aeson -import Data.Text.Lazy ( Text ) -import Data.Time -import Data.Vector.Unboxing ( Vector ) - -import GHC.Generics - -import TextShow -import qualified TextShow.Generic as TSG +import Calamity.Types.Model.Guild.Role +import Calamity.Types.Model.User +import Calamity.Types.Snowflake +import Control.DeepSeq (NFData) +import Data.Aeson +import Data.Text.Lazy (Text) +import Data.Time +import Data.Vector.Unboxing (Vector) import Data.Word (Word64) +import GHC.Generics +import TextShow +import qualified TextShow.Generic as TSG data Member = Member - { id :: Snowflake User - , username :: Text + { id :: Snowflake User + , username :: Text , discriminator :: Text - , bot :: Maybe Bool - , avatar :: Maybe Text - , mfaEnabled :: Maybe Bool - , verified :: Maybe Bool - , email :: Maybe Text - , flags :: Maybe Word64 - , premiumType :: Maybe Word64 - , guildID :: Snowflake Guild - , nick :: Maybe Text - , roles :: Vector (Snowflake Role) - , joinedAt :: UTCTime - , deaf :: Bool - , mute :: Bool + , bot :: Maybe Bool + , avatar :: Maybe Text + , mfaEnabled :: Maybe Bool + , verified :: Maybe Bool + , email :: Maybe Text + , flags :: Maybe Word64 + , premiumType :: Maybe Word64 + , guildID :: Snowflake Guild + , nick :: Maybe Text + , roles :: Vector (Snowflake Role) + , joinedAt :: UTCTime + , deaf :: Bool + , mute :: Bool } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Member - deriving ( FromJSON ) via WithSpecialCases '[ - "user" `ExtractFields` ["id", "username", "discriminator", - "bot", "avatar", "mfa_enabled", - "verified", "email", "flags", "premium_type"]] Member - deriving ( HasID Guild ) via HasIDField "guildID" Member - deriving ( HasID Member ) via HasIDFieldCoerce "id" Member User - deriving ( HasID User ) via HasIDField "id" Member + deriving (Eq, Show, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric Member + deriving + (FromJSON) + via WithSpecialCases + '[ "user" + `ExtractFields` [ "id" + , "username" + , "discriminator" + , "bot" + , "avatar" + , "mfa_enabled" + , "verified" + , "email" + , "flags" + , "premium_type" + ] + ] + Member + deriving (HasID Guild) via HasIDField "guildID" Member + deriving (HasID Member) via HasIDFieldCoerce "id" Member User + deriving (HasID User) via HasIDField "id" Member diff --git a/src/Calamity/Types/Model/Guild/Overwrite.hs b/src/Calamity/Types/Model/Guild/Overwrite.hs --- a/src/Calamity/Types/Model/Guild/Overwrite.hs +++ b/src/Calamity/Types/Model/Guild/Overwrite.hs @@ -1,25 +1,25 @@ -- | Permission overwrites -module Calamity.Types.Model.Guild.Overwrite - ( Overwrite(..) ) where +module Calamity.Types.Model.Guild.Overwrite (Overwrite (..)) where -import Calamity.Internal.AesonThings -import Calamity.Types.Model.Guild.Permissions -import Calamity.Types.Snowflake +import Calamity.Internal.AesonThings +import Calamity.Types.Model.Guild.Permissions +import Calamity.Types.Snowflake -import Data.Aeson +import Data.Aeson -import GHC.Generics +import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Control.DeepSeq (NFData) +import TextShow +import qualified TextShow.Generic as TSG data Overwrite = Overwrite - { id :: Snowflake Overwrite + { id :: Snowflake Overwrite , type_ :: Int , allow :: Permissions - , deny :: Permissions + , deny :: Permissions } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Overwrite - deriving ( ToJSON, FromJSON ) via CalamityJSON Overwrite - deriving ( HasID Overwrite ) via HasIDField "id" Overwrite + deriving (Eq, Show, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric Overwrite + deriving (ToJSON, FromJSON) via CalamityJSON Overwrite + deriving (HasID Overwrite) via HasIDField "id" Overwrite diff --git a/src/Calamity/Types/Model/Guild/Permissions.hs b/src/Calamity/Types/Model/Guild/Permissions.hs --- a/src/Calamity/Types/Model/Guild/Permissions.hs +++ b/src/Calamity/Types/Model/Guild/Permissions.hs @@ -45,6 +45,7 @@ import Data.Text.Read (decimal) import Data.Word import TextShow +import Control.DeepSeq (NFData) $( bitmaskWrapper "Permissions" @@ -96,3 +97,4 @@ Left e -> parseFail e deriving via FromStringShow Permissions instance TextShow Permissions +deriving via Word64 instance NFData Permissions diff --git a/src/Calamity/Types/Model/Guild/Role.hs b/src/Calamity/Types/Model/Guild/Role.hs --- a/src/Calamity/Types/Model/Guild/Role.hs +++ b/src/Calamity/Types/Model/Guild/Role.hs @@ -1,33 +1,40 @@ -- | Guild roles -module Calamity.Types.Model.Guild.Role - ( Role(..) ) where +module Calamity.Types.Model.Guild.Role (Role (..)) where -import Calamity.Internal.AesonThings -import Calamity.Internal.IntColour () -import Calamity.Internal.Utils () -import Calamity.Types.Model.Guild.Permissions -import Calamity.Types.Snowflake +import Calamity.Internal.AesonThings +import Calamity.Internal.IntColour () +import Calamity.Internal.Utils () +import Calamity.Types.Model.Guild.Permissions +import Calamity.Types.Snowflake -import Data.Aeson -import Data.Colour -import Data.Text.Lazy ( Text ) +import Data.Aeson +import Data.Colour +import Data.Text.Lazy (Text) -import GHC.Generics +import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Control.DeepSeq (NFData (rnf), rwhnf) +import TextShow +import qualified TextShow.Generic as TSG data Role = Role - { id :: Snowflake Role - , name :: Text - , color :: Colour Double - , hoist :: Bool - , position :: Int + { id :: Snowflake Role + , name :: Text + , color :: Colour Double + , hoist :: Bool + , position :: Int , permissions :: Permissions - , managed :: Bool + , managed :: Bool , mentionable :: Bool } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Role - deriving ( ToJSON, FromJSON ) via CalamityJSON Role - deriving ( HasID Role ) via HasIDField "id" Role + deriving (Eq, Show, Generic) + deriving (TextShow) via TSG.FromGeneric Role + deriving (ToJSON, FromJSON) via CalamityJSON Role + deriving (HasID Role) via HasIDField "id" Role + +instance NFData Role where + rnf (Role id name color hoist position permissions managed mentionable) = + rnf id `seq` rnf name `seq` rwhnf color `seq` rnf hoist `seq` rnf position + `seq` rnf permissions + `seq` rnf managed + `seq` rnf mentionable diff --git a/src/Calamity/Types/Model/Presence/Activity.hs b/src/Calamity/Types/Model/Presence/Activity.hs --- a/src/Calamity/Types/Model/Presence/Activity.hs +++ b/src/Calamity/Types/Model/Presence/Activity.hs @@ -1,27 +1,26 @@ -- | User activities -module Calamity.Types.Model.Presence.Activity - ( Activity(..) - , activity - , ActivityType(..) - , ActivityTimestamps(..) - , ActivityParty(..) - , ActivityAssets(..) - , ActivitySecrets(..) ) where - -import Calamity.Internal.AesonThings -import Calamity.Internal.Utils -import Calamity.Types.Snowflake -import Calamity.Types.UnixTimestamp - -import Data.Aeson -import Data.Scientific -import Data.Text.Lazy ( Text ) -import Data.Word - -import GHC.Generics +module Calamity.Types.Model.Presence.Activity ( + Activity (..), + activity, + ActivityType (..), + ActivityTimestamps (..), + ActivityParty (..), + ActivityAssets (..), + ActivitySecrets (..), +) where -import TextShow -import qualified TextShow.Generic as TSG +import Calamity.Internal.AesonThings +import Calamity.Internal.Utils +import Calamity.Types.Snowflake +import Calamity.Types.UnixTimestamp +import Control.DeepSeq (NFData) +import Data.Aeson +import Data.Scientific +import Data.Text.Lazy (Text) +import Data.Word +import GHC.Generics +import TextShow +import qualified TextShow.Generic as TSG data ActivityType = Game @@ -29,8 +28,8 @@ | Listening | Custom | Other Int - deriving ( Eq, Generic, Show ) - deriving ( TextShow ) via TSG.FromGeneric ActivityType + deriving (Eq, Generic, Show, NFData) + deriving (TextShow) via TSG.FromGeneric ActivityType instance ToJSON ActivityType where toJSON Game = Number 0 @@ -41,7 +40,7 @@ instance FromJSON ActivityType where parseJSON = withScientific "ActivityType" $ \n -> case toBoundedInteger @Int n of - Just v -> case v of + Just !v -> case v of 0 -> pure Game 1 -> pure Streaming 2 -> pure Listening @@ -50,51 +49,52 @@ Nothing -> fail $ "Invalid ActivityType: " <> show n data Activity = Activity - { name :: Text - , type_ :: ActivityType - , url :: Maybe Text - , timestamps :: Maybe ActivityTimestamps + { name :: Text + , type_ :: !ActivityType + , url :: Maybe Text + , timestamps :: Maybe ActivityTimestamps , applicationID :: Maybe (Snowflake ()) - , details :: Maybe Text - , state :: Maybe Text - , party :: Maybe ActivityParty - , assets :: Maybe ActivityAssets - , secrets :: Maybe ActivitySecrets - , instance_ :: Maybe Bool - , flags :: Maybe Word64 + , details :: Maybe Text + , state :: Maybe Text + , party :: Maybe ActivityParty + , assets :: Maybe ActivityAssets + , secrets :: Maybe ActivitySecrets + , instance_ :: Maybe Bool + , flags :: Maybe Word64 } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric Activity - deriving ( ToJSON, FromJSON ) via CalamityJSON Activity + deriving (Eq, Show, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric Activity + deriving (ToJSON, FromJSON) via CalamityJSON Activity -- | Make an 'Activity' with all optional fields set to Nothing activity :: Text -> ActivityType -> Activity -activity name type_ = +activity !name !type_ = Activity - { name = name, - type_ = type_, - url = Nothing, - timestamps = Nothing, - applicationID = Nothing, - details = Nothing, - state = Nothing, - party = Nothing, - assets = Nothing, - secrets = Nothing, - instance_ = Nothing, - flags = Nothing + { name = name + , type_ = type_ + , url = Nothing + , timestamps = Nothing + , applicationID = Nothing + , details = Nothing + , state = Nothing + , party = Nothing + , assets = Nothing + , secrets = Nothing + , instance_ = Nothing + , flags = Nothing } data ActivityTimestamps = ActivityTimestamps - { start :: Maybe UnixTimestamp - , end :: Maybe UnixTimestamp + { start :: !(Maybe UnixTimestamp) + , end :: !(Maybe UnixTimestamp) } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric ActivityTimestamps + deriving (Eq, Show, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric ActivityTimestamps instance ToJSON ActivityTimestamps where - toJSON ActivityTimestamps { start, end } = object - ["start" .= (unixToMilliseconds <$> start), "end" .= (unixToMilliseconds <$> end)] + toJSON ActivityTimestamps{start, end} = + object + ["start" .= (unixToMilliseconds <$> start), "end" .= (unixToMilliseconds <$> end)] instance FromJSON ActivityTimestamps where parseJSON = withObject "ActivityTimestamps" $ \v -> do @@ -104,28 +104,28 @@ pure $ ActivityTimestamps start end data ActivityParty = ActivityParty - { id :: Maybe Text + { id :: Maybe Text , size :: Maybe (Int, Int) } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric ActivityParty - deriving ( ToJSON, FromJSON ) via CalamityJSON ActivityParty + deriving (Eq, Show, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric ActivityParty + deriving (ToJSON, FromJSON) via CalamityJSON ActivityParty data ActivityAssets = ActivityAssets { largeImage :: Maybe Text - , largeText :: Maybe Text + , largeText :: Maybe Text , smallImage :: Maybe Text - , smallText :: Maybe Text + , smallText :: Maybe Text } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric ActivityAssets - deriving ( ToJSON, FromJSON ) via CalamityJSON ActivityAssets + deriving (Eq, Show, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric ActivityAssets + deriving (ToJSON, FromJSON) via CalamityJSON ActivityAssets data ActivitySecrets = ActivitySecrets - { join :: Maybe Text + { join :: Maybe Text , spectate :: Maybe Text - , match :: Maybe Text + , match :: Maybe Text } - deriving ( Eq, Show, Generic ) - deriving ( TextShow ) via TSG.FromGeneric ActivitySecrets - deriving ( ToJSON, FromJSON ) via CalamityJSON ActivitySecrets + deriving (Eq, Show, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric ActivitySecrets + deriving (ToJSON, FromJSON) via CalamityJSON ActivitySecrets 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,15 +1,15 @@ -- | User presences -module Calamity.Types.Model.Presence.Presence - ( Presence (..), - ClientStatus (..), - ) -where +module Calamity.Types.Model.Presence.Presence ( + Presence (..), + ClientStatus (..), +) where 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 Control.DeepSeq (NFData) import Data.Aeson import qualified Data.Override as O import Data.Override.Aeson () @@ -19,13 +19,13 @@ import qualified TextShow.Generic as TSG data Presence = Presence - { user :: Snowflake User, - guildID :: Snowflake Guild, - status :: StatusType, - activities :: [Activity], - clientStatus :: ClientStatus + { user :: Snowflake User + , guildID :: Snowflake Guild + , status :: StatusType + , activities :: [Activity] + , clientStatus :: ClientStatus } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) deriving (TextShow) via TSG.FromGeneric Presence deriving (ToJSON) @@ -40,10 +40,10 @@ 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 (Eq, Show, Generic, NFData) deriving (TextShow) via TSG.FromGeneric ClientStatus deriving (ToJSON, FromJSON) via CalamityJSON ClientStatus diff --git a/src/Calamity/Types/Model/User.hs b/src/Calamity/Types/Model/User.hs --- a/src/Calamity/Types/Model/User.hs +++ b/src/Calamity/Types/Model/User.hs @@ -1,47 +1,49 @@ -- | A User -module Calamity.Types.Model.User - ( User(..) - , Partial(PartialUser) - , StatusType(..) ) where +module Calamity.Types.Model.User ( + User (..), + Partial (PartialUser), + StatusType (..), +) where -import Calamity.Internal.AesonThings +import Calamity.Internal.AesonThings import {-# SOURCE #-} Calamity.Types.Model.Guild.Member -import Calamity.Types.Partial -import Calamity.Types.Snowflake +import Calamity.Types.Partial +import Calamity.Types.Snowflake -import Data.Aeson -import Data.Text.Lazy ( Text ) -import Data.Word +import Data.Aeson +import Data.Text.Lazy (Text) +import Data.Word -import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Control.DeepSeq +import GHC.Generics +import TextShow +import qualified TextShow.Generic as TSG data User = User - { id :: Snowflake User - , username :: Text + { id :: Snowflake User + , username :: Text , discriminator :: Text - , bot :: Maybe Bool - , avatar :: Maybe Text - , mfaEnabled :: Maybe Bool - , verified :: Maybe Bool - , email :: Maybe Text - , flags :: Maybe Word64 - , premiumType :: Maybe Word64 + , bot :: Maybe Bool + , avatar :: Maybe Text + , mfaEnabled :: Maybe Bool + , verified :: Maybe Bool + , email :: Maybe Text + , flags :: Maybe Word64 + , premiumType :: Maybe Word64 } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric User - deriving ( ToJSON, FromJSON ) via CalamityJSON User - deriving ( HasID User ) via HasIDField "id" User - deriving ( HasID Member ) via HasIDFieldCoerce' "id" User + deriving (Show, Eq, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric User + deriving (ToJSON, FromJSON) via CalamityJSON User + deriving (HasID User) via HasIDField "id" User + deriving (HasID Member) via HasIDFieldCoerce' "id" User newtype instance Partial User = PartialUser { id :: Snowflake User } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric (Partial User) - deriving ( ToJSON, FromJSON ) via CalamityJSON (Partial User) - deriving ( HasID User ) via HasIDField "id" (Partial User) + deriving (Show, Eq, Generic) + deriving (TextShow) via TSG.FromGeneric (Partial User) + deriving (ToJSON, FromJSON) via CalamityJSON (Partial User) + deriving (HasID User) via HasIDField "id" (Partial User) data StatusType = Idle @@ -49,22 +51,23 @@ | Online | Offline | Invisible - deriving ( Eq, Show, Enum, Generic ) - deriving ( TextShow ) via TSG.FromGeneric StatusType + deriving (Eq, Show, Enum, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric StatusType instance FromJSON StatusType where parseJSON = withText "StatusType" $ \case - "idle" -> pure Idle - "dnd" -> pure DND - "online" -> pure Online - "offline" -> pure Offline + "idle" -> pure Idle + "dnd" -> pure DND + "online" -> pure Online + "offline" -> pure Offline "invisible" -> pure Invisible - _ -> fail "Unknown status type" + _ -> fail "Unknown status type" instance ToJSON StatusType where - toJSON = String . \case - Idle -> "idle" - DND -> "dnd" - Online -> "online" - Offline -> "offline" - Invisible -> "invisible" + toJSON = + String . \case + Idle -> "idle" + DND -> "dnd" + Online -> "online" + Offline -> "offline" + Invisible -> "invisible" diff --git a/src/Calamity/Types/Model/Voice/VoiceState.hs b/src/Calamity/Types/Model/Voice/VoiceState.hs --- a/src/Calamity/Types/Model/Voice/VoiceState.hs +++ b/src/Calamity/Types/Model/Voice/VoiceState.hs @@ -1,31 +1,31 @@ -module Calamity.Types.Model.Voice.VoiceState - ( VoiceState(..) ) where +module Calamity.Types.Model.Voice.VoiceState (VoiceState (..)) where -import Calamity.Internal.AesonThings -import Calamity.Types.Model.Channel.Guild.Voice +import Calamity.Internal.AesonThings +import Calamity.Types.Model.Channel.Guild.Voice import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild -import Calamity.Types.Model.User -import Calamity.Types.Snowflake +import Calamity.Types.Model.User +import Calamity.Types.Snowflake -import Data.Aeson -import Data.Text.Lazy ( Text ) +import Data.Aeson +import Data.Text.Lazy (Text) -import GHC.Generics +import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Control.DeepSeq (NFData) +import TextShow +import qualified TextShow.Generic as TSG data VoiceState = VoiceState - { guildID :: Maybe (Snowflake Guild) + { guildID :: Maybe (Snowflake Guild) , channelID :: Maybe (Snowflake VoiceChannel) - , userID :: Snowflake User + , userID :: Snowflake User , sessionID :: Text - , deaf :: Bool - , mute :: Bool - , selfDeaf :: Bool - , selfMute :: Bool - , suppress :: Bool + , deaf :: Bool + , mute :: Bool + , selfDeaf :: Bool + , selfMute :: Bool + , suppress :: Bool } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric VoiceState - deriving ( ToJSON, FromJSON ) via CalamityJSON VoiceState + deriving (Show, Eq, Generic, NFData) + deriving (TextShow) via TSG.FromGeneric VoiceState + deriving (ToJSON, FromJSON) via CalamityJSON VoiceState diff --git a/src/Calamity/Types/UnixTimestamp.hs b/src/Calamity/Types/UnixTimestamp.hs --- a/src/Calamity/Types/UnixTimestamp.hs +++ b/src/Calamity/Types/UnixTimestamp.hs @@ -1,60 +1,68 @@ -- | Parsing of unix timestamps -module Calamity.Types.UnixTimestamp - ( UnixTimestamp(..) - , unixToMilliseconds - , millisecondsToUnix ) where +module Calamity.Types.UnixTimestamp ( + UnixTimestamp (..), + unixToMilliseconds, + millisecondsToUnix, +) where -import Calamity.Internal.Utils () +import Calamity.Internal.Utils () -import Control.Arrow +import Control.Arrow -import Data.Aeson -import Data.Aeson.Encoding ( word64 ) -import Data.Time -import Data.Time.Clock.POSIX -import Data.Word +import Data.Aeson +import Data.Aeson.Encoding (word64) +import Data.Time +import Data.Time.Clock.POSIX +import Data.Word -import GHC.Generics +import GHC.Generics -import TextShow -import qualified TextShow.Generic as TSG +import Control.DeepSeq (NFData) +import TextShow +import qualified TextShow.Generic as TSG newtype UnixTimestamp = UnixTimestamp - { unUnixTimestamp :: UTCTime - } - deriving ( Show, Eq, Generic ) - deriving ( TextShow ) via TSG.FromGeneric UnixTimestamp + { unUnixTimestamp :: UTCTime + } + deriving (Show, Eq, Generic) + deriving newtype (NFData) + deriving (TextShow) via TSG.FromGeneric UnixTimestamp unixToMilliseconds :: UnixTimestamp -> Word64 -unixToMilliseconds = unUnixTimestamp - >>> utcTimeToPOSIXSeconds - >>> toRational - >>> (* 1000) - >>> round +unixToMilliseconds = + unUnixTimestamp + >>> utcTimeToPOSIXSeconds + >>> toRational + >>> (* 1000) + >>> round millisecondsToUnix :: Word64 -> UnixTimestamp -millisecondsToUnix = toRational - >>> fromRational - >>> (/ 1000) - >>> posixSecondsToUTCTime - >>> UnixTimestamp +millisecondsToUnix = + toRational + >>> fromRational + >>> (/ 1000) + >>> posixSecondsToUTCTime + >>> UnixTimestamp instance ToJSON UnixTimestamp where - toJSON = unUnixTimestamp - >>> utcTimeToPOSIXSeconds - >>> toRational - >>> round - >>> toJSON @Word64 - toEncoding = unUnixTimestamp - >>> utcTimeToPOSIXSeconds - >>> toRational - >>> round - >>> word64 + toJSON = + unUnixTimestamp + >>> utcTimeToPOSIXSeconds + >>> toRational + >>> round + >>> toJSON @Word64 + toEncoding = + unUnixTimestamp + >>> utcTimeToPOSIXSeconds + >>> toRational + >>> round + >>> word64 instance FromJSON UnixTimestamp where - parseJSON = withScientific "UnixTimestamp" $ - toRational - >>> fromRational - >>> posixSecondsToUTCTime - >>> UnixTimestamp - >>> pure + parseJSON = + withScientific "UnixTimestamp" $ + toRational + >>> fromRational + >>> posixSecondsToUTCTime + >>> UnixTimestamp + >>> pure