Scotty+STMで状態を持ったサーバ

stm.hs

{-# LANGUAGE OverloadedStrings #-}

module Main where

import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad.IO.Class
import Data.Text.Lazy
import Web.Scotty
import Data.Aeson.Types

newtype Counter = Counter (TVar Int)

getCounter :: Counter -> IO Int
getCounter (Counter c) = atomically . readTVar $ c

newCounter :: IO Counter
newCounter = fmap Counter (newTVarIO 0)

incCounter :: Counter -> IO ()
incCounter (Counter c) = atomically $ modifyTVar c succ

delay :: Int -> IO ()
delay = threadDelay . (* 1000)

act :: Counter -> IO ThreadId
act c =
  forkIO $ do
    delay 10000
    incCounter c
    delay 10000
    incCounter c
    putStrLn "finish!"

main :: IO ()
main = do
   c <- newCounter
   scotty 3000 $ do
    get "/get" $ do
      liftIO . putStrLn $ "get!"
      liftIO (getCounter c) >>= json

    get "/inc" $ do
      liftIO . putStrLn $ "inc!"
      liftIO $ incCounter c
      liftIO (getCounter c) >>= json

    get "/act" $ do
      liftIO . putStrLn $ "act!"
      _ <- liftIO . act $ c
      return ()