discord-haskell 1.6.1 → 1.7.0

raw patch · 17 files changed

+108/−104 lines, 17 filesdep +mtldep +unliftioPVP ok

version bump matches the API change (PVP)

Dependencies added: mtl, unliftio

API changes (from Hackage documentation)

Files

• README.md +7/−6
• discord-haskell.cabal +4/−2
• examples/ping-pong.hs +17/−16
• src/Discord.hs +59/−52
• src/Discord/Internal/Gateway/Cache.hs +0/−1
• src/Discord/Internal/Gateway/EventLoop.hs +4/−5
• src/Discord/Internal/Rest/Channel.hs +0/−1
• src/Discord/Internal/Rest/Emoji.hs +0/−1
• src/Discord/Internal/Rest/Guild.hs +0/−1
• src/Discord/Internal/Rest/HTTP.hs +2/−3
• src/Discord/Internal/Rest/Invite.hs +0/−1
• src/Discord/Internal/Rest/Prelude.hs +1/−2
• src/Discord/Internal/Rest/User.hs +0/−1
• src/Discord/Internal/Rest/Webhook.hs +0/−1
• src/Discord/Internal/Types/Channel.hs +6/−1
• src/Discord/Internal/Types/Gateway.hs +7/−9
• src/Discord/Internal/Types/Prelude.hs +1/−1

