From 3d3163a1028e99e5073fd39adc9aee5d76a5e5a2 Mon Sep 17 00:00:00 2001 From: Jacques Comeaux Date: Fri, 27 May 2022 21:07:43 -0500 Subject: Initial Commit --- src/Tomato/Post.hs | 65 ++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 65 insertions(+) create mode 100644 src/Tomato/Post.hs (limited to 'src/Tomato/Post.hs') diff --git a/src/Tomato/Post.hs b/src/Tomato/Post.hs new file mode 100644 index 0000000..1e97782 --- /dev/null +++ b/src/Tomato/Post.hs @@ -0,0 +1,65 @@ +module Tomato.Post + ( postTomato + , uploadTomato + , postMessage + ) where + +import RIO + +import Network.HTTP.Req + ( jsonResponse + , ignoreResponse + , req + , ReqBodyFile (..) + , ReqBodyJson (..) + , (/:) + , POST (..) + , Req + , https + , header + , responseBody + ) + +import Data.Message (GMIUrl (..), OutMessage (..)) + +import qualified Data.Aeson as Ae +import qualified Data.Aeson.KeyMap as Ae + +-- TODO global config reader monad +tomatoFile :: FilePath +tomatoFile = "tomato.png" + +accessToken :: ByteString +accessToken = "nj8X8tB3TC0MoZdMLhIUA4G89r9IlQfVej97Mhg3" + +botId :: Text +botId = "713bcb4a4604006c944804552c" + +-- | Post the current tomato +postTomato :: Req () +postTomato = do + url <- uploadTomato + postMessage $ OutMessage url + +-- | Upload the current tomato to the GroupMe image server +uploadTomato :: Req GMIUrl +uploadTomato = do + let url = https "image.groupme.com" /: "pictures" + js <- req POST url (ReqBodyFile tomatoFile) jsonResponse $ + header "X-Access-Token" accessToken <> + header "Content-Type" "image/png" + gmURL <- case Ae.fromJSON (responseBody js) of + Ae.Success r -> pure r + Ae.Error _s -> error "deal with this later" -- TODO error monad + return gmURL + +-- | Post a message to the group with image as attachment +postMessage :: OutMessage -> Req () +postMessage outMes = do + let url = https "api.groupme.com" /: "v3" /: "bots" /: "post" + outMes' = case Ae.toJSON outMes of + Ae.Object o -> Ae.Object $ Ae.insert "bot_id" (Ae.toJSON botId) o + _ -> error "exceptional" + req POST url (ReqBodyJson outMes') ignoreResponse $ + header "X-Access-Token" accessToken + return () -- cgit v1.2.3