Servant always give me a initial value in ReaderT Monad

I'm learning Servant and write a simple service. Here's source code:

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}

module BigMama where

import           Control.Concurrent
import           Control.Concurrent.STM
import           Control.Monad
import           Control.Monad.Reader
import           Data.Aeson
import           Data.Aeson.Types
import qualified Data.ByteString.Lazy.Char8 as C
import           Data.Char
import qualified Data.Map as M
import           Debug.Trace
import           GHC.Generics
import           Prelude hiding (id)
import           Servant

data MicroService = MicroService
  { name :: String
  , port :: Int
  , id :: Maybe String
  } deriving (Generic)

instance ToJSON MicroService
instance FromJSON MicroService

instance Show MicroService where
  show = C.unpack . encode

type ServiceSet = STM (TVar (M.Map String MicroService))

type LocalHandler = ReaderT ServiceSet IO

defaultServices :: ServiceSet
defaultServices = newTVar $ M.fromList []

type Api =
  "bigmama" :> Get '[JSON] (Maybe MicroService)
  :<|> "bigmama" :> ReqBody '[JSON] MicroService :> Post '[JSON] MicroService

api :: Proxy Api
api = Proxy

serverT :: ServerT Api LocalHandler
serverT = getService
  :<|> registerService

getService :: LocalHandler (Maybe MicroService)
getService = do
  stm <- ask
  liftIO . atomically $ do
    tvar <- stm
    mss <- readTVar tvar
    return $ M.lookup "file" mss

registerService :: MicroService -> LocalHandler MicroService
registerService ms = do
  stm <- ask
  liftIO . atomically $ do
    tvar <- stm
    mss <- readTVar tvar
    let mss' = M.insert (name ms) ms mss
    writeTVar tvar mss'
  return ms

readerToHandler' :: forall a. ServiceSet -> LocalHandler a -> Handler a
readerToHandler' ss r = liftIO $ runReaderT r ss

readerToHandler :: ServiceSet -> (:~>) LocalHandler Handler
readerToHandler ss = Nat (readerToHandler' ss)

server :: Server Api
server = enter (readerToHandler defaultServices) serverT

It seems like servant providing a new defaultServices for every request. I send POST to create service (name = "file") and can't get the service back on GET request. How to share data among requests on servant?

Solution

It seems like servant providing a new defaultServices for every request.

It is, because your code as written is an STM action to do so. Following the logic—

defaultServices :: ServiceSet
defaultServices = newTVar ...

This (fragmentary) definition crucially does not run the STM action to produce a new TVar. Instead it defines a value (defaultServices) which is an STM action which can produce TVars. Following where defaultServices gets passed to, you use it in your handlers like—

getService = do
  stm <- ask
  liftIO . atomically $ do
    tvar <- stm
    ...

The action stored in your Reader is unchanged from the defaultServices value itself, so this code is equivalent to—

getService = do
  liftIO . atomically $ do
    tvar <- defaultServices
    ...

And by substituting in the definition of defaultServices—

getService = do
  liftIO . atomically $ do
    tvar <- newTVar ...
    ...

This now looks obviously wrong. Instead of defaultServices being an action to produce a new TVar, it should be that TVar itself, right? So on the type level without aliases—

type ServiceSet = STM (TVar (M.Map String MicroService)) -- From this
type Services   =      TVar (M.Map String MicroService)  -- To this

defaultServices :: Services

Now defaultServices represents an actual TVar, instead of a method of creating TVars. Writing this may seem tricky if it's your first time because you somehow have to run an STM action, but atomically just turns that into an IO action, and you probably “know” that there is no way to escape IO. This actually is incredibly common though, and a quick look at the actual stm documentation for the functions in play will point you right to the answer.

It turns out that this is one of those exciting times in your life as a Haskell developer that you get to use unsafePerformIO. The definition of atomically spells out pretty much exactly what you have to do.

Perform a series of STM actions atomically.

You cannot use atomically inside an unsafePerformIO or unsafeInterleaveIO. Any attempt to do so will result in a runtime error. (Reason: allowing this would effectively allow a transaction inside a transaction, depending on exactly when the thunk is evaluated.)

However, see newTVarIO, which can be called inside unsafePerformIO, and which allows top-level TVars to be allocated.

Now there's one final piece of this puzzle that isn't in the documentation, which is that unless you tell GHC not to inline your top-level value produced using unsafePerformIO, you might still end up with sites where you use defaultServices having their own unique set of services. E.g., without forbidding inlining this would happen—

getService = do
  liftIO . atomically $ do
    mss <- readTVar defaultServices

getService = do
  liftIO . atomically $ do
    mss <- readTVar (unsafePerformIO $ newTVarIO ...)
    ...

This is a simple fix though, just add a NOINLINE pragma to your definition of defaultServices.

defaultServices :: Services
defaultServices = unsafePerformIO $ newTVar M.empty
{-# NOINLINE defaultServices #-}

Now this is a fine solution, and I've happily used it in production code, but there are some objections to it. Since you're already fine with using a ReaderT in your handler monad stack (and the above solution is mostly for people who for some reason are avoiding threading a reference around), you could just create a new TVar at program initialization and then pass that in. The briefest sketch of how that would work is below.

main :: IO ()
main = do
  services <- atomically (newTVar M.empty)
  run 8080 $ serve Proxy (server services)

server :: TVar Services -> Server Api
server services = enter (readerToHandler services) serverT

getService :: LocalHandler (Maybe MicroService)
getService = do
  services <- ask
  liftIO . atomically $ do
    mss <- readTVar services
    ...