happstack-state 0.2.1 → 0.3.1

raw patch · 11 files changed

+119/−29 lines, 11 filesdep ~happstack-datadep ~happstack-utilPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: happstack-data, happstack-util

API changes (from Hackage documentation)

Files

• happstack-state.cabal +9/−4
• src/Happstack/State/Checkpoint.hs +13/−4
• src/Happstack/State/ComponentSystem.hs +11/−0
• src/Happstack/State/Control.hs +6/−3
• src/Happstack/State/Monad.hs +4/−2
• src/Happstack/State/Saver.hs +19/−2
• src/Happstack/State/Saver/Impl/File.hs +37/−5
• src/Happstack/State/Saver/Types.hs +1/−0
• src/Happstack/State/Transaction.hs +7/−2
• src/Happstack/State/TxControl.hs +8/−5
• src/Happstack/State/Util.hs +4/−2

@@ -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 <happs@googlegroups.com> 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,

@@ -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.

@@ -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

@@ -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"))

@@ -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'.

@@ -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 () 

@@ -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 ()++

@@ -14,3 +14,4 @@     , writerAtomicReplace :: a -> IO ()     , writerCut           :: IO Int     }+

@@ -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)

@@ -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+

@@ -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