diff options
| -rw-r--r-- | app/Main.hs | 54 | ||||
| -rw-r--r-- | package.yaml | 9 | ||||
| -rw-r--r-- | src/Data/Message.hs | 9 | ||||
| -rw-r--r-- | src/Tomato/.Post.hs.swp | bin | 12288 -> 0 bytes | |||
| -rw-r--r-- | src/Tomato/Validate.hs | 2 | ||||
| -rw-r--r-- | tomatobot.cabal | 64 |
6 files changed, 73 insertions, 65 deletions
diff --git a/app/Main.hs b/app/Main.hs index bdbef74..3f1dcf5 100644 --- a/app/Main.hs +++ b/app/Main.hs @@ -1,9 +1,11 @@ module Main - ( main - ) where + ( main + ) where import RIO +import Data.Conduit (runConduit, (.|)) +import Data.Conduit.Attoparsec (sinkParser) import Network.HTTP.Req ( jsonResponse , req @@ -17,17 +19,24 @@ import Network.HTTP.Req , defaultHttpConfig , runReq ) +import Network.HTTP.Types (status200, status500) +import Network.Wai (responseBuilder, responseLBS, Response) +import Network.Wai.Conduit (sourceRequestBody) +import Network.Wai.Handler.Warp (run) +import Data.Message (InMessage (..)) import Data.Tomato (Tomato) import Tomato.Post (postTomato) +import Tomato.Validate (isTomato) -import qualified Data.Aeson.Types as Ae +import qualified Data.Aeson as Ae +import qualified Data.ByteString.Lazy.Char8 as BL8 data App = App { appLogFunc :: !LogFunc - , appName :: !Utf8Builder - , appToken :: !Text + , appToken :: !Text + , appBotId :: !Text } instance HasLogFunc App where @@ -41,13 +50,13 @@ runApp inner = do withLogFunc logOptions $ \logFunc -> do let app = App { appLogFunc = logFunc - , appName = "Tomato Bot" - , appToken = "placeholder" + , appToken = "placeholder" + , appBotId = "placeholder" } runRIO app inner -randomTomato :: Req Tomato -randomTomato = do +_randomTomato :: Req Tomato +_randomTomato = do let url = https "api.unsplash.com" /: "photos" /: "random" js <- req GET url NoReqBody jsonResponse $ "query" =: ("tomato" :: Text) <> @@ -59,8 +68,6 @@ randomTomato = do tomatoBot :: RIO App () tomatoBot = do - name <- view $ to appName - logInfo $ "Hello, " <> name logInfo $ "Fetching tomato" -- tomato <- runReq defaultHttpConfig randomTomato -- logInfo $ displayShow tomato @@ -70,4 +77,27 @@ tomatoBot = do logInfo $ "All done" main :: IO () -main = runApp tomatoBot +main = run 3000 $ \request send -> do + eres <- tryAnyDeep $ do + val <- runConduit + $ sourceRequestBody request + .| sinkParser Ae.json + case Ae.fromJSON val of + Ae.Success r -> return r + Ae.Error _s -> error "handle this later" + case eres of + Left e -> send $ errorResponse e + Right inMes -> do + when (isTomato inMes) $ runApp tomatoBot + send $ validResponse inMes + where + errorResponse :: SomeException -> Response + errorResponse e = responseLBS + status500 + [("Content-Type", "text/plain")] + $ BL8.pack $ "Exception occurred: " ++ show e + validResponse :: InMessage -> Response + validResponse inMes = responseBuilder + status200 + [("Content-Type", "application/json")] + $ Ae.fromEncoding $ Ae.toEncoding $ text inMes diff --git a/package.yaml b/package.yaml index efb09cf..bfe8700 100644 --- a/package.yaml +++ b/package.yaml @@ -8,7 +8,6 @@ copyright: "2022 Author name here" extra-source-files: - README.md -- ChangeLog.md # Metadata used when publishing your package # synopsis: Short description of your package @@ -25,6 +24,14 @@ dependencies: - modern-uri - req - rio +- wai +- wai-conduit +- warp +- http-types +- bytestring +- unliftio +- conduit +- conduit-extra library: source-dirs: src diff --git a/src/Data/Message.hs b/src/Data/Message.hs index dfbc20b..c218cdc 100644 --- a/src/Data/Message.hs +++ b/src/Data/Message.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveGeneric #-} module Data.Message ( InMessage (..) , GMIUrl (..) @@ -21,15 +22,17 @@ import qualified Text.URI as URI data InMessage = InMessage { hasAttach :: !Bool - , groupId :: !Word + , groupId :: !Text , isUser :: !Bool , text :: !Text - } deriving Show + } 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" + <*> o .: "group_id" <*> ((==) ("user" :: Text) <$> o .: "sender_type") <*> o .: "text" diff --git a/src/Tomato/.Post.hs.swp b/src/Tomato/.Post.hs.swp Binary files differdeleted file mode 100644 index f823f90..0000000 --- a/src/Tomato/.Post.hs.swp +++ /dev/null diff --git a/src/Tomato/Validate.hs b/src/Tomato/Validate.hs index a3dd328..0afc4b5 100644 --- a/src/Tomato/Validate.hs +++ b/src/Tomato/Validate.hs @@ -10,7 +10,7 @@ import Data.Message (InMessage (..)) isTomato :: InMessage -> Bool isTomato m = not (hasAttach m) && - groupId m == 87220147 && + groupId m == "87220147" && isUser m && text m == "tomato" diff --git a/tomatobot.cabal b/tomatobot.cabal index 95e382a..f4202d1 100644 --- a/tomatobot.cabal +++ b/tomatobot.cabal @@ -13,11 +13,9 @@ author: Author name here maintainer: example@example.com copyright: 2022 Author name here license: BSD3 -license-file: LICENSE build-type: Simple extra-source-files: README.md - ChangeLog.md source-repository head type: git @@ -66,9 +64,17 @@ library build-depends: aeson , base >=4.7 && <5 + , bytestring + , conduit + , conduit-extra + , http-types , modern-uri , req , rio + , unliftio + , wai + , wai-conduit + , warp default-language: Haskell2010 executable tomatobot-exe @@ -110,54 +116,16 @@ executable tomatobot-exe build-depends: aeson , base >=4.7 && <5 + , bytestring + , conduit + , conduit-extra + , http-types , modern-uri , req , rio , tomatobot - default-language: Haskell2010 - -test-suite tomatobot-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Paths_tomatobot - hs-source-dirs: - test - default-extensions: - ApplicativeDo - BangPatterns - ConstraintKinds - DataKinds - EmptyCase - ExistentialQuantification - FlexibleContexts - FlexibleInstances - GADTs - GeneralizedNewtypeDeriving - InstanceSigs - KindSignatures - LambdaCase - MultiParamTypeClasses - NoImplicitPrelude - NoStarIsType - OverloadedStrings - PatternSynonyms - PolyKinds - RankNTypes - ScopedTypeVariables - StandaloneDeriving - StandaloneKindSignatures - TupleSections - TypeApplications - TypeFamilies - TypeFamilyDependencies - TypeOperators - ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wredundant-constraints -Wmissing-local-signatures -Wmissing-export-lists -Wpartial-fields -Wmonomorphism-restriction -Widentities -Wno-unticked-promoted-constructors -fprint-expanded-synonyms -threaded -rtsopts -with-rtsopts=-N - build-depends: - aeson - , base >=4.7 && <5 - , modern-uri - , req - , rio - , tomatobot + , unliftio + , wai + , wai-conduit + , warp default-language: Haskell2010 |