如何在Happstack中携带非酸性价值？

Question

我读过Happstack撞车事故。我的网络服务器几乎完全按照Passing multiple AcidState handles around transparently

部分的描述

我遇到的问题是，我的价值是非酸性的，但想要在Happstack应用程序中访问。具体来说，来自push-notify-general library的“PushManager”，

我想要的是：

data Acid = Acid
   { acidCountState    :: AcidState CountState
  , acidGreetingState :: AcidState GreetingState
  , acidPushManager   :: AcidState PushManager
  }

我无法做到这一点，因为1）PushManager在内部使用如此多的数据类型，并且通过调用$（deriveSafeCopy ...）使底层数据类型SafeCopy兼容是不现实/健壮的。 2）PushManager不仅包含简单的值，还包含与SafeCopy兼容的功能。

我试过的其他事情是“酸”数据声明不仅携带AcidState，还携带非AcidState数据。通过查看runApp的定义，“Acid”仅用于Reading，所以我认为用State monad重写可能能够满足我的需求。 - 但事实证明并非如此简单。我的暂定代码是：

{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, 
     TemplateHaskell, TypeFamilies, DeriveDataTypeable, 
     FlexibleContexts, ScopedTypeVariables, 
     NamedFieldPuns, DeriveFunctor, StandaloneDeriving, OverloadedStrings #-}


import Control.Applicative         ( Applicative, Alternative, (<$>))
import Control.Monad               ( MonadPlus )
import Control.Monad.State.Strict  ( MonadState, StateT, get, put,  evalStateT )
import Control.Monad.Trans         ( MonadIO )
import Data.Acid
import Data.Data                   ( Data, Typeable )

import Happstack.Server 



newtype Simple a = Simple { unSimple :: a }
                   deriving (Show)

data CountState = CountState { count :: Integer }
    deriving (Eq, Ord, Data, Typeable, Show)

-- This data is equivalent to the one previously called "Acid"
data States = States {
  simpleState :: Simple Int
  , acidCountState :: AcidState CountState
  }


initialStates :: States
initialStates = States { simpleState = Simple 1, acidCountState = undefined }


newtype App a = App { unApp :: ServerPartT (StateT States IO) a }
    deriving ( Functor, Alternative, Applicative, Monad                
             , MonadPlus, MonadIO, HasRqData, ServerMonad
             , WebMonad Response, FilterMonad Response
             , Happstack, MonadState States )



class HasSimple m st where
  getSimple :: m (Simple st)
  putSimple :: (Simple st) -> m ()


instance HasSimple App Int where
  getSimple = simpleState <$> get
  putSimple input = do
    whole <- get
    put $ whole {simpleState = input}


simpleQuery :: ( Functor m
               , HasSimple m a
               , MonadIO m
               , Show a
               ) =>
               m a
simpleQuery = do
  (Simple a) <- getSimple
  return a


simpleUpdate :: ( Functor m
                , HasSimple m a
                , MonadIO m
                , Show a
                ) =>
                a
                -> m ()
simpleUpdate a = putSimple (Simple a)


runApp :: States -> App a -> ServerPartT IO a
runApp states (App sp) = do
  mapServerPartT (flip evalStateT states) sp


rootDir :: App Response
rootDir = do
  intVal <- simpleQuery
  let newIntVal :: Int
      newIntVal = intVal + 1
  simpleUpdate newIntVal
  ok $ toResponse $ ("hello number:" ++ (show newIntVal))

main :: IO ()
main = do
  simpleHTTP nullConf $ runApp initialStates rootDir

它已编译，但每次请求网页时，页面都会显示相同的编号。再看一下我的代码，我觉得runApp中的evalStateT是错误的，因为它永远不会使用更新的状态值。

现在，我正在阅读mapServerPartT和ServerPartT，但这太复杂了。 感谢是否有人可以回答标题：“如何在Happstack中携带非酸性价值？”

Answer 1

mapServerPartT也无济于事。这里的问题是你传递给simpleHTTP的处理函数会在每个进入的请求的新线程中调用。每次调用runApp时都会调用initialStates论点。因此，不仅在请求结束时丢失了值，而且如果多个线程正在处理请求，它们将各自拥有自己的状态副本。

一旦我们意识到我们想要在多个线程之间共享的状态，我们就会意识到答案必须依赖于其中一个用于进行线程间通信的工具。一个不错的选择可能是TVar，http://hackage.haskell.org/package/stm-2.4.3/docs/Control-Concurrent-STM-TVar.html

main :: IO ()
main = do
  states <- atomically $ newTVar initialStates
  simpleHTTP nullConf $ runApp states rootDir

请注意，我们在开始侦听传入连接之前创建TVar。我们将TVar传递给所有请求处理线程，STM负责同步线程之间的值。

TVar有点像acid-state而没有（D）可用性。由于不需要保存数据，因此不需要SafeCopy实例等。

Answer 2

基于 stepcut 的答案，我能够使用TVar在Happstack中携带非酸性值。

如果有人有兴趣，这里是简化代码： https://gist.github.com/anonymous/5686161783fd53c4e413

这是完整版本，其中包含＆＃34; AcidState CountState＆＃34;和＃34; TVar CountState＆＃34;。

{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, 
     TemplateHaskell, TypeFamilies, DeriveDataTypeable, 
     FlexibleContexts, ScopedTypeVariables, 
     NamedFieldPuns, DeriveFunctor, StandaloneDeriving, OverloadedStrings,
     RecordWildCards #-}

import Happstack.Server
import Control.Applicative         ( Applicative, Alternative, (<$>))
import Control.Monad               ( MonadPlus, msum )
import Control.Monad.Reader        ( MonadReader, ReaderT(..), ask)
import Control.Monad.State         (get, put)
import Control.Monad.Trans         ( MonadIO, liftIO )
import Control.Monad.Trans.Control ( MonadBaseControl )
import Data.Maybe (fromMaybe)
import Control.Exception
import Control.Concurrent.STM
import Control.Concurrent.STM.TVar
import Data.Acid hiding (update)
import Data.Acid.Advanced   (query', update')
import Data.Acid.Local
import Data.SafeCopy
import Data.Data                   ( Data, Typeable )
import System.FilePath             ((</>))


data CountState = CountState { count :: Integer }
    deriving (Eq, Ord, Data, Typeable, Show)

$(deriveSafeCopy 0 'base ''CountState)

initialCountState :: CountState
initialCountState = CountState { count = 0 }

-- for AcidState
incCount :: Update CountState Integer
incCount =
  do (CountState c) <- get
     let c' = succ c
     put (CountState c')
     return c'

$(makeAcidic ''CountState ['incCount])

-- for TVar
incCountState :: App Integer
incCountState = do
  (_, CountState newVal) <- updateTVar incCount'
  return newVal
    where
      incCount' :: CountState -> CountState
      incCount' (CountState c) = CountState $ succ c


data Aci = Aci
  { acidCountState :: AcidState CountState
  , tvarCountState :: TVar CountState
  }



withAci :: Maybe FilePath -> (Aci -> IO a) -> IO a
withAci mBasePath action = do
  initialTVarCount <- newTVarIO initialCountState
  let basePath = fromMaybe "_state" mBasePath
      countPath = Just $ basePath </> "count"
    in withLocalState countPath initialCountState $ \c ->
      action (Aci c initialTVarCount)


-- for AcidState
class HasAcidState m st where
   getAcidState :: m (AcidState st)
query :: forall event m.
         ( Functor m
         , MonadIO m
         , QueryEvent event
         , HasAcidState m (EventState event)
         ) =>
         event
      -> m (EventResult event)
query event =
    do as <- getAcidState
       query' (as :: AcidState (EventState event)) event
update :: forall event m.
          ( Functor m
          , MonadIO m
          , UpdateEvent event
          , HasAcidState m (EventState event)
          ) =>
          event
       -> m (EventResult event)
update event =
    do as <- getAcidState
       update' (as :: AcidState (EventState event)) event



-- for TVar
class HasTVarState m st where
   getTVarState :: m (TVar st)

instance HasTVarState App CountState where
    getTVarState = tvarCountState <$> ask

queryTVar :: ( HasTVarState m a
             , MonadIO m
             ) => m a
queryTVar = do
  as <- getTVarState
  liftIO $ readTVarIO as

updateTVar :: ( HasTVarState m a
              , MonadIO m ) => 
              (a -> a)    -- ^ function to modify value
              -> m (a, a) -- ^ return value - "before change" and "after change"
updateTVar func = do
  as <- getTVarState
  liftIO $ atomically $ do -- STM
    prevVal <- readTVar as
    let newVal = func prevVal
    writeTVar as newVal
    return (prevVal, newVal)

-- | same as updateTVar, except no return
updateTVar_ :: ( HasTVarState m a
              , MonadIO m ) => 
              (a -> a)    -- ^ function to modify value
              -> m ()
updateTVar_ func = do
  as <- getTVarState
  liftIO $ atomically $ modifyTVar as func



withLocalState
  :: ( IsAcidic st
       , Typeable st
       ) =>
       Maybe FilePath        -- ^ path to state directory
    -> st                    -- ^ initial state value
    -> (AcidState st -> IO a) -- ^ function which uses the
                             --   `AcidState` handle
    -> IO a
withLocalState mPath initialState =
  bracket (liftIO $ open initialState)
          (liftIO . createCheckpointAndClose)
  where
    open = maybe openLocalState openLocalStateFrom mPath


newtype App a = App { unApp :: ServerPartT (ReaderT Aci IO) a }
    deriving ( Functor, Alternative, Applicative, Monad                
             , MonadPlus, MonadIO, HasRqData, ServerMonad
             , WebMonad Response, FilterMonad Response
             , Happstack, MonadReader Aci )


runApp :: Aci -> App a -> ServerPartT IO a
runApp aci (App sp) = do
  mapServerPartT (flip runReaderT aci) sp

instance HasAcidState App CountState where
    getAcidState = acidCountState <$> ask


acidCounter :: App Response
acidCounter = do
  c <- update IncCount -- ^ a CountState event
  ok $ toResponse $ ("hello number acid:" ++ (show c))

tvarCounter :: App Response
tvarCounter = do
  c <- incCountState
  ok $ toResponse $ ("hello number tvar:" ++ (show c))



rootDir :: App Response
rootDir = do
  msum 
    [ dir "favicon.ico" $ notFound (toResponse ())
    , dir "acidCounter" acidCounter
    , dir "tvarCounter" tvarCounter
    , ok $ toResponse ("access /acidCounter or /tvarCounter" :: String)
    ]


main :: IO ()
main = do
  withAci Nothing $ \aci -> 
    simpleHTTP nullConf $ runApp aci rootDir