Throttler.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DeriveGeneric #-}

module Main where

import Web.Scotty (get, post, delete, param, html, json, jsonData, scotty, ScottyM)
import Data.Aeson (FromJSON, ToJSON)
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Concurrent.STM (atomically, STM)
import Control.Concurrent.STM.TChan
import GHC.Generics (Generic)
import Control.Monad (forever)
import Control.Concurrent (forkIO, threadDelay)
import qualified Data.Text.Lazy as T

data Msg = Msg { to :: String
               , from :: String} deriving (Eq, Show, Generic)
instance FromJSON Msg
instance ToJSON Msg

main :: IO ()
main = do
  queueChn <- newTChanIO
  forkIO $ printMsg queueChn 
  scotty 3000 $ do
    testJson queueChn 

printMsg :: TChan (Msg, TChan T.Text) -> IO ()
printMsg queueChn = forever $ do
  (msg, respChn) <- liftSTM $ readTChan queueChn
  putStrLn $ show msg
  liftSTM $ writeTChan respChn "ok"
  threadDelay 1000000


testJson :: TChan (Msg, TChan T.Text) -> ScottyM ()
testJson queueChn = do
  post "/msg" $ process queueChn 

process queueChn = do
  msg <- jsonData
  respChn <- liftIO $ newTChanIO
  liftSTM $ writeTChan queueChn (msg, respChn)
  resp <- liftSTM $ readTChan respChn
  html resp


liftSTM :: MonadIO m => STM a -> m a
liftSTM ma = liftIO $ atomically ma