Servant geben Sie mir immer einen Anfangswert in ReaderT Monad

Question

Ich lerne Servant und schreibe einen einfachen Service. Hier Quellcode:

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

Es scheint, als Diener für jede Anfrage einen neuen defaultServices bereitstellt. Ich sende POST, um Dienst (Name = "Datei") zu erstellen, und kann den Dienst nicht auf GET-Anforderung abrufen. Wie teilt man Daten zwischen Anfragen auf Diener?

Answer 1

Es scheint wie Servant Bereitstellung eines neuen defaultServices für jede Anfrage.

Es ist, weil Ihr Code wie geschrieben ist eine STM Aktion zu tun. Nach der Logik —

defaultServices :: ServiceSet 
defaultServices = newTVar ... 

Diese (fragmentarisch) Definition entscheidend nicht läuft die STM Aktion ein neues TVar zu erzeugen. Stattdessen definiert es einen Wert (defaultServices), der eine STM Aktion ist, die TVar s produzieren kann. Nach dem defaultServices zu übergeben wird, verwenden Sie es in Ihrem Handler wie —

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

Die Aktion gespeichert in Ihrem Reader ist unverändert aus dem defaultServices Wert selbst, so dass dieser Code entspricht —

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

Und indem die Definition von defaultServices —

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

ersetzt wird

Das sieht jetzt offensichtlich falsch aus. Anstatt defaultServices eine Aktion zu sein, um eine neue TVar zu produzieren, sollte es sein, dass TVar sich selbst, richtig? Also auf der Typ-Ebene ohne Aliase —

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

defaultServices :: Services 

Jetzt defaultServices stellt eine tatsächliche TVar, anstelle eines Verfahrens zum Erzeugen TVar s. Dies zu schreiben kann schwierig erscheinen, wenn es Ihr erstes Mal ist, weil Sie irgendwie eine STM Aktion ausführen müssen, aber atomically verwandelt das in eine IO Aktion, und Sie wissen wahrscheinlich ”, dass es keine Möglichkeit gibt, IO zu entkommen. Dies ist tatsächlich unglaublich gemeinsame obwohl, und ein kurzer Blick auf die tatsächlichen stm documentation für die Funktionen im Spiel wird Sie direkt auf die Antwort zeigen.

Es stellt sich heraus, dass dies eine der aufregenden Zeiten in Ihrem Leben als Haskell-Entwickler ist, die Sie verwenden können, unsafePerformIO. Die Definition von atomically sagt ziemlich genau, was Sie tun müssen.

Eine Reihe von STM-Aktionen atomar ausführen.

Sie können atomically in einem unsafePerformIO oder unsafeInterleaveIO nicht verwenden. Jeder Versuch führt zu einem Laufzeitfehler Fehler. (Grund:. Erlauben würde dies effektiv eine Transaktion innerhalb einer Transaktion ermöglichen, je nach genau, wann der Thunk ist ausgewertet)

jedoch sehen newTVarIO, die innerhalb unsafePerformIO bezeichnet werden können, und der es ermöglicht Top-Level-TVar s zugewiesen werden.

Jetzt gibt es ein letztes Stück des Puzzles, die nicht in der Dokumentation ist, die das ist, wenn Sie GHC sagen nicht Ihren Top-Level-Wert Inline unsafePerformIO der unter Verwendung von, können Sie immer noch mit Websites landen, wo Sie Verwenden Sie defaultServices mit ihren eigenen einzigartigen Satz von Diensten. Zum Beispiel, ohne das Verbot inlining dies geschehen würde —

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

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

Dies ist eine einfache Lösung aber nur eine NOINLINE Pragma Ihrer Definition von defaultServices hinzuzufügen.

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

---

Nun ist dies eine feine Lösung, und ich habe es gerne in der Produktion Code, aber es gibt some objections zu. Da Sie bereits einen ReaderT in Ihrem Handler-Monad-Stack verwenden können (und die obige Lösung hauptsächlich für Leute gedacht ist, die aus irgendeinem Grund vermeiden, eine Referenz herumzufädeln), könnten Sie einfach eine neue TVar bei der Programminitialisierung erstellen und diese dann übergeben Die kürzeste Skizze, wie das funktionieren würde, ist unten.

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