diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,3 +1,3 @@ #!/usr/bin/env runhaskell import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks +main = defaultMainWithHooks simpleUserHooks diff --git a/happstack-state.cabal b/happstack-state.cabal --- a/happstack-state.cabal +++ b/happstack-state.cabal @@ -1,5 +1,5 @@ Name: happstack-state -Version: 0.2.1 +Version: 6.1.4 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 @@ -8,26 +8,41 @@ Maintainer: Happstack team homepage: http://happstack.com Category: Web, Distributed Computing -Cabal-Version: >= 1.2.3 +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.ClockTime 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 @@ -35,13 +50,7 @@ Happstack.State.Tests.SaverProperties Other-modules: Happstack.State.Checkpoint - Happstack.State.Spread Happstack.State.Monad - Happstack.State.Saver.Impl.File - Happstack.State.Saver.Impl.Memory - Happstack.State.Saver.Impl.Queue - Happstack.State.Saver.Types --- Happstack.State.OperationModes Happstack.State.Types Happstack.State.Util Happstack.State.TxControl @@ -53,21 +62,27 @@ extensible-exceptions, filepath, hslogger >= 1.0.2, - hspread >= 0.3, - happstack-util >= 0.2.1 && < 0.3, - happstack-data >= 0.2.1 && < 0.3, - mtl, + happstack-util >= 6.0 && < 6.1, + happstack-data >= 6.0.1 && < 6.1, + mtl >= 1.1 && < 2.1, old-time, random, - stm, + stm >= 2.1.2.2, 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 - if flag(tests) - Build-Depends: QuickCheck < 2, HUnit hs-source-dirs: src if flag(tests) @@ -82,18 +97,21 @@ OverlappingInstances, UndecidableInstances, CPP, TypeFamilies, FunctionalDependencies, TypeOperators, GADTs, EmptyDataDecls, ExistentialQuantification, RankNTypes, - ScopedTypeVariables, PatternSignatures, PatternGuards, + ScopedTypeVariables, PatternGuards, MagicHash, TypeSynonymInstances - ghc-options: -Wall + 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 - Build-depends: HUnit hs-source-dirs: tests, src if flag(tests) Buildable: True + Build-depends: HUnit else Buildable: False diff --git a/src/Happstack/State.hs b/src/Happstack/State.hs --- a/src/Happstack/State.hs +++ b/src/Happstack/State.hs @@ -3,7 +3,7 @@ Ev, AnyEv, TxControl, query, update, Update, Query, -- * Types - TxId, EpochMilli, TxConfig(..),nullTxConfig,Saver(..), + TxId, EpochMilli, Saver(..), -- * Misc utilities module Happstack.State.Monad, getEventId, getTime, getEventClockTime, getEventStream, EventItem(..), @@ -13,11 +13,12 @@ module Happstack.Data.SerializeTH, module Happstack.State.Control, - module Happstack.State.TxControl, module Happstack.State.ComponentTH, module Happstack.State.ComponentSystem, - closeTxControl, + --closeTxControl, + runTxSystem, createCheckpoint, + shutdownSystem, -- * Unsafe things unsafeIOToEv ) where @@ -28,7 +29,6 @@ import Happstack.Data.Serialize import Happstack.Data.SerializeTH import Happstack.State.Transaction -import Happstack.State.Checkpoint import Happstack.State.ComponentSystem import Happstack.State.Types import Happstack.State.Util diff --git a/src/Happstack/State/CentralLogServer.hs b/src/Happstack/State/CentralLogServer.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/State/CentralLogServer.hs @@ -0,0 +1,251 @@ +module 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) diff --git a/src/Happstack/State/Checkpoint.hs b/src/Happstack/State/Checkpoint.hs --- a/src/Happstack/State/Checkpoint.hs +++ b/src/Happstack/State/Checkpoint.hs @@ -1,8 +1,6 @@ {-# LANGUAGE CPP, TemplateHaskell, DeriveDataTypeable #-} module Happstack.State.Checkpoint - ( createTxControl - , closeTxControl - , restoreState + ( restoreState , createCheckpoint ) where @@ -11,7 +9,6 @@ import Happstack.Data.Serialize import Happstack.Data.SerializeTH import Happstack.State.Transaction -import Happstack.State.ComponentSystem import Data.Typeable import Data.Maybe @@ -20,8 +17,6 @@ import Control.Exception as E import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.Map as M -import System.IO -import qualified Data.Map as M import System.Log.Logger @@ -44,24 +39,8 @@ instance Version State $(deriveSerialize ''State) --- | Starts a new TxControl -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 - newMVar $ TxControl - { ctlSaver = saver - , ctlEventSaver = eventSaverVar - , ctlAllComponents = allStateTypes prox - , ctlComponentVersions = componentVersions prox - , ctlChildren = [] } + --- | Saves and ends the TxControl -closeTxControl :: MVar TxControl -> IO () -closeTxControl ctlVar - = do ctl <- takeMVar ctlVar - writerClose =<< takeMVar (ctlEventSaver ctl) -- FIXME: It may be nice to print out what components were saved on disk -- compared to the components actually used in the application. diff --git a/src/Happstack/State/ClockTime.hs b/src/Happstack/State/ClockTime.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/State/ClockTime.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE TemplateHaskell, TypeFamilies, DeriveDataTypeable, + FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, + UndecidableInstances, StandaloneDeriving, TypeSynonymInstances + #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- |instances of Typeable, Data, Serialize, Version, and Default for ClockTime +module Happstack.State.ClockTime (ClockTime(..)) where + +import Data.Generics (Data, Typeable) +import Happstack.Data (deriveNewData) +import Happstack.State (Version, deriveSerialize) +import System.Time (ClockTime(..)) + +deriving instance Typeable ClockTime +deriving instance Data ClockTime +instance Version ClockTime +$(deriveSerialize ''ClockTime) +$(deriveNewData [''ClockTime]) diff --git a/src/Happstack/State/ComponentSystem.hs b/src/Happstack/State/ComponentSystem.hs --- a/src/Happstack/State/ComponentSystem.hs +++ b/src/Happstack/State/ComponentSystem.hs @@ -3,7 +3,6 @@ module Happstack.State.ComponentSystem where import Happstack.Data.Serialize -import Happstack.Data.Proxy import Happstack.State.Types import Data.Typeable @@ -34,9 +33,11 @@ class (Serialize ev, Serialize res) => QueryEvent ev res | ev -> res -------------------------------------------------------------- --- Methods contain the query and update handlers for a component +-- Methods contain the query and update handl ers 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 @@ -49,10 +50,10 @@ methodType m = case m of Update fn -> let ev :: (ev -> Update st res) -> ev ev _ = undefined - in show (typeOf (ev fn)) + in showQualifiedTypeRep (typeOf (ev fn)) Query fn -> let ev :: (ev -> Query st res) -> ev ev _ = undefined - in show (typeOf (ev fn)) + in showQualifiedTypeRep (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' @@ -92,11 +93,19 @@ -------------------------------------------------------------- -- 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 @@ -121,7 +130,7 @@ collectHandlers' :: (Methods a, Component a) => Proxy a -> Collect () collectHandlers' prox - = let key = show (typeOf (unProxy prox)) + = let key = showQualifiedTypeRep (typeOf (unProxy prox)) item = MethodMap $ Map.fromList [ (methodType m, m) | m <- methods prox ] versions = collectVersions prox in do addItem key item versions (onLoad prox) @@ -129,5 +138,6 @@ 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 diff --git a/src/Happstack/State/ComponentTH.hs b/src/Happstack/State/ComponentTH.hs --- a/src/Happstack/State/ComponentTH.hs +++ b/src/Happstack/State/ComponentTH.hs @@ -19,7 +19,15 @@ import Data.Generics.Basics -nubCxt :: [TypeQ] -> Q [Type] +#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 @@ -55,23 +63,38 @@ ds5 <- genSerializeInstances methodInfos return (ds1 ++ [ds2] ++ ds4 ++ ds5 ) -mkKeyConstraints :: [Name] -> [TypeQ] +mkKeyConstraints :: [Name] -> [CtxElemQ] mkKeyConstraints keys - = [ appT (conT ''Typeable) (varT key) | key <- keys ] ++ - [ appT (conT ''Serialize) (varT key) | key <- keys ] + = [ mkCtxt ''Typeable (varT key) | key <- keys ] ++ + [ mkCtxt ''Serialize (varT key) | key <- keys ] -mkMethodConstraints :: [Name] -> MethodInfo -> [TypeQ] +mkMethodConstraints :: [Name] -> MethodInfo -> [CtxElemQ] mkMethodConstraints keys method = map return (substMethodContext method keys) -substMethodContext :: MethodInfo -> [Name] -> [Type] +substMethodContext :: MethodInfo -> [Name] -> [CtxElem] substMethodContext method keys = let relation = zip (methodKeys method) keys - worker (VarT old) | Just new <- lookup old relation + + workerT (VarT old) | Just new <- lookup old relation = VarT new - worker (AppT l r) = AppT (worker l) (worker r) - worker (ForallT c names t) = ForallT c names (worker t) - worker t = t + 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 @@ -120,14 +143,21 @@ genEventInstance method = do let keys = methodKeys method eventType = foldl appT (conT (upperName (methodName method))) (map varT keys) - instanceD (nubCxt $ [appT (conT ''Serialize) eventType - ,appT (conT ''Serialize) (return (methodResult method))] + 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 @@ -137,8 +167,16 @@ 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)) (methodKeys method) [c] (derv) ] + 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 @@ -148,7 +186,7 @@ data MethodInfo = Method { methodName :: Name , methodKeys :: [Name] - , methodContext:: [Type] + , methodContext:: [CtxElem] , methodArgs :: [Type] , methodClass :: Name , methodEv :: Name @@ -179,12 +217,12 @@ _ -> 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 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 @@ -231,24 +269,56 @@ getStateKeys (ConT _st) = [] getStateKeys v = error $ "Bad state type: " ++ pprint v ++ " (expected a constant, an application or a type variable)" -isMonadState :: [Type] -> Type -> Maybe Type -isMonadState contxt name = listToMaybe [ state | AppT (AppT (ConT m) state) mName <- contxt, - mName == name, m == ''MonadState ] +-- |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 -isMonadReader :: [Type] -> Type -> Maybe Type -isMonadReader contxt name = listToMaybe [ state | AppT (AppT (ConT m) state) mName <- contxt, - mName == name, m == ''MonadReader ] -isRelevant :: [Name] -> Type -> Bool -isRelevant keys t = isAcceptableContext t && any (`elem` keys) (getStateKeys t) +isMonadState :: [CtxElem] -> Type -> Maybe Type +isMonadState = isMonadX ''MonadState -isAcceptableContext :: Type -> Bool +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)) = names -requireSimpleCon _ (TyConI (NewtypeD _ _ names _ _derv)) = names -requireSimpleCon _ (TyConI (TySynD _ names _)) = names +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 +#endif diff --git a/src/Happstack/State/Control.hs b/src/Happstack/State/Control.hs --- a/src/Happstack/State/Control.hs +++ b/src/Happstack/State/Control.hs @@ -2,20 +2,19 @@ module Happstack.State.Control ( startSystemState - , startSystemStateMultimaster + , 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 Control.Monad -import Data.List import Data.Char -import Data.Maybe import System.Environment import System.IO import System.Exit @@ -23,6 +22,8 @@ import Control.Monad.Trans import Control.Concurrent +import Numeric (showHex) + #ifdef UNIX import System.Posix.Signals hiding (Handler) import System.Posix.IO ( stdInput ) @@ -31,30 +32,43 @@ 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 multimaster support. Uses the default Saver. +-- | 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 _txConfig <- parseArgs - saver <- stdSaver + = do saver <- stdSaver runTxSystem saver proxy --- | Starts the MACID system with multimaster support. Uses the default Saver. -startSystemStateMultimaster :: (Methods a, Component a) => - Proxy a -> IO (MVar TxControl) -startSystemStateMultimaster proxy - = do _txConfig <- parseArgs - saver <- stdSaver - runTxSystem' True 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. +-- | Returns the default Saver. It will save the application state into +-- the _local directory. stdSaver :: IO Saver -stdSaver = do pn <- getProgName +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 @@ -77,12 +91,6 @@ loop 'c' #endif -mkTxConfig :: [Flag] -> TxConfig -mkTxConfig = foldr worker nullTxConfig - where worker (Cluster serv) c = c{txcOperationMode = ClusterMode (fromMaybe "" serv)} - worker (ClusterPort port) c = c{txcClusterPort = port} - worker _ c = c - data NullLogger instance SLH.LogHandler NullLogger where setLevel = error "Don't do this! This logger should not be used!" @@ -104,7 +112,6 @@ worker (LogLevel pri) = do updateGlobalLogger "Happstack" (setLevel pri) rlogger <- getLogger "Happstack" logM "" WARNING ("Set logging priority to " ++ show (getLevel rlogger)) - worker _ = return () -- order should not matter, though it does now. -- we should ALSO allow multiple loggers at the same time! --log-target=stdout --log-target=syslog @@ -113,17 +120,11 @@ "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" - -- FIXME: use a better flag name - ,Option "" ["cluster-mode"] (OptArg (Cluster) "servers") - "Start in multimaster mode. Will join cluster if optional arg is given." - ,Option "" ["cluster-port"] (ReqArg (ClusterPort . read) "port") - "Multimaster server will listen on this port." ] data Target = File FilePath | StdOut | SysLog deriving (Read,Show,Eq,Ord) -data Flag = LogLevel Priority | LogTarget Target - | Cluster (Maybe String) | ClusterPort Int deriving Show +data Flag = LogLevel Priority | LogTarget Target deriving Show readTarget :: String -> Target readTarget arg = case map toLower arg of @@ -137,8 +138,8 @@ worker (ReqArg _ f) = ReqArg (const ()) f worker (OptArg _ f) = OptArg (const ()) f -parseArgs :: IO TxConfig -parseArgs = do +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! @@ -147,8 +148,7 @@ putStrLn ("Usage "++usageInfo pn castOptions) exitWith (ExitFailure 1) case getOpt' Permute options args of - (flags,_fs,_args',[]) -> do setLoggingSettings flags - -- FIXME: replace system args with fs++args' - return (mkTxConfig flags) + (flags,fs,args',[]) -> do setLoggingSettings flags + withArgs (fs ++ args') action (_,_,_,es) -> err "errors" es diff --git a/src/Happstack/State/Monad.hs b/src/Happstack/State/Monad.hs --- a/src/Happstack/State/Monad.hs +++ b/src/Happstack/State/Monad.hs @@ -9,7 +9,6 @@ import Control.Monad.State import Control.Monad.Reader -import Control.Monad instance (Monad m) => Monad (Ev m) where return x = Ev $ \_ -> return x @@ -36,14 +35,16 @@ setUpdateType :: Proxy t -> Update t () setUpdateType _ = return () -proxyUpdate :: Ev (StateT t STM) b -> Proxy t -> Ev (StateT t STM) b +-- | 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 () -proxyQuery :: Ev (ReaderT t STM) b -> Proxy t -> Ev (ReaderT t STM) b +-- | 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'. @@ -71,11 +72,26 @@ liftSTM :: STM a -> AnyEv a liftSTM = unsafeSTMToEv +{- +In stm >= 2.2.0.1 catchSTM always has the type: + +catchSTM :: Exception e => STM a -> (e -> STM a) -> STM a + +In earlier versions of stm the type of catchSTM depends on what is exported by GHC.Conc.catchSTM from base. +-} class CatchEv m where -#if __GLASGOW_HASKELL__ < 610 - catchEv :: Ev m a -> (Exception -> a) -> Ev m a +#if (MIN_VERSION_stm(2,2,0)) + catchEv :: (Exception e) => Ev m a -> (e -> a) -> Ev m a #else +#if (MIN_VERSION_base(4,3,0)) + catchEv :: (Exception e) => Ev m a -> (e -> a) -> Ev m a +#else +#if (MIN_VERSION_base(4,0,0)) catchEv :: Ev m a -> (SomeException -> a) -> Ev m a +#else + catchEv :: Ev m a -> (Exception -> a) -> Ev m a +#endif +#endif #endif instance CatchEv (ReaderT st STM) where catchEv (Ev cmd) fun = Ev $ \s -> ReaderT $ \r -> runReaderT (cmd s) r `catchSTM` (\a -> return (fun a)) diff --git a/src/Happstack/State/NetworkChan.hs b/src/Happstack/State/NetworkChan.hs new file mode 100644 --- /dev/null +++ b/src/Happstack/State/NetworkChan.hs @@ -0,0 +1,64 @@ +module 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) +-} + diff --git a/src/Happstack/State/Saver.hs b/src/Happstack/State/Saver.hs --- a/src/Happstack/State/Saver.hs +++ b/src/Happstack/State/Saver.hs @@ -1,7 +1,12 @@ module Happstack.State.Saver ( module Happstack.State.Saver.Types + , PrefixLock , Saver(..) - , createReader, createWriter ) where + , createReader + , createWriter + , obtainLock + , releaseLock + ) where import Control.Concurrent import Happstack.State.Saver.Impl.File @@ -12,10 +17,11 @@ 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. - -- Creates the prefix directory. | 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 @@ -26,6 +32,8 @@ , 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 @@ -36,4 +44,13 @@ , 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 () diff --git a/src/Happstack/State/Saver/Impl/File.hs b/src/Happstack/State/Saver/Impl/File.hs --- a/src/Happstack/State/Saver/Impl/File.hs +++ b/src/Happstack/State/Saver/Impl/File.hs @@ -1,6 +1,10 @@ {-# LANGUAGE CPP #-} module Happstack.State.Saver.Impl.File - ( fileReader, fileWriter + ( PrefixLock + , fileReader + , fileWriter + , obtainPrefixLock + , releasePrefixLock ) where import Happstack.State.Saver.Types @@ -8,22 +12,43 @@ import Control.Concurrent import Control.Exception.Extensible as E -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.ByteString.Char8 as B -import System.Directory ( createDirectoryIfMissing, renameFile, doesFileExist ) +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" @@ -35,7 +60,7 @@ = do let file = prefix formatFilePath cutoff key tryE $ createDirectoryIfMissing True prefix return $ ReaderStream - { readerClose = do return () + { readerClose = return () , readerGet = do logMF NOTICE "fileReader: readerGet" allFiles <- getAllFiles prefix key cutoff allData <- mapM B.readFile allFiles @@ -58,8 +83,7 @@ let getFileName = do cutoff <- readMVar cutoffVar return $ prefix formatFilePath cutoff key file <- getFileName - logMF NOTICE ("fileWrter: "++key++" @ "++prefix) - tryE $ createDirectoryIfMissing True prefix + logMF NOTICE ("fileWriter: "++key++" @ "++prefix) hmv <- newMVar =<< openBinaryFile file WriteMode return $ WriterStream { writerClose = withMVar hmv hClose @@ -96,3 +120,121 @@ 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 diff --git a/src/Happstack/State/Saver/Types.hs b/src/Happstack/State/Saver/Types.hs --- a/src/Happstack/State/Saver/Types.hs +++ b/src/Happstack/State/Saver/Types.hs @@ -14,3 +14,4 @@ , writerAtomicReplace :: a -> IO () , writerCut :: IO Int } + diff --git a/src/Happstack/State/Spread.hs b/src/Happstack/State/Spread.hs deleted file mode 100644 --- a/src/Happstack/State/Spread.hs +++ /dev/null @@ -1,173 +0,0 @@ -{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} -module Happstack.State.Spread - ( connectToCluster - , changeEventMapping - ) where - -import Happstack.State.Transaction -import Happstack.Data.Serialize -import Happstack.Data.SerializeTH - -import qualified Data.ByteString.Char8 as B -import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.Map as Map - -import Data.Typeable -import Spread.Client -import qualified Control.Concurrent.Chan.Closeable as Closeable - -import System.Log.Logger -import Control.Monad hiding (join) -import Control.Concurrent -import System.Random - -logSP :: Priority -> String -> IO () -logSP = logM "Happstack.State.Spread" - - -data Cluster = Cluster - { clusterChan :: Closeable.Chan Closeable.R Message - , clusterConnection :: Connection - } - -type EventId = Int - -data ClusterMsg - = RequestState - | NewState B.ByteString -- A piece of state (map of all components) - | StateTransferred -- The entire state has been transmitted. - | ForeignEvent EventId Object - | EventResponse EventId Object - deriving (Typeable) -instance Version ClusterMsg -- version 0 -$(deriveSerialize ''ClusterMsg) - -{- | Connects the Happstack process to the local running spread daemon. - The spread daemon must already be running. --} - -connectToCluster :: IO Cluster -connectToCluster - = do logSP NOTICE "Connecting to spread daemon on localhost" - uniq <- randomRIO (0,30000) -- FIXME: this is a hack to get unique names. - let name = mkPrivateName (B.pack $ "node" ++ show (uniq::Int)) - (chan, conn) <- connect defaultConf{desiredName = name} - startReceive conn - join receiverGroup conn - return $ Cluster chan conn - -receiverGroup :: Group -receiverGroup = let Just g = makeGroup "receiver" - in g - -{- | This function modifies any event handlers in the given EventMap - to make them route the update information to the rest of the cluster - --} - -changeEventMapping :: MVar TxControl -> EventMap -> Cluster -> IO EventMap -changeEventMapping ctlVar localEventMap cluster - = do logSP NOTICE "Create new event mapper" - mems <- getClusterMembers cluster - responseIndex <- newMVar Map.empty - ready <- newEmptyMVar - eventQueue <- newChan - stateVar <- newMVar L.empty - eidStore <- newMVar 0 -- eid's are locally unique. - let newEID = modifyMVar eidStore (\store -> return (store+1,store+1)) - pushStateBlock st = modifyMVar_ stateVar (\acc -> return $ acc `L.append` L.fromChunks [st]) - insertEID eid = do mv <- newEmptyMVar - modifyMVar_ responseIndex $ \idx -> return $ Map.insert eid mv idx - return $ takeMVar mv - returnResponse eid object = modifyMVar_ responseIndex $ \idx -> - case Map.lookup eid idx of - Nothing -> return idx -- We're already received the result from another node. - Just mv -> do putMVar mv object -- Notify the caller about the new response. - return $ Map.delete eid idx - listener = forever $ - do mbMsg <- Closeable.readChan (clusterChan cluster) - case mbMsg of - Nothing -> error "Disconnected from the spread daemon." - Just (Regular msg) -> - case fst (deserialize (L.fromChunks [inData msg])) of - RequestState -> sendState ctlVar (inSender msg) cluster - ForeignEvent eid object -> writeChan eventQueue (inSender msg, eid, object) - NewState st -> pushStateBlock st - -- FIXME: check that stateVar is non-empty? - StateTransferred -> do restoreState =<< takeMVar stateVar - putMVar ready () - EventResponse eid object-> returnResponse eid object - Just _ -> return () - responder = forever $ - do (sender, eid, object) <- readChan eventQueue - response <- runObjectEventFunc object localEventMap - sendClusterMsg [sender] (EventResponse eid response) cluster - forkIO listener - forkIO responder - case mems of - [] -> putMVar ready () -- The cluster is empty, use state from disk. - (x:_) -> do logSP NOTICE $ "Requesting state from: " ++ show x - sendClusterMsg [x] RequestState cluster - logSP NOTICE "Waiting for ready signal" - takeMVar ready - logSP NOTICE "Ready signal received" - let newEventMap = flip Map.map localEventMap $ \handler -> - case handler of - UpdateHandler runCold _ parse - -> let runHot ev = do eid <- newEID - logSP NOTICE $ "New eid: " ++ show eid - wait <- insertEID eid - sendClusterMsg [receiverGroup] (ForeignEvent eid (mkObject ev)) cluster - response <- wait - logSP NOTICE $ "Received response for: " ++ show eid - return $ parseObject response - in UpdateHandler runCold runHot parse - QueryHandler{} -> handler - return newEventMap - -sendState :: MVar TxControl -> Group -> Cluster -> IO () -sendState ctlVar sender cluster - = withMVar ctlVar $ \ctl -> - do logSP NOTICE $ "Sending state to: " ++ show sender - allStates <- mapM getState (ctlAllComponents ctl) - let chunks = L.toChunks $ serialize $ zip (ctlAllComponents ctl) allStates - forM_ chunks $ \chunk -> - do sendClusterMsg [sender] (NewState chunk) cluster - sendClusterMsg [sender] StateTransferred cluster - logSP NOTICE $ "The state has been transmitted." - -restoreState :: L.ByteString -> IO () -restoreState stateObject - = do logSP NOTICE $ "Loading components from network." - forM_ state $ \(stateType, stateData) -> - do setNewState stateType stateData - logSP NOTICE $ "All components successfully loaded" - where state = fst (deserialize stateObject) - -sendClusterMsg :: [Group] -> ClusterMsg -> Cluster -> IO () -sendClusterMsg to msg cluster - = send outMsg (clusterConnection cluster) - where outMsg = Outgoing { outOrdering = Safe - , outDiscard = False - , outData = B.concat (L.toChunks (serialize msg)) - , outGroups = to - , outMsgType = 0 } - --- Cluster members not including self. -getClusterMembers :: Cluster -> IO [PrivateGroup] -getClusterMembers cluster - = do mbMsg <- Closeable.readChan (clusterChan cluster) - case mbMsg of - Just (Membership membership) - -> case membership of - Reg{members=m} -> return $ filter (/= privateGroup (clusterConnection cluster)) m - Transient{} -> error $ "Received a Transient message on connect." - SelfLeave{} -> error $ "Received a SelfLeave message on connect." - Just msg -> error $ "Expected membership message from cluster. Received a " ++ showMsgType msg ++ " message." - Nothing -> error "Cluster channel unexpectedly closed." - -showMsgType :: Message -> String -showMsgType (Regular _) = "regular" -showMsgType (Membership _) = "membership" -showMsgType (Rejected _) = "rejected" - diff --git a/src/Happstack/State/Transaction.hs b/src/Happstack/State/Transaction.hs --- a/src/Happstack/State/Transaction.hs +++ b/src/Happstack/State/Transaction.hs @@ -22,7 +22,6 @@ import Happstack.Data.Serialize import Happstack.Data.SerializeTH import Happstack.State.Types -import Happstack.Util.Common (Seconds) import Data.Dynamic import GHC.Base @@ -40,9 +39,13 @@ getTime = sel (fromIntegral . txTime . evContext) getEventClockTime :: AnyEv ClockTime -getEventClockTime = do milliSeconds <- sel (txTime . evContext) - return $ TOD (fromIntegral milliSeconds) 0 +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) @@ -87,7 +90,7 @@ data EventHandler where UpdateHandler :: UpdateEvent ev res => - (TxContext -> ev -> IO ()) -> + (TxContext -> ev -> IO res) -> (ev -> IO res) -> (Object -> ev) -> EventHandler @@ -121,7 +124,7 @@ EmitInternal eventMap -> emitFunc eventMap eventType ev emitEvent :: (Serialize ev, Typeable res) => ev -> IO res -emitEvent ev = emitEvent' (show (typeOf ev)) ev +emitEvent ev = emitEvent' (showQualifiedTypeRep (typeOf ev)) ev setNewEventMap :: EventMap -> IO () setNewEventMap eventMap @@ -166,10 +169,12 @@ 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' cxt ev + = let updateCold' ev getCxt = do mv <- newEmptyMVar - let handler = do lastCxt <- readTVar (txLastTxContext tx) + 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 $ @@ -181,11 +186,12 @@ case me of Left e -> throwIO e Right e -> return e - updateCold cxt ev = do updateCold' cxt ev; return () + updateCold cxt ev = do updateCold' ev $ return cxt updateHot ev - = do cxt <- atomically . addTxId tx =<< newTxContext - updateCold' cxt ev + = do cxt <- newTxContext + updateCold' ev $ addTxId tx cxt in UpdateHandler updateCold updateHot parseObject + eventHandler tx (Query fn) = let queryEmitter ev = do mv <- newEmptyMVar @@ -207,7 +213,7 @@ ] where t :: TxRun st -> st t _ = undefined - stateType = show (typeOf (t tx)) + stateType = showQualifiedTypeRep (typeOf (t tx)) getStateHandler tx' = let fn :: GetCheckpointState -> IO L.ByteString fn ev = do mv <- newEmptyMVar @@ -257,6 +263,10 @@ 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 @@ -342,19 +352,19 @@ -> do res <- runHot (parse obj) return $ mkObject res -runColdEvent :: TxContext -> Object -> IO () +runColdEvent :: TxContext -> Object -> IO Object runColdEvent cxt obj = do EmitInternal eventMap <- readIORef emitRef runColdEventFunc cxt obj eventMap -runColdEventFunc :: TxContext -> Object -> EventMap -> IO () +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 runCold cxt (parse obj) - return () + -> do res <- runCold cxt (parse obj) + return $ mkObject res lookupEventHandler :: TypeString -> EventMap -> IO EventHandler lookupEventHandler eventType eventMap @@ -364,7 +374,7 @@ eventTString :: Serialize ev => ev -> TypeString -eventTString ev = show (typeOf ev) +eventTString ev = showQualifiedTypeRep (typeOf ev) @@ -423,20 +433,14 @@ globalRandomGen = unsafePerformIO (newMVar =<< getStdGen) -data TxConfig = TxConfig - { txcCheckpointSeconds :: Seconds, -- ^ Perform checkpoint at least every N seconds. - txcOperationMode :: OperationMode, - txcClusterSize :: Int, -- ^ Number of active nodes in the cluster (not counting this node). - txcClusterPort :: Int, -- - txcCommitFrequency :: Int -- ^ Commits per second. Only applies to cluster mode. - } - 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) @@ -447,18 +451,7 @@ do (context, obj) <- safeGet return $ EventLogEntry context obj -data OperationMode - = SingleMode - | ClusterMode String -nullTxConfig :: TxConfig -nullTxConfig = TxConfig { txcCheckpointSeconds = 60*60*24, - txcOperationMode = SingleMode, - txcClusterSize = 0, - txcClusterPort = 8500, - txcCommitFrequency = 50 - } - runTxLoop :: MVar (WriterStream EventLogEntry) -> ProcessQueue st -> st -> IO () runTxLoop eventSaverVar queue st0 = let loop st = do @@ -492,6 +485,10 @@ 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 () diff --git a/src/Happstack/State/TxControl.hs b/src/Happstack/State/TxControl.hs --- a/src/Happstack/State/TxControl.hs +++ b/src/Happstack/State/TxControl.hs @@ -1,54 +1,117 @@ +{-# LANGUAGE CPP #-} module Happstack.State.TxControl ( runTxSystem - , runTxSystem' + , runTxSystemAmazon , shutdownSystem + , createCheckpoint ) where import System.Log.Logger -import System.IO import Control.Monad import Control.Exception import Control.Concurrent -import Happstack.State.Checkpoint +import qualified Happstack.State.Checkpoint as Checkpoint import Happstack.State.Saver import Happstack.State.Transaction -import Happstack.State.Spread + +#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 = runTxSystem' False - --- | Run the MACID system with multimaster support turned on if the first --- argument is True. -runTxSystem' :: (Methods st, Component st) => Bool -> Saver -> Proxy st -> IO (MVar TxControl) -runTxSystem' withMultimaster saver stateProxy = +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 <- restoreState ctl - when (withMultimaster) - $ do logMM NOTICE "Multimaster mode" - cluster <- connectToCluster - eventMap <- changeEventMapping ctl localEventMap cluster - setNewEventMap eventMap + 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} + 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 @@ -59,3 +122,4 @@ mapM_ (takeMVar . snd) children -- FIXME: Use a timeout. logMM NOTICE "Shutdown complete" closeTxControl ctl + diff --git a/src/Happstack/State/Types.hs b/src/Happstack/State/Types.hs --- a/src/Happstack/State/Types.hs +++ b/src/Happstack/State/Types.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances, TemplateHaskell, ExistentialQuantification, RankNTypes, FlexibleInstances, DeriveDataTypeable, - ScopedTypeVariables, PatternSignatures + ScopedTypeVariables #-} @@ -15,7 +15,6 @@ import Control.Monad.State import Control.Monad.Reader -import Control.Monad.Trans import Data.Generics -- Monad things @@ -29,6 +28,8 @@ instance Typeable StdGen where typeOf _ = mkTyConApp (mkTyCon "System.Random.StdGen") [] +#if (MIN_VERSION_random(1,0,1)) +#else instance Random Word64 where randomR = integralRandomR random = randomR (minBound,maxBound) @@ -41,7 +42,7 @@ integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer, fromIntegral b :: Integer) g of (x,g') -> (fromIntegral x, g') - +#endif data TxContext = TxContext { txId :: TxId, diff --git a/src/Happstack/State/Util.hs b/src/Happstack/State/Util.hs --- a/src/Happstack/State/Util.hs +++ b/src/Happstack/State/Util.hs @@ -7,7 +7,6 @@ ) where import Control.Concurrent.STM -import Control.Monad.State import System.Random import Happstack.State.Monad @@ -41,8 +40,10 @@ -- FIXME: Throw a decent error message if the input isn't a record. --- | Infer updating functions for a record @a_foo :: component -> record -> record@ and --- @withFoo = localState foo a_foo@. +-- | 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 diff --git a/tests/Happstack/State/Tests/CheckpointProperties.hs b/tests/Happstack/State/Tests/CheckpointProperties.hs --- a/tests/Happstack/State/Tests/CheckpointProperties.hs +++ b/tests/Happstack/State/Tests/CheckpointProperties.hs @@ -2,7 +2,6 @@ module Happstack.State.Tests.CheckpointProperties ( testCongestedCheckpoint , congestedCheckpoint - , checkCheckpointProperties , checkpointProperties , runRestoreCongestionKnownFailures ) where @@ -22,7 +21,6 @@ import Text.Printf import Test.QuickCheck -import Test.QuickCheck.Batch import Test.HUnit (Test(..),(~:), assertBool, assertFailure) -------------------------------------------------------------- @@ -179,7 +177,7 @@ forkIO $ createCheckpoint ctl `finally` putMVar mv () takeMVar mv replicateM_ (length values) (waitQSem sem) - +{- checkCheckpointProperties :: IO () checkCheckpointProperties = tryTests ("runRestore") options [run (prop_runRestoreId saver) @@ -187,20 +185,20 @@ ,run (prop_runRestoreMultipleCheckpoint saver) ,run (prop_runRestoreAsync saver) ,run (prop_runRestoreCongestion saver)] - where options = defOpt{length_of_tests=5} + where args = stdArgs {maxSize=5} saver = withQueueSaver withMemorySaver - +-} checkpointProperties :: Test checkpointProperties = "checkpointProperties" ~: - [ "prop_runRestoreId" ~: qccheck config (prop_runRestoreId saver) - , "prop_runRestoreCheckpoint" ~: qccheck config (prop_runRestoreCheckpoint saver) - , "prop_runRestoreMultipleCheckpoint" ~: qccheck config (prop_runRestoreMultipleCheckpoint saver) - , "prop_runRestoreAsync" ~: qccheck config (prop_runRestoreAsync saver) - , "prop_runRestoreCongestion" ~: qccheck config (prop_runRestoreCongestion saver) + [ "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 - config = defaultConfig { configMaxTest = 100 } + args = stdArgs { maxSize = 100 } saver = withQueueSaver withMemorySaver diff --git a/tests/Happstack/State/Tests/Helpers.hs b/tests/Happstack/State/Tests/Helpers.hs --- a/tests/Happstack/State/Tests/Helpers.hs +++ b/tests/Happstack/State/Tests/Helpers.hs @@ -12,23 +12,16 @@ import Control.Exception import Control.Concurrent -import Test.QuickCheck -import Test.QuickCheck.Batch +import Test.QuickCheck (Arbitrary(arbitrary), choose) import Text.Printf -instance Arbitrary Char where - arbitrary = choose ('a','z') - coarbitrary = undefined - instance (Arbitrary a, Num a) => Arbitrary (Abs a) where arbitrary = liftM (Abs . abs) arbitrary - coarbitrary = undefined instance (Arbitrary a) => Arbitrary (NonEmpty a) where arbitrary = do x <- arbitrary xs <- arbitrary return $ NonEmpty (x:xs) - coarbitrary = undefined data Abs a = Abs a instance (Show a) => Show (Abs a) where @@ -88,7 +81,7 @@ , ("File", withFileSaver) , ("Queue File", \action -> withFileSaver (action . Queue)) ] - +{- tryTests :: String -> TestOptions -> [TestOptions -> IO TestResult] -> IO () tryTests name opt tests = do printf "%25s : " name @@ -106,3 +99,4 @@ putStrLn (" ** " ++ show exp) exitWith (ExitFailure 1) putChar '\n' +-} diff --git a/tests/Happstack/State/Tests/SaverProperties.hs b/tests/Happstack/State/Tests/SaverProperties.hs --- a/tests/Happstack/State/Tests/SaverProperties.hs +++ b/tests/Happstack/State/Tests/SaverProperties.hs @@ -1,44 +1,43 @@ module Happstack.State.Tests.SaverProperties - ( checkSaverProperties - , 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, qcrun) - +import Happstack.Util.Testing (qctest, qccheck) import System.Directory import System.Random import System.FilePath import System.IO.Unsafe -import Control.Monad -import Control.Exception -import Control.Concurrent -import Data.List -import Test.QuickCheck -import Test.QuickCheck.Batch -import Test.HUnit (Test(TestCase),(~:), assertFailure) +import Test.QuickCheck (Args(maxSize), Property, (==>), stdArgs) +import Test.HUnit (Test(TestCase),(~:)) -------------------------------------------------------------- -- Tests -------------------------------------------------------------- -- read (write values) == values -prop_getSetId withSaver key cutoff values - = not (null key) ==> - cutoff > 0 ==> +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 cutoff + do writer <- createWriter saver key (abs cutoff) forM_ values $ \value -> writerAdd writer (value::Int) $ return () writerClose writer - reader <- createReader saver key cutoff + 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 +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 () @@ -48,8 +47,10 @@ 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 +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 () @@ -60,8 +61,10 @@ reader <- createReader saver key newCut (out,_) <- readerGet reader return $ b `isSuffixOf` out + where + key = "key" -prop_atomic withSaver (NonEmpty key) (Abs cutoff) value +prop_atomic withSaver {- (NonEmpty key) -} (Abs cutoff) value = ioProperty $ withSaver $ \saver -> do writer <- createWriter saver key cutoff writerAtomicReplace writer (value::Int) @@ -71,24 +74,26 @@ out <- readerGetUncut reader readerClose reader return $ out == [value] - + where + key = "key" +{- checkSaverProperties :: IO () checkSaverProperties = forEachSaver_ $ \name withSaver -> - tryTests (name ++ " saver") options [run (prop_getSetId withSaver) + tryTests (name ++ " saver") args [run (prop_getSetId withSaver) ,run (prop_seqReadWrite withSaver) ,run (prop_cutDrop withSaver) ,run (prop_atomic withSaver)] - where options = defOpt{length_of_tests=5} - + where args = stdArgs{maxSize=5} +-} saverProperties :: Test saverProperties = "saverProperties" ~: ((forEachSaver $ \name withSaver -> name ~: - [ "prop_getSetId" ~: qcrun (prop_getSetId withSaver) options - , "prop_seqReadWrite" ~: qcrun (prop_seqReadWrite withSaver) options - , "prop_cutDrop" ~: qcrun (prop_cutDrop withSaver) options - , "prop_atomic" ~: qcrun (prop_atomic withSaver) options + [ "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 options = defOpt{length_of_tests=5} + where args = stdArgs{maxSize=5}