module UDrawGraph.Basic(
Context,
newContext,
doInContextGeneral,
doInContext,
withHandler,
newType,
newNodeId,
newEdgeId,
newMenuId,
daVinciVersion,
exitDaVinci,
) where
import Data.Maybe
import Data.List (isPrefixOf)
import System.IO.Unsafe
import Control.Concurrent.MVar
import qualified Control.Exception as Exception
import Foreign.C.String
import Data.IORef
import System.Environment
import Util.Object
import Util.WBFiles
import Util.Computation as Computation (propagate, done)
import Util.Registry
import Util.UniqueString
import Util.Thread
import Util.ExtendedPrelude (mapOrd, mapEq)
import Events.Spawn
import Events.Events
import Events.Channels
import Events.Destructible
import Events.Synchronized
import Reactor.BSem
import Posixutil.ChildProcess
import Reactor.InfoBus
import qualified UDrawGraph.Types as DaVinciTypes
import UDrawGraph.Types hiding (DaVinciAnswer(Context))
import UDrawGraph.Types (DaVinciAnswer())
data DaVinci = DaVinci {
childProcess :: ChildProcess,
contextRegistry :: Registry ContextId Context,
currentContextIdMVar :: MVar ContextId,
destroyActMVar :: MVar (IO ()),
responseMVar :: MVar (ContextId,DaVinciAnswer),
oID :: ObjectID,
version :: Maybe String
}
daVinci :: DaVinci
daVinci = unsafePerformIO newDaVinci
challengeResponsePair :: (String,String)
challengeResponsePair =
(unlines $ replicate 3 "nothing",
unlines $ replicate 4 "ok")
newDaVinci :: IO DaVinci
newDaVinci =
do
daVinciPath <- getDaVinciPath
daVinciIconsOpt <- getDaVinciIcons
env <- getEnvironment
let
configs = [
environment $ maybe id
(\ daVinciIcons -> (("DAVINCI_ICONDIR", daVinciIcons) :))
daVinciIconsOpt env,
arguments ["-pipe"],
standarderrors False,
linemode True,
challengeResponse challengeResponsePair,
toolName "daVinci"
]
childProcess <- newChildProcess daVinciPath configs
sendMsg childProcess (show (Special Version))
contextRegistry <- newRegistry
currentContextIdMVar <- newMVar invalidContextId
typeSource <- newUniqueStringSource
destroyActMVar <- newEmptyMVar
responseMVar <- newEmptyMVar
oID <- newObject
versionAnswer <- getNextAnswer childProcess
let
version = case versionAnswer of
Versioned str -> Just str
CommunicationError _ -> Nothing
daVinci =
DaVinci {
childProcess = childProcess,
contextRegistry = contextRegistry,
currentContextIdMVar = currentContextIdMVar,
destroyActMVar = destroyActMVar,
responseMVar = responseMVar,
oID = oID,
version = version
}
destroyAnswerDispatcher <- spawn (answerDispatcher daVinci)
putMVar destroyActMVar (
do
deregisterTool daVinci
forAllContexts destroy
sendMsg childProcess (show(Menu(File(Exit))))
destroy childProcess
destroyAnswerDispatcher
)
registerToolDebug "daVinci" daVinci
return daVinci
daVinciVersion :: Maybe String
daVinciVersion = version daVinci
workAroundDaVinciBug1 :: Bool
workAroundDaVinciBug1 =
case daVinciVersion of
Just "daVinci Presenter Professional 3.0.3" -> True
Just "daVinci Presenter Professional 3.0.4" -> True
Just "daVinci Presenter Professional 3.0.5" -> True
_ -> False
daVinciSkip :: IO ()
daVinciSkip =
if workAroundDaVinciBug1 then delay (secs 0.1) else done
instance Destroyable DaVinci where
destroy (DaVinci {
destroyActMVar = destroyActMVar,
responseMVar = responseMVar
}) =
do
destroyAct <- takeMVar destroyActMVar
putMVar destroyActMVar done
destroyAct
tryPutMVar responseMVar
(invalidContextId,CommunicationError
"daVinci ended before command completed")
done
instance Object DaVinci where
objectID daVinci = oID daVinci
getDaVinciEnvironment :: IO [(String,String)]
getDaVinciEnvironment =
do
let
getEnvOpt :: String -> IO (Maybe (String,String))
getEnvOpt envName =
do
res <- Exception.try (getEnv envName)
return (case res of
Left (_ :: Exception.IOException) -> Nothing
Right envVal -> Just (envName,envVal)
)
daVinciEnvs
<- mapM getEnvOpt [
"DISPLAY","LD_LIBRARY_PATH","DAVINCIHOME","LANG","OSTYPE",
"PATH","PWD","USER"]
return (catMaybes (daVinciEnvs :: [Maybe (String,String)]))
data Context = Context {
contextId :: ContextId,
destructChannel :: Channel (),
typeSource :: UniqueStringSource,
idSource :: UniqueStringSource,
menuIdSource :: UniqueStringSource,
handlerIORef :: IORef (DaVinciAnswer -> IO ()),
withHandlerLock :: BSem
}
newContext :: (DaVinciAnswer -> IO ()) -> IO Context
newContext handler =
do
(newContextId,result)
<- doInContextVeryGeneral (Multi NewContext) Nothing
case result of
Ok -> done
CommunicationError str ->
error ("DaVinciBasic: newContext returned error "++str)
destructChannel <- newChannel
typeSource <- newUniqueStringSource
idSource <- newUniqueStringSource
menuIdSource <- newUniqueStringSource
handlerIORef <- newIORef handler
withHandlerLock <- newBSem
let
newContext = Context {
contextId = newContextId,
destructChannel = destructChannel,
typeSource = typeSource,
idSource = idSource,
menuIdSource = menuIdSource,
handlerIORef = handlerIORef,
withHandlerLock = withHandlerLock
}
setValue (contextRegistry daVinci) newContextId newContext
return newContext
instance Destroyable Context where
destroy (context@ Context {contextId = contextId}) =
do
deleted <- deleteFromRegistryBool (contextRegistry daVinci) contextId
if not deleted
then
done
else
do
putMVar (responseMVar daVinci) (contextId,Ok)
doInContext (Menu(File(Close))) context
instance Destructible Context where
destroyed context = receive (destructChannel context)
exitDaVinci :: Context -> IO ()
exitDaVinci (context@ Context {contextId = contextId}) = do
putMVar (responseMVar daVinci) (contextId,Ok)
doInContext (Menu(File(Exit))) context
doInContext :: DaVinciCmd -> Context -> IO ()
doInContext daVinciCmd context =
do
answer <- doInContextGeneral daVinciCmd context
case answer of
Ok -> done
CommunicationError str ->
error ("DaVinciBasic: "++(show daVinciCmd)++
" returned error "++str)
doInContextGeneral :: DaVinciCmd -> Context -> IO DaVinciAnswer
doInContextGeneral daVinciCmd context =
do
(cId,answer) <- doInContextVeryGeneral daVinciCmd (Just context)
return answer
doInContextVeryGeneral :: DaVinciCmd -> Maybe Context
-> IO (ContextId,DaVinciAnswer)
doInContextVeryGeneral daVinciCmd contextOpt =
do
let
cmdString = shows daVinciCmd "\n"
cIdOpt = (fmap contextId) contextOpt
DaVinci {
childProcess = childProcess,
responseMVar = responseMVar,
currentContextIdMVar = currentContextIdMVar
} = daVinci
withCStringLen cmdString (\ cStringLen ->
do
currentContextId <- takeMVar currentContextIdMVar
case cIdOpt of
Nothing -> done
Just newContextId ->
if currentContextId == newContextId
then
done
else
do
sendMsg childProcess
(show(Multi(SetContext newContextId)))
(gotContextId,result) <- takeMVar responseMVar
if gotContextId /= newContextId
then
do
putStrLn ("daVinci bug: "
++ "set_context returned wrong context")
failSafeSetContext newContextId
else
done
daVinciSkip
case result of
Ok -> done
_ -> error ("set_context returned "++
(show result))
sendMsgRaw childProcess cStringLen
result@(gotContextId,daVinciAnswer) <- takeMVar responseMVar
putMVar currentContextIdMVar gotContextId
case cIdOpt of
Nothing -> done
Just newContextId ->
if gotContextId == newContextId
then
done
else
do
putStrLn "daVinci bug: Mismatch in returned context"
failSafeSetContext gotContextId
return result
)
failSafeSetContext :: ContextId -> IO ()
failSafeSetContext contextId =
do
putStrLn "Trying again with setContext"
sendMsg (childProcess daVinci) (show(Multi(SetContext contextId)))
(gotContextId,result) <- takeMVar (responseMVar daVinci)
if gotContextId /= contextId
then
do
putStrLn "Yet another mismatch; trying again with delay"
delay (secs 0.1)
failSafeSetContext contextId
else
done
forAllContexts :: (Context -> IO ()) -> IO ()
forAllContexts contextAct =
do
idsContexts <- listRegistryContents (contextRegistry daVinci)
sequence_ (map (contextAct . snd) idsContexts)
invalidContextId :: ContextId
invalidContextId = ContextId ""
withHandler :: (DaVinciAnswer -> IO ()) -> Context -> IO a -> IO a
withHandler newHandler context act =
do
result <- synchronize (withHandlerLock context) (
do
let
ioRef = handlerIORef context
oldHandler <- readIORef ioRef
writeIORef ioRef newHandler
result <- Exception.try act
writeIORef ioRef oldHandler
return result
)
Computation.propagate result
data AnswerDestination =
Response
| LocalEvent
| GlobalEvent
answerDestination :: DaVinciAnswer -> AnswerDestination
answerDestination Ok = Response
answerDestination (CommunicationError _) = Response
answerDestination (TclAnswer _) = Response
answerDestination (Versioned _) = Response
answerDestination DaVinciTypes.Quit = GlobalEvent
answerDestination Disconnect = GlobalEvent
answerDestination _ = LocalEvent
data DestroysContext = Yes | No
destroysContext :: DaVinciAnswer -> DestroysContext
destroysContext Closed = Yes
destroysContext DaVinciTypes.Quit = Yes
destroysContext (CloseWindow _) = Yes
destroysContext _ = No
answerDispatcher :: DaVinci -> IO ()
answerDispatcher (daVinci@DaVinci{
childProcess = childProcess,
contextRegistry = contextRegistry,
currentContextIdMVar = currentContextIdMVar,
responseMVar = responseMVar
}) =
do
answerDispatcher'
where
forward :: DaVinciAnswer -> Context -> IO ()
forward daVinciAnswer context =
do
handler <- readIORef (handlerIORef context)
handler daVinciAnswer
case destroysContext daVinciAnswer of
Yes ->
do
takeMVar currentContextIdMVar
putMVar currentContextIdMVar (ContextId "")
sync (noWait (send (destructChannel context) ()))
No -> done
answerDispatcher' =
do
(contextId,daVinciAnswer) <- getMultiAnswer childProcess
case answerDestination daVinciAnswer of
LocalEvent ->
do
contextOpt <- getValueOpt contextRegistry contextId
case contextOpt of
Nothing -> done
Just context -> forward daVinciAnswer context
Response ->
do
tryPutMVar responseMVar (contextId,daVinciAnswer)
done
GlobalEvent ->
forAllContexts (forward daVinciAnswer)
answerDispatcher'
getMultiAnswer :: ChildProcess -> IO (ContextId,DaVinciAnswer)
getMultiAnswer childProcess =
do
answer1 <- getNextAnswer childProcess
case answer1 of
DaVinciTypes.Context contextId ->
do
answer2 <- getNextAnswer childProcess
return (contextId,answer2)
_ -> error ("Unexpected daVinci answer expecting contextId: "
++ show answer1)
getNextAnswer :: ChildProcess -> IO DaVinciAnswer
getNextAnswer childProcess =
do
line <- readMsg childProcess
if isPrefixOf "program error:" line
then
do
putStrLn line
putStrLn "************ DAvINCI BUG IGNORED ***************"
getNextAnswer childProcess
else
return (read line)
newType :: Context -> IO Type
newType context =
do
typeString <- newUniqueString (typeSource context)
return (Type typeString)
newNodeId :: Context -> IO NodeId
newNodeId context =
do
nodeString <- newUniqueString (idSource context)
return (NodeId nodeString)
newEdgeId :: Context -> IO EdgeId
newEdgeId context =
do
edgeString <- newUniqueString (idSource context)
return (EdgeId edgeString)
newMenuId :: Context -> IO MenuId
newMenuId context =
do
menuIdString <- newUniqueString (menuIdSource context)
return (MenuId menuIdString)
instance Eq Context where
(==) = mapEq contextId
instance Ord Context where
compare = mapOrd contextId