Handle requests

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
deleted 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