From 8a06c083fab9c66e754c7ed5a75dd4d89131c43e Mon Sep 17 00:00:00 2001 From: Jacques Comeaux Date: Sun, 29 May 2022 16:07:59 -0500 Subject: Improve error reporting --- src/Data/Message.hs | 81 ---------------------------------------------- src/Data/Tomato.hs | 70 --------------------------------------- src/Tomato/App.hs | 32 ++++++++++++++++++ src/Tomato/Bot.hs | 19 +++++++++++ src/Tomato/Data/Except.hs | 9 ++++++ src/Tomato/Data/Message.hs | 81 ++++++++++++++++++++++++++++++++++++++++++++++ src/Tomato/Data/Tomato.hs | 70 +++++++++++++++++++++++++++++++++++++++ src/Tomato/Post.hs | 36 ++++++++++++--------- src/Tomato/Retrieve.hs | 34 ++++++++++--------- src/Tomato/Validate.hs | 3 +- 10 files changed, 252 insertions(+), 183 deletions(-) delete mode 100644 src/Data/Message.hs delete mode 100644 src/Data/Tomato.hs create mode 100644 src/Tomato/App.hs create mode 100644 src/Tomato/Bot.hs create mode 100644 src/Tomato/Data/Except.hs create mode 100644 src/Tomato/Data/Message.hs create mode 100644 src/Tomato/Data/Tomato.hs (limited to 'src') diff --git a/src/Data/Message.hs b/src/Data/Message.hs deleted file mode 100644 index c218cdc..0000000 --- a/src/Data/Message.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Data.Message - ( InMessage (..) - , GMIUrl (..) - , OutMessage (..) - ) where - -import RIO - -import Data.Aeson ((.:), (.=)) -import Network.HTTP.Req - ( Url - , Scheme (Https) - , useHttpsURI - , renderUrl - ) - -import qualified Data.Aeson as Ae -import qualified Data.Aeson.Types as Ae -import qualified RIO.Vector as V -import qualified Text.URI as URI - -data InMessage = InMessage - { hasAttach :: !Bool - , groupId :: !Text - , isUser :: !Bool - , text :: !Text - } deriving (Show, Generic) - -instance NFData InMessage - -instance Ae.FromJSON InMessage where - parseJSON = Ae.withObject "InMessage" $ \o -> InMessage - <$> (o .: "attachments" >>= Ae.withArray "attachments" (pure . not . null)) - <*> o .: "group_id" - <*> ((==) ("user" :: Text) <$> o .: "sender_type") - <*> o .: "text" - - -newtype GMIUrl = GMIUrl - { unGMIUrl :: Url Https - } deriving Show - -instance Ae.FromJSON GMIUrl where - parseJSON = Ae.withObject "payload" $ \o -> do - p <- o .: "payload" - u <- p .: "url" - GMIUrl <$> toUrl u - where - toUrl :: Text -> Ae.Parser (Url Https) - toUrl t = maybe mzero pure $ fmap fst $ useHttpsURI =<< URI.mkURI t - -data OutMessage = OutMessage - { image :: !GMIUrl - } deriving Show - -instance Ae.ToJSON OutMessage where - toJSON om = Ae.object - [ "attachments" .= - ( Ae.Array $ V.singleton attach ) - -- , "bot_id" .= botId - ] - where - attach :: Ae.Value - attach = Ae.object - [ "type" .= ("image" :: Text) - , "url" .= url - ] - url :: Text - url = renderUrl $ unGMIUrl $ image om - - -- { - -- "bot_id" : "j5abcdefg", - -- "text" : "Hello world", - -- "attachments" : [ - -- { - -- "type" : "image", - -- "url" : "https://i.groupme.com/somethingsomething.large" - -- } - -- ] --- } diff --git a/src/Data/Tomato.hs b/src/Data/Tomato.hs deleted file mode 100644 index fc9b8b5..0000000 --- a/src/Data/Tomato.hs +++ /dev/null @@ -1,70 +0,0 @@ -module Data.Tomato - ( Links (..) - , Tomato (..) - , Urls (..) - ) where - -import RIO - -import Data.Aeson ((.:)) -import Network.HTTP.Req (Url, Scheme (Https), useHttpsURI) - -import qualified Data.Aeson as Ae -import qualified Data.Aeson.Types as Ae -import qualified Text.URI as URI - - -data Tomato = Tomato - { id :: !Text - , width :: !Word - , height :: !Word - , color :: !Text - , blur_hash :: !Text - , description :: !Text - , urls :: !Urls - , links :: !Links - } deriving Show - -instance Ae.FromJSON Tomato where - parseJSON = Ae.withObject "Tomato" $ \o -> Tomato - <$> o .: "id" - <*> o .: "width" - <*> o .: "height" - <*> o .: "color" - <*> o .: "blur_hash" - <*> o .: "description" - <*> o .: "urls" - <*> o .: "links" - -data Links = Links - { self :: !(Url Https) - , html :: !(Url Https) - , download :: !(Url Https) - , download_location :: !(Url Https) - } deriving Show - -instance Ae.FromJSON Links where - parseJSON = Ae.withObject "Links" $ \o -> Links - <$> (o .: "self" >>= toUrl) - <*> (o .: "html" >>= toUrl) - <*> (o .: "download" >>= toUrl) - <*> (o .: "download_location" >>= toUrl) - -data Urls = Urls - { raw :: !(Url Https) - , full :: !(Url Https) - , regular :: !(Url Https) - , small :: !(Url Https) - , thumb :: !(Url Https) - } deriving Show - -instance Ae.FromJSON Urls where - parseJSON = Ae.withObject "Urls" $ \o -> Urls - <$> (o .: "raw" >>= toUrl) - <*> (o .: "full" >>= toUrl) - <*> (o .: "regular" >>= toUrl) - <*> (o .: "small" >>= toUrl) - <*> (o .: "thumb" >>= toUrl) - -toUrl :: Text -> Ae.Parser (Url Https) -toUrl t = maybe mzero pure $ fmap fst $ useHttpsURI =<< URI.mkURI t diff --git a/src/Tomato/App.hs b/src/Tomato/App.hs new file mode 100644 index 0000000..14bf61a --- /dev/null +++ b/src/Tomato/App.hs @@ -0,0 +1,32 @@ +module Tomato.App + ( App (..) + , runApp + ) where + +import RIO + + +data App = App + { appLogFunc :: !LogFunc + , appToken :: !ByteString + , appBotId :: !Text + , appFile :: !FilePath + , appClientId :: !Text + } + +instance HasLogFunc App where + logFuncL = lens appLogFunc (\x y -> x { appLogFunc = y }) + +runApp :: RIO App a -> IO a +runApp inner = do + logOptions' <- logOptionsHandle stderr False + let logOptions = setLogUseTime True $ setLogUseLoc True logOptions' + withLogFunc logOptions $ \logFunc -> do + let app = App + { appLogFunc = logFunc + , appToken = "t2YhlxxwZmn2cWfkAomjMc6BgVPMaC5NRkqHzGQl" + , appBotId = "713bcb4a4604006c944804552c" + , appFile = "tomato.png" + , appClientId = "FbzqI-oR7277JwL1ZGsyUw7yG1F5U0U3WhQ3kOW71Do" + } + runRIO app inner diff --git a/src/Tomato/Bot.hs b/src/Tomato/Bot.hs new file mode 100644 index 0000000..8d4cf6d --- /dev/null +++ b/src/Tomato/Bot.hs @@ -0,0 +1,19 @@ +module Tomato.Bot + ( tomatoBot + ) where + +import RIO + +import Tomato.App (App) +import Tomato.Post (postTomato) +import Tomato.Retrieve (randomTomato) + + +-- | Fetch and post a tomato +tomatoBot :: RIO App () +tomatoBot = do + logInfo $ "Fetching tomato" + randomTomato + logInfo $ "Posting tomato" + postTomato + logInfo $ "Done" diff --git a/src/Tomato/Data/Except.hs b/src/Tomato/Data/Except.hs new file mode 100644 index 0000000..30212cf --- /dev/null +++ b/src/Tomato/Data/Except.hs @@ -0,0 +1,9 @@ +module Tomato.Data.Except + ( DecodeException (..) + ) where + +import RIO + +data DecodeException = DecodeException !Text + deriving (Show, Typeable) +instance Exception DecodeException diff --git a/src/Tomato/Data/Message.hs b/src/Tomato/Data/Message.hs new file mode 100644 index 0000000..0f650db --- /dev/null +++ b/src/Tomato/Data/Message.hs @@ -0,0 +1,81 @@ +{-# LANGUAGE DeriveGeneric #-} +module Tomato.Data.Message + ( InMessage (..) + , GMIUrl (..) + , OutMessage (..) + ) where + +import RIO + +import Data.Aeson ((.:), (.=)) +import Network.HTTP.Req + ( Url + , Scheme (Https) + , useHttpsURI + , renderUrl + ) + +import qualified Data.Aeson as Ae +import qualified Data.Aeson.Types as Ae +import qualified RIO.Vector as V +import qualified Text.URI as URI + +data InMessage = InMessage + { hasAttach :: !Bool + , groupId :: !Text + , isUser :: !Bool + , text :: !Text + } deriving (Show, Generic) + +instance NFData InMessage + +instance Ae.FromJSON InMessage where + parseJSON = Ae.withObject "InMessage" $ \o -> InMessage + <$> (o .: "attachments" >>= Ae.withArray "attachments" (pure . not . null)) + <*> o .: "group_id" + <*> ((==) ("user" :: Text) <$> o .: "sender_type") + <*> o .: "text" + + +newtype GMIUrl = GMIUrl + { unGMIUrl :: Url Https + } deriving Show + +instance Ae.FromJSON GMIUrl where + parseJSON = Ae.withObject "payload" $ \o -> do + p <- o .: "payload" + u <- p .: "url" + GMIUrl <$> toUrl u + where + toUrl :: Text -> Ae.Parser (Url Https) + toUrl t = maybe mzero pure $ fmap fst $ useHttpsURI =<< URI.mkURI t + +data OutMessage = OutMessage + { image :: !GMIUrl + } deriving Show + +instance Ae.ToJSON OutMessage where + toJSON om = Ae.object + [ "attachments" .= + ( Ae.Array $ V.singleton attach ) + -- , "bot_id" .= botId + ] + where + attach :: Ae.Value + attach = Ae.object + [ "type" .= ("image" :: Text) + , "url" .= url + ] + url :: Text + url = renderUrl $ unGMIUrl $ image om + + -- { + -- "bot_id" : "j5abcdefg", + -- "text" : "Hello world", + -- "attachments" : [ + -- { + -- "type" : "image", + -- "url" : "https://i.groupme.com/somethingsomething.large" + -- } + -- ] +-- } diff --git a/src/Tomato/Data/Tomato.hs b/src/Tomato/Data/Tomato.hs new file mode 100644 index 0000000..4b75adf --- /dev/null +++ b/src/Tomato/Data/Tomato.hs @@ -0,0 +1,70 @@ +module Tomato.Data.Tomato + ( Links (..) + , Tomato (..) + , Urls (..) + ) where + +import RIO + +import Data.Aeson ((.:)) +import Network.HTTP.Req (Url, Scheme (Https), useHttpsURI) + +import qualified Data.Aeson as Ae +import qualified Data.Aeson.Types as Ae +import qualified Text.URI as URI + + +data Tomato = Tomato + { id :: !Text + , width :: !Word + , height :: !Word + , color :: !Text + , blur_hash :: !Text + , description :: !Text + , urls :: !Urls + , links :: !Links + } deriving Show + +instance Ae.FromJSON Tomato where + parseJSON = Ae.withObject "Tomato" $ \o -> Tomato + <$> o .: "id" + <*> o .: "width" + <*> o .: "height" + <*> o .: "color" + <*> o .: "blur_hash" + <*> o .: "description" + <*> o .: "urls" + <*> o .: "links" + +data Links = Links + { self :: !(Url Https) + , html :: !(Url Https) + , download :: !(Url Https) + , download_location :: !(Url Https) + } deriving Show + +instance Ae.FromJSON Links where + parseJSON = Ae.withObject "Links" $ \o -> Links + <$> (o .: "self" >>= toUrl) + <*> (o .: "html" >>= toUrl) + <*> (o .: "download" >>= toUrl) + <*> (o .: "download_location" >>= toUrl) + +data Urls = Urls + { raw :: !(Url Https) + , full :: !(Url Https) + , regular :: !(Url Https) + , small :: !(Url Https) + , thumb :: !(Url Https) + } deriving Show + +instance Ae.FromJSON Urls where + parseJSON = Ae.withObject "Urls" $ \o -> Urls + <$> (o .: "raw" >>= toUrl) + <*> (o .: "full" >>= toUrl) + <*> (o .: "regular" >>= toUrl) + <*> (o .: "small" >>= toUrl) + <*> (o .: "thumb" >>= toUrl) + +toUrl :: Text -> Ae.Parser (Url Https) +toUrl t = maybe mzero pure $ fmap fst $ useHttpsURI =<< URI.mkURI t diff --git a/src/Tomato/Post.hs b/src/Tomato/Post.hs index c3bd847..4adcdbb 100644 --- a/src/Tomato/Post.hs +++ b/src/Tomato/Post.hs @@ -10,6 +10,9 @@ import Network.HTTP.Req ( jsonResponse , ignoreResponse , req + , Req + , defaultHttpConfig + , runReq , ReqBodyFile (..) , ReqBodyJson (..) , (/:) @@ -20,46 +23,47 @@ import Network.HTTP.Req , responseBody ) -import Data.Message (GMIUrl (..), OutMessage (..)) +import Tomato.Data.Except (DecodeException (..)) +import Tomato.Data.Message (GMIUrl (..), OutMessage (..)) +import Tomato.App (App (..)) import qualified Data.Aeson as Ae import qualified Data.Aeson.KeyMap as Ae +import qualified RIO.Text as T --- TODO global config reader monad -tomatoFile :: FilePath -tomatoFile = "tomato.png" - -accessToken :: ByteString -accessToken = "t2YhlxxwZmn2cWfkAomjMc6BgVPMaC5NRkqHzGQl" - -botId :: Text -botId = "713bcb4a4604006c944804552c" -- | Post the current tomato -postTomato :: Req () +postTomato :: RIO App () postTomato = do url <- uploadTomato postMessage $ OutMessage url -- | Upload the current tomato to the GroupMe image server -uploadTomato :: Req GMIUrl +uploadTomato :: RIO App GMIUrl uploadTomato = do + tomatoFile <- asks appFile + accessToken <- asks appToken let url = https "image.groupme.com" /: "pictures" - js <- req POST url (ReqBodyFile tomatoFile) jsonResponse $ + js <- rr $ 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 + Ae.Error s -> throwM $ DecodeException $ T.pack s return gmURL -- | Post a message to the group with image as attachment -postMessage :: OutMessage -> Req () +postMessage :: OutMessage -> RIO App () postMessage outMes = do + botId <- asks appBotId + accessToken <- asks appToken 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 $ + rr $ req POST url (ReqBodyJson outMes') ignoreResponse $ header "X-Access-Token" accessToken return () + +rr :: Req a -> RIO App a +rr = runReq defaultHttpConfig diff --git a/src/Tomato/Retrieve.hs b/src/Tomato/Retrieve.hs index 80bdac6..2f7f20b 100644 --- a/src/Tomato/Retrieve.hs +++ b/src/Tomato/Retrieve.hs @@ -10,49 +10,53 @@ import Network.HTTP.Req ( jsonResponse , bsResponse , req + , Req + , runReq + , defaultHttpConfig , NoReqBody (..) , (/:) , (=:) - , Req , GET (..) , https , responseBody ) -import Data.Tomato (Tomato (..), Links (..)) +import Tomato.App (App (..)) +import Tomato.Data.Except (DecodeException (..)) +import Tomato.Data.Tomato (Tomato (..), Links (..)) import qualified Data.Aeson as Ae import qualified RIO.ByteString as B +import qualified RIO.Text as T --- TODO global config reader monad -tomatoFile :: FilePath -tomatoFile = "tomato.png" - -clientId :: Text -clientId = "FbzqI-oR7277JwL1ZGsyUw7yG1F5U0U3WhQ3kOW71Do" - -- | Get a random tomato -randomTomato :: Req () +randomTomato :: RIO App () randomTomato = queryTomato >>= downloadTomato -- | Ask for a tomato -queryTomato :: Req Tomato +queryTomato :: RIO App Tomato queryTomato = do + clientId <- asks appClientId let url = https "api.unsplash.com" /: "photos" /: "random" - js <- req GET url NoReqBody jsonResponse $ + js <- rr $ req GET url NoReqBody jsonResponse $ "query" =: ("tomato" :: Text) <> "client_id" =: clientId tomato <- case Ae.fromJSON (responseBody js) of Ae.Success r -> pure r - Ae.Error _s -> error "deal with this later" + Ae.Error s -> throwM $ DecodeException $ T.pack s return tomato -- | Download a specific tomato -downloadTomato :: Tomato -> Req () +downloadTomato :: Tomato -> RIO App () downloadTomato tom = do + tomatoFile <- asks appFile + clientId <- asks appClientId let url = download (links tom) - bs <- req GET url NoReqBody bsResponse $ + bs <- rr $ req GET url NoReqBody bsResponse $ "query" =: ("tomato" :: Text) <> "client_id" =: clientId B.writeFile tomatoFile (responseBody bs) + +rr :: Req a -> RIO App a +rr = runReq defaultHttpConfig diff --git a/src/Tomato/Validate.hs b/src/Tomato/Validate.hs index 0afc4b5..fe0d82a 100644 --- a/src/Tomato/Validate.hs +++ b/src/Tomato/Validate.hs @@ -4,9 +4,10 @@ module Tomato.Validate import RIO -import Data.Message (InMessage (..)) +import Tomato.Data.Message (InMessage (..)) +-- | Check if a message is a tomato request isTomato :: InMessage -> Bool isTomato m = not (hasAttach m) && -- cgit v1.2.3