0

我读过 Happstack 速成课程。我的 Web 服务器几乎与透明地传递多个 AcidState 句柄部分中描述的完全相同

我的问题是,我有非酸性的值,但想在 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 兼容的功能。

我尝试的另一件事是“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,但这太复杂了。感谢是否有人可以回答标题行:“如何在 Happstack 中携带非酸性价值?”

4

2 回答 2

1

mapServerPartT也不会帮助你。这里的问题是,对于每个传入的请求,您传递给的处理程序函数simpleHTTP都会在一个新线程中被调用。并且每次它都将runApp使用initialStates参数进行调用。因此,不仅在请求结束时会丢失值,而且如果多个线程正在处理请求,它们每个都会有自己独立的状态副本。

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

aTVar有点像acid-state没有(D)耐用性。由于不需要保存数据,因此不需要SafeCopy实例等。

于 2014-10-02T14:02:32.983 回答
1

根据stepcut的回答,我能够使用 TVar 在 Happstack 中携带非酸性值。

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

这是带有“AcidState CountState”和“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
于 2014-10-07T03:30:32.000 回答