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.5.0.4 +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 @@ -14,7 +14,7 @@ source-repository head type: darcs subdir: happstack-state - location: http://patch-tag.com/r/mae/happstack/pullrepo + location: http://patch-tag.com/r/mae/happstack flag base4 @@ -32,10 +32,15 @@ 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: @@ -46,10 +51,6 @@ Other-modules: Happstack.State.Checkpoint Happstack.State.Monad - Happstack.State.Saver.Impl.File - Happstack.State.Saver.Impl.Memory - Happstack.State.Saver.Impl.Queue - Happstack.State.Saver.Types Happstack.State.Types Happstack.State.Util Happstack.State.TxControl @@ -61,12 +62,12 @@ extensible-exceptions, filepath, hslogger >= 1.0.2, - happstack-util >= 0.5 && < 0.6, - happstack-data >= 0.5 && < 0.6, + 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) @@ -98,9 +99,10 @@ GADTs, EmptyDataDecls, ExistentialQuantification, RankNTypes, ScopedTypeVariables, PatternGuards, MagicHash, TypeSynonymInstances - if impl(ghc < 6.10) - Extensions: PatternSignatures - 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 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 @@ -33,7 +33,7 @@ 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 @@ -50,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' @@ -130,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) 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 @@ -8,6 +8,7 @@ , waitForTermination ) where +import Control.Applicative ((<$>)) import System.Log.Logger import qualified System.Log.Handler as SLH import System.Log.Handler.Simple @@ -21,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 ) @@ -58,8 +61,14 @@ -- | 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 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 @@ -72,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/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 @@ -21,9 +21,22 @@ 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 @@ -31,8 +44,10 @@ 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" @@ -106,8 +121,105 @@ 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 @@ -125,5 +237,4 @@ tryE $ hClose h tryE $ removeFile fp return () - - +#endif 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 @@ -124,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 @@ -213,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 @@ -374,7 +374,7 @@ eventTString :: Serialize ev => ev -> TypeString -eventTString ev = show (typeOf ev) +eventTString ev = showQualifiedTypeRep (typeOf ev) 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 @@ -28,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) @@ -40,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,