Слуга всегда дает мне начальное значение в ReaderT Monad

Question

Я изучаю Слугу и пишу простой сервис. Вот исходный код:

{-# 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 с. После где 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, который можно назвать внутри unsafePerformIO, и который позволяет верхнего уровня 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 #-} 

---

Теперь это прекрасное решение, и я с удовольствием использовал его в производстве кода, но есть some objections к нему. Так как вы уже отлично справляетесь с использованием ReaderT в стеке моноды вашего обработчика (и вышеприведенное решение в основном для людей, которые почему-то избегают потоковой ссылки), вы можете просто создать новый TVar при инициализации программы, а затем передать это in. Самый короткий набросок того, как это будет работать, ниже.

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