diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,123 @@ +License Agreement + +Preamble + +The aim of this licence agreement is to enable the free use of the +software that is described in the sequel by anyone. In order to +guarantee this, it is necessary to set up rules for the use of the +software that hold for any user. + +Provider of this licence is the University of Bremen, represented by +its principal (called "licence provider" in the sequel). The provider +of the licence has developed the "Uniform Workbench" (just +called "software" in the sequel). The software includes a +graphical tool for accessing documents stored in a versioned repository, +but also contains libraries and some other tools. + +Following the ideas of open source software, the licence provider +gives access to the software without fee for anyone (called "licence +taker" in the sequel) under the following conditions which are similar +to the Lesser Gnu Public License (LGPL). Each licence taker obligates +himself to follow the terms of use below. + + + +1 Principle + +Each licence taker appreciating these terms of use receives a simple +right, not resctricted in time and space and without any fee, to use +the software, in particular, to copy, distribute and process +it. Exclusively the following terms of use do hold. The licence +provider explicitly contradicts any conflicting terms of business. By +making use of the rights described below, in particular by copying or +distributing it, a licence treaty between the licence provider and the +licence takes is concluded. + + + +2 Copying + +The licence taker has the right to make and distribute unmodified +copies of the software on any media. Prerequisite for this is that the +licence provider and this licence agreement is clearly recognizable, +and that the sources are distributed together with the software. + + + +3 Modification and Distribution + +The licence taker has the right to modify copies of the software (or +parts thereof) and to distribute these modifications under the terms +of 2 above and the following conditions: + +1. The modified software has to carry a clear mark that points to the +original licence provider, the modification that has been made, and +the date of the modification. + +2. The licence taker has to ensure that the software as a whole or +parts of it are accessible to third parties under the terms of this +licence agreement without fee. + +3. If during the modification a copyright of the licence taker +emerges, then this copyright must be put under the terms of this +licence if the modified software is distributed. + + +4 Other duties + +1. Reference to the validity of this licence agreement must not be +modified or deleted by the licence taker. + +2. The use of the software by third parties must not be conditioned by +the fulfilment of duties that are not mentioned in this licence +agreement. + +3. The use of the software must not be prevented or complicated by +means fo technical protection, in particular copy protection means. + + + +5 Liability, Update + +1. Liability of the licence provider is restriced to fraudulent +withheld factual or legal errors. The licence provider does not give +any warranty, and neither ensures any properties of the +software. Furthermore, he is liable only for those damages that are +caused by willful or grossly negligent violation of duty. + +2. The licence provider has the right to update these terms of use at +any time. + + + + +6 Forum for users + +The licence provider does provide neither support nor +consultation. Without acknowledgement of any legal duty, the licence +provider will care about the installation of a user forum for +discussions about the software and its further development. + + +7 Legal domicile + +It is agreed that the law of the Federal Republic of Germany is valid +for this licence agreement. For any lawsuits or legal actions emerging +from this licence agreement, it is agreed that exclusively German +courts are competent. Legal domicile is Bremen. + + +8 Termination through Offence + +Any violation of a duty of this agreement automatically terminates the +rights of use of the offender. + + + +9 Salvatorian Clause + +If any rule of this agreement should be or become inoperative, +validity of the other rules is not affected. The parties will care +about replacing the invalid rule by some valid rule that comes close +to the purpose of this agreement. + diff --git a/Reactor/BSem.hs b/Reactor/BSem.hs new file mode 100644 --- /dev/null +++ b/Reactor/BSem.hs @@ -0,0 +1,139 @@ +-- | +-- Description: Simple Lock +-- +-- A simple semaphore +module Reactor.BSem ( + BSem, + newBSem, + newLockedBSem, + + tryAcquireBSems, + tryAcquireBSemsWithError, + tryAcquireBSemsWithError1, + ) where + +import Data.Maybe + +import Control.Concurrent.MVar + +import Util.Computation +import Events.Synchronized +import Reactor.Lock + +-- -------------------------------------------------------------------------- +-- Type +-- -------------------------------------------------------------------------- + +-- | A simple lock. +newtype BSem = BSem (MVar ()) deriving Eq + +-- -------------------------------------------------------------------------- +-- Instances +-- -------------------------------------------------------------------------- + +instance Lock BSem where + acquire (BSem sem) = takeMVar sem + release (BSem sem) = putMVar sem () + tryAcquire (BSem sem) = + do + success <- tryTakeMVar sem + return (isJust success) + +instance Synchronized BSem where + synchronize (BSem sem) c = + do + takeMVar sem + ans <- try c + putMVar sem () + propagate ans + +-- -------------------------------------------------------------------------- +-- Commands +-- -------------------------------------------------------------------------- + +-- | Create a new unlocked BSem +newBSem :: IO BSem +newBSem = newMVar () >>= return . BSem + +-- | Create a new locked BSem +newLockedBSem :: IO BSem +newLockedBSem = newEmptyMVar >>= return . BSem + + +-- -------------------------------------------------------------------------- +-- Utilities +-- -------------------------------------------------------------------------- + +-- | tryAcquireBSems attempts to acquire a list of BSems. If successful it +-- returns the action to release them all again. If unsuccessful it +-- returns Nothing, and leaves all the BSems released. +tryAcquireBSems :: [BSem] -> IO (Maybe (IO ())) +tryAcquireBSems bSems = + do + let + toMess _ = return "" + actWithError <- tryAcquireBSemsWithError id toMess bSems + return (case fromWithError actWithError of + Left _ -> Nothing + Right act -> Just act + ) + +-- | tryAcquireBSemsWithError is a generalisation of tryAcquireBSems, which +-- produces an error message +-- +-- The first argument extracts an object\'s BSem; the second gets a String to +-- be used as a message if we can\'t get the object\'s lock. +tryAcquireBSemsWithError :: (object -> BSem) -> (object -> IO String) + -> [object] -> IO (WithError (IO ())) +tryAcquireBSemsWithError toBSem toMess objects = + let + getBSem object = return (toBSem object) + getMessIfError object = + do + mess <- toMess object + return (Just mess) + in + tryAcquireBSemsWithError1 getBSem getMessIfError objects + +-- | tryAcquireBSemsWithError1 toBSem getMessIfError objects +-- attempts to acquire the BSems in (map toBSem objects). In +-- the event of a (toBSem object) already being acquired, it looks at +-- the result of getMessIfError object. If this is (Just mess) +-- it returns an error condition with message (mess), first +-- releasing all BSems it has already acquired; if it is (Nothing) +-- it goes on to attempt to acquire the BSems for the remaining objects. +-- If it gets to the end of the list it returns an action which can be +-- used to release all the BSems it has acquired. +tryAcquireBSemsWithError1 :: + (object -> IO BSem) -> (object -> IO (Maybe String)) -> [object] + -> IO (WithError (IO ())) +tryAcquireBSemsWithError1 _ _ [] = return . return $ done +tryAcquireBSemsWithError1 getBSem getMessIfError (object:objects) = + do + bSem <- getBSem object + acquire1 <- tryAcquire bSem + if acquire1 + then + do + acquires + <- tryAcquireBSemsWithError1 getBSem getMessIfError objects + case fromWithError acquires of + Right releaseAct -> + return (return ( + do + releaseAct + release bSem + )) + Left _ -> + do + release bSem + return acquires + else + do + errorMessIfError <- getMessIfError object + case errorMessIfError of + Just errorMess -> return (fail errorMess) + Nothing -> + tryAcquireBSemsWithError1 getBSem getMessIfError objects + + diff --git a/Reactor/InfoBus.hs b/Reactor/InfoBus.hs new file mode 100644 --- /dev/null +++ b/Reactor/InfoBus.hs @@ -0,0 +1,136 @@ +-- | InfoBus implements the 'shutdown' command. This destroys all the +-- things registered via 'registerTool' and not +-- subsequently registered via 'deregisterTool'. Tools are identified +-- by 'ObjectId'. +module Reactor.InfoBus ( + registerTool, + registerToolDebug, + deregisterTool, + shutdown, + registerDestroyAct, + encapsulateWaitTermAct, + ) where + + +import Control.Concurrent.MVar +import qualified Data.Map as Map +import System.IO.Unsafe +import System.Mem(performGC) + +import Util.Computation +import Util.Object +import Util.Debug(debug) + +import Events.Destructible + +-- -------------------------------------------------------------------------- +-- Tool Manager State +-- -------------------------------------------------------------------------- + +type ToolManager = MVar Tools + +type Tools = Map.Map ObjectID (IO ()) + + +-- -------------------------------------------------------------------------- +-- Fetch Tool Manager State +-- -------------------------------------------------------------------------- + +toolmanager :: ToolManager +toolmanager = unsafePerformIO (newMVar Map.empty) +{-# NOINLINE toolmanager #-} + + +-- -------------------------------------------------------------------------- +-- Client Commands +-- -------------------------------------------------------------------------- + +registerTool :: (Object t, Destroyable t) => t -> IO () +registerTool t = + do + map <- takeMVar toolmanager + putMVar toolmanager (Map.insert (objectID t) (destroy t) map) + done + +registerToolDebug :: (Object t, Destroyable t) => String -> t -> IO () +registerToolDebug title t = + do + map <- takeMVar toolmanager + putMVar toolmanager (Map.insert (objectID t) (destroy t) map) + debug ("registerTool " ++ title,objectID t) + done + + +deregisterTool :: (Object t) => t -> IO () +deregisterTool t = + do + let oid = objectID t + try( -- ignore exceptions if they occur. I don't see how they can + -- actually. + do + map <- takeMVar toolmanager + putMVar toolmanager (Map.delete oid map) + ) + debug ("deregisterTool ",oid) + done + +shutdown :: IO () +shutdown = + do + map <- takeMVar toolmanager + let toShutDown = Map.toList map + putMVar toolmanager Map.empty + foreach toShutDown + (\ (oid,cmd) -> + do + debug ("Shutting down ",oid) + try cmd + ) + performGC + +-- -------------------------------------------------------------------------- +-- Simple interface allowing us to register something to be done without +-- having to create special instances for it. +-- -------------------------------------------------------------------------- + + +-- | register the given action to be done at shutdown. The returned action +-- cancels the registration (without performing the given action). +registerDestroyAct :: IO () -> IO (IO ()) +registerDestroyAct act = + do + oID <- newObject + let + simpleTool = SimpleTool { + oID = oID, + destroyAct = act + } + + registerTool simpleTool + return (deregisterTool simpleTool) + +-- | encapsulate an action such that shutdown waits for its termination +encapsulateWaitTermAct :: IO () -> IO () +encapsulateWaitTermAct act = + do sync <- newEmptyMVar + _ <- registerDestroyAct (readMVar sync) + act + putMVar sync () + + +data SimpleTool = SimpleTool { + oID :: ObjectID, + destroyAct :: IO () + } + +instance Object SimpleTool where + objectID simpleTool = oID simpleTool + +instance Destroyable SimpleTool where + destroy simpleTool = destroyAct simpleTool + + + + + + diff --git a/Reactor/Lock.hs b/Reactor/Lock.hs new file mode 100644 --- /dev/null +++ b/Reactor/Lock.hs @@ -0,0 +1,19 @@ +-- | Lock is an instance of a typical thing we synchronize with. +-- One instance is 'BSem'. +module Reactor.Lock ( + Lock(..), + ) where + +-- -------------------------------------------------------------------------- +-- Class Lock +-- -------------------------------------------------------------------------- + +class Lock l where + -- | release a lock + release :: l -> IO () + -- | acquire a lock + acquire :: l -> IO () + + -- | acquire a lock and return True, if that can be done at once, otherwise + -- return False. + tryAcquire :: l -> IO Bool diff --git a/Reactor/MSem.hs b/Reactor/MSem.hs new file mode 100644 --- /dev/null +++ b/Reactor/MSem.hs @@ -0,0 +1,61 @@ +-- | +-- Description: Reentrant Lock +-- +-- This is a much simpler reimplementation of Einar's old Mutex semaphores. +-- This is a lock which can be required by a thread which is already holding +-- it. +-- +-- See also "TSem". +module Reactor.MSem( + MSem, + newMSem, -- :: IO MSem + synchronizeWithChoice, + -- :: MSem -> (Bool -> IO a) -> IO a + -- Lock on the MSem. The action is given True iff this thread + -- already holds the lock on the MSem. + ) where + +import Data.IORef +import Control.Concurrent + +import Util.Computation +import Events.Synchronized +import Reactor.Lock +import Reactor.BSem + +data MSem = MSem { + lock :: BSem, + holdingThreadRef :: IORef (Maybe ThreadId) + -- only written when BSem is held by this thread. + } + +newMSem :: IO MSem +newMSem = + do + lock <- newBSem + holdingThreadRef <- newIORef Nothing + return (MSem {lock = lock,holdingThreadRef = holdingThreadRef}) + +synchronizeWithChoice :: MSem -> (Bool -> IO a) -> IO a +synchronizeWithChoice mSem toAct = + do + holdingThreadOpt <- readIORef (holdingThreadRef mSem) + thisThread <- myThreadId + let + heldByUs = case holdingThreadOpt of + Nothing -> False + Just holdingThread -> holdingThread == thisThread + if heldByUs + then + (toAct True) + else + do + acquire (lock mSem) + writeIORef (holdingThreadRef mSem) (Just thisThread) + actOut <- try (toAct False) + writeIORef (holdingThreadRef mSem) Nothing + release (lock mSem) + propagate actOut + +instance Synchronized MSem where + synchronize mSem act = synchronizeWithChoice mSem (const act) diff --git a/Reactor/ReferenceVariables.hs b/Reactor/ReferenceVariables.hs new file mode 100644 --- /dev/null +++ b/Reactor/ReferenceVariables.hs @@ -0,0 +1,80 @@ +-- | +-- - Reentrant, protected references: an IORef in an MVar, protected by +-- - a reentrant monitor. +-- - +-- - The operations which change the value (setRef, changeRef, withRef) +-- - are protected by the monitor, which additionally provides a reentrant +-- - synchronize method. + + +module Reactor.ReferenceVariables( + Ref, -- type Ref a + newRef, -- :: a -> IO (Ref a) + setRef, -- :: Ref a -> a -> IO () + changeRef, -- :: Ref a -> (a -> a) -> IO () + changeRefM, -- :: Ref a-> (a-> IO a) -> IO () + withRef, -- :: Ref a -> (a -> b) -> IO b + getRef -- :: Ref a -> IO a + +) where + +import Data.IORef +import Control.Concurrent.MVar + +import Events.Synchronized +import Reactor.MSem + +data Ref a = Ref MSem (MVar (IORef a)) + +newRef :: a -> IO (Ref a) +newRef val = + do + ioref <- newIORef val + mvar <- newMVar ioref + mtx <- newMSem + return (Ref mtx mvar) + +setRef :: Ref a -> a -> IO () +setRef (Ref mtx mvar) val = + synchronize mtx $ + do ioref <- takeMVar mvar + writeIORef ioref val + putMVar mvar ioref + +changeRef :: Ref a -> (a -> a) -> IO () +changeRef (Ref mtx mvar) fn = + synchronize mtx $ + do ioref <- takeMVar mvar + val <- readIORef ioref + writeIORef ioref (fn val) + putMVar mvar ioref + +changeRefM :: Ref a -> (a -> IO a) -> IO () +changeRefM (Ref mtx mvar) act = + synchronize mtx $ + do ioref <- takeMVar mvar + val <- readIORef ioref + val' <- act val + writeIORef ioref val' + putMVar mvar ioref + +withRef :: Ref a -> (a -> b) -> IO b +withRef (Ref mtx mvar) fn = + synchronize mtx $ + do + ioref <- takeMVar mvar + val <- readIORef ioref + putMVar mvar ioref + return (fn val) + +getRef :: Ref a -> IO a +getRef (Ref _ mvar) = + do + ioref <- takeMVar mvar + val <- readIORef ioref + putMVar mvar ioref + return val + +instance Synchronized (Ref a) where + synchronize (Ref mtx mvar) = synchronize mtx + diff --git a/Reactor/WithDir.hs b/Reactor/WithDir.hs new file mode 100644 --- /dev/null +++ b/Reactor/WithDir.hs @@ -0,0 +1,34 @@ +-- | A function for changing directories in a thread-safe way. +-- +-- We use an MSem to lock the current directory. This means that +-- withDir can be nested without deadlock (presumably the user knows what +-- he's doing). +module Reactor.WithDir( + withDir, -- :: FilePath -> IO a -> IO a + ) where + +import System.Directory + +import System.IO.Unsafe + +import Util.Computation + +import Events.Synchronized + +import Reactor.MSem + +dirMSem :: MSem +dirMSem = unsafePerformIO newMSem +{-# NOINLINE dirMSem #-} + + +withDir :: FilePath -> IO a -> IO a +withDir filePath act = + synchronize dirMSem ( + do + originalDir <- getCurrentDirectory + setCurrentDirectory filePath + actOut <- try act + setCurrentDirectory originalDir + propagate actOut + ) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/uni-reactor.cabal b/uni-reactor.cabal new file mode 100644 --- /dev/null +++ b/uni-reactor.cabal @@ -0,0 +1,27 @@ +name: uni-reactor +version: 2.2.0.0 +build-type: Simple +license: LGPL +license-file: LICENSE +author: uniform@informatik.uni-bremen.de +maintainer: Christian.Maeder@dfki.de +homepage: http://www.informatik.uni-bremen.de/uniform/wb/ +category: Uniform +synopsis: Reactors for the uniform workbench +description: uni reactor +cabal-version: >= 1.4 +Tested-With: GHC==6.8.3, GHC==6.10.4, GHC==6.12.3 + +library + exposed-modules: + Reactor.Lock, + Reactor.BSem, + Reactor.MSem, + Reactor.ReferenceVariables, + Reactor.InfoBus, + Reactor.WithDir + + build-depends: base >=3 && < 5, containers, directory, uni-util, uni-events + + if impl(ghc > 6.10) + ghc-options: -fwarn-unused-imports -fno-warn-warnings-deprecations