happstack-state-6.0.0/0000755000000000000000000000000011527320411012773 5ustar0000000000000000happstack-state-6.0.0/Setup.hs0000644000000000000000000000014111527320411014423 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMainWithHooks simpleUserHooks happstack-state-6.0.0/COPYING0000644000000000000000000000267111527320411014034 0ustar0000000000000000Copyright (c) 2006, HAppS.org All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. Neither the name of the HAppS.org; nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. happstack-state-6.0.0/happstack-state.cabal0000644000000000000000000001051611527320411017056 0ustar0000000000000000Name: happstack-state Version: 6.0.0 Synopsis: Event-based distributed state. Description: Unplug your machine and restart and have your app recover to exactly where it left off. Happstack-State spares you the need to deal with all the marshalling, consistency, and configuration headache that you would have if you used an external DBMS for this purpose. Its component model makes it easy to compose big applications from smaller reliable parts. Use event subscription to trigger IO actions and support comet-style or irc-bot applications. License: BSD3 License-file: COPYING Author: Happstack team, HAppS LLC Maintainer: Happstack team homepage: http://happstack.com Category: Web, Distributed Computing Cabal-Version: >= 1.6 Build-Type: Simple source-repository head type: darcs subdir: happstack-state location: http://patch-tag.com/r/mae/happstack flag base4 Flag tests Description: Build the testsuite, and include the tests in the library Default: False flag replication Description: Enable state replication through a central serialization service. Default: False Library Exposed-modules: Happstack.State -- Happstack.State.Logger Happstack.State.Saver Happstack.State.Control Happstack.State.Transaction Happstack.State.ComponentTH Happstack.State.ComponentSystem Happstack.State.Saver.Impl.File Happstack.State.Saver.Impl.Memory Happstack.State.Saver.Impl.Queue Happstack.State.Saver.Types if flag(tests) Build-Depends: QuickCheck >= 2 && <3, HUnit, network Exposed-modules: Happstack.State.Tests Happstack.State.Tests.Helpers Happstack.State.Tests.CheckpointProperties Happstack.State.Tests.SaverProperties Other-modules: Happstack.State.Checkpoint Happstack.State.Monad Happstack.State.Types Happstack.State.Util Happstack.State.TxControl Build-Depends: binary, bytestring, containers, directory, extensible-exceptions, filepath, hslogger >= 1.0.2, happstack-util >= 6.0 && < 6.1, happstack-data >= 6.0 && < 6.1, mtl >= 1.1 && < 2.1, old-time, random, stm, template-haskell if flag(replication) Other-modules: Happstack.State.CentralLogServer Happstack.State.NetworkChan Build-Depends: hS3 >= 0.5.1 && < 0.6, bencode >= 0.5, process, SHA >= 1.4.0 && < 2 cpp-options: -DREPLICATION if flag(base4) Build-Depends: base >= 4 && < 5, syb else Build-Depends: base < 4 hs-source-dirs: src if flag(tests) hs-source-dirs: tests if !os(windows) Build-Depends: unix cpp-options: -DUNIX Extensions: TemplateHaskell, FlexibleInstances, FlexibleContexts, MultiParamTypeClasses, DeriveDataTypeable, OverlappingInstances, UndecidableInstances, CPP, TypeFamilies, FunctionalDependencies, TypeOperators, GADTs, EmptyDataDecls, ExistentialQuantification, RankNTypes, ScopedTypeVariables, PatternGuards, MagicHash, TypeSynonymInstances if impl(ghc >= 6.12) ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-orphans else ghc-options: -Wall -fno-warn-orphans GHC-Prof-Options: -auto-all Executable happstack-state-tests Main-Is: Test.hs GHC-Options: -threaded hs-source-dirs: tests, src if flag(tests) Buildable: True Build-depends: HUnit else Buildable: False happstack-state-6.0.0/src/0000755000000000000000000000000011527320411013562 5ustar0000000000000000happstack-state-6.0.0/src/Happstack/0000755000000000000000000000000011527320411015500 5ustar0000000000000000happstack-state-6.0.0/src/Happstack/State.hs0000644000000000000000000000202711527320411017115 0ustar0000000000000000module Happstack.State (-- * ACID monad Ev, AnyEv, TxControl, query, update, Update, Query, -- * Types TxId, EpochMilli, Saver(..), -- * Misc utilities module Happstack.State.Monad, getEventId, getTime, getEventClockTime, getEventStream, EventItem(..), module Happstack.State.Util, -- * Serialization module Happstack.Data.Serialize, module Happstack.Data.SerializeTH, module Happstack.State.Control, module Happstack.State.ComponentTH, module Happstack.State.ComponentSystem, --closeTxControl, runTxSystem, createCheckpoint, shutdownSystem, -- * Unsafe things unsafeIOToEv ) where import Happstack.State.Monad import Happstack.State.Saver import Happstack.Data.Serialize import Happstack.Data.SerializeTH import Happstack.State.Transaction import Happstack.State.ComponentSystem import Happstack.State.Types import Happstack.State.Util import Happstack.State.ComponentTH import Happstack.State.TxControl import Happstack.State.Control happstack-state-6.0.0/src/Happstack/State/0000755000000000000000000000000011527320411016560 5ustar0000000000000000happstack-state-6.0.0/src/Happstack/State/Util.hs0000644000000000000000000000653411527320411020041 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, CPP #-} module Happstack.State.Util ( -- * Random numbers getRandom, getRandomR, -- * TH helpers inferRecordUpdaters ) where import Control.Concurrent.STM import System.Random import Happstack.State.Monad import Happstack.State.Types import Data.Char(toUpper) import Language.Haskell.TH -- Random numbers -- | Get a random number. getRandom :: Random a => AnyEv a getRandom = do r <- sel evRandoms g <- liftSTM $ readTVar r let (x,g') = random g liftSTM $ writeTVar r g' return x -- | Get a random number inside the range. getRandomR :: Random a => (a,a) -> AnyEv a getRandomR z = do r <- sel evRandoms g <- liftSTM $ readTVar r let (x,g') = randomR z g liftSTM $ writeTVar r g' return x -------------------------------------------------------------- -- inferRecordUpdater -------------------------------------------------------------- -- FIXME: Throw a decent error message if the input isn't a record. -- | Infer updating functions for a record. Given a data declaration -- of @data Foo = Foo {bar :: String, baz :: Int}@ then @$(inferRecordUpdaters ''Foo)@ -- will define functions @a_bar :: String -> Foo -> Foo@, @withBar :: Update String a -> Update Foo a@, -- etc. that can be used as convenience updaters. inferRecordUpdaters :: Name -> Q [Dec] inferRecordUpdaters typeName = do con <- decToSimpleRecord =<< nameToDec typeName let c name upd s = do let un = mkName ("a_"++ns) wn = mkName ("with"++(toUpper (head ns):tail ns)) ns = nameBase name ud <- un `sdef` upd wd <- wn `sdef` (varE 'localState `appE` s `appE` varE un) return [ud, wd] xs <- sequence $ zipWith3 c (fieldNames con) (updFuns con) (selFuns con) return $ concat xs -- Utilities decToSimpleRecord :: Dec -> Q Con decToSimpleRecord (DataD _ _ _ [con] _) = return con decToSimpleRecord (DataD _ n _ _ _) = fail ("Not a simple record (has multiple constructors): "++show n) decToSimpleRecord (NewtypeD _ _ _ con _) = return con decToSimpleRecord x = fail ("Wanted a simple record, got: "++show x) nameToDec :: Name -> Q Dec nameToDec ty = reify ty >>= un where un (TyConI d) = return $ d un _ = fail "nameToDec: expected TyCon" -- | Create a list of selection functions for a record. selFuns :: Con -> [ExpQ] selFuns (RecC _ ts) = [ varE n | (n,_,_) <- ts ] selFuns _ = error "Constructors other than RecC not handled in selFuns" -- | Create a list of update functions for a record. updFuns :: Con -> [ExpQ] updFuns (RecC _ ts) = [ upd n | (n,_,_) <- ts ] where [x,y] = map mkName ["x","y"] upd f = lamE [varP x, varP y] $ rup f rup f = recUpdE (varE y) [return (f,VarE x)] updFuns _ = error "Constructors other than RecC not handled in updFuns" -- | Return field names fieldNames :: Con -> [Name] fieldNames (RecC _ ts) = [ n | (n,_,_) <- ts ] fieldNames _ = error "Constructors other than RecC not handled in fieldNames" -- | Simple definition sdef :: Name -> ExpQ -> DecQ sdef vn ve = valD (varP vn) (normalB ve) [] -------------------------------------------------------------- -- inferRecordUpdater end -------------------------------------------------------------- happstack-state-6.0.0/src/Happstack/State/Monad.hs0000644000000000000000000000702311527320411020154 0ustar0000000000000000{-# LANGUAGE CPP, FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-} module Happstack.State.Monad where import Control.Exception import Control.Concurrent.STM import Happstack.State.Types import Happstack.Data.Proxy import Control.Monad.State import Control.Monad.Reader instance (Monad m) => Monad (Ev m) where return x = Ev $ \_ -> return x fail x = Ev $ \_ -> fail x ev >>= f = Ev $ \env -> unEv ev env >>= \x -> unEv (f x) env instance MonadState st (Update st) where get = Ev $ \_ -> get put x = Ev $ \_ -> put x instance MonadReader st (Query st) where ask = Ev $ \_ -> ask local l (Ev cmd) = Ev $ \env -> local l (cmd env) instance MonadReader st (Update st) where ask = Ev $ \_ -> get local l (Ev cmd) = Ev $ \env -> StateT $ \s -> do (r,_s') <- runStateT (cmd env) (l s) return (r,s) instance (Monad m) => Functor (Ev m) where fmap = liftM -- | Use a proxy to force the type of an update action. setUpdateType :: Proxy t -> Update t () setUpdateType _ = return () -- | Forces the type of the proxy and update to match proxyUpdate :: Update t b -> Proxy t -> Update t b proxyUpdate f prox = setUpdateType prox >> f -- | Use a proxy to force the type of a query action. setQueryType :: Proxy t -> Query t () setQueryType _ = return () -- | Forces the type of proxy and query to match proxyQuery :: Query t b -> Proxy t -> Query t b proxyQuery f prox = setQueryType prox >> f -- | Currying version of 'setUpdateType'. asUpdate :: Update t a -> Proxy t -> Update t a asUpdate upd _ = upd -- | Currying version of 'setQueryType'. asQuery :: Query t a -> Proxy t -> Query t a asQuery query _ = query -- | Specialized version of 'ask' askState :: Query st st askState = ask -- | Specialized version of 'get' getState :: Update st st getState = get -- | Specialized version of 'put'. putState :: st -> Update st () putState = put -- | Lift an STM action into Ev. liftSTM :: STM a -> AnyEv a liftSTM = unsafeSTMToEv class CatchEv m where #if __GLASGOW_HASKELL__ < 610 catchEv :: Ev m a -> (Exception -> a) -> Ev m a #else catchEv :: Ev m a -> (SomeException -> a) -> Ev m a #endif instance CatchEv (ReaderT st STM) where catchEv (Ev cmd) fun = Ev $ \s -> ReaderT $ \r -> runReaderT (cmd s) r `catchSTM` (\a -> return (fun a)) instance CatchEv (StateT st STM) where catchEv (Ev cmd) fun = Ev $ \s -> StateT $ \r -> runStateT (cmd s) r `catchSTM` (\a -> return (fun a,r)) instance MonadPlus m => MonadPlus (Ev m) where mzero = Ev $ \_ -> mzero mplus (Ev fn1) (Ev fn2) = Ev $ \env -> fn1 env `mplus` fn2 env -- | Select a part of the environment. sel :: (Env -> b) -> AnyEv b sel f = Ev $ \env -> return (f env) -- FIXME: should the users see this function? -- | Run a computation with local state. Changes to state will be visible to outside. localState :: (outer -> inner) -> (inner -> outer -> outer) -> Ev (StateT inner STM) a -> Ev (StateT outer STM) a localState ifun ufun (Ev cmd) = Ev $ \env -> StateT $ \s -> do (r,s') <- runStateT (cmd env) (ifun s) return (r, ufun s' s) -- | Run a computation with local state. localStateReader :: (outer -> inner) -> Ev (ReaderT inner STM) a -> Ev (ReaderT outer STM) a localStateReader ifun (Ev cmd) = Ev $ \env -> ReaderT $ \s -> runReaderT (cmd env) (ifun s) -- | Execute a Query action in the Update monad. runQuery :: Query st a -> Update st a runQuery fn = Ev $ \env -> StateT $ \st -> do a <- runReaderT (unEv fn env) st return (a,st) happstack-state-6.0.0/src/Happstack/State/Checkpoint.hs0000644000000000000000000001441211527320411021205 0ustar0000000000000000{-# LANGUAGE CPP, TemplateHaskell, DeriveDataTypeable #-} module Happstack.State.Checkpoint ( restoreState , createCheckpoint ) where import Happstack.State.Saver import Happstack.Data.Serialize import Happstack.Data.SerializeTH import Happstack.State.Transaction import Data.Typeable import Data.Maybe import Control.Concurrent import Control.Monad import Control.Exception as E import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Map as M import System.Log.Logger logMC :: Priority -> String -> IO () logMC = logM "Happstack.State.Checkpoint" {- State on disk: * ${TXD}/events event files in ascending order * ${TXD}/checkpoints checkpoint files in ascending order * ${TXD}/current pointer to last checkpoint -} data State = State { stateVersion :: Int , stateCutoff :: Int } deriving (Typeable,Show) instance Version State $(deriveSerialize ''State) -- FIXME: It may be nice to print out what components were saved on disk -- compared to the components actually used in the application. -- | Load state from disk and re-run any needed events to -- fully restore the state. The returned function enables -- event logging. restoreState :: MVar TxControl -> IO (IO ()) restoreState ctlVar = withMVar ctlVar $ \ctl -> do -- Find the last saved cutoff point. mbState <- readState ctl case mbState of Nothing -> do writeState ctl (State 0 0) -- No events to replay. Switch to real saver. return $ do swapMVar (ctlEventSaver ctl) =<< createWriter (ctlSaver ctl) "events" 0 return () Just state -> do let cutoff = stateCutoff state -- Load state and replay events. loadState ctl cutoff offset <- loadEvents ctl cutoff -- We use a NullSaver when replaying events. Switch to real saver. return $ do swapMVar (ctlEventSaver ctl) =<< createWriter (ctlSaver ctl) "events" (cutoff+offset) return () -- Load state from disk. loadState :: TxControl -> Int -> IO () loadState ctl cutoff = do logMC NOTICE $ "Loading components from storage." checkpoints <- withReader ctl "checkpoints" cutoff $ loadCheckpoints forM_ (ctlAllComponents ctl) $ \stateType -> case M.lookup stateType (ctlComponentVersions ctl) of Just versions -> forM_ versions $ \stateTypeVersion -> case M.lookup (L.unpack stateTypeVersion) checkpoints of Just state -> setNewState stateType state Nothing -> return () Nothing -> return () -- FIXME: Prints stats about which components weren't found on disk -- and which components weren't found in the dependency tree. logMC NOTICE "All components successfully loaded" -- Read and execute events since last checkpoint. loadEvents :: TxControl -> Int -> IO Int loadEvents ctl cutoff = do logMC NOTICE "Loading events from storage" (events, offset) <- withReader ctl "events" cutoff $ readerGet -- Execute events. Events that predate the last checkpoint aren't executed. forM_ events $ \(EventLogEntry context object) -> runColdEvent context object logMC NOTICE "All events successfully replayed." return offset withReader :: (Serialize a) => TxControl -> String -> Int -> (ReaderStream a -> IO c) -> IO c withReader ctl key cutoff = bracket (createReader (ctlSaver ctl) key cutoff) (readerClose) withWriter :: (Serialize a) => TxControl -> String -> Int -> (WriterStream a -> IO c) -> IO c withWriter ctl key cutoff = bracket (createWriter (ctlSaver ctl) key cutoff) (writerClose) readState :: (Serialize a) => TxControl -> IO (Maybe a) readState ctl = withReader ctl "current" 0 $ \s -> liftM listToMaybe $ readerGetUncut s writeState :: TxControl -> State -> IO () writeState ctl state = bracket (createWriter (ctlSaver ctl) "current" 0) (writerClose) (\saver -> writerAtomicReplace saver state) -- FIXME: Show process while loading state? -- Might not be useful here since we just load the raw data. -- The time consuming parsing takes place later on. -- | Load a map from component types to serialized states. loadCheckpoints :: ReaderStream (M.Map String L.ByteString) -> IO (M.Map String L.ByteString) loadCheckpoints saver = do checkpointss <- readerGetUncut saver case checkpointss of [checkpoints] -> return checkpoints [] -> return M.empty _ -> error "Failed to read checkpoints." saveCheckpoints :: WriterStream (M.Map String L.ByteString) -> M.Map String L.ByteString -> IO () saveCheckpoints saver checkpoints = do mv <- newEmptyMVar writerAdd saver checkpoints (putMVar mv ()) takeMVar mv -- Each checkpoint has a separate event queue. We don't want -- to clear the queues since that would block event execution. -- Hence, events may be written to the log after we make the cut -- and before the state is saved. This means that some events -- may need to be discarded next time the state is restored. -- | Creates a checkpoint using the provided TxControl. -- This checkpoint may be used as a safe state with which to start the system, -- e.g. one may delete all the serialized events that took place after the last -- checkpoint and start the application fresh from the checkpoint. -- Calling this function manually is the only way to create checkpoints. createCheckpoint :: MVar TxControl -> IO () createCheckpoint ctlVar = withMVar ctlVar $ \ctl -> do logMC NOTICE "Initiating checkpoint." newCut <- writerCut =<< readMVar (ctlEventSaver ctl) withWriter ctl "checkpoints" newCut $ \saver -> do allStates <- mapM getState (ctlAllComponents ctl) saveCheckpoints saver (M.fromList $ zip (ctlAllComponents ctl) allStates) writeState ctl $ State {stateVersion = 0 ,stateCutoff = newCut} logMC NOTICE "Checkpoint successfully serialized." happstack-state-6.0.0/src/Happstack/State/ComponentTH.hs0000644000000000000000000003157711527320411021327 0ustar0000000000000000{-# LANGUAGE FlexibleInstances, TemplateHaskell, CPP, PatternGuards #-} module Happstack.State.ComponentTH ( mkMethods ) where import Data.Char import Language.Haskell.TH import Happstack.State.Types import Happstack.Data.Serialize import Happstack.State.ComponentSystem import Control.Monad.State import Control.Monad.Reader import Control.Monad.Writer import Data.Maybe import Data.List import Data.Generics.Basics #if MIN_VERSION_template_haskell(2,4,0) type CtxElemQ = PredQ type CtxElem = Pred #else type CtxElemQ = TypeQ type CtxElem = Type #endif nubCxt :: [CtxElemQ] -> Q [CtxElem] nubCxt tsQ = do ts <- cxt tsQ return $ nub ts {- Error cases: not all state keys are tyvars. method not using the keys in either the args or the result. Checked: component not being a data declaration with a single constructor. Checked: method using a tyvar that isn't a key. Checked: method is not a function. -} {- | This function will derive, for the provided type name and the provided list of methods, an instance of Methods for the given type and necessary instance of UpdateEvent and QueryEvent to make the provided list of functions into Methods. This TH splice needs to be executed for any MACID state type in order to have the necessary code for event handling generated. Ex: @$(mkMethods ''Foo ['fooUpdate,'fooQuery'])@ -} mkMethods :: Name -> [Name] -> Q [Dec] mkMethods componentName componentMethods = do keys <- liftM (requireSimpleCon componentName) $ reify componentName methodInfos <- getMethodInfos keys componentMethods ds1 <- genEventInstances methodInfos let handlers = genComponentHandlers methodInfos stType = mkType componentName keys context' = mkKeyConstraints keys ++ concatMap (mkMethodConstraints keys) methodInfos ds2 <- instanceD (nubCxt context') (appT (conT ''Methods) stType) [ funD 'methods [clause [wildP] (normalB handlers) []] ] ds4 <- genMethodStructs [''Typeable] methodInfos ds5 <- genSerializeInstances methodInfos return (ds1 ++ [ds2] ++ ds4 ++ ds5 ) mkKeyConstraints :: [Name] -> [CtxElemQ] mkKeyConstraints keys = [ mkCtxt ''Typeable (varT key) | key <- keys ] ++ [ mkCtxt ''Serialize (varT key) | key <- keys ] mkMethodConstraints :: [Name] -> MethodInfo -> [CtxElemQ] mkMethodConstraints keys method = map return (substMethodContext method keys) substMethodContext :: MethodInfo -> [Name] -> [CtxElem] substMethodContext method keys = let relation = zip (methodKeys method) keys workerT (VarT old) | Just new <- lookup old relation = VarT new workerT (AppT l r) = AppT (workerT l) (workerT r) workerT (ForallT c names t) = ForallT c names (workerT t) workerT t = t #if MIN_VERSION_template_haskell(2,4,0) workerP (ClassP old typs) = let new = case lookup old relation of Nothing -> old Just nm -> nm in ClassP new $ map workerT typs workerP p = p worker = workerP #else worker = workerT #endif in map worker (methodContext method) mkType :: Name -> [Name] -> TypeQ mkType name args = foldl appT (conT name) (map varT args) genSerializeInstances :: [MethodInfo] -> Q [Dec] genSerializeInstances meths = liftM concat $ forM meths $ \method -> let constraints = nubCxt $ mkKeyConstraints (methodKeys method) ++ map return (methodContext method) upperMethod = upperName (methodName method) encode = do args <- replicateM (length (methodArgs method)) (newName "arg") lamE [conP upperMethod $ map varP args ] $ doE $ [ noBindS $ appE (varE 'safePut) (varE arg) | arg <- args] ++ [ noBindS [| return () |] ] decode = do args <- replicateM (length (methodArgs method)) (newName "arg") doE $ [ bindS (varP arg) (varE 'safeGet) | arg <- args] ++ [ noBindS $ appE (varE 'return) $ foldl appE (conE upperMethod) $ map varE args ] in do s <- instanceD constraints (appT (conT ''Serialize) (mkType (upperName (methodName method)) (methodKeys method))) [funD 'putCopy [clause [] (normalB [| contain . $(encode) |]) []] ,funD 'getCopy [clause [] (normalB [| contain $(decode) |]) []]] v <- instanceD constraints (appT (conT ''Version) (mkType (upperName (methodName method)) (methodKeys method))) [] return [s,v] {- [ Update $ \(SetComponent c) -> setComponent c , Query $ \GetComponent -> getComponent ] -} genComponentHandlers :: [MethodInfo] -> ExpQ genComponentHandlers meths = do let localHandlers = flip map meths $ \method -> let upName = upperName (methodName method) in do args <- replicateM (length (methodArgs method)) (newName "arg") appE (conE (methodEv method)) $ lamE [conP upName (map varP args)] $ foldl appE (varE (methodName method)) $ map varE args handlers = listE localHandlers handlers genEventInstances :: [MethodInfo] -> Q [Dec] genEventInstances methodsInfo = mapM genEventInstance methodsInfo genEventInstance :: MethodInfo -> Q Dec genEventInstance method = do let keys = methodKeys method eventType = foldl appT (conT (upperName (methodName method))) (map varT keys) instanceD (nubCxt $ [mkCtxt ''Serialize eventType ,mkCtxt ''Serialize (return (methodResult method)) ] ++ mkKeyConstraints keys ++ mkMethodConstraints keys method ) (appT (appT (conT (methodClass method)) eventType) (return (methodResult method))) [] mkCtxt :: Name -> TypeQ -> CtxElemQ #if MIN_VERSION_template_haskell(2,4,0) mkCtxt name typ = classP name [typ] #else mkCtxt name typ = appT (conT name) typ #endif genMethodStructs :: [Name] -> [MethodInfo] -> Q [Dec] genMethodStructs derv meths = liftM concat (mapM (genMethodStruct derv) meths) -- FIXME: allow class constraints on keys. genMethodStruct :: [Name] -> MethodInfo -> Q [Dec] genMethodStruct derv method = do let c = NormalC (upperName (methodName method)) (zip (repeat NotStrict ) (methodArgs method)) return [ DataD [] (upperName (methodName method)) (map mkTyVarBndr $ methodKeys method) [c] (derv) ] where #if MIN_VERSION_template_haskell(2,4,0) mkTyVarBndr = PlainTV #else mkTyVarBndr = id #endif upperName :: Name -> Name upperName = mkName . upperFirst . nameBase upperFirst :: String -> String upperFirst (x:xs) = toUpper x : xs upperFirst "" = error "ComponentTH.UpperFirst []" data MethodInfo = Method { methodName :: Name , methodKeys :: [Name] , methodContext:: [CtxElem] , methodArgs :: [Type] , methodClass :: Name , methodEv :: Name , methodResult :: Type } -- get and validate method information. getMethodInfos :: [Name] -> [Name] -> Q [MethodInfo] getMethodInfos sessionKeys names = do ms <- mapM getMethodInfo names mapM worker ms where worker m | length (methodKeys m) /= length sessionKeys = error $ "Inconsistent keys: " ++ pprint (methodName m) ++ ": " ++ show (sessionKeys, methodKeys m) | otherwise = case compare (sort (methodTyVars m)) (sort (methodKeys m)) of EQ -> return m GT -> error $ "Method too general: " ++ pprint (methodName m) LT -> error $ "Method not general enough: " ++ pprint (methodName m) getArgKeys (AppT t1 t2) = getArgKeys t1 ++ getArgKeys t2 getArgKeys (VarT key) = [key] getArgKeys _ = [] methodTyVars m = nub $ concatMap getArgKeys (methodResult m:methodArgs m) getMethodInfo :: Name -> Q MethodInfo getMethodInfo method = do methodInfo <- reify method case methodInfo of VarI _name funcType _decl _fixity -> return (getTypes funcType){methodName = method} _ -> error $ "Method is not a function: " ++ nameBase method ++ " is a " ++ showInfo methodInfo showInfo :: Info -> String showInfo ClassI{} = "class" showInfo TyConI{} = "type constructor" showInfo PrimTyConI{} = "primitive type constructor" showInfo DataConI{} = "data constructor" showInfo VarI{} = "variable" showInfo TyVarI{} = "type variable" showInfo x = pprint x -- Cases: -- forall m. MonadState state m => X -> m Y -- forall key. key -> Update () -- forall key m. MonadState state m => key -> m () -- X -> Ev (ReaderT state STM) Y -- X -> Ev (StateT state STM) Y getTypes :: Type -> MethodInfo getTypes (ForallT _ contxt t) = getTypes' contxt t getTypes t = getTypes' [] t -- FIXME: only allow type variables used by the component. getTypes' :: Cxt -> Type -> MethodInfo getTypes' contxt t = case runWriter (worker t) of ((keys,className, typeName, res), args) -> Method { methodName = error "Method name not set", methodKeys = keys , methodContext = filter (isRelevant keys) contxt , methodArgs = args [], methodClass = className , methodEv = typeName, methodResult = res} where -- recursive case: A -> B worker (AppT (AppT ArrowT t1) t2) = do tell (t1:) worker t2 -- end case: Update state res || Query state res worker (AppT (AppT (ConT c) state) r) | c == ''Update = return (getStateKeys state,''UpdateEvent, 'Update, r) | c == ''Query = return (getStateKeys state,''QueryEvent, 'Query, r) -- end case: Ev (ReaderT state STM) res || Ev (StateT state STM) res worker (AppT (AppT (ConT _ev) (AppT (AppT (ConT m) state) (ConT _stm))) r) | m == ''StateT = return (getStateKeys state,''UpdateEvent, 'Update, r) | m == ''ReaderT = return (getStateKeys state,''QueryEvent, 'Query, r) -- end case: m res (check if m is an instance of MonadState) worker (AppT name r) | Just state <- isMonadState contxt name = return (getStateKeys state, ''UpdateEvent, 'Update, r) | Just state <- isMonadReader contxt name = return (getStateKeys state, ''QueryEvent, 'Query, r) -- error case worker c = error ("Unexpected method type: " ++ pprint c) getStateKeys :: Type -> [Name] getStateKeys (AppT r r') = getStateKeys r ++ getStateKeys r' getStateKeys (VarT key) = [key] getStateKeys (ConT _st) = [] getStateKeys v = error $ "Bad state type: " ++ pprint v ++ " (expected a constant, an application or a type variable)" -- |Ignoring EqualP predicates, returns all names associated with a -- context predicate getPredKeys :: CtxElem -> [Name] #if MIN_VERSION_template_haskell(2,4,0) getPredKeys (ClassP nm typs) = nm : concatMap getStateKeys typs getPredKeys _ = [] #else getPredKeys = getStateKeys #endif isMonadState :: [CtxElem] -> Type -> Maybe Type isMonadState = isMonadX ''MonadState isMonadReader :: [CtxElem] -> Type -> Maybe Type isMonadReader = isMonadX ''MonadReader isMonadX :: Name -> [CtxElem] -> Type -> Maybe Type #if MIN_VERSION_template_haskell(2,4,0) isMonadX monadType contxt name = listToMaybe [ state | ClassP m [state,mName] <- contxt, mName == name, m == monadType ] #else isMonadX monadType contxt name = listToMaybe [ state | AppT (AppT (ConT m) state) mName <- contxt, mName == name, m == monadType ] #endif isRelevant :: [Name] -> CtxElem -> Bool isRelevant keys p = isAcceptableContext p && any (`elem` keys) (getPredKeys p) isAcceptableContext :: CtxElem -> Bool #if MIN_VERSION_template_haskell(2,4,0) isAcceptableContext (ClassP con _) = con `notElem` [''MonadState, ''MonadReader] #else isAcceptableContext (AppT r r') = isAcceptableContext r && isAcceptableContext r' isAcceptableContext (ConT con) = con `notElem` [''MonadState, ''MonadReader] #endif isAcceptableContext _ = True requireSimpleCon :: Name -> Info -> [Name] requireSimpleCon _ (TyConI (DataD _ _ names _ _derv)) = map conv names requireSimpleCon _ (TyConI (NewtypeD _ _ names _ _derv)) = map conv names requireSimpleCon _ (TyConI (TySynD _ names _)) = map conv names requireSimpleCon name _ = error $ "Cannot create component from '"++pprint name++"'. Expected a data structure." #if MIN_VERSION_template_haskell(2,4,0) conv :: TyVarBndr -> Name conv (PlainTV nm) = nm conv (KindedTV nm _) = nm #else conv = id #endifhappstack-state-6.0.0/src/Happstack/State/CentralLogServer.hs0000644000000000000000000003025611527320411022343 0ustar0000000000000000module Happstack.State.CentralLogServer ( ApplicationName , connectToCluster , changeEventMapping , createCheckpoint ) where import Data.Binary import qualified Data.ByteString.Lazy.Char8 as L import Control.Concurrent import System.Process import System.Exit import System.IO import Control.Applicative ((<$>), (<*>)) import Data.Int import Data.List import Control.Exception import qualified Data.Map as Map import Control.Monad import System.Random (mkStdGen) import Network.AWS.AWSConnection import Network.AWS.S3Bucket hiding (key) import Network.AWS.S3Object import Happstack.Data.Serialize import Happstack.State.Transaction import Happstack.State.Types import Happstack.State.NetworkChan import Data.BEncode import Data.BEncode.Parser import Data.Digest.Pure.SHA import System.Log.Logger logLS :: Priority -> String -> IO () logLS = logM "Happstack.State.CentralLogServer" type ApplicationName = String data Entry = Entry EntryId EpochMilli EntryData deriving (Show) type EntryId = Int64 type EntryData = L.ByteString type URL = String instance Binary Entry where get = Entry <$> get <*> get <*> get put (Entry eid epoch edata) = put eid >> put epoch >> put edata data ForeignEvent = ForeignEvent Int L.ByteString instance Binary ForeignEvent where get = ForeignEvent <$> get <*> get put (ForeignEvent hash event) = put hash >> put event data CheckpointMsg = NoCheckpoint | Checkpoint EntryId URL deriving (Show) instance BEncodeable CheckpointMsg where bencode NoCheckpoint = BString (L.pack "NoCheckpoint") bencode (Checkpoint eid url) = BDict (Map.singleton "Checkpoint" $ BDict $ Map.fromList [ ("entry_id", BInt $ fromIntegral eid) , ("url", BString (encode url))]) bdecode = do str <- bstring token guard (str == "NoCheckpoint") return NoCheckpoint <|> do setInput =<< dict "Checkpoint" eid <- bint (dict "entry_id") url <- bbytestring (dict "url") return (Checkpoint (fromIntegral eid) $ decode url) instance BEncodeable Entry where bencode entry = BString (encode entry) bdecode = fmap decode (bbytestring token) data Response = Response Entry Bool instance BEncodeable Response where bencode (Response entry isOwner) = BDict (Map.fromList [("entry",bencode entry) ,("owner",BString $ L.pack $ show isOwner)]) bdecode = do owner <- bstring (dict "owner") setInput =<< dict "entry" entry <- bdecode case owner of "True" -> return $ Response entry True _ -> return $ Response entry False instance BEncodeable L.ByteString where bencode bs = BString bs bdecode = bbytestring token data UserMsg = NewEvent L.ByteString | NewCheckpoint EntryId URL deriving (Show) instance BEncodeable UserMsg where bencode (NewEvent event) = BDict (Map.singleton "NewEvent" (BString event)) bencode (NewCheckpoint eid url) = BDict $ Map.singleton "NewCheckpoint" $ BDict $ Map.fromList [ ("entry_id", BInt $ fromIntegral eid) , ("url", BString $ L.pack url) ] bdecode = do setInput =<< dict "NewEvent" fmap NewEvent (bbytestring token) <|> do setInput =<< dict "NewCheckpoint" eid <- bint (dict "entry_id") url <- bbytestring (dict "url") return (NewCheckpoint (fromIntegral eid) (L.unpack url)) data Cluster = Cluster { clusterChan :: NetworkChan , clusterS3 :: AWSConnection , clusterBucket :: String , clusterLastId :: MVar EntryId } -- FIXME: The logging service should have a domain name. logServerAddress :: URL logServerAddress = "174.129.13.114" -- Connect to the central log server via SSH. -- The appropriate identities have to be added to the autentication agent. See ssh-add(1). connectToCluster :: ApplicationName -> EventMap -> IO Cluster connectToCluster appName localEventMap = do logLS NOTICE "Retrieving S3 credentials from environment." Just conn <- amazonS3ConnectionFromEnv bucket <- initiateBucket conn -- FIXME: Run this function in 'createCheckpoint' instead? logLS NOTICE "Running LogRelay through ssh." (inh, outh) <- sshConnect ("app_" ++ appName) logServerAddress "LogRelay" logLS NOTICE "Creating network channel." chan <- newNetworkChan inh outh checkpoint <- peek chan :: IO CheckpointMsg lastId <- newEmptyMVar case checkpoint of NoCheckpoint -> do putMVar lastId 0 logLS NOTICE "No checkpoint available." Checkpoint eid url -> do putMVar lastId eid let (checkpoint_bucket,key) = read url logLS NOTICE $ "Checkpoint available from this location: " ++ show (checkpoint_bucket,key) ret <- getObject conn (S3Object { obj_bucket = checkpoint_bucket , obj_name = key , content_type = "" , obj_headers = [] , obj_data = L.empty }) case ret of Left err -> error (show err) Right obj -> do (stateMap, _rest) <- evaluate $ deserialize (obj_data obj) forM_ (Map.toList stateMap) $ \(stateTy, state) -> setNewState' localEventMap stateTy state return Cluster { clusterChan = chan , clusterS3 = conn , clusterBucket = bucket , clusterLastId = lastId } -- Update a snapshot of the component states to S3 and notify the log-server about it. createCheckpoint :: MVar TxControl -> Cluster -> IO () createCheckpoint ctlVar cluster = withMVar ctlVar $ \ctl -> do -- This ID number is used as the cutoff for the checkpoint. After this checkpoint has been -- saved, events younger than this ID will not be sent when restoring the state. lastId <- readMVar (clusterLastId cluster) allStates <- mapM getState (ctlAllComponents ctl) let stateMap = Map.fromList (zip (ctlAllComponents ctl) allStates) checkpoint = serialize stateMap let bucket = clusterBucket cluster key = "checkpoint_" ++ show (sha1 checkpoint) sendObject (clusterS3 cluster) (S3Object { obj_bucket = bucket , obj_name = key , content_type = "application/octet-stream" , obj_headers = [] , obj_data = checkpoint }) let url = show (bucket, key) poke (clusterChan cluster) (NewCheckpoint lastId url) {- Find a bucket to place new checkpoints in. If no suitable bucket exists, create one. Race conditions aren't important since we're just trying to keep the happs buckets to a minimum (preferable just one). -} initiateBucket :: AWSConnection -> IO String initiateBucket conn = do response <- listBuckets conn case response of Left err -> error (show err) Right buckets -> case [ bucket_name bucket | bucket <- buckets, "happs_checkpoints" `isPrefixOf` bucket_name bucket ] of (bucket:_) -> return bucket [] -> do ret <- createBucketWithPrefix conn "happs_checkpoints" case ret of Left err -> error (show err) Right bucket -> return bucket {- The new event mapping pipes Update events through the logging server. Query events do not need to be sequenced and are therefore executed normally. Incoming Update events may have been sent from another client and hence will not have a local listener attached. Those alien events are still executed (to update the state) but their computed result is discarded. For events that originated locally, the computed response is sent to the appropriate listener. -} changeEventMapping :: EventMap -> Cluster -> IO EventMap changeEventMapping localEventMap cluster = do logLS NOTICE "Create new event mapper" responseIndex <- newMVar Map.empty let chan = clusterChan cluster let insertEID uniq = do mv <- newEmptyMVar modifyMVar_ responseIndex $ \idx -> return $ Map.insert uniq mv idx return $ takeMVar mv returnResponse uniq object = modifyMVar_ responseIndex $ \idx -> case Map.lookup uniq idx of Nothing -> return idx -- This shouldn't happen. Just mv -> do putMVar mv object -- Notify the caller about the new response. return $ Map.delete uniq idx listener = forever $ do Response (Entry eid time foreign) owner <- peek chan let ForeignEvent uniq object = decode foreign logLS NOTICE $ "Received entry with id: " ++ show uniq ++ " " ++ show owner let txContext = TxContext { txId = eid , txRand = 0 , txTime = time , txStdGen = mkStdGen 0 } response <- runColdEventFunc txContext (fst $ deserialize object) localEventMap swapMVar (clusterLastId cluster) eid -- If we sent this event, pipe the result to the listener. when owner $ returnResponse uniq response forkIO listener uniqVar <- newMVar 0 let newEventMap = flip Map.map localEventMap $ \handler -> case handler of UpdateHandler runCold _ parse -> let runHot ev = do uniq <- modifyMVar uniqVar (\a -> return (a+1, a)) let obj = serialize $ mkObject ev foreign = ForeignEvent uniq obj logLS NOTICE $ "New locally unique id: " ++ show uniq wait <- insertEID uniq poke chan (NewEvent (encode foreign)) response <- wait logLS NOTICE $ "Received response for: " ++ show uniq return $ parseObject response in UpdateHandler runCold runHot parse QueryHandler{} -> handler return newEventMap type UserName = String type ServerAddress = String type Command = String -- Run a command through an SSH tunnel. sshConnect :: UserName -> ServerAddress -> Command -> IO (Handle, Handle) sshConnect userName serverAddress command = do (inh, outh, errh, _pid) <- runInteractiveProcess "ssh" ["-o", "BatchMode=yes", userName ++ "@" ++ serverAddress, command] Nothing Nothing tid <- myThreadId forkIO $ do errMsg <- hGetLine errh hPutStrLn stderr $ "SSH tunneling failed: " ++ errMsg throwTo tid (ExitFailure 255) return (inh, outh) happstack-state-6.0.0/src/Happstack/State/Control.hs0000644000000000000000000001401011527320411020530 0ustar0000000000000000{-# LANGUAGE CPP, EmptyDataDecls #-} module Happstack.State.Control ( startSystemState , startSystemStateAmazon , processLoggingFlags , stdSaver , waitForTermination ) where import Control.Applicative ((<$>)) import System.Log.Logger import qualified System.Log.Handler as SLH import System.Log.Handler.Simple import System.Log.Handler.Syslog import Data.Char import System.Environment import System.IO import System.Exit import System.Console.GetOpt import Control.Monad.Trans import Control.Concurrent import Numeric (showHex) #ifdef UNIX import System.Posix.Signals hiding (Handler) import System.Posix.IO ( stdInput ) import System.Posix.Terminal ( queryTerminal ) #endif import Happstack.State.Transaction import Happstack.State.Saver #ifdef REPLICATION import Happstack.State.CentralLogServer (ApplicationName) #endif import Happstack.State.TxControl import Happstack.State.ComponentSystem import Happstack.Data.Proxy hiding (proxy) -- | Starts the MACID system without replication support. Uses the default behavior -- of saving the state into the _local directory. startSystemState :: (Methods a, Component a) => Proxy a -> IO (MVar TxControl) startSystemState proxy = do saver <- stdSaver runTxSystem saver proxy #ifdef REPLICATION startSystemStateAmazon :: (Methods a, Component a) => ApplicationName -> Proxy a -> IO (MVar TxControl) startSystemStateAmazon appName proxy = runTxSystemAmazon appName proxy #else type ApplicationName = String startSystemStateAmazon :: (Methods a, Component a) => ApplicationName -> Proxy a -> IO (MVar TxControl) startSystemStateAmazon appName proxy = runTxSystemAmazon appName proxy #endif -- | Returns the default Saver. It will save the application state into -- the _local directory. stdSaver :: IO Saver stdSaver = do pn <- escape <$> getProgName return $ Queue (FileSaver ("_local/" ++pn++"_state")) where escape :: String -> String escape = concatMap escapeChar escapeChar :: Char -> String escapeChar c | isAlphaNum c = [c] | otherwise = showString "_" $ showHex (ord c) "" -- | Wait for a signal. -- On unix, a signal is sigINT or sigTERM. On windows, the signal -- is entering 'e'. waitForTermination :: IO () waitForTermination = do #ifdef UNIX istty <- queryTerminal stdInput mv <- newEmptyMVar installHandler softwareTermination (CatchOnce (putMVar mv ())) Nothing case istty of True -> do installHandler keyboardSignal (CatchOnce (putMVar mv ())) Nothing return () False -> return () takeMVar mv #else let loop 'e' = return () loop _ = getChar >>= loop loop 'c' #endif data NullLogger instance SLH.LogHandler NullLogger where setLevel = error "Don't do this! This logger should not be used!" getLevel = error "Don't do this! This logger should not be used!" emit = error "Don't do this! This logger should not be used!" close = error "This logger should not be used!" setLoggingSettings :: [Flag] -> IO () setLoggingSettings flags = do updateGlobalLogger "" (setHandlers ([] :: [NullLogger])) s <- streamHandler stdout DEBUG updateGlobalLogger "Happstack" (setHandlers [s] . setLevel WARNING) mapM_ worker flags where worker (LogTarget SysLog) = do s <- openlog "Happstack" [PID] DAEMON DEBUG -- This priority seems to be ignored? updateGlobalLogger "Happstack" (setHandlers [s]) worker (LogTarget StdOut) = do s <- streamHandler stdout DEBUG updateGlobalLogger "Happstack" (setHandlers [s]) worker (LogTarget (File path)) = do s <- fileHandler path DEBUG -- This priority seems to be ignored? updateGlobalLogger "Happstack" (setHandlers [s]) worker (LogLevel pri) = do updateGlobalLogger "Happstack" (setLevel pri) rlogger <- getLogger "Happstack" logM "" WARNING ("Set logging priority to " ++ show (getLevel rlogger)) -- order should not matter, though it does now. -- we should ALSO allow multiple loggers at the same time! --log-target=stdout --log-target=syslog options :: [OptDescr Flag] options = [Option "" ["log-level"] (ReqArg (LogLevel . read . map toUpper) "level") "Log level: DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY. Default: WARNING" ,Option "" ["log-target"] (ReqArg (LogTarget . readTarget) "target") "Log target: stdout, syslog, or a FilePath such as /home/foo/bar.log . Default: stdout" ] data Target = File FilePath | StdOut | SysLog deriving (Read,Show,Eq,Ord) data Flag = LogLevel Priority | LogTarget Target deriving Show readTarget :: String -> Target readTarget arg = case map toLower arg of "stdout" -> StdOut "syslog" -> SysLog _ -> File arg castOptions :: [OptDescr ()] castOptions = flip map options $ \(Option c f desc help) -> Option c f (worker desc) help where worker (NoArg _) = (NoArg ()) worker (ReqArg _ f) = ReqArg (const ()) f worker (OptArg _ f) = OptArg (const ()) f processLoggingFlags :: IO a -> IO a processLoggingFlags action = do args <- liftIO getArgs pn <- liftIO getProgName let err n ls = -- XXX these next lines should be written to stderr! do putStrLn ("Syntax error in command line - "++n) putStrLn $ unlines $ map (" "++) ls putStrLn ("Usage "++usageInfo pn castOptions) exitWith (ExitFailure 1) case getOpt' Permute options args of (flags,fs,args',[]) -> do setLoggingSettings flags withArgs (fs ++ args') action (_,_,_,es) -> err "errors" es happstack-state-6.0.0/src/Happstack/State/TxControl.hs0000644000000000000000000001154411527320411021055 0ustar0000000000000000{-# LANGUAGE CPP #-} module Happstack.State.TxControl ( runTxSystem , runTxSystemAmazon , shutdownSystem , createCheckpoint ) where import System.Log.Logger import Control.Monad import Control.Exception import Control.Concurrent import qualified Happstack.State.Checkpoint as Checkpoint import Happstack.State.Saver import Happstack.State.Transaction #ifdef REPLICATION import qualified Happstack.State.CentralLogServer as LogServer #endif import Happstack.State.ComponentSystem import Happstack.Data.Proxy logMM :: Priority -> String -> IO () logMM = logM "Happstack.State.TxControl" -- | Given a Saver and a Proxy, createTxControl will -- initialize a TxControl. This does not actually start the -- state system. createTxControl :: (Methods state, Component state) => Saver -> Proxy state -> IO (MVar TxControl) createTxControl saver prox = do -- The state hasn't been loaded yet. Ignore events. eventSaverVar <- newMVar =<< createWriter NullSaver "events" 0 -- obtain a prefix lock lock <- obtainLock saver newMVar $ TxControl { ctlSaver = saver , ctlEventSaver = eventSaverVar , ctlAllComponents = allStateTypes prox , ctlComponentVersions = componentVersions prox , ctlChildren = [] , ctlPrefixLock = lock , ctlCreateCheckpoint = return () } -- | Saves the state and closes the serialization closeTxControl :: MVar TxControl -> IO () closeTxControl ctlVar = do ctl <- takeMVar ctlVar writerClose =<< takeMVar (ctlEventSaver ctl) releaseLock (ctlPrefixLock ctl) -- | Run the MACID system without multimaster support and with the given Saver. runTxSystem :: (Methods st, Component st) => Saver -> Proxy st -> IO (MVar TxControl) runTxSystem saver stateProxy = do logMM NOTICE "Initializing system control." ctl <- createTxControl saver stateProxy -- insert code to lock based on the saver logMM NOTICE "Creating event mapper." localEventMap <- createEventMap ctl stateProxy setNewEventMap localEventMap logMM NOTICE "Restoring state." enableLogging <- Checkpoint.restoreState ctl -- Multimaster support used to be here. -- enableLogging let ioActions = componentIO stateProxy logMM NOTICE "Forking children." children <- forM ioActions $ \action -> do mv <- newEmptyMVar tid <- forkIO (action `finally` putMVar mv ()) return (tid,mv) modifyMVar_ ctl $ \c -> return c{ ctlChildren = children , ctlCreateCheckpoint = Checkpoint.createCheckpoint ctl } return ctl #ifdef REPLICATION runTxSystemAmazon :: (Methods st, Component st) => LogServer.ApplicationName -> Proxy st -> IO (MVar TxControl) runTxSystemAmazon appName stateProxy = do logMM NOTICE "Initializing system control" ctl <- createTxControl NullSaver stateProxy logMM NOTICE "Creating local event mapper." localEventMap <- createEventMap ctl stateProxy logMM NOTICE "Connecting to central log server." cluster <- LogServer.connectToCluster appName localEventMap logMM NOTICE "Modifying local event map." eventMap <- LogServer.changeEventMapping localEventMap cluster setNewEventMap eventMap let ioActions = componentIO stateProxy logMM NOTICE "Forking children." children <- forM ioActions $ \action -> do mv <- newEmptyMVar tid <- forkIO (action `finally` putMVar mv ()) return (tid,mv) modifyMVar_ ctl $ \c -> return c{ ctlChildren = children , ctlCreateCheckpoint = LogServer.createCheckpoint ctl cluster } return ctl #else type ApplicationName = String -- Hm, this should actually be defined in CentralLogServer.hs runTxSystemAmazon :: (Methods st, Component st) => ApplicationName -> Proxy st -> IO (MVar TxControl) runTxSystemAmazon appName stateProxy = error "Happstack-state has been built without replication support." #endif createCheckpoint :: MVar TxControl -> IO () createCheckpoint = join . fmap ctlCreateCheckpoint . readMVar -- | Shuts down a transaction system shutdownSystem :: MVar TxControl -> IO () shutdownSystem ctl = do logMM NOTICE "Shutting down." children <- liftM ctlChildren $ readMVar ctl logMM NOTICE "Killing children." mapM_ (killThread . fst) children mapM_ (takeMVar . snd) children -- FIXME: Use a timeout. logMM NOTICE "Shutdown complete" closeTxControl ctl happstack-state-6.0.0/src/Happstack/State/ComponentSystem.hs0000644000000000000000000001316211527320411022266 0ustar0000000000000000{-# LANGUAGE TypeFamilies, FlexibleContexts, FunctionalDependencies, CPP, MultiParamTypeClasses, TypeOperators, DeriveDataTypeable, GADTs #-} module Happstack.State.ComponentSystem where import Happstack.Data.Serialize import Happstack.State.Types import Data.Typeable import qualified Data.Map as Map import Data.Map (Map) import Control.Monad.State.Strict import qualified Data.ByteString.Lazy.Char8 as L -------------------------------------------------------------- -- Type level list ------------------------------------------------------------- -- | Equivalent of [] for type level lists. Used for Components that have no -- dependencies data End = End -- | Type level Cons for enumerating type dependencies of a Component data h :+: t = h :+: t infixr 6 :+: -------------------------------------------------------------- -- Event classes -------------------------------------------------------------- -- TH doesn't support type families yet. class (Serialize ev, Serialize res) => UpdateEvent ev res | ev -> res class (Serialize ev, Serialize res) => QueryEvent ev res | ev -> res -------------------------------------------------------------- -- Methods contain the query and update handlers for a component -------------------------------------------------------------- -- | Method is the actual type that all Updates and Querys eventually -- get lifted into via 'mkMethods'. data Method st where Update :: (UpdateEvent ev res) => (ev -> Update st res) -> Method st Query :: (QueryEvent ev res) => (ev -> Query st res) -> Method st instance Show (Method st) where show method = "Method: " ++ methodType method -- | Displays the type of a Method methodType :: Method t -> String methodType m = case m of Update fn -> let ev :: (ev -> Update st res) -> ev ev _ = undefined in show (typeOf (ev fn)) Query fn -> let ev :: (ev -> Query st res) -> ev ev _ = undefined in show (typeOf (ev fn)) -- | Class for enumerating the set of defined methods by the type of the state. -- Instances should not be defined directly, but using 'mkMethods' class Methods a where methods :: Proxy a -> [Method a] data MethodMap where MethodMap :: (Component st) => Map String (Method st) -> MethodMap instance Show MethodMap where show (MethodMap m) = show m -- | State type -> method map type ComponentTree = Map String MethodMap -- | State type -> all versions type ComponentVersions = Map String [L.ByteString] -------------------------------------------------------------- -- A component consists of a list of subcomponents, some -- initiation code and some methods. -- The methods are in a different class so they can be generated -- separately. -------------------------------------------------------------- -- | In order to be used as a part of Happstack's MACID state, a data type -- needs to be an instance of Component. The minimal definition is -- an initialValue and the type corresponding to the set of Dependencies. -- Note that the SubHandlers condition will be automatically met if the -- Dependencies is built from 'End' and ':+:' with other instances of -- Component and Methods class (SubHandlers (Dependencies a),Serialize a) => Component a where type Dependencies a initialValue :: a onLoad :: Proxy a -> IO () onLoad _ = return () -------------------------------------------------------------- -- Class for walking the component tree. -------------------------------------------------------------- -- | SubHandlers is used to build up the set of components corresponding to -- the instance type. class SubHandlers a where subHandlers :: a -> Collect () -- | In correspondence with its role as [] in the type level list, -- the instance for End does not add any components to the set. instance SubHandlers End where subHandlers ~End = return () -- | This is the instance that completes the definition of :+: and End as being -- the constructors of a type level list in SubHandlers. Note that since b -- needs to be an instance of SubHandlers, the list needs to be terminated with End. instance (Methods a, Component a, SubHandlers b) => SubHandlers (a :+: b) where subHandlers ~(a :+: b) = do collectHandlers' (proxy a) subHandlers b data Collection = Collection ComponentTree ComponentVersions [IO ()] addItem :: (MonadState Collection m) => String -> MethodMap -> [L.ByteString] -> IO () -> m () addItem key item versions ioAction = do Collection tree allVersions ioActions <- get case Map.member key tree of False -> put $ Collection (Map.insert key item tree) (Map.insert key versions allVersions) (ioAction:ioActions) True -> dup key type Collect = State Collection collectHandlers :: (Methods a, Component a) => Proxy a -> (ComponentTree, ComponentVersions, [IO ()]) collectHandlers prox = case execState (collectHandlers' prox) (Collection Map.empty Map.empty []) of Collection tree versions ioActions -> (tree, versions, ioActions) collectHandlers' :: (Methods a, Component a) => Proxy a -> Collect () collectHandlers' prox = let key = show (typeOf (unProxy prox)) item = MethodMap $ Map.fromList [ (methodType m, m) | m <- methods prox ] versions = collectVersions prox in do addItem key item versions (onLoad prox) subHandlers (sub prox) where sub :: Component a => Proxy a -> Dependencies a sub _ = undefined -- | An error is thrown when this is evaluated. dup :: String -> b dup key = error $ "Duplicate component: " ++ key happstack-state-6.0.0/src/Happstack/State/Saver.hs0000644000000000000000000000442111527320411020175 0ustar0000000000000000module Happstack.State.Saver ( module Happstack.State.Saver.Types , PrefixLock , Saver(..) , createReader , createWriter , obtainLock , releaseLock ) where import Control.Concurrent import Happstack.State.Saver.Impl.File import Happstack.State.Saver.Impl.Memory import Happstack.State.Saver.Impl.Queue import Happstack.State.Saver.Types import Happstack.Data.Serialize data Saver = NullSaver -- ^ A saver that discards all output | FileSaver String -- ^ A saver that operates on files. The parameter is the prefix for the files. | Queue Saver -- ^ Enable queueing. | Memory (MVar Store) -- | Dispatches over the Saver type provided to return a 'ReaderStream' for the inferred -- type. createReader :: Serialize a => Saver -> String -> Int -> IO (ReaderStream a) createReader (FileSaver prefix) key cutoff = fileReader prefix key cutoff createReader (Memory store) key cutoff = memoryReader store key cutoff createReader (Queue saver) key cutoff = queueReader =<< createReader saver key cutoff createReader NullSaver _key _cutoff = return $ ReaderStream { readerClose = return () , readerGet = fail "NullSaver: readerGet" , readerGetUncut = fail "NullSaver: readerGetUncut" } -- | Dispatches over the Saver type provided to return a WriterStream for the -- inferred type. createWriter :: Serialize a => Saver -> String -> Int -> IO (WriterStream a) createWriter (FileSaver prefix) key cutoff = fileWriter prefix key cutoff createWriter (Memory store) key cutoff = memoryWriter store key cutoff createWriter (Queue saver) key cutoff = queueWriter =<< createWriter saver key cutoff createWriter NullSaver _key _cutoff = return $ WriterStream { writerClose = return () , writerAdd = \_ io -> io , writerAtomicReplace = fail "NullSaver: writerAtomicReplace" , writerCut = fail "NullSaver: writerCut" } obtainLock :: Saver -> IO (Maybe PrefixLock) obtainLock (Queue saver) = obtainLock saver obtainLock (FileSaver prefix) = fmap Just (obtainPrefixLock prefix) obtainLock _ = return Nothing releaseLock :: Maybe PrefixLock -> IO () releaseLock (Just lock) = releasePrefixLock lock releaseLock Nothing = return () happstack-state-6.0.0/src/Happstack/State/Types.hs0000644000000000000000000000564611527320411020233 0ustar0000000000000000{-# LANGUAGE UndecidableInstances, TemplateHaskell, ExistentialQuantification, RankNTypes, FlexibleInstances, DeriveDataTypeable, ScopedTypeVariables #-} module Happstack.State.Types where import Control.Concurrent.STM import Data.Int import Data.Word import qualified GHC.Conc(unsafeIOToSTM) import System.Random -- (StdGen) import Control.Monad.State import Control.Monad.Reader import Data.Generics -- Monad things data Env = Env { evRandoms :: TVar StdGen , evContext :: TxContext } type TxId = Int64 type EpochMilli= Int64 instance Typeable StdGen where typeOf _ = mkTyConApp (mkTyCon "System.Random.StdGen") [] instance Random Word64 where randomR = integralRandomR random = randomR (minBound,maxBound) instance Random Int64 where randomR = integralRandomR random = randomR (minBound,maxBound) integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g) integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, fromIntegral b :: Integer) g of (x,g') -> (fromIntegral x, g') data TxContext = TxContext { txId :: TxId, txRand :: Word64, txTime :: EpochMilli, txStdGen :: StdGen } deriving (Read,Show,Typeable) {- Is STM really be best backend monad? We don't use any of the STM features. -} -- | ACID computations that work with any state and event types. type AnyEv a = forall t. (Monad (t STM), MonadTrans t) => Ev (t STM) a -- | Monad for ACID event handlers. newtype Ev m t = Ev { unEv :: Env -> m t } instance (Typeable st, Typeable1 m) => Typeable1 (ReaderT st m) where typeOf1 x = mkTyConApp (mkTyCon "Control.Monad.Reader.ReaderT") [typeOf (undefined :: st), typeOf1 (m x)] where m :: ReaderT st m a -> m a m = undefined instance (Typeable st, Typeable1 m) => Typeable1 (StateT st m) where typeOf1 x = mkTyConApp (mkTyCon "Control.Monad.State.StateT") [typeOf (undefined :: st), typeOf1 (m x)] where m :: StateT st m a -> m a m = undefined instance (Typeable state, Typeable t) => Typeable (Ev (ReaderT state STM) t) where typeOf (Ev _cmd) = mkTyConApp (mkTyCon "Happstack.State.Types.Ev") [typeOf (u::ReaderT state STM t)] where u = undefined instance (Typeable state, Typeable t) => Typeable (Ev (StateT state STM) t) where typeOf (Ev _cmd) = mkTyConApp (mkTyCon "Happstack.State.Types.Ev") [typeOf (u::StateT state STM t)] where u = undefined type Query state = Ev (ReaderT state STM) type Update state = Ev (StateT state STM) -- unsafe lifting unsafeIOToEv :: IO a -> AnyEv a unsafeIOToEv c = unsafeSTMToEv (unsafeIOToSTM c) unsafeSTMToEv :: STM a -> AnyEv a unsafeSTMToEv c = Ev $ \_ -> lift c unsafeIOToSTM :: IO a -> STM a unsafeIOToSTM = GHC.Conc.unsafeIOToSTM -- Misc newtype Shadow t a = Shadow { unShadow :: a } deriving Typeable newtype UsingXml a = UsingXml { unXml :: a } deriving Typeable happstack-state-6.0.0/src/Happstack/State/Transaction.hs0000644000000000000000000004637311527320411021416 0ustar0000000000000000{-# LANGUAGE CPP, TemplateHaskell, MagicHash, ExistentialQuantification, DeriveDataTypeable, GADTs, MultiParamTypeClasses #-} module Happstack.State.Transaction where import Control.Concurrent import Control.Concurrent.STM import Control.Exception.Extensible import Control.Monad.State import Control.Monad.Reader import qualified Data.Map as M import qualified Data.ByteString.Lazy as L import Data.IORef import System.IO.Unsafe import System.Random import System.Time(getClockTime,ClockTime(TOD)) import System.Log.Logger import Happstack.State.ComponentSystem import Happstack.State.Monad import Happstack.State.Saver import Happstack.Data.Serialize import Happstack.Data.SerializeTH import Happstack.State.Types import Data.Dynamic import GHC.Base import Prelude hiding (catch) import qualified Data.Binary as Binary type ExceptionT = SomeException logMT :: Priority -> String -> IO () logMT = logM "Happstack.State.Transaction" getTime :: (Integral epochTime) => AnyEv epochTime getTime = sel (fromIntegral . txTime . evContext) getEventClockTime :: AnyEv ClockTime getEventClockTime = do milliSeconds <- sel (txTime . evContext) let (seconds, justMilliSeconds) = (fromIntegral milliSeconds) `divMod` 1000 return $ TOD seconds (justMilliSeconds * 1000000000) getEventId :: (Integral txId) => AnyEv txId getEventId = sel (fromIntegral . txId . evContext) instance Version TxContext -- Default to version 0 $(deriveSerialize ''TxContext) -- Isomorphic to (), we're interested in a descriptive name. data GetCheckpointState = GetCheckpointState deriving (Typeable) instance Version GetCheckpointState $(deriveSerialize ''GetCheckpointState) newtype SetCheckpointState = SetCheckpointState L.ByteString deriving (Typeable) instance Version SetCheckpointState $(deriveSerialize ''SetCheckpointState) instance Version StdGen instance Serialize StdGen where getCopy = contain $ liftM read safeGet putCopy = contain . safePut . show {- Durablity: * Pending queue is TChan (TxContext, ev) * Get events from the input sources in circular fashion * Dump events on disk before adding to pending queue * Checkpoints as follows: * check point event arrives from one of the input sources * write a new checkpoint file with: + list of pending transactions (all non-pending are out of system) + next txid + save state + rotare log files * resume transaction processing -} type TypeString = String data EventHandler where UpdateHandler :: UpdateEvent ev res => (TxContext -> ev -> IO res) -> (ev -> IO res) -> (Object -> ev) -> EventHandler QueryHandler :: QueryEvent ev res => (ev -> IO res) -> (Object -> ev) -> EventHandler type EventMap = M.Map TypeString EventHandler data EmitInternal = EmitInternal EventMap {-# NOINLINE emitRef #-} emitRef :: IORef EmitInternal emitRef = unsafePerformIO $ newIORef (error "Happstack not initiated") -- Low level function for emitting events. Very unsafe, do not expose. emitFunc :: (Serialize ev, Typeable res) => EventMap -> TypeString -> ev -> IO res emitFunc eventMap eventType ev = case M.lookup eventType eventMap of Nothing -> error $ "Emitted event to unknown component. Ev: " ++ eventType Just (UpdateHandler _cold hot _parse) -> unsafeCoerce# hot ev Just (QueryHandler fn _parse) -> unsafeCoerce# fn ev -- Wrapper around the global emitter map. Very unsafe, do not expose. -- This function is only safe through 'query' and 'update'. emitEvent' :: (Serialize ev, Typeable res) => TypeString -> ev -> IO res emitEvent' eventType ev = do internal <- readIORef emitRef case internal of EmitInternal eventMap -> emitFunc eventMap eventType ev emitEvent :: (Serialize ev, Typeable res) => ev -> IO res emitEvent ev = emitEvent' (show (typeOf ev)) ev setNewEventMap :: EventMap -> IO () setNewEventMap eventMap = writeIORef emitRef $ EmitInternal eventMap data EventItem = EventItem { eventContext :: TxContext , eventData :: Dynamic } {-# NOINLINE eventStreamRef #-} eventStreamRef :: MVar (Chan EventItem) eventStreamRef = unsafePerformIO $ newMVar $ error "eventStreamRef not initialized." initEventStream :: IO () initEventStream = do c <- newChan forkIO $ forever $ readChan c -- Immediately discard items from this channel. swapMVar eventStreamRef c return () pushEventItem :: Serialize ev => TxContext -> ev -> IO () pushEventItem context ev = do c <- readMVar eventStreamRef writeChan c $ EventItem context (toDyn ev) getEventStream :: IO (IO EventItem) getEventStream = do c <- dupChan =<< readMVar eventStreamRef return (readChan c) {- Events for different components can be executed in parallel. -} -- Casting the event and the result type is safe. The types are kept sane due to the -- EventUpdate and EventQuery classes. createEventMap :: (Methods st, Component st) => MVar TxControl -> Proxy st -> IO EventMap createEventMap ctlVar componentProxy = do initEventStream maps <- forM (M.elems componentTree) $ \(MethodMap m) -> do tx <- createNewTxRun ctl <- readMVar ctlVar runTxLoop (ctlEventSaver ctl) (txProcessQueue tx) initialValue return $ M.union (extraEvents tx) (M.map (eventHandler tx) m) return $ M.unions maps where (componentTree, _versions, _ioActions) = collectHandlers componentProxy eventHandler :: Serialize st => TxRun st -> Method st -> EventHandler eventHandler tx (Update fn) = let updateCold' ev getCxt = do mv <- newEmptyMVar let handler = do cxt <- getCxt lastCxt <- readTVar (txLastTxContext tx) if txId lastCxt < txId cxt then do writeTVar (txLastTxContext tx) cxt writeTChan (txProcessQueue tx) $ IHR cxt ev $ handleUpdate (putMVar mv) $ fn ev return $ return () else return $ putMVar mv $ Right $ error "Cold event not executed" join $ atomically $ handler me <- takeMVar mv case me of Left e -> throwIO e Right e -> return e updateCold cxt ev = do updateCold' ev $ return cxt updateHot ev = do cxt <- newTxContext updateCold' ev $ addTxId tx cxt in UpdateHandler updateCold updateHot parseObject eventHandler tx (Query fn) = let queryEmitter ev = do mv <- newEmptyMVar quickQuery' tx $ HR ev $ handleQuery (putMVar mv) (fn ev) me <- takeMVar mv case me of Left e -> throwIO e Right e -> return e in QueryHandler queryEmitter parseObject instance QueryEvent GetCheckpointState L.ByteString instance UpdateEvent SetCheckpointState () extraEvents :: Serialize st => TxRun st -> EventMap extraEvents tx = M.fromList [ (getStateType stateType, getStateHandler tx) , (setNewStateType stateType, setNewStateHandler tx) ] where t :: TxRun st -> st t _ = undefined stateType = show (typeOf (t tx)) getStateHandler tx' = let fn :: GetCheckpointState -> IO L.ByteString fn ev = do mv <- newEmptyMVar quickQuery' tx' $ HR ev $ \context st -> return (Nothing, putMVar mv (serialize (context, st))) takeMVar mv in QueryHandler fn parseObject setNewStateHandler tx' = let fn :: SetCheckpointState -> IO () fn (SetCheckpointState bs) = do ((context, newState), rest) <- evaluate $ deserialize bs unless (L.null rest) $ error $ "Junk after checkpoint for state: " ++ stateType mv <- newEmptyMVar quickQuery' tx' $ HR () $ \_context _oldState -> return (Just newState, putMVar mv ()) takeMVar mv atomically $ writeTVar (txLastTxContext tx') context in UpdateHandler (error "No cold setState handler") fn parseObject allStateTypes :: (Methods a, Component a) => Proxy a -> [TypeString] allStateTypes prox = let (componentTree, _versions, _ioActions) = collectHandlers prox in M.keys componentTree componentVersions :: (Methods a, Component a) => Proxy a -> M.Map String [L.ByteString] componentVersions prox = let (_componentTree, versions, _ioActions) = collectHandlers prox in versions componentIO :: (Methods a, Component a) => Proxy a -> [IO ()] componentIO prox = let (_componentTree, _versions, ioActions) = collectHandlers prox in ioActions createNewTxRun :: IO (TxRun st) createNewTxRun = atomically $ do processQueue <- newTChan lastContext <- newTVar (TxContext 0 0 0 (mkStdGen 42)) return $ TxRun processQueue lastContext setNewStateType :: String -> String setNewStateType str = "SetNewState: " ++ str getStateType :: String -> String getStateType str = "GetState: " ++ str setNewState :: TypeString -> L.ByteString -> IO () setNewState stateType state = emitEvent' (setNewStateType stateType) (SetCheckpointState state) setNewState' :: EventMap -> TypeString -> L.ByteString -> IO () setNewState' eventMap stateType state = emitFunc eventMap (setNewStateType stateType) (SetCheckpointState state) getState :: TypeString -> IO L.ByteString getState stateType = emitEvent' (getStateType stateType) GetCheckpointState data SetNewState st = SetNewState L.ByteString deriving (Typeable) data GetState st = GetState deriving (Typeable) instance Version (SetNewState st) instance Typeable st => Serialize (SetNewState st) where putCopy (SetNewState lbs) = contain $ Binary.put lbs getCopy = contain $ liftM SetNewState Binary.get instance Version (GetState st) instance Typeable st => Serialize (GetState st) where putCopy GetState = contain $ return () getCopy = contain $ return GetState instance Typeable st => UpdateEvent (SetNewState st) () instance Typeable st => QueryEvent (GetState st) L.ByteString -- | Schedule an update and wait for it to complete. When this function returns, you're -- guaranteed the update will be persistent. update :: (MonadIO m, UpdateEvent ev res) => ev -> m res update = liftIO . emitEvent -- | Emit a state query and wait for the result. query :: (MonadIO m, QueryEvent ev res) => ev -> m res query = liftIO . emitEvent -- Execute a query immediately without giving it a unique timestamp & transaction ID. quickQuery' :: (Serialize st) => TxRun st -> HR st -> IO () quickQuery' txrun (HR ev fun) = do now <- getEpochMilli atomically $ do tx <- readTVar (txLastTxContext txrun) writeTChan (txProcessQueue txrun) $ IHR tx{txTime=now} ev fun type Runner ev res = IO (IO ev, res -> IO ()) type EH i o = i -> IO o data Event = forall ev. Serialize ev => Event ev data IHR st = forall ev. (Serialize ev) => IHR TxContext ev (RunHandler st ev) data HR st = forall ev. (Serialize ev) => HR ev (RunHandler st ev) type RunHandler st ev = TxContext -> st -> IO (Maybe st, IO ()) data Res a = Ok a | Error ExceptionT type EventQueue st = TChan (HR st) -- Queue of local event not yet given a TxContext. type ProcessQueue st = TChan (IHR st) -- Queue of events to be processed. TxContext'es have been asigned at this point. data TxRun st = TxRun {txProcessQueue :: !(ProcessQueue st) ,txLastTxContext :: !(TVar TxContext)} type EvLoaders' st = M.Map String (ProcessQueue st -> L.ByteString -> IO (TxId,L.ByteString)) type EvLoaders = M.Map String (L.ByteString -> IO (TxId,L.ByteString)) setEvLoadersQueue :: ProcessQueue st -> EvLoaders' st -> EvLoaders setEvLoadersQueue queue = M.map (\fn -> fn queue) -- serialized object -> serialized response runObjectEvent :: Object -> IO Object runObjectEvent obj = do EmitInternal eventMap <- readIORef emitRef runObjectEventFunc obj eventMap runObjectEventFunc :: Object -> EventMap -> IO Object runObjectEventFunc obj eventMap = do handler <- lookupEventHandler (objectType obj) eventMap case handler of -- FIXME: This will have to be filled in when doing sharding. QueryHandler{} -> error $ "Cold event was a query: " ++ objectType obj UpdateHandler _runCold runHot parse -> do res <- runHot (parse obj) return $ mkObject res runColdEvent :: TxContext -> Object -> IO Object runColdEvent cxt obj = do EmitInternal eventMap <- readIORef emitRef runColdEventFunc cxt obj eventMap runColdEventFunc :: TxContext -> Object -> EventMap -> IO Object runColdEventFunc cxt obj eventMap = do handler <- lookupEventHandler (objectType obj) eventMap case handler of QueryHandler{} -> error $ "Cold event was a query: " ++ objectType obj UpdateHandler runCold _runHotObj parse -> do res <- runCold cxt (parse obj) return $ mkObject res lookupEventHandler :: TypeString -> EventMap -> IO EventHandler lookupEventHandler eventType eventMap = case M.lookup eventType eventMap of Nothing -> error $ "Couldn't find handler for event of type: " ++ eventType Just handler -> return handler eventTString :: Serialize ev => ev -> TypeString eventTString ev = show (typeOf ev) handleEvent :: (st -> Env -> Ev m res -> STM intermediate) -> (st -> intermediate -> IO (Maybe st, res)) -> (Either ExceptionT res -> IO ()) -> Ev m res -> RunHandler st ev handleEvent runner stateCheck ofun action tx st = handle eh $ do intermediate <- atomically $ runQuery' (newState, res) <- stateCheck st intermediate return (newState, ofun (Right res)) where runQuery' = do rs <- newTVar (txStdGen tx) let env = Env { evContext = tx, evRandoms = rs } intermediate <- runner st env action return $ intermediate eh e = do logMT ERROR ("handleEvent FAIL: "++ show e) return (Nothing,ofun (Left e)) handleQuery :: (Either ExceptionT res -> IO ()) -> Query st res -> RunHandler st ev handleQuery = handleEvent (\st env (Ev cmd) -> runReaderT (cmd env) st) (\_st res -> return (Nothing, res)) handleUpdate :: (Either ExceptionT res -> IO ()) -> Update st res -> RunHandler st ev handleUpdate = handleEvent (\st env (Ev cmd) -> runStateT (cmd env) st) (\st (res,st') -> checkDiff st st' >>= \diff -> return (diff, res)) {- Some updates might not modify the state. Doing a pointer-check might be worth it. (as a side note, reallyUnsafePtrEquality# is orders of magnitude faster than comparing StableNames.) -} checkDiff :: a -> a -> IO (Maybe a) checkDiff _old new = return (Just new) getEpochMilli :: IO EpochMilli getEpochMilli = do TOD sec pico <- getClockTime return $ fromIntegral $ sec * 1000 + pico `div` 10^9 newTxContext :: IO TxContext newTxContext = do milli <- getEpochMilli let txid = -1 -- Not set yet. sgen <- modifyMVar globalRandomGen (return . split) let (rand, sgen') = random sgen return $ TxContext txid rand milli sgen' addTxId :: TxRun st -> TxContext -> STM TxContext addTxId tx context = do lastContext <- readTVar (txLastTxContext tx) let new = context{txId = txId lastContext + 1} writeTVar (txLastTxContext tx) new return new{txId = txId new + 1} {-# NOINLINE globalRandomGen #-} -- XXX: why are we using a global StdGen? Isn't there already one in System.Random? globalRandomGen :: MVar StdGen globalRandomGen = unsafePerformIO (newMVar =<< getStdGen) data TxControl = TxControl { ctlSaver :: Saver -- ^ Saver given by the user. , ctlEventSaver :: MVar (WriterStream EventLogEntry) , ctlAllComponents :: [String] -- ^ Types of each component used. , ctlComponentVersions :: M.Map String [L.ByteString] -- ^ Map listing all versions of a component , ctlChildren :: [(ThreadId, MVar ())] -- , ctlPrefixLock :: Maybe PrefixLock -- ^ Stores exclusive prefix lock (implemented in filesystem) , ctlCreateCheckpoint :: IO () } data EventLogEntry = EventLogEntry TxContext Object deriving (Typeable, Show) instance Version EventLogEntry instance Serialize EventLogEntry where putCopy (EventLogEntry context obj) = contain $ safePut (context,obj) getCopy = contain $ do (context, obj) <- safeGet return $ EventLogEntry context obj runTxLoop :: MVar (WriterStream EventLogEntry) -> ProcessQueue st -> st -> IO () runTxLoop eventSaverVar queue st0 = let loop st = do IHR context ev fun <- atomically $ readTChan queue pushEventItem context ev -- Notify the user that this event is about to be executed. -- FIXME: What if the user wants to know when the event has -- finished executing? let tstring = eventTString ev logMT NOTICE $ ("> Event "++show (txId context)++" of "++tstring) (mst,ra) <- fun context st case mst of -- State was not updated. -- -- Thus the response can be executed immediately. Nothing -> do forkIO $ logMT NOTICE "> pure" >> ra loop st -- There is a new State. -- -- Note that saverAdd can return without yet writing the result -- as long as: -- 1) saverAdd calls honor the sequence in which they were made. -- 2) saverAdd calls execute the finalizers only after the value -- has been serialized. The finalizers typically return the -- result to the user so they should not be kept -- waiting too long. -- 3) This means that checkpoints need to flush the saver -- which will guarantee that all pending result/side-effects -- have been processed. -- 4) Savers must *not* block while running the finalizers Just st' -> do eventSaver <- readMVar eventSaverVar writerAdd eventSaver (EventLogEntry context (mkObject ev)) (logMT NOTICE "> disk " >> ra) loop st' in do forkIO $ (loop st0) `catch` (\ThreadKilled -> return ()) #if MIN_VERSION_base(4,2,0) `catch` (\BlockedIndefinitelyOnSTM -> return ()) #else `catch` (\BlockedIndefinitely -> return ()) #endif return () happstack-state-6.0.0/src/Happstack/State/NetworkChan.hs0000644000000000000000000000456111527320411021345 0ustar0000000000000000module Happstack.State.NetworkChan ( BEncodeable(..) , NetworkChan , newNetworkChan , peek , poke ) where import Data.BEncode import Data.BEncode.Parser import Control.Monad (when, forever, forM_ ) import System.IO import qualified Data.ByteString.Lazy as L import Data.Binary import Control.Concurrent.STM import Control.Concurrent (forkIO, ThreadId) class BEncodeable a where bencode :: a -> BEncode bdecode :: BParser a data NetworkChan = NetworkChan { outgoingChan :: TVar [L.ByteString] , incomingHandle :: Handle , writerThread :: ThreadId } newNetworkChan :: Handle -> Handle -> IO NetworkChan newNetworkChan outgoing incoming = do cache <- newTVarIO [] tid <- forkIO $ forever $ do ls <- atomically $ do ls <- readTVar cache when (null ls) retry writeTVar cache [] return (reverse ls) forM_ ls $ \entry -> do L.hPut outgoing (encode (L.length entry)) L.hPut outgoing entry hFlush outgoing return NetworkChan { outgoingChan = cache , incomingHandle = incoming , writerThread = tid } peek :: BEncodeable a => NetworkChan -> IO a peek chan = do size <- L.hGet (incomingHandle chan) 8 when (L.length size < 8) $ error "NetworkChan.peek: Connection closed." body <- L.hGet (incomingHandle chan) (decode size) case bRead body of Nothing -> error "NetworkChan.peek: Malformed bencoded data." Just encoded -> case runParser bdecode encoded of Left err -> error "NetworkChan.peek: Parsing bencoded data failed." Right msg -> return msg poke :: BEncodeable a => NetworkChan -> a -> IO () poke chan msg = atomically $ do ls <- readTVar (outgoingChan chan) writeTVar (outgoingChan chan) (bPack (bencode msg):ls) {- do L.hPut (inputHandle chan) (encode (L.length body)) L.hPut (inputHandle chan) body hFlush (inputHandle chan) where body = bPack (bencode msg) -} happstack-state-6.0.0/src/Happstack/State/Saver/0000755000000000000000000000000011527320411017640 5ustar0000000000000000happstack-state-6.0.0/src/Happstack/State/Saver/Types.hs0000644000000000000000000000061111527320411021276 0ustar0000000000000000module Happstack.State.Saver.Types where data ReaderStream a = ReaderStream { readerClose :: IO () , readerGet :: IO ([a], Int) , readerGetUncut :: IO [a] } data WriterStream a = WriterStream { writerClose :: IO () , writerAdd :: a -> IO () -> IO () , writerAtomicReplace :: a -> IO () , writerCut :: IO Int } happstack-state-6.0.0/src/Happstack/State/Saver/Impl/0000755000000000000000000000000011527320411020541 5ustar0000000000000000happstack-state-6.0.0/src/Happstack/State/Saver/Impl/Queue.hs0000644000000000000000000000415711527320411022170 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable #-} module Happstack.State.Saver.Impl.Queue ( queueReader , queueWriter ) where import Happstack.State.Saver.Types import Happstack.Data.Serialize import Control.Concurrent.STM import Control.Concurrent import Control.Monad import Data.Typeable import Data.Binary data Item = Close (IO ()) | Add Put (IO ()) queueReader :: ReaderStream a -> IO (ReaderStream a) queueReader stream = return stream data Encoded = Encoded Put deriving Typeable instance Version Encoded where mode = Primitive instance Serialize Encoded where putCopy (Encoded out) = contain out getCopy = error "decoding from writer queue." -- | A saver that bunches writes. queueWriter :: Serialize a => WriterStream Encoded -> IO (WriterStream a) queueWriter writer = do ch <- newCh let handler = do input <- getChs ch let il (Add p f : rest) a0 a1 = il rest (p:a0) (f:a1) il something a0 a1 = (reverse a0, sequence_ $ reverse a1, something) let (ps,io,rest) = il input [] [] when (not (null ps)) $ writerAdd writer (Encoded $ sequence_ ps) io case rest of [] -> handler (Close io':_) -> writerClose writer >> io' _ -> fail "queueSaver: Invalid saver bunch!" forkIO handler return $ WriterStream { writerClose = do mv <- newEmptyMVar writeCh ch $ Close (writerClose writer >> putMVar mv ()) takeMVar mv , writerAdd = \ps fin -> writeCh ch $ Add (safePut ps) fin , writerAtomicReplace = \a -> writerAtomicReplace writer (Encoded $ safePut a) , writerCut = writerCut writer } -- Sample variables/queues newtype Ch a = Ch (TVar [a]) newCh :: IO (Ch a) newCh = fmap Ch $ newTVarIO [] writeCh :: Ch a -> a -> IO () writeCh (Ch ch) x = atomically $ do vs <- readTVar ch writeTVar ch (x:vs) getChs :: Ch a -> IO [a] getChs (Ch ch) = atomically $ do vs <- readTVar ch guard (not (null vs)) writeTVar ch [] return (reverse vs) happstack-state-6.0.0/src/Happstack/State/Saver/Impl/Memory.hs0000644000000000000000000000632211527320411022350 0ustar0000000000000000module Happstack.State.Saver.Impl.Memory where import Happstack.Data.Serialize import Happstack.State.Saver.Types import Control.Concurrent import qualified Data.ByteString.Lazy.Char8 as L import Data.Maybe import qualified Data.Map as M type Store = M.Map String (M.Map Int L.ByteString) newMemoryStore :: IO (MVar Store) newMemoryStore = newMVar M.empty memoryReader :: Serialize a => MVar Store -> String -> Int -> IO (ReaderStream a) memoryReader store key cutoff = do return $ ReaderStream { readerClose = do return () , readerGet = withMVar store $ \storeData -> let getAllData ((cut,_):xs) n | n > cut = getAllData xs n getAllData ((cut,dat):xs) n | n == cut = dat : getAllData xs (n+1) getAllData _ _ = [] allData = getAllData (maybe [] M.toList $ M.lookup key storeData) cutoff in return $ (parseAll (L.concat allData), length allData) , readerGetUncut = withMVar store $ \storeData -> return $ parseAll $ fromMaybe L.empty $ M.lookup cutoff =<< M.lookup key storeData } memoryWriter :: Serialize a => MVar Store -> String -> Int -> IO (WriterStream a) memoryWriter store key cutoffInit = do cutoffVar <- newMVar cutoffInit modifyMVar_ store $ \storeData -> return (addToStore key cutoffInit L.empty storeData) return $ WriterStream { writerClose = return () , writerAdd = \m f -> do cutoff <- readMVar cutoffVar modifyMVar_ store $ \storeData -> return $ addToStore key cutoff (serialize m) storeData forkIO f return () , writerAtomicReplace = \ss -> do cutoff <- readMVar cutoffVar modifyMVar_ store $ \storeData -> return $ setStore key cutoff (serialize ss) storeData , writerCut = do newCut <- modifyMVar cutoffVar $ \cutoff -> return (cutoff+1, cutoff+1) modifyMVar_ store $ \storeData -> return (addToStore key newCut L.empty storeData) return newCut } parseAll :: Serialize a => L.ByteString -> [a] parseAll = loop where loop l | L.null l = [] loop l = let (a,rest) = deserialize l in a:loop rest addToStore :: (Ord a, Ord b) => a -> b -> L.ByteString -> M.Map a (M.Map b L.ByteString) -> M.Map a (M.Map b L.ByteString) addToStore key cutoff val store = M.unionWith (M.unionWith L.append) store element where element = M.singleton key $ M.singleton cutoff val setStore :: (Ord a) => a -> b -> c -> M.Map a (M.Map b c) -> M.Map a (M.Map b c) setStore key cutoff val store = M.unionWith (\_ _ -> M.singleton cutoff val) store element where element = M.singleton key $ M.singleton cutoff val happstack-state-6.0.0/src/Happstack/State/Saver/Impl/File.hs0000644000000000000000000002321711527320411021761 0ustar0000000000000000{-# LANGUAGE CPP #-} module Happstack.State.Saver.Impl.File ( PrefixLock , fileReader , fileWriter , obtainPrefixLock , releasePrefixLock ) where import Happstack.State.Saver.Types import Happstack.Data.Serialize import Control.Concurrent import Control.Exception.Extensible as E import qualified Data.ByteString.Lazy as L import qualified Data.ByteString as B import System.Directory ( createDirectoryIfMissing, removeFile, renameFile, doesFileExist ) import System.IO import System.Random ( randomIO ) import System.Log.Logger import Text.Printf import Control.Monad import System.FilePath #ifdef UNIX import Data.Maybe (listToMaybe) import qualified System.IO.Error as SE import System.Posix.IO (openFd, OpenMode(ReadWrite), defaultFileFlags, exclusive, trunc, fdToHandle) import System.Posix.Process (getProcessID) import System.Posix.Signals (nullSignal, signalProcess) import System.Posix.Types (ProcessID) #else import Happstack.Util.OpenExclusively (openExclusively) #endif #ifdef UNIX newtype PrefixLock = PrefixLock FilePath #else type PrefixLock = (FilePath, Handle) #endif tryE :: IO a -> IO (Either SomeException a) tryE = E.try catchE :: IO a -> (SomeException -> IO a) -> IO a catchE = E.catch #ifndef UNIX catchIO :: IO a -> (IOException -> IO a) -> IO a catchIO = E.catch #endif logMF :: Priority -> String -> IO () logMF = logM "Happstack.State.Saver.Impl.File" formatFilePath :: Int -> String -> FilePath formatFilePath n str = printf "%s-%010d" str n fileReader :: Serialize a => FilePath -> String -> Int -> IO (ReaderStream a) fileReader prefix key cutoff = do let file = prefix formatFilePath cutoff key tryE $ createDirectoryIfMissing True prefix return $ ReaderStream { readerClose = return () , readerGet = do logMF NOTICE "fileReader: readerGet" allFiles <- getAllFiles prefix key cutoff allData <- mapM B.readFile allFiles return $ (parseAll (L.fromChunks allData), length allFiles) , readerGetUncut = do logMF NOTICE "fileReader: readerGetUncut" allData <- B.readFile file `catchE` \_ -> return B.empty return $ parseAll (L.fromChunks [allData]) } parseAll :: Serialize a => L.ByteString -> [a] parseAll = loop where loop l | L.null l = [] loop l = let (a,rest) = deserialize l in a:loop rest fileWriter :: Serialize a => FilePath -> String -> Int -> IO (WriterStream a) fileWriter prefix key cutoffInit = do cutoffVar <- newMVar cutoffInit let getFileName = do cutoff <- readMVar cutoffVar return $ prefix formatFilePath cutoff key file <- getFileName logMF NOTICE ("fileWriter: "++key++" @ "++prefix) hmv <- newMVar =<< openBinaryFile file WriteMode return $ WriterStream { writerClose = withMVar hmv hClose , writerAdd = \m f -> do logMF NOTICE "fileWriter: saverAdd" withMVar hmv (\h -> L.hPut h (serialize m) >> hFlush h) forkIO f return () , writerAtomicReplace = \ss -> do h <- takeMVar hmv hClose h file' <- getFileName atomicWriteFile file' (serialize ss) putMVar hmv =<< openBinaryFile file' AppendMode , writerCut = do h <- takeMVar hmv hClose h cutoff <- takeMVar cutoffVar let file' = prefix formatFilePath (cutoff+1) key putMVar cutoffVar (cutoff+1) putMVar hmv =<< openBinaryFile file' WriteMode return (cutoff+1) } getAllFiles :: FilePath -> String -> Int -> IO [FilePath] getAllFiles prefix key cutoff = loop cutoff where loop n = do let file = prefix formatFilePath n key exist <- doesFileExist file if exist then liftM (file:) (loop (n+1)) else return [] -- | Just to avoid a dependency. atomicWriteFile :: String -> L.ByteString -> IO () atomicWriteFile path string = do r <- randomIO :: IO Int let p' = path ++ ".atomic-tmp-" ++ show (abs r) L.writeFile p' string renameFile p' path #ifdef UNIX obtainPrefixLock :: FilePath -> IO PrefixLock obtainPrefixLock prefix = do checkLock fp >> takeLock fp where fp = prefix ++ ".lock" -- |Read the lock and break it if the process is dead. checkLock :: FilePath -> IO () checkLock fp = readLock fp >>= maybeBreakLock fp -- |Read the lock and return the process id if possible. readLock :: FilePath -> IO (Maybe ProcessID) readLock fp = try (readFile fp) >>= return . either (checkReadFileError fp) (fmap (fromInteger . read) . listToMaybe . lines) -- |Is this a permission error? If so we don't have permission to -- remove the lock file, abort. checkReadFileError :: [Char] -> IOError -> Maybe ProcessID checkReadFileError fp e | SE.isPermissionError e = throw (userError ("Could not read lock file: " ++ show fp)) | SE.isDoesNotExistError e = Nothing | True = throw e maybeBreakLock :: FilePath -> Maybe ProcessID -> IO () maybeBreakLock fp Nothing = -- The lock file exists, but there's no PID in it. At this point, -- we will break the lock, because the other process either died -- or will give up when it failed to read its pid back from this -- file. breakLock fp maybeBreakLock fp (Just pid) = do -- The lock file exists and there is a PID in it. We can break the -- lock if that process has died. -- getProcessStatus only works on the children of the calling process. -- exists <- try (getProcessStatus False True pid) >>= either checkException (return . isJust) exists <- doesProcessExist pid case exists of True -> throw (lockedBy fp pid) False -> breakLock fp doesProcessExist :: ProcessID -> IO Bool doesProcessExist pid = -- Implementation 1 -- doesDirectoryExist ("/proc/" ++ show pid) -- Implementation 2 try (signalProcess nullSignal pid) >>= return . either checkException (const True) where checkException e | SE.isDoesNotExistError e = False | True = throw e -- |We have determined the locking process is gone, try to remove the -- lock. breakLock :: FilePath -> IO () breakLock fp = try (removeFile fp) >>= either checkBreakError (const (return ())) -- |An exception when we tried to break a lock, if it says the lock -- file has already disappeared we are still good to go. checkBreakError :: IOError -> IO () checkBreakError e | SE.isDoesNotExistError e = return () | True = throw e -- |Try to create lock by opening the file with the O_EXCL flag and -- writing our PID into it. Verify by reading the pid back out and -- matching, maybe some other process slipped in before we were done -- and broke our lock. takeLock :: FilePath -> IO PrefixLock takeLock fp = do createDirectoryIfMissing True (takeDirectory fp) h <- openFd fp ReadWrite (Just 0o600) (defaultFileFlags {exclusive = True, trunc = True}) >>= fdToHandle pid <- getProcessID hPutStrLn h (show pid) >> hClose h -- Read back our own lock and make sure its still ours readLock fp >>= maybe (throw (cantLock fp pid)) (\ pid' -> if pid /= pid' then throw (stolenLock fp pid pid') else return (PrefixLock fp)) -- |An exception saying the data is locked by another process. lockedBy :: (Show a) => FilePath -> a -> SomeException lockedBy fp pid = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Locked by " ++ show pid) Nothing (Just fp)) -- |An exception saying we don't have permission to create lock. cantLock :: FilePath -> ProcessID -> SomeException cantLock fp pid = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Process " ++ show pid ++ " could not create a lock") Nothing (Just fp)) -- |An exception saying another process broke our lock before we -- finished creating it. stolenLock :: FilePath -> ProcessID -> ProcessID -> SomeException stolenLock fp pid pid' = SomeException (SE.mkIOError SE.alreadyInUseErrorType ("Process " ++ show pid ++ "'s lock was stolen by process " ++ show pid') Nothing (Just fp)) -- |Relinquish the lock by removing it and then verifying the removal. releasePrefixLock :: PrefixLock -> IO () releasePrefixLock (PrefixLock fp) = dropLock >>= either checkDrop return where dropLock = try (removeFile fp) checkDrop e | SE.isDoesNotExistError e = return () | True = throw e #else obtainPrefixLock :: FilePath -> IO PrefixLock obtainPrefixLock prefix = do createDirectoryIfMissing True prefix -- catchIO obtainLock onError catchIO obtainLock onError where fp = prefix ++ ".lock" obtainLock = do h <- openExclusively fp return (fp, h) onError e = do putStrLn "There may already be an instance of this application running, which could result in a loss of data." putStrLn ("Please make sure there is no other application attempting to access '" ++ prefix ++ "'") throw e releasePrefixLock :: PrefixLock -> IO () releasePrefixLock (fp, h) = do tryE $ hClose h tryE $ removeFile fp return () #endif happstack-state-6.0.0/tests/0000755000000000000000000000000011527320411014135 5ustar0000000000000000happstack-state-6.0.0/tests/Test.hs0000644000000000000000000000120511527320411015406 0ustar0000000000000000module Main where import Happstack.State.Tests (allTests) import Test.HUnit (errors, failures, putTextToShowS,runTestText, runTestTT) import System.Exit (exitFailure) import System.IO (hIsTerminalDevice, stdout) -- |A simple driver for running the local test suite. main :: IO () main = do c <- do istty <- hIsTerminalDevice stdout if istty then runTestTT allTests else do (c,st) <- runTestText putTextToShowS allTests putStrLn (st "") return c case (failures c) + (errors c) of 0 -> return () n -> exitFailure happstack-state-6.0.0/tests/Happstack/0000755000000000000000000000000011527320411016053 5ustar0000000000000000happstack-state-6.0.0/tests/Happstack/State/0000755000000000000000000000000011527320411017133 5ustar0000000000000000happstack-state-6.0.0/tests/Happstack/State/Tests.hs0000644000000000000000000000121411527320411020567 0ustar0000000000000000module Happstack.State.Tests (allTests) where import Happstack.State.Tests.SaverProperties (saverProperties) import Happstack.State.Tests.CheckpointProperties (checkpointProperties, congestedCheckpoint, runRestoreCongestionKnownFailures) import Test.HUnit allTests :: Test allTests = "happstack-state" ~: [ runRestoreCongestionKnownFailures , checkpointProperties , congestedCheckpoint , saverProperties ] {- List of properties * for all operations, memory saver == file saver * saverCut is only an optimization * checkpoint is only an optimization * events that predate the last checkpoint are ignored -} happstack-state-6.0.0/tests/Happstack/State/Tests/0000755000000000000000000000000011527320411020235 5ustar0000000000000000happstack-state-6.0.0/tests/Happstack/State/Tests/Helpers.hs0000644000000000000000000000720311527320411022175 0ustar0000000000000000module Happstack.State.Tests.Helpers where import Happstack.State.Saver import Happstack.State.Saver.Impl.Memory import System.Directory import System.Random import System.FilePath import System.Exit import System.IO.Unsafe import Control.Monad import Control.Exception import Control.Concurrent import Test.QuickCheck (Arbitrary(arbitrary), choose) import Text.Printf instance (Arbitrary a, Num a) => Arbitrary (Abs a) where arbitrary = liftM (Abs . abs) arbitrary instance (Arbitrary a) => Arbitrary (NonEmpty a) where arbitrary = do x <- arbitrary xs <- arbitrary return $ NonEmpty (x:xs) data Abs a = Abs a instance (Show a) => Show (Abs a) where show (Abs a) = show a data NonEmpty a = NonEmpty [a] instance (Show a) => Show (NonEmpty a) where show (NonEmpty a) = show a ioProperty = unsafePerformIO withTemporaryDirectory :: (FilePath -> IO a) -> IO a withTemporaryDirectory action = do tmp <- getTemporaryDirectory n <- randomIO let dir = tmp (show (abs n :: Int)) exist <- doesDirectoryExist dir if exist then withTemporaryDirectory action else bracket_ (createDirectoryIfMissing False dir) (removeDirectoryRecursive dir) (action dir) withMemorySaver action = action =<< liftM Memory newMemoryStore withFileSaver action = withTemporaryDirectory $ \dir -> action (FileSaver dir) withQueueSaver h action = h (action . Queue) forEachSaverM :: (Monad m) => (String -> ((Saver -> IO a) -> IO a) -> m b) -> m [b] forEachSaverM action = forM savers $ \(name, withSaver) -> action name withSaver where savers = [ ("Memory", withMemorySaver) , ("Queue Memory", \action -> withMemorySaver (action . Queue)) , ("File", withFileSaver) , ("Queue File", \action -> withFileSaver (action . Queue)) ] forEachSaver :: (String -> ((Saver -> IO a) -> IO a) -> b) -> [b] forEachSaver action = flip map savers $ \(name, withSaver) -> action name withSaver where savers = [ ("Memory", withMemorySaver) , ("Queue Memory", \action -> withMemorySaver (action . Queue)) , ("File", withFileSaver) , ("Queue File", \action -> withFileSaver (action . Queue)) ] forEachSaver_ action = forM_ savers $ \(name, withSaver) -> action name withSaver where savers = [ ("Memory", withMemorySaver) , ("Queue Memory", \action -> withMemorySaver (action . Queue)) , ("File", withFileSaver) , ("Queue File", \action -> withFileSaver (action . Queue)) ] {- tryTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO () tryTests name opt tests = do printf "%25s : " name forM_ tests $ \test -> do res <- test opt case res of TestOk _ _ _ -> putStr "." TestExausted _ _ _ -> putStr "?" TestFailed err num -> do putStr "\n" printf " ** test %d of %s failed with the binding(s)\n" num name sequence_ [ putStrLn (" ** " ++ v) | v <- err ] exitWith (ExitFailure 1) TestAborted exp -> do putStr "\n" printf " ** test %s failed with the exception\n" name putStrLn (" ** " ++ show exp) exitWith (ExitFailure 1) putChar '\n' -}happstack-state-6.0.0/tests/Happstack/State/Tests/CheckpointProperties.hs0000644000000000000000000002115611527320411024742 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, TemplateHaskell, TypeFamilies #-} module Happstack.State.Tests.CheckpointProperties ( testCongestedCheckpoint , congestedCheckpoint , checkpointProperties , runRestoreCongestionKnownFailures ) where import Happstack.State import Happstack.State.ComponentTH import Happstack.State.TxControl import Happstack.State.Tests.Helpers import Happstack.Util.Testing (qccheck, qctest) import Control.Monad import Control.Monad.State (get,put) import Control.Monad.Reader (ask) import Control.Exception import Control.Concurrent import Data.Typeable import Text.Printf import Test.QuickCheck import Test.HUnit (Test(..),(~:), assertBool, assertFailure) -------------------------------------------------------------- -- Checkpoint congestion -------------------------------------------------------------- data RestoreTest = RestoreTest Int deriving (Typeable) instance Version RestoreTest $(deriveSerialize ''RestoreTest) data Block = Block (Maybe (MVar ())) deriving (Typeable) -- We don't want to block events that are loaded from disk. instance Version Block instance Serialize Block where putCopy _ = contain $ return () getCopy = contain $ return $ Block Nothing succValue :: Block -> Update RestoreTest () succValue block = do RestoreTest n <- get put $ RestoreTest (n+1) case block of Block (Just mv) -> unsafeIOToEv $ takeMVar mv _ -> return () getValue :: Query RestoreTest Int getValue = do RestoreTest n <- ask return n $(mkMethods ''RestoreTest [ 'succValue , 'getValue]) instance Component RestoreTest where type Dependencies RestoreTest = End initialValue = RestoreTest 0 restoreTestEntryPoint :: Proxy RestoreTest restoreTestEntryPoint = Proxy {- There is a small window after the saver has been cut and the checkpoints have been queried. Events that are executed in this windows must be ignored when the state is restored. That is, events with a transaction id lower than the saved checkpoint should not be replayed. In applications, this is bound to happen when the processing queue is congested (non-empty). We will trigger this occasion via a blocking event. The event will enter the processing queue and block before it has been written to disk. We will then schedule a checkpoint and unblock the event. The event will be written in the same file as the checkpoint. If the event isn't discarded when the state is restored, the value in the state will be '2' instead of '1'. -} testCongestedCheckpoint = withMemorySaver $ \saver -> do initCongestedCheckpoint (Queue saver) checkRestoredValue (Queue saver) checkRestoredValue saver = bracket (runTxSystem saver restoreTestEntryPoint) (shutdownSystem) $ \ctl -> do val <- query $ GetValue when (val /= 1) $ error $ "testCongestedCheckpoint failed: " ++ show val printf "%25s : OK\n" "Checkpoint congestion" congestedCheckpoint :: Test congestedCheckpoint = TestCase $ withMemorySaver $ \saver -> do initCongestedCheckpoint (Queue saver) bracket (runTxSystem saver restoreTestEntryPoint) (shutdownSystem) $ \ctl -> do val <- query $ GetValue when (val /= 1) $ assertFailure $ "testCongestedCheckpoint failed: " ++ show val initCongestedCheckpoint saver = bracket (runTxSystem saver restoreTestEntryPoint) (shutdownSystem) $ \ctl -> do mv <- newEmptyMVar forkIO $ do update $ SuccValue (Block (Just mv)) yield -- Relying on yields for correctness isn't a great idea. forkIO $ createCheckpoint ctl yield -- However, it's OK for now since tests aren't vital. putMVar mv () -------------------------------------------------------------- -- Run/Restore -------------------------------------------------------------- data RunRestore = RunRestore [Int] deriving (Typeable,Show) instance Version RunRestore $(deriveSerialize ''RunRestore) push :: Int -> Update RunRestore () push val = do RunRestore ls <- get put $ RunRestore (val:ls) peek :: Query RunRestore [Int] peek = do RunRestore ls <- ask return $ reverse ls $(mkMethods ''RunRestore [ 'push , 'peek]) instance Component RunRestore where type Dependencies RunRestore = End initialValue = RunRestore [] runRestoreEntryPoint :: Proxy RunRestore runRestoreEntryPoint = Proxy genRunRestoreProp withSaver check action = ioProperty $ withSaver $ \saver -> do bracket (runTxSystem saver runRestoreEntryPoint) (shutdownSystem) $ \ctl -> do action ctl bracket (runTxSystem saver runRestoreEntryPoint) (shutdownSystem) $ \ctl -> do ls <- query Peek return (check ls) -- State changes without a checkpoint should be lost. prop_runRestoreId withSaver values = genRunRestoreProp withSaver (==values) $ \ctl -> forM_ values (update . Push) -- Checkpoints can be placed arbitrarily. prop_runRestoreCheckpoint withSaver before after = genRunRestoreProp withSaver (== (before++after)) $ \ctl -> do forM_ before (update . Push) createCheckpoint ctl forM_ after (update . Push) -- Multiple checkpoints can be placed arbitrarily. prop_runRestoreMultipleCheckpoint withSaver allData = genRunRestoreProp withSaver (== concat allData) $ \ctl -> do forM_ allData $ \dataList -> do createCheckpoint ctl forM_ dataList (update . Push) -- 'update'/'update' and 'checkCheckpoint' are thread-safe. prop_runRestoreAsync withSaver values = genRunRestoreProp withSaver (== values) $ \ctl -> do mv1 <- newEmptyMVar mv2 <- newEmptyMVar forkIO $ forM_ values (update . Push) `finally` putMVar mv1 () forkIO $ createCheckpoint ctl `finally` putMVar mv2 () takeMVar mv1 takeMVar mv2 -- Send all events in parallel. Better at testing congestion. prop_runRestoreCongestion withSaver values = genRunRestoreProp withSaver (\ls -> sum ls == sum values) $ \ctl -> do sem <- newQSem 0 mv <- newEmptyMVar forM_ values $ \value -> forkIO (update (Push value) `finally` signalQSem sem) forkIO $ createCheckpoint ctl `finally` putMVar mv () takeMVar mv replicateM_ (length values) (waitQSem sem) {- checkCheckpointProperties :: IO () checkCheckpointProperties = tryTests ("runRestore") options [run (prop_runRestoreId saver) ,run (prop_runRestoreCheckpoint saver) ,run (prop_runRestoreMultipleCheckpoint saver) ,run (prop_runRestoreAsync saver) ,run (prop_runRestoreCongestion saver)] where args = stdArgs {maxSize=5} saver = withQueueSaver withMemorySaver -} checkpointProperties :: Test checkpointProperties = "checkpointProperties" ~: [ "prop_runRestoreId" ~: qccheck args (prop_runRestoreId saver) , "prop_runRestoreCheckpoint" ~: qccheck args (prop_runRestoreCheckpoint saver) , "prop_runRestoreMultipleCheckpoint" ~: qccheck args (prop_runRestoreMultipleCheckpoint saver) , "prop_runRestoreAsync" ~: qccheck args (prop_runRestoreAsync saver) , "prop_runRestoreCongestion" ~: qccheck args (prop_runRestoreCongestion saver) ] where args = stdArgs { maxSize = 100 } saver = withQueueSaver withMemorySaver {- I have seen prop_runRestoreCongestion fail several times. I tried adding the failing cases as explicit tests, but they don't seem to fail. ### Failure in: happstack-state:0:checkpointProperties:4:prop_runRestoreCongestion Falsifiable, after 56 tests: [-15,8,-11,-6,-3,-7,20,20,15,-16,13,20,-17,-19,14,-2,-17,-15,-1,-17] ### Failure in: happstack-state:0:checkpointProperties:4:prop_runRestoreCongestion Falsifiable, after 59 tests: [6,-10,3,14,2,1,-12,-8,-14,17,7,-14,10,-11] ### Failure in: happstack:3:happstack-state:0:checkpointProperties:4:prop_runRestoreCongestion Falsifiable, after 67 tests: [11,22,22,10,12,-13,-8,-21,9,19,3,11,-5] -} runRestoreCongestionKnownFailures :: Test runRestoreCongestionKnownFailures = "runRestoreCongestionKnownFailures" ~: map (assertBool "" . prop_runRestoreCongestion saver) known where saver = withQueueSaver withMemorySaver known = [ [-15,8,-11,-6,-3,-7,20,20,15,-16,13,20,-17,-19,14,-2,-17,-15,-1,-17] , [6,-10,3,14,2,1,-12,-8,-14,17,7,-14,10,-11] , [11,22,22,10,12,-13,-8,-21,9,19,3,11,-5] ] happstack-state-6.0.0/tests/Happstack/State/Tests/SaverProperties.hs0000644000000000000000000000723511527320411023735 0ustar0000000000000000module Happstack.State.Tests.SaverProperties ( saverProperties ) where import Control.Monad import Control.Exception import Control.Concurrent import Data.Char (isAlphaNum) import Data.List import Happstack.State.Saver import Happstack.State.Saver.Impl.Memory import Happstack.State.Tests.Helpers import Happstack.Util.Testing (qctest, qccheck) import System.Directory import System.Random import System.FilePath import System.IO.Unsafe import Test.QuickCheck (Args(maxSize), Property, (==>), stdArgs) import Test.HUnit (Test(TestCase),(~:)) -------------------------------------------------------------- -- Tests -------------------------------------------------------------- -- read (write values) == values prop_getSetId :: ((Saver -> IO Bool) -> IO Bool) -> {- String -> -} Int -> [Int] -> Property prop_getSetId withSaver {- (NonEmpty key) -} cutoff values = (abs cutoff) > 0 ==> ioProperty $ withSaver $ \saver -> do writer <- createWriter saver key (abs cutoff) forM_ values $ \value -> writerAdd writer (value::Int) $ return () writerClose writer reader <- createReader saver key (abs cutoff) out <- readerGetUncut reader return $ values == out where key = "key" -- not sure if randomly generating the key is useful. But it was causing trouble because it contain ~ / and other meaningful characters prop_seqReadWrite withSaver {-(NonEmpty key) -} (Abs cutoff) valss = ioProperty $ withSaver $ \saver -> do writer <- createWriter saver key cutoff forM_ valss $ \vals -> do forM_ vals $ \val -> writerAdd writer (val::Int) $ return () writerCut writer writerClose writer reader <- createReader saver key cutoff (out,newCut) <- readerGet reader return $ out == concat valss && newCut == length valss + 1 where key = "key" prop_cutDrop withSaver {- (NonEmpty key) -} (Abs cutoff) a b = ioProperty $ withSaver $ \saver -> do writer <- createWriter saver key cutoff forM_ a $ \val -> writerAdd writer (val::Int) $ return () newCut <- writerCut writer forM_ b $ \val -> writerAdd writer (val::Int) $ return () writerClose writer reader <- createReader saver key newCut (out,_) <- readerGet reader return $ b `isSuffixOf` out where key = "key" prop_atomic withSaver {- (NonEmpty key) -} (Abs cutoff) value = ioProperty $ withSaver $ \saver -> do writer <- createWriter saver key cutoff writerAtomicReplace writer (value::Int) writerClose writer reader <- createReader saver key cutoff out <- readerGetUncut reader readerClose reader return $ out == [value] where key = "key" {- checkSaverProperties :: IO () checkSaverProperties = forEachSaver_ $ \name withSaver -> tryTests (name ++ " saver") args [run (prop_getSetId withSaver) ,run (prop_seqReadWrite withSaver) ,run (prop_cutDrop withSaver) ,run (prop_atomic withSaver)] where args = stdArgs{maxSize=5} -} saverProperties :: Test saverProperties = "saverProperties" ~: ((forEachSaver $ \name withSaver -> name ~: [ "prop_getSetId" ~: qccheck args (prop_getSetId withSaver) , "prop_seqReadWrite" ~: qccheck args (prop_seqReadWrite withSaver) , "prop_cutDrop" ~: qccheck args (prop_cutDrop withSaver) , "prop_atomic" ~: qccheck args (prop_atomic withSaver) ])) where args = stdArgs{maxSize=5}