2

我正在学习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 以创建服务（名称 =“文件”），但无法通过 GET 请求恢复服务。如何在服务端的请求之间共享数据？

4

1 回答 1

3

似乎仆人defaultServices为每个请求提供了一个新的。

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

defaultServices :: ServiceSet
defaultServices = newTVar ...

这个（零碎的）定义关键不会运行STM产生新的TVar. 相反，它定义了一个值 ( defaultServices)，它是一个STM可以产生TVars 的动作。在传递到 where 之后defaultServices，您可以在处理程序中使用它，例如-

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

存储在 yourReader中的动作与值本身没有变化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，而不是创建TVars 的方法。如果这是你第一次写这个可能看起来很棘手，因为你必须以某种方式运行一个STM动作，但atomically只是把它变成一个IO动作，你可能“知道”没有办法逃脱IO。不过，这实际上是非常普遍的，快速查看实际的stm 文档以了解正在使用的函数将为您指明答案。

事实证明，这是您作为 Haskell 开发人员可以使用的那些激动人心的时刻之一unsafePerformIO。定义atomically几乎准确地说明了您必须做什么。

原子地执行一系列 STM 动作。

您不能在or atomically内使用。任何这样做的尝试都会导致运行时错误。（原因：允许这将有效地允许事务内部的事务，具体取决于评估 thunk 的确切时间。）unsafePerformIOunsafeInterleaveIO

但是，请参阅newTVarIO，它可以在内部调用，并且允许分配unsafePerformIO顶级s。TVar

现在这个难题的最后一个部分不在文档中，那就是除非您告诉 GHC 不要内联使用 生成的顶级值，否则您unsafePerformIO最终可能仍会使用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在处理程序 monad 堆栈中使用 a （并且上述解决方案主要适用于出于某种原因避免线程引用的人），您可以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
    ...
于 2016-07-01T17:23:04.513 回答