Change backing REST lib to Req (From Wreq) (#11)

* Keep only REST

* Qualified Wreq

* Ported to Req, rest sample stub

* Fixes/cleanup

* Removed rest-only example, added missing ext to Framework

* Separate HTTP details

* Fighting type hell

* Fixed type issues, thx @Lazersmoke

* Documentation

* Fixed GetChannelMessages args, removed redundant return

* Changes for Req

* Add changelog

CHANGELOG.md

@@ -0,0 +1,4 @@
+Changes:
+- Switch from Req to Wreq (See issue #9)
+- Breaking api change to UploadFile, now UploadFile fileName file
+  (file arg remains a LBS)

discord-hs.cabal

@@ -23,20 +23,21 @@ Flag disable-docs
 
 library
   exposed-modules:     Network.Discord
-                     , Network.Discord.Framework
-                     , Network.Discord.Gateway
                      , Network.Discord.Rest
                      , Network.Discord.Rest.Channel
                      , Network.Discord.Rest.Guild
                      , Network.Discord.Rest.User
+                     , Network.Discord.Framework
+                     , Network.Discord.Gateway
                      , Network.Discord.Types
                      , Network.Discord.Types.Channel
+                     , Network.Discord.Types.Guild
                      , Network.Discord.Types.Events
                      , Network.Discord.Types.Gateway
-                     , Network.Discord.Types.Guild
   other-modules:       Paths_discord_hs
                      , Network.Discord.Rest.Prelude
                      , Network.Discord.Types.Prelude
+                     , Network.Discord.Rest.HTTP
   -- other-extensions:
   build-depends:       base==4.*
                      , aeson==1.0.*
@@ -46,7 +47,7 @@ library
                      , data-default==0.7.*
                      , hashable==1.2.*
                      , hslogger==1.2.*
-                     , lens==4.15.*
+                     , http-client==0.5.*
                      , mmorph==1.0.*
                      , mtl==2.2.*
                      , pipes==4.3.*
@@ -59,7 +60,7 @@ library
                      , url==2.1.*
                      , vector==0.11.*
                      , websockets==0.10.*
-                     , wreq==0.5.*
+                     , req==0.2.*
                      , wuss==1.1.*
   ghc-options:         -Wall
   hs-source-dirs:      src

examples/putstr.hs

@@ -11,7 +11,7 @@ import Network.Discord.Gateway
 
 data PutStrClient = PsClient
 instance Client PutStrClient where
-  getAuth _ = Bot "TOKEN HERE"
+  getAuth _ = Bot "TOKEN"
 
 main :: IO ()
 main = runWebsocket (fromJust $ importURL "wss://gateway.discord.gg") PsClient $ do

src/Network/Discord/Framework.hs

@@ -7,7 +7,7 @@ module Network.Discord.Framework where
   import Data.Proxy
 
   import Control.Concurrent.STM
-  import Control.Monad.State (execStateT, get)
+  import Control.Monad.State (get)
   import Data.Aeson (Object)
   import Pipes ((~>))
   import Pipes.Core hiding (Proxy)
@@ -27,7 +27,7 @@ module Network.Discord.Framework where
       undefined
       undefined
       limits
- 
+
   -- | Basic client implementation. Most likely suitable for most bots.
   data BotClient = BotClient Auth
   instance D.Client BotClient where
@@ -51,8 +51,8 @@ module Network.Discord.Framework where
   runAsync c effect = do
       client <- liftIO . atomically $ getSTMClient c
       st <- asyncState client
-      liftIO . void $ forkFinally 
-        (execStateT (runEffect effect) st)
+      liftIO . void $ forkFinally
+        (execDiscordM (runEffect effect) st)
         finish
     where
       finish (Right DiscordState{getClient = st}) = atomically $ mergeClient st
@@ -63,7 +63,7 @@ module Network.Discord.Framework where
 
   -- | Event handlers for 'Gateway' events. These correspond to events listed in
   --   'Event'
-  data D.Client c => Handle c = Null                         
+  data D.Client c => Handle c = Null
                               | Misc                         (Event   -> Effect DiscordM ())
                               | ReadyEvent                   (Init    -> Effect DiscordM ())
                               | ResumedEvent                 (Object  -> Effect DiscordM ())

src/Network/Discord/Gateway.hs

@@ -37,7 +37,7 @@ module Network.Discord.Gateway where
   runWebsocket (URL (Absolute h) path _) client inner = do
     rl <- newTVarIO []
     runSecureClient (host h) 443 (path++"/?v=6")
-      $ \conn -> evalStateT (runEffect inner)
+      $ \conn -> evalDiscordM (runEffect inner)
         (DiscordState Create client conn undefined rl)
   runWebsocket _ _ _ = mzero
 
@@ -94,3 +94,4 @@ module Network.Discord.Gateway where
   --   'Connection' to a stream of gateway 'Event's
   eventCore :: Connection -> Producer Event DiscordM ()
   eventCore conn = makeWebsocketSource conn >-> makeEvents
+

src/Network/Discord/Rest.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings, FlexibleInstances #-}
 {-# OPTIONS_HADDOCK prune, not-home #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
 -- | Provides framework to interact with REST api gateways. Implementations specific to the
 --   Discord API are provided in Network.Discord.Rest.Channel, Network.Discord.Rest.Guild,
 --   and Network.Discord.Rest.User.
@@ -13,46 +14,51 @@ module Network.Discord.Rest
   ) where
     import Control.Monad (void)
     import Data.Maybe (fromJust)
+    import Control.Exception (throwIO)
 
-    import Control.Lens
+    import qualified Network.HTTP.Req as R
     import Control.Monad.Morph (lift)
     import Data.Aeson.Types
     import Data.Hashable
     import Network.URL
-    import Network.Wreq
     import Pipes.Core
 
     import Network.Discord.Types as Dc
     import Network.Discord.Rest.Channel
     import Network.Discord.Rest.Guild
     import Network.Discord.Rest.Prelude
     import Network.Discord.Rest.User
-
+    import Network.Discord.Rest.HTTP (baseUrl)
+
     -- | Perform an API request.
     fetch :: (DoFetch a, Hashable a)
       => a -> Pipes.Core.Proxy X () c' c DiscordM Fetched
     fetch req = restServer +>> (request $ Fetch req)
-    
+
     -- | Perform an API request, ignoring the response
     fetch' :: (DoFetch a, Hashable a)
       => a -> Pipes.Core.Proxy X () c' c DiscordM ()
     fetch' = void . fetch
-    
+
     -- | Alternative method of interacting with the REST api
     withApi :: Pipes.Core.Client Fetchable Fetched DiscordM Fetched
       -> Effect DiscordM ()
     withApi inner = void $ restServer +>> inner
-    
+
     -- | Provides a pipe to perform REST actions
     restServer :: Fetchable -> Server Fetchable Fetched DiscordM Fetched
     restServer req =
       lift (doFetch req) >>= respond >>= restServer
 
+    instance R.MonadHttp IO where
+      handleHttpException = throwIO
+
     -- | Obtains a new gateway to connect to.
     getGateway :: IO URL
     getGateway = do
-      resp <- asValue =<< get (baseURL++"/gateway")
-      return . fromJust $ importURL =<< parseMaybe getURL (resp ^. responseBody)
+      r <- R.req R.GET (baseUrl R./: "gateway") R.NoReqBody R.jsonResponse mempty
+      return . fromJust $ importURL =<< parseMaybe getURL (R.responseBody r)
+
       where
         getURL :: Value -> Parser String
         getURL = withObject "url" (.: "url")

src/Network/Discord/Rest/Channel.hs

@@ -5,22 +5,19 @@ module Network.Discord.Rest.Channel
   (
     ChannelRequest(..)
   ) where
-    import Control.Monad (when)
-
-    import Control.Concurrent.STM
-    import Control.Lens
-    import Control.Monad.Morph (lift)
+
     import Data.Aeson
     import Data.ByteString.Lazy
     import Data.Hashable
-    import Data.Monoid ((<>))
-    import Data.Text
-    import Data.Time.Clock.POSIX
-    import Network.Wreq
-    import qualified Control.Monad.State as ST (get, liftIO)
-
+    import Data.Monoid (mempty, (<>))
+    import Data.Text as T
+    import Network.HTTP.Client (RequestBody (..))
+    import Network.HTTP.Client.MultipartFormData (partFileRequestBody)
+    import Network.HTTP.Req (reqBodyMultipart)
+    
     import Network.Discord.Rest.Prelude
-    import Network.Discord.Types as Dc
+    import Network.Discord.Types
+    import Network.Discord.Rest.HTTP
 
     -- | Data constructor for Channel requests. See <https://discordapp.com/developers/docs/resources/Channel Channel API>
     data ChannelRequest a where
@@ -31,13 +28,13 @@ module Network.Discord.Rest.Channel
       -- | Deletes a channel if its id doesn't equal to the id of guild.
       DeleteChannel           :: Snowflake -> ChannelRequest Channel
       -- | Gets a messages from a channel with limit of 100 per request.
-      GetChannelMessages      :: Snowflake -> [(Text, Text)] -> ChannelRequest [Message]
+      GetChannelMessages      :: Snowflake -> Range -> ChannelRequest [Message]
       -- | Gets a message in a channel by its id.
       GetChannelMessage       :: Snowflake -> Snowflake -> ChannelRequest Message
       -- | Sends a message to a channel.
       CreateMessage           :: Snowflake -> Text -> Maybe Embed -> ChannelRequest Message
       -- | Sends a message with a file to a channel.
-      UploadFile              :: Snowflake -> Text -> ByteString -> ChannelRequest Message
+      UploadFile              :: Snowflake -> FilePath -> ByteString -> ChannelRequest Message
       -- | Edits a message content.
       EditMessage             :: Message   -> Text -> Maybe Embed -> ChannelRequest Message
       -- | Deletes a message.
@@ -83,109 +80,61 @@ module Network.Discord.Rest.Channel
       hashWithSalt s (AddPinnedMessage chan _) = hashWithSalt s ("pin"::Text, chan)
       hashWithSalt s (DeletePinnedMessage chan _) = hashWithSalt s ("pin"::Text, chan)
 
-    instance Eq (ChannelRequest a) where
-      a == b = hash a == hash b
-
-    instance RateLimit (ChannelRequest a) where
-      getRateLimit req = do
-        DiscordState {getRateLimits=rl} <- ST.get
-        now <- ST.liftIO (fmap round getPOSIXTime :: IO Int)
-        ST.liftIO . atomically $ do
-          rateLimits <- readTVar rl
-          case lookup (hash req) rateLimits of
-            Nothing -> return Nothing
-            Just a
-              | a >= now  -> return $ Just a
-              | otherwise -> modifyTVar' rl (Dc.delete $ hash req) >> return Nothing
-
-      setRateLimit req reset = do
-        DiscordState {getRateLimits=rl} <- ST.get
-        ST.liftIO . atomically . modifyTVar rl $ Dc.insert (hash req) reset
+    instance RateLimit (ChannelRequest a)
 
     instance (FromJSON a) => DoFetch (ChannelRequest a) where
-      doFetch req = do
-        waitRateLimit req
-        SyncFetched <$> fetch req
-
-    -- |Sends a request, used by doFetch.
-    fetch :: FromJSON a => ChannelRequest a -> DiscordM a
-    fetch request = do
-      req  <- baseRequest
-      (resp, rlRem, rlNext) <- lift $ do
-        resp <- case request of
-          GetChannel chan -> getWith req
-            (baseURL ++ "/channels/" ++ show chan)
-
-          ModifyChannel chan patch -> customPayloadMethodWith "PATCH" req
-            (baseURL ++ "/channels/" ++ show chan)
-            (toJSON patch)
-
-          DeleteChannel chan -> deleteWith req
-            (baseURL ++ "/channels/" ++ show chan)
-
-          GetChannelMessages chan patch -> getWith
-            (Prelude.foldr (\(k, v) -> param k .~ [v]) req patch)
-            (baseURL ++ "/channels/" ++ show chan ++ "/messages")
-
-          GetChannelMessage chan msg -> getWith req
-            (baseURL ++ "/channels/" ++ show chan ++ "/messages/" ++ show msg)
-
-          CreateMessage chan msg embed -> postWith req
-            (baseURL ++ "/channels/" ++ show chan ++ "/messages")
-            (object $ [("content", toJSON msg)] <> maybeEmbed embed)
-
-          UploadFile chan msg file -> postWith
-            (req & header "Content-Type" .~ ["multipart/form-data"])
-            (baseURL ++ "/channels/" ++ show chan ++ "/messages")
-            ["content" := msg, "file" := file]
-
-          EditMessage (Message msg chan _ _ _ _ _ _ _ _ _ _ _ _) new embed ->
-            customPayloadMethodWith "PATCH" req
-              (baseURL ++ "/channels/" ++ show chan ++ "/messages/" ++ show msg)
-              (object $ [("content", toJSON new)] <> maybeEmbed embed)
-
-          DeleteMessage (Message msg chan _ _ _ _ _ _ _ _ _ _ _ _) ->
-            deleteWith req
-              (baseURL ++ "/channels/" ++ show chan ++ "/messages/" ++ show msg)
-
-          BulkDeleteMessage chan msgs -> postWith req
-            (baseURL ++ "/channels/" ++ show chan ++ "/messages/bulk-delete")
-            (object
-              [("messages", toJSON
-                $ Prelude.map (\(Message msg _ _ _ _ _ _ _ _ _ _ _ _ _) -> msg) msgs)])
-
-          EditChannelPermissions chan perm patch -> putWith req
-            (baseURL ++ "/channels/" ++ show chan ++ "/permissions/" ++ show perm)
-            (toJSON patch)
-
-          GetChannelInvites chan -> getWith req
-            (baseURL ++ "/channels/" ++ show chan ++ "/invites")
-
-          CreateChannelInvite chan patch -> postWith req
-            (baseURL ++ "/channels/" ++ show chan ++ "/invites")
-            (toJSON patch)
-
-          DeleteChannelPermission chan perm -> deleteWith req
-            (baseURL ++ "/channels/" ++ show chan ++ "/permissions/" ++ show perm)
-
-          TriggerTypingIndicator chan -> postWith req
-            (baseURL ++ "/channels/" ++ show chan ++ "/typing")
-            (toJSON ([]::[Int]))
-
-          GetPinnedMessages chan -> getWith req
-            (baseURL ++ "/channels/" ++ show chan ++ "/pins")
-
-          AddPinnedMessage chan msg -> putWith req
-            (baseURL ++ "/channels/" ++ show chan ++ "/pins/" ++ show msg)
-            (toJSON ([]::[Int]))
-
-          DeletePinnedMessage chan msg -> deleteWith req
-            (baseURL ++ "/channels/" ++ show chan ++ "/pins/" ++ show msg)
-        return (justRight . eitherDecode $ resp ^. responseBody
-          , justRight . eitherDecodeStrict $ resp ^. responseHeader "X-RateLimit-Remaining"::Int
-          , justRight . eitherDecodeStrict $ resp ^. responseHeader "X-RateLimit-Reset"::Int)
-      when (rlRem == 0) $ setRateLimit request rlNext
-      return resp
-      where
-        maybeEmbed :: Maybe Embed -> [(Text, Value)]
-        maybeEmbed = maybe [] $ \embed -> [("embed", toJSON embed)]
+      doFetch req = SyncFetched <$> go req
+        where
+          maybeEmbed :: Maybe Embed -> [(Text, Value)]
+          maybeEmbed = maybe [] $ \embed -> ["embed" .= embed]
+          url = baseUrl /: "channels"
+          go :: ChannelRequest a -> DiscordM a
+          go r@(GetChannel chan) = makeRequest r
+            $ Get (url // chan) mempty
+          go r@(ModifyChannel chan patch) = makeRequest r
+            $ Patch (url // chan)
+              (ReqBodyJson patch) mempty
+          go r@(DeleteChannel chan) = makeRequest r
+            $ Delete (url // chan) mempty
+          go r@(GetChannelMessages chan range) = makeRequest r
+            $ Get (url // chan /: "messages") (toQueryString range)
+          go r@(GetChannelMessage chan msg) = makeRequest r
+            $ Get (url // chan /: "messages" // msg) mempty
+          go r@(CreateMessage chan msg embed) = makeRequest r
+            $ Post (url // chan /: "messages")
+              (ReqBodyJson . object $ ["content" .= msg] <> maybeEmbed embed)
+              mempty
+          go r@(UploadFile chan fileName file) = do
+            body <- reqBodyMultipart [partFileRequestBody "file" fileName $ RequestBodyLBS file]
+            makeRequest r $ Post (url // chan /: "messages")
+              body mempty
+          go r@(EditMessage (Message msg chan _ _ _ _ _ _ _ _ _ _ _ _) new embed) = makeRequest r
+            $ Patch (url // chan /: "messages" // msg)
+              (ReqBodyJson . object $ ["content" .= new] <> maybeEmbed embed)
+              mempty
+          go r@(DeleteMessage (Message msg chan _ _ _ _ _ _ _ _ _ _ _ _)) = makeRequest r
+            $ Delete (url // chan /: "messages" // msg) mempty
+          go r@(BulkDeleteMessage chan msgs) = makeRequest r
+            $ Post (url // chan /: "messages" /: "bulk-delete")
+              (ReqBodyJson $ object ["messages" .= Prelude.map messageId msgs])
+              mempty
+          go r@(EditChannelPermissions chan perm patch) = makeRequest r
+            $ Put (url // chan /: "permissions" // perm)
+              (ReqBodyJson patch) mempty
+          go r@(GetChannelInvites chan) = makeRequest r
+            $ Get (url // chan /: "invites") mempty
+          go r@(CreateChannelInvite chan patch) = makeRequest r
+            $ Post (url // chan /: "invites")
+              (ReqBodyJson patch) mempty
+          go r@(DeleteChannelPermission chan perm) = makeRequest r
+            $ Delete (url // chan /: "permissions" // perm) mempty
+          go r@(TriggerTypingIndicator chan) = makeRequest r
+            $ Post (url // chan /: "typing")
+              NoReqBody mempty
+          go r@(GetPinnedMessages chan) = makeRequest r
+            $ Get (url // chan /: "pins") mempty
+          go r@(AddPinnedMessage chan msg) = makeRequest r
+            $ Put (url // chan /: "pins" // msg)
+              NoReqBody mempty
+          go r@(DeletePinnedMessage chan msg) = makeRequest r
+            $ Delete (url // chan /: "pins" // msg) mempty