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: 0.3.1 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,9 +8,14 @@ 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/publicrepos/happstack + flag base4 Flag tests @@ -54,8 +59,8 @@ filepath, hslogger >= 1.0.2, hspread >= 0.3, - happstack-util >= 0.2.1 && < 0.3, - happstack-data >= 0.2.1 && < 0.3, + happstack-util >= 0.3.1 && < 0.4, + happstack-data >= 0.3.1 && < 0.4, mtl, old-time, random, 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 @@ -44,24 +44,33 @@ instance Version State $(deriveSerialize ''State) --- | Starts a new 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. + = 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 = [] } + , ctlChildren = [] + , ctlPrefixLock = lock } + --- | Saves and ends the TxControl +-- | Saves the state and closes the serialization closeTxControl :: MVar TxControl -> IO () closeTxControl ctlVar = do ctl <- takeMVar ctlVar writerClose =<< takeMVar (ctlEventSaver ctl) + releaseLock (ctlPrefixLock 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/ComponentSystem.hs b/src/Happstack/State/ComponentSystem.hs --- a/src/Happstack/State/ComponentSystem.hs +++ b/src/Happstack/State/ComponentSystem.hs @@ -37,6 +37,8 @@ -- 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 @@ -92,11 +94,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 @@ -129,5 +139,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/Control.hs b/src/Happstack/State/Control.hs --- a/src/Happstack/State/Control.hs +++ b/src/Happstack/State/Control.hs @@ -35,7 +35,8 @@ 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 multimaster 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 @@ -43,7 +44,8 @@ saver <- stdSaver runTxSystem saver proxy --- | Starts the MACID system with multimaster support. Uses the default Saver. +-- | Starts the MACID system with multimaster support. Uses the default behavior +-- of saving the state into the _local directory. startSystemStateMultimaster :: (Methods a, Component a) => Proxy a -> IO (MVar TxControl) startSystemStateMultimaster proxy @@ -51,7 +53,8 @@ saver <- stdSaver runTxSystem' True saver proxy --- | 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 return $ Queue (FileSaver ("_local/" ++pn++"_state")) 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 @@ -36,14 +36,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'. 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 @@ -10,20 +14,27 @@ 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 System.Directory ( createDirectoryIfMissing, removeFile, renameFile, doesFileExist ) import System.IO +import qualified System.IO.Error as SE import System.Random ( randomIO ) import System.Log.Logger import Text.Printf import Control.Monad import System.FilePath +import Happstack.Util.OpenExclusively (openExclusively) +type PrefixLock = (FilePath, Handle) + tryE :: IO a -> IO (Either SomeException a) tryE = E.try catchE :: IO a -> (SomeException -> IO a) -> IO a catchE = E.catch +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO = E.catch + logMF :: Priority -> String -> IO () logMF = logM "Happstack.State.Saver.Impl.File" @@ -35,7 +46,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 +69,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 +106,25 @@ let p' = path ++ ".atomic-tmp-" ++ show (abs r) L.writeFile p' string renameFile p' path + +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 () + + 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/Transaction.hs b/src/Happstack/State/Transaction.hs --- a/src/Happstack/State/Transaction.hs +++ b/src/Happstack/State/Transaction.hs @@ -40,9 +40,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) @@ -437,6 +441,7 @@ , 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) } data EventLogEntry = EventLogEntry TxContext Object deriving (Typeable, Show) 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 @@ -30,16 +30,17 @@ runTxSystem' withMultimaster 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 + when withMultimaster + $ do logMM NOTICE "Multimaster mode" + cluster <- connectToCluster + eventMap <- changeEventMapping ctl localEventMap cluster + setNewEventMap eventMap enableLogging let ioActions = componentIO stateProxy logMM NOTICE "Forking children." @@ -53,9 +54,11 @@ shutdownSystem :: MVar TxControl -> IO () shutdownSystem ctl = do logMM NOTICE "Shutting down." + saver <- liftM ctlSaver $ readMVar ctl 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 + 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 @@ -41,8 +41,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