@@ -7,9 +7,10 @@  import Control.Monad (when) import Data.Text (isPrefixOf, toLower, Text)-import Control.Concurrent (threadDelay) import qualified Data.Text.IO as TIO +import UnliftIO+ import Discord import Discord.Types import qualified Discord.Requests as R@@ -21,12 +22,12 @@                                             , discordOnEvent = eventHandler }                      TIO.putStrLn userFacingError -eventHandler :: DiscordHandle -> Event -> IO ()-eventHandler dis event = case event of+eventHandler :: Event -> DiscordHandler ()+eventHandler event = case event of        MessageCreate m -> when (not (fromBot m) && isPing (messageText m)) $ do-               _ <- restCall dis (R.CreateReaction (messageChannel m, messageId m) "eyes")+               _ <- restCall (R.CreateReaction (messageChannel m, messageId m) "eyes")                threadDelay (4 * 10^6)-               _ <- restCall dis (R.CreateMessage (messageChannel m) "Pong!")+               _ <- restCall (R.CreateMessage (messageChannel m) "Pong!")                pure ()        _ -> pure () @@ -94,7 +95,7 @@ `CreateEmbed` has a `Default` instance, so you only need to specify the fields you use:  ```haskell-_ <- restCall dis (R.CreateMessageEmbed <channel_id> "Pong!" $+_ <- restCall (R.CreateMessageEmbed <channel_id> "Pong!" $         def { createEmbedTitle = "Pong Embed"             , createEmbedImage = Just $ CreateEmbedImageUpload <bytestring>             , createEmbedThumbnail = Just $ CreateEmbedImageUrl

@@ -1,7 +1,7 @@ cabal-version:       2.0 name:                discord-haskell -- library version is also noted at src/Discord/Rest/Prelude.hs-version:             1.6.1+version:             1.7.0 description:         Functions and data types to write discord bots.                      Official discord docs <https://discord.com/developers/docs/reference>.                      .@@ -32,6 +32,7 @@                        -threaded   build-depends:       base                      , text+                     , unliftio                      , discord-haskell  library@@ -86,4 +87,5 @@                      , vector                      , websockets                      , wuss-+                     , mtl+                     , unliftio

@@ -1,11 +1,12 @@ {-# LANGUAGE OverloadedStrings #-}  -- allows "strings" to be Data.Text  import Control.Monad (when, forM_)-import Control.Concurrent (threadDelay)-import Data.Char (toLower) import qualified Data.Text as T import qualified Data.Text.IO as TIO +import UnliftIO (liftIO)+import UnliftIO.Concurrent+ import Discord import Discord.Types import qualified Discord.Requests as R@@ -22,34 +23,34 @@   -- open ghci and run  [[ :info RunDiscordOpts ]] to see available fields   t <- runDiscord $ def { discordToken = tok                         , discordOnStart = startHandler-                        , discordOnEnd = putStrLn "Ended"+                        , discordOnEnd = liftIO $ putStrLn "Ended"                         , discordOnEvent = eventHandler                         , discordOnLog = \s -> TIO.putStrLn s >> TIO.putStrLn ""                         }-  threadDelay (1 `div` 10 * 10^6)+  threadDelay (1 `div` 10 * 10^(6 :: Int))   TIO.putStrLn t  -- If the start handler throws an exception, discord-haskell will gracefully shutdown --     Use place to execute commands you know you want to complete-startHandler :: DiscordHandle -> IO ()-startHandler dis = do-  Right partialGuilds <- restCall dis R.GetCurrentUserGuilds+startHandler :: DiscordHandler ()+startHandler = do+  Right partialGuilds <- restCall R.GetCurrentUserGuilds    forM_ partialGuilds $ \pg -> do-    Right guild <- restCall dis $ R.GetGuild (partialGuildId pg)-    Right chans <- restCall dis $ R.GetGuildChannels (guildId guild)+    Right guild <- restCall $ R.GetGuild (partialGuildId pg)+    Right chans <- restCall $ R.GetGuildChannels (guildId guild)     case filter isTextChannel chans of-      (c:_) -> do _ <- restCall dis $ R.CreateMessage (channelId c) "Hello! I will reply to pings with pongs"+      (c:_) -> do _ <- restCall $ R.CreateMessage (channelId c) "Hello! I will reply to pings with pongs"                   pure ()       _ -> pure ()  -- If an event handler throws an exception, discord-haskell will continue to run-eventHandler :: DiscordHandle -> Event -> IO ()-eventHandler dis event = case event of+eventHandler :: Event -> DiscordHandler ()+eventHandler event = case event of       MessageCreate m -> when (not (fromBot m) && isPing m) $ do-        _ <- restCall dis (R.CreateReaction (messageChannel m, messageId m) "eyes")-        threadDelay (4 * 10^6)-        _ <- restCall dis (R.CreateMessage (messageChannel m) "Pong!")+        _ <- restCall (R.CreateReaction (messageChannel m, messageId m) "eyes")+        threadDelay (4 * 10^(6 :: Int))+        _ <- restCall (R.CreateMessage (messageChannel m) "Pong!")         pure ()       _ -> pure () @@ -61,4 +62,4 @@ fromBot m = userIsBot (messageAuthor m)  isPing :: Message -> Bool-isPing = ("ping" `T.isPrefixOf`) . T.map toLower . messageText+isPing = ("ping" `T.isPrefixOf`) . T.toLower . messageText

@@ -9,6 +9,8 @@   , readCache   , stopDiscord +  , DiscordHandler+   , DiscordHandle   , Cache(..)   , RestCallErrorCode(..)@@ -18,37 +20,36 @@   ) where  import Prelude hiding (log)-import Control.Monad (forever, void)-import Control.Concurrent (forkIO, threadDelay, ThreadId, killThread)-import Control.Concurrent.Async (race)-import Control.Exception.Safe (try, finally, IOException, SomeException)-import Control.Concurrent.Chan-import Control.Concurrent.MVar+import Control.Monad.Reader import Data.Aeson (FromJSON) import Data.Default (Default, def) import qualified Data.Text as T import qualified Data.Text.Encoding as TE +import UnliftIO (race, try, finally, SomeException, IOException)+import UnliftIO.Concurrent+ import Discord.Handle import Discord.Internal.Rest import Discord.Internal.Rest.User (UserRequest(GetCurrentUser)) import Discord.Internal.Gateway +type DiscordHandler = ReaderT DiscordHandle IO  data RunDiscordOpts = RunDiscordOpts   { discordToken :: T.Text-  , discordOnStart :: DiscordHandle -> IO ()+  , discordOnStart :: DiscordHandler ()   , discordOnEnd :: IO ()-  , discordOnEvent :: DiscordHandle -> Event -> IO ()+  , discordOnEvent :: Event -> DiscordHandler ()   , discordOnLog :: T.Text -> IO ()   , discordForkThreadForEvents :: Bool   }  instance Default RunDiscordOpts where   def = RunDiscordOpts { discordToken = ""-                       , discordOnStart = \_ -> pure ()+                       , discordOnStart = pure ()                        , discordOnEnd = pure ()-                       , discordOnEvent = \_ _-> pure ()+                       , discordOnEvent = \_ -> pure ()                        , discordOnLog = \_ -> pure ()                        , discordForkThreadForEvents = True                        }@@ -56,10 +57,10 @@ runDiscord :: RunDiscordOpts -> IO T.Text runDiscord opts = do   log <- newChan-  logId <- startLogger (discordOnLog opts) log-  (cache, cacheId) <- startCacheThread log-  (rest, restId) <- startRestThread (Auth (discordToken opts)) log-  (gate, gateId) <- startGatewayThread (Auth (discordToken opts)) cache log+  logId <- liftIO $ startLogger (discordOnLog opts) log+  (cache, cacheId) <- liftIO $ startCacheThread log+  (rest, restId) <- liftIO $ startRestThread (Auth (discordToken opts)) log+  (gate, gateId) <- liftIO $ startGatewayThread (Auth (discordToken opts)) cache log    libE <- newEmptyMVar @@ -76,19 +77,19 @@                                  ]                              } -  finally (runDiscordLoop opts handle)-          (discordOnEnd opts >> stopDiscord handle)+  finally (runDiscordLoop handle opts)+          (discordOnEnd opts >> runReaderT stopDiscord handle) -runDiscordLoop :: RunDiscordOpts -> DiscordHandle -> IO T.Text-runDiscordLoop opts handle = do-  resp <- writeRestCall (discordHandleRestChan handle) GetCurrentUser+runDiscordLoop :: DiscordHandle -> RunDiscordOpts -> IO T.Text+runDiscordLoop handle opts = do+  resp <- liftIO $ writeRestCall (discordHandleRestChan handle) GetCurrentUser   case resp of     Left (RestCallInternalErrorCode c e1 e2) -> libError $              "HTTP Error Code " <> T.pack (show c) <> " " <> TE.decodeUtf8 e1                                                    <> " " <> TE.decodeUtf8 e2     Left (RestCallInternalHttpException e) -> libError ("HTTP Exception -  " <> T.pack (show e))     Left (RestCallInternalNoParse _ _) -> libError "Couldn't parse GetCurrentUser"-    _ -> do me <- try (discordOnStart opts handle)+    _ -> do me <- liftIO . runReaderT (try $ discordOnStart opts) $ handle             case me of               Left (e :: SomeException) -> libError ("discordOnStart handler stopped on an exception:\n\n" <> T.pack (show e))               Right _ -> loop@@ -104,7 +105,7 @@                Right (Right event) -> do                  let action = if discordForkThreadForEvents opts then void . forkIO                                                                  else id-                 action $ do me <- try (discordOnEvent opts handle event)+                 action $ do me <- liftIO . runReaderT (try $ discordOnEvent opts event) $ handle                              case me of                                Left (e :: SomeException) -> writeChan (discordHandleLog handle)                                          ("discord-haskell stopped on an exception:\n\n" <> T.pack (show e))@@ -117,44 +118,50 @@   deriving (Show, Eq, Ord)  -- | Execute one http request and get a response-restCall :: (FromJSON a, Request (r a)) => DiscordHandle -> r a -> IO (Either RestCallErrorCode a)-restCall h r = do empty <- isEmptyMVar (discordHandleLibraryError h)-                  if not empty-                  then pure (Left (RestCallErrorCode 400 "Library Stopped Working" ""))-                  else do-                      resp <- writeRestCall (discordHandleRestChan h) r-                      case resp of-                        Right x -> pure (Right x)-                        Left (RestCallInternalErrorCode c e1 e2) ->-                          pure (Left (RestCallErrorCode c (TE.decodeUtf8 e1) (TE.decodeUtf8 e2)))-                        Left (RestCallInternalHttpException _) ->-                          threadDelay (10 * 10^6) >> restCall h r-                        Left (RestCallInternalNoParse err dat) -> do-                          let formaterr = T.pack ("Parse Exception " <> err <> " for " <> show dat)-                          writeChan (discordHandleLog h) formaterr-                          pure (Left (RestCallErrorCode 400 "Library Stopped Working" formaterr))+restCall :: (FromJSON a, Request (r a)) => r a -> DiscordHandler (Either RestCallErrorCode a)+restCall r = do h <- ask+                empty <- isEmptyMVar (discordHandleLibraryError h)+                if not empty+                then pure (Left (RestCallErrorCode 400 "Library Stopped Working" ""))+                else do+                    resp <- liftIO $ writeRestCall (discordHandleRestChan h) r+                    case resp of+                      Right x -> pure (Right x)+                      Left (RestCallInternalErrorCode c e1 e2) ->+                        pure (Left (RestCallErrorCode c (TE.decodeUtf8 e1) (TE.decodeUtf8 e2)))+                      Left (RestCallInternalHttpException _) ->+                        threadDelay (10 * 10^(6 :: Int)) >> restCall r+                      Left (RestCallInternalNoParse err dat) -> do+                        let formaterr = T.pack ("Parse Exception " <> err <> " for " <> show dat)+                        writeChan (discordHandleLog h) formaterr+                        pure (Left (RestCallErrorCode 400 "Library Stopped Working" formaterr))  -- | Send a GatewaySendable, but not Heartbeat, Identify, or Resume-sendCommand :: DiscordHandle -> GatewaySendable -> IO ()-sendCommand h e = case e of-                    Heartbeat _ -> pure ()-                    Identify {} -> pure ()-                    Resume {} -> pure ()-                    _ -> writeChan (snd (discordHandleGateway h)) e+sendCommand :: GatewaySendable -> DiscordHandler ()+sendCommand e = do+  h <- ask+  case e of+    Heartbeat _ -> pure ()+    Identify {} -> pure ()+    Resume {} -> pure ()+    _ -> writeChan (snd (discordHandleGateway h)) e  -- | Access the current state of the gateway cache-readCache :: DiscordHandle -> IO Cache-readCache h = do merr <- readMVar (snd (discordHandleCache h))-                 case merr of-                   Left (c, _) -> pure c-                   Right c -> pure c+readCache :: DiscordHandler Cache+readCache = do+  h <- ask+  merr <- readMVar (snd (discordHandleCache h))+  case merr of+    Left (c, _) -> pure c+    Right c -> pure c   -- | Stop all the background threads-stopDiscord :: DiscordHandle -> IO ()-stopDiscord h = do _ <- tryPutMVar (discordHandleLibraryError h) "Library has closed"-                   threadDelay (10^6 `div` 10)-                   mapM_ (killThread . toId) (discordHandleThreads h)+stopDiscord :: DiscordHandler ()+stopDiscord = do h <- ask+                 _ <- tryPutMVar (discordHandleLibraryError h) "Library has closed"+                 threadDelay (10^(6 :: Int) `div` 10)+                 mapM_ (killThread . toId) (discordHandleThreads h)   where toId t = case t of                    DiscordHandleThreadIdRest a -> a                    DiscordHandleThreadIdGateway a -> a

@@ -4,7 +4,6 @@ module Discord.Internal.Gateway.Cache where  import Prelude hiding (log)-import Data.Monoid ((<>)) import Control.Monad (forever) import Control.Concurrent.MVar import Control.Concurrent.Chan

@@ -13,7 +13,6 @@ import Control.Concurrent.Chan import Control.Concurrent (threadDelay, killThread, forkIO) import Control.Exception.Safe (try, finally, handle, SomeException)-import Data.Monoid ((<>)) import Data.IORef import Data.Aeson (eitherDecode, encode) import qualified Data.Text as T@@ -90,7 +89,7 @@                       startEventStream (ConnData conn seshID auth events) interval seqID userSend log                   Right (InvalidSession retry) -> do                       t <- getRandomR (1,5)-                      threadDelay (t * 10^6)+                      threadDelay (t * (10^(6 :: Int)))                       pure $ if retry                              then ConnReconnect (Auth tok) seshID seqID                              else ConnStart@@ -104,7 +103,7 @@                       pure ConnClosed           case next :: Either SomeException ConnLoopState of             Left _ -> do t <- getRandomR (3,20)-                         threadDelay (t * 10^6)+                         threadDelay (t * (10^(6 :: Int)))                          writeChan log ("gateway - trying to reconnect after " <> T.pack (show retries)                                                <> " failures")                          loop (ConnReconnect (Auth tok) seshID seqID) (retries + 1)@@ -130,7 +129,7 @@  heartbeat :: Chan GatewaySendable -> Int -> IORef Integer -> IO () heartbeat send interval seqKey = do-  threadDelay (1 * 10^6)+  threadDelay (1 * 10^(6 :: Int))   forever $ do     num <- readIORef seqKey     writeChan send (Heartbeat num)@@ -208,7 +207,7 @@ sendableLoop :: Connection -> Sendables -> IO () sendableLoop conn sends = forever $ do   -- send a ~120 events a min by delaying-  threadDelay (round (10^6 * (62 / 120)))+  threadDelay $ round ((10^(6 :: Int)) * (62 / 120) :: Double)   let e :: Either GatewaySendable GatewaySendable -> GatewaySendable       e = either id id   payload <- e <$> race (readChan (userSends sends)) (readChan (gatewaySends sends))

@@ -19,7 +19,6 @@  import Data.Aeson import Data.Emoji (unicodeByName)-import Data.Monoid (mempty, (<>)) import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL

@@ -13,7 +13,6 @@   ) where  import Data.Aeson-import Data.Monoid (mempty, (<>)) import Codec.Picture import Network.HTTP.Req ((/:)) import qualified Network.HTTP.Req as R

@@ -21,7 +21,6 @@   import Data.Aeson-import Data.Monoid (mempty, (<>)) import Network.HTTP.Req ((/:)) import qualified Network.HTTP.Req as R import qualified Data.Text as T

@@ -11,7 +11,6 @@   ) where  import Prelude hiding (log)-import Data.Semigroup ((<>))  import Control.Monad.IO.Class (liftIO) import Control.Concurrent (threadDelay)@@ -101,8 +100,8 @@   let body   = R.responseBody resp       code   = R.responseStatusCode resp       status = R.responseStatusMessage resp-      global = (Just "true" ==) $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Global"-      remain = fromMaybe 1 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Remaining"+      global = (Just ("true" :: String) ==) $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Global"+      remain = fromMaybe 1 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Remaining" :: Integer       reset = withDelta . fromMaybe 10 $ readMaybeBS =<< R.responseHeader resp "X-RateLimit-Reset-After"        withDelta :: Double -> POSIXTime

@@ -10,7 +10,6 @@   ( InviteRequest(..)   ) where -import Data.Monoid (mempty) import Network.HTTP.Req ((/:)) import qualified Network.HTTP.Req as R import qualified Data.Text as T

@@ -9,7 +9,6 @@ import Prelude hiding (log) import Control.Exception.Safe (throwIO) import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Monoid ((<>)) import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -25,7 +24,7 @@   where   -- | https://discord.com/developers/docs/reference#user-agent   -- Second place where the library version is noted-  agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.6.1)"+  agent = "DiscordBot (https://github.com/aquarial/discord-haskell, 1.7.0)"  -- Append to an URL infixl 5 //

@@ -14,7 +14,6 @@  import Data.Aeson import Codec.Picture-import Data.Monoid (mempty, (<>)) import Network.HTTP.Req ((/:)) import qualified Network.HTTP.Req as R import qualified Data.Text as T

@@ -14,7 +14,6 @@   ) where  import Data.Aeson-import Data.Monoid (mempty, (<>)) import qualified Data.Text as T import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL

@@ -7,7 +7,6 @@ import Control.Applicative (empty) import Data.Aeson import Data.Aeson.Types (Parser)-import Data.Monoid ((<>)) import Data.Text (Text) import Data.Time.Clock import qualified Data.Text as T@@ -31,6 +30,7 @@       , channelTopic       :: T.Text      -- ^ The topic of the channel. (0 - 1024 chars).       , channelLastMessage :: Maybe MessageId   -- ^ The id of the last message sent in the                                                 --   channel+      , parentId           :: ParentId    -- ^ The id of the parent channel (category)       }   | ChannelNews       { channelId          :: ChannelId@@ -75,6 +75,7 @@       }   | ChannelGuildCategory       { channelId          :: ChannelId+      , channelName        :: T.Text       , channelGuild       :: GuildId       } deriving (Show, Eq, Ord) @@ -92,6 +93,7 @@                      <*> o .:? "nsfw" .!= False                      <*> o .:? "topic" .!= ""                      <*> o .:? "last_message_id"+                     <*> o .:  "parent_id"       1 ->         ChannelDirectMessage <$> o .:  "id"                              <*> o .:  "recipients"@@ -111,6 +113,7 @@                        <*> o .:? "last_message_id"       4 ->         ChannelGuildCategory <$> o .: "id"+                             <*> o .:  "name"                              <*> o .:? "guild_id" .!= 0       5 ->         ChannelNews <$> o .:  "id"@@ -141,6 +144,7 @@               , ("permission_overwrites",   toJSON <$> pure channelPermissions)               , ("topic",   toJSON <$> pure channelTopic)               , ("last_message_id",  toJSON <$> channelLastMessage)+              , ("parent_id",  toJSON <$> pure parentId)               ] ]   toJSON ChannelNews{..} = object [(name,value) | (name, Just value) <-               [ ("id",     toJSON <$> pure channelId)@@ -182,6 +186,7 @@               ] ]   toJSON ChannelGuildCategory{..} = object [(name,value) | (name, Just value) <-               [ ("id",     toJSON <$> pure channelId)+              , ("name", toJSON <$> pure channelName)               , ("guild_id", toJSON <$> pure channelGuild)               ] ] 

@@ -8,12 +8,12 @@ import System.Info  import qualified Data.Text as T-import Data.Monoid ((<>)) import Data.Time (UTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import Data.Aeson import Data.Aeson.Types import Data.Maybe (fromMaybe)+import Data.Functor import Text.Read (readMaybe)  import Discord.Internal.Types.Prelude@@ -140,16 +140,14 @@   toJSON (UpdateStatus (UpdateStatusOpts since game status afk)) = object [       "op" .= (3 :: Int)     , "d"  .= object [-        "since" .= case since of Nothing -> Nothing-                                 Just s -> Just ((10^6) * (utcTimeToPOSIXSeconds s))+        "since" .= (since <&> \s -> 1000 * utcTimeToPOSIXSeconds s) -- takes UTCTime and returns unix time (in milliseconds)       , "afk" .= afk       , "status" .= statusString status-      , "game" .= case game of Nothing -> Nothing-                               Just a -> Just $ object [-                                           "name" .= activityName a-                                         , "type" .= (fromEnum $ activityType a :: Int)-                                         , "url" .= activityUrl a-                                         ]+      , "game" .= (game <&> \a -> object [+                                "name" .= activityName a+                              , "type" .= (fromEnum $ activityType a :: Int)+                              , "url" .= activityUrl a+                              ])       ]     ]   toJSON (UpdateStatusVoice (UpdateStatusVoiceOpts guild channel mute deaf)) =

@@ -11,7 +11,6 @@ import Data.Time.Clock import qualified Data.Text as T import Data.Time.Clock.POSIX-import Data.Monoid ((<>)) import Control.Monad (mzero)  import Data.Functor.Compose (Compose(Compose, getCompose))@@ -54,6 +53,7 @@ type RoleId = Snowflake type IntegrationId = Snowflake type WebhookId = Snowflake+type ParentId = Snowflake  -- | Gets a creation date from a snowflake. snowflakeCreationDate :: Snowflake -> UTCTime