如何在Happstack中携带非酸性值

Question

我读过Happstack crashcourse。我的web服务器几乎完全按照透明传递多个AcidState句柄一节中描述的方式

我的问题是，我有一个非酸性的值，但想在Happstack应用程序中访问。具体来说，"PushManager"来自推送通知通用库，

我想要的是：

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

我无法做到这一点，因为1）PushManager在内部使用了太多数据类型，通过调用$（deriveSafeCopy…）使底层数据类型SafeCopy兼容是不现实/不可靠的。2）PushManager不仅包含简单的值，还包含与SafeCopy兼容的函数。

我尝试的另一件事是"Acid"数据声明，不仅携带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，但这太复杂了。如果有人能回答标题行："如何在Hapstack中携带非酸性值？"

Answer 1

mapServerPartT对您也没有帮助。这里的问题是，传递给simpleHTTP的处理程序函数会在新线程中为传入的每个请求调用。每次它都会用initialStates参数调用runApp。因此，不仅值在请求结束时丢失，而且如果多个线程正在处理请求，它们将各自拥有各自的状态副本。

一旦我们意识到我们想要在多个线程之间共享的状态，我们就会意识到答案必须依赖于执行线程间通信的工具之一。一个好的选择可能是CCD_ 5，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负责同步线程之间的值。

CCD_ 8有点像CCD_。由于数据不需要保存，因此不需要SafeCopy实例等。

Answer 2

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

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

这是完整的版本，包含"AcidState CountState"one_answers"TVar CountState"。

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