app/Main.hs


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59

module Main
  ( main
  ) where

import RIO

import Data.Conduit (runConduit, (.|))
import Data.Conduit.Attoparsec (sinkParser)
import Network.HTTP.Types (status200, status500)
import Network.Wai (responseBuilder, responseLBS, Response)
import Network.Wai.Conduit (sourceRequestBody)
import Network.Wai.Handler.Warp (run)
import System.Environment (getArgs)

import Tomato.App (runApp)
import Tomato.Bot (tomatoBot)
import Tomato.Data.Except (DecodeException (..))
import Tomato.Data.Message (InMessage (..))
import Tomato.Validate (isTomato)

import qualified Data.Aeson as Ae
import qualified Data.ByteString.Lazy.Char8 as BL8
import qualified RIO.List.Partial as L'
import qualified RIO.Text as T

-- | Listen for tomato message and respond with tomato
runServer :: Int -> IO ()
runServer port = run port $ \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 -> throwM $ DecodeException $ T.pack s
    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

main :: IO ()
main = do
    args <- getArgs
    when (null args) (error "no port")
    let portS = readMaybe $ L'.head args
    let port = maybe (error "invalid port") id portS
    runServer port