Counter.hs

-- | Test case for ReaderT based server
module Test.Server.Counter (spec) where

import Control.Monad.Reader
import Data.IORef
import Data.Maybe
import Data.Text qualified as Text
import Mig.Core
import Mig.Core qualified as Request (Request (..))
import Network.HTTP.Types.Method (methodPost)
import Test.Hspec
import Test.Server.Common

-------------------------------------------------------------------------------------
-- server definition

newtype Env = Env (IORef Int)

initEnv :: IO Env
initEnv = Env <$> newIORef 0

newtype App a = App (ReaderT Env IO a)
  deriving newtype (Functor, Applicative, Monad, MonadReader Env, MonadIO)

runApp :: Env -> App a -> IO a
runApp env (App act) = runReaderT act env

{-| Server has two routes:

* get - to querry current state
* put - to add some integer to the state
-}
server :: Server App
server =
  "counter"
    /. [ "get" /. handleGet
       , "put" /. handlePut
       ]

-- | Get handler. It logs the call and returns current state
handleGet :: Get App (Resp Json Int)
handleGet = Send $ do
  Env ref <- ask
  liftIO $ ok <$> readIORef ref

-- | Put handler. It logs the call and updates the state with integer which is read from URL
handlePut :: Capture "arg" Int -> Post App (Resp Json ())
handlePut (Capture val) = Send $ do
  Env ref <- ask
  liftIO $ ok <$> atomicModifyIORef' ref (\cur -> (cur + val, ()))

-------------------------------------------------------------------------------------
-- test cases

spec :: Spec
spec = describe "counter server (ReaderT)" $ do
  describe "plain route finder" $ specBy plainApiStrategy
  describe "tree route finder" $ specBy treeApiStrategy

specBy :: FindRoute normalForm App -> Spec
specBy findRoute =
  it "run accumulator script" $
    script serverFun [1, 2, 3, 4] `shouldReturn` [1, 3, 6, 10]
  where
    serverFun = fromServer findRoute server

{-| Puts inputs to server and returns result of "counter/get" method call
on each increment
-}
script :: ServerFun App -> [Int] -> IO [Int]
script f inputs = do
  env <- initEnv
  runApp env $ catMaybes <$> mapM go inputs
  where
    go :: Int -> App (Maybe Int)
    go n = fmap (parseResp =<<) $ do
      mRes <- f (putReq n)
      if (isJust mRes)
        then f getReq
        else pure Nothing

    putReq :: Int -> Request
    putReq increment =
      emptyReq
        { method = methodPost
        , Request.path = ["counter", "put", Text.pack (show increment)]
        }

    getReq :: Request
    getReq = emptyReq{Request.path = ["counter", "get"]}