package.yaml

name: erlchat-test

dependencies:
  - base >= 4.12 && < 5
  - servant
  - servant-server
  - warp
  - stm
  - mtl

executables:
  erlchat-test:
    main: Main.hs

servant-state-t.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

import Control.Concurrent.STM (atomically, check, newTVarIO, readTVar, writeTVar)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.State (StateT, get, modify, runStateT)
import Data.Proxy (Proxy (..))
import Network.Wai.Handler.Warp (run)
import Servant (Get, Handler, JSON, ServerT, hoistServer, serve, (:<|>) (..), (:>))

type API = "get" :> Get '[JSON] Int :<|> "inc" :> Get '[JSON] ()

newtype f ~> g = NT {runNT :: forall x. f x -> g x}

mkStateNT :: s -> IO (StateT s Handler ~> Handler)
mkStateNT init = do
  lock <- newTVarIO False
  state <- newTVarIO init
  let hoist handler = do
        state' <- (liftIO . atomically) do
          check . not =<< readTVar lock
          writeTVar lock True
          readTVar state
        (result, state') <- runStateT handler state'
        (liftIO . atomically) do
          writeTVar lock False
          writeTVar state state'
        pure result
  pure (NT hoist)

api :: Proxy API
api = Proxy

server :: ServerT API (StateT Int Handler)
server = get :<|> modify (+ 1)

main :: IO ()
main = do
  stateNT <- mkStateNT 0
  run 8080 (serve api (hoistServer api (runNT stateNT) server))