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以创建服务（name =“file”），并且无法在GET请求上返回服务。如何在服务员的请求之间共享数据？

Answer 1

似乎服务员为每个请求提供了新的defaultServices。

是的，因为您编写的代码是STM操作。遵循逻辑 -

defaultServices :: ServiceSet
defaultServices = newTVar ...

这个（零碎的）定义关键不会运行 STM动作来生成新的TVar。相反，它定义了一个值defaultServices，这是一个STM动作，可以产生TVar s。在传递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的定义完全解释了你必须做的事情。

以原子方式执行一系列STM操作。

您无法在atomically或unsafePerformIO内使用unsafeInterleaveIO   newTVarIO。任何这样做的尝试都将导致运行时   错误。（原因：允许这将有效地允许交易   在事务内部，具体取决于thunk的确切时间   进行评价。）

但是，请参阅可在unsafePerformIO内调用的TVar，   并且允许分配顶级unsafePerformIO。

现在这个难题的最后一部分不在文档中，除非你告诉GHC不要内联使用defaultServices生成的顶级值，否则你可能仍然会在您使用getService = do liftIO . atomically $ do mss <- readTVar defaultServices getService = do liftIO . atomically $ do mss <- readTVar (unsafePerformIO $ newTVarIO ...) ...拥有自己独特的服务集。例如，在没有禁止内联的情况下会发生这种情况 -

NOINLINE

这是一个简单的修复，只需在defaultServices的定义中添加defaultServices :: Services defaultServices = unsafePerformIO $ newTVar M.empty {-# NOINLINE defaultServices #-}编译指示。

ReaderT

现在这是一个很好的解决方案，我很高兴在生产代码中使用它，但它有some objections。由于你已经在你的处理程序monad堆栈中使用TVar已经很好了（上面的解决方案主要是出于某种原因避免线程引用的人），你可以创建一个新的{{1}程序初始化然后传入。最简单的草图如何工作在下面。

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

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

1 个答案: