calamity 0.1.14.9 → 0.1.15.0

raw patch · 19 files changed

+85/−50 lines, 19 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• ChangeLog.md +8/−0
• calamity.cabal +4/−4
• src/Calamity/Client/Client.hs +1/−1
• src/Calamity/Client/Types.hs +2/−5
• src/Calamity/Commands/CommandUtils.hs +2/−2
• src/Calamity/Commands/Parser.hs +2/−2
• src/Calamity/Commands/Utils.hs +1/−1
• src/Calamity/Gateway/Shard.hs +12/−6
• src/Calamity/HTTP/Internal/Ratelimit.hs +7/−5
• src/Calamity/HTTP/Internal/Request.hs +2/−2
• src/Calamity/HTTP/Internal/Route.hs +4/−6
• src/Calamity/Internal/SnowflakeMap.hs +2/−0
• src/Calamity/Internal/Utils.hs +2/−2
• src/Calamity/Types/Model/Channel/ChannelType.hs +7/−2
• src/Calamity/Types/Model/Channel/Guild.hs +1/−1
• src/Calamity/Types/Model/Channel/Message.hs +11/−2
• src/Calamity/Types/Model/Presence/Activity.hs +8/−2
• src/Calamity/Utils/Message.hs +2/−1
• src/Calamity/Utils/Permissions.hs +7/−6

@@ -1,6 +1,14 @@ # Changelog for Calamity +## 0.1.15.0++* General cleanup of codebase++* Enable StrictData by default+ ## 0.1.14.9++*2020-06-22*  * Support manually invoking commands. 

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: f72f949bfceab606de1405fc387f5c350303bcb5a2b05af291acc246bbdb49ae+-- hash: 4b15c9b738742337c0b66ea62dee6c54be20a41b9161fe630a70cf58dddf1d1c  name:           calamity-version:        0.1.14.9+version:        0.1.15.0 synopsis:       A library for writing discord bots in haskell description:    Please see the README on GitHub at <https://github.com/nitros12/calamity#readme> category:       Network, Web@@ -134,8 +134,8 @@       Paths_calamity   hs-source-dirs:       src-  default-extensions: CPP AllowAmbiguousTypes BlockArguments NoMonomorphismRestriction 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 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 -fno-warn-name-shadowing+  default-extensions: StrictData CPP AllowAmbiguousTypes BlockArguments NoMonomorphismRestriction 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 MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings OverloadedLabels PartialTypeSignatures PatternGuards PolyKinds RankNTypes RecordWildCards ScopedTypeVariables TupleSections TypeFamilies TypeSynonymInstances ViewPatterns DuplicateRecordFields TypeOperators TypeApplications RoleAnnotations+  ghc-options: -fwrite-ide-info -hiedir=.hie -fplugin=Polysemy.Plugin -funbox-strict-fields -Wall -fno-warn-name-shadowing   build-depends:       aeson >=1.4 && <2     , async >=2.2 && <3

@@ -157,7 +157,7 @@ react handler = do   handler' <- bindSemToIO handler   ehidC <- P.asks (^. #ehidCounter)-  id' <- P.embed $ atomicModifyIORef ehidC (\i -> (succ i, i))+  id' <- P.embed $ atomicModifyIORef ehidC (\i -> (i + 1, i))   let handlers = makeEventHandlers (Proxy @s) id' (const () <.> handler')   P.atomicModify (handlers <>)   pure $ removeHandler @s id'

@@ -274,13 +274,10 @@  instance GetEventHandlers' 'True ('CustomEvt s a) where   getEventHandlers' _ _ _ = error "use getCustomEventHandlers instead"-    -- let handlerMap = unwrapEventHandler @('CustomEvt Void Dynamic) $ fromJust-    --       (TM.lookup handlers :: Maybe (EventHandler ('CustomEvt Void Dynamic)))-    -- in concat $ LH.lookup (typeRep $ Proxy @s) handlerMap >>= LH.lookup (typeRep $ Proxy @a) <&> map eh  instance (Typeable s, Typeable (StoredEHType s), EHStorageType s ~ [EventHandlerWithID (StoredEHType s)]) => GetEventHandlers' 'False s where   getEventHandlers' _ _ (EventHandlers handlers) =-    let theseHandlers = unwrapEventHandler @s $ fromJust (TM.lookup handlers :: Maybe (EventHandler s))+    let theseHandlers = unwrapEventHandler @s $ fromMaybe mempty (TM.lookup handlers :: Maybe (EventHandler s))     in map eh theseHandlers  @@ -306,6 +303,6 @@  getCustomEventHandlers :: TypeRep -> TypeRep -> EventHandlers -> [Dynamic -> IO ()] getCustomEventHandlers s a (EventHandlers handlers) =-    let handlerMap = unwrapEventHandler @('CustomEvt Void Dynamic) $ fromJust+    let handlerMap = unwrapEventHandler @('CustomEvt Void Dynamic) $ fromMaybe mempty           (TM.lookup handlers :: Maybe (EventHandler ('CustomEvt Void Dynamic)))     in map eh . concat $ LH.lookup s handlerMap >>= LH.lookup a

