diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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. 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: 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 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 diff --git a/src/Calamity/Client/Client.hs b/src/Calamity/Client/Client.hs --- a/src/Calamity/Client/Client.hs +++ b/src/Calamity/Client/Client.hs @@ -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' diff --git a/src/Calamity/Client/Types.hs b/src/Calamity/Client/Types.hs --- a/src/Calamity/Client/Types.hs +++ b/src/Calamity/Client/Types.hs @@ -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 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 @@ -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'' 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 @@ -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 diff --git a/src/Calamity/Commands/Utils.hs b/src/Calamity/Commands/Utils.hs --- a/src/Calamity/Commands/Utils.hs +++ b/src/Calamity/Commands/Utils.hs @@ -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 diff --git a/src/Calamity/Gateway/Shard.hs b/src/Calamity/Gateway/Shard.hs --- a/src/Calamity/Gateway/Shard.hs +++ b/src/Calamity/Gateway/Shard.hs @@ -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 () diff --git a/src/Calamity/HTTP/Internal/Ratelimit.hs b/src/Calamity/HTTP/Internal/Ratelimit.hs --- a/src/Calamity/HTTP/Internal/Ratelimit.hs +++ b/src/Calamity/HTTP/Internal/Ratelimit.hs @@ -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 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 @@ -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 diff --git a/src/Calamity/HTTP/Internal/Route.hs b/src/Calamity/HTTP/Internal/Route.hs --- a/src/Calamity/HTTP/Internal/Route.hs +++ b/src/Calamity/HTTP/Internal/Route.hs @@ -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 diff --git a/src/Calamity/Internal/SnowflakeMap.hs b/src/Calamity/Internal/SnowflakeMap.hs --- a/src/Calamity/Internal/SnowflakeMap.hs +++ b/src/Calamity/Internal/SnowflakeMap.hs @@ -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 #-} diff --git a/src/Calamity/Internal/Utils.hs b/src/Calamity/Internal/Utils.hs --- a/src/Calamity/Internal/Utils.hs +++ b/src/Calamity/Internal/Utils.hs @@ -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 <$>) diff --git a/src/Calamity/Types/Model/Channel/ChannelType.hs b/src/Calamity/Types/Model/Channel/ChannelType.hs --- a/src/Calamity/Types/Model/Channel/ChannelType.hs +++ b/src/Calamity/Types/Model/Channel/ChannelType.hs @@ -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 diff --git a/src/Calamity/Types/Model/Channel/Guild.hs b/src/Calamity/Types/Model/Channel/Guild.hs --- a/src/Calamity/Types/Model/Channel/Guild.hs +++ b/src/Calamity/Types/Model/Channel/Guild.hs @@ -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" diff --git a/src/Calamity/Types/Model/Channel/Message.hs b/src/Calamity/Types/Model/Channel/Message.hs --- a/src/Calamity/Types/Model/Channel/Message.hs +++ b/src/Calamity/Types/Model/Channel/Message.hs @@ -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 diff --git a/src/Calamity/Types/Model/Presence/Activity.hs b/src/Calamity/Types/Model/Presence/Activity.hs --- a/src/Calamity/Types/Model/Presence/Activity.hs +++ b/src/Calamity/Types/Model/Presence/Activity.hs @@ -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 diff --git a/src/Calamity/Utils/Message.hs b/src/Calamity/Utils/Message.hs --- a/src/Calamity/Utils/Message.hs +++ b/src/Calamity/Utils/Message.hs @@ -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 -- diff --git a/src/Calamity/Utils/Permissions.hs b/src/Calamity/Utils/Permissions.hs --- a/src/Calamity/Utils/Permissions.hs +++ b/src/Calamity/Utils/Permissions.hs @@ -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 --