packages feed

calamity (empty) → 0.1.0.0

raw patch · 69 files changed

+5032/−0 lines, 69 filesdep +aesondep +asyncdep +basesetup-changed

Dependencies added: aeson, async, base, bytestring, concurrent-extra, data-default-class, deepseq, deque, df1, di-polysemy, exceptions, fmt, focus, generic-lens, generic-override, generic-override-aeson, hashable, http-date, http-types, lens, lens-aeson, mtl, polysemy, polysemy-plugin, reflection, scientific, stm, stm-chans, stm-containers, text, text-show, time, typerep-map, unordered-containers, vector, websockets, wreq-patchable, wuss

Files

+ ChangeLog.md view
@@ -0,0 +1,3 @@+# Changelog for Calamity++## Unreleased changes
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2020 Ben Simms++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,89 @@+# Calamity++A discord library for haskell++# Example++``` haskell+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedLabels #-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeApplications #-}++{-# LANGUAGE TypeOperators #-}++module Main where++import           Calamity+import           Calamity.Cache.InMemory++import           Control.Concurrent+import           Control.Concurrent.STM.TVar+import           Control.Lens+import           Control.Monad++import           Data.Text.Lazy              ( Text, fromStrict )+import           Data.Text.Strict.Lens++import qualified DiPolysemy                  as DiP++import qualified Polysemy                    as P+import qualified Polysemy.Async              as P+import qualified Polysemy.AtomicState        as P+import qualified Polysemy.Embed              as P+import qualified Polysemy.Fail               as P++import           Prelude                     hiding ( error )++import           TextShow++data Counter m a where+  GetCounter :: Counter m Int++P.makeSem ''Counter++runCounterAtomic :: P.Member (P.Embed IO) r => P.Sem (Counter ': r) () -> P.Sem r ()+runCounterAtomic m = do+  var <- P.embed $ newTVarIO (0 :: Int)+  P.runAtomicStateTVar var $ P.reinterpret (\case+                                              GetCounter -> P.atomicState (\v -> (v + 1, v))) m++handleErrorByLogging m = do+  r <- P.runFail m+  case r of+    Left e -> DiP.error (e ^. packed)+    _      -> pure ()++info = DiP.info @Text+debug = DiP.info @Text++main :: IO ()+main = do+  P.runFinal . P.embedToFinal . runCounterAtomic . runCacheInMemory $ runBotIO (BotToken "") $ do+    react @"messagecreate" $ \msg -> handleErrorByLogging $ do+      when (msg ^. #content == "!count") $ replicateM_ 3 $ do+        val <- getCounter+        info $ "the counter is: " <> fromStrict (showt val)+        void . invokeRequest $ CreateMessage (msg ^. #channelID) ("The value is: " <> showt val)+      when (msg ^. #content == "!say hi") $ replicateM_ 3 . P.async $ do+        info "saying heya"+        Right msg' <- invokeRequest $ CreateMessage (msg ^. #channelID) "heya"+        info "sleeping"+        P.embed $ threadDelay (5 * 1000 * 1000)+        info "slept"+        void . invokeRequest $ EditMessage (msg ^. #channelID) msg' (Just "lol") Nothing+        info "edited"+      when (msg ^. #content == "!explode") $ do+        Just x <- pure Nothing+        debug "unreachable!"+      when (msg ^. #content == "!bye") $ do+        void . invokeRequest $ CreateMessage (msg ^. #channelID) "bye!"+        stopBot+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal.project view
@@ -0,0 +1,10 @@+-- Generated by stackage-to-hackage++with-compiler: ghc-8.6.5++packages:+    ./+++allow-older: *+allow-newer: *
+ calamity.cabal view
@@ -0,0 +1,145 @@+cabal-version: 1.18+name: calamity+version: 0.1.0.0+license: MIT+license-file: LICENSE+copyright: 2020 Ben Simms+maintainer: ben@bensimms.moe+author: Ben Simms+tested-with: ghc ==8.6.5+homepage: https://github.com/nitros12/calamity+bug-reports: https://github.com/nitros12/calamity/issues+synopsis: A library for writing discord bots+description:+    Please see the README on GitHub at <https://github.com/nitros12/calamity#readme>+category: Network, Web+build-type: Simple+extra-source-files:+    README.md+    ChangeLog.md+    cabal.project+extra-doc-files: README.md++source-repository head+    type: git+    location: https://github.com/nitros12/calamity++library+    exposed-modules:+        Calamity+        Calamity.Cache.Eff+        Calamity.Cache.InMemory+        Calamity.Client+        Calamity.Client.Client+        Calamity.Client.ShardManager+        Calamity.Client.Types+        Calamity.Gateway+        Calamity.Gateway.DispatchEvents+        Calamity.Gateway.Shard+        Calamity.Gateway.Types+        Calamity.HTTP+        Calamity.HTTP.Channel+        Calamity.HTTP.Emoji+        Calamity.HTTP.Guild+        Calamity.HTTP.Internal.Ratelimit+        Calamity.HTTP.Internal.Request+        Calamity.HTTP.Internal.Route+        Calamity.HTTP.Internal.Types+        Calamity.HTTP.MiscRoutes+        Calamity.Internal.AesonThings+        Calamity.Internal.MessageStore+        Calamity.Internal.SnowflakeMap+        Calamity.Internal.Updateable+        Calamity.Internal.Utils+        Calamity.LogEff+        Calamity.Types+        Calamity.Types.Model+        Calamity.Types.Model.Channel+        Calamity.Types.Model.Channel.Attachment+        Calamity.Types.Model.Channel.ChannelType+        Calamity.Types.Model.Channel.DM+        Calamity.Types.Model.Channel.Embed+        Calamity.Types.Model.Channel.Group+        Calamity.Types.Model.Channel.Guild+        Calamity.Types.Model.Channel.Guild.Category+        Calamity.Types.Model.Channel.Guild.Text+        Calamity.Types.Model.Channel.Guild.Voice+        Calamity.Types.Model.Channel.Message+        Calamity.Types.Model.Channel.Reaction+        Calamity.Types.Model.Guild+        Calamity.Types.Model.Guild.Emoji+        Calamity.Types.Model.Guild.Guild+        Calamity.Types.Model.Guild.Invite+        Calamity.Types.Model.Guild.Member+        Calamity.Types.Model.Guild.Overwrite+        Calamity.Types.Model.Guild.Role+        Calamity.Types.Model.Guild.UnavailableGuild+        Calamity.Types.Model.Presence+        Calamity.Types.Model.Presence.Activity+        Calamity.Types.Model.Presence.Presence+        Calamity.Types.Model.User+        Calamity.Types.Model.Voice+        Calamity.Types.Model.Voice.VoiceState+        Calamity.Types.Partial+        Calamity.Types.Snowflake+        Calamity.Types.Token+        Calamity.Types.UnixTimestamp+    hs-source-dirs: src+    other-modules:+        Paths_calamity+    default-language: Haskell2010+    default-extensions: CPP AllowAmbiguousTypes BlockArguments+                        NoMonomorphismRestriction AutoDeriveTypeable BangPatterns+                        BinaryLiterals UndecidableInstances ConstraintKinds DataKinds+                        DefaultSignatures DeriveDataTypeable DeriveFoldable DeriveFunctor+                        DeriveGeneric DeriveTraversable DoAndIfThenElse EmptyDataDecls+                        ExistentialQuantification FlexibleContexts FlexibleInstances+                        FunctionalDependencies GADTs DerivingVia DerivingStrategies+                        GeneralizedNewtypeDeriving StandaloneDeriving DeriveAnyClass+                        InstanceSigs KindSignatures LambdaCase MonadFailDesugaring+                        MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings+                        OverloadedLabels PartialTypeSignatures PatternGuards PolyKinds+                        RankNTypes RecordWildCards ScopedTypeVariables TupleSections+                        TypeFamilies TypeSynonymInstances ViewPatterns+                        DuplicateRecordFields TypeOperators TypeApplications+                        RoleAnnotations+    ghc-options: -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall+    build-depends:+        aeson >=1.4 && <2,+        async >=2.2 && <3,+        base >=4.12 && <5,+        bytestring ==0.10.*,+        concurrent-extra ==0.7.*,+        data-default-class ==0.1.*,+        deepseq >=1.4.4.0 && <2,+        deque ==0.4.*,+        df1 ==0.3.*,+        di-polysemy ==0.1.*,+        exceptions ==0.10.*,+        fmt ==0.6.*,+        focus >=1.0 && <2,+        generic-lens >=2.0 && <3,+        generic-override >=0.0.0.0 && <0.0.1,+        generic-override-aeson >=0.0.0.0 && <0.0.1,+        hashable >=1.2 && <2,+        http-date >=0.0.8 && <0.1,+        http-types ==0.12.*,+        lens >=4.18 && <5,+        lens-aeson >=1.1 && <2,+        mtl >=2.2 && <3,+        polysemy >=1.3 && <2,+        polysemy-plugin ==0.2.*,+        reflection >=2.1 && <3,+        scientific ==0.3.*,+        stm >=2.5 && <3,+        stm-chans >=3.0 && <4,+        stm-containers >=1.1 && <2,+        text >=1.2 && <2,+        text-show >=3.8 && <4,+        time >=1.8 && <1.11,+        typerep-map ==0.3.*,+        unordered-containers ==0.2.*,+        vector ==0.12.*,+        websockets ==0.12.*,+        wreq-patchable >=1.0 && <2,+        wuss >=1.1 && <2
+ src/Calamity.hs view
@@ -0,0 +1,8 @@+module Calamity+    ( module Calamity.Client+    , module Calamity.HTTP+    , module Calamity.Types ) where++import           Calamity.Client+import           Calamity.HTTP+import           Calamity.Types
+ src/Calamity/Cache/Eff.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE TemplateHaskell #-}++-- | Effect for handling the cache+module Calamity.Cache.Eff+    ( CacheEff(..)+    , setBotUser+    , updateBotUser+    , getBotUser+    , setGuild+    , updateGuild+    , getGuild+    , delGuild+    , setDM+    , updateDM+    , getDM+    , delDM+      -- , setGuildChannel+      -- , getGuildChannel+      -- , delGuildChannel+    , setUser+    , updateUser+    , getUser+    , delUser+    , setUnavailableGuild+    , isUnavailableGuild+    , delUnavailableGuild+    , setMessage+    , updateMessage+    , getMessage+    , delMessage ) where++import           Calamity.Internal.Utils+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild+import           Calamity.Types.Model.User+import           Calamity.Types.Snowflake++import           Polysemy+import qualified Polysemy                     as P++data CacheEff m a where+  -- | Set the 'User' representing the bot itself+  SetBotUser :: User -> CacheEff m ()+  -- | Get the 'User' representing the bot itself+  GetBotUser :: CacheEff m (Maybe User)++  -- | Set or Update a 'Guild' in the cache+  SetGuild :: Guild -> CacheEff m ()+  -- | Get a 'Guild' from the cache+  GetGuild :: Snowflake Guild -> CacheEff m (Maybe Guild)+  -- | Delete a 'Guild' from the cache+  DelGuild :: Snowflake Guild -> CacheEff m ()++  -- | Set or Update a 'DMChannel' in the cache+  SetDM :: DMChannel -> CacheEff m ()+  -- | Get a 'DMChannel' from the cache+  GetDM :: Snowflake DMChannel -> CacheEff m (Maybe DMChannel)+  -- | Delete a 'DMChannel' from the cache+  DelDM :: Snowflake DMChannel -> CacheEff m ()++  -- -- | Set or Update a 'GuildChannel' in the cache+  -- SetGuildChannel :: GuildChannel -> CacheEff m ()+  -- -- | Get a 'GuildChannel' from the cache+  -- GetGuildChannel :: Snowflake GuildChannel -> CacheEff m (Maybe GuildChannel)+  -- -- | Delete a 'GuildChannel' from the cache+  -- DelGuildChannel :: Snowflake GuildChannel -> CacheEff m ()+  -- | Set or Update a 'User' in the cache+  SetUser :: User -> CacheEff m ()+  -- | Get a 'User' from the cache+  GetUser :: Snowflake User -> CacheEff m (Maybe User)+  -- | Delete a 'User' from the cache+  DelUser :: Snowflake User -> CacheEff m ()++  -- | Flag a 'Guild' as unavailable+  SetUnavailableGuild :: Snowflake Guild -> CacheEff m ()+  -- | Test if a 'Guild' is flagged as unavailable+  IsUnavailableGuild :: Snowflake Guild -> CacheEff m Bool+  -- | Unflag a 'Guild' from being unavailable+  DelUnavailableGuild :: Snowflake Guild -> CacheEff m ()++  -- | Add or Update a 'Message' in the cache+  SetMessage :: Message -> CacheEff m ()+  -- | Get a 'Message' from the cache+  GetMessage :: Snowflake Message -> CacheEff m (Maybe Message)+  -- | Delete a 'Message' from the cache+  DelMessage :: Snowflake Message -> CacheEff m ()++makeSem ''CacheEff++updateBotUser :: P.Member CacheEff r => (User -> User) -> Sem r ()+updateBotUser f = getBotUser >>= flip whenJust (setBotUser . f)++updateGuild :: P.Member CacheEff r => Snowflake Guild -> (Guild -> Guild) -> Sem r ()+updateGuild id f = getGuild id >>= flip whenJust (setGuild . f)++updateDM :: P.Member CacheEff r => Snowflake DMChannel -> (DMChannel -> DMChannel) -> Sem r ()+updateDM id f = getDM id >>= flip whenJust (setDM . f)++updateUser :: P.Member CacheEff r => Snowflake User -> (User -> User) -> Sem r ()+updateUser id f = getUser id >>= flip whenJust (setUser . f)++updateMessage :: P.Member CacheEff r => Snowflake Message -> (Message -> Message) -> Sem r ()+updateMessage id f = getMessage id >>= flip whenJust (setMessage . f)
+ src/Calamity/Cache/InMemory.hs view
@@ -0,0 +1,72 @@+-- | A 'Cache' handler that operates in memory+module Calamity.Cache.InMemory+    ( runCacheInMemory ) where++import           Calamity.Cache.Eff+import           Calamity.Internal.MessageStore+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           Control.Lens+import           Control.Monad.State.Strict++import           Data.Default.Class+import qualified Data.HashSet                   as LS+import           Data.IORef++import           GHC.Generics++import qualified Polysemy                       as P+import qualified Polysemy.AtomicState           as P++data Cache = Cache+  { user              :: Maybe User+  , guilds            :: SM.SnowflakeMap Guild+  , dms               :: SM.SnowflakeMap DMChannel+  , channels          :: SM.SnowflakeMap GuildChannel+  , users             :: SM.SnowflakeMap User+  , unavailableGuilds :: LS.HashSet (Snowflake Guild)+  , messages          :: MessageStore+  }+  deriving ( Generic, Show )++emptyCache :: Cache+emptyCache = Cache Nothing SM.empty SM.empty SM.empty SM.empty LS.empty def++runCacheInMemory :: P.Member (P.Embed IO) r => P.Sem (CacheEff ': r) a -> P.Sem r a+runCacheInMemory m = do+  var <- P.embed $ newIORef emptyCache+  P.runAtomicStateIORef var $ P.reinterpret updateCache' m++updateCache' :: P.Member (P.AtomicState Cache) r => CacheEff m a -> P.Sem r a+updateCache' act = P.atomicState' ((swap .) . runState $ updateCache act)++updateCache :: CacheEff m a -> State Cache a++updateCache (SetBotUser u) = #user ?= u+updateCache GetBotUser     = use #user++updateCache (SetGuild g)   = #guilds %= SM.insert g+updateCache (GetGuild gid) = use (#guilds . at gid)+updateCache (DelGuild gid) = #guilds %= sans gid+++updateCache (SetDM dm)   = #dms %= SM.insert dm+updateCache (GetDM did) = use (#dms . at did)+updateCache (DelDM did) = #dms %= sans did++updateCache (SetUser u)   = #users %= SM.insert u+updateCache (GetUser uid) = use (#users . at uid)+updateCache (DelUser uid) = #users %= sans uid++updateCache (SetUnavailableGuild gid) = #unavailableGuilds %= LS.insert gid+updateCache (IsUnavailableGuild gid) = use (#unavailableGuilds . contains gid)+updateCache (DelUnavailableGuild gid) = #unavailableGuilds %= sans gid++updateCache (SetMessage m)   = #messages %= addMessage m+updateCache (GetMessage mid) = use (#messages . at mid)+updateCache (DelMessage mid) = #messages %= sans mid
+ src/Calamity/Client.hs view
@@ -0,0 +1,7 @@+-- | Module containing the core client stuff+module Calamity.Client+    ( module Calamity.Client.Client+    , module Calamity.Client.Types ) where++import           Calamity.Client.Client+import           Calamity.Client.Types
+ src/Calamity/Client/Client.hs view
@@ -0,0 +1,422 @@+-- | The client+module Calamity.Client.Client+    ( Client(..)+    , react+    , runBotIO+    , stopBot ) where++import           Calamity.Cache.Eff+import           Calamity.Client.ShardManager+import           Calamity.Client.Types+import           Calamity.Gateway.DispatchEvents+import           Calamity.Gateway.Types+import           Calamity.HTTP.Internal.Ratelimit+import qualified Calamity.Internal.SnowflakeMap              as SM+import           Calamity.Internal.Updateable+import           Calamity.Internal.Utils+import           Calamity.LogEff+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild.UnavailableGuild+import           Calamity.Types.Model.Presence               ( Presence(..) )+import           Calamity.Types.Snowflake+import           Calamity.Types.Token++import           Control.Concurrent.MVar+import           Control.Concurrent.STM+import           Control.Lens+import           Control.Monad++import           Data.Default.Class+import           Data.Dynamic+import           Data.Foldable+import           Data.Maybe+import           Data.Traversable+import qualified Data.TypeRepMap                             as TM++import qualified DiPolysemy                                  as Di++import           Fmt++import           GHC.TypeLits++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.Fail                               as P+import qualified Polysemy.Reader                             as P+++newClient :: Token -> IO Client+newClient token = do+  shards'        <- newTVarIO []+  numShards'     <- newEmptyMVar+  rlState'       <- newRateLimitState+  eventQueue'    <- newTQueueIO++  pure $ Client shards'+                numShards'+                token+                rlState'+                eventQueue'++type SetupEff r = Sem (LogEff ': P.Reader Client ': P.AtomicState EventHandlers ': P.Async ': r) ()++runBotIO :: (P.Members '[P.Embed IO, P.Final IO, CacheEff] r, Typeable r) => Token -> SetupEff r -> Sem r ()+runBotIO token setup = do+  client <- P.embed $ newClient token+  handlers <- P.embed $ newTVarIO def+  P.asyncToIOFinal . P.runAtomicStateTVar handlers . P.runReader client . Di.runDiToStderrIO $ do+    setup+    shardBot+    clientLoop+    finishUp++react :: forall (s :: Symbol) r. (KnownSymbol s, BotC r, EHType' s ~ Dynamic, Typeable (EHType s (Sem r))) => EHType s (Sem r) -> Sem r ()+react f =+  let handlers = EventHandlers . TM.one $ EH @s [toDyn f]+  in P.atomicModify (handlers <>)++stopBot :: BotC r => Sem r ()+stopBot = do+  debug "stopping bot"+  shards <- P.asks (^. #shards) >>= P.embed . readTVarIO+  for_ shards $ \shard ->+    P.embed . atomically $ writeTQueue (shard ^. _1 . #cmdQueue) ShutDownShard+  eventQueue <- P.asks (^. #eventQueue)+  P.embed . atomically $ writeTQueue eventQueue ShutDown++finishUp :: BotC r => Sem r ()+finishUp = do+  debug "finishing up"+  shards <- P.asks (^. #shards) >>= P.embed . readTVarIO+  for_ shards $ \shard -> void . P.await $ (shard ^. _2)+  debug "bot has stopped"++-- | main loop of the client, handles fetching the next event, processing the event+-- and invoking it's handler functions+clientLoop :: BotC r => Sem r ()+clientLoop = do+  evtQueue <- P.asks (^. #eventQueue)+  void . P.runError . forever $ do+    evt' <- P.embed . atomically $ readTQueue evtQueue+    case evt' of+      DispatchData' evt -> P.raise $ handleEvent evt+      ShutDown          -> P.throw ()+  debug "leaving client loop"++handleEvent :: BotC r => DispatchData -> Sem r ()+handleEvent data' = do+  debug "handling an event"+  eventHandlers <- P.atomicGet+  actions <- P.runFail $ handleEvent' eventHandlers data'+  case actions of+    Right actions -> for_ actions P.async+    Left err      -> debug $ "Failed handling actions for event: " +| err |+ ""++-- NOTE: We have to be careful with how we run event handlers+--       They're registered through `react` which ensures the value of `r` in the event handler+--       is the same as the final value of `r`, but:+--       because they're held inside a 'Dynamic' to prevent the value of `r` being recursive,+--       we have to make sure that we don't accidentally try to execute the event handler inside a+--       nested effect, ie: `P.runError $ {- Handle events here -}` since that will result the value of+--       `r` where we handle events be: `(P.Error a ': r)`, which will make stuff explode when we unwrap the+--       event handlers++unwrapEvent :: forall s r.+            (KnownSymbol s, EHType' s ~ Dynamic, Typeable r, Typeable (EHType s (Sem r)))+            => EventHandlers+            -> [EHType s (Sem r)]+unwrapEvent (EventHandlers eh) = map (fromJust . fromDynamic) . unwrapEventHandler @s . fromJust+  $ (TM.lookup eh :: Maybe (EventHandler s))+-- where unwrapEach handler =+--         let msg = "wanted: " <> show (typeRep $ Proxy @r) <> ", got: " <> show (dynTypeRep handler)+--         in unwrapEvt msg . fromDynamic $ handler++handleEvent' :: BotC r+              => EventHandlers+              -> DispatchData+              -> Sem (P.Fail ': r) [Sem r ()]+handleEvent' eh evt@(Ready rd@ReadyData { user, guilds }) = do+  updateCache evt+  pure $ map ($ rd) (unwrapEvent @"ready" eh)++handleEvent' eh evt@(ChannelCreate (DMChannel' chan)) = do+  updateCache evt+  Just newChan <- DMChannel' <<$>> getDM (getID chan)+  pure $ map ($ newChan) (unwrapEvent @"channelcreate" eh)++handleEvent' eh evt@(ChannelCreate (GuildChannel' chan)) = do+  updateCache evt+  Just guild <- getGuild (getID chan)+  Just newChan <- pure $ GuildChannel' <$> guild ^. #channels . at (getID chan)+  pure $ map ($ newChan) (unwrapEvent @"channelcreate" eh)++handleEvent' eh evt@(ChannelUpdate (DMChannel' chan)) = do+  Just oldChan <- DMChannel' <<$>> getDM (getID chan)+  updateCache evt+  Just newChan <- DMChannel' <<$>> getDM (getID chan)+  pure $ map (\f -> f oldChan newChan) (unwrapEvent @"channelupdate" eh)++handleEvent' eh evt@(ChannelUpdate (GuildChannel' chan)) = do+  Just oldGuild <- getGuild (getID chan)+  Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan)+  updateCache evt+  Just newGuild <- getGuild (getID chan)+  Just newChan <- pure $ GuildChannel' <$> newGuild ^. #channels . at (getID chan)+  pure $ map (\f -> f oldChan newChan) (unwrapEvent @"channelupdate" eh)++handleEvent' eh evt@(ChannelDelete (GuildChannel' chan)) = do+  Just oldGuild <- getGuild (getID chan)+  Just oldChan <- pure $ GuildChannel' <$> oldGuild ^. #channels . at (getID chan)+  updateCache evt+  pure $ map (\f -> f oldChan) (unwrapEvent @"channeldelete" eh)++handleEvent' eh evt@(ChannelDelete (DMChannel' chan)) = do+  Just oldChan <- DMChannel' <<$>> getDM (getID chan)+  updateCache evt+  pure $ map (\f -> f oldChan) (unwrapEvent @"channeldelete" eh)++-- handleEvent' eh evt@(ChannelPinsUpdate ChannelPinsUpdateData { channelID, lastPinTimestamp }) = do+--   chan <- (GuildChannel' <$> os ^? #channels . at (coerceSnowflake channelID) . _Just)+--     <|> (DMChannel' <$> os ^? #dms . at (coerceSnowflake channelID) . _Just)+--   pure $ map (\f -> f chan lastPinTimestamp) (unwrapEvent @"channelpinsupdate" eh)++handleEvent' eh evt@(GuildCreate guild) = do+  isNew <- isUnavailableGuild (getID guild)+  updateCache evt+  Just guild <- getGuild (getID guild)+  pure $ map (\f -> f guild isNew) (unwrapEvent @"guildcreate" eh)++handleEvent' eh evt@(GuildUpdate guild) = do+  Just oldGuild <- getGuild (getID guild)+  updateCache evt+  Just newGuild <- getGuild (getID guild)+  pure $ map (\f -> f oldGuild newGuild) (unwrapEvent @"guildupdate" eh)++-- NOTE: Guild will be deleted in the new cache if unavailable was false+handleEvent' eh evt@(GuildDelete UnavailableGuild { id, unavailable }) = do+  Just oldGuild <- getGuild id+  updateCache evt+  pure $ map (\f -> f oldGuild unavailable) (unwrapEvent @"guilddelete" eh)++handleEvent' eh evt@(GuildBanAdd GuildBanData { guildID, user }) = do+  Just guild <- getGuild guildID+  updateCache evt+  pure $ map (\f -> f guild user) (unwrapEvent @"guildbanadd" eh)++handleEvent' eh evt@(GuildBanRemove GuildBanData { guildID, user }) = do+  Just guild <- getGuild guildID+  updateCache evt+  pure $ map (\f -> f guild user) (unwrapEvent @"guildbanremove" eh)++-- NOTE: we fire this event using the guild data with old emojis+handleEvent' eh evt@(GuildEmojisUpdate GuildEmojisUpdateData { guildID, emojis }) = do+  Just guild <- getGuild guildID+  updateCache evt+  pure $ map (\f -> f guild emojis) (unwrapEvent @"guildemojisupdate" eh)++handleEvent' eh evt@(GuildIntegrationsUpdate GuildIntegrationsUpdateData { guildID }) = do+  updateCache evt+  Just guild <- getGuild guildID+  pure $ map ($ guild) (unwrapEvent @"guildintegrationsupdate" eh)++handleEvent' eh evt@(GuildMemberAdd member) = do+  updateCache evt+  Just guild <- getGuild (getID member)+  Just member <- pure $ guild ^. #members . at (getID member)+  pure $ map ($ member) (unwrapEvent @"guildmemberadd" eh)++handleEvent' eh evt@(GuildMemberRemove GuildMemberRemoveData { user, guildID }) = do+  Just guild <- getGuild guildID+  Just member <- pure $ guild ^. #members . at (getID user)+  updateCache evt+  pure $ map ($ member) (unwrapEvent @"guildmemberremove" eh)++handleEvent' eh evt@(GuildMemberUpdate GuildMemberUpdateData { user, guildID }) = do+  Just oldGuild <- getGuild guildID+  Just oldMember <- pure $ oldGuild ^. #members . at (getID user)+  updateCache evt+  Just newGuild <- getGuild guildID+  Just newMember <- pure $ newGuild ^. #members . at (getID user)+  pure $ map (\f -> f oldMember newMember) (unwrapEvent @"guildmemberupdate" eh)++handleEvent' eh evt@(GuildMembersChunk GuildMembersChunkData { members, guildID }) = do+  updateCache evt+  Just guild <- getGuild guildID+  let members' = guild ^.. #members . foldMap (at . getID) members . _Just+  pure $ map (\f -> f guild members') (unwrapEvent @"guildmemberschunk" eh)++handleEvent' eh evt@(GuildRoleCreate GuildRoleData { guildID, role }) = do+  updateCache evt+  Just guild <- getGuild guildID+  Just role' <- pure $ guild ^. #roles . at (getID role)+  pure $ map (\f -> f guild role') (unwrapEvent @"guildrolecreate" eh)++handleEvent' eh evt@(GuildRoleUpdate GuildRoleData { guildID, role }) = do+  Just oldGuild <- getGuild guildID+  Just oldRole <- pure $ oldGuild ^. #roles . at (getID role)+  updateCache evt+  Just newGuild <- getGuild guildID+  Just newRole <- pure $ newGuild ^. #roles . at (getID role)+  pure $ map (\f -> f newGuild oldRole newRole) (unwrapEvent @"guildroleupdate" eh)++handleEvent' eh evt@(GuildRoleDelete GuildRoleDeleteData { guildID, roleID }) = do+  Just guild <- getGuild guildID+  Just role <- pure $ guild ^. #roles . at roleID+  updateCache evt+  pure $ map (\f -> f guild role) (unwrapEvent @"guildroledelete" eh)++handleEvent' eh evt@(MessageCreate msg) = do+  updateCache evt+  pure $ map ($ msg) (unwrapEvent @"messagecreate" eh)++handleEvent' eh evt@(MessageUpdate msg) = do+  Just oldMsg <- getMessage (getID msg)+  updateCache evt+  Just newMsg <- getMessage (getID msg)+  pure $ map (\f -> f oldMsg newMsg) (unwrapEvent @"messageupdate" eh)++handleEvent' eh evt@(MessageDelete MessageDeleteData { id }) = do+  Just oldMsg <- getMessage id+  updateCache evt+  pure $ map ($ oldMsg) (unwrapEvent @"messagedelete" eh)++handleEvent' eh evt@(MessageDeleteBulk MessageDeleteBulkData { ids }) = do+  messages <- catMaybes <$> mapM getMessage ids+  updateCache evt+  join <$> for messages (\msg -> pure $ map ($ msg) (unwrapEvent @"messagedelete" eh))++handleEvent' eh evt@(MessageReactionAdd reaction) = do+  updateCache evt+  Just msg <- getMessage (getID reaction)+  pure $ map (\f -> f msg reaction) (unwrapEvent @"messagereactionadd" eh)++handleEvent' eh evt@(MessageReactionRemove reaction) = do+  Just msg <- getMessage (getID reaction)+  updateCache evt+  pure $ map (\f -> f msg reaction) (unwrapEvent @"messagereactionremove" eh)++handleEvent' eh evt@(MessageReactionRemoveAll MessageReactionRemoveAllData { messageID }) = do+  Just msg <- getMessage messageID+  updateCache evt+  pure $ map ($ msg) (unwrapEvent @"messagereactionremoveall" eh)++handleEvent' eh evt@(PresenceUpdate PresenceUpdateData { userID, presence = Presence { guildID } }) = do+  Just oldGuild <- getGuild guildID+  Just oldMember <- pure $ oldGuild ^. #members . at (coerceSnowflake userID)+  updateCache evt+  Just newGuild <- getGuild guildID+  Just newMember <- pure $ newGuild ^. #members . at (coerceSnowflake userID)+  let userUpdates = if oldMember ^. #user /= newMember ^. #user+                    then map (\f -> f (oldMember ^. #user) (newMember ^. #user)) (unwrapEvent @"userupdate" eh)+                    else mempty+  pure $ userUpdates <> map (\f -> f oldMember newMember) (unwrapEvent @"guildmemberupdate" eh)++handleEvent' eh (TypingStart TypingStartData { channelID, guildID, userID, timestamp }) =+  case guildID of+    Just gid -> do+      Just guild <- getGuild gid+      Just member <- pure $ guild ^. #members . at (coerceSnowflake userID)+      Just chan <- pure $ GuildChannel' <$> guild ^. #channels . at (coerceSnowflake channelID)+      pure $ map (\f -> f chan (Just member) timestamp) (unwrapEvent @"typingstart" eh)+    Nothing -> do+      Just chan <- DMChannel' <<$>> getDM (coerceSnowflake channelID)+      pure $ map (\f -> f chan Nothing timestamp) (unwrapEvent @"typingstart" eh)++handleEvent' eh evt@(UserUpdate _) = do+  Just oldUser <- getBotUser+  updateCache evt+  Just newUser <- getBotUser+  pure $ map (\f -> f oldUser newUser) (unwrapEvent @"userupdate" eh)++handleEvent' _ e = fail $ "Unhandled event: " <> show e++updateCache :: P.Members '[CacheEff, P.Fail] r => DispatchData -> Sem r ()+updateCache (Ready ReadyData { user, guilds }) = do+  setBotUser user+  for_ (map getID guilds) setUnavailableGuild++updateCache (ChannelCreate (DMChannel' chan)) =+  setDM chan++updateCache (ChannelCreate (GuildChannel' chan)) =+  updateGuild (getID chan) (#channels %~ SM.insert chan)++updateCache (ChannelUpdate (DMChannel' chan)) =+  updateDM (getID chan) (update chan)++updateCache (ChannelUpdate (GuildChannel' chan)) =+  updateGuild (getID chan) (#channels . at (getID chan) . _Just %~ update chan)++updateCache (ChannelDelete (DMChannel' chan)) =+  delDM (getID chan)++updateCache (ChannelDelete (GuildChannel' chan)) =+  updateGuild (getID chan) (#channels %~ sans (getID chan))++updateCache (GuildCreate guild) = do+  isNew <- isUnavailableGuild (getID guild)+  when isNew $ delUnavailableGuild (getID guild)+  setGuild guild+  for_ (SM.fromList (guild ^.. #members . traverse . #user)) setUser++updateCache (GuildUpdate guild) =+  updateGuild (getID guild) (update guild)++updateCache (GuildDelete guild) =+  delGuild (getID guild)++updateCache (GuildEmojisUpdate GuildEmojisUpdateData { guildID, emojis }) =+  updateGuild guildID (#emojis .~ SM.fromList emojis)++updateCache (GuildMemberAdd member) = do+  setUser (member ^. #user)+  updateGuild (getID member) (#members . at (getID member) ?~ member)++updateCache (GuildMemberRemove GuildMemberRemoveData { guildID, user }) =+  updateGuild guildID (#members %~ sans (getID user))++updateCache (GuildMemberUpdate GuildMemberUpdateData { guildID, roles, user, nick }) = do+  setUser user+  updateGuild guildID (#members . at (getID user) . _Just %~ (#roles .~ roles) . (#nick .~ nick))++updateCache (GuildMembersChunk GuildMembersChunkData { members }) =+  traverse_ (updateCache . GuildMemberAdd) members++updateCache (GuildRoleCreate GuildRoleData { guildID, role }) =+  updateGuild guildID (#roles %~ SM.insert role)++updateCache (GuildRoleUpdate GuildRoleData { guildID, role }) =+  updateGuild guildID (#roles %~ SM.insert role)++updateCache (GuildRoleDelete GuildRoleDeleteData { guildID, roleID }) =+  updateGuild guildID (#roles %~ sans roleID)++updateCache (MessageCreate msg) = setMessage msg++updateCache (MessageUpdate msg) =+  updateMessage (getID msg) (update msg)++updateCache (MessageDelete MessageDeleteData { id }) = delMessage id++updateCache (MessageDeleteBulk MessageDeleteBulkData { ids }) =+  for_ ids delMessage++updateCache (MessageReactionAdd reaction) =+  updateMessage (getID reaction) (#reactions %~ cons reaction)++updateCache (MessageReactionRemove reaction) =+  updateMessage (getID reaction) (#reactions %~ filter (\r -> r ^. #emoji /= reaction ^. #emoji))++updateCache (MessageReactionRemoveAll MessageReactionRemoveAllData { messageID }) =+  updateMessage messageID (#reactions .~ mempty)++updateCache (PresenceUpdate PresenceUpdateData { userID, roles, presence }) =+  updateGuild (getID presence) ((#members . at (coerceSnowflake userID) . _Just . #roles .~ roles)+                                . (#presences . at userID ?~ presence))++updateCache (UserUpdate user) = setBotUser user++updateCache _data' = pure () -- TODO
+ src/Calamity/Client/ShardManager.hs view
@@ -0,0 +1,72 @@+-- | Contains stuff for managing shards+module Calamity.Client.ShardManager+    ( shardBot ) where++import           Calamity.Client.Types+import           Calamity.Gateway+import           Calamity.HTTP+import           Calamity.Internal.Utils++import           Control.Concurrent.MVar+import           Control.Concurrent.STM+import           Control.Lens+import           Control.Monad++import           Data.Traversable++import           Fmt++import           Polysemy                    ( Sem )+import qualified Polysemy                    as P+import qualified Polysemy.Reader             as P++aa :: (Show a, Monad m) => Either a b -> m b+aa (Right x) = pure x+aa (Left x) = fail $ show x++-- | Connects the bot to the gateway over n shards+shardBot :: BotC r => Sem r ()+shardBot = do+  numShardsVar <- P.asks numShards+  shardsVar <- P.asks shards++  hasShards <- P.embed $ not . null <$> readTVarIO shardsVar+  when hasShards $ fail "don't use shardBot on an already running bot."++  token <- P.asks Calamity.Client.Types.token+  eventQueue <- P.asks eventQueue++  gateway <- aa =<< invokeRequest GetGatewayBot++  let numShards' = gateway ^. #shards+  let host = gateway ^. #url+  P.embed $ putMVar numShardsVar numShards'++  info $ "Number of shards: " +| numShards' |+ ""++  shards <- for [0 .. numShards' - 1] $ \id ->+    newShard host id numShards' token eventQueue++  P.embed . atomically $ writeTVar shardsVar shards++-- | Connects the bot to the gateway over 1 shard (userbot)+-- shardUserBot :: BotM ()+-- shardUserBot = do+--   numShardsVar <- asks numShards+--   shardsVar <- asks shards++--   hasShards <- liftIO $ (not . null) <$> readTVarIO shardsVar+--   when hasShards $ fail "don't use shardUserBot on an already running bot."++--   token <- asks Calamity.Client.Types.token+--   eventQueue <- asks eventQueue+--   logEnv <- askLog++--   gateway <- aa <$> invokeRequest GetGateway++--   let host = gateway ^. #url+--   liftIO $ putMVar numShardsVar 1++--   liftIO $ do+--     shard <- newShard host 0 1 token logEnv eventQueue+--     atomically $ writeTVar shardsVar [shard]
+ src/Calamity/Client/Types.hs view
@@ -0,0 +1,161 @@+-- | Types for the client+module Calamity.Client.Types+    ( Client(..)+    , BotC+    , EHType+    , EHType'+    , EventHandlers(..)+    , EventHandler(..) ) where++import           Calamity.Cache.Eff+import           Calamity.Gateway.DispatchEvents+import           Calamity.Gateway.Shard+import           Calamity.HTTP.Internal.Types+import           Calamity.LogEff+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild+import           Calamity.Types.Model.User+import           Calamity.Types.Token+import           Calamity.Types.UnixTimestamp++import           Control.Concurrent.Async+import           Control.Concurrent.MVar+import           Control.Concurrent.STM.TQueue+import           Control.Concurrent.STM.TVar++import           Data.Default.Class+import           Data.Dynamic+import           Data.Time+import qualified Data.TypeRepMap                 as TM+import           Data.TypeRepMap                 ( TypeRepMap, WrapTypeable(..) )++import           GHC.Exts                        ( fromList )+import           GHC.Generics+import qualified GHC.TypeLits                    as TL++import qualified Polysemy                        as P+import qualified Polysemy.Async                  as P+import qualified Polysemy.AtomicState            as P+import qualified Polysemy.Reader                 as P++data Client = Client+  { shards        :: TVar [(Shard, Async (Maybe ()))] -- TODO: migrate this to a set of Shard (make Shard hash to it's shardThread)+  , numShards     :: MVar Int+  , token         :: Token+  , rlState       :: RateLimitState+  , eventQueue    :: TQueue DispatchMessage+  }+  deriving ( Generic )++type BotC r = (LogC r, P.Members '[CacheEff, P.Reader Client, P.AtomicState EventHandlers, P.Embed IO, P.Final IO, P.Async] r, Typeable r)++type family EHType d m where+  EHType "ready"                    m = ReadyData                                   -> m ()+  EHType "channelcreate"            m = Channel                                     -> m ()+  EHType "channelupdate"            m = Channel   -> Channel                        -> m ()+  EHType "channeldelete"            m = Channel                                     -> m ()+  EHType "channelpinsupdate"        m = Channel   -> Maybe UTCTime                  -> m ()+  EHType "guildcreate"              m = Guild     -> Bool                           -> m ()+  EHType "guildupdate"              m = Guild     -> Guild                          -> m ()+  EHType "guilddelete"              m = Guild     -> Bool                           -> m ()+  EHType "guildbanadd"              m = Guild     -> User                           -> m ()+  EHType "guildbanremove"           m = Guild     -> User                           -> m ()+  EHType "guildemojisupdate"        m = Guild     -> [Emoji]                        -> m ()+  EHType "guildintegrationsupdate"  m = Guild                                       -> m ()+  EHType "guildmemberadd"           m = Member                                      -> m ()+  EHType "guildmemberremove"        m = Member                                      -> m ()+  EHType "guildmemberupdate"        m = Member    -> Member                         -> m ()+  EHType "guildmemberschunk"        m = Guild     -> [Member]                       -> m ()+  EHType "guildrolecreate"          m = Guild     -> Role                           -> m ()+  EHType "guildroleupdate"          m = Guild     -> Role          -> Role          -> m ()+  EHType "guildroledelete"          m = Guild     -> Role                           -> m ()+  EHType "messagecreate"            m = Message                                     -> m ()+  EHType "messageupdate"            m = Message   -> Message                        -> m ()+  EHType "messagedelete"            m = Message                                     -> m ()+  EHType "messagedeletebulk"        m = [Message]                                   -> m ()+  EHType "messagereactionadd"       m = Message   -> Reaction                       -> m ()+  EHType "messagereactionremove"    m = Message   -> Reaction                       -> m ()+  EHType "messagereactionremoveall" m = Message                                     -> m ()+  EHType "typingstart"              m = Channel   -> Maybe Member  -> UnixTimestamp -> m ()+  EHType "userupdate"               m = User      -> User                           -> m ()+  EHType s _ = TL.TypeError ('TL.Text "Unknown event name: " 'TL.:<>: 'TL.ShowType s)+  -- EHType "voicestateupdate"         = VoiceStateUpdateData -> EventM ()+  -- EHType "voiceserverupdate"        = VoiceServerUpdateData -> EventM ()+  -- EHType "webhooksupdate"           = WebhooksUpdateData -> EventM ()++type family EHType' d where+  EHType' "ready"                    = Dynamic+  EHType' "channelcreate"            = Dynamic+  EHType' "channelupdate"            = Dynamic+  EHType' "channeldelete"            = Dynamic+  EHType' "channelpinsupdate"        = Dynamic+  EHType' "guildcreate"              = Dynamic+  EHType' "guildupdate"              = Dynamic+  EHType' "guilddelete"              = Dynamic+  EHType' "guildbanadd"              = Dynamic+  EHType' "guildbanremove"           = Dynamic+  EHType' "guildemojisupdate"        = Dynamic+  EHType' "guildintegrationsupdate"  = Dynamic+  EHType' "guildmemberadd"           = Dynamic+  EHType' "guildmemberremove"        = Dynamic+  EHType' "guildmemberupdate"        = Dynamic+  EHType' "guildmemberschunk"        = Dynamic+  EHType' "guildrolecreate"          = Dynamic+  EHType' "guildroleupdate"          = Dynamic+  EHType' "guildroledelete"          = Dynamic+  EHType' "messagecreate"            = Dynamic+  EHType' "messageupdate"            = Dynamic+  EHType' "messagedelete"            = Dynamic+  EHType' "messagedeletebulk"        = Dynamic+  EHType' "messagereactionadd"       = Dynamic+  EHType' "messagereactionremove"    = Dynamic+  EHType' "messagereactionremoveall" = Dynamic+  EHType' "typingstart"              = Dynamic+  EHType' "userupdate"               = Dynamic+  EHType' s = TL.TypeError ('TL.Text "Unknown event name: " 'TL.:<>: 'TL.ShowType s)++newtype EventHandlers = EventHandlers (TypeRepMap EventHandler)++newtype EventHandler d = EH+  { unwrapEventHandler :: [EHType' d]+  }+  deriving newtype ( Semigroup, Monoid )++instance Default EventHandlers where+  def = EventHandlers $ fromList [ WrapTypeable $ EH @"ready" []+                                 , WrapTypeable $ EH @"channelcreate" []+                                 , WrapTypeable $ EH @"channelupdate" []+                                 , WrapTypeable $ EH @"channeldelete" []+                                 , WrapTypeable $ EH @"channelpinsupdate" []+                                 , WrapTypeable $ EH @"guildcreate" []+                                 , WrapTypeable $ EH @"guildupdate" []+                                 , WrapTypeable $ EH @"guilddelete" []+                                 , WrapTypeable $ EH @"guildbanadd" []+                                 , WrapTypeable $ EH @"guildbanremove" []+                                 , WrapTypeable $ EH @"guildemojisupdate" []+                                 , WrapTypeable $ EH @"guildintegrationsupdate" []+                                 , WrapTypeable $ EH @"guildmemberadd" []+                                 , WrapTypeable $ EH @"guildmemberremove" []+                                 , WrapTypeable $ EH @"guildmemberupdate" []+                                 , WrapTypeable $ EH @"guildrolecreate" []+                                 , WrapTypeable $ EH @"guildroleupdate" []+                                 , WrapTypeable $ EH @"guildroledelete" []+                                 , WrapTypeable $ EH @"messagecreate" []+                                 , WrapTypeable $ EH @"messageupdate" []+                                 , WrapTypeable $ EH @"messagedelete" []+                                 , WrapTypeable $ EH @"messagedeletebulk" []+                                 , WrapTypeable $ EH @"messagereactionadd" []+                                 , WrapTypeable $ EH @"messagereactionremove" []+                                 , WrapTypeable $ EH @"messagereactionremoveall" []+                                 , WrapTypeable $ EH @"typingstart" []+                                 , WrapTypeable $ EH @"userupdate" []+                                 -- , WrapTypeable $ EH m @"voicestateupdate" []+                                 -- , WrapTypeable $ EH m @"voiceserverupdate" []+                                 -- , WrapTypeable $ EH m @"webhooksupdate" []+                                 ]++instance Semigroup EventHandlers where+  (EventHandlers a) <> (EventHandlers b) = EventHandlers $ TM.unionWith (<>) a b++instance Monoid EventHandlers where+  mempty = def
+ src/Calamity/Gateway.hs view
@@ -0,0 +1,7 @@+-- |+module Calamity.Gateway+    ( module Calamity.Gateway.Shard+    , module Calamity.Gateway.Types ) where++import           Calamity.Gateway.Shard+import           Calamity.Gateway.Types
+ src/Calamity/Gateway/DispatchEvents.hs view
@@ -0,0 +1,204 @@+-- | module containing all dispatch events+module Calamity.Gateway.DispatchEvents where++import           Calamity.Internal.AesonThings+import           Calamity.Internal.Utils                     ()+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Channel.Message+import           Calamity.Types.Model.Guild.Emoji+import           Calamity.Types.Model.Guild.Guild+import           Calamity.Types.Model.Guild.Member+import           Calamity.Types.Model.Guild.Role+import           Calamity.Types.Model.Guild.UnavailableGuild+import           Calamity.Types.Model.Presence.Presence+import           Calamity.Types.Model.User+import           Calamity.Types.Snowflake+import           Calamity.Types.UnixTimestamp++import           Data.Aeson+import           Data.Text.Lazy                              ( Text )+import           Data.Time+import           Data.Vector.Unboxed                         ( Vector )++import           GHC.Generics++data DispatchMessage+  = DispatchData' DispatchData+  | ShutDown+  deriving ( Show, Generic )++data DispatchData+  = Ready ReadyData+  | ChannelCreate Channel+  | ChannelUpdate Channel+  | ChannelDelete Channel+  | ChannelPinsUpdate ChannelPinsUpdateData+  | GuildCreate Guild+  | GuildUpdate UpdatedGuild+  | GuildDelete UnavailableGuild+  | GuildBanAdd GuildBanData+  | GuildBanRemove GuildBanData+  | GuildEmojisUpdate GuildEmojisUpdateData+  | GuildIntegrationsUpdate GuildIntegrationsUpdateData+  | GuildMemberAdd Member+  | GuildMemberRemove GuildMemberRemoveData+  | GuildMemberUpdate GuildMemberUpdateData+  | GuildMembersChunk GuildMembersChunkData+  | GuildRoleCreate GuildRoleData+  | GuildRoleUpdate GuildRoleData+  | GuildRoleDelete GuildRoleDeleteData+  | MessageCreate Message+  | 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 )++data ReadyData = ReadyData+  { v         :: Integer+  , user      :: User+  , guilds    :: [UnavailableGuild]+  , sessionID :: Text+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON ReadyData++data ChannelPinsUpdateData = ChannelPinsUpdateData+  { channelID        :: Snowflake Channel+  , lastPinTimestamp :: Maybe UTCTime+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON ChannelPinsUpdateData++data GuildBanData = GuildBanData+  { guildID :: Snowflake Guild+  , user    :: User+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON GuildBanData++data GuildEmojisUpdateData = GuildEmojisUpdateData+  { guildID :: Snowflake Guild+  , emojis  :: [Emoji]+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON GuildEmojisUpdateData++newtype GuildIntegrationsUpdateData = GuildIntegrationsUpdateData+  { guildID :: Snowflake Guild+  }+  deriving newtype ( Show, Generic )+  deriving FromJSON via CalamityJSON GuildIntegrationsUpdateData++data GuildMemberRemoveData = GuildMemberRemoveData+  { guildID :: Snowflake Guild+  , user    :: User+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON GuildMemberRemoveData++data GuildMemberUpdateData = GuildMemberUpdateData+  { guildID :: Snowflake Guild+  , roles   :: Vector (Snowflake Role)+  , user    :: User+  , nick    :: Maybe Text+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON GuildMemberUpdateData++data GuildMembersChunkData = GuildMembersChunkData+  { guildID :: Snowflake Guild+  , members :: [Member]+  }+  deriving ( Show, Generic )++instance FromJSON GuildMembersChunkData where+  parseJSON = withObject "GuildMembersChunkData" $ \v -> do+    guildID <- v .: "guild_id"++    members' <- do+      members' <- v .: "members"+      traverse (\m -> parseJSON $ Object (m <> "guild_id" .= guildID)) members'++    pure $ GuildMembersChunkData guildID members'++data GuildRoleData = GuildRoleData+  { guildID :: Snowflake Guild+  , role    :: Role+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON GuildRoleData++data GuildRoleDeleteData = GuildRoleDeleteData+  { guildID :: Snowflake Guild+  , roleID  :: Snowflake Role+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON GuildRoleDeleteData++data MessageDeleteData = MessageDeleteData+  { id        :: Snowflake Message+  , channelID :: Snowflake Channel+  , guildID   :: Snowflake Guild+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON MessageDeleteData++data MessageDeleteBulkData = MessageDeleteBulkData+  { guildID   :: Snowflake Guild+  , channelID :: Snowflake Channel+  , ids       :: [Snowflake Message]+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON MessageDeleteBulkData++data MessageReactionRemoveAllData = MessageReactionRemoveAllData+  { channelID :: Snowflake Channel+  , messageID :: Snowflake Message+  , guildID   :: Maybe (Snowflake Guild)+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON MessageReactionRemoveAllData++data PresenceUpdateData = PresenceUpdateData+  { userID   :: Snowflake User+  , roles    :: Vector (Snowflake Role)+  , presence :: Presence+  }+  deriving ( Show, Generic )++instance FromJSON PresenceUpdateData where+  parseJSON = withObject "PresenceUpdate" $ \v -> do+    user <- (v .: "user") >>= (.: "id")+    roles <- v .: "roles"+    presence <- parseJSON $ Object v+    pure $ PresenceUpdateData user roles presence++data TypingStartData = TypingStartData+  { channelID :: Snowflake Channel+  , guildID   :: Maybe (Snowflake Guild)+  , userID    :: Snowflake User+  , timestamp :: UnixTimestamp+  }+  deriving ( Show, Generic )+  deriving FromJSON via CalamityJSON TypingStartData++newtype VoiceStateUpdateData = VoiceStateUpdateData Value+  deriving newtype ( Show, Generic )+  deriving newtype ( ToJSON, FromJSON )++newtype VoiceServerUpdateData = VoiceServerUpdateData Value+  deriving newtype ( Show, Generic )+  deriving newtype ( ToJSON, FromJSON )++newtype WebhooksUpdateData = WebhooksUpdateData Value+  deriving newtype ( Show, Generic )+  deriving newtype ( ToJSON, FromJSON )
+ src/Calamity/Gateway/Shard.hs view
@@ -0,0 +1,330 @@+-- | The shard logic+{-# LANGUAGE RecursiveDo #-}+{-# LANGUAGE TemplateHaskell #-}++module Calamity.Gateway.Shard+    ( Shard(..)+    , newShard ) where++import           Calamity.Gateway.DispatchEvents+import           Calamity.Gateway.Types+import           Calamity.Internal.Utils+import           Calamity.LogEff+import           Calamity.Types.Token++import           Control.Concurrent+import           Control.Concurrent.Async+import           Control.Concurrent.STM+import           Control.Concurrent.STM.TBMQueue+import           Control.Exception+import           Control.Lens+import           Control.Monad+import           Control.Monad.State.Lazy++import qualified Data.Aeson                      as A+import           Data.Functor+import           Data.Maybe+import           Data.Text.Lazy                  ( Text, stripPrefix )+import           Data.Text.Lazy.Lens+import           Data.Void++import           DiPolysemy                      hiding ( debug, error, info )++import           Fmt++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           Prelude                         hiding ( error )++import           Wuss++data Websocket m a where+  RunWebsocket :: Text -> Text -> (Connection -> m a) -> Websocket m a++P.makeSem ''Websocket++websocketToIO :: forall r a. P.Member (P.Embed IO) r => Sem (Websocket ': r) a -> Sem r a+websocketToIO = P.interpretH+  (\case+     RunWebsocket host path a -> do+       istate <- P.getInitialStateT+       ma <- P.bindT a++       P.withLowerToIO $ \lower finish -> do+         let done :: Sem (Websocket ': r) x -> IO x+             done = lower . P.raise . websocketToIO++         runSecureClient (host ^. unpacked) 443 (path ^. unpacked)+           (\x -> do+              res <- done (ma $ istate $> x)+              finish+              pure res))++newShardState :: Shard -> ShardState+newShardState shard = ShardState shard Nothing Nothing False Nothing Nothing Nothing++-- | Creates and launches a shard+newShard :: P.Members '[LogEff, P.Embed IO, P.Final IO, P.Async] r+         => Text+         -> Int+         -> Int+         -> Token+         -> TQueue DispatchMessage+         -> Sem r (Shard, Async (Maybe ()))+newShard gateway id count token evtQueue = do+  (shard, stateVar) <- P.embed $ mdo+    cmdQueue' <- newTQueueIO+    stateVar <- newTVarIO (newShardState shard)+    let shard = Shard id count gateway evtQueue cmdQueue' stateVar (rawToken token)+    pure (shard, stateVar)++  let runShard = P.runAtomicStateTVar stateVar shardLoop+  let action = attr "shard-id" id . push "calamity-shard" $ runShard++  thread' <- P.async action++  pure (shard, thread')++sendToWs :: ShardC r => SentDiscordMessage -> Sem r ()+sendToWs data' = do+  wsConn' <- P.atomicGets wsConn+  case wsConn' of+    Just wsConn -> do+      let encodedData = A.encode data'+      debug $ "sending " +|| data' ||+ " encoded to " +|| encodedData ||+ " to gateway"+      P.embed . sendTextData wsConn $ encodedData+    Nothing -> debug "tried to send to closed WS"++fromEitherVoid :: Either a Void -> a+fromEitherVoid (Left a) = a+fromEitherVoid (Right a) = absurd a -- yeet++-- | Catches ws close events and decides if we can restart or not+checkWSClose :: IO a -> IO (Either ControlMessage a)+checkWSClose m = (Right <$> m) `catch` \case+  e@(CloseRequest code _) -> do+    print e+    if code `elem` [1000, 4004, 4010, 4011]+      then pure . Left $ ShutDownShard+      else pure . Left $ RestartShard++  e                       -> throwIO e++tryWriteTBMQueue' :: TBMQueue a -> a -> STM Bool+tryWriteTBMQueue' q v = do+  v' <- tryWriteTBMQueue q v+  case v' of+    Just False -> retry+    Just True  -> pure True+    Nothing    -> pure False++-- | The loop a shard will run on+shardLoop :: ShardC r => Sem r ()+shardLoop = do+  void outerloop+  debug "Shard shut down"+ where+  controlStream :: Shard -> TBMQueue ShardMsg -> IO ()+  controlStream shard outqueue = inner+    where+      q = shard ^. #cmdQueue+      inner = do+        v <- atomically $ readTQueue q+        r <- atomically $ tryWriteTBMQueue' outqueue (Control v)+        when r inner++  discordStream :: P.Members '[LogEff, P.Embed IO] r => Connection -> TBMQueue ShardMsg -> Sem r ()+  discordStream ws outqueue = inner+    where inner = do+            msg <- P.embed . checkWSClose $ receiveData ws++            -- trace $ "Received from stream: "+||msg||+""++            case msg of+              Left c ->+                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++  -- mergedStream ::  Log -> Shard -> Connection -> ExceptT ShardException ShardM ShardMsg+  -- mergedStream logEnv shard ws =+  --   liftIO (fromEither <$> race (controlStream shard) (discordStream logEnv ws))++  -- | The outer loop, sets up the ws conn, etc handles reconnecting and such+  -- Currently if this goes to the error path we just exit the forever loop+  -- and the shard stops, maybe we might want to do some extra logic to reboot+  -- the shard, or maybe force a resharding+  outerloop :: ShardC r => Sem r (Either ShardException ())+  outerloop = P.runError . forever $ do+    shard :: Shard <- P.atomicGets (^. #shardS)+    let host = shard ^. #gateway+    let host' =  fromMaybe host $ stripPrefix "wss://" host+    info $ "starting up shard "+| (shard ^. #shardID) |+" of "+| (shard ^. #shardCount) |+""+++    innerLoopVal <- websocketToIO $ runWebsocket host' "/?v=7&encoding=json" innerloop++    case innerLoopVal of+      ShardExcShutDown -> do+        info "Shutting down shard"+        P.throw ShardExcShutDown++      ShardExcRestart ->+        info "Restaring shard"+        -- we restart normally when we loop++  -- | 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 ShardException+  innerloop ws = do+    debug "Entering inner loop of shard"++    shard <- P.atomicGets (^. #shardS)+    P.atomicModify (#wsConn ?~ ws)++    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+                  })+      _ -> 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 = Nothing+                  })++    result <- P.runResource $ P.bracket (P.embed $ newTBMQueueIO 1)+      (\q -> P.embed . atomically $ closeTBMQueue q)+      (\q -> do+        debug "handling events now"+        _controlThread <- P.async . P.embed $ controlStream shard q+        _discordThread <- P.async $ discordStream ws q+        (fromEitherVoid <$>) . P.raise . P.runError . forever $ do+          -- only we close the queue+          msg <- P.embed . atomically $ readTBMQueue q+          handleMsg $ fromJust 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 ShardException) r) => ShardMsg -> Sem r ()+  handleMsg (Discord msg) = case msg of+    Dispatch sn data' -> do+      -- trace $ "Handling event: ("+||data'||+")"+      P.atomicModify (#seqNum ?~ sn)++      case data' of+        Ready rdata' ->+          P.atomicModify (#sessionID ?~ (rdata' ^. #sessionID))++        _ -> pure ()++      shard <- P.atomicGets (^. #shardS)+      P.embed . atomically $ writeTQueue (shard ^. #evtQueue) (DispatchData' data')+      -- sn' <- P.atomicGets (^. #seqNum)+      -- trace $ "Done handling event, seq is now: "+||sn'||+""++    HeartBeatReq -> do+      debug "Received heartbeat request"+      sendHeartBeat++    Reconnect -> do+      debug "Being asked to restart by Discord"+      P.throw ShardExcRestart++    InvalidSession resumable -> do+      if resumable+      then 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)+      else+        info "Received resumable invalid session"+      P.throw ShardExcRestart++    Hello interval -> do+      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'||+")"+      sendToWs $ StatusUpdate data'++    RestartShard       -> P.throw ShardExcRestart+    ShutDownShard      -> P.throw ShardExcShutDown++startHeartBeatLoop :: ShardC r => Int -> Sem r ()+startHeartBeatLoop interval = do+  haltHeartBeat -- cancel any currently running hb thread+  thread <- P.async $ heartBeatLoop interval+  P.atomicModify (#hbThread ?~ thread)++haltHeartBeat :: ShardC r => Sem r ()+haltHeartBeat = do+  thread <- P.atomicState @ShardState . (swap .) . runState $ do+    thread <- use #hbThread+    #hbThread .= Nothing+    pure thread+  case thread of+    Just t  -> do+      debug "Stopping heartbeat thread"+      P.embed (void $ cancel t)+    Nothing -> pure ()++sendHeartBeat :: ShardC r => Sem r ()+sendHeartBeat = do+  sn <- P.atomicGets (^. #seqNum)+  debug $ "Sending heartbeat (seq: " +|| sn ||+ ")"+  sendToWs $ HeartBeat sn+  P.atomicModify (#hbResponse .~ False)++heartBeatLoop :: ShardC r => Int -> Sem r ()+heartBeatLoop interval = void . P.runError . forever $ do+  sendHeartBeat+  P.embed . threadDelay $ interval * 1000+  unlessM (P.atomicGets (^. #hbResponse)) $ do+    debug "No heartbeat response, restarting shard"+    wsConn <- fromJust <$> P.atomicGets (^. #wsConn)+    P.embed $ sendCloseCode wsConn 4000 ("No heartbeat in time" :: Text)+    P.throw ()
+ src/Calamity/Gateway/Types.hs view
@@ -0,0 +1,247 @@+{-# OPTIONS_GHC -Wno-orphans #-}++-- | Types for shards+module Calamity.Gateway.Types where++import           Calamity.Gateway.DispatchEvents+import           Calamity.Internal.AesonThings+import           Calamity.LogEff+import           Calamity.Types.Model.Guild.Guild+import           Calamity.Types.Model.Voice+import           Calamity.Types.Snowflake++import           Control.Concurrent.Async+import           Control.Concurrent.STM.TQueue+import           Control.Concurrent.STM.TVar+import           Control.Exception+import           Control.Monad                    ( fail )++import           Data.Aeson+import qualified Data.Aeson.Types                 as AT+import           Data.Generics.Labels             ()+import           Data.Maybe+import           Data.Text.Lazy                   ( Text )++import           GHC.Generics++import           Network.WebSockets.Connection    ( Connection )++import qualified Polysemy                         as P+import qualified Polysemy.Async                   as P+import qualified Polysemy.AtomicState             as P++data ShardMsg+  = Discord ReceivedDiscordMessage+  | Control ControlMessage+  deriving ( Show, Generic )++data ReceivedDiscordMessage+  = Dispatch Int !DispatchData+  | HeartBeatReq+  | Reconnect+  | InvalidSession Bool+  | Hello Int+  | HeartBeatAck+  deriving ( Show, Generic )++instance FromJSON ReceivedDiscordMessage where+  parseJSON = withObject "ReceivedDiscordMessage" $ \v -> do+    op :: Int <- v .: "op"+    case op of+      0  -> do+        d <- v .: "d"+        t <- v .: "t"+        s <- v .: "s"+        Dispatch s <$> parseDispatchData t d++      1  -> pure HeartBeatReq++      7  -> pure Reconnect++      9  -> InvalidSession <$> v .: "d"++      10 -> Hello <$> do+        d <- v .: "d"+        d .: "heartbeat_interval"++      11 -> pure HeartBeatAck++      _  -> fail $ "invalid opcode: " <> show op++parseDispatchData :: DispatchType -> Value -> AT.Parser DispatchData+parseDispatchData READY data' = Ready <$> parseJSON data'+parseDispatchData CHANNEL_CREATE data' = ChannelCreate <$> parseJSON data'+parseDispatchData CHANNEL_UPDATE data' = ChannelUpdate <$> parseJSON data'+parseDispatchData CHANNEL_DELETE data' = ChannelDelete <$> parseJSON data'+parseDispatchData CHANNEL_PINS_UPDATE data' = ChannelPinsUpdate <$> parseJSON data'+parseDispatchData GUILD_CREATE data' = GuildCreate <$> parseJSON data'+parseDispatchData GUILD_UPDATE data' = GuildUpdate <$> parseJSON data'+parseDispatchData GUILD_DELETE data' = GuildDelete <$> parseJSON data'+parseDispatchData GUILD_BAN_ADD data' = GuildBanAdd <$> parseJSON data'+parseDispatchData GUILD_BAN_REMOVE data' = GuildBanRemove <$> parseJSON data'+parseDispatchData GUILD_EMOJIS_UPDATE data' = GuildEmojisUpdate <$> parseJSON data'+parseDispatchData GUILD_INTEGRATIONS_UPDATE data' = GuildIntegrationsUpdate <$> parseJSON data'+parseDispatchData GUILD_MEMBER_ADD data' = GuildMemberAdd <$> parseJSON data'+parseDispatchData GUILD_MEMBER_REMOVE data' = GuildMemberRemove <$> parseJSON data'+parseDispatchData GUILD_MEMBER_UPDATE data' = GuildMemberUpdate <$> parseJSON data'+parseDispatchData GUILD_MEMBERS_CHUNK data' = GuildMembersChunk <$> parseJSON data'+parseDispatchData GUILD_ROLE_CREATE data' = GuildRoleCreate <$> parseJSON data'+parseDispatchData GUILD_ROLE_UPDATE data' = GuildRoleUpdate <$> parseJSON data'+parseDispatchData GUILD_ROLE_DELETE data' = GuildRoleDelete <$> parseJSON data'+parseDispatchData MESSAGE_CREATE data' = MessageCreate <$> parseJSON data'+parseDispatchData MESSAGE_UPDATE data' = MessageUpdate <$> parseJSON data'+parseDispatchData MESSAGE_DELETE data' = MessageDelete <$> parseJSON data'+parseDispatchData MESSAGE_DELETE_BULK data' = MessageDeleteBulk <$> parseJSON data'+parseDispatchData MESSAGE_REACTION_ADD data' = MessageReactionAdd <$> parseJSON data'+parseDispatchData MESSAGE_REACTION_REMOVE data' = MessageReactionRemove <$> parseJSON data'+parseDispatchData MESSAGE_REACTION_REMOVE_ALL data' = MessageReactionRemoveAll <$> parseJSON data'+parseDispatchData PRESENCE_UPDATE data' = PresenceUpdate <$> parseJSON data'+parseDispatchData TYPING_START data' = TypingStart <$> parseJSON data'+parseDispatchData USER_UPDATE data' = UserUpdate <$> parseJSON data'+parseDispatchData VOICE_STATE_UPDATE data' = VoiceStateUpdate <$> parseJSON data'+parseDispatchData VOICE_SERVER_UPDATE data' = VoiceServerUpdate <$> parseJSON data'+parseDispatchData WEBHOOKS_UPDATE data' = WebhooksUpdate <$> parseJSON data'++data SentDiscordMessage+  = StatusUpdate StatusUpdateData+  | Identify IdentifyData+  | HeartBeat (Maybe Int)+  | VoiceStatusUpdate VoiceState+  | Resume ResumeData+  | RequestGuildMembers RequestGuildMembersData+  deriving ( Show, Generic )++instance ToJSON SentDiscordMessage where+  toEncoding (HeartBeat data') = pairs ("op" .= (1 :: Int) <> "d" .= data')++  toEncoding (Identify data') = pairs ("op" .= (2 :: Int) <> "d" .= data')++  toEncoding (StatusUpdate data') = pairs ("op" .= (3 :: Int) <> "d" .= data')++  toEncoding (VoiceStatusUpdate data') = pairs ("op" .= (4 :: Int) <> "d" .= data')++  toEncoding (Resume data') = pairs ("op" .= (6 :: Int) <> "d" .= data')++  toEncoding (RequestGuildMembers data') = pairs ("op" .= (8 :: Int) <> "d" .= data')++-- Thanks sbrg:+-- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs+data DispatchType+  = READY+  | CHANNEL_CREATE+  | CHANNEL_UPDATE+  | CHANNEL_DELETE+  | CHANNEL_PINS_UPDATE+  | GUILD_CREATE+  | GUILD_UPDATE+  | GUILD_DELETE+  | GUILD_BAN_ADD+  | GUILD_BAN_REMOVE+  | GUILD_EMOJIS_UPDATE+  | GUILD_INTEGRATIONS_UPDATE+  | GUILD_MEMBER_ADD+  | GUILD_MEMBER_REMOVE+  | GUILD_MEMBER_UPDATE+  | GUILD_MEMBERS_CHUNK+  | GUILD_ROLE_CREATE+  | GUILD_ROLE_UPDATE+  | GUILD_ROLE_DELETE+  | MESSAGE_CREATE+  | MESSAGE_UPDATE+  | MESSAGE_DELETE+  | MESSAGE_DELETE_BULK+  | MESSAGE_REACTION_ADD+  | MESSAGE_REACTION_REMOVE+  | MESSAGE_REACTION_REMOVE_ALL+  | PRESENCE_UPDATE+  | TYPING_START+  | USER_UPDATE+  | VOICE_STATE_UPDATE+  | VOICE_SERVER_UPDATE+  | WEBHOOKS_UPDATE+  deriving ( Show, Eq, Enum, Generic )+  deriving anyclass ( ToJSON, FromJSON )++data IdentifyData = IdentifyData+  { token          :: Text+  , properties     :: IdentifyProps+  , compress       :: Bool+  , largeThreshold :: Int+  , shard          :: (Int, Int)+  , presence       :: Maybe StatusUpdateData+  }+  deriving ( Show, Generic )+  deriving ToJSON via CalamityJSON IdentifyData++data StatusUpdateData = StatusUpdateData+  { since  :: Maybe Integer+  , game   :: Maybe Value+  , status :: Text+  , afk    :: Bool+  }+  deriving ( Show, Generic )+  deriving ToJSON via CalamityJSON StatusUpdateData++data ResumeData = ResumeData+  { token     :: Text+  , sessionID :: Text+  , seq       :: Int+  }+  deriving ( Show, Generic )+  deriving ( ToJSON, FromJSON ) via CalamityJSON ResumeData++data RequestGuildMembersData = RequestGuildMembersData+  { guildID :: Snowflake Guild+  , query   :: Maybe Text+  , limit   :: Maybe Int+  }+  deriving ( Show, Generic )++instance ToJSON RequestGuildMembersData where+  toEncoding RequestGuildMembersData { guildID, query, limit } = pairs+    ("guild_id" .= guildID <> "query" .= fromMaybe "" query <> "limit" .= fromMaybe 0 limit)++data IdentifyProps = IdentifyProps+  { browser :: Text+  , device  :: Text+  }+  deriving ( Show, Generic )++instance ToJSON IdentifyProps where+  toEncoding IdentifyProps { browser, device } = pairs ("$browser" .= browser <> "$device" .= device)++data ControlMessage+  = RestartShard+  | ShutDownShard+  | SendPresence StatusUpdateData+  deriving ( Show )++data ShardException+  = ShardExcRestart+  | ShardExcShutDown+  deriving ( Show )+  deriving anyclass Exception++data Shard = Shard+  { shardID     :: Int+  , shardCount  :: Int+  , gateway     :: Text+  , evtQueue    :: TQueue DispatchMessage+  , cmdQueue    :: TQueue ControlMessage+  , shardState  :: TVar ShardState+  , token       :: Text+  }+  deriving ( Generic )++data ShardState = ShardState+  { shardS     :: Shard+  , seqNum     :: Maybe Int+  , hbThread   :: Maybe (Async (Maybe ()))+  , hbResponse :: Bool+  , wsHost     :: Maybe Text+  , sessionID  :: Maybe Text+  , wsConn     :: Maybe Connection+  }+  deriving ( Generic )++type ShardC r = (LogC r, P.Members '[P.AtomicState ShardState, P.Embed IO, P.Final IO, P.Async] r)
+ src/Calamity/HTTP.hs view
@@ -0,0 +1,13 @@+-- | Combined http request stuff+module Calamity.HTTP+    ( module Calamity.HTTP.Internal.Request+    , module Calamity.HTTP.Channel+    , module Calamity.HTTP.Emoji+    , module Calamity.HTTP.Guild+    , module Calamity.HTTP.MiscRoutes ) where++import           Calamity.HTTP.Channel+import           Calamity.HTTP.Emoji+import           Calamity.HTTP.Guild+import           Calamity.HTTP.Internal.Request ( invokeRequest )+import           Calamity.HTTP.MiscRoutes
+ src/Calamity/HTTP/Channel.hs view
@@ -0,0 +1,215 @@+-- | Channel endpoints+module Calamity.HTTP.Channel+    ( ChannelUpdate(..)+    , ChannelMessagesQuery(..)+    , ChannelRequest(..)+    , GetReactionsOptions(..)+    , CreateChannelInviteOptions(..)+    , GroupDMAddRecipientOptions(..) ) where++import           Calamity.HTTP.Internal.Request+import           Calamity.HTTP.Internal.Route+import           Calamity.Internal.AesonThings+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild+import           Calamity.Types.Model.Guild.Overwrite+import           Calamity.Types.Model.User+import           Calamity.Types.Snowflake++import           Control.Arrow+import           Control.Lens                         hiding ( (.=) )++import           Data.Aeson+import           Data.Default.Class+import           Data.Maybe+import           Data.Text                            ( Text )++import           GHC.Generics++import           Network.Wreq++import           TextShow++data ChannelUpdate = ChannelUpdate+  { name                 :: Maybe Text+  , position             :: Maybe Int+  , topic                :: Maybe Text+  , nsfw                 :: Maybe Bool+  , rateLimitPerUser     :: Maybe Int+  , bitrate              :: Maybe Int+  , userLimit            :: Maybe Int+  , permissionOverwrites :: Maybe [Overwrite]+  , parentID             :: Maybe (Snowflake Channel)+  }+  deriving ( Generic, Show )+  deriving anyclass ( Default )+  deriving ( ToJSON ) via CalamityJSON ChannelUpdate++data ChannelMessagesQuery+  = ChannelMessagesAround+      { around :: Snowflake Message+      }+  | ChannelMessagesBefore+      { before :: Snowflake Message+      }+  | ChannelMessagesAfter+      { after :: Snowflake Message+      }+  | ChannelMessagesLimit+      { limit :: Int+      }+  deriving ( Generic, Show )+  deriving ( ToJSON ) via CalamityJSON ChannelMessagesQuery++data GetReactionsOptions = GetReactionsOptions+  { before :: Maybe (Snowflake User)+  , after  :: Maybe (Snowflake User)+  , limit  :: Maybe Integer+  }+  deriving ( Show )++data CreateChannelInviteOptions = CreateChannelInviteOptions+  { maxAge    :: Maybe Int+  , maxUses   :: Maybe Int+  , temporary :: Maybe Bool+  , unique    :: Maybe Bool+  }+  deriving ( Show, Generic )+  deriving ( ToJSON ) via CalamityJSON CreateChannelInviteOptions++data GroupDMAddRecipientOptions = GroupDMAddRecipientOptions+  { accessToken :: Text+  , nick        :: Text+  }+  deriving ( Show, Generic )+  deriving ( ToJSON ) via CalamityJSON GroupDMAddRecipientOptions++data ChannelRequest a where+  CreateMessage            :: (HasID Channel c) => c -> Text -> ChannelRequest Message+  GetMessage               :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest Message+  EditMessage              :: (HasID Channel c, HasID Message m) => c -> m -> Maybe Text -> Maybe Embed -> ChannelRequest Message+  DeleteMessage            :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest ()+  BulkDeleteMessages       :: (HasID Channel c, HasID Message m) => c -> [m] -> ChannelRequest ()+  GetChannel               :: (HasID Channel c) => c -> ChannelRequest Channel+  ModifyChannel            :: (HasID Channel c) => c -> ChannelUpdate -> ChannelRequest Channel+  DeleteChannel            :: (HasID Channel c) => c -> ChannelRequest ()+  GetChannelMessages       :: (HasID Channel c) => c -> Maybe ChannelMessagesQuery -> ChannelRequest [Message]+  CreateReaction           :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> ChannelRequest ()+  DeleteOwnReaction        :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> ChannelRequest ()+  DeleteUserReaction       :: (HasID Channel c, HasID Message m, HasID User u) => c -> m -> RawEmoji -> u -> ChannelRequest ()+  GetReactions             :: (HasID Channel c, HasID Message m) => c -> m -> RawEmoji -> GetReactionsOptions -> ChannelRequest [User]+  DeleteAllReactions       :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest ()+  GetChannelInvites        :: (HasID Channel c) => c -> ChannelRequest [Invite]+  CreateChannelInvite      :: (HasID Channel c) => c -> CreateChannelInviteOptions -> ChannelRequest Invite+  EditChannelPermissions   :: (HasID Channel c) => c -> Overwrite -> ChannelRequest ()+  DeleteChannelPermission  :: (HasID Channel c, HasID Overwrite o) => c -> o -> ChannelRequest ()+  TriggerTyping            :: (HasID Channel c) => c -> ChannelRequest ()+  GetPinnedMessages        :: (HasID Channel c) => c -> ChannelRequest [Message]+  AddPinnedMessage         :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest ()+  DeletePinnedMessage      :: (HasID Channel c, HasID Message m) => c -> m -> ChannelRequest ()+  GroupDMAddRecipient      :: (HasID Channel c, HasID User u) => c -> u -> GroupDMAddRecipientOptions -> ChannelRequest ()+  GroupDMRemoveRecipient   :: (HasID Channel c, HasID User u) => c -> u -> ChannelRequest ()+++baseRoute :: Snowflake Channel -> RouteBuilder _+baseRoute id = mkRouteBuilder // S "channels" // ID @Channel+  & giveID id++instance Request (ChannelRequest a) a where+  toRoute (CreateMessage (getID -> id) _)      = baseRoute id // S "messages" & buildRoute+  toRoute (GetChannel    (getID -> id))        = baseRoute id                 & buildRoute+  toRoute (ModifyChannel (getID -> id) _)      = baseRoute id                 & buildRoute+  toRoute (DeleteChannel (getID -> id))        = baseRoute id                 & buildRoute+  toRoute (GetChannelMessages (getID -> id) _) = baseRoute id // S "messages" & buildRoute+  toRoute (GetMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "messages" // ID @Message+    & giveID mid+    & buildRoute+  toRoute (CreateReaction (getID -> cid) (getID @Message -> mid) emoji) =+    baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) // S "@me"+    & giveID mid+    & buildRoute+  toRoute (DeleteOwnReaction (getID -> cid) (getID @Message -> mid) emoji) =+    baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) // S "@me"+    & giveID mid+    & buildRoute+  toRoute (DeleteUserReaction (getID -> cid) (getID @Message -> mid) emoji (getID @User -> uid)) =+    baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji) // ID @User+    & giveID mid+    & giveID uid+    & buildRoute+  toRoute (GetReactions (getID -> cid) (getID @Message -> mid) emoji _) =+    baseRoute cid // S "messages" // ID @Message // S "reactions" // S (showt emoji)+    & giveID mid+    & buildRoute+  toRoute (DeleteAllReactions (getID -> cid) (getID @Message -> mid)) =+    baseRoute cid // S "messages" // ID @Message // S "reactions"+    & giveID mid+    & buildRoute+  toRoute (EditMessage (getID -> cid) (getID @Message -> mid) _ _) =+    baseRoute cid // S "messages" // ID @Message+    & giveID mid+    & buildRoute+  toRoute (DeleteMessage (getID -> cid) (getID @Message -> mid)) =+    baseRoute cid // S "messages" // ID @Message+    & giveID mid+    & buildRoute+  toRoute (BulkDeleteMessages (getID -> cid) _) =+    baseRoute cid // S "messages" // S "bulk-delete"+    & buildRoute+  toRoute (GetChannelInvites (getID -> cid)) = baseRoute cid // S "invites" & buildRoute+  toRoute (CreateChannelInvite (getID -> cid) _) = baseRoute cid // S "invites" & buildRoute+  toRoute (EditChannelPermissions (getID -> cid) (getID @Overwrite -> oid)) =+    baseRoute cid // S "permissions" // ID @Overwrite+    & giveID oid+    & buildRoute+  toRoute (DeleteChannelPermission (getID -> cid) (getID @Overwrite -> oid)) =+    baseRoute cid // S "permissions" // ID @Overwrite+    & giveID oid+    & buildRoute+  toRoute (TriggerTyping (getID -> cid)) = baseRoute cid // S "typing" & buildRoute+  toRoute (GetPinnedMessages (getID -> cid)) = baseRoute cid // S "pins" & buildRoute+  toRoute (AddPinnedMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "pins" // ID @Message+    & giveID mid+    & buildRoute+  toRoute (DeletePinnedMessage (getID -> cid) (getID @Message -> mid)) = baseRoute cid // S "pins" // ID @Message+    & giveID mid+    & buildRoute+  toRoute (GroupDMAddRecipient (getID -> cid) (getID @User -> uid) _) = baseRoute cid // S "recipients" // ID @User+    & giveID uid+    & buildRoute+  toRoute (GroupDMRemoveRecipient (getID -> cid) (getID @User -> uid)) = baseRoute cid // S "recipients" // ID @User+    & giveID uid+    & buildRoute++  toAction (CreateMessage _ t) = postWith' (object ["content" .= t])+  toAction (GetChannel _)      = getWith+  toAction (ModifyChannel _ p) = putWith' (toJSON p)+  toAction (DeleteChannel _)   = deleteWith+  toAction (GetChannelMessages _ (Just (ChannelMessagesAround (showt . fromSnowflake -> a)))) = getWithP (param "around" .~ [a])+  toAction (GetChannelMessages _ (Just (ChannelMessagesBefore (showt . fromSnowflake -> a)))) = getWithP (param "before" .~ [a])+  toAction (GetChannelMessages _ (Just (ChannelMessagesAfter  (showt . fromSnowflake -> a)))) = getWithP (param "after"  .~ [a])+  toAction (GetChannelMessages _ (Just (ChannelMessagesLimit  (showt -> a))))                 = getWithP (param "around" .~ [a])+  toAction (GetChannelMessages _ Nothing) = getWith+  toAction (GetMessage _ _)               = getWith+  toAction CreateReaction {}              = putEmpty+  toAction DeleteOwnReaction {}           = deleteWith+  toAction DeleteUserReaction {}          = deleteWith+  toAction (GetReactions _ _ _ GetReactionsOptions { before, after, limit }) = getWithP+    (param "before" .~ maybeToList (showt <$> before)+     >>> param "after" .~ maybeToList (showt <$> after)+     >>> param "limit" .~ maybeToList (showt <$> limit))+  toAction (DeleteAllReactions _ _) = deleteWith+  toAction (EditMessage _ _ content embed) = patchWith'+    (object ["content" .= content, "embed" .= embed])+  toAction (DeleteMessage _ _)                       = deleteWith+  toAction (BulkDeleteMessages _ (map (getID @Message) -> ids)) = postWith' (object ["messages" .= ids])+  toAction (GetChannelInvites _)                     = getWith+  toAction (CreateChannelInvite _ o)                 = postWith' (toJSON o)+  toAction (EditChannelPermissions _ o)              = putWith' (toJSON o)+  toAction (DeleteChannelPermission _ _)             = deleteWith+  toAction (TriggerTyping _)                         = postEmpty+  toAction (GetPinnedMessages _)                     = getWith+  toAction (AddPinnedMessage _ _)                    = putEmpty+  toAction (DeletePinnedMessage _ _)                 = deleteWith+  toAction (GroupDMAddRecipient _ _ o)               = putWith' (toJSON o)+  toAction (GroupDMRemoveRecipient _ _)              = deleteWith
+ src/Calamity/HTTP/Emoji.hs view
@@ -0,0 +1,63 @@+-- | Emoji endpoints+module Calamity.HTTP.Emoji+    ( EmojiRequest(..) ) where++import           Calamity.HTTP.Internal.Request+import           Calamity.HTTP.Internal.Route+import           Calamity.Internal.AesonThings+import           Calamity.Internal.Utils        ()+import           Calamity.Types.Model.Guild+import           Calamity.Types.Snowflake++import           Data.Aeson+import           Data.Function+import           Data.Text                      ( Text )++import           GHC.Generics++import           Network.Wreq+++data CreateGuildEmojiOptions = CreateGuildEmojiOptions+  { name  :: Text+  , image :: Text+  , roles :: [Snowflake Role]+  }+  deriving ( Show, Generic )+  deriving ( ToJSON ) via CalamityJSON CreateGuildEmojiOptions++data ModifyGuildEmojiOptions = ModifyGuildEmojiOptions+  { name  :: Text+  , roles :: [Snowflake Role]+  }+  deriving ( Show, Generic )+  deriving ( ToJSON ) via CalamityJSON ModifyGuildEmojiOptions++data EmojiRequest a where+  ListGuildEmojis :: (HasID Guild g) => g -> EmojiRequest [Emoji]+  GetGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> EmojiRequest Emoji+  CreateGuildEmoji :: (HasID Guild g) => g -> CreateGuildEmojiOptions -> EmojiRequest Emoji+  ModifyGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> ModifyGuildEmojiOptions -> EmojiRequest Emoji+  DeleteGuildEmoji :: (HasID Guild g, HasID Emoji e) => g -> e -> EmojiRequest ()++baseRoute :: Snowflake Guild -> RouteBuilder _+baseRoute id = mkRouteBuilder // S "guilds" // ID @Guild // S "emojis" & giveID id++instance Request (EmojiRequest a) a where+  toRoute (ListGuildEmojis (getID -> gid)) = baseRoute gid & buildRoute+  toRoute (GetGuildEmoji (getID -> gid) (getID @Emoji -> eid)) = baseRoute gid // ID @Emoji+    & giveID eid+    & buildRoute+  toRoute (CreateGuildEmoji (getID -> gid) _) = baseRoute gid & buildRoute+  toRoute (ModifyGuildEmoji (getID -> gid) (getID @Emoji -> eid) _) = baseRoute gid // ID @Emoji+    & giveID eid+    & buildRoute+  toRoute (DeleteGuildEmoji (getID -> gid) (getID @Emoji -> eid)) = baseRoute gid // ID @Emoji+    & giveID eid+    & buildRoute++  toAction (ListGuildEmojis _)       = getWith+  toAction (GetGuildEmoji _ _)       = getWith+  toAction (CreateGuildEmoji _ o)    = postWith' (toJSON o)+  toAction (ModifyGuildEmoji _ _ o)  = patchWith' (toJSON o)+  toAction (DeleteGuildEmoji _ _)    = deleteWith
+ src/Calamity/HTTP/Guild.hs view
@@ -0,0 +1,70 @@+-- | Guild endpoints+module Calamity.HTTP.Guild+    ( GuildRequest(..) ) where++import           Calamity.HTTP.Internal.Request+import           Calamity.HTTP.Internal.Route+import           Calamity.Internal.AesonThings+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild+import           Calamity.Types.Model.User+import           Calamity.Types.Snowflake++import           Data.Aeson+import           Data.Function+import           Data.Text                      ( Text )++import           GHC.Generics++import           Network.Wreq++data CreateGuildData = CreateGuildData+  { name                        :: Text+  , region                      :: Text+  , icon                        :: Text+  , verificationLevel           :: Integer -- TODO: enums for these+  , defaultMessageNotifications :: Integer+  , explicitContentFilter       :: Integer+  , roles                       :: [Role]+  , channels                    :: [Partial Channel]+  }+  deriving ( Show, Generic )+  deriving ( ToJSON ) via CalamityJSON CreateGuildData++data ModifyGuildData = ModifyGuildData+  { name                        :: Maybe Text+  , region                      :: Maybe Text+  , icon                        :: Maybe Text+  , verificationLevel           :: Maybe Integer -- TODO: enums for these+  , defaultMessageNotifications :: Maybe Integer+  , explicitContentFilter       :: Maybe Integer+  , afkChannelID                :: Maybe (Snowflake Channel)+  , afkTimeout                  :: Maybe Integer+  , ownerID                     :: Maybe (Snowflake User)+  , splash                      :: Maybe Text+  , banner                      :: Maybe Text+  , systemChannelID             :: Maybe (Snowflake Channel)+  }+  deriving ( Show, Generic )+  deriving ( ToJSON ) via CalamityJSON ModifyGuildData++data GuildRequest a where+  CreateGuild :: CreateGuildData -> GuildRequest Guild+  GetGuild    :: HasID Guild g => g -> GuildRequest Guild+  ModifyGuild :: HasID Guild g => g -> ModifyGuildData -> GuildRequest Guild++baseRoute :: Snowflake Guild -> RouteBuilder _+baseRoute id = mkRouteBuilder // S "guilds" // ID @Guild+  & giveID id++instance Request (GuildRequest a) a where+  toRoute (CreateGuild _) = mkRouteBuilder // S "guilds"+    & buildRoute+  toRoute (GetGuild (getID -> gid)) = baseRoute gid+    & buildRoute+  toRoute (ModifyGuild (getID -> gid) _) = baseRoute gid+    & buildRoute++  toAction (CreateGuild o) = postWith' (toJSON o)+  toAction (GetGuild _) = getWith+  toAction (ModifyGuild _ o) = patchWith' (toJSON o)
+ src/Calamity/HTTP/Internal/Ratelimit.hs view
@@ -0,0 +1,201 @@+-- | Module containing ratelimit stuff+module Calamity.HTTP.Internal.Ratelimit+    ( newRateLimitState+    , doRequest ) where++import           Calamity.Client.Types        ( BotC )+import           Calamity.HTTP.Internal.Route+import           Calamity.HTTP.Internal.Types+import           Calamity.Internal.Utils++import           Control.Concurrent+import           Control.Concurrent.Event     ( Event )+import qualified Control.Concurrent.Event     as E+import           Control.Concurrent.STM+import           Control.Concurrent.STM.Lock  ( Lock )+import qualified Control.Concurrent.STM.Lock  as L+import           Control.Lens+import           Control.Monad++import           Data.Aeson+import           Data.Aeson.Lens+import           Data.ByteString              ( ByteString )+import qualified Data.ByteString.Lazy         as LB+import           Data.Functor+import           Data.Maybe+import           Data.Time+import           Data.Time.Clock.POSIX++import           Fmt++import           Focus++import           Network.HTTP.Date+import           Network.HTTP.Types           hiding ( statusCode )+import           Network.Wreq++import qualified Polysemy                     as P+import           Polysemy                     ( Sem )+import qualified Polysemy.Async               as P++import           Prelude                      hiding ( error )++import qualified StmContainers.Map            as SC++newRateLimitState :: IO RateLimitState+newRateLimitState = RateLimitState <$> SC.newIO <*> E.newSet++lookupOrInsertDefaultM :: Monad m => m a -> Focus a m a+lookupOrInsertDefaultM aM = casesM+  (do a <- aM+      pure (a, Set a))+  (\a -> pure (a, Leave))++getRateLimit :: RateLimitState -> Route -> STM Lock+getRateLimit s h = SC.focus (lookupOrInsertDefaultM L.new) h (rateLimits s)++doDiscordRequest+  :: BotC r+  => IO (Response LB.ByteString)+  -> Sem r DiscordResponseType+doDiscordRequest r = do+  --debug "making request"+  --maskState <- P.embed getMaskingState+  --print maskState+  r' <- P.embed r+  let status = r' ^. responseStatus+  if+    | statusIsSuccessful status -> do+      let resp = r' ^. responseBody+      debug $ "Got good response from discord: " +|| r' ^. responseStatus ||+ ""+      pure $ if isExhausted r'+        then ExhaustedBucket resp $ parseRateLimitHeader r'+        else Good resp+    | statusIsServerError status -> do+      debug $ "Got server error from discord: " +| status ^. statusCode |+ ""+      pure $ ServerError (status ^. statusCode)+    | status == status429 -> do+      debug "Got 429 from discord, retrying."+      case asValue r' of+        Just rv -> pure $ Ratelimited (parseRetryAfter rv) (isGlobal rv)+        Nothing -> pure $ ClientError (status ^. statusCode) "429 with invalid json???"+    | statusIsClientError status -> do+      let err = r' ^. responseBody+      error $ "You fucked up: " +|| err ||+ " response: " +|| r' ||+ ""+      pure $ ClientError (status ^. statusCode) err+    | otherwise -> fail "Bogus response, discord fix your shit"++parseDiscordTime :: ByteString -> Maybe UTCTime+parseDiscordTime s = httpDateToUTC <$> parseHTTPDate s++computeDiscordTimeDiff :: Double -> UTCTime -> Int+computeDiscordTimeDiff end now = round . (* 1000.0) $ diffUTCTime end' now+  where end' = end & toRational & fromRational & posixSecondsToUTCTime++-- | Parse a ratelimit header returning the number of milliseconds until it resets+parseRateLimitHeader :: Response a -> Int+parseRateLimitHeader r = computeDiscordTimeDiff end now+ where+  end = r ^?! responseHeader "X-Ratelimit-Reset" . _Double+  now = r ^?! responseHeader "Date" & parseDiscordTime & fromJust++isExhausted :: Response a -> Bool+isExhausted r = r ^? responseHeader "X-RateLimit-Remaining" == Just "0"++parseRetryAfter :: Response Value -> Int+parseRetryAfter r =+  r ^?! responseBody . key "retry_after" . _Integral++isGlobal :: Response Value -> Bool+isGlobal r = r ^? responseBody . key "global" . _Bool == Just True+++-- Either (Either a a) b+data ShouldRetry a b+  = Retry a+  | RFail a+  | RGood b++retryRequest+  :: BotC r+  => Int -- ^ number of retries+  -> Sem r (ShouldRetry a b) -- ^ action to perform+  -> Sem r ()  -- ^ action to run if max number of retries was reached+  -> Sem r (Either a b)+retryRequest max_retries action failAction = retryInner 0+ where+  retryInner num_retries = do+    res <- action+    case res of+      Retry r | num_retries > max_retries -> do+        debug $ "Request failed after " +| max_retries |+ " retries."+        doFail $ Left r+      Retry _ -> retryInner (succ num_retries)+      RFail r -> do+        debug "Request failed due to error response."+        doFail $ Left r+      RGood r -> pure $ Right r+    where doFail v = failAction $> v+++-- Run a single request+-- NOTE: this function will only unlock the ratelimit lock if the request+-- gave a response, otherwise it will stay locked so that it can be retried again+doSingleRequest+  :: BotC r+  => Event -- ^ Global lock+  -> Lock -- ^ Local lock+  -> IO (Response LB.ByteString) -- ^ Request action+  -> Sem r (ShouldRetry RestError LB.ByteString)+doSingleRequest gl l r = do+  r' <- doDiscordRequest r+  case r' of+    Good v -> do+      P.embed . atomically $ L.release l+      pure $ RGood v++    ExhaustedBucket v d -> do+      debug $ "Exhausted bucket, unlocking after " +| d |+ "ms"+      void . P.async $ do+        P.embed $ do+          threadDelay $ 1000 * d+          atomically $ L.release l+        debug "unlocking bucket"+      pure $ RGood v++    Ratelimited d False -> do+      debug $ "429 ratelimited on route, sleeping for " +| d |+ " ms"+      P.embed . threadDelay $ 1000 * d+      pure $ Retry (HTTPError 429 Nothing)++    Ratelimited d True -> do+      debug "429 ratelimited globally"+      P.embed $ do+        E.clear gl+        threadDelay $ 1000 * d+        E.set gl+      pure $ Retry (HTTPError 429 Nothing)++    ServerError c -> do+      debug "Server failed, retrying"+      pure $ Retry (HTTPError c Nothing)++    ClientError c v -> pure $ RFail (HTTPError c $ decode v)++doRequest+  :: BotC r+  => RateLimitState+  -> Route+  -> IO (Response LB.ByteString)+  -> Sem r (Either RestError LB.ByteString)+doRequest rlState route action = do+  P.embed $ E.wait (globalLock rlState)++  ratelimit <- P.embed . atomically $ do+    lock <- getRateLimit rlState route+    L.acquire lock+    pure lock++  retryRequest 5+               (doSingleRequest (globalLock rlState) ratelimit action)+               (P.embed . atomically $ L.release ratelimit)
+ src/Calamity/HTTP/Internal/Request.hs view
@@ -0,0 +1,101 @@+-- | Generic Request type+module Calamity.HTTP.Internal.Request+    ( Request(..)+    , postWith'+    , putWith'+    , patchWith'+    , putEmpty+    , postEmpty+    , getWithP ) where++import           Calamity.Client.Types+import           Calamity.HTTP.Internal.Ratelimit+import           Calamity.HTTP.Internal.Route+import           Calamity.HTTP.Internal.Types+import           Calamity.Types.Token++import           Control.Lens++import           Data.Aeson                       hiding ( Options )+import           Data.ByteString                  ( ByteString )+import qualified Data.ByteString.Lazy             as LB+import qualified Data.Text                        as TS+import qualified Data.Text.Encoding               as TS+import qualified Data.Text.Lazy                   as TL++import           DiPolysemy                       hiding ( debug, error, info )++import           Network.Wreq+import           Network.Wreq.Types               ( Patchable, Postable, Putable )++import           Polysemy                         ( Sem )+import qualified Polysemy                         as P+import qualified Polysemy.Error                   as P+import qualified Polysemy.Reader                  as P++fromResult :: P.Member (P.Error RestError) r => Result a -> Sem r a+fromResult (Success a) = pure a+fromResult (Error e) = P.throw (DecodeError . TL.pack $ e)++fromJSONDecode :: P.Member (P.Error RestError) r => Either String a -> Sem r a+fromJSONDecode (Right a) = pure a+fromJSONDecode (Left e) = P.throw (DecodeError . TL.pack $ e)++extractRight :: P.Member (P.Error e) r => Either e a -> Sem r a+extractRight (Left e) = P.throw e+extractRight (Right a) = pure a++class ReadResponse a where+  readResp :: LB.ByteString -> Either String a++instance ReadResponse () where+  readResp = const (Right ())++instance {-# OVERLAPS #-}FromJSON a => ReadResponse a where+  readResp = eitherDecode++class Request a r | a -> r where+  toRoute :: a -> Route++  url :: a -> String+  url = TS.unpack . path . toRoute++  toAction :: a -> Options -> String -> IO (Response LB.ByteString)++  invokeRequest :: forall reffs. (BotC reffs, FromJSON r) => a -> Sem reffs (Either RestError r)+  invokeRequest a = do+      rlState' <- P.asks rlState+      token' <- P.asks token++      resp <- attr "route" (toRoute a ^. #path) $ doRequest rlState' (toRoute a)+        (toAction a (requestOptions token') (Calamity.HTTP.Internal.Request.url a))++      P.runError $ (fromResult . fromJSON) =<< (fromJSONDecode . readResp) =<< extractRight resp++defaultRequestOptions :: Options+defaultRequestOptions = defaults+  & header "User-Agent" .~ ["Calamity (https://github.com/nitros12/calamity)"]+  & header "X-RateLimit-Precision" .~ ["millisecond"]+  & checkResponse ?~ (\_ _ -> pure ())++requestOptions :: Token -> Options+requestOptions t = defaultRequestOptions+  & header "Authorization" .~ [TS.encodeUtf8 . TL.toStrict $ formatToken t]++postWith' :: Postable a => a -> Options -> String -> IO (Response LB.ByteString)+postWith' p o s = postWith o s p++postEmpty :: Options -> String -> IO (Response LB.ByteString)+postEmpty o s = postWith o s ("" :: ByteString)++putWith' :: Putable a => a -> Options -> String -> IO (Response LB.ByteString)+putWith' p o s = putWith o s p++patchWith' :: Patchable a => a -> Options -> String -> IO (Response LB.ByteString)+patchWith' p o s = patchWith o s p++putEmpty :: Options -> String -> IO (Response LB.ByteString)+putEmpty o s = putWith o s ("" :: ByteString)++getWithP :: (Options -> Options) -> Options -> String -> IO (Response LB.ByteString)+getWithP oF o = getWith (oF o)
+ src/Calamity/HTTP/Internal/Route.hs view
@@ -0,0 +1,148 @@+-- | The route type+-- Why I did this I don't know+{-# OPTIONS_GHC -Wno-unused-top-binds #-}++module Calamity.HTTP.Internal.Route+    ( mkRouteBuilder+    , giveID+    , buildRoute+    , RouteBuilder+    , RouteRequirement+    , Route(path)+    , S(..)+    , ID(..)+    , RouteFragmentable(..) ) where++import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild+import           Calamity.Types.Snowflake++import           Data.Hashable+import           Data.Kind+import           Data.List                    ( lookup )+import           Data.Maybe                   ( fromJust )+import           Data.Text                    ( Text )+import qualified Data.Text                    as T+import           Data.Typeable+import           Data.Word++import           GHC.Generics                 hiding ( S )++import           TextShow++data RouteFragment+  = S' Text+  | ID' TypeRep+  deriving ( Generic, Show, Eq )++newtype S = S Text++data ID a = ID++instance Hashable RouteFragment++data RouteRequirement+  = NotNeeded+  | Required+  | Satisfied+  deriving ( Generic, Show, Eq )++data RouteBuilder (idState :: [(Type, RouteRequirement)]) = UnsafeMkRouteBuilder+  { route :: [RouteFragment]+  , ids   :: [(TypeRep, Word64)]+  }++mkRouteBuilder :: RouteBuilder '[]+mkRouteBuilder = UnsafeMkRouteBuilder [] []++giveID+  :: forall k ids+   . Typeable k+  => Snowflake k+  -> RouteBuilder ids+  -> RouteBuilder ('(k, 'Satisfied) ': ids)+giveID (Snowflake id) (UnsafeMkRouteBuilder route ids) =+  UnsafeMkRouteBuilder route ((typeRep (Proxy @k), id) : ids)++type family (&&) (a :: Bool) (b :: Bool) :: Bool where+  'True && 'True = 'True+  _     && _     = 'False++type family Lookup (x :: k) (l :: [(k, v)]) :: Maybe v where+  Lookup k ('(k, v) ': xs) = 'Just v+  Lookup k ('(_, v) ': xs) = Lookup k xs+  Lookup _ '[]             = 'Nothing++type family IsElem (x :: k) (l :: [k]) :: Bool where+  IsElem _ '[]      = 'False+  IsElem k (k : _)  = 'True+  IsElem k (_ : xs) = IsElem k xs++type family EnsureFulfilled (ids :: [(k, RouteRequirement)]) :: Constraint where+  EnsureFulfilled ids = EnsureFulfilledInner ids '[] 'True++type family EnsureFulfilledInner (ids :: [(k, RouteRequirement)]) (seen :: [k]) (ok :: Bool) :: Constraint where+  EnsureFulfilledInner '[]                      _    'True = ()+  EnsureFulfilledInner ('(k, 'NotNeeded) ': xs) seen ok    = EnsureFulfilledInner xs (k ': seen) ok+  EnsureFulfilledInner ('(k, 'Satisfied) ': xs) seen ok    = EnsureFulfilledInner xs (k ': seen) ok+  EnsureFulfilledInner ('(k, 'Required)  ': xs) seen ok    = EnsureFulfilledInner xs (k ': seen) (IsElem k seen && ok)++type family AddRequired k (ids :: [(Type, RouteRequirement)]) :: [(Type, RouteRequirement)] where+  AddRequired k ids = '(k, AddRequiredInner (Lookup k ids)) ': ids++type family AddRequiredInner (k :: Maybe RouteRequirement) :: RouteRequirement where+  AddRequiredInner ('Just 'Required)  = 'Required+  AddRequiredInner ('Just 'Satisfied) = 'Satisfied+  AddRequiredInner ('Just 'NotNeeded) = 'Required+  AddRequiredInner 'Nothing           = 'Required++class Typeable a => RouteFragmentable a ids where+  type ConsRes a ids++  (//) :: RouteBuilder ids -> a -> ConsRes a ids++instance RouteFragmentable S ids where+  type ConsRes S ids = RouteBuilder ids++  (UnsafeMkRouteBuilder r ids) // (S t) =+    UnsafeMkRouteBuilder (S' t : r) ids++instance Typeable a => RouteFragmentable (ID (a :: Type)) (ids :: [(Type, RouteRequirement)]) where+  type ConsRes (ID a) ids = RouteBuilder (AddRequired a ids)++  (UnsafeMkRouteBuilder r ids) // ID =+    UnsafeMkRouteBuilder (ID' (typeRep (Proxy @a)) : r) ids++infixl 5 //++data Route = Route+  { path      :: Text+  , key       :: Text+  , channelID :: Maybe (Snowflake Channel)+  , guildID   :: Maybe (Snowflake Guild)+  } deriving (Generic, Show, Eq)++instance Hashable Route where+  hashWithSalt s (Route _ ident c g) = hashWithSalt s (ident, c, g)++baseURL :: Text+baseURL = "https://discordapp.com/api/v7"++buildRoute+  :: forall (ids :: [(Type, RouteRequirement)])+   . EnsureFulfilled ids+  => RouteBuilder ids+  -> Route+buildRoute (UnsafeMkRouteBuilder route ids) = Route+  (T.intercalate "/" (baseURL : map goR route'))+  (T.concat (map goIdent route'))+  (Snowflake <$> lookup (typeRep (Proxy @Channel)) ids)+  (Snowflake <$> lookup (typeRep (Proxy @Guild)) ids)+ where+  route' = reverse route++  goR (S'  t) = t+  goR (ID' t) = showt . fromJust $ lookup t ids++  goIdent (S'  t) = t+  goIdent (ID' t) = showt t
+ src/Calamity/HTTP/Internal/Types.hs view
@@ -0,0 +1,61 @@+-- | Types for the http lib+module Calamity.HTTP.Internal.Types+    ( RestError(..)+    , RateLimitState(..)+    , DiscordResponseType(..)+    , GatewayResponse+    , BotGatewayResponse ) where++import           Calamity.HTTP.Internal.Route+import           Calamity.Internal.AesonThings++import           Control.Concurrent.Event      ( Event )+import           Control.Concurrent.STM.Lock   ( Lock )++import           Data.Aeson+import qualified Data.ByteString.Lazy          as LB+import           Data.Text.Lazy++import           GHC.Generics++import qualified StmContainers.Map             as SC++data RestError+  = HTTPError+      { status   :: Int+      , response :: Maybe Value+      }+  | DecodeError Text+  deriving ( Show, Generic )++data RateLimitState = RateLimitState+  { rateLimits :: SC.Map Route Lock+  , globalLock :: Event+  }+  deriving ( Generic )++data DiscordResponseType+  = -- | A good response+    Good LB.ByteString+    -- | We got a response but also exhausted the bucket+  | ExhaustedBucket LB.ByteString Int -- ^ Retry after (milliseconds)+    -- | We hit a 429, no response and ratelimited+  | Ratelimited Int -- ^ Retry after (milliseconds)+                Bool -- ^ Global ratelimit+    -- | Discord's error, we should retry (HTTP 5XX)+  | ServerError Int+    -- | Our error, we should fail+  | ClientError Int LB.ByteString++newtype GatewayResponse = GatewayResponse+  { url :: Text+  }+  deriving ( Generic, Show )+  deriving ( FromJSON ) via CalamityJSON GatewayResponse++data BotGatewayResponse = BotGatewayResponse+  { url    :: Text+  , shards :: Int+  }+  deriving ( Generic, Show )+  deriving ( FromJSON ) via CalamityJSON BotGatewayResponse
+ src/Calamity/HTTP/MiscRoutes.hs view
@@ -0,0 +1,24 @@+-- | Miscellaneous routes+module Calamity.HTTP.MiscRoutes where++import           Calamity.HTTP.Internal.Request+import           Calamity.HTTP.Internal.Route+import           Calamity.HTTP.Internal.Types++import           Data.Function++import           Network.Wreq++data MiscRequest a where+  GetGateway :: MiscRequest GatewayResponse+  GetGatewayBot :: MiscRequest BotGatewayResponse++instance Request (MiscRequest a) a where+  toRoute GetGateway = mkRouteBuilder // S "gateway"+    & buildRoute++  toRoute GetGatewayBot = mkRouteBuilder // S "gateway" // S "bot"+    & buildRoute++  toAction GetGateway = getWith+  toAction GetGatewayBot = getWith
+ src/Calamity/Internal/AesonThings.hs view
@@ -0,0 +1,151 @@+module Calamity.Internal.AesonThings+    ( WithSpecialCases+    , WithSpecialCasesInner(..)+    , type IfNoneThen+    , type ExtractField+    , type ExtractFields+    , type InjectID+    , SpecialRule+    , DefaultToEmptyArray+    , DefaultToZero+    , DefaultToFalse+    , CalamityJSON(..)+    , jsonOptions+    , jsonOptionsKeepNothing ) where++import           Control.Lens++import           Data.Aeson+import           Data.Aeson.Lens+import           Data.Aeson.Types      ( Parser )+import           Data.Kind+import           Data.Reflection       ( Reifies(..) )+import           Data.Text             ( Text )+import           Data.Text.Strict.Lens+import           Data.Typeable++import           GHC.Generics+import qualified GHC.TypeLits          as TL+import           GHC.TypeLits          ( KnownSymbol, Symbol, symbolVal )++textSymbolVal :: forall n. KnownSymbol n => Proxy n -> Text+textSymbolVal _ = symbolVal @n Proxy ^. packed++data SpecialCaseList+  = SpecialCaseNil+  | forall label action inner. SpecialCaseElem label action inner++data SpecialRule (label :: Symbol) (action :: SpecialRuleAction)++data SpecialRuleAction+  = forall d. IfNoneThen d+  | forall field. ExtractField field+  | forall field. ExtractFields field+  | forall mn idn. InjectID idn mn++type IfNoneThen label d =+  SpecialRule label ('IfNoneThen d)++type ExtractField label field =+  SpecialRule label ('ExtractField field)++type ExtractFields label field =+  SpecialRule label ('ExtractFields field)++type InjectID label mn idn =+  SpecialRule label ('InjectID mn idn)++class PerformAction (action :: SpecialRuleAction) where+  runAction :: Proxy action -> Value -> Parser Value++instance Reifies d Value => PerformAction ('IfNoneThen d) where+  runAction _ Null = pure $ reflect @d Proxy+  runAction _ x = pure x++instance (KnownSymbol field) => PerformAction ('ExtractField field) where+  runAction _ Null = pure Null+  runAction _ o = withObject (("extracting field " <> textSymbolVal @field Proxy) ^. unpacked)+    (.: textSymbolVal @field Proxy) o++instance (KnownSymbol field) => PerformAction ('ExtractFields field) where+  runAction _ Null = pure Null+  runAction _ o = withArray (("extracting fields " <> textSymbolVal @field Proxy) ^. unpacked)+    ((Array <$>) . traverse (withObject "extracting field" (.: textSymbolVal @field Proxy))) o++instance (KnownSymbol idn, KnownSymbol mn) => PerformAction ('InjectID idn mn) where+  runAction _ = withObject+    (("injecting id from " <> textSymbolVal @idn Proxy <> " into " <> textSymbolVal @mn Proxy) ^. unpacked) $ \o -> do+      id <- o .: "id"++      pure (Object o+            & key (textSymbolVal @mn Proxy) . values . _Object . at (textSymbolVal @idn Proxy) ?~ id)++type family FoldSpecialCases (rules :: [Type]) :: SpecialCaseList where+  FoldSpecialCases '[]                              = 'SpecialCaseNil+  FoldSpecialCases (SpecialRule label action ': xs) = 'SpecialCaseElem label action (FoldSpecialCases xs)+  FoldSpecialCases _ = TL.TypeError ('TL.Text "What did you do?")++newtype WithSpecialCasesInner (rules :: SpecialCaseList) a = WithSpecialCasesInner+  { unwrapWithSpecialCases :: a+  }++type family WithSpecialCases rules a :: Type where+  WithSpecialCases rules a = WithSpecialCasesInner (FoldSpecialCases rules) a++class RunSpecialCase a where+  runSpecialCases :: Proxy a -> Object -> Parser Object++instance RunSpecialCase 'SpecialCaseNil where+  runSpecialCases _ = pure . id++instance (RunSpecialCase inner, KnownSymbol label, PerformAction action)+  => RunSpecialCase ('SpecialCaseElem label action inner) where+  runSpecialCases _ o = do+    o' <- runSpecialCases (Proxy @inner) o+    v <- o' .:? textSymbolVal @label Proxy .!= Null+    v' <- runAction (Proxy @action) v+    pure (o' & at (textSymbolVal @label Proxy) ?~ v')++instance (RunSpecialCase rules, Typeable a, Generic a, GFromJSON Zero (Rep a))+  => FromJSON (WithSpecialCasesInner rules a) where+  parseJSON = withObject (show . typeRep $ Proxy @a) $ \o -> do+    o' <- runSpecialCases (Proxy @rules) o+    WithSpecialCasesInner <$> genericParseJSON jsonOptions (Object o')+++data DefaultToEmptyArray++instance Reifies DefaultToEmptyArray Value where+  reflect _ = Array mempty++data DefaultToZero++instance Reifies DefaultToZero Value where+  reflect _ = Number 0++data DefaultToFalse++instance Reifies DefaultToFalse Value where+  reflect _ = Bool False++newtype CalamityJSON a = CalamityJSON+  { unCalamityJSON :: a+  }++instance (Typeable a, Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CalamityJSON a) where+  toJSON = genericToJSON jsonOptions . unCalamityJSON++  toEncoding = genericToEncoding jsonOptions . unCalamityJSON++instance (Typeable a, Generic a, GFromJSON Zero (Rep a)) => FromJSON (CalamityJSON a) where+  parseJSON = fmap CalamityJSON . genericParseJSON jsonOptions++jsonOptions :: Options+jsonOptions = defaultOptions { sumEncoding        = UntaggedValue+                             , fieldLabelModifier = camelTo2 '_' . filter (/= '_')+                             , omitNothingFields  = True }++jsonOptionsKeepNothing :: Options+jsonOptionsKeepNothing = defaultOptions { sumEncoding        = UntaggedValue+                                        , fieldLabelModifier = camelTo2 '_' . filter (/= '_')+                                        , omitNothingFields  = False }
+ src/Calamity/Internal/MessageStore.hs view
@@ -0,0 +1,84 @@+-- | A thing for storing the last N messages+module Calamity.Internal.MessageStore+    ( MessageStore(..)+    , addMessage+    , getMessage+    , dropMessage ) where++import           Calamity.Internal.Utils+import           Calamity.Types.Model.Channel.Message+import           Calamity.Types.Snowflake++import           Control.Lens+import           Control.Lens.Operators               ( (.=) )+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 )++import           GHC.Generics++data MessageStore = MessageStore+  { messageQueue :: Deque (Snowflake Message)+  , messages     :: HashMap (Snowflake Message) Message+  , limit        :: Int+  , size         :: Int+  }+  deriving ( Show, Generic )++instance Default MessageStore where+  def = MessageStore mempty H.empty 1000 0++type instance (Index MessageStore) = Snowflake Message+type instance (IxValue MessageStore) = Message++instance Ixed MessageStore++instance At MessageStore where+  at k f m = f mv <&> \case+    Nothing -> maybe m (const (dropMessage k m)) mv+    Just v  -> addMessage v m+    where+      mv = getMessage k m++  {-# INLINE at #-}++addMessage :: Message -> MessageStore -> MessageStore+addMessage m = execState $ do+  unlessM (H.member (m ^. #id) <$> use #messages) do+    #messageQueue %= DQ.cons (getID m)+    #size += 1++  size <- use #size+  limit <- use #limit++  when (size > limit) do+    q <- use #messageQueue+    let Just (rid, q') = DQ.unsnoc q+    #messageQueue .= q'+    #messages %= sans rid+    #size -= 1++  #messages %= H.insert (getID m) m++{-# INLINE addMessage #-}++getMessage :: Snowflake Message -> MessageStore -> Maybe Message+getMessage id s = H.lookup id (s ^. #messages)++{-# INLINE getMessage #-}++dropMessage :: Snowflake Message -> MessageStore -> MessageStore+dropMessage id = execState $ do+  whenM (H.member id <$> use #messages) do+    #size -= 1++  #messageQueue %= DQ.filter (/= id)+  #messages %= H.delete id++{-# INLINE dropMessage #-}
+ src/Calamity/Internal/SnowflakeMap.hs view
@@ -0,0 +1,239 @@+-- | Module for custom instance of Data.HashMap.Lazy 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++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 anyclass ( NFData, Hashable )++-- instance At (SnowflakeMap a) where+--   at k f m = at (unSnowflakeMap k) f m++instance Functor SnowflakeMap where+  fmap f = SnowflakeMap . coerceSnowflakeMap . fmap f . unSnowflakeMap++instance Foldable SnowflakeMap where+  foldr f b = Prelude.foldr f b . unSnowflakeMap++instance Traversable SnowflakeMap where+  traverse f = fmap (SnowflakeMap . coerceSnowflakeMap) . traverse f . unSnowflakeMap++-- deriving instance NFData a => NFData (SnowflakeMap a)++-- deriving instance Hashable a => Hashable (SnowflakeMap a)++instance Wrapped (SnowflakeMap a) where+  type Unwrapped (SnowflakeMap a) = HashMap (Snowflake a) a++  _Wrapped' = iso unSnowflakeMap SnowflakeMap++type instance (Index (SnowflakeMap a)) = Snowflake a++type instance (IxValue (SnowflakeMap a)) = a++instance SnowflakeMap a ~ t => Rewrapped (SnowflakeMap b) a++instance Ixed (SnowflakeMap a) where+  ix i = _Wrapped . ix i++instance At (SnowflakeMap a) where+  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 #-}++-- I guess I could just do this by unwrapping everything and using coerceSnowflake+coerceSnowflakeMap :: HashMap (Snowflake a) v -> HashMap (Snowflake b) v+coerceSnowflakeMap = unsafeCoerce+{-# INLINABLE coerceSnowflakeMap #-}++empty :: SnowflakeMap a+empty = SnowflakeMap LH.empty+{-# INLINABLE empty #-}++singleton :: HasID' a => a -> SnowflakeMap a+singleton v = SnowflakeMap $ LH.singleton (getID v) v+{-# INLINABLE singleton #-}++null :: SnowflakeMap a -> Bool+null = LH.null . unSnowflakeMap+{-# INLINABLE null #-}++size :: SnowflakeMap a -> Int+size = LH.size . unSnowflakeMap+{-# INLINABLE size #-}++member :: Snowflake a -> SnowflakeMap a -> Bool+member k = LH.member k . unSnowflakeMap+{-# INLINABLE member #-}++lookup :: Snowflake a -> SnowflakeMap a -> Maybe a+lookup k = LH.lookup k . unSnowflakeMap+{-# INLINABLE lookup #-}++lookupDefault :: a -> Snowflake a -> SnowflakeMap a -> a+lookupDefault d k = LH.lookupDefault d k . unSnowflakeMap+{-# INLINABLE lookupDefault #-}++(!) :: SnowflakeMap a -> Snowflake a -> a+(!) m k = unSnowflakeMap m LH.! k+{-# INLINABLE (!) #-}++insert :: HasID' a => a -> SnowflakeMap a -> SnowflakeMap a+insert v = over $ LH.insert (getID v) v+{-# INLINABLE insert #-}++insertWith :: HasID' a => (a -> a -> a) -> a -> SnowflakeMap a -> SnowflakeMap a+insertWith f v = over $ LH.insertWith f (getID v) v+{-# INLINABLE insertWith #-}++delete :: Snowflake a -> SnowflakeMap a -> SnowflakeMap a+delete k = over $ LH.delete k+{-# INLINABLE delete #-}++adjust :: (a -> a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a+adjust f k = over $ LH.adjust f k+{-# INLINABLE adjust #-}++update :: (a -> Maybe a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a+update f k = over $ LH.update f k+{-# INLINABLE update #-}++alter :: (Maybe a -> Maybe a) -> Snowflake a -> SnowflakeMap a -> SnowflakeMap a+alter f k = over $ LH.alter f k+{-# INLINABLE alter #-}++union :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a+union m m' = SnowflakeMap $ LH.union (unSnowflakeMap m) (unSnowflakeMap m')+{-# INLINABLE 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 #-}++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 #-}++unions :: [SnowflakeMap a] -> SnowflakeMap a+unions = SnowflakeMap . LH.unions . Prelude.map unSnowflakeMap+{-# INLINABLE unions #-}++map :: (a1 -> a2) -> SnowflakeMap a1 -> SnowflakeMap a2+map f = over $ coerceSnowflakeMap . LH.map f+{-# INLINABLE map #-}++mapWithKey :: (Snowflake a1 -> a1 -> a2) -> SnowflakeMap a1 -> SnowflakeMap a2+mapWithKey f = over $ coerceSnowflakeMap . LH.mapWithKey f+{-# INLINABLE 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 #-}++difference :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a+difference m m' = SnowflakeMap $ LH.difference (unSnowflakeMap m) (unSnowflakeMap m')+{-# INLINABLE 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 #-}++intersection :: SnowflakeMap a -> SnowflakeMap a -> SnowflakeMap a+intersection m m' = SnowflakeMap $ LH.intersection (unSnowflakeMap m) (unSnowflakeMap m')+{-# INLINABLE 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 #-}++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 #-}++foldl' :: (a -> b -> a) -> a -> SnowflakeMap b -> a+foldl' f s m = LH.foldl' f s $ unSnowflakeMap m+{-# INLINABLE foldl' #-}++foldlWithKey' :: (a -> Snowflake b -> b -> a) -> a -> SnowflakeMap b -> a+foldlWithKey' f s m = LH.foldlWithKey' f s $ unSnowflakeMap m+{-# INLINABLE foldlWithKey' #-}++foldr :: (b -> a -> a) -> a -> SnowflakeMap b -> a+foldr f s m = LH.foldr f s $ unSnowflakeMap m+{-# INLINABLE foldr #-}++foldrWithKey :: (Snowflake b -> b -> a -> a) -> a -> SnowflakeMap b -> a+foldrWithKey f s m = LH.foldrWithKey f s $ unSnowflakeMap m+{-# INLINABLE foldrWithKey #-}++filter :: (a -> Bool) -> SnowflakeMap a -> SnowflakeMap a+filter f = over $ LH.filter f+{-# INLINABLE filter #-}++filterWithKey :: (Snowflake a -> a -> Bool) -> SnowflakeMap a -> SnowflakeMap a+filterWithKey f = over $ LH.filterWithKey f+{-# INLINABLE filterWithKey #-}++mapMaybe :: (a -> Maybe b) -> SnowflakeMap a -> SnowflakeMap b+mapMaybe f = over $ coerceSnowflakeMap . LH.mapMaybe f+{-# INLINABLE mapMaybe #-}++mapMaybeWithKey :: (Snowflake a -> a -> Maybe b) -> SnowflakeMap a -> SnowflakeMap b+mapMaybeWithKey f = over $ coerceSnowflakeMap . LH.mapMaybeWithKey f+{-# INLINABLE mapMaybeWithKey #-}++keys :: SnowflakeMap a -> [Snowflake a]+keys = LH.keys . unSnowflakeMap+{-# INLINABLE keys #-}++elems :: SnowflakeMap a -> [a]+elems = LH.elems . unSnowflakeMap+{-# INLINABLE elems #-}++toList :: SnowflakeMap a -> [(Snowflake a, a)]+toList = LH.toList . unSnowflakeMap+{-# INLINABLE toList #-}++fromList :: HasID' a => [a] -> SnowflakeMap a+fromList = SnowflakeMap . LH.fromList . Prelude.map (\v -> (getID v, v))+{-# INLINABLE fromList #-}++fromListWith :: HasID' a => (a -> a -> a) -> [a] -> SnowflakeMap a+fromListWith f = SnowflakeMap . LH.fromListWith f . Prelude.map (\v -> (getID v, v))+{-# INLINABLE fromListWith #-}++instance (FromJSON a, HasID' a) => FromJSON (SnowflakeMap a) where+  parseJSON = withArray "SnowflakeMap" $ \l -> do+    parsed <- traverse parseJSON l+    pure . Calamity.Internal.SnowflakeMap.fromList . F.toList $ parsed++instance ToJSON a => ToJSON (SnowflakeMap a) where+  toEncoding = toEncoding . elems
+ src/Calamity/Internal/Updateable.hs view
@@ -0,0 +1,97 @@+-- | Updateable objects+module Calamity.Internal.Updateable+    ( Updateable(..) ) where++import           Calamity.Internal.Utils+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Channel.Message+import           Calamity.Types.Model.Guild.Guild+import           Calamity.Types.Model.User++import           Control.Lens++import           Data.Generics.Product.Fields+import           Data.Maybe++import           GHC.TypeLits++class Updateable a where+  type Updated a+  type Updated a = a++  update :: Updated a -> a -> a++-- | sets original field to new field+setF :: forall (f :: Symbol) o n b. (HasField' f o b, HasField' f o b, HasField' f n b) => n -> o -> o+setF n = field' @f .~ (n ^. field' @f)++-- | sets original field to unwrapped new field if new field is not Nothing+mergeF :: forall (f :: Symbol) o n b. (HasField' f o b, HasField' f o b, HasField' f n (Maybe b)) => o -> n -> o -> o+mergeF o n = field' @f .~ fromMaybe (o ^. field' @f) (n ^. field' @f)++-- | sets original field to new field if new field is not Nothing+mergeF' :: forall (f :: Symbol) o n b. (HasField' f o (Maybe b), HasField' f n (Maybe b)) => o -> n -> o -> o+mergeF' o n = field' @f .~ lastMaybe (o ^. field' @f) (n ^. field' @f)++instance Updateable Message where+  type Updated Message = UpdatedMessage++  update n o = o+    & mergeF @"content" o n+    & setF @"editedTimestamp" n+    & mergeF @"tts" o n+    & mergeF @"mentionEveryone" o n+    & mergeF @"mentions" o n+    & mergeF @"mentionRoles" o n+    & mergeF @"attachments" o n+    & mergeF @"embeds" o n+    & mergeF @"reactions" o n+    & mergeF @"pinned" o n++instance Updateable Channel where+  update n _ = n++instance Updateable DMChannel where+  update n _ = n++instance Updateable GuildChannel where+  update n _ = n++instance Updateable Guild where+  type Updated Guild = UpdatedGuild++  -- For updating guild we just put in the non-present data from+  update n o = o+    & setF @"name" n+    & setF @"icon" n+    & setF @"splash" n+    & setF @"owner" n+    & setF @"ownerID" n+    & mergeF @"permissions" o n+    & setF @"region" n+    & setF @"afkChannelID" n+    & setF @"afkTimeout" n+    & mergeF @"embedEnabled" o n+    & setF @"embedChannelID" n+    & setF @"verificationLevel" n+    & setF @"defaultMessageNotifications" n+    & setF @"explicitContentFilter" n+    & setF @"roles" n+    & setF @"features" n+    & setF @"mfaLevel" n+    & setF @"applicationID" n+    & mergeF @"widgetEnabled" o n+    & setF @"widgetChannelID" n+    & setF @"systemChannelID" n++instance Updateable User where+  update n o = o+    & setF @"username" n+    & setF @"discriminator" n+    & mergeF' @"bot" o n+    & mergeF' @"avatar" o n+    & mergeF' @"mfaEnabled" o n+    & mergeF' @"verified" o n+    & mergeF' @"email" o n+    & mergeF' @"flags" o n+    & mergeF' @"premiumType" o n
+ src/Calamity/Internal/Utils.hs view
@@ -0,0 +1,66 @@+module Calamity.Internal.Utils+    ( whenJust+    , whenM+    , unlessM+    , lastMaybe+    , (<<$>>)+    , debug+    , info+    , Calamity.Internal.Utils.error+    , swap ) where++import           Calamity.LogEff++import qualified Data.HashMap.Lazy   as LH+import           Data.Semigroup      ( Last(..) )+import           Data.Text.Lazy+import           Data.Time+import qualified Data.Vector.Unboxed as VU+import           Data.Vector.Unboxed ( Vector )++import qualified DiPolysemy          as Di++import qualified Polysemy            as P++import           TextShow++whenJust :: Applicative m => Maybe a -> (a -> m ()) -> m ()+whenJust = flip $ maybe (pure ())++whenM :: Monad m => m Bool -> m () -> m ()+whenM p m = p >>= \case+  True -> m+  _    -> pure ()++unlessM :: Monad m => m Bool -> m () -> m ()+unlessM = whenM . (not <$>)++lastMaybe :: Maybe a -> Maybe a -> Maybe a+lastMaybe l r = getLast <$> fmap Last l <> fmap Last r++(<<$>>) :: (Functor f, Functor g) => (a -> b) -> f (g a) -> f (g b)+(<<$>>) = fmap . fmap++infixl 4 <<$>>++debug :: P.Member LogEff r => Text -> P.Sem r ()+debug = Di.debug++info :: P.Member LogEff r => Text -> P.Sem r ()+info = Di.info++error :: P.Member LogEff r => Text -> P.Sem r ()+error = Di.error++swap :: (a, b) -> (b, a)+swap ~(a, b) = (b, a)++instance TextShow UTCTime where+  showb = fromString . show++instance (TextShow a, VU.Unbox a) => TextShow (Vector a) where+  showb = showbList . VU.toList++-- lazy and strict use the same internal data structure+instance (Show k, Show v) => TextShow (LH.HashMap k v) where+  showb = fromString . show
+ src/Calamity/LogEff.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE NoImplicitPrelude #-}++-- | The logging effect we use+module Calamity.LogEff+    ( LogEff+    , LogC ) where++import qualified Df1++import           DiPolysemy++import qualified Polysemy   as P++type LogEff = Di Df1.Level Df1.Path Df1.Message++type LogC r = P.Member LogEff r
+ src/Calamity/Types.hs view
@@ -0,0 +1,13 @@+-- | All user facing types+module Calamity.Types+    ( module Calamity.Types.Model+    , module Calamity.Types.Partial+    , module Calamity.Types.Snowflake+    , module Calamity.Types.Token+    , module Calamity.Types.UnixTimestamp ) where++import           Calamity.Types.Model+import           Calamity.Types.Partial+import           Calamity.Types.Snowflake+import           Calamity.Types.Token+import           Calamity.Types.UnixTimestamp
+ src/Calamity/Types/Model.hs view
@@ -0,0 +1,13 @@+-- | Discord data models+module Calamity.Types.Model+    ( module Calamity.Types.Model.Channel+    , module Calamity.Types.Model.Guild+    , module Calamity.Types.Model.Presence+    , module Calamity.Types.Model.User+    , module Calamity.Types.Model.Voice ) where++import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild+import           Calamity.Types.Model.Presence+import           Calamity.Types.Model.User+import           Calamity.Types.Model.Voice
+ src/Calamity/Types/Model/Channel.hs view
@@ -0,0 +1,65 @@+-- | The generic channel type+module Calamity.Types.Model.Channel+    ( Channel(..)+    , Partial(PartialChannel)+    , module Calamity.Types.Model.Channel.DM+    , module Calamity.Types.Model.Channel.Group+    , module Calamity.Types.Model.Channel.Guild+    , module Calamity.Types.Model.Channel.Attachment+    , module Calamity.Types.Model.Channel.Reaction+    , module Calamity.Types.Model.Channel.Embed+    , module Calamity.Types.Model.Channel.ChannelType+    , module Calamity.Types.Model.Channel.Message ) where++import           Calamity.Internal.AesonThings+import           Calamity.Types.Model.Channel.Attachment+import           Calamity.Types.Model.Channel.ChannelType+import           Calamity.Types.Model.Channel.DM+import           Calamity.Types.Model.Channel.Embed+import           Calamity.Types.Model.Channel.Group+import           Calamity.Types.Model.Channel.Guild+import {-# SOURCE #-} Calamity.Types.Model.Channel.Message hiding ( UpdatedMessage )+import           Calamity.Types.Model.Channel.Reaction+import           Calamity.Types.Partial+import           Calamity.Types.Snowflake++import           Data.Aeson+import           Data.Text.Lazy                           ( Text )++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic                         as TSG++data Channel+  = DMChannel' DMChannel+  | GroupChannel' GroupChannel+  | GuildChannel' GuildChannel+  deriving ( Show, Eq, Generic )+  deriving ( TextShow ) via TSG.FromGeneric Channel++instance HasID Channel Channel where+  getID (DMChannel' a) = getID a+  getID (GroupChannel' a) = getID a+  getID (GuildChannel' a) = getID a++instance FromJSON Channel where+  parseJSON = withObject "Channel" $ \v -> do+    type_ <- v .: "type"++    case type_ of+      GuildTextType     -> GuildChannel' <$> parseJSON (Object v)+      GuildVoiceType    -> GuildChannel' <$> parseJSON (Object v)+      GuildCategoryType -> GuildChannel' <$> parseJSON (Object v)+      DMType            -> DMChannel' <$> parseJSON (Object v)+      GroupDMType       -> GroupChannel' <$> parseJSON (Object v)++data instance Partial Channel = PartialChannel+  { id    :: Snowflake Channel+  , name  :: Text+  , type_ :: ChannelType+  }+  deriving ( Show, Eq, Generic )+  deriving ( TextShow ) via TSG.FromGeneric (Partial Channel)+  deriving ( ToJSON, FromJSON ) via CalamityJSON (Partial Channel)+  deriving ( HasID Channel ) via HasIDField "id" (Partial Channel)
+ src/Calamity/Types/Model/Channel.hs-boot view
@@ -0,0 +1,7 @@+-- | The generic channel type+module Calamity.Types.Model.Channel+    ( Channel ) where++data Channel+instance Show Channel+instance Eq Channel
+ src/Calamity/Types/Model/Channel/Attachment.hs view
@@ -0,0 +1,49 @@+-- | Message attachments+module Calamity.Types.Model.Channel.Attachment+    ( Attachment(..) ) where++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+  pure (a', b')++data Attachment = Attachment+  { id         :: Snowflake Attachment+  , filename   :: Text+  , size       :: Word64+  , url        :: Text+  , proxyUrl   :: Text+  , dimensions :: Maybe (Word64, Word64)+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric Attachment+  deriving ( HasID Attachment ) via HasIDField "id" Attachment++instance ToJSON Attachment where+  toEncoding Attachment { id, filename, size, url, proxyUrl, dimensions = Just (width, height) } = pairs+    ("id" .= id <> "filename" .= filename <> "size" .= size <> "url" .= url <> "proxy_url" .= proxyUrl+     <> "width" .= width <> "height" .= height)++  toEncoding Attachment { id, filename, size, url, proxyUrl } = pairs+    ("id" .= id <> "filename" .= filename <> "size" .= size <> "url" .= url <> "proxy_url" .= proxyUrl)++instance FromJSON Attachment where+  parseJSON = withObject "Attachment" $ \v -> do+    width <- v .:? "width"+    height <- v .:? "height"++    Attachment <$> v .: "id" <*> v .: "filename" <*> v .: "size" <*> v .: "url" <*> v .: "proxy_url" <*> pure+      (fuseTup2 (width, height))
+ src/Calamity/Types/Model/Channel/ChannelType.hs view
@@ -0,0 +1,29 @@+-- | Types of channels+module Calamity.Types.Model.Channel.ChannelType+    ( ChannelType(..) ) where++import           Data.Aeson+import           Data.Scientific++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic as TSG++-- Thanks sbrg (https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hsfield#L182)+data ChannelType+  = GuildTextType+  | DMType+  | GuildVoiceType+  | GroupDMType+  | GuildCategoryType+  deriving ( Eq, Generic, Show, Enum )+  deriving ( TextShow ) via TSG.FromGeneric ChannelType++instance ToJSON ChannelType where+  toJSON t = Number $ fromIntegral (fromEnum t)++instance FromJSON ChannelType where+  parseJSON = withScientific "ChannelType" $ \n -> case toBoundedInteger n of+    Just v  -> pure $ toEnum v+    Nothing -> fail $ "Invalid ChannelType: " <> show n
+ src/Calamity/Types/Model/Channel/DM.hs view
@@ -0,0 +1,31 @@+-- | A DM channel with a single person+module Calamity.Types.Model.Channel.DM+    ( DMChannel(..) ) where++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           Data.Aeson+import           Data.Time+import           Data.Vector.Unboxed                  ( Vector )++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic                     as TSG++data DMChannel = DMChannel+  { id               :: Snowflake DMChannel+  , lastMessageID    :: Maybe (Snowflake Message)+  , lastPinTimestamp :: Maybe UTCTime+  , recipients       :: Vector (Snowflake User)+  }+  deriving ( Show, Eq, Generic )+  deriving ( TextShow ) via TSG.FromGeneric DMChannel+  deriving ( FromJSON, ToJSON ) via CalamityJSON DMChannel+  deriving ( HasID DMChannel ) via HasIDField "id" DMChannel+  deriving ( HasID Channel ) via HasIDFieldCoerce' "id" DMChannel
+ src/Calamity/Types/Model/Channel/Embed.hs view
@@ -0,0 +1,111 @@+-- | Message embeds+module Calamity.Types.Model.Channel.Embed+    ( Embed(..)+    , EmbedFooter(..)+    , EmbedImage(..)+    , EmbedThumbnail(..)+    , EmbedVideo(..)+    , EmbedProvider(..)+    , EmbedAuthor(..)+    , EmbedField(..) ) where++import           Calamity.Internal.AesonThings+import           Calamity.Internal.Utils       ()++import           Data.Aeson+import           Data.Text.Lazy                ( Text )+import           Data.Time+import           Data.Word++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic              as TSG++data Embed = Embed+  { title       :: Maybe Text+  , type_       :: Maybe Text+  , description :: Maybe Text+  , url         :: Maybe Text+  , timestamp   :: Maybe UTCTime+  , color       :: Maybe Word64+  , footer      :: Maybe EmbedFooter+  , image       :: Maybe EmbedImage+  , thumbnail   :: Maybe EmbedThumbnail+  , video       :: Maybe EmbedVideo+  , provider    :: Maybe EmbedProvider+  , author      :: Maybe EmbedAuthor+  , fields      :: [EmbedField]+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric Embed+  deriving ( FromJSON ) via WithSpecialCases '[IfNoneThen "fields" DefaultToEmptyArray]+      Embed+  deriving ( ToJSON ) via CalamityJSON Embed++data EmbedFooter = EmbedFooter+  { text         :: Text+  , iconUrl      :: Maybe Text+  , proxyIconUrl :: Maybe Text+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric EmbedFooter+  deriving ( ToJSON, FromJSON ) via CalamityJSON EmbedFooter++data EmbedImage = EmbedImage+  { url      :: Text+  , proxyUrl :: Text+  , width    :: Word64+  , height   :: Word64+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric EmbedImage+  deriving ( FromJSON, ToJSON ) via CalamityJSON EmbedImage++data EmbedThumbnail = EmbedThumbnail+  { url      :: Text+  , proxyUrl :: Text+  , width    :: Word64+  , height   :: Word64+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric EmbedThumbnail+  deriving ( FromJSON, ToJSON ) via CalamityJSON EmbedThumbnail++data EmbedVideo = EmbedVideo+  { url    :: Text+  , width  :: Word64+  , height :: Word64+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric EmbedVideo+  deriving ( FromJSON, ToJSON ) via CalamityJSON EmbedVideo++data EmbedProvider = EmbedProvider+  { name :: Text+  , url  :: Maybe Text+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric EmbedProvider+  deriving ( ToJSON, FromJSON ) via CalamityJSON EmbedProvider++data EmbedAuthor = EmbedAuthor+  { name         :: Maybe Text+  , url          :: Maybe Text+  , iconUrl      :: Maybe Text+  , proxyIconURL :: Maybe Text+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric EmbedAuthor+  deriving ( ToJSON, FromJSON ) via CalamityJSON EmbedAuthor++data EmbedField = EmbedField+  { name   :: Text+  , value  :: Text+  , inline :: Bool+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric EmbedField+  deriving ( FromJSON ) via WithSpecialCases '[IfNoneThen "inline" DefaultToFalse]+      EmbedField+  deriving ( ToJSON ) via CalamityJSON EmbedField
+ src/Calamity/Types/Model/Channel/Group.hs view
@@ -0,0 +1,36 @@+-- | A Group Group channel+module Calamity.Types.Model.Channel.Group+    ( GroupChannel(..) ) where++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           Data.Aeson+import           Data.Text.Lazy                       ( Text )+import           Data.Time+import           Data.Vector.Unboxed                  ( Vector )++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic                     as TSG++data GroupChannel = GroupChannel+  { id               :: Snowflake GroupChannel+  , ownerID          :: Snowflake User+  , lastMessageID    :: Maybe (Snowflake Message)+  , lastPinTimestamp :: Maybe UTCTime+  , icon             :: Maybe Text+  , recipients       :: Vector (Snowflake User)+  , name             :: Text+  }+  deriving ( Show, Eq, Generic )+  deriving ( TextShow ) via TSG.FromGeneric GroupChannel+  deriving ( ToJSON, FromJSON ) via CalamityJSON GroupChannel+  deriving ( HasID GroupChannel ) via HasIDField "id" GroupChannel+  deriving ( HasID Channel ) via HasIDFieldCoerce' "id" GroupChannel+  deriving ( HasID User ) via HasIDField "ownerID" GroupChannel
+ src/Calamity/Types/Model/Channel/Guild.hs view
@@ -0,0 +1,54 @@+-- | 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++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 {-# SOURCE #-} Calamity.Types.Model.Guild.Guild+import           Calamity.Types.Snowflake++import           Control.Lens++import           Data.Aeson+import           Data.Generics.Product.Fields++import           GHC.Generics++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++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)+      GuildCategoryType -> GuildCategory <$> parseJSON (Object v)+      _                 -> fail "Not a valid guild channel"++instance HasID GuildChannel GuildChannel where+  getID (GuildTextChannel a) = coerceSnowflake $ a ^. field' @"id"+  getID (GuildVoiceChannel a) = coerceSnowflake $ a ^. field' @"id"+  getID (GuildCategory a) = coerceSnowflake $ a ^. field' @"id"++instance HasID Channel GuildChannel where+  getID = coerceSnowflake . getID @GuildChannel++instance HasID Guild GuildChannel where+  getID (GuildTextChannel a) = coerceSnowflake $ a ^. field' @"guildID"+  getID (GuildVoiceChannel a) = coerceSnowflake $ a ^. field' @"guildID"+  getID (GuildCategory a) = coerceSnowflake $ a ^. field' @"guildID"
+ src/Calamity/Types/Model/Channel/Guild/Category.hs view
@@ -0,0 +1,32 @@+module Calamity.Types.Model.Channel.Guild.Category+    ( Category(..) ) where++import           Calamity.Internal.AesonThings+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++data Category = Category+  { id                   :: Snowflake Category+  , permissionOverwrites :: [Overwrite]+  , 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
+ src/Calamity/Types/Model/Channel/Guild/Category.hs-boot view
@@ -0,0 +1,8 @@+module Calamity.Types.Model.Channel.Guild.Category+    ( Category ) where+++data Category++instance Show Category+instance Eq Category
+ src/Calamity/Types/Model/Channel/Guild/Text.hs view
@@ -0,0 +1,43 @@+-- | Text channels+module Calamity.Types.Model.Channel.Guild.Text+    ( TextChannel(..) ) where++import           Calamity.Internal.AesonThings+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++data TextChannel = TextChannel+  { id                   :: Snowflake TextChannel+  , guildID              :: Snowflake Guild+  , position             :: Int+  , permissionOverwrites :: [Overwrite]+  , 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
+ src/Calamity/Types/Model/Channel/Guild/Voice.hs view
@@ -0,0 +1,36 @@+-- | Voice channels+module Calamity.Types.Model.Channel.Guild.Voice+    ( VoiceChannel(..) ) where++import           Calamity.Internal.AesonThings+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++data VoiceChannel = VoiceChannel+  { id                   :: Snowflake VoiceChannel+  , guildID              :: Snowflake Guild+  , position             :: Int+  , permissionOverwrites :: [Overwrite]+  , 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
+ src/Calamity/Types/Model/Channel/Message.hs view
@@ -0,0 +1,99 @@+-- | A message from a channel+module Calamity.Types.Model.Channel.Message+    ( Message(..)+    , UpdatedMessage(..)+    , MessageType(..) ) where++import           Calamity.Internal.AesonThings+import           Calamity.Internal.Utils          ()+import           Calamity.Types.Model.Channel+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.Scientific+import           Data.Text.Lazy                   ( Text )+import           Data.Time+import qualified Data.Vector.Unboxed              as UV++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic                 as TSG++-- NOTE: make sure we fill in the guildID field when retrieving from REST+data Message = Message+  { id              :: Snowflake Message+  , channelID       :: Snowflake Channel+  , guildID         :: Maybe (Snowflake Guild)+  , author          :: Snowflake User+  , content         :: Text+  , timestamp       :: UTCTime+  , editedTimestamp :: Maybe UTCTime+  , tts             :: Bool+  , mentionEveryone :: Bool+  , mentions        :: UV.Vector (Snowflake User)+  , mentionRoles    :: UV.Vector (Snowflake Role)+  , attachments     :: [Attachment]+  , embeds          :: [Embed]+  , reactions       :: [Reaction]+  , nonce           :: Maybe (Snowflake Message)+  , pinned          :: Bool+  , webhookID       :: Maybe (Snowflake ())+  , type_           :: MessageType+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric Message+  deriving ( ToJSON ) via CalamityJSON Message+  deriving ( FromJSON ) via WithSpecialCases+      '["author" `ExtractField` "id", "mentions" `ExtractFields` "id",+        "reactions" `IfNoneThen` DefaultToEmptyArray]+      Message+  deriving ( HasID Message ) via HasIDField "id" Message+  deriving ( HasID Channel ) via HasIDField "channelID" Message+  deriving ( HasID User ) via HasIDField "author" Message++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))+  , 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" `ExtractField` "id", "mentions" `ExtractFields` "id"]+      UpdatedMessage+  deriving ( HasID Message ) via HasIDField "id" UpdatedMessage+  deriving ( HasID Channel ) via HasIDField "channelID" UpdatedMessage++-- Thanks sbrg (https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs#L264)+data MessageType+  = Default+  | RecipientAdd+  | RecipientRemove+  | Call+  | ChannelNameChange+  | ChannelIconChange+  | ChannelPinnedMessage+  | GuildMemberJoin+  deriving ( Eq, Show, Enum, Generic )+  deriving ( TextShow ) via TSG.FromGeneric MessageType++instance ToJSON MessageType where+  toJSON t = Number $ fromIntegral (fromEnum t)++instance FromJSON MessageType where+  parseJSON = withScientific "MessageType" $ \n -> case toBoundedInteger n of+    Just v  -> pure $ toEnum v+    Nothing -> fail $ "Invalid MessageType: " <> show n
+ src/Calamity/Types/Model/Channel/Message.hs-boot view
@@ -0,0 +1,20 @@+-- | A message from a channel+module Calamity.Types.Model.Channel.Message+    ( Message+    , UpdatedMessage+    , MessageType ) where++data Message++instance Show Message+instance Eq Message++data UpdatedMessage++instance Show UpdatedMessage+instance Eq UpdatedMessage++data MessageType++instance Show MessageType+instance Eq MessageType
+ src/Calamity/Types/Model/Channel/Reaction.hs view
@@ -0,0 +1,32 @@+-- | Message reactions+module Calamity.Types.Model.Channel.Reaction+    ( Reaction(..) ) where++import           Calamity.Internal.AesonThings+import {-# SOURCE #-} Calamity.Types.Model.Channel+import {-# SOURCE #-} Calamity.Types.Model.Channel.Message+import           Calamity.Types.Model.Guild.Emoji+import {-# SOURCE #-} Calamity.Types.Model.Guild.Guild+import           Calamity.Types.Model.User+import           Calamity.Types.Snowflake++import           Data.Aeson++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic                     as TSG++data Reaction = Reaction+  { userID    :: Snowflake User+  , channelID :: Snowflake Channel+  , messageID :: Snowflake Message+  , guildID   :: Maybe (Snowflake Guild)+  , emoji     :: RawEmoji+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric Reaction+  deriving ( ToJSON, FromJSON ) via CalamityJSON Reaction+  deriving ( HasID User ) via HasIDField "userID" Reaction+  deriving ( HasID Channel ) via HasIDField "channelID" Reaction+  deriving ( HasID Message ) via HasIDField "messageID" Reaction
+ src/Calamity/Types/Model/Guild.hs view
@@ -0,0 +1,17 @@+-- | Discord Guilds+module Calamity.Types.Model.Guild+    ( module Calamity.Types.Model.Guild.Emoji+    , module Calamity.Types.Model.Guild.Guild+    , module Calamity.Types.Model.Guild.Member+    , module Calamity.Types.Model.Guild.Overwrite+    , module Calamity.Types.Model.Guild.Invite+    , module Calamity.Types.Model.Guild.Role+    , module Calamity.Types.Model.Guild.UnavailableGuild ) where++import           Calamity.Types.Model.Guild.Emoji+import           Calamity.Types.Model.Guild.Guild            hiding ( UpdatedGuild )+import           Calamity.Types.Model.Guild.Invite+import           Calamity.Types.Model.Guild.Member+import           Calamity.Types.Model.Guild.Overwrite+import           Calamity.Types.Model.Guild.Role+import           Calamity.Types.Model.Guild.UnavailableGuild
+ src/Calamity/Types/Model/Guild/Emoji.hs view
@@ -0,0 +1,63 @@+-- | Discord emojis+module Calamity.Types.Model.Guild.Emoji+    ( Emoji(..)+    , Partial(PartialEmoji)+    , RawEmoji(..) ) 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           Data.Aeson+import           Data.Text.Lazy                  ( Text )+import           Data.Vector.Unboxed             ( Vector )++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic                as TSG++data Emoji = Emoji+  { id            :: Snowflake Emoji+  , name          :: Text+  , roles         :: Vector (Snowflake Role)+  , user          :: Maybe (Snowflake User)+  , requireColons :: 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" `ExtractField` "id"] Emoji+  deriving ( HasID Emoji ) via HasIDField "id" Emoji++data instance Partial Emoji = PartialEmoji+  { id   :: Snowflake Emoji+  , name :: Text+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric (Partial Emoji)+  deriving ( ToJSON, FromJSON ) via CalamityJSON (Partial Emoji)+  deriving ( HasID Emoji ) via HasIDField "id" (Partial Emoji)++data RawEmoji+  = UnicodeEmoji Text+  | CustomEmoji (Partial Emoji)+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric RawEmoji++instance ToJSON RawEmoji where+  toEncoding (CustomEmoji e) = pairs $ "emoji" .= e+  toEncoding (UnicodeEmoji s) = pairs $ "emoji" .= (("name" .= s) :: Object)++instance FromJSON RawEmoji where+  parseJSON = withObject "RawEmoji" $ \v -> do+    m_id :: Maybe (Snowflake Emoji) <- v .:? "id"+    name :: Text <- v .: "name"++    pure $ case m_id of+      Just id -> CustomEmoji $ PartialEmoji id name+      Nothing -> UnicodeEmoji name
+ src/Calamity/Types/Model/Guild/Guild.hs view
@@ -0,0 +1,162 @@+-- | Discord Guilds+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 {-# 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++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+  , 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+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric Guild+  deriving ( HasID Guild ) via HasIDField "id" Guild++instance FromJSON Guild where+  parseJSON = withObject "Guild" $ \v -> do+    id <- v .: "id"++    -- TODO: clean this up++    members' <- do+      members' <- v .: "members"+      SM.fromList <$> traverse (\m -> parseJSON $ Object (m <> "guild_id" .= id)) members'++    channels' <- do+      channels' <- v .: "channels"+      SM.fromList <$> traverse (\m -> parseJSON $ Object (m <> "guild_id" .= id)) channels'++    presences' <- do+      presences' <- v .: "presences"+      LH.fromList <$> traverse (\m -> do+                                  p <- parseJSON $ Object (m <> "guild_id" .= id)+                                  pure (getID $ p ^. field @"user", p)) presences'++    Guild id+      <$> v .: "name"+      <*> v .: "icon"+      <*> v .:? "splash"+      <*> v .:? "owner"+      <*> v .: "owner_id"+      <*> v .:? "permissions"    .!= 0+      <*> v .: "region"+      <*> v .:? "afk_channel_id"+      <*> v .: "afk_timeout"+      <*> v .:? "embed_enabled"  .!= False+      <*> v .:? "embed_channel_id"+      <*> v .: "verification_level"+      <*> v .: "default_message_notifications"+      <*> v .: "explicit_content_filter"+      <*> v .: "roles"+      <*> v .: "emojis"+      <*> v .: "features"+      <*> v .: "mfa_level"+      <*> v .:? "application_id"+      <*> v .:? "widget_enabled" .!= False+      <*> v .:? "widget_channel_id"+      <*> v .:? "system_channel_id"+      <*> v .:? "joined_at"+      <*> v .: "large"+      <*> v .: "unavailable"+      <*> v .: "member_count"+      <*> v .: "voice_states"+      <*> pure members'+      <*> pure channels'+      <*> pure presences'++data instance Partial Guild = PartialGuild+  { 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)++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+  , 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)+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric UpdatedGuild+  deriving ( FromJSON ) via CalamityJSON UpdatedGuild+  deriving ( HasID Guild ) via HasIDField "id" UpdatedGuild
+ src/Calamity/Types/Model/Guild/Guild.hs-boot view
@@ -0,0 +1,14 @@+-- | Discord Guilds+module Calamity.Types.Model.Guild.Guild+    ( Guild+    , UpdatedGuild ) where++data Guild++instance Show Guild+instance Eq Guild++data UpdatedGuild++instance Show UpdatedGuild+instance Eq UpdatedGuild
+ src/Calamity/Types/Model/Guild/Invite.hs view
@@ -0,0 +1,31 @@+-- | Guild invites+module Calamity.Types.Model.Guild.Invite+    ( Invite(..) ) where++import           Calamity.Internal.AesonThings+import           Calamity.Types.Model.Channel+import           Calamity.Types.Model.Guild.Guild+import           Calamity.Types.Model.User+import           Calamity.Types.Snowflake++import           Data.Aeson+import           Data.Text.Lazy                   ( Text )++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic                 as TSG++data Invite = Invite+  { code                     :: Text+  , guild                    :: Maybe (Partial Guild)+  , channel                  :: Maybe (Partial Channel)+  , targetUser               :: Maybe (Snowflake User)+  , targetUserType           :: Maybe Int+  , approximatePresenceCount :: Maybe Int+  , approximateMemberCount   :: Maybe Int+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric Invite+  deriving ( ToJSON ) via CalamityJSON Invite+  deriving ( FromJSON ) via WithSpecialCases '["targetUser" `ExtractField` "id"] Invite
+ src/Calamity/Types/Model/Guild/Member.hs view
@@ -0,0 +1,43 @@+-- | Guild Members+module Calamity.Types.Model.Guild.Member+    ( Member(..) ) where++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           Control.Lens++import           Data.Aeson+import           Data.Generics.Product.Fields+import           Data.Text.Lazy                   ( Text )+import           Data.Time+import           Data.Vector.Unboxed              ( Vector )++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic                 as TSG++data Member = Member+  { user     :: User+  , 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 ( ToJSON, FromJSON ) via CalamityJSON Member+  deriving ( HasID Guild ) via HasIDField "guildID" Member++instance HasID User Member where+  getID = getID . (^. field @"user")++instance HasID Member Member where+  getID = coerceSnowflake . getID @User
+ src/Calamity/Types/Model/Guild/Member.hs-boot view
@@ -0,0 +1,8 @@+-- | Guild Members+module Calamity.Types.Model.Guild.Member+    ( Member ) where++data Member++instance Show Member+instance Eq Member
+ src/Calamity/Types/Model/Guild/Overwrite.hs view
@@ -0,0 +1,26 @@+-- | Permission overwrites+module Calamity.Types.Model.Guild.Overwrite+    ( Overwrite(..) ) where++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++data Overwrite = Overwrite+  { id    :: Snowflake Overwrite+  , type_ :: Text+  , allow :: Word64+  , deny  :: Word64+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric Overwrite+  deriving ( ToJSON, FromJSON ) via CalamityJSON Overwrite+  deriving ( HasID Overwrite ) via HasIDField "id" Overwrite
+ src/Calamity/Types/Model/Guild/Role.hs view
@@ -0,0 +1,30 @@+-- | Guild roles+module Calamity.Types.Model.Guild.Role+    ( Role(..) ) where++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++data Role = Role+  { id          :: Snowflake Role+  , name        :: Text+  , color       :: Word64+  , hoist       :: Bool+  , position    :: Int+  , permissions :: Word64+  , 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
+ src/Calamity/Types/Model/Guild/UnavailableGuild.hs view
@@ -0,0 +1,23 @@+-- | Guilds that are unavailable+module Calamity.Types.Model.Guild.UnavailableGuild+    ( UnavailableGuild(..) ) where++import           Calamity.Internal.AesonThings+import           Calamity.Types.Model.Guild.Guild+import           Calamity.Types.Snowflake++import           Data.Aeson++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic                 as TSG++data UnavailableGuild = UnavailableGuild+  { id          :: Snowflake Guild+  , unavailable :: Bool+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric UnavailableGuild+  deriving ( ToJSON, FromJSON ) via CalamityJSON UnavailableGuild+  deriving ( HasID Guild ) via HasIDField "id" UnavailableGuild
+ src/Calamity/Types/Model/Presence.hs view
@@ -0,0 +1,7 @@+-- | User presences+module Calamity.Types.Model.Presence+    ( module Calamity.Types.Model.Presence.Presence+    , module Calamity.Types.Model.Presence.Activity ) where++import           Calamity.Types.Model.Presence.Activity+import           Calamity.Types.Model.Presence.Presence
+ src/Calamity/Types/Model/Presence/Activity.hs view
@@ -0,0 +1,101 @@+-- | User activities+module Calamity.Types.Model.Presence.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++import           TextShow+import qualified TextShow.Generic              as TSG++data ActivityType+  = Game+  | Streaming+  | Listening+  deriving ( Eq, Generic, Show, Enum )+  deriving ( TextShow ) via TSG.FromGeneric ActivityType++instance ToJSON ActivityType where+  toJSON t = Number $ fromIntegral (fromEnum t)++instance FromJSON ActivityType where+  parseJSON = withScientific "ActivityType" $ \n -> case toBoundedInteger n of+    Just v  -> pure $ toEnum v+    Nothing -> fail $ "Invalid ActivityType: " <> show n++data Activity = Activity+  { 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+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric Activity+  deriving ( ToJSON, FromJSON ) via CalamityJSON Activity++data ActivityTimestamps = ActivityTimestamps+  { start :: Maybe UnixTimestamp+  , end   :: Maybe UnixTimestamp+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric ActivityTimestamps++instance ToJSON ActivityTimestamps where+  toEncoding ActivityTimestamps { start, end } = pairs+    ("start" .= (unixToMilliseconds <$> start) <> "end" .= (unixToMilliseconds <$> end))++instance FromJSON ActivityTimestamps where+  parseJSON = withObject "ActivityTimestamps" $ \v -> do+    start <- millisecondsToUnix <<$>> v .:? "start"+    end <- millisecondsToUnix <<$>> v .:? "end"++    pure $ ActivityTimestamps start end++data ActivityParty = ActivityParty+  { id   :: Maybe Text+  , size :: Maybe (Int, Int)+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric ActivityParty+  deriving ( ToJSON, FromJSON ) via CalamityJSON ActivityParty++data ActivityAssets = ActivityAssets+  { largeImage :: Maybe Text+  , largeText  :: Maybe Text+  , smallImage :: Maybe Text+  , smallText  :: Maybe Text+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric ActivityAssets+  deriving ( ToJSON, FromJSON ) via CalamityJSON ActivityAssets++data ActivitySecrets = ActivitySecrets+  { join     :: Maybe Text+  , spectate :: Maybe Text+  , match    :: Maybe Text+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric ActivitySecrets+  deriving ( ToJSON, FromJSON ) via CalamityJSON ActivitySecrets
+ src/Calamity/Types/Model/Presence/Presence.hs view
@@ -0,0 +1,43 @@+-- | User presences+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           Data.Aeson+import qualified Data.Override                          as O+import           Data.Override.Aeson                    ()+import           Data.Text.Lazy                         ( Text )++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic                       as TSG++data Presence = Presence+  { user         :: Snowflake User+  , game         :: Maybe Activity+  , guildID      :: Snowflake Guild+  , status       :: StatusType+  , clientStatus :: ClientStatus+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric Presence+  deriving ( ToJSON, FromJSON ) via CalamityJSON+      (O.Override Presence '["user" `O.As` Partial User])+  deriving ( HasID User ) via HasIDField "user" Presence+  deriving ( HasID Guild ) via HasIDField "guildID" Presence++data ClientStatus = ClientStatus+  { desktop :: Maybe Text+  , mobile  :: Maybe Text+  , web     :: Maybe Text+  }+  deriving ( Eq, Show, Generic )+  deriving ( TextShow ) via TSG.FromGeneric ClientStatus+  deriving ( ToJSON, FromJSON ) via CalamityJSON ClientStatus
+ src/Calamity/Types/Model/User.hs view
@@ -0,0 +1,70 @@+-- | A User+module Calamity.Types.Model.User+    ( User(..)+    , Partial(PartialUser)+    , StatusType(..) ) where++import           Calamity.Internal.AesonThings+import {-# SOURCE #-} Calamity.Types.Model.Guild.Member+import           Calamity.Types.Partial+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++data User = User+  { 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+  }+  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++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)++data StatusType+  = Idle+  | DND+  | Online+  | Offline+  | Invisible+  deriving ( Eq, Show, Enum, Generic )+  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+    "invisible" -> pure Invisible+    _           -> fail "Unknown status type"++instance ToJSON StatusType where+  toJSON = String . \case+    Idle      -> "idle"+    DND       -> "dnd"+    Online    -> "online"+    Offline   -> "offline"+    Invisible -> "invisible"
+ src/Calamity/Types/Model/Voice.hs view
@@ -0,0 +1,5 @@+-- | Voice data types+module Calamity.Types.Model.Voice+    ( module Calamity.Types.Model.Voice.VoiceState ) where++import           Calamity.Types.Model.Voice.VoiceState
+ src/Calamity/Types/Model/Voice/VoiceState.hs view
@@ -0,0 +1,31 @@+module Calamity.Types.Model.Voice.VoiceState+    ( VoiceState(..) ) where++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           Data.Aeson+import           Data.Text.Lazy                           ( Text )++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic                         as TSG++data VoiceState = VoiceState+  { guildID   :: Maybe (Snowflake Guild)+  , channelID :: Maybe (Snowflake VoiceChannel)+  , userID    :: Snowflake User+  , sessionID :: Text+  , 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
+ src/Calamity/Types/Partial.hs view
@@ -0,0 +1,5 @@+-- | Partial data family+module Calamity.Types.Partial+    ( Partial ) where++data family Partial t
+ src/Calamity/Types/Snowflake.hs view
@@ -0,0 +1,142 @@+-- | The snowflake type+module Calamity.Types.Snowflake+    ( Snowflake(..)+    , HasID(..)+    , type HasID'+    , HasIDField(..)+    , HasIDFieldCoerce(..)+    , type HasIDFieldCoerce'+    , coerceSnowflake ) where++import           Control.DeepSeq+import           Control.Lens+import           Control.Monad++import           Data.Aeson+import           Data.Data+import           Data.Generics.Product.Fields+import           Data.Hashable+import           Data.Text.Read+import qualified Data.Vector.Generic.Base     as V+import qualified Data.Vector.Generic.Mutable  as MV+import qualified Data.Vector.Unboxed          as U+import           Data.Word++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic as TSG++-- Thanks sbrg+-- https://github.com/saevarb/haskord/blob/d1bb07bcc4f3dbc29f2dfd3351ff9f16fc100c07/haskord-lib/src/Haskord/Types/Common.hs#L78+newtype Snowflake t = Snowflake+  { fromSnowflake :: Word64+  }+  deriving ( Generic, Show, Eq, Ord, Data )+  deriving ( TextShow ) via TSG.FromGeneric (Snowflake t)+  deriving newtype ( NFData, ToJSONKey, Hashable )++instance ToJSON (Snowflake t) where+  toJSON (Snowflake s) = String . showt $ s++instance FromJSON (Snowflake t) where+  parseJSON = withText "Snowflake" $ \t -> do+    n <- case decimal t of+      Right (n, _) -> pure n+      Left e       -> fail e+    pure $ Snowflake n++coerceSnowflake :: Snowflake a -> Snowflake b+coerceSnowflake (Snowflake t) = Snowflake t++-- | A typeclass for types that contain snowflakes of type `b`+class HasID b a where++  -- | Retrieve the ID from the type+  getID :: a -> Snowflake b++type HasID' a = HasID a a++-- | A newtype wrapper for deriving HasID generically+newtype HasIDField field a = HasIDField a++instance HasField' field a (Snowflake b) => HasID b (HasIDField field a) where+  getID (HasIDField a) = a ^. field' @field++-- | A data `a` which contains an ID of type `Snowflake c`+--   which should be swapped with `Snowflake b` upon fetching+newtype HasIDFieldCoerce field a c = HasIDFieldCoerce a++type HasIDFieldCoerce' field a = HasIDFieldCoerce field a a++instance HasField' field a (Snowflake c) => HasID b (HasIDFieldCoerce field a c) where+  getID (HasIDFieldCoerce a) = coerceSnowflake $ a ^. field' @field++instance HasID a (Snowflake a) where+  getID = id++newtype instance U.MVector s (Snowflake t) = MV_Snowflake (U.MVector s Word64)++newtype instance U.Vector (Snowflake t) = V_Snowflake (U.Vector Word64)++instance MV.MVector U.MVector (Snowflake t) where+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicOverlaps #-}+  {-# INLINE basicUnsafeNew #-}+  {-# INLINE basicInitialize #-}+  {-# INLINE basicUnsafeReplicate #-}+  {-# INLINE basicUnsafeRead #-}+  {-# INLINE basicUnsafeWrite #-}+  {-# INLINE basicClear #-}+  {-# INLINE basicSet #-}+  {-# INLINE basicUnsafeCopy #-}+  {-# INLINE basicUnsafeGrow #-}+  basicLength (MV_Snowflake v) = MV.basicLength v++  basicUnsafeSlice i n (MV_Snowflake v) = MV_Snowflake $ MV.basicUnsafeSlice i n v++  basicOverlaps (MV_Snowflake v1) (MV_Snowflake v2) = MV.basicOverlaps v1 v2++  basicUnsafeNew n = MV_Snowflake `liftM` MV.basicUnsafeNew n++  basicInitialize (MV_Snowflake v) = MV.basicInitialize v++  basicUnsafeReplicate n x = MV_Snowflake `liftM` MV.basicUnsafeReplicate n (fromSnowflake x)++  basicUnsafeRead (MV_Snowflake v) i = Snowflake `liftM` MV.basicUnsafeRead v i++  basicUnsafeWrite (MV_Snowflake v) i x = MV.basicUnsafeWrite v i (fromSnowflake x)++  basicClear (MV_Snowflake v) = MV.basicClear v++  basicSet (MV_Snowflake v) x = MV.basicSet v (fromSnowflake x)++  basicUnsafeCopy (MV_Snowflake v1) (MV_Snowflake v2) = MV.basicUnsafeCopy v1 v2++  basicUnsafeMove (MV_Snowflake v1) (MV_Snowflake v2) = MV.basicUnsafeMove v1 v2++  basicUnsafeGrow (MV_Snowflake v) n = MV_Snowflake `liftM` MV.basicUnsafeGrow v n++instance V.Vector U.Vector (Snowflake t) where+  {-# INLINE basicUnsafeFreeze #-}+  {-# INLINE basicUnsafeThaw #-}+  {-# INLINE basicLength #-}+  {-# INLINE basicUnsafeSlice #-}+  {-# INLINE basicUnsafeIndexM #-}+  {-# INLINE elemseq #-}+  basicUnsafeFreeze (MV_Snowflake v) = V_Snowflake `liftM` V.basicUnsafeFreeze v++  basicUnsafeThaw (V_Snowflake v) = MV_Snowflake `liftM` V.basicUnsafeThaw v++  basicLength (V_Snowflake v) = V.basicLength v++  basicUnsafeSlice i n (V_Snowflake v) = V_Snowflake $ V.basicUnsafeSlice i n v++  basicUnsafeIndexM (V_Snowflake v) i = Snowflake `liftM` V.basicUnsafeIndexM v i++  basicUnsafeCopy (MV_Snowflake mv) (V_Snowflake v) = V.basicUnsafeCopy mv v++  elemseq _ = seq++instance U.Unbox (Snowflake t)
+ src/Calamity/Types/Token.hs view
@@ -0,0 +1,26 @@+-- | Discord tokens+module Calamity.Types.Token+    ( Token(..)+    , formatToken+    , rawToken ) where++import           Data.Text.Lazy++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic as TSG++data Token+  = BotToken Text+  | UserToken Text+  deriving ( Generic, Show )+  deriving ( TextShow ) via TSG.FromGeneric Token++formatToken :: Token -> Text+formatToken (BotToken t) = "Bot " <> t+formatToken (UserToken t) = t++rawToken :: Token -> Text+rawToken (BotToken t) = t+rawToken (UserToken t) = t
+ src/Calamity/Types/UnixTimestamp.hs view
@@ -0,0 +1,55 @@+-- | Parsing of unix timestamps+module Calamity.Types.UnixTimestamp+    ( UnixTimestamp(..)+    , unixToMilliseconds+    , millisecondsToUnix ) where++import           Calamity.Internal.Utils ()++import           Control.Arrow++import           Data.Aeson+import           Data.Aeson.Encoding     ( word64 )+import           Data.Time+import           Data.Time.Clock.POSIX+import           Data.Word++import           GHC.Generics++import           TextShow+import qualified TextShow.Generic        as TSG++newtype UnixTimestamp = UnixTimestamp+  { unUnixTimestamp :: UTCTime+  }+  deriving ( Show, Eq, Generic )+  deriving ( TextShow ) via TSG.FromGeneric UnixTimestamp++unixToMilliseconds :: UnixTimestamp -> Word64+unixToMilliseconds = unUnixTimestamp+                     >>> utcTimeToPOSIXSeconds+                     >>> toRational+                     >>> (* 1000)+                     >>> round++millisecondsToUnix :: Word64 -> UnixTimestamp+millisecondsToUnix = toRational+                     >>> fromRational+                     >>> (/ 1000)+                     >>> posixSecondsToUTCTime+                     >>> UnixTimestamp++instance ToJSON UnixTimestamp where+  toEncoding = unUnixTimestamp+               >>> utcTimeToPOSIXSeconds+               >>> toRational+               >>> round+               >>> word64++instance FromJSON UnixTimestamp where+  parseJSON = withScientific "UnixTimestamp" $+    toRational+    >>> fromRational+    >>> posixSecondsToUTCTime+    >>> UnixTimestamp+    >>> pure