0

Happstack クラッシュコースを読みました。私の Web サーバーには、透過的に複数の AcidState ハンドルを渡すセクションで説明したほぼ正確な方法があります。

私が抱えている問題は、非酸性の値がありますが、Happstack アプリケーション内でアクセスしたいということです。具体的に言えば、 push-notify-general ライブラリの「PushManager」、

私が欲しかったのは：

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

1) PushManager は非常に多くのデータ型を内部で使用しており、$(deriveSafeCopy ...) を呼び出して基になるデータ型の SafeCopy と互換性を持たせることは現実的ではなく、堅牢ではないため、これを機能させることができませんでした。2) PushManager には単純な値だけでなく、SafeCopy と互換性のある機能も含まれています。

私が試したもう1つのことは、AcidStateだけでなく非AcidStateデータも運ぶ「Acid」データ宣言です。runApp の定義を見てみると、「Acid」は単に Read に使われているだけなので、State モナドで書き換えれば解決できるのではないかと思いました。-しかし、それはそれほど単純ではないことがわかりました。私の暫定的なコードは次のとおりです。

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

コンパイルしましたが、Webページがリクエストされるたびに、ページには同じ番号が表示されます。コードをもう一度見てみると、runApp の evalStateT が間違っていると感じました。これは、更新された状態値を使用しないためです。

今、mapServerPartT と ServerPartT を読んでいますが、それは複雑すぎます。誰かがタイトル行に答えることができれば感謝します:「Happstack で非酸性の価値を運ぶ方法は?」

4

2 に答える 2

1

stepcutの Answer に基づいて、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 に答える
1

もあなたmapServerPartTを助けません。ここでの問題は、渡されたハンドラー関数が、入ってくる要求ごとに新しいスレッドで呼び出されることです。そして、引数を使用してsimpleHTTP呼び出すたびに。そのため、リクエストの終了時に値が失われるだけでなく、複数のスレッドがリクエストを処理している場合、それぞれに個別の状態のコピーが存在します。runAppinitialStates

複数のスレッド間で共有される状態が必要であることがわかったら、答えはスレッド間通信を行うためのツールの 1 つに依存する必要があることに気付きます。おそらく良い選択は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 がスレッド間の値の同期を処理します。

aは、(D)urability がない場合TVarと少し似ています。acid-stateデータを保存する必要がないため、SafeCopyインスタンスなどは必要ありません。

于 2014-10-02T14:02:32.983 に答える