How to carry non-Acidic value in Happstack?

Question

I've read Happstack crashcourse. My web server has almost exact way described in the section Passing multiple AcidState handles around transparently

Problem I have is that, I have value which is non-acidic, but want to access within the Happstack application. Specifically speaking, "PushManager" from push-notify-general library,

What I wanted is:

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

I couldn't make this work, because 1) PushManager use so many data types internally, and it is not realistic/robust to make underlying data type SafeCopy compatible by calling $(deriveSafeCopy ...). 2) PushManager not only contains simple value, but also function which is SafeCopy compatible.

Other thing I tried is to "Acid" data declaration to carry not only AcidState, but also non-AcidState data. By looking at the definition of runApp, "Acid" is just used for Reading, so I thought that rewriting with State monad may be able to achive my need. - but it turns out that it was not so simple. My tentative code is:

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

It compiled, but every time web page is requested, the page display same number. Looking at my code again, and I felt that evalStateT in runApp is wrong, because it never use updated state value.

Now, I am reading mapServerPartT and ServerPartT, but that is too complex. Appreciate if anybody can answer the title line: "How to carry non-Acidic value in Happstack?"

Answer 1

The mapServerPartT would not help you either. The issue here is that the handler function you pass to simpleHTTP gets called in a new thread for each request that comes in. And each time it is going to be calling runApp with the initialStates argument. So not only is the value lost at the end of the request, but if multiple threads are handling requests, they will each have their own separate copy of the state.

Once we realize that we want state that is shared between multiple threads, we realize that the answer must rely on one of the tools for doing interthread communication. A good choice would probably be a 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

Note that we create the TVar before we start listening for incoming connections. We pass the TVar to all the request handling threads, and STM takes care of synchronizing the values between threads.

a TVar is a bit like acid-state without the (D)urability. Since the data does not need to be saved, there is no need for SafeCopy instances, etc.

Answer 2

Based on stepcut's Answer, I was able to carry non-acidic value within Happstack using TVar.

If anybody is interested in, here is simplified code: https://gist.github.com/anonymous/5686161783fd53c4e413

And this is full version which carries both "AcidState CountState" and "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