Servant 总是在 ReaderT Monad 给我一个初始值

Question

我正在学习 Servant 并编写一个简单的服务。这是源代码：

{-# 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

似乎仆人为每个请求提供了一个新的defaultServices。我发送 POST 来创建服务（名称 = "file"），但无法根据 GET 请求取回该服务。如何在 servant 的请求之间共享数据？

Answer 1

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

是的，因为您编写的代码是一个 STM 操作。按照逻辑——

defaultServices :: ServiceSet
defaultServices = newTVar ...

这个（零散的）定义根本不会运行 STM 动作产生新的 TVar。相反，它定义了一个值 (defaultServices)，它是一个可以产生 TVar 的 STM 动作。在 defaultServices 被传递到的位置之后，您可以在处理程序中使用它，例如 —

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

存储在您的 Reader 中的操作与 defaultServices 值本身没有变化，因此这段代码等同于—

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

并代入defaultServices的定义——

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

这现在看起来显然是错误的。 defaultServices 不是产生新 TVar 的动作，而是 TVar 本身，对吧？所以在没有别名的类型层面上——

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

defaultServices :: Services

现在 defaultServices 表示实际的 TVar，而不是创建 TVar 的方法。如果这是你第一次写这个可能看起来很棘手，因为你必须运行一个 STM 动作，但是 atomically 只是把它变成一个 IO 动作，你可能“知道”没有办法逃脱IO。这实际上是 令人难以置信的 常见，快速浏览一下正在运行的函数的实际 stm documentation 会告诉你正确的答案。

事实证明，这是您作为 Haskell 开发人员生活中激动人心的时刻之一，您可以使用 unsafePerformIO。 atomically 的定义几乎清楚地说明了您必须做的事情。

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.

现在这个难题的最后一块没有在文档中，那就是除非你告诉 GHC 不要内联你使用 unsafePerformIO 产生的顶级值，否则你可能仍然会得到您使用 defaultServices 的网站拥有自己独特的服务集。例如，如果不禁止内联，就会发生这种情况——

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

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

虽然这是一个简单的修复，只需在 defaultServices.

的定义中添加一个 NOINLINE pragma

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

现在这是一个很好的解决方案，我很乐意在生产代码中使用它，但是还有 some objections。由于您已经可以在处理程序 monad 堆栈中使用 ReaderT （并且上述解决方案主要适用于出于某种原因避免使用线程引用的人），您可以创建一个新的 TVar 在程序初始化时，然后将其传递进去。下面是其工作原理的最简短草图。

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

Servant 总是在 ReaderT Monad 给我一个初始值

Servant always give me a initial value in ReaderT Monad

haskell

servant