HAppS-State (empty) → 0.9.2
raw patch · 17 files changed
+1937/−0 lines, 17 filesdep +HAppS-Datadep +HAppS-Utildep +HaXmlsetup-changed
Dependencies added: HAppS-Data, HAppS-Util, HaXml, base, binary, bytestring, containers, directory, filepath, hslogger, mtl, network, old-locale, old-time, random, stm, template-haskell, unix
Files
- HAppS-State.cabal +38/−0
- Setup.hs +3/−0
- src/HAppS/State.hs +37/−0
- src/HAppS/State/Checkpoint.hs +159/−0
- src/HAppS/State/ComponentSystem.hs +168/−0
- src/HAppS/State/ComponentTH.hs +250/−0
- src/HAppS/State/Control.hs +177/−0
- src/HAppS/State/Monad.hs +141/−0
- src/HAppS/State/Saver.hs +41/−0
- src/HAppS/State/Saver/Impl/File.hs +88/−0
- src/HAppS/State/Saver/Impl/Memory.hs +62/−0
- src/HAppS/State/Saver/Impl/Queue.hs +69/−0
- src/HAppS/State/Saver/Types.hs +16/−0
- src/HAppS/State/Transaction.hs +439/−0
- src/HAppS/State/TxControl.hs +47/−0
- src/HAppS/State/Types.hs +104/−0
- src/HAppS/State/Util.hs +98/−0
+ HAppS-State.cabal view
@@ -0,0 +1,38 @@+Name: HAppS-State+Version: 0.9.2+Synopsis: Event-based distributed state.+Description: Web framework+License: BSD3+Copyright: 2007 HAppS LLC+Author: HAppS LLC+Maintainer: AlexJacobson@HAppS.org+Category: Web, Distributed Computing+Build-Depends: base, HaXml >= 1.13 && < 1.14, mtl, network,+ stm, template-haskell, hslogger >= 1.0.2, HAppS-Util>=0.9.2,+ HAppS-Data>=0.9.2, bytestring, containers, random, old-time,+ old-locale, unix, directory, binary, filepath+Build-Type: Simple+hs-source-dirs: src+Exposed-modules: + HAppS.State+-- HAppS.State.Logger+ HAppS.State.Saver+ HAppS.State.Control+ HAppS.State.Transaction+ HAppS.State.ComponentTH+ HAppS.State.ComponentSystem+Other-modules: + HAppS.State.Checkpoint+ HAppS.State.Monad+ HAppS.State.Saver.Impl.File+ HAppS.State.Saver.Impl.Memory+ HAppS.State.Saver.Impl.Queue+ HAppS.State.Saver.Types+-- HAppS.State.OperationModes+ HAppS.State.Types+ HAppS.State.Util+ HAppS.State.TxControl+Extensions: CPP+cpp-options: -DUNIX+ghc-options: -W -fno-warn-incomplete-patterns+GHC-Prof-Options: -auto-all
+ Setup.hs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMainWithHooks defaultUserHooks
+ src/HAppS/State.hs view
@@ -0,0 +1,37 @@+module HAppS.State+ (-- * ACID monad+ Ev, AnyEv,+ TxControl, query, update, Update, Query,+ -- * Types+ TxId, EpochMilli, TxConfig(..),nullTxConfig,Saver(..),+ -- * Misc utilities+ module HAppS.State.Monad,+ getEventId, getTime, getEventClockTime,+ module HAppS.State.Util,+ -- * Serialization+ module HAppS.Data.Serialize,+ module HAppS.Data.SerializeTH,++ module HAppS.State.Control,+ module HAppS.State.TxControl,+ module HAppS.State.ComponentTH,+ module HAppS.State.ComponentSystem,+ closeTxControl,+ createCheckpoint,+ -- * Unsafe things+ unsafeIOToEv+ ) where+++import HAppS.State.Monad+import HAppS.State.Saver+import HAppS.Data.Serialize+import HAppS.Data.SerializeTH+import HAppS.State.Transaction+import HAppS.State.Checkpoint+import HAppS.State.ComponentSystem+import HAppS.State.Types+import HAppS.State.Util+import HAppS.State.ComponentTH+import HAppS.State.TxControl+import HAppS.State.Control
+ src/HAppS/State/Checkpoint.hs view
@@ -0,0 +1,159 @@+{-# OPTIONS -fglasgow-exts -fth #-}+module HAppS.State.Checkpoint+ ( createTxControl+ , closeTxControl+ , restoreState+ , createCheckpoint+ ) where+++import HAppS.State.Saver+import HAppS.Data.Serialize+import HAppS.Data.SerializeTH+import HAppS.State.Transaction+import HAppS.State.Types+import HAppS.State.ComponentSystem++import Data.Typeable+import Data.Maybe+import Control.Concurrent+import Control.Monad+import Control.Exception as E+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.Map as M+import System.IO+import qualified Data.Map as M++import System.Log.Logger++logMC = logM "HAppS.State.Checkpoint"++{- State on disk:++* ${TXD}/events event files in ascending order+* ${TXD}/checkpoints checkpoint files in ascending order+* ${TXD}/current pointer to last checkpoint++-}++data State = State+ { stateVersion :: Int+ , stateCutoff :: Int+ } deriving (Typeable,Show)++instance Version State+$(deriveSerialize ''State)++createTxControl :: (Methods state, Component state) =>+ Saver -> Proxy state -> IO (MVar TxControl)+createTxControl saver proxy+ = do -- The state hasn't been loaded yet. Ignore events.+ eventSaverVar <- newMVar =<< createWriter NullSaver "events" 0+ newMVar $ TxControl+ { ctlSaver = saver+ , ctlEventSaver = eventSaverVar+ , ctlAllComponents = allStateTypes proxy+ , ctlChildren = [] }++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.+-- | Load state from disk and re-run any needed events to+-- fully restore the state.+restoreState :: MVar TxControl -> IO ()+restoreState ctlVar+ = withMVar ctlVar $ \ctl ->+ do -- Find the last saved cutoff point.+ mbState <- readState ctl+ case mbState of+ Nothing ->+ do writeState ctl (State 0 0)+ -- No events to replay. Switch to real saver.+ swapMVar (ctlEventSaver ctl) =<< createWriter (ctlSaver ctl) "events" 0+ Just state ->+ do let cutoff = stateCutoff state+ -- Load state and replay events.+ loadState ctl cutoff+ offset <- loadEvents ctl cutoff+ -- We use a NullSaver when replaying events. Switch to real saver.+ swapMVar (ctlEventSaver ctl) =<< createWriter (ctlSaver ctl) "events" (cutoff+offset)+ return ()++-- Load state from disk.+loadState :: TxControl -> Int -> IO ()+loadState ctl cutoff+ = do logMC NOTICE $ "Loading components from storage."+ checkpoints <- withReader ctl "checkpoints" cutoff $ loadCheckpoints+ forM_ (ctlAllComponents ctl) $ \stateType+ -> case M.lookup stateType checkpoints of+ Just state -> setNewState stateType state+ Nothing -> return ()+ logMC NOTICE "All components successfully loaded"++-- Read and execute events since last checkpoint.+loadEvents :: TxControl -> Int -> IO Int+loadEvents ctl cutoff+ = do logMC NOTICE "Loading events from storage"+ (events, offset) <- withReader ctl "events" cutoff $ readerGet+ -- Execute events. Events that predate the last checkpoint aren't executed.+ forM_ events $ \(EventLogEntry context object) -> runColdEvent context object+ logMC NOTICE "All events successfully replayed."+ return offset++withReader ctl key cutoff+ = bracket (createReader (ctlSaver ctl) key cutoff)+ (readerClose)++withWriter ctl key cutoff+ = bracket (createWriter (ctlSaver ctl) key cutoff)+ (writerClose)++readState ctl+ = withReader ctl "current" 0 $ \s ->+ liftM listToMaybe $ readerGetUncut s++writeState :: TxControl -> State -> IO ()+writeState ctl state+ = bracket (createWriter (ctlSaver ctl) "current" 0)+ (writerClose)+ (\saver -> writerAtomicReplace saver state)++-- FIXME: Show process while loading state?+-- Might not be useful here since we just load the raw data.+-- The time consuming parsing takes place later on.+-- | Load a map from component types to serialized states.+loadCheckpoints :: ReaderStream (M.Map String L.ByteString) -> IO (M.Map String L.ByteString)+loadCheckpoints saver+ = do checkpointss <- readerGetUncut saver+ case checkpointss of+ [checkpoints] -> return checkpoints+ [] -> return M.empty+ _ -> error "Failed to read checkpoints."++saveCheckpoints :: WriterStream (M.Map String L.ByteString) -> M.Map String L.ByteString -> IO ()+saveCheckpoints saver checkpoints+ = do mv <- newEmptyMVar+ writerAdd saver checkpoints (putMVar mv ())+ takeMVar mv++-- Each checkpoint has a separate event queue. We don't want+-- to clear the queues since that would block event execution.+-- Hence, events may be written to the log after we make the cut+-- and before the state is saved. This means that some events+-- may need to be discarded next time the state is restored.+createCheckpoint :: MVar TxControl -> IO ()+createCheckpoint ctlVar+ = withMVar ctlVar $ \ctl ->+ do logMC NOTICE "Initiating checkpoint."+ newCut <- writerCut =<< readMVar (ctlEventSaver ctl)+ withWriter ctl "checkpoints" newCut $ \saver ->+ do allStates <- mapM getState (ctlAllComponents ctl)+ saveCheckpoints saver (M.fromList $ zip (ctlAllComponents ctl) allStates)+ writeState ctl $ State {stateVersion = 0+ ,stateCutoff = newCut}+ logMC NOTICE "Checkpoint successfully serialized."+
+ src/HAppS/State/ComponentSystem.hs view
@@ -0,0 +1,168 @@+{-# LANGUAGE TypeFamilies, FlexibleContexts, FunctionalDependencies, CPP,+ MultiParamTypeClasses, TypeOperators, DeriveDataTypeable, GADTs #-}+module HAppS.State.ComponentSystem where++import HAppS.Data.Serialize+import HAppS.Data.Proxy+import HAppS.State.Types++import Data.Typeable+import qualified Data.Map as Map+import Data.Map (Map)+import Control.Monad.State.Strict++--------------------------------------------------------------+-- Type level list+-------------------------------------------------------------+#ifndef __HADDOCK__+data End = End+data h :+: t = h :+: t+infixr 6 :+:+#endif+++--------------------------------------------------------------+-- Event classes+--------------------------------------------------------------++-- TH doesn't support type families yet.+class (Serialize ev, Serialize res) => UpdateEvent ev res | ev -> res+class (Serialize ev, Serialize res) => QueryEvent ev res | ev -> res++--------------------------------------------------------------+-- Methods contain the query and update handlers for a component+--------------------------------------------------------------++#ifndef __HADDOCK__+data Method st where+ Update :: (UpdateEvent ev res) => (ev -> Update st res) -> Method st+ Query :: (QueryEvent ev res) => (ev -> Query st res) -> Method st+#endif++instance Show (Method st) where+ show method = "Method: " ++ methodType method++methodType m = case m of+ Update fn -> let ev :: (ev -> Update st res) -> ev+ ev _ = undefined+ in show (typeOf (ev fn))+ Query fn -> let ev :: (ev -> Query st res) -> ev+ ev _ = undefined+ in show (typeOf (ev fn))++class Methods a where+ methods :: Proxy a -> [Method a]++#ifndef __HADDOCK__+data MethodMap where+ MethodMap :: (Component st) => Map String (Method st) -> MethodMap+#endif++instance Show MethodMap where+ show (MethodMap m) = show m++-- State type -> method map+type ComponentTree = Map String MethodMap++#ifndef __HADDOCK__+--------------------------------------------------------------+-- A component consists of a list of subcomponents, some+-- initiation code and some methods.+-- The methods are in a different class so they can be generated+-- separately.+--------------------------------------------------------------+class (SubHandlers (Dependencies a),Serialize a) => Component a where+ type Dependencies a+ initialValue :: a+ onLoad :: Proxy a -> IO ()+ onLoad _ = return ()+#endif++--------------------------------------------------------------+-- Class for walking the component tree.+--------------------------------------------------------------+class SubHandlers a where+ subHandlers :: a -> Collect ()+#ifndef __HADDOCK__+instance SubHandlers End where+ subHandlers ~End = return ()+instance (Methods a, Component a, SubHandlers b) => SubHandlers (a :+: b) where+ subHandlers ~(a :+: b) = do collectHandlers' (proxy a)+ subHandlers b+#endif++data Collection = Collection ComponentTree [IO ()]++addItem key item ioAction+ = do Collection tree ioActions <- get+ case Map.member key tree of+ False -> put $ Collection (Map.insert key item tree) (ioAction:ioActions)+ True -> dup key++type Collect = State Collection++collectHandlers :: (Methods a, Component a) => Proxy a -> (ComponentTree, [IO ()])+collectHandlers proxy+ = case execState (collectHandlers' proxy) (Collection Map.empty []) of+ Collection tree ioActions -> (tree, ioActions)++collectHandlers' :: (Methods a, Component a) => Proxy a -> Collect ()+collectHandlers' proxy+ = let key = show (typeOf (unProxy proxy))+ item = MethodMap $ Map.fromList [ (methodType m, m) | m <- methods proxy ]+ in do addItem key item (onLoad proxy)+ subHandlers (sub proxy)+ where sub :: Component a => Proxy a -> Dependencies a+ sub _ = undefined++dup key = error $ "Duplicate component: " ++ key+++++--------------------------------------------------------------+-- Tests+--------------------------------------------------------------+{-++data Test = Test deriving (Typeable)+instance StartState Test where startState = Test+instance Serialize Test++instance Methods Test where+ methods _ = []++instance Component Test where+ -- Note that subcomponents are separate from the state.+ -- This means we have no requirements to the format of the state.+ type Depdendencies Test = UniqueSupply Int :+:+ UniqueSupply String :+:+ End+ onLoad _ = putStrLn "test init"++++data UniqueSupply a = UniqueSupply Int deriving Typeable+instance StartState (UniqueSupply a) where startState = UniqueSupply 0+instance Typeable a => Serialize (UniqueSupply a)++-- This instance and the associated data types are usually generated by TH.+-- However, it can also be written manually if a show-stopper flaw was+-- encountered in mentioned TH code.+instance (Show a, Ord a) => Methods (UniqueSupply a) where+ methods _ = []++-- Note that 'Show' and 'Ord' does not have to be mentioned here.+instance (Typeable a) => Component (UniqueSupply a) where+ type Depdendencies (UniqueSupply a) = End+ onLoad proxy = putStrLn $ "Unique init: " ++ show (typeOf $ unProxy proxy)+++++mainState v = collectHandlers (proxy v)++runTest = let (tree, io) = mainState Test+ in do sequence_ io+ print tree+-}
+ src/HAppS/State/ComponentTH.hs view
@@ -0,0 +1,250 @@+{-# LANGUAGE FlexibleInstances, TemplateHaskell, CPP, PatternGuards #-}+module HAppS.State.ComponentTH+ ( mkMethods+ ) where++import Data.Char+import Language.Haskell.TH++import HAppS.State.Types+import HAppS.Data.Serialize+import HAppS.State.ComponentSystem++import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Writer+import Data.Maybe++import Data.List++import Data.Generics.Basics++nubCxt tsQ+ = do ts <- cxt tsQ+ return $ nub ts++{-+ Error cases:+ not all state keys are tyvars.+ method not using the keys in either the args or the result.+ Checked: component not being a data declaration with a single constructor.+ Checked: method using a tyvar that isn't a key.+ Checked: method is not a function.+-}+mkMethods :: Name -> [Name] -> Q [Dec]+#ifndef __HADDOCK__+mkMethods componentName componentMethods+ = do keys <- liftM (requireSimpleCon componentName) $ reify componentName+ methodInfos <- getMethodInfos keys componentMethods+ ds1 <- genEventInstances methodInfos+ let handlers = genComponentHandlers methodInfos+ stType = mkType componentName keys+ mkArrowType [x] = x+ mkArrowType (x:xs) = appT (appT arrowT x) (mkArrowType xs)+ context' = mkKeyConstraints keys +++ concatMap (mkMethodConstraints keys) methodInfos+ ds2 <- instanceD (nubCxt context') (appT (conT ''Methods) stType) [ funD 'methods [clause [wildP] (normalB handlers) []] ]+ ds4 <- genMethodStructs [''Typeable] methodInfos+ ds5 <- genSerializeInstances methodInfos+ return (ds1 ++ [ds2] ++ ds4 ++ ds5 )+#endif++mkKeyConstraints :: [Name] -> [TypeQ]+#ifndef __HADDOCK__+mkKeyConstraints keys+ = [ appT (conT ''Typeable) (varT key) | key <- keys ] +++ [ appT (conT ''Serialize) (varT key) | key <- keys ]+#endif++mkMethodConstraints :: [Name] -> MethodInfo -> [TypeQ]+#ifndef __HADDOCK__+mkMethodConstraints keys method+ = map return (substMethodContext method keys)+#endif++substMethodContext method keys+ = let relation = zip (methodKeys method) keys+ worker (VarT old) | Just new <- lookup old relation+ = VarT new+ worker (AppT l r) = AppT (worker l) (worker r)+ worker (ForallT cxt names t) = ForallT cxt names (worker t)+ worker t = t+ in map worker (methodContext method)+++mkType name args = foldl appT (conT name) (map varT args)++genSerializeInstances :: [MethodInfo] -> Q [Dec]+#ifndef __HADDOCK__+genSerializeInstances methods+ = liftM concat $ forM methods $ \method ->+ let constraints = nubCxt $ mkKeyConstraints (methodKeys method) ++ map return (methodContext method)+ upperMethod = upperName (methodName method)+ encode = do args <- replicateM (length (methodArgs method)) (newName "arg")+ lamE [conP upperMethod $ map varP args ] $+ doE $ [ noBindS $ appE (varE 'safePut) (varE arg) | arg <- args] +++ [ noBindS [| return () |] ]+ decode = do args <- replicateM (length (methodArgs method)) (newName "arg")+ doE $ [ bindS (varP arg) (varE 'safeGet) | arg <- args] +++ [ noBindS $ appE (varE 'return) $ foldl appE (conE upperMethod) $ map varE args ]+ in do s <- instanceD constraints+ (appT (conT ''Serialize) (mkType (upperName (methodName method)) (methodKeys method)))+ [funD 'putCopy [clause [] (normalB [| contain . $(encode) |]) []]+ ,funD 'getCopy [clause [] (normalB [| contain $(decode) |]) []]]+ v <- instanceD constraints (appT (conT ''Version) (mkType (upperName (methodName method)) (methodKeys method))) []+ return [s,v]+#endif++{-+ [ Update $ \(SetComponent c) -> setComponent c+ , Query $ \GetComponent -> getComponent ]+-}+genComponentHandlers :: [MethodInfo] -> ExpQ+#ifndef __HADDOCK__+genComponentHandlers methods+ = do let localHandlers = flip map methods $ \method ->+ let upName = upperName (methodName method)+ in do args <- replicateM (length (methodArgs method)) (newName "arg")+ appE (conE (methodEv method)) $+ lamE [conP upName (map varP args)] $ foldl appE (varE (methodName method)) $ map varE args+ handlers = listE localHandlers+ handlers+#endif+++genEventInstances :: [MethodInfo] -> Q [Dec]+genEventInstances methodsInfo+ = mapM genEventInstance methodsInfo++-- instance (cxt keys, Serialize keys) => QueryEvent (GetPageCurrent key) WikiRevision+genEventInstance :: MethodInfo -> Q Dec+#ifndef __HADDOCK__+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))]+ ++ mkKeyConstraints keys+ ++ mkMethodConstraints keys method+ )+ (appT (appT (conT (methodClass method)) eventType) (return (methodResult method)))+ []+#endif++genMethodStructs :: [Name] -> [MethodInfo] -> Q [Dec]+genMethodStructs derv methods+ = liftM concat (mapM (genMethodStruct derv) methods)++-- FIXME: allow class constraints on keys.+genMethodStruct :: [Name] -> MethodInfo -> Q [Dec]+genMethodStruct derv method+ = do let c = NormalC (upperName (methodName method)) (zip (repeat NotStrict ) (methodArgs method))+ return [ DataD [] (upperName (methodName method)) (methodKeys method) [c] (derv) ]++upperName = mkName . upperFirst . nameBase++upperFirst :: String -> String+upperFirst (x:xs) = toUpper x : xs+upperFirst "" = error "ComponentTH.UpperFirst []"++data MethodInfo = Method { methodName :: Name+ , methodKeys :: [Name]+ , methodContext:: [Type]+ , methodArgs :: [Type]+ , methodClass :: Name+ , methodEv :: Name+ , methodResult :: Type+ }++-- get and validate method information.+getMethodInfos :: [Name] -> [Name] -> Q [MethodInfo]+getMethodInfos sessionKeys names+ = do ms <- mapM getMethodInfo names+ mapM worker ms+ where worker m | length (methodKeys m) /= length sessionKeys+ = error $ "Inconsistent keys: " ++ pprint (methodName m) ++ ": " ++ show (sessionKeys, methodKeys m)+ | otherwise = case compare (sort (methodTyVars m)) (sort (methodKeys m)) of+ EQ -> return m+ GT -> error $ "Method too general: " ++ pprint (methodName m)+ LT -> error $ "Method not general enough: " ++ pprint (methodName m)+ getArgKeys (AppT t1 t2) = getArgKeys t1 ++ getArgKeys t2+ getArgKeys (VarT key) = [key]+ getArgKeys _ = []+ methodTyVars m = nub $ concatMap getArgKeys (methodResult m:methodArgs m)++getMethodInfo :: Name -> Q MethodInfo+getMethodInfo method+ = do methodInfo <- reify method+ case methodInfo of+ VarI _name funcType _decl _fixity -> return (getTypes funcType){methodName = method}+ _ -> error $ "Method is not a function: " ++ nameBase method ++ " is a " ++ showInfo methodInfo+++showInfo (ClassI _) = "class"+showInfo (TyConI _) = "type constructor"+showInfo (PrimTyConI _ _ _) = "primitive type constructor"+showInfo (DataConI _ _ _ _) = "data constructor"+showInfo (VarI _ _ _ _) = "variable"+showInfo (TyVarI _ _) = "type variable"+showInfo x = pprint x+++-- Cases:+-- forall m. MonadState state m => X -> m Y+-- forall key. key -> Update ()+-- forall key m. MonadState state m => key -> m ()+-- X -> Ev (ReaderT state STM) Y+-- X -> Ev (StateT state STM) Y+getTypes :: Type -> MethodInfo+getTypes (ForallT _ cxt t) = getTypes' cxt t+getTypes t = getTypes' [] t++-- FIXME: only allow type variables used by the component.+getTypes' :: Cxt -> Type -> MethodInfo+#ifndef __HADDOCK__+getTypes' cxt t+ = case runWriter (worker t) of+ ((keys,className, typeName, res), args) -> Method { methodName = error "Method name not set", methodKeys = keys+ , methodContext = filter (isRelevant keys) cxt+ , methodArgs = args [], methodClass = className+ , methodEv = typeName, methodResult = res}+ where -- recursive case: A -> B+ worker (AppT (AppT ArrowT t1) t2)+ = do tell (t1:)+ worker t2+ -- end case: Update state res || Query state res+ worker (AppT (AppT (ConT c) state) r)+ | c == ''Update = return (getStateKeys state,''UpdateEvent, 'Update, r)+ | c == ''Query = return (getStateKeys state,''QueryEvent, 'Query, r)+ -- end case: Ev (ReaderT state STM) res || Ev (StateT state STM) res+ worker (AppT (AppT (ConT _ev) (AppT (AppT (ConT m) state) (ConT _stm))) r)+ | m == ''StateT = return (getStateKeys state,''UpdateEvent, 'Update, r)+ | m == ''ReaderT = return (getStateKeys state,''QueryEvent, 'Query, r)+ -- end case: m res (check if m is an instance of MonadState)+ worker (AppT name r)+ | Just state <- isMonadState cxt name = return (getStateKeys state, ''UpdateEvent, 'Update, r)+ | Just state <- isMonadReader cxt name = return (getStateKeys state, ''QueryEvent, 'Query, r)+ -- error case+ worker t = error ("Unexpected method type: " ++ pprint t)++getStateKeys (AppT r r') = getStateKeys r ++ getStateKeys r'+getStateKeys (VarT key) = [key]+getStateKeys (ConT _st) = []+getStateKeys v = error $ "Bad state type: " ++ pprint v ++ " (expected a constant, an application or a type variable)"++isMonadState cxt name = listToMaybe [ state | AppT (AppT (ConT m) state) mName <- cxt, mName == name, m == ''MonadState ]+isMonadReader cxt name = listToMaybe [ state | AppT (AppT (ConT m) state) mName <- cxt, mName == name, m == ''MonadReader ]++isRelevant keys t = isAcceptableContext t && any (`elem` keys) (getStateKeys t)++isAcceptableContext (AppT r r') = isAcceptableContext r && isAcceptableContext r'+isAcceptableContext (ConT con) = con `notElem` [''MonadState, ''MonadReader]+isAcceptableContext _ = True++#endif++requireSimpleCon :: Name -> Info -> [Name]+requireSimpleCon _ (TyConI (DataD _ _ names _ _derv)) = names+requireSimpleCon _ (TyConI (NewtypeD _ _ names _ _derv)) = names+requireSimpleCon _ (TyConI (TySynD _ names _)) = names+requireSimpleCon name _ = error $ "Cannot create component from '"++pprint name++"'. Expected a data structure."
+ src/HAppS/State/Control.hs view
@@ -0,0 +1,177 @@+{-# OPTIONS -cpp -fglasgow-exts #-}+module HAppS.State.Control+ ( startSystemState+ , stdSaver+ , waitForTermination+ ) where++import System.Log.Logger+import qualified System.Log.Handler as SLH+-- import System.Log.Handler (LogHandler) -- why doesn't this work?+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+import System.Console.GetOpt+import Control.Monad.Trans+import Control.Concurrent++#ifdef UNIX+import System.Posix.Signals hiding (Handler)+import System.Posix.IO ( stdInput )+import System.Posix.Terminal ( queryTerminal )+#endif++import HAppS.State.Transaction+import HAppS.State.Saver+import HAppS.State.TxControl+++startSystemState proxy+ = do _txConfig <- parseArgs+ saver <- stdSaver+ runTxSystem saver proxy++stdSaver = do pn <- getProgName+ return $ Queue (FileSaver ("_local/" ++pn++"_state"))++--stdLogger = do pn <- getProgName+-- return $ Queue (FileSaver ("_local/" ++ pn ++ "_error.log"))++-- | Wait for a signal.+-- On unix, a signal is sigINT or sigTERM. On windows, the signal+-- is entering 'e'.+waitForTermination :: IO ()+waitForTermination+ = do+#ifdef UNIX+ istty <- queryTerminal stdInput+ mv <- newEmptyMVar+ installHandler softwareTermination (CatchOnce (putMVar mv ())) Nothing+ case istty of+ True -> do installHandler keyboardSignal (CatchOnce (putMVar mv ())) Nothing+ return ()+ False -> return ()+ takeMVar mv+#else+ let loop 'e' = return () + loop _ = getChar >>= loop+ loop 'c'+#endif++{-++-- | Run a web application with a user specified Saver.+stdMainWithSaver :: SystemState st => Saver -> StdPart st -> IO ()+stdMainWithSaver saver sp+ = stdMainEx sp $ \config _ hs ->+ runWithConf (config { txcSaver = saver }) hs++-- | Run a web application with FileSaver.+stdMain :: (SystemState st) => StdPart st -> IO ()+stdMain sp = stdMainEx sp $ \config fs hs -> do+ pn <- liftIO getProgName+ let fp = if null fs then ("_local/" ++pn++"_state") else head fs+ let conf = config { txcSaver = Queue (FileSaver fp), txcLogger = Queue (FileSaver ("_local/" ++ pn ++ "_error.log")) }+ runWithConf conf hs++simpleMain sp = stdMainEx sp $ \config _fs hs -> do+ pn <- liftIO getProgName+ let conf = config {txcSaver = Queue (FileSaver $ "."++pn++"_state"),txcLogger = Queue (FileSaver $ "."++pn++"_error_log")}+ runWithConf conf hs++-}++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!"+ getLevel = error "Don't do this! This logger should not be used!"+ emit = error "Don't do this! This logger should not be used!"+ close = error "This logger should not be used!"++setLoggingSettings :: [Flag] -> IO ()+setLoggingSettings flags = do updateGlobalLogger "" (setHandlers ([] :: [NullLogger]))+ s <- streamHandler stdout DEBUG+ updateGlobalLogger "HAppS" (setHandlers [s] . setLevel WARNING)+ mapM_ worker flags+ where worker (LogTarget SysLog) = do s <- openlog "HAppS" [PID] DAEMON DEBUG -- This priority seems to be ignored?+ updateGlobalLogger "HAppS" (setHandlers [s])+ worker (LogTarget StdOut) = do s <- streamHandler stdout DEBUG+ updateGlobalLogger "HAppS" (setHandlers [s])+ worker (LogTarget (File path)) = do s <- fileHandler path DEBUG -- This priority seems to be ignored?+ updateGlobalLogger "HAppS" (setHandlers [s])+ worker (LogLevel priority) = do updateGlobalLogger "HAppS" (setLevel priority)+ rlogger <- getLogger "HAppS"+ logM "" WARNING ("Set logging priority to " ++ show (getLevel rlogger))+ worker _ = return ()++{-+runWithConf :: (SystemState st) => TxConfig -> [Handler st] -> IO ()+runWithConf conf hs = do+ st0 <- startState+ tx <- runTxSystem conf st0 (hs++componentHandlers id const)+#ifdef UNIX+ istty <- queryTerminal stdInput+ case istty of+ True -> installHandler keyboardSignal (CatchOnce (txCheckpointAndExit tx)) Nothing+ >> installHandler softwareTermination (CatchOnce (txCheckpointAndExit tx)) Nothing+ False -> installHandler softwareTermination (CatchOnce (txCheckpointAndExit tx)) Nothing+ takeMVar (txTerminationMVar tx) `CE.catch` \_ -> txCheckpointAndExit tx+#else+ let loop 'e' = return () + loop _ = getChar >>= loop+ loop 'c' `CE.finally` txCheckpointAndExit tx+#endif+-}+-- order should not matter, though it does now.+-- we should ALSO allow multiple loggers at the same time! --log-target=stdout --log-target=syslog+options = [Option "" ["log-level"] (ReqArg (LogLevel . read . map toUpper) "level")+ "Log level: DEBUG, INFO, NOTICE, WARNING, ERROR, CRITICAL, ALERT, EMERGENCY. Default: WARNING"+ ,Option "" ["log-target"] (ReqArg (LogTarget . readTarget) "target")+ "Log target: stdout, syslog, or a FilePath such as /home/foo/bar.log . Default: stdout"+ -- 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++readTarget arg = case map toLower arg of+ "stdout" -> StdOut+ "syslog" -> SysLog+ _ -> File arg+castOptions = flip map options $ \(Option c f desc help) -> Option c f (worker desc) help+ where worker (NoArg _) = (NoArg ())+ worker (ReqArg _ f) = ReqArg (const ()) f+ worker (OptArg _ f) = OptArg (const ()) f+parseArgs = do+ args <- liftIO getArgs+ pn <- liftIO getProgName+ let err n ls = -- XXX these next lines should be written to stderr!+ do putStrLn ("Syntax error in command line - "++n)+ putStrLn $ unlines $ map (" "++) ls+ putStrLn ("Usage "++usageInfo pn castOptions)+ exitWith (ExitFailure 1)+ case getOpt' Permute options args of+ (flags,_fs,_args',[]) -> do setLoggingSettings flags+ -- FIXME: replace system args with fs++args'+ return (mkTxConfig flags)+ (_,_,_,es) -> err "errors" es+
+ src/HAppS/State/Monad.hs view
@@ -0,0 +1,141 @@+{-# OPTIONS -fglasgow-exts #-}+module HAppS.State.Monad where++import Control.Exception(Exception)+import Control.Concurrent.STM+import HAppS.State.Types+import HAppS.Data.Proxy++import Control.Monad.State+import Control.Monad.Reader+import Control.Monad++{-+instance (Monad (m STM), MonadTrans m) => Monad (Ev (m STM)) where+ return x = Ev $ return x+ fail x = unsafeIOToEv (logM "HAppS.State.Monad" CRITICAL ("Ev failure: "++x)) >> Ev (fail x)+ ev >>= f = Ev $ unEv ev >>= unEv . f+-}+instance (Monad m) => Monad (Ev m) where+ return x = Ev $ \_ -> return x+ fail x = Ev $ \_ -> fail x+ ev >>= f = Ev $ \env -> unEv ev env >>= \x -> unEv (f x) env++instance MonadState st (Update st) where+ get = Ev $ \_ -> get+ put x = Ev $ \_ -> put x++instance MonadReader st (Query st) where+ ask = Ev $ \_ -> ask+ local l (Ev cmd) = Ev $ \env -> local l (cmd env)++instance MonadReader st (Update st) where+ ask = Ev $ \_ -> get+ local l (Ev cmd) = Ev $ \env -> StateT $ \s ->+ do (r,_s') <- runStateT (cmd env) (l s)+ return (r,s)++instance (Monad m) => Functor (Ev m) where fmap = liftM++-- | Use a proxy to force the type of an update action.+setUpdateType :: Proxy t -> Update t ()+setUpdateType _ = return ()+proxyUpdate f proxy = setUpdateType proxy >> f++-- | Use a proxy to force the type of a query action.+setQueryType :: Proxy t -> Query t ()+setQueryType _ = return ()+proxyQuery f proxy = setQueryType proxy >> f++-- | Currying version of 'setUpdateType'.+asUpdate :: Update t a -> Proxy t -> Update t a+asUpdate upd _ = upd++-- | Currying version of 'setQueryType'.+asQuery :: Query t a -> Proxy t -> Query t a+asQuery query _ = query++-- | Specialized version of 'ask'+askState :: Query st st+askState = ask++-- | Specialized version of 'get'+getState :: Update st st+getState = get++-- | Specialized version of 'put'.+putState :: st -> Update st ()+putState = put+++-- | Lift an STM action into Ev.+liftSTM :: STM a -> AnyEv a+liftSTM = unsafeSTMToEv++class CatchEv m where+ catchEv :: Ev m a -> (Exception -> a) -> Ev m a+instance CatchEv (ReaderT st STM) where+ catchEv (Ev cmd) fun = Ev $ \s -> ReaderT $ \r -> runReaderT (cmd s) r `catchSTM` (\a -> return (fun a))++instance CatchEv (StateT st STM) where+ catchEv (Ev cmd) fun = Ev $ \s -> StateT $ \r -> runStateT (cmd s) r `catchSTM` (\a -> return (fun a,r))++instance MonadPlus m => MonadPlus (Ev m) where+ mzero = Ev $ \_ -> mzero+ mplus (Ev fn1) (Ev fn2) = Ev $ \env -> fn1 env `mplus` fn2 env++{-+-- | Catch errors.+catchEv :: Ev m a -> (Exception -> a) -> Ev m a+catchEv (Ev cmd) fun = Ev $ StateT $ \s -> runStateT cmd s `catchSTM` (\a -> return (fun a, s))+-}+-- | Select a part of the environment.+sel :: (Env -> b) -> AnyEv b+sel f = Ev $ \env -> return (f env)++-- | Run a computation with a local environment.+{-+plocal :: (Env sta a -> Env stb b) -> Ev stb b r -> Ev sta a r+plocal fun (Ev c) = Ev $ StateT $ \s ->+ do (r,s') <- runStateT c (fun s)+ return (r,s)+-}+-- FIXME: should the users see this function?+-- | Run a computation with local state. Changes to state will be visible to outside.+localState :: (outer -> inner) -> (inner -> outer -> outer) -> Ev (StateT inner STM) a -> Ev (StateT outer STM) a+localState ifun ufun (Ev cmd)+ = Ev $ \env -> StateT $ \s ->+ do (r,s') <- runStateT (cmd env) (ifun s)+ return (r, ufun s' s)++-- | Run a computation with local state.+localStateReader :: (outer -> inner) -> Ev (ReaderT inner STM) a -> Ev (ReaderT outer STM) a+localStateReader ifun (Ev cmd)+ = Ev $ \env -> ReaderT $ \s ->+ runReaderT (cmd env) (ifun s)++-- | Execute a Query action in the Update monad.+runQuery :: Query st a -> Update st a+runQuery fn = Ev $ \env -> StateT $ \st ->+ do a <- runReaderT (unEv fn env) st+ return (a,st)++++{-+localState ifun ufun (Ev cmd) = Ev $ do+ old <- readRefSTM (evState env)+ ntv <- newRefSTM $! ifun old+ res <- cmd $ env { evState = ntv }+ new <- readRefSTM ntv+ writeRefSTM (evState env) $! ufun new old+ return res+-}++-- | Run a computation with local event type.+{-+localEvent :: ev -> Ev st ev a -> Ev st oev a+localEvent ev (Ev cmd) = Ev $ StateT $ \s -> do (r, s') <- runStateT cmd s{evEvent = (evEvent s){txEvent = ev}}+ return (r,s'{evEvent = evEvent s})+-}+-- cmd $ env { evEvent = (evEvent env) { txEvent = ev } }
+ src/HAppS/State/Saver.hs view
@@ -0,0 +1,41 @@+module HAppS.State.Saver+ ( module HAppS.State.Saver.Types+ , Saver(..)+ , createReader, createWriter ) where++import Control.Concurrent+import HAppS.State.Saver.Impl.File+import HAppS.State.Saver.Impl.Memory+import HAppS.State.Saver.Impl.Queue+import HAppS.State.Saver.Types+import HAppS.Data.Serialize++data Saver = NullSaver -- ^ A saver that discards all output+ | FileSaver String -- ^ A saver that operates on files. The parameter is the prefix for the files.+ -- Creates the prefix directory.+ | Queue Saver -- ^ Enable queueing.+ | Memory (MVar Store)++createReader :: Serialize a => Saver -> String -> Int -> IO (ReaderStream a)+createReader (FileSaver prefix) key cutoff = fileReader prefix key cutoff+createReader (Memory store) key cutoff = memoryReader store key cutoff+createReader (Queue saver) key cutoff = queueReader =<< createReader saver key cutoff+createReader NullSaver _key _cutoff+ = return $ ReaderStream+ { readerClose = return ()+ , readerGet = fail "NullSaver: readerGet"+ , readerGetUncut = fail "NullSaver: readerGetUncut" }++createWriter :: Serialize a => Saver -> String -> Int -> IO (WriterStream a)+createWriter (FileSaver prefix) key cutoff = fileWriter prefix key cutoff+createWriter (Memory store) key cutoff = memoryWriter store key cutoff+createWriter (Queue saver) key cutoff = queueWriter =<< createWriter saver key cutoff+createWriter NullSaver _key _cutoff+ = return $ WriterStream+ { writerClose = return ()+ , writerAdd = \_ io -> io+ , writerAtomicReplace = fail "NullSaver: writerAtomicReplace"+ , writerCut = fail "NullSaver: writerCut" }+++
+ src/HAppS/State/Saver/Impl/File.hs view
@@ -0,0 +1,88 @@+module HAppS.State.Saver.Impl.File+ ( fileReader, fileWriter+ ) where++import HAppS.State.Saver.Types+import HAppS.Data.Serialize++import Control.Concurrent+import Control.Exception ( try )+import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Char8 as B+import System.Directory ( createDirectoryIfMissing, renameFile, doesFileExist )+import System.IO+import System.Random ( randomIO )+import System.Log.Logger+import Text.Printf+import Control.Monad+import System.FilePath++logMF = logM "HAppS.State.Saver.Impl.File"++formatFilePath :: Int -> String -> FilePath+formatFilePath n str = printf "%s-%010d" str n++fileReader :: Serialize a => FilePath -> String -> Int -> IO (ReaderStream a)+fileReader prefix key cutoff+ = do let file = prefix </> formatFilePath cutoff key+ try $ createDirectoryIfMissing True prefix+ return $ ReaderStream+ { readerClose = do return ()+ , readerGet = do logMF NOTICE "fileReader: readerGet"+ allFiles <- getAllFiles prefix key cutoff+ allData <- mapM B.readFile allFiles+ return $ (parseAll (L.fromChunks allData), length allFiles)+ , readerGetUncut = do logMF NOTICE "fileReader: readerGetUncut"+ allData <- B.readFile file `catch` \_ -> return B.empty+ return $ parseAll (L.fromChunks [allData])+ }+++parseAll :: Serialize a => L.ByteString -> [a]+parseAll = loop+ where loop l | L.null l = []+ loop l = let (a,rest) = deserialize l+ in a:loop rest++fileWriter :: Serialize a => FilePath -> String -> Int -> IO (WriterStream a)+fileWriter prefix key cutoffInit = do+ cutoffVar <- newMVar cutoffInit+ let getFileName = do cutoff <- readMVar cutoffVar+ return $ prefix </> formatFilePath cutoff key+ file <- getFileName+ logMF NOTICE ("fileWrter: "++key++" @ "++prefix)+ try $ createDirectoryIfMissing True prefix+ hmv <- newMVar =<< openBinaryFile file WriteMode+ return $ WriterStream+ { writerClose = withMVar hmv hClose+ , writerAdd = \m f -> do logMF NOTICE "fileWriter: saverAdd"+ withMVar hmv (\h -> L.hPut h (serialize m) >> hFlush h)+ forkIO f+ return ()+ , writerAtomicReplace = \ss -> do h <- takeMVar hmv+ hClose h+ file <- getFileName+ atomicWriteFile file (serialize ss)+ putMVar hmv =<< openBinaryFile file AppendMode+ , writerCut = do h <- takeMVar hmv+ hClose h+ cutoff <- takeMVar cutoffVar+ let file = prefix </> formatFilePath (cutoff+1) key+ putMVar cutoffVar (cutoff+1)+ putMVar hmv =<< openBinaryFile file WriteMode+ return (cutoff+1)+ }++getAllFiles prefix key cutoff+ = loop cutoff+ where loop n = do let file = prefix </> formatFilePath n key+ exist <- doesFileExist file+ if exist then liftM (file:) (loop (n+1))+ else return []++-- | Just to avoid a dependency.+atomicWriteFile path string = do+ r <- randomIO :: IO Int+ let p' = path ++ ".atomic-tmp-" ++ show (abs r)+ L.writeFile p' string+ renameFile p' path
+ src/HAppS/State/Saver/Impl/Memory.hs view
@@ -0,0 +1,62 @@+module HAppS.State.Saver.Impl.Memory where++import HAppS.Data.Serialize+import HAppS.State.Saver.Types++import Control.Concurrent++import qualified Data.ByteString.Lazy.Char8 as L+import Data.Maybe++import qualified Data.Map as M++type Store = M.Map String (M.Map Int L.ByteString)++newMemoryStore :: IO (MVar Store)+newMemoryStore = newMVar M.empty++memoryReader :: Serialize a => MVar Store -> String -> Int -> IO (ReaderStream a)+memoryReader store key cutoff+ = do return $ ReaderStream+ { readerClose = do return ()+ , readerGet = withMVar store $ \storeData ->+ let getAllData ((cut,_):xs) n | n > cut = getAllData xs n+ getAllData ((cut,dat):xs) n | n == cut = dat : getAllData xs (n+1)+ getAllData _ _ = []+ allData = getAllData (maybe [] M.toList $ M.lookup key storeData) cutoff+ in return $ (parseAll (L.concat allData), length allData)+ , readerGetUncut = withMVar store $ \storeData ->+ return $ parseAll $ fromMaybe L.empty $ M.lookup cutoff =<< M.lookup key storeData+ }++memoryWriter :: Serialize a => MVar Store -> String -> Int -> IO (WriterStream a)+memoryWriter store key cutoffInit+ = do cutoffVar <- newMVar cutoffInit+ modifyMVar_ store $ \storeData -> return (addToStore key cutoffInit L.empty storeData)+ return $ WriterStream+ { writerClose = return ()+ , writerAdd = \m f ->+ do cutoff <- readMVar cutoffVar+ modifyMVar_ store $ \storeData -> return $ addToStore key cutoff (serialize m) storeData+ forkIO f+ return ()+ , writerAtomicReplace = \ss -> do cutoff <- readMVar cutoffVar+ modifyMVar_ store $ \storeData -> return $ setStore key cutoff (serialize ss) storeData+ , writerCut = do newCut <- modifyMVar cutoffVar $ \cutoff -> return (cutoff+1, cutoff+1)+ modifyMVar_ store $ \storeData -> return (addToStore key newCut L.empty storeData)+ return newCut+ }++parseAll :: Serialize a => L.ByteString -> [a]+parseAll = loop+ where loop l | L.null l = []+ loop l = let (a,rest) = deserialize l+ in a:loop rest++addToStore key cutoff val store+ = M.unionWith (M.unionWith L.append) store elem+ where elem = M.singleton key $ M.singleton cutoff val++setStore key cutoff val store+ = M.unionWith (\_ _ -> M.singleton cutoff val) store elem+ where elem = M.singleton key $ M.singleton cutoff val
+ src/HAppS/State/Saver/Impl/Queue.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE DeriveDataTypeable #-}+module HAppS.State.Saver.Impl.Queue+ ( queueReader+ , queueWriter+ ) where++import HAppS.State.Saver.Types+import HAppS.Data.Serialize++import Control.Concurrent.STM+import Control.Concurrent+import Control.Monad+import Data.Typeable++import Data.Binary++data Item = Close (IO ())+ | Add Put (IO ())++queueReader :: ReaderStream a -> IO (ReaderStream a)+queueReader stream = return stream++data Encoded = Encoded Put deriving Typeable+instance Version Encoded where mode = Primitive+instance Serialize Encoded where+ putCopy (Encoded out) = contain out+ getCopy = error "decoding from writer queue."++-- | A saver that bunches writes.+queueWriter :: Serialize a => WriterStream Encoded -> IO (WriterStream a)+queueWriter writer = do+ ch <- newCh+ let handler = do+ input <- getChs ch+ let il (Add p f : rest) a0 a1 = il rest (p:a0) (f:a1)+ il something a0 a1 = (reverse a0, sequence_ $ reverse a1, something)+ let (ps,io,rest) = il input [] []+ when (not (null ps)) $ writerAdd writer (Encoded $ sequence_ ps) io+ case rest of+ [] -> handler+ (Close io:_) -> writerClose writer >> io+ _ -> fail "queueSaver: Invalid saver bunch!"++ forkIO handler+ return $ WriterStream+ { writerClose = do+ mv <- newEmptyMVar+ writeCh ch $ Close (writerClose writer >> putMVar mv ())+ takeMVar mv+ , writerAdd = \ps fin -> writeCh ch $ Add (safePut ps) fin+ , writerAtomicReplace = \a -> writerAtomicReplace writer (Encoded $ safePut a)+ , writerCut = writerCut writer+ }+++-- Sample variables/queues+newtype Ch a = Ch (TVar [a])+newCh = fmap Ch $ newTVarIO []+writeCh :: Ch a -> a -> IO ()+writeCh (Ch ch) x = atomically $ do vs <- readTVar ch+ writeTVar ch (x:vs)++getChs :: Ch a -> IO [a]+getChs (Ch ch) = atomically $ do vs <- readTVar ch+ guard (not (null vs))+ writeTVar ch []+ return (reverse vs)++
+ src/HAppS/State/Saver/Types.hs view
@@ -0,0 +1,16 @@+module HAppS.State.Saver.Types where++data ReaderStream a+ = ReaderStream+ { readerClose :: IO ()+ , readerGet :: IO ([a], Int)+ , readerGetUncut :: IO [a]+ }++data WriterStream a+ = WriterStream+ { writerClose :: IO ()+ , writerAdd :: a -> IO () -> IO ()+ , writerAtomicReplace :: a -> IO ()+ , writerCut :: IO Int+ }
+ src/HAppS/State/Transaction.hs view
@@ -0,0 +1,439 @@+{-# OPTIONS -fglasgow-exts -cpp -fth #-}+module HAppS.State.Transaction where++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception(handle,throw,Exception(..),AsyncException(..),throwIO,evaluate)+import Control.Monad.State+import Control.Monad.Reader+import qualified Data.Map as M+import qualified Data.ByteString.Lazy as L+import Data.IORef+import Data.Maybe+import System.IO.Unsafe+import System.Random+import System.Time(getClockTime,ClockTime(TOD))+import System.Log.Logger++import HAppS.State.ComponentSystem+import HAppS.State.Monad+import HAppS.State.Saver+import HAppS.Data.Serialize+import HAppS.Data.SerializeTH+import HAppS.State.Types+import HAppS.Util.Common (Seconds)++import Data.Typeable+import GHC.Base++import qualified Data.Binary as Binary++logMT = logM "HAppS.State.Transaction"++--getTime :: AnyEv EpochTime+getTime :: (Integral epochTime) => AnyEv epochTime+getTime = sel (fromIntegral . txTime . evContext)++getEventClockTime :: AnyEv ClockTime+getEventClockTime = do milliSeconds <- sel (txTime . evContext)+ return $ TOD (fromIntegral milliSeconds) 0++-- getEventId :: AnyEv TxId+getEventId :: (Integral txId) => AnyEv txId+getEventId = sel (fromIntegral . txId . evContext)+++instance Version TxContext -- Default to version 0+$(deriveSerialize ''TxContext)++instance Version StdGen+instance Serialize StdGen where+ getCopy = contain $ liftM read safeGet+ putCopy = contain . safePut . show++{- Durablity:+* Pending queue is TChan (TxContext, ev)+* Get events from the input sources in circular fashion+* Dump events on disk before adding to pending queue+* Checkpoints as follows:+ * check point event arrives from one of the input sources+ * write a new checkpoint file with:+ + list of pending transactions (all non-pending are out of system)+ + next txid+ + save state+ + rotare log files+ * resume transaction processing+++-}+++type TypeString = String++#ifndef __HADDOCK__+data EventHandler where+ UpdateHandler :: UpdateEvent ev res =>+ (Maybe TxContext -> ev -> IO res) ->+ (Object -> ev) ->+ EventHandler+ QueryHandler :: QueryEvent ev res =>+ (ev -> IO res) ->+ (Object -> ev) ->+ EventHandler+#else+data EventHandler = EventHandler+#endif++type EventMap = M.Map TypeString EventHandler+data EmitInternal = EmitInternal EventMap++{-# NOINLINE emitRef #-}+emitRef :: IORef EmitInternal+emitRef = unsafePerformIO $ newIORef (error "HAppS not initiated")++-- Low level function for emitting events. Very unsafe, do not expose.+emitFunc :: (Serialize ev, Typeable res) =>+ EventMap -> TypeString -> ev -> IO res+emitFunc eventMap eventType ev+ = case M.lookup eventType eventMap of+ Nothing -> error $ "Emitted event to unknown component. Ev: " ++ eventType+ Just (UpdateHandler fn _) -> unsafeCoerce# fn Nothing ev+ Just (QueryHandler fn _) -> unsafeCoerce# fn ev++-- Wrapper around the global emitter map. Very unsafe, do not expose.+-- This function is only safe through 'query' and 'update'.+emitEvent' :: (Serialize ev, Typeable res) => TypeString -> ev -> IO res+emitEvent' eventType ev+ = do internal <- readIORef emitRef+ case internal of+ EmitInternal eventMap -> emitFunc eventMap eventType ev++emitEvent :: (Serialize ev, Typeable res) => ev -> IO res+emitEvent ev = emitEvent' (show (typeOf ev)) ev++initEventMap :: (Methods st, Component st) => MVar TxControl -> Proxy st -> IO ()+initEventMap ctlVar componentProxy+ = do eventMap <- createEventMap ctlVar componentProxy+ writeIORef emitRef $ EmitInternal eventMap++{-+ Events for different components can be executed in parallel.+ +-}+-- Casting the event and the result type is safe. The types are kept sane due to the+-- EventUpdate and EventQuery classes.+createEventMap :: (Methods st, Component st) => MVar TxControl -> Proxy st -> IO EventMap+createEventMap ctlVar componentProxy+ = do maps <- forM (M.elems componentTree) $ \(MethodMap m) ->+ do tx <- createNewTxRun+ forkIO $ forever $ atomically $+ do HR ev fn <- readTChan (txEventQueue tx)+ tev <- addTxId tx =<< newTxContext+ writeTChan (txProcessQueue tx) (IHR tev ev fn)+ ctl <- readMVar ctlVar+ runTxLoop (ctlEventSaver ctl) (txProcessQueue tx) initialValue+ return $ M.union (extraEvents tx) (M.map (eventHandler tx) m)+ return $ M.unions maps+ where (componentTree, _ioActions) = collectHandlers componentProxy+ eventHandler tx (Update fn)+ = let updateEmitter mbContext ev+ = let realEv = ev+ in do mv <- newEmptyMVar+ let handler fn =+ case mbContext of+ Nothing -> writeTChan (txEventQueue tx) (HR realEv fn)+ Just cxt -> do lastCxt <- readTVar (txLastTxContext tx)+ writeTChan (txProcessQueue tx) $ IHR cxt realEv $+ if txId lastCxt < txId cxt+ then fn+ else handleUpdate (putMVar mv) $ return $ error "Forced result from dated event."+ atomically $ handler $ handleUpdate (putMVar mv) (fn realEv)+ takeMVar mv+ in UpdateHandler updateEmitter parseObject+ eventHandler tx (Query fn)+ = let queryEmitter ev+ = let realEv = ev+ in do mv <- newEmptyMVar+ quickQuery' tx $ HR realEv $ handleQuery (putMVar mv) (fn realEv)+ takeMVar mv+ in QueryHandler queryEmitter parseObject++instance QueryEvent () L.ByteString+instance UpdateEvent L.ByteString ()++extraEvents :: Serialize st => TxRun st -> EventMap+extraEvents tx+ = M.fromList [ (getStateType stateType, getStateHandler tx)+ , (setNewStateType stateType, setNewStateHandler tx)+ ]+ where t :: TxRun st -> st+ t _ = undefined+ stateType = show (typeOf (t tx))+ getStateHandler tx+ = let fn :: () -> IO L.ByteString+ fn () = do mv <- newEmptyMVar+ quickQuery' tx $ HR () $ \context st ->+ return (Nothing, putMVar mv (serialize (context, st)))+ takeMVar mv+ in QueryHandler fn (error "No parser for GetState event")+ setNewStateHandler tx+ = let fn :: L.ByteString -> IO ()+ fn bs = do ((context, newState), _) <- evaluate $ deserialize bs+ mv <- newEmptyMVar+ quickQuery' tx $ HR () $ \_context _oldState ->+ return (Just newState, putMVar mv ())+ takeMVar mv+ atomically $ writeTVar (txLastTxContext tx) context+ in UpdateHandler (const fn) (error "No parser for SetNewState event")+++allStateTypes :: (Methods a, Component a) => Proxy a -> [TypeString]+allStateTypes proxy = let (componentTree, _ioActions) = collectHandlers proxy+ in M.keys componentTree++componentIO :: (Methods a, Component a) => Proxy a -> [IO ()]+componentIO proxy = let (_componentTree, ioActions) = collectHandlers proxy+ in ioActions++createNewTxRun :: IO (TxRun st)+createNewTxRun =+ atomically $+ do eventQueue <- newTChan+ processQueue <- newTChan+ lastContext <- newTVar (TxContext 0 0 0 (mkStdGen 42))+ return $ TxRun eventQueue processQueue lastContext++setNewStateType str = "SetNewState: " ++ str+getStateType str = "GetState: " ++ str++setNewState :: TypeString -> L.ByteString -> IO ()+setNewState stateType state+ = emitEvent' (setNewStateType stateType) state++getState :: TypeString -> IO L.ByteString+getState stateType+ = emitEvent' (getStateType stateType) ()++data SetNewState st = SetNewState L.ByteString deriving (Typeable)+data GetState st = GetState deriving (Typeable)++instance Version (SetNewState st)+instance Typeable st => Serialize (SetNewState st) where+ putCopy (SetNewState lbs) = contain $ Binary.put lbs+ getCopy = contain $ liftM SetNewState Binary.get+instance Version (GetState st)+instance Typeable st => Serialize (GetState st) where+ putCopy GetState = contain $ return ()+ getCopy = contain $ return GetState++instance Typeable st => UpdateEvent (SetNewState st) ()++instance Typeable st => QueryEvent (GetState st) L.ByteString++++++-- | Schedule an update and wait for it to complete. When this function returns, you're+-- guaranteed the update will be persistent.+update :: (MonadIO m, UpdateEvent ev res) => ev -> m res+update = liftIO . emitEvent++-- | Emit a state query and wait for the result.+query :: (MonadIO m, QueryEvent ev res) => ev -> m res+query = liftIO . emitEvent+++-- Execute a query immediately without giving it a unique timestamp & transaction ID.+quickQuery' :: (Serialize st) => TxRun st -> HR st -> IO ()+quickQuery' txrun (HR ev fun)+ = do now <- getEpochMilli+ atomically $+ do tx <- readTVar (txLastTxContext txrun)+ writeTChan (txProcessQueue txrun) $ IHR tx{txTime=now} ev fun+++type Runner ev res = IO (IO ev, res -> IO ())+type EH i o = i -> IO o++data Event = forall ev. Serialize ev => Event ev++data IHR st = forall ev. (Serialize ev)+ => IHR TxContext+ ev+ (RunHandler st ev)+data HR st = forall ev. (Serialize ev)+ => HR ev+ (RunHandler st ev)+type RunHandler st ev = TxContext -> st -> IO (Maybe st, IO ())+data Res a = Ok a | Error Exception+type EventQueue st = TChan (HR st) -- Queue of local event not yet given a TxContext.+type ProcessQueue st = TChan (IHR st) -- Queue of events to be processed. TxContext'es have been asigned at this point.+data TxRun st = TxRun {txEventQueue :: !(EventQueue st)+ ,txProcessQueue :: !(ProcessQueue st)+ ,txLastTxContext :: !(TVar TxContext)}+++type EvLoaders' st = M.Map String (ProcessQueue st -> L.ByteString -> IO (TxId,L.ByteString))+type EvLoaders = M.Map String (L.ByteString -> IO (TxId,L.ByteString))++setEvLoadersQueue :: ProcessQueue st -> EvLoaders' st -> EvLoaders+setEvLoadersQueue queue = M.map (\fn -> fn queue)+++runColdEvent :: TxContext -> Object -> IO ()+runColdEvent cxt obj+ = do EmitInternal eventMap <- readIORef emitRef+ runColdEventFunc cxt obj eventMap++runColdEventFunc :: TxContext -> Object -> EventMap -> IO ()+runColdEventFunc cxt obj eventMap+ = case M.lookup eventType eventMap of+ Nothing -> error $ "Couldn't find handler for cold event of type: " ++ eventType+ Just (QueryHandler run parse)+ -> do run (parse obj)+ return ()+ Just (UpdateHandler run parse)+ -> do run (Just cxt) (parse obj)+ return ()+ where eventType = objectType obj+++eventTString :: Serialize ev => ev -> TypeString+eventTString ev = show (typeOf ev)+++++handleEvent :: (st -> Env -> Ev m res -> STM intermediate) -> (st -> intermediate -> IO (Maybe st, res))+ -> (res -> IO ()) -> Ev m res -> RunHandler st ev+handleEvent runner stateCheck ofun action tx st+ = handle eh $+ do intermediate <- atomically $ runQuery+ (newState, res) <- stateCheck st intermediate+ return (newState, ofun res)+ where runQuery = do rs <- newTVar (txStdGen tx)+ let env = Env { evContext = tx, evRandoms = rs }+ intermediate <- runner st env action+ return $ intermediate+ eh e = do logMT ERROR ("handleEvent FAIL: "++ show e)+ return (Nothing,ofun (throw e))++handleQuery :: (res -> IO ()) -> Query st res -> RunHandler st ev+handleQuery = handleEvent (\st env (Ev cmd) -> runReaderT (cmd env) st) (\_st res -> return (Nothing, res))++handleUpdate :: (res -> IO ()) -> Update st res -> RunHandler st ev+handleUpdate = handleEvent (\st env (Ev cmd) -> runStateT (cmd env) st) (\st (res,st') -> checkDiff st st' >>= \diff -> return (diff, res))++{- Some updates might not modify the state.+ Doing a pointer-check might be worth it.+ (as a side note, reallyUnsafePtrEquality# is orders of magnitude faster+ than comparing StableNames.)+-}+checkDiff :: a -> a -> IO (Maybe a)+checkDiff _old new+ = return (Just new)++processEvent :: (Serialize ev) =>+ TxRun st -> ev + -> (RunHandler st ev)+ -> IO ()+processEvent txrun ev runHandler+ = atomically $ writeTChan (txEventQueue txrun) $ HR ev (runHandler)++getEpochMilli :: IO EpochMilli+getEpochMilli =+ do TOD sec pico <- getClockTime+ return $ fromIntegral $ sec * 1000 + pico `div` 10^9++newTxContext :: STM TxContext+newTxContext = unsafeIOToSTM $ do+ milli <- getEpochMilli+ let txid = -1 -- Not set yet.+ sgen <- modifyMVar globalRandomGen (return . split)+ let (rand, sgen') = random sgen+ return $ TxContext txid rand milli sgen'++addTxId :: TxRun st -> TxContext -> STM TxContext+addTxId tx context+ = do lastContext <- readTVar (txLastTxContext tx)+ let new = context{txId = txId lastContext + 1}+ writeTVar (txLastTxContext tx) new+ return new++{-# NOINLINE globalRandomGen #-}+-- XXX: why are we using a global StdGen? Isn't there already one in System.Random?+globalRandomGen :: MVar StdGen+globalRandomGen = unsafePerformIO (newMVar =<< getStdGen)+++data 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.+ , ctlChildren :: [(ThreadId, MVar ())] -- + }++data EventLogEntry = EventLogEntry TxContext Object deriving (Typeable, Show)+instance Version EventLogEntry+instance Serialize EventLogEntry where+ putCopy (EventLogEntry context obj) = contain $ safePut (context,obj)+ getCopy = contain $ + do (context, obj) <- safeGet+ return $ EventLogEntry context obj++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+ IHR context ev fun <- atomically $ readTChan queue+ let tstring = eventTString ev+ logMT NOTICE $ ("> Event "++show (txId context)++" of "++tstring)+ (mst,ra) <- fun context st+ case mst of+ -- State was not updated.+ --+ -- Thus the response can be executed immediately.+ Nothing -> do forkIO $ logMT NOTICE "> pure" >> ra+ loop st + -- There is a new State.+ --+ -- Note that saverAdd can return without yet writing the result+ -- as long as:+ -- 1) saverAdd calls honor the sequence in which they were made.+ -- 2) saverAdd calls execute the finalizers only after the value+ -- has been serialized. The finalizers typically return the+ -- result to the user so they should not be kept+ -- waiting too long.+ -- 3) This means that checkpoints need to flush the saver+ -- which will guarantee that all pending result/side-effects+ -- have been processed.+ -- 4) Savers must *not* block while running the finalizers+ Just st' -> do eventSaver <- readMVar eventSaverVar+ writerAdd eventSaver (EventLogEntry context (mkObject ev)) (logMT NOTICE "> disk " >> ra)+ loop st'+ in do forkIO $ handle excHandler $ loop st0+ return ()+ where excHandler (AsyncException ThreadKilled) = return ()+ excHandler BlockedIndefinitely = return ()+ excHandler e = throwIO e+
+ src/HAppS/State/TxControl.hs view
@@ -0,0 +1,47 @@+module HAppS.State.TxControl+ ( runTxSystem+ , shutdownSystem+ ) where++import System.Log.Logger+import System.IO+import Control.Monad+import Control.Exception+import Control.Concurrent++import HAppS.State.Checkpoint+import HAppS.State.Saver+import HAppS.State.Transaction+import HAppS.State.Types+import HAppS.State.ComponentSystem+import HAppS.Data.Proxy++logMM = logM "HAppS.State.TxControl"+++-- | Run a transaction system +runTxSystem :: (Methods st, Component st) => Saver -> Proxy st -> IO (MVar TxControl)+runTxSystem saver stateProxy =+ do logMM NOTICE "Initializing system control."+ ctl <- createTxControl saver stateProxy+ logMM NOTICE "Creating event mapper."+ initEventMap ctl stateProxy+ logMM NOTICE "Restoring state."+ restoreState ctl+ 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 $ \ctl -> return ctl{ctlChildren = children}+ return ctl++shutdownSystem :: MVar TxControl -> IO ()+shutdownSystem ctl+ = do logMM NOTICE "Shutting down."+ children <- liftM ctlChildren $ readMVar ctl+ logMM NOTICE "Killing children."+ mapM_ (killThread . fst) children+ mapM_ (takeMVar . snd) children -- FIXME: Use a timeout.+ logMM NOTICE "Shutdown complete"+ closeTxControl ctl
+ src/HAppS/State/Types.hs view
@@ -0,0 +1,104 @@+{-# OPTIONS -fglasgow-exts -fth -cpp -fallow-undecidable-instances #-}+module HAppS.State.Types where++import Control.Concurrent.STM+import Data.Int+import Data.Word+import qualified GHC.Conc(unsafeIOToSTM)+import System.Random -- (StdGen)++import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Trans+import HAppS.Data+import Data.Generics+-- Monad things+++data Env = Env+ { evRandoms :: TVar StdGen+ , evContext :: TxContext }++type TxId = Int64+--type EpochTime = Int64+type EpochMilli= Int64++instance Typeable StdGen where typeOf _ = mkTyConApp (mkTyCon "System.Random.StdGen") []++instance Random Word64 where+ randomR = integralRandomR+ random = randomR (minBound,maxBound)++instance Random Int64 where+ randomR = integralRandomR+ random = randomR (minBound,maxBound)++integralRandomR :: (Integral a, RandomGen g) => (a,a) -> g -> (a,g)+integralRandomR (a,b) g = case randomR (fromIntegral a :: Integer,+ fromIntegral b :: Integer) g of+ (x,g) -> (fromIntegral x, g)+++data TxContext = TxContext+ { txId :: TxId,+ txRand :: Word64,+ txTime :: EpochMilli,+ txStdGen :: StdGen+ } deriving (Read,Show,Typeable)+++{-+ Is STM really be best backend monad?+ We don't use any of the STM features.+-}+-- | ACID computations that work with any state and event types.+type AnyEv a = forall t. (Monad (t STM), MonadTrans t) => Ev (t STM) a++-- | Monad for ACID event handlers.+newtype Ev m t = Ev { unEv :: Env -> m t }++instance (Typeable st, Typeable1 m) => Typeable1 (ReaderT st m) where+ typeOf1 x = mkTyConApp (mkTyCon "Control.Monad.Reader.ReaderT") [typeOf (undefined :: st), typeOf1 (m x)]+ where m :: ReaderT st m a -> m a+ m = undefined++instance (Typeable st, Typeable1 m) => Typeable1 (StateT st m) where+ typeOf1 x = mkTyConApp (mkTyCon "Control.Monad.State.StateT") [typeOf (undefined :: st), typeOf1 (m x)]+ where m :: StateT st m a -> m a+ m = undefined++instance (Typeable state, Typeable t) => Typeable (Ev (ReaderT state STM) t) where+ typeOf (Ev _cmd) = mkTyConApp (mkTyCon "HAppS.State.Types.Ev") [typeOf (u::ReaderT state STM t)]+ where u = undefined+instance (Typeable state, Typeable t) => Typeable (Ev (StateT state STM) t) where+ typeOf (Ev _cmd) = mkTyConApp (mkTyCon "HAppS.State.Types.Ev") [typeOf (u::StateT state STM t)]+ where u = undefined++type Query state = Ev (ReaderT state STM)+type Update state = Ev (StateT state STM)++{-+withAny :: AnyEv Env+withAny = Ev $ StateT $ \s -> return (s, s)++test :: (Query st Env, Update st Env)+test = (withAny, withAny)+-}++-- unsafe lifting++unsafeIOToEv :: IO a -> AnyEv a+unsafeIOToEv c = unsafeSTMToEv (unsafeIOToSTM c)+unsafeSTMToEv :: STM a -> AnyEv a+unsafeSTMToEv c = Ev $ \_ -> lift c+unsafeIOToSTM :: IO a -> STM a+unsafeIOToSTM = GHC.Conc.unsafeIOToSTM++++-- Misc++newtype Shadow t a = Shadow { unShadow :: a } deriving Typeable++newtype UsingXml a = UsingXml { unXml :: a } deriving Typeable+
+ src/HAppS/State/Util.hs view
@@ -0,0 +1,98 @@+{-# LANGUAGE TemplateHaskell, CPP #-}+module HAppS.State.Util+ ( -- * Random numbers+ getRandom, getRandomR,+ -- * TH helpers+ inferRecordUpdaters+ ) where++import Control.Concurrent.STM+import Control.Monad.State+import System.Random++import HAppS.State.Monad+import HAppS.State.Types++import Data.Char(toUpper)+import Language.Haskell.TH+++-- Random numbers++-- | Get a random number.+getRandom :: Random a => AnyEv a+getRandom = do r <- sel evRandoms+ g <- liftSTM $ readTVar r+ let (x,g') = random g+ liftSTM $ writeTVar r g'+ return x++-- | Get a random number inside the range.+getRandomR :: Random a => (a,a) -> AnyEv a+getRandomR z = do r <- sel evRandoms+ g <- liftSTM $ readTVar r+ let (x,g') = randomR z g+ liftSTM $ writeTVar r g'+ return x++--------------------------------------------------------------+-- inferRecordUpdater+--------------------------------------------------------------+++-- FIXME: Throw a decent error message if the input isn't a record.+-- | Infer updating functions for a record @a_foo :: component -> record -> record@ and+-- @withFoo = localState foo a_foo@.+inferRecordUpdaters :: Name -> Q [Dec]+#ifndef __HADDOCK__+inferRecordUpdaters typeName = do+ con <- decToSimpleRecord =<< nameToDec typeName+ let c name upd sel = + do let un = mkName ("a_"++ns)+ wn = mkName ("with"++(toUpper (head ns):tail ns))+ ns = nameBase name+ ud <- un `sdef` upd+ wd <- wn `sdef` (varE 'localState `appE` sel `appE` varE un)+ return [ud, wd]+ xs <- sequence $ zipWith3 c (fieldNames con) (updFuns con) (selFuns con)+ return $ concat xs+#endif+++-- Utilities++decToSimpleRecord :: Dec -> Q Con+decToSimpleRecord (DataD _ _ _ [con] _) = return con+decToSimpleRecord (DataD _ n _ _ _) =+ fail ("Not a simple record (has multiple constructors): "++show n)+decToSimpleRecord (NewtypeD _ _ _ con _) = return con+decToSimpleRecord x = fail ("Wanted a simple record, got: "++show x)++nameToDec :: Name -> Q Dec+nameToDec ty = reify ty >>= un+ where un (TyConI d) = return $ d+ un _ = fail "nameToDec: expected TyCon"++-- | Create a list of selection functions for a record.+selFuns :: Con -> [ExpQ]+selFuns (RecC _ ts) = [ varE n | (n,_,_) <- ts ]++-- | Create a list of update functions for a record.+updFuns :: Con -> [ExpQ]+updFuns (RecC _ ts) = [ upd n | (n,_,_) <- ts ]+ where [x,y] = map mkName ["x","y"]+ upd f = lamE [varP x, varP y] $ rup f+ rup f = recUpdE (varE y) [return (f,VarE x)]+++-- | Return field names+fieldNames (RecC _ ts) = [ n | (n,_,_) <- ts ]++-- | Simple definition+sdef vn ve = valD (varP vn) (normalB ve) []+++--------------------------------------------------------------+-- inferRecordUpdater end+--------------------------------------------------------------+