diff --git a/HAppS-State.cabal b/HAppS-State.cabal new file mode 100644 --- /dev/null +++ b/HAppS-State.cabal @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +import Distribution.Simple +main = defaultMainWithHooks defaultUserHooks diff --git a/src/HAppS/State.hs b/src/HAppS/State.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State.hs @@ -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 diff --git a/src/HAppS/State/Checkpoint.hs b/src/HAppS/State/Checkpoint.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State/Checkpoint.hs @@ -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." + diff --git a/src/HAppS/State/ComponentSystem.hs b/src/HAppS/State/ComponentSystem.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State/ComponentSystem.hs @@ -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 +-} diff --git a/src/HAppS/State/ComponentTH.hs b/src/HAppS/State/ComponentTH.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State/ComponentTH.hs @@ -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." diff --git a/src/HAppS/State/Control.hs b/src/HAppS/State/Control.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State/Control.hs @@ -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 + diff --git a/src/HAppS/State/Monad.hs b/src/HAppS/State/Monad.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State/Monad.hs @@ -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 } } diff --git a/src/HAppS/State/Saver.hs b/src/HAppS/State/Saver.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State/Saver.hs @@ -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" } + + + diff --git a/src/HAppS/State/Saver/Impl/File.hs b/src/HAppS/State/Saver/Impl/File.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State/Saver/Impl/File.hs @@ -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 diff --git a/src/HAppS/State/Saver/Impl/Memory.hs b/src/HAppS/State/Saver/Impl/Memory.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State/Saver/Impl/Memory.hs @@ -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 diff --git a/src/HAppS/State/Saver/Impl/Queue.hs b/src/HAppS/State/Saver/Impl/Queue.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State/Saver/Impl/Queue.hs @@ -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) + + diff --git a/src/HAppS/State/Saver/Types.hs b/src/HAppS/State/Saver/Types.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State/Saver/Types.hs @@ -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 + } diff --git a/src/HAppS/State/Transaction.hs b/src/HAppS/State/Transaction.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State/Transaction.hs @@ -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 + diff --git a/src/HAppS/State/TxControl.hs b/src/HAppS/State/TxControl.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State/TxControl.hs @@ -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 diff --git a/src/HAppS/State/Types.hs b/src/HAppS/State/Types.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State/Types.hs @@ -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 + diff --git a/src/HAppS/State/Util.hs b/src/HAppS/State/Util.hs new file mode 100644 --- /dev/null +++ b/src/HAppS/State/Util.hs @@ -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 +-------------------------------------------------------------- +