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リクエストごとに新しいものを提供するサーバントのようです。サービス (name = "file") を作成するために POST を送信しましたが、GET 要求でサービスを取得できません。サーバントのリクエスト間でデータを共有する方法は?

4

1 に答える 1

3

defaultServicesリクエストごとに新しいものを提供するサーバントのようです。

それは、書かれたコードがSTMそうするためのアクションだからです。論理に従って—

defaultServices :: ServiceSet
defaultServices = newTVar ...

この (断片的な) 定義は決定的にアクションを実行STMして新しい を生成しませんTVar。代わりに、を生成できるアクションである値 ( defaultServices) を定義します。where gets passed to に続いて、次のようにハンドラーで使用します—STMTVardefaultServices

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

your に格納されているアクション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、実際の を表すようになりました。なんらかのアクションを実行する必要があるため、初めての場合、これを書くのは難しいように思えるかもしれませんが、それをアクションに変えるだけで、おそらく逃げる方法がないことを「知っている」でしょう。ただし、これは実際には信じられないほど一般的であり、使用中の関数の実際のstm ドキュメントをざっと見てみると、答えがすぐにわかります。TVarTVarSTMatomicallyIOIO

これは、Haskell 開発者としての人生でunsafePerformIO. の定義は、atomically何をしなければならないかをほぼ正確に示しています。

一連の STM アクションをアトミックに実行します。

または atomicallyの内部では使用できません。そうしようとすると、実行時エラーが発生します。(理由: これを許可すると、サンクが評価される正確なタイミングに応じて、トランザクション内のトランザクションが事実上許可されます。)unsafePerformIOunsafeInterleaveIO

ただし、 を参照してくださいnewTVarIO。これは 内で呼び出すことがunsafePerformIOでき、トップレベルTVarの を割り当てることができます。

ここで、このパズルの最後のピースが 1 つありますが、これはドキュメントにはありません。それは、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 #-}

これは優れたソリューションであり、私はそれを製品コードで喜んで使用していますが、これにはいくつかの反論があります。ハンドラー モナド スタックでa を使用することは既に問題ないのでReaderT(上記の解決策は主に、何らかの理由で参照をスレッド化することを避けている人向けです)、TVarプログラムの初期化時に new を作成し、それを渡すことができます。それがどのように機能するかの最も簡単なスケッチを以下に示します。

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 に答える