@@ -108,8 +108,8 @@   :: P.Member (P.Final IO) r => ((Context, a) -> P.Sem (P.Fail ': r) ()) -> P.Sem r ((Context, a) -> IO (Maybe L.Text)) buildCallback cb = do   cb' <- bindSemToIO (\x -> P.runFail (cb x) <&> \case-                        Left e -> Just $ L.pack e-                        _      -> Nothing)+                        Left e  -> Just $ L.pack e+                        Right _ -> Nothing)   let cb'' = fromMaybe (Just "failed internally") <.> cb'   pure cb'' 

@@ -230,7 +230,7 @@   offe <- getOffset   case r of     Just r' -> pure r'-    _       -> parseError . errFancy offs . fancy . ErrorCustom $ SpannedError e offs offe+    Nothing -> parseError . errFancy offs . fancy . ErrorCustom $ SpannedError e offs offe  -- | Parser for members in the guild the command was invoked in, this only looks -- in the cache. Use @'Snowflake' 'Member'@ and use@@ -308,7 +308,7 @@ ping' m = chunk "<" *> m *> snowflake <* chunk ">"  snowflake :: MonadParsec e L.Text m => m (Snowflake a)-snowflake = (Snowflake . read) <$> some digitChar+snowflake = Snowflake <$> decimal  partialEmoji :: MonadParsec e L.Text m => m (Partial Emoji) partialEmoji = do

@@ -141,7 +141,7 @@   let gchan = guild ^? _Just . #channels . ix (coerceSnowflake $ getID @Channel msg)   Just channel <- case gchan of     Just chan -> pure . pure $ GuildChannel' chan-    _         -> DMChannel' <<$>> getDM (coerceSnowflake $ getID @Channel msg)+    Nothing   -> DMChannel' <<$>> getDM (coerceSnowflake $ getID @Channel msg)   Just user <- getUser $ getID msg    pure $ Context msg guild member channel user command prefix unparsed

@@ -109,13 +109,19 @@     Just True  -> pure True     Nothing    -> pure False +restartUnless :: P.Members '[LogEff, P.Error ShardFlowControl] r => L.Text -> Maybe a -> P.Sem r a+restartUnless _   (Just a) = pure a+restartUnless msg Nothing  = do+  error msg+  P.throw ShardFlowRestart+ -- | The loop a shard will run on shardLoop :: ShardC r => Sem r () shardLoop = do   activeShards <- registerGauge "active_shards" mempty-  void $ modifyGauge succ activeShards+  void $ modifyGauge (+ 1) activeShards   void outerloop-  void $ modifyGauge pred activeShards+  void $ modifyGauge (subtract 1) activeShards   debug "Shard shut down"  where   controlStream :: Shard -> TBMQueue ShardMsg -> IO ()@@ -199,7 +205,7 @@                   , sessionID = s                   , seq = n                   })-      _ -> do+      _noActiveSession -> do         debug "Identifying shard"         sendToWs (Identify IdentifyData                   { token = shard ^. #token@@ -224,7 +230,7 @@         (fromEitherVoid <$>) . P.raise . P.runError . forever $ do           -- only we close the queue           msg <- P.embed . atomically $ readTBMQueue q-          handleMsg $ fromJust msg)+          handleMsg =<< restartUnless "shard message stream closed by someone other than the sink" msg)      debug "Exiting inner loop of shard" @@ -243,7 +249,7 @@         Ready rdata' ->           P.atomicModify (#sessionID ?~ (rdata' ^. #sessionID)) -        _ -> pure ()+        _NotReady -> pure ()        shard <- P.atomicGets (^. #shardS)       P.embed $ UC.writeChan (shard ^. #evtIn) (Dispatch (shard ^. #shardID) data')@@ -314,6 +320,6 @@   P.embed . threadDelay $ interval * 1000   unlessM (P.atomicGets (^. #hbResponse)) $ do     debug "No heartbeat response, restarting shard"-    wsConn <- fromJust <$> P.atomicGets (^. #wsConn)+    wsConn <- P.note () =<< P.atomicGets (^. #wsConn)     P.embed $ sendCloseCode wsConn 4000 ("No heartbeat in time" :: L.Text)     P.throw ()

@@ -67,7 +67,9 @@           let resp = r' ^. responseBody           debug $ "Got good response from discord: " +|| r' ^. responseStatus ||+ ""           pure $ if isExhausted r'-                then ExhaustedBucket resp $ parseRateLimitHeader r'+                then case parseRateLimitHeader r' of+                       Just sleepTime -> ExhaustedBucket resp sleepTime+                       Nothing        -> ServerError (status ^. statusCode)                 else Good resp         | status == status429 -> do           debug "Got 429 from discord, retrying."@@ -94,11 +96,11 @@   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+parseRateLimitHeader :: Response a -> Maybe Int+parseRateLimitHeader r = computeDiscordTimeDiff end <$> now  where   end = r ^?! responseHeader "X-Ratelimit-Reset" . _Double-  now = r ^?! responseHeader "Date" & parseDiscordTime & fromJust+  now = r ^?! responseHeader "Date" & parseDiscordTime  isExhausted :: Response a -> Bool isExhausted r = r ^? responseHeader "X-RateLimit-Remaining" == Just "0"@@ -131,7 +133,7 @@       Retry r | num_retries > max_retries -> do         debug $ "Request failed after " +| max_retries |+ " retries."         doFail $ Left r-      Retry _ -> retryInner (succ num_retries)+      Retry _ -> retryInner (num_retries + 1)       RFail r -> do         debug "Request failed due to error response."         doFail $ Left r

@@ -75,13 +75,13 @@        inFlightRequests <- registerGauge "inflight_requests" [("route", route' ^. #path)]       totalRequests <- registerCounter "total_requests" [("route", route' ^. #path)]-      void $ modifyGauge succ inFlightRequests+      void $ modifyGauge (+ 1) inFlightRequests       void $ addCounter 1 totalRequests        resp <- attr "route" (route' ^. #path) $ doRequest rlState' route'         (action a (requestOptions token') (route' ^. #path . unpacked)) -      void $ modifyGauge pred inFlightRequests+      void $ modifyGauge (subtract 1) inFlightRequests        P.runError $ (fromResult . fromJSON) =<< (fromJSONDecode . readResp) =<< extractRight resp 

@@ -104,13 +104,13 @@   type ConsRes S ids = RouteBuilder ids    (UnsafeMkRouteBuilder r ids) // (S t) =-    UnsafeMkRouteBuilder (S' t : r) ids+    UnsafeMkRouteBuilder (r <> [S' t]) 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+    UnsafeMkRouteBuilder (r <> [ID' (typeRep (Proxy @a))]) ids  infixl 5 // @@ -133,13 +133,11 @@   => RouteBuilder ids   -> Route buildRoute (UnsafeMkRouteBuilder route ids) = Route-  (T.intercalate "/" (baseURL : map goR route'))-  (T.concat (map goIdent 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 

@@ -106,6 +106,8 @@ (!) m k = unSnowflakeMap m LH.! k {-# INLINABLE (!) #-} +infixl 9 !+ insert :: HasID' a => a -> SnowflakeMap a -> SnowflakeMap a insert v = over $ LH.insert (getID v) v {-# INLINABLE insert #-}

@@ -42,8 +42,8 @@  whenM :: Monad m => m Bool -> m () -> m () whenM p m = p >>= \case-  True -> m-  _    -> pure ()+  True  -> m+  False -> pure ()  unlessM :: Monad m => m Bool -> m () -> m () unlessM = whenM . (not <$>)

@@ -24,6 +24,11 @@   toJSON t = Number $ fromIntegral (fromEnum t)  instance FromJSON ChannelType where-  parseJSON = withScientific "ChannelType" $ \n -> case toBoundedInteger n of-    Just v  -> pure $ toEnum v+  parseJSON = withScientific "ChannelType" $ \n -> case toBoundedInteger @Int n of+    Just v  -> case v of+      0 -> pure GuildTextType+      1 -> pure DMType+      2 -> pure GuildVoiceType+      4 -> pure GuildCategoryType+      _ -> fail $ "Invalid ChannelType: " <> show n     Nothing -> fail $ "Invalid ChannelType: " <> show n

@@ -41,7 +41,7 @@       GuildTextType     -> GuildTextChannel <$> parseJSON (Object v)       GuildVoiceType    -> GuildVoiceChannel <$> parseJSON (Object v)       GuildCategoryType -> GuildCategory <$> parseJSON (Object v)-      _                 -> fail "Not a valid guild channel"+      typ               -> fail $ "Not a valid guild channel: " <> show typ  instance HasID GuildChannel GuildChannel where   getID (GuildTextChannel a) = coerceSnowflake $ a ^. field' @"id"

@@ -69,6 +69,15 @@   deriving ( TextShow ) via TSG.FromGeneric MessageType  instance FromJSON MessageType where-  parseJSON = withScientific "MessageType" $ \n -> case toBoundedInteger n of-    Just v  -> pure $ toEnum v+  parseJSON = withScientific "MessageType" $ \n -> case toBoundedInteger @Int n of+    Just v  -> case v of+      0 -> pure Default+      1 -> pure RecipientAdd+      2 -> pure RecipientRemove+      3 -> pure Call+      4 -> pure ChannelNameChange+      5 -> pure ChannelIconChange+      6 -> pure ChannelPinnedMessage+      7 -> pure GuildMemberJoin+      _ -> fail $ "Invalid MessageType: " <> show n     Nothing -> fail $ "Invalid MessageType: " <> show n

@@ -27,6 +27,7 @@   = Game   | Streaming   | Listening+  | Custom   deriving ( Eq, Generic, Show, Enum )   deriving ( TextShow ) via TSG.FromGeneric ActivityType @@ -34,8 +35,13 @@   toJSON t = Number $ fromIntegral (fromEnum t)  instance FromJSON ActivityType where-  parseJSON = withScientific "ActivityType" $ \n -> case toBoundedInteger n of-    Just v  -> pure $ toEnum v+  parseJSON = withScientific "ActivityType" $ \n -> case toBoundedInteger @Int n of+    Just v  -> case v of+      0 -> pure Game+      1 -> pure Streaming+      2 -> pure Listening+      3 -> pure Custom+      _ -> fail $ "Invalid ActivityType: " <> show n     Nothing -> fail $ "Invalid ActivityType: " <> show n  data Activity = Activity

@@ -33,6 +33,7 @@ import Data.String (IsString, fromString) import qualified Data.Text.Lazy as L import TextShow (TextShow (showtl))+import Data.Foldable (Foldable(foldl'))  zws :: IsString s => s zws = fromString "\x200b"@@ -63,7 +64,7 @@  -- | Escape all discord formatting escapeFormatting :: L.Text -> L.Text-escapeFormatting = foldl (.) Prelude.id [escapeCodelines, escapeCodeblocks, escapeBold, escapeStrike, escapeUnderline, escapeSpoilers, escapeFormatting]+escapeFormatting = foldl' (.) Prelude.id [escapeCodelines, escapeCodeblocks, escapeBold, escapeStrike, escapeUnderline, escapeSpoilers, escapeFormatting]  -- | Formats a lang and content into a codeblock --

@@ -21,6 +21,7 @@ import qualified Data.Vector.Unboxed                    as V  import qualified Polysemy                               as P+import Data.Foldable (Foldable(foldl'))  -- | Calculate a 'Member''s 'Permissions' in a 'Guild' basePermissions :: Guild -> Member -> Permissions@@ -29,7 +30,7 @@   | otherwise = let everyoneRole  = g ^. #roles . at (coerceSnowflake $ getID @Guild g)                     permsEveryone = maybe noFlags (^. #permissions) everyoneRole                     rolePerms     = g ^.. #roles . foldMap ix (V.toList $ m ^. #roles) . #permissions-                    perms         = foldl andFlags noFlags (permsEveryone:rolePerms)+                    perms         = foldl' andFlags noFlags (permsEveryone:rolePerms)                 in if perms .<=. administrator                    then allFlags                    else perms@@ -45,8 +46,8 @@         p'                = p .-. everyoneDeny .+. everyoneAllow         roleOverwrites    = c ^.. #permissionOverwrites . foldMap ix           (map (coerceSnowflake @_ @Overwrite) . V.toList $ m ^. #roles)-        roleAllow         = foldl andFlags noFlags (roleOverwrites ^.. traverse . #allow)-        roleDeny          = foldl andFlags noFlags (roleOverwrites ^.. traverse . #deny)+        roleAllow         = foldl' andFlags noFlags (roleOverwrites ^.. traverse . #allow)+        roleDeny          = foldl' andFlags noFlags (roleOverwrites ^.. traverse . #deny)         p''               = p' .-. roleDeny .+. roleAllow         memberOverwrite   = c ^. #permissionOverwrites . at (coerceSnowflake @_ @Overwrite $ getID @Member m)         memberAllow       = maybe noFlags (^. #allow) memberOverwrite@@ -86,7 +87,7 @@     g <- upgrade (getID @Guild c)     case (m, g) of       (Just m, Just g') -> pure $ permissionsIn (g', c) m-      _                 -> pure noFlags+      _cantFind         -> pure noFlags  -- | A 'Member''s 'Permissions' in a guild are just their roles instance PermissionsIn' Guild where@@ -103,8 +104,8 @@   permissionsIn' cid u = do     c <- upgrade cid     case c of-      Just c' -> permissionsIn' c' u-      _       -> pure noFlags+      Just c'  -> permissionsIn' c' u+      Nothing  -> pure noFlags  -- | A 'Member''s 'Permissions' in a guild are just their roles --