diff --git a/Calamity/HTTP/Channel.hs b/Calamity/HTTP/Channel.hs --- a/Calamity/HTTP/Channel.hs +++ b/Calamity/HTTP/Channel.hs @@ -34,12 +34,12 @@ import Calamity.Types.Snowflake import Data.Aeson qualified as Aeson import Data.Aeson.KeyMap qualified as K -import Data.ByteString.Lazy (ByteString) import Data.Default.Class import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.Text qualified as T import Data.Word +import Network.HTTP.Client (RequestBody) import Network.HTTP.Client.MultipartFormData import Network.HTTP.Req import Network.Mime @@ -49,10 +49,19 @@ data CreateMessageAttachment = CreateMessageAttachment { filename :: Text , description :: Maybe Text - , content :: ByteString + , content :: RequestBody } - deriving (Show) +instance Show CreateMessageAttachment where + show (CreateMessageAttachment filename description _) = + mconcat + [ "CreateMessageAttachment {filename = " + , show filename + , ", description = " + , show description + , ", content = }" + ] + data CreateMessageOptions = CreateMessageOptions { content :: Maybe Text , nonce :: Maybe Text @@ -418,7 +427,7 @@ & buildRoute action (CreateMessage _ cm) = \u o -> do let filePart CreateMessageAttachment {filename, content} n = - (partLBS @IO (T.pack $ "files[" <> show n <> "]") content) + (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) { partFilename = Just (T.unpack filename) , partContentType = Just (defaultMimeLookup filename) } diff --git a/Calamity/HTTP/Interaction.hs b/Calamity/HTTP/Interaction.hs --- a/Calamity/HTTP/Interaction.hs +++ b/Calamity/HTTP/Interaction.hs @@ -324,7 +324,7 @@ in postWith' (ReqBodyJson jsonBody) action (CreateResponseMessage _ _ cm) = \u o -> do let filePart CreateMessageAttachment {filename, content} n = - (partLBS @IO (T.pack $ "files[" <> show n <> "]") content) + (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) { partFilename = Just (T.unpack filename) , partContentType = Just (defaultMimeLookup filename) } @@ -354,7 +354,7 @@ postWith' body u o action (CreateResponseUpdate _ _ cm) = \u o -> do let filePart CreateMessageAttachment {filename, content} n = - (partLBS @IO (T.pack $ "files[" <> show n <> "]") content) + (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) { partFilename = Just (T.unpack filename) , partContentType = Just (defaultMimeLookup filename) } @@ -399,7 +399,7 @@ action (GetOriginalInteractionResponse _ _) = getWith action (EditOriginalInteractionResponse _ _ cm) = \u o -> do let filePart CreateMessageAttachment {filename, content} n = - (partLBS @IO (T.pack $ "files[" <> show n <> "]") content) + (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) { partFilename = Just (T.unpack filename) , partContentType = Just (defaultMimeLookup filename) } @@ -430,7 +430,7 @@ action (DeleteOriginalInteractionResponse _ _) = deleteWith action (CreateFollowupMessage _ _ cm) = \u o -> do let filePart CreateMessageAttachment {filename, content} n = - (partLBS @IO (T.pack $ "files[" <> show n <> "]") content) + (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) { partFilename = Just (T.unpack filename) , partContentType = Just (defaultMimeLookup filename) } @@ -456,7 +456,7 @@ action GetFollowupMessage {} = getWith action (EditFollowupMessage _ _ _ cm) = \u o -> do let filePart CreateMessageAttachment {filename, content} n = - (partLBS @IO (T.pack $ "files[" <> show n <> "]") content) + (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) { partFilename = Just (T.unpack filename) , partContentType = Just (defaultMimeLookup filename) } diff --git a/Calamity/HTTP/Webhook.hs b/Calamity/HTTP/Webhook.hs --- a/Calamity/HTTP/Webhook.hs +++ b/Calamity/HTTP/Webhook.hs @@ -183,7 +183,7 @@ action (DeleteWebhookToken _ _) = deleteWith action (ExecuteWebhook _ _ wh) = \u o -> do let filePart CreateMessageAttachment {filename, content} n = - (partLBS @IO (T.pack $ "files[" <> show n <> "]") content) + (partFileRequestBody @IO (T.pack $ "files[" <> show n <> "]") "" content) { partFilename = Just (T.unpack filename) , partContentType = Just (defaultMimeLookup filename) } diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Changelog for Calamity +## 0.10.0.0 + ++ Updated `CreateMessageAttachment.content` to be a `Network.HTTP.Client.RequestBody` + to allow for easy streaming of uploads + ## 0.9.0.0 + Require tls >= 1.7 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -57,9 +57,8 @@ {- cabal: build-depends: base >= 4.13 && < 5 - , calamity >= 0.3.0.0 + , calamity >= 0.10.0.0 , optics >= 0.4.1 && < 0.5 - , lens >= 5.1 && < 6 , di-polysemy ^>= 0.2 , di >= 1.3 && < 2 , df1 >= 0.3 && < 0.5 @@ -68,44 +67,51 @@ , polysemy-plugin >= 0.3 && <0.5 , stm >= 2.5 && <3 , text-show >= 3.8 && <4 + , http-client ^>= 0.7 -} {-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} +{-# LANGUAGE ImportQualifiedPost #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedLabels #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-} module Main (main) where import Calamity import Calamity.Cache.InMemory import Calamity.Commands -import Calamity.Commands.Context (useFullContext) -import qualified Calamity.Interactions as I +import Calamity.Commands.Context (FullContext, useFullContext) +import Calamity.Interactions qualified as I import Calamity.Metrics.Noop +import Calamity.Utils.CDNUrl (assetHashFile) import Control.Concurrent -import Optics import Control.Monad -import qualified Data.Text as T -import qualified Di -import qualified DiPolysemy as DiP -import qualified Polysemy as P -import qualified Polysemy.Async as P -import qualified Polysemy.State as P +import Data.Foldable (for_) +import Data.Text qualified as T +import Di qualified +import DiPolysemy qualified as DiP +import Optics +import Polysemy qualified as P +import Polysemy.Async qualified as P +import Polysemy.State qualified as P import System.Environment (getEnv) import TextShow +import Network.HTTP.Client (RequestBody(RequestBodyLBS)) data MyViewState = MyViewState { numOptions :: Int @@ -118,15 +124,25 @@ main = do token <- T.pack <$> getEnv "BOT_TOKEN" Di.new $ \di -> - void . P.runFinal . P.embedToFinal . DiP.runDiToIO di + void + . P.runFinal + . P.embedToFinal + . DiP.runDiToIO di . runCacheInMemory . runMetricsNoop . useConstantPrefix "!" . useFullContext - $ runBotIO (BotToken token) defaultIntents $ do - addCommands $ do + $ runBotIO (BotToken token) defaultIntents + $ do + void . addCommands $ do + helpCommand -- just some examples + command @'[User] "pfp" \ctx u -> do + Right pfp <- fetchAsset (u ^. #avatar) + let name = maybe "default.png" assetHashFile (u ^. #avatar % #hash) + file = CreateMessageAttachment name (Just "Your avatar") (Network.HTTP.Client.RequestBodyLBS pfp) + void $ tell ctx file command @'[User] "utest" \ctx u -> do void . tell @T.Text ctx $ "got user: " <> showt u command @'[Named "u" User, Named "u1" User] "utest2" \ctx u u1 -> do @@ -219,7 +235,27 @@ void $ I.respond ("Thanks: " <> a <> " " <> b) I.endView () - pure () + react @('CustomEvt (CtxCommandError FullContext)) \(CtxCommandError ctx e) -> do + DiP.info $ "Command failed with reason: " <> showt e + case e of + ParseError n r -> + void . tell ctx $ + "Failed to parse parameter: " + <> codeline n + <> ", with reason: " + <> codeblock' Nothing r + CheckError n r -> + void . tell ctx $ + "The following check failed: " + <> codeline n + <> ", with reason: " + <> codeblock' Nothing r + InvokeError n r -> + void . tell ctx $ + "The command: " + <> codeline n + <> ", failed with reason: " + <> codeblock' Nothing r ``` ## Disabling library logging diff --git a/calamity.cabal b/calamity.cabal --- a/calamity.cabal +++ b/calamity.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: calamity -version: 0.9.0.0 +version: 0.10.0.0 synopsis: A library for writing discord bots in haskell description: Please see the README on GitHub at @@ -195,9 +195,9 @@ , calamity-commands >=0.4 && <0.5 , colour >=2.3.5 && <2.4 , concurrent-extra >=0.7 && <0.8 + , containers >=0.6 && <0.7 , crypton-connection >=0.2.6 && <0.4 , crypton-x509-system >=1.6.6 && <1.7 - , containers >=0.6 && <0.7 , data-default-class >=0.1 && <0.2 , data-flags >=0.0.3 && <0.1 , deepseq >=1.4.4.0 && <2