Servant always give me a initial value in ReaderT Monad - haskell

Question

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?

Answer 1

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
...