diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,13 @@ # Changelog for Calamity +## 0.1.10.0 + +* Renamed `Calamity.Commands.Parser.KleeneConcat` to + `Calamity.Commands.Parser.KleeneStarConcat` and added + `Calamity.Commands.Parser.KleenePlusConcat` + +* Added `Calamity.Types.Upgradeable` + ## 0.1.9.2 *2020-05-23* diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -107,7 +107,7 @@ main :: IO () main = do token <- view packed <$> getEnv "BOT_TOKEN" - void . P.runFinal . P.embedToFinal . runCounterAtomic . runCacheInMemory . runMetricsPrometheusIO . useConstantPrefix "!" + void . P.runFinal . P.embedToFinal . runCounterAtomic . runCacheInMemory . runMetricsNoop . useConstantPrefix "!" $ runBotIO (BotToken token) $ do addCommands $ do helpCommand @@ -126,7 +126,7 @@ val <- getCounter void $ tellt ctx ("The value is: " <> showtl val) group "say" $ do - command @'[KleeneConcat L.Text] "this" $ \ctx msg -> do + command @'[KleenePlusConcat L.Text] "this" $ \ctx msg -> do void $ tellt ctx msg command @'[Snowflake Emoji] "etest" $ \ctx e -> do void $ tellt ctx $ "got emoji: " <> showtl e diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack -- --- hash: d09b5d61b03cb493c415218e661c595c070b5c50807b090c8689f0cbe15a9782 +-- hash: 386f342de92acd940a2fa9856b8efa38f04e137426a3c6100bcbeaadb5ac5e17 name: calamity -version: 0.1.9.4 +version: 0.1.10 synopsis: A library for writing discord bots description: Please see the README on GitHub at category: Network, Web @@ -121,6 +121,7 @@ Calamity.Types.Tellable Calamity.Types.Token Calamity.Types.UnixTimestamp + Calamity.Types.Upgradeable other-modules: Paths_calamity hs-source-dirs: diff --git a/src/Calamity/Cache/Eff.hs b/src/Calamity/Cache/Eff.hs --- a/src/Calamity/Cache/Eff.hs +++ b/src/Calamity/Cache/Eff.hs @@ -9,6 +9,7 @@ , setGuild , updateGuild , getGuild + , getGuildChannel , getGuilds , delGuild , setDM @@ -53,6 +54,8 @@ SetGuild :: Guild -> CacheEff m () -- | Get a 'Guild' from the cache GetGuild :: Snowflake Guild -> CacheEff m (Maybe Guild) + -- | Get a 'GuildChannel' from the cache + GetGuildChannel :: Snowflake GuildChannel -> CacheEff m (Maybe GuildChannel) -- | Get all 'Guild's from the cache GetGuilds :: CacheEff m [Guild] -- | Delete a 'Guild' from the cache diff --git a/src/Calamity/Cache/InMemory.hs b/src/Calamity/Cache/InMemory.hs --- a/src/Calamity/Cache/InMemory.hs +++ b/src/Calamity/Cache/InMemory.hs @@ -14,6 +14,8 @@ import Control.Lens import Control.Monad.State.Strict +import qualified Data.HashMap.Lazy as LH + import Data.Default.Class import Data.Foldable import qualified Data.HashSet as LS @@ -28,7 +30,7 @@ { user :: Maybe User , guilds :: SM.SnowflakeMap Guild , dms :: SM.SnowflakeMap DMChannel - , channels :: SM.SnowflakeMap GuildChannel + , guildChannels :: LH.HashMap (Snowflake GuildChannel) Guild , users :: SM.SnowflakeMap User , unavailableGuilds :: LS.HashSet (Snowflake Guild) , messages :: BoundedStore Message @@ -36,7 +38,7 @@ deriving ( Generic, Show ) emptyCache :: Cache -emptyCache = Cache Nothing SM.empty SM.empty SM.empty SM.empty LS.empty def +emptyCache = Cache Nothing SM.empty SM.empty LH.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 @@ -51,10 +53,16 @@ runCache (SetBotUser u) = #user ?= u runCache GetBotUser = use #user -runCache (SetGuild g) = #guilds %= SM.insert g +runCache (SetGuild g) = do + #guilds %= SM.insert g + #guildChannels %= LH.filter (\v -> getID @Guild v /= getID @Guild g) + #guildChannels %= LH.union (LH.fromList $ map (,g) (SM.keys (g ^. #channels))) runCache (GetGuild gid) = use (#guilds . at gid) +runCache (GetGuildChannel cid) = use (#guildChannels . at cid) <&> (>>= (^. #channels . at cid)) runCache GetGuilds = SM.elems <$> use #guilds -runCache (DelGuild gid) = #guilds %= sans gid +runCache (DelGuild gid) = do + #guilds %= sans gid + #guildChannels %= LH.filter (\v -> getID @Guild v /= gid) runCache (SetDM dm) = #dms %= SM.insert dm runCache (GetDM did) = use (#dms . at did) diff --git a/src/Calamity/Commands/CommandUtils.hs b/src/Calamity/Commands/CommandUtils.hs --- a/src/Calamity/Commands/CommandUtils.hs +++ b/src/Calamity/Commands/CommandUtils.hs @@ -69,7 +69,7 @@ -- Building a command that bans a user by id. -- -- @ --- 'buildCommand' @\'['Named' "user" ('Snowflake' 'User'), 'Named' "reason" ('KleeneConcat' 'S.Text')] +-- 'buildCommand' @\'['Named' "user" ('Snowflake' 'User'), 'Named' "reason" ('KleeneStarConcat' 'S.Text')] -- "ban" 'Nothing' [] ('const' "Ban a user") $ \ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of -- 'Just' guild -> do -- 'void' . 'Calamity.HTTP.invoke' . 'Calamity.HTTP.reason' r $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid diff --git a/src/Calamity/Commands/Dsl.hs b/src/Calamity/Commands/Dsl.hs --- a/src/Calamity/Commands/Dsl.hs +++ b/src/Calamity/Commands/Dsl.hs @@ -73,7 +73,7 @@ -- -- @ -- 'command' \@\'['Calamity.Commands.Parser.Named' "user" ('Calamity.Types.Snowflake' 'Calamity.Types.Model.User'), --- 'Calamity.Commands.Parser.Named' "reason" ('Calamity.Commands.Parser.KleeneConcat' 'S.Text')] +-- 'Calamity.Commands.Parser.Named' "reason" ('Calamity.Commands.Parser.KleeneStarConcat' 'S.Text')] -- "ban" $ \ctx uid r -> case (ctx 'Control.Lens.^.' #guild) of -- 'Just' guild -> do -- 'Control.Monad.void' . 'Calamity.HTTP.invoke' . 'Calamity.HTTP.reason' r $ 'Calamity.HTTP.Guild.CreateGuildBan' guild uid diff --git a/src/Calamity/Commands/Parser.hs b/src/Calamity/Commands/Parser.hs --- a/src/Calamity/Commands/Parser.hs +++ b/src/Calamity/Commands/Parser.hs @@ -2,7 +2,8 @@ module Calamity.Commands.Parser ( Parser(..) , Named - , KleeneConcat + , KleeneStarConcat + , KleenePlusConcat , runCommandParser ) where import Calamity.Cache.Eff @@ -19,6 +20,7 @@ import Data.Char ( isSpace ) import Data.Kind import Data.List.NonEmpty ( NonEmpty(..) ) +import Data.Semigroup import qualified Data.Text as S import qualified Data.Text.Lazy as L import Data.Typeable @@ -118,26 +120,48 @@ -- | A parser that consumes zero or more of @a@ then concatenates them together. -- --- @'KleeneConcat' 'L.Text'@ Is therefore consumes all remaining input. -data KleeneConcat (a :: Type) +-- @'KleeneStarConcat' 'L.Text'@ Is therefore consumes all remaining input. +data KleeneStarConcat (a :: Type) -instance (Monoid (ParserResult a), Parser a r) => Parser (KleeneConcat a) r where - type ParserResult (KleeneConcat a) = ParserResult a +instance (Monoid (ParserResult a), Parser a r) => Parser (KleeneStarConcat a) r where + type ParserResult (KleeneStarConcat a) = ParserResult a parse = mconcat <$> parse @[a] -instance {-# OVERLAPS #-}Parser (KleeneConcat L.Text) r where - type ParserResult (KleeneConcat L.Text) = ParserResult L.Text +instance {-# OVERLAPS #-}Parser (KleeneStarConcat L.Text) r where + type ParserResult (KleeneStarConcat L.Text) = ParserResult L.Text -- consume rest on text just takes everything remaining - parse = parseMP (parserName @(KleeneConcat L.Text)) someSingle + parse = parseMP (parserName @(KleeneStarConcat L.Text)) manySingle -instance {-# OVERLAPS #-}Parser (KleeneConcat S.Text) r where - type ParserResult (KleeneConcat S.Text) = ParserResult S.Text +instance {-# OVERLAPS #-}Parser (KleeneStarConcat S.Text) r where + type ParserResult (KleeneStarConcat S.Text) = ParserResult S.Text -- consume rest on text just takes everything remaining - parse = parseMP (parserName @(KleeneConcat S.Text)) (L.toStrict <$> someSingle) + parse = parseMP (parserName @(KleeneStarConcat S.Text)) (L.toStrict <$> manySingle) +-- | A parser that consumes one or more of @a@ then concatenates them together. +-- +-- @'KleenePlusConcat' 'L.Text'@ Is therefore consumes all remaining input. +data KleenePlusConcat (a :: Type) + +instance (Monoid (ParserResult a), Parser a r) => Parser (KleenePlusConcat a) r where + type ParserResult (KleenePlusConcat a) = ParserResult a + + parse = sconcat <$> parse @(NonEmpty a) + +instance {-# OVERLAPS #-}Parser (KleenePlusConcat L.Text) r where + type ParserResult (KleenePlusConcat L.Text) = ParserResult L.Text + + -- consume rest on text just takes everything remaining + parse = parseMP (parserName @(KleenePlusConcat L.Text)) someSingle + +instance {-# OVERLAPS #-}Parser (KleenePlusConcat S.Text) r where + type ParserResult (KleenePlusConcat S.Text) = ParserResult S.Text + + -- consume rest on text just takes everything remaining + parse = parseMP (parserName @(KleenePlusConcat S.Text)) (L.toStrict <$> someSingle) + instance Typeable (Snowflake a) => Parser (Snowflake a) r where parse = parseMP (parserName @(Snowflake a)) snowflake @@ -226,8 +250,8 @@ item :: MonadParsec e L.Text m => m L.Text item = try quotedString <|> someNonWS --- manySingle :: MonadParsec e s m => m (Tokens s) --- manySingle = takeWhileP (Just "Any character") (const True) +manySingle :: MonadParsec e s m => m (Tokens s) +manySingle = takeWhileP (Just "Any character") (const True) someSingle :: MonadParsec e s m => m (Tokens s) someSingle = takeWhile1P (Just "any character") (const True) diff --git a/src/Calamity/HTTP/Internal/Request.hs b/src/Calamity/HTTP/Internal/Request.hs --- a/src/Calamity/HTTP/Internal/Request.hs +++ b/src/Calamity/HTTP/Internal/Request.hs @@ -15,7 +15,6 @@ import Calamity.HTTP.Internal.Ratelimit import Calamity.HTTP.Internal.Route import Calamity.HTTP.Internal.Types -import Calamity.Internal.Utils import Calamity.Metrics.Eff import Calamity.Types.Token @@ -38,8 +37,6 @@ import qualified Polysemy as P import qualified Polysemy.Error as P import qualified Polysemy.Reader as P - -import TextShow fromResult :: P.Member (P.Error RestError) r => Data.Aeson.Result a -> Sem r a fromResult (Success a) = pure a diff --git a/src/Calamity/Internal/BoundedStore.hs b/src/Calamity/Internal/BoundedStore.hs --- a/src/Calamity/Internal/BoundedStore.hs +++ b/src/Calamity/Internal/BoundedStore.hs @@ -12,20 +12,20 @@ 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 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 qualified Deque.Lazy as DQ +import Deque.Lazy ( Deque ) import GHC.Generics data BoundedStore a = BoundedStore { itemQueue :: Deque (Snowflake a) , items :: HashMap (Snowflake a) a - , limit :: Int - , size :: Int + , limit :: Int + , size :: Int } deriving ( Show, Generic ) @@ -36,6 +36,7 @@ def = BoundedStore mempty H.empty 1000 0 type instance (Index (BoundedStore a)) = Snowflake a + type instance (IxValue (BoundedStore a)) = a instance HasID' a => Ixed (BoundedStore a) @@ -51,14 +52,14 @@ addItem :: HasID' a => a -> BoundedStore a -> BoundedStore a addItem m = execState $ do - unlessM (H.member (getID m) <$> use #items) do + unlessM (H.member (getID m) <$> use #items) $ do #itemQueue %= DQ.cons (getID m) #size += 1 size <- use #size limit <- use #limit - when (size > limit) do + when (size > limit) $ do q <- use #itemQueue let Just (rid, q') = DQ.unsnoc q #itemQueue .= q' @@ -76,7 +77,7 @@ dropItem :: Snowflake a -> BoundedStore a -> BoundedStore a dropItem id = execState $ do - whenM (H.member id <$> use #items) do + whenM (H.member id <$> use #items) $ do #size -= 1 #itemQueue %= DQ.filter (/= id) diff --git a/src/Calamity/Types.hs b/src/Calamity/Types.hs --- a/src/Calamity/Types.hs +++ b/src/Calamity/Types.hs @@ -5,6 +5,7 @@ , module Calamity.Types.Snowflake , module Calamity.Types.Token , module Calamity.Types.Tellable + , module Calamity.Types.Upgradeable , module Calamity.Types.UnixTimestamp -- * Types -- $typesDocs @@ -15,11 +16,15 @@ import Calamity.Types.Snowflake import Calamity.Types.Token import Calamity.Types.Tellable +import Calamity.Types.Upgradeable import Calamity.Types.UnixTimestamp -- $typesDocs -- -- This module collects all discord models, and other useful types together. -- --- The 'Tellable' class is also in here, which allows you to construct and send +-- The 'Tellable' class allows you to construct and send -- messages to things to you can send messages to in a neat way. +-- +-- The 'Upgradeable' class allows you to upgrade a snowflake to the full value +-- it refers to. diff --git a/src/Calamity/Types/Upgradeable.hs b/src/Calamity/Types/Upgradeable.hs new file mode 100644 --- /dev/null +++ b/src/Calamity/Types/Upgradeable.hs @@ -0,0 +1,93 @@ +-- | Things that can be upgraded from snowflakes to their full data +module Calamity.Types.Upgradeable + ( Upgradeable(..) ) where + +import Calamity.Cache.Eff +import Calamity.Client.Types +import Calamity.HTTP as H +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.Applicative +import Control.Lens + +import Data.Generics.Sum.Constructors + +import qualified Polysemy as P +import qualified Polysemy.Fail as P +import qualified Polysemy.NonDet as P + +class Upgradeable a ids | a -> ids, ids -> a where + upgrade :: BotC r => ids -> P.Sem r (Maybe a) + +maybeToAlt :: Alternative f => Maybe a -> f a +maybeToAlt (Just x) = pure x +maybeToAlt Nothing = empty + +instance Upgradeable User (Snowflake User) where + upgrade uid = P.runNonDetMaybe ((getUser uid >>= maybeToAlt) <|> gethttp) + where + gethttp = P.failToNonDet $ do + Right u <- invoke $ H.GetUser uid + setUser u + pure u + +instance Upgradeable Member (Snowflake Guild, Snowflake Member) where + upgrade (gid, mid) = P.runNonDetMaybe (getcache <|> gethttp) + where + getcache = P.failToNonDet $ do + Just g <- getGuild gid + Just m <- pure (g ^. #members . at mid) + pure m + gethttp = P.failToNonDet $ do + Right m <- invoke $ H.GetGuildMember gid (coerceSnowflake @_ @User mid) + -- getcache could have failed becuase the member wasn't cached + updateGuild gid (#members . at mid ?~ m) + pure m + +instance Upgradeable Guild (Snowflake Guild) where + upgrade gid = P.runNonDetMaybe ((getGuild gid >>= maybeToAlt) <|> gethttp) + where + gethttp = P.failToNonDet $ do + Right g <- invoke $ H.GetGuild gid + pure g + +insertChannel :: BotC r => Channel -> P.Sem r () +insertChannel (DMChannel' dm) = setDM dm +insertChannel (GuildChannel' ch) = + updateGuild (getID ch) (#channels . at (getID @GuildChannel ch) ?~ ch) +insertChannel _ = pure () + +instance Upgradeable Channel (Snowflake Channel) where + upgrade cid = P.runNonDetMaybe (getcacheDM <|> getcacheGuild <|> gethttp) + where + getcacheDM = DMChannel' <<$>> getDM (coerceSnowflake cid) >>= maybeToAlt + getcacheGuild = GuildChannel' <<$>> getGuildChannel (coerceSnowflake cid) >>= maybeToAlt + gethttp = P.failToNonDet $ do + Right c <- invoke $ H.GetChannel cid + insertChannel c + pure c + +instance Upgradeable GuildChannel (Snowflake GuildChannel) where + upgrade cid = P.runNonDetMaybe (getcache <|> gethttp) + where + getcache = getGuildChannel (coerceSnowflake cid) >>= maybeToAlt + gethttp = P.failToNonDet $ do + Right c <- invoke $ H.GetChannel (coerceSnowflake @_ @Channel cid) + insertChannel c + maybeToAlt (c ^? _Ctor @"GuildChannel'") + +instance Upgradeable Emoji (Snowflake Guild, Snowflake Emoji) where + upgrade (gid, eid) = P.runNonDetMaybe (getcache <|> gethttp) + where + getcache = P.failToNonDet $ do + Just g <- getGuild gid + Just m <- pure (g ^. #emojis . at eid) + pure m + gethttp = P.failToNonDet $ do + Right e <- invoke $ H.GetGuildEmoji gid eid + updateGuild gid (#emojis . at eid ?~ e) + pure e