diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for Calamity + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabal.project b/cabal.project new file mode 100644 --- /dev/null +++ b/cabal.project @@ -0,0 +1,10 @@ +-- Generated by stackage-to-hackage + +with-compiler: ghc-8.6.5 + +packages: + ./ + + +allow-older: * +allow-newer: * diff --git a/calamity.cabal b/calamity.cabal new file mode 100644 --- /dev/null +++ b/calamity.cabal @@ -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 +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 diff --git a/src/Calamity.hs b/src/Calamity.hs new file mode 100644 --- /dev/null +++ b/src/Calamity.hs @@ -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 diff --git a/src/Calamity/Cache/Eff.hs b/src/Calamity/Cache/Eff.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Cache/Eff.hs @@ -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) diff --git a/src/Calamity/Cache/InMemory.hs b/src/Calamity/Cache/InMemory.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Cache/InMemory.hs @@ -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 diff --git a/src/Calamity/Client.hs b/src/Calamity/Client.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Client.hs @@ -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 diff --git a/src/Calamity/Client/Client.hs b/src/Calamity/Client/Client.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Client/Client.hs @@ -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 diff --git a/src/Calamity/Client/ShardManager.hs b/src/Calamity/Client/ShardManager.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Client/ShardManager.hs @@ -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] diff --git a/src/Calamity/Client/Types.hs b/src/Calamity/Client/Types.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Client/Types.hs @@ -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 diff --git a/src/Calamity/Gateway.hs b/src/Calamity/Gateway.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Gateway.hs @@ -0,0 +1,7 @@ +-- | +module Calamity.Gateway + ( module Calamity.Gateway.Shard + , module Calamity.Gateway.Types ) where + +import Calamity.Gateway.Shard +import Calamity.Gateway.Types diff --git a/src/Calamity/Gateway/DispatchEvents.hs b/src/Calamity/Gateway/DispatchEvents.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Gateway/DispatchEvents.hs @@ -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 ) diff --git a/src/Calamity/Gateway/Shard.hs b/src/Calamity/Gateway/Shard.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Gateway/Shard.hs @@ -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 () diff --git a/src/Calamity/Gateway/Types.hs b/src/Calamity/Gateway/Types.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Gateway/Types.hs @@ -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) diff --git a/src/Calamity/HTTP.hs b/src/Calamity/HTTP.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/HTTP.hs @@ -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 diff --git a/src/Calamity/HTTP/Channel.hs b/src/Calamity/HTTP/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/HTTP/Channel.hs @@ -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 diff --git a/src/Calamity/HTTP/Emoji.hs b/src/Calamity/HTTP/Emoji.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/HTTP/Emoji.hs @@ -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 diff --git a/src/Calamity/HTTP/Guild.hs b/src/Calamity/HTTP/Guild.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/HTTP/Guild.hs @@ -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) diff --git a/src/Calamity/HTTP/Internal/Ratelimit.hs b/src/Calamity/HTTP/Internal/Ratelimit.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/HTTP/Internal/Ratelimit.hs @@ -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) diff --git a/src/Calamity/HTTP/Internal/Request.hs b/src/Calamity/HTTP/Internal/Request.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/HTTP/Internal/Request.hs @@ -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) diff --git a/src/Calamity/HTTP/Internal/Route.hs b/src/Calamity/HTTP/Internal/Route.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/HTTP/Internal/Route.hs @@ -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 diff --git a/src/Calamity/HTTP/Internal/Types.hs b/src/Calamity/HTTP/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/HTTP/Internal/Types.hs @@ -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 diff --git a/src/Calamity/HTTP/MiscRoutes.hs b/src/Calamity/HTTP/MiscRoutes.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/HTTP/MiscRoutes.hs @@ -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 diff --git a/src/Calamity/Internal/AesonThings.hs b/src/Calamity/Internal/AesonThings.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Internal/AesonThings.hs @@ -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 } diff --git a/src/Calamity/Internal/MessageStore.hs b/src/Calamity/Internal/MessageStore.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Internal/MessageStore.hs @@ -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 #-} diff --git a/src/Calamity/Internal/SnowflakeMap.hs b/src/Calamity/Internal/SnowflakeMap.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Internal/SnowflakeMap.hs @@ -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 diff --git a/src/Calamity/Internal/Updateable.hs b/src/Calamity/Internal/Updateable.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Internal/Updateable.hs @@ -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 diff --git a/src/Calamity/Internal/Utils.hs b/src/Calamity/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Internal/Utils.hs @@ -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 diff --git a/src/Calamity/LogEff.hs b/src/Calamity/LogEff.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/LogEff.hs @@ -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 diff --git a/src/Calamity/Types.hs b/src/Calamity/Types.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types.hs @@ -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 diff --git a/src/Calamity/Types/Model.hs b/src/Calamity/Types/Model.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model.hs @@ -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 diff --git a/src/Calamity/Types/Model/Channel.hs b/src/Calamity/Types/Model/Channel.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel.hs @@ -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) diff --git a/src/Calamity/Types/Model/Channel.hs-boot b/src/Calamity/Types/Model/Channel.hs-boot new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel.hs-boot @@ -0,0 +1,7 @@ +-- | The generic channel type +module Calamity.Types.Model.Channel + ( Channel ) where + +data Channel +instance Show Channel +instance Eq Channel diff --git a/src/Calamity/Types/Model/Channel/Attachment.hs b/src/Calamity/Types/Model/Channel/Attachment.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel/Attachment.hs @@ -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)) diff --git a/src/Calamity/Types/Model/Channel/ChannelType.hs b/src/Calamity/Types/Model/Channel/ChannelType.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel/ChannelType.hs @@ -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 diff --git a/src/Calamity/Types/Model/Channel/DM.hs b/src/Calamity/Types/Model/Channel/DM.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel/DM.hs @@ -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 diff --git a/src/Calamity/Types/Model/Channel/Embed.hs b/src/Calamity/Types/Model/Channel/Embed.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel/Embed.hs @@ -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 diff --git a/src/Calamity/Types/Model/Channel/Group.hs b/src/Calamity/Types/Model/Channel/Group.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel/Group.hs @@ -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 diff --git a/src/Calamity/Types/Model/Channel/Guild.hs b/src/Calamity/Types/Model/Channel/Guild.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel/Guild.hs @@ -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" diff --git a/src/Calamity/Types/Model/Channel/Guild/Category.hs b/src/Calamity/Types/Model/Channel/Guild/Category.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel/Guild/Category.hs @@ -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 diff --git a/src/Calamity/Types/Model/Channel/Guild/Category.hs-boot b/src/Calamity/Types/Model/Channel/Guild/Category.hs-boot new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel/Guild/Category.hs-boot @@ -0,0 +1,8 @@ +module Calamity.Types.Model.Channel.Guild.Category + ( Category ) where + + +data Category + +instance Show Category +instance Eq Category diff --git a/src/Calamity/Types/Model/Channel/Guild/Text.hs b/src/Calamity/Types/Model/Channel/Guild/Text.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel/Guild/Text.hs @@ -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 diff --git a/src/Calamity/Types/Model/Channel/Guild/Voice.hs b/src/Calamity/Types/Model/Channel/Guild/Voice.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel/Guild/Voice.hs @@ -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 diff --git a/src/Calamity/Types/Model/Channel/Message.hs b/src/Calamity/Types/Model/Channel/Message.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel/Message.hs @@ -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 diff --git a/src/Calamity/Types/Model/Channel/Message.hs-boot b/src/Calamity/Types/Model/Channel/Message.hs-boot new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel/Message.hs-boot @@ -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 diff --git a/src/Calamity/Types/Model/Channel/Reaction.hs b/src/Calamity/Types/Model/Channel/Reaction.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Channel/Reaction.hs @@ -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 diff --git a/src/Calamity/Types/Model/Guild.hs b/src/Calamity/Types/Model/Guild.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Guild.hs @@ -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 diff --git a/src/Calamity/Types/Model/Guild/Emoji.hs b/src/Calamity/Types/Model/Guild/Emoji.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Guild/Emoji.hs @@ -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 diff --git a/src/Calamity/Types/Model/Guild/Guild.hs b/src/Calamity/Types/Model/Guild/Guild.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Guild/Guild.hs @@ -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 diff --git a/src/Calamity/Types/Model/Guild/Guild.hs-boot b/src/Calamity/Types/Model/Guild/Guild.hs-boot new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Guild/Guild.hs-boot @@ -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 diff --git a/src/Calamity/Types/Model/Guild/Invite.hs b/src/Calamity/Types/Model/Guild/Invite.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Guild/Invite.hs @@ -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 diff --git a/src/Calamity/Types/Model/Guild/Member.hs b/src/Calamity/Types/Model/Guild/Member.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Guild/Member.hs @@ -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 diff --git a/src/Calamity/Types/Model/Guild/Member.hs-boot b/src/Calamity/Types/Model/Guild/Member.hs-boot new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Guild/Member.hs-boot @@ -0,0 +1,8 @@ +-- | Guild Members +module Calamity.Types.Model.Guild.Member + ( Member ) where + +data Member + +instance Show Member +instance Eq Member diff --git a/src/Calamity/Types/Model/Guild/Overwrite.hs b/src/Calamity/Types/Model/Guild/Overwrite.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Guild/Overwrite.hs @@ -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 diff --git a/src/Calamity/Types/Model/Guild/Role.hs b/src/Calamity/Types/Model/Guild/Role.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Guild/Role.hs @@ -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 diff --git a/src/Calamity/Types/Model/Guild/UnavailableGuild.hs b/src/Calamity/Types/Model/Guild/UnavailableGuild.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Guild/UnavailableGuild.hs @@ -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 diff --git a/src/Calamity/Types/Model/Presence.hs b/src/Calamity/Types/Model/Presence.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Presence.hs @@ -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 diff --git a/src/Calamity/Types/Model/Presence/Activity.hs b/src/Calamity/Types/Model/Presence/Activity.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Presence/Activity.hs @@ -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 diff --git a/src/Calamity/Types/Model/Presence/Presence.hs b/src/Calamity/Types/Model/Presence/Presence.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Presence/Presence.hs @@ -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 diff --git a/src/Calamity/Types/Model/User.hs b/src/Calamity/Types/Model/User.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/User.hs @@ -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" diff --git a/src/Calamity/Types/Model/Voice.hs b/src/Calamity/Types/Model/Voice.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Voice.hs @@ -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 diff --git a/src/Calamity/Types/Model/Voice/VoiceState.hs b/src/Calamity/Types/Model/Voice/VoiceState.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Model/Voice/VoiceState.hs @@ -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 diff --git a/src/Calamity/Types/Partial.hs b/src/Calamity/Types/Partial.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Partial.hs @@ -0,0 +1,5 @@ +-- | Partial data family +module Calamity.Types.Partial + ( Partial ) where + +data family Partial t diff --git a/src/Calamity/Types/Snowflake.hs b/src/Calamity/Types/Snowflake.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Snowflake.hs @@ -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) diff --git a/src/Calamity/Types/Token.hs b/src/Calamity/Types/Token.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Token.hs @@ -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 diff --git a/src/Calamity/Types/UnixTimestamp.hs b/src/Calamity/Types/UnixTimestamp.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/UnixTimestamp.hs @@ -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