diff --git a/Tests/AllTests.hs b/Tests/AllTests.hs --- a/Tests/AllTests.hs +++ b/Tests/AllTests.hs @@ -1,9 +1,12 @@ module Main where import qualified MsgGen +import qualified TopicTest import Test.Tasty main :: IO () main = do genTests <- MsgGen.tests - defaultMain $ + defaultMain $ testGroup "roshask" [ testGroup "roshask executable" [ genTests ] + , testGroup "roshask library" + [ TopicTest.topicTests]] diff --git a/roshask.cabal b/roshask.cabal --- a/roshask.cabal +++ b/roshask.cabal @@ -1,5 +1,5 @@ Name: roshask -Version: 0.2 +Version: 0.2.1 Synopsis: Haskell support for the ROS robotics framework. License: BSD3 License-file: LICENSE @@ -15,16 +15,14 @@ Description: Tools for working with ROS in Haskell. . ROS () is a software - framework developed by Willow Garage - () that aims - to provide a standard software architecture for - robotic systems. The main idea of the framework - is to support the development and execution of - loosely coupled /Node/s connected by typed - /Topic/s. Each Node represents a locus of - processing, ideally with a minimal interface - specified in terms of the types of Topics it - takes as input and offers as output. + framework that provides a standard software + architecture for robotic systems. The main idea + of the framework is to support the development + and execution of loosely coupled /Node/s + connected by typed /Topic/s. Each Node represents + a locus of processing, ideally with a minimal + interface specified in terms of the types of + Topics it takes as input and offers as output. . This package provides libraries for creating new ROS Nodes in Haskell, along with the @roshask@ @@ -112,7 +110,7 @@ snap-server >= 0.9, storable-tuple >= 0.0.2, transformers >= 0.4, - haxr >= 3000.10.3, + haxr >= 3000.10.4, utf8-string >= 0.3.6, uri >= 0.1.5, vector-space, @@ -126,7 +124,7 @@ Build-depends: unix - GHC-Options: -O2 -Wall + GHC-Options: -Wall Hs-Source-Dirs: src default-language: Haskell2010 -- Modules not exported by this package. @@ -160,7 +158,7 @@ GHC-Options: -O2 -Wall Main-Is: Main.hs Other-modules: Analysis Gen MD5 Parse PkgInit ResolutionTypes - FieldImports Unregister + FieldImports Unregister PkgBuilder Types Instances.Binary Instances.Storable Instances.NFData Paths_roshask Hs-Source-Dirs: src/executable diff --git a/src/Ros/Graph/Master.hs b/src/Ros/Graph/Master.hs --- a/src/Ros/Graph/Master.hs +++ b/src/Ros/Graph/Master.hs @@ -5,9 +5,8 @@ import Ros.Internal.RosTypes import Ros.Service.ServiceTypes import Network.XmlRpc.Internals (fromValue, toValue) -import Control.Monad.Except (ExceptT(..)) +import Control.Monad.Except (ExceptT(..), runExceptT) import System.IO.Error (catchIOError) -import Control.Monad.Error (runErrorT) -- |Subscribe the caller to the specified topic. In addition to -- receiving a list of current publishers, the subscriber will also @@ -53,7 +52,7 @@ lookupService :: URI -> String -> ServiceName -> ExceptT ServiceResponseExcept IO (Int, String, String) lookupService u s1 s2 = ExceptT . (flip catchIOError) handler $ do let res = call u "lookupService" (fmap toValue [s1, s2]) >>= fromValue - err <- runErrorT res + err <- runExceptT res return $ case err of Left x -> Left $ MasterExcept $ "Could not look up service with master. Got message: " ++ x Right y -> Right y diff --git a/src/Ros/Internal/DepFinder.hs b/src/Ros/Internal/DepFinder.hs --- a/src/Ros/Internal/DepFinder.hs +++ b/src/Ros/Internal/DepFinder.hs @@ -65,8 +65,9 @@ -- Packages that we will ignore for tracking down message definition -- dependencies. ignoredPackages :: [String] -ignoredPackages = ["genmsg_cpp", "rospack", "rosconsole", "rosbagmigration", - "roscpp", "rospy", "roslisp", "roslib", "boost"] +ignoredPackages = [ "genmsg_cpp", "rospack", "rosconsole", "rosbagmigration" + , "roscpp", "rospy", "roslisp", "roslib", "boost" + , "libconsole-bridge-dev" ] -- |Find the names of the ROS packages this package depends on as -- indicated by the manifest.xml or package.xml file in this package's root diff --git a/src/Ros/Node/RosTcp.hs b/src/Ros/Node/RosTcp.hs --- a/src/Ros/Node/RosTcp.hs +++ b/src/Ros/Node/RosTcp.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ScopedTypeVariables, BangPatterns #-} +{-# LANGUAGE BangPatterns, FlexibleContexts, ScopedTypeVariables #-} module Ros.Node.RosTcp (subStream, runServer, runServers, callServiceWithMaster) where import Control.Applicative ((<$>)) import Control.Arrow (first) diff --git a/src/Ros/Topic/Util.hs b/src/Ros/Topic/Util.hs --- a/src/Ros/Topic/Util.hs +++ b/src/Ros/Topic/Util.hs @@ -195,6 +195,20 @@ go (Right _) (r@(Right _), t) = go r =<< runTopic t go (Right y) (Left x, t) = return ((x,y), Topic $ warmup =<< runTopic t) +-- |Returns a 'Topic' that produces a new pair every time a value of +-- first topic produces a new value, followed by a new value from the +-- second topic. This can be used for sampling the first topic with +-- the second topic. +firstThenSecond :: Topic IO a -> Topic IO b -> Topic IO (a,b) +firstThenSecond t1 t2 = leftThenRight (t1 <+> t2) + +-- |Produces a value when a Left value is followed by a Right value. +leftThenRight :: (Monad m) => Topic m (Either a b) -> Topic m (a,b) +leftThenRight t1 = Topic $ warmup =<< runTopic t1 + where warmup (v,t) = go v =<< runTopic t + go (Left x) (Right y, t) = return ((x,y), Topic $ warmup =<< runTopic t) + go _ (x, t) = go x =<< runTopic t + -- |Merge two 'Topic's into one. The items from each component -- 'Topic' will be added to the combined 'Topic' as they become -- available. diff --git a/src/executable/PkgBuilder.hs b/src/executable/PkgBuilder.hs new file mode 100644 --- /dev/null +++ b/src/executable/PkgBuilder.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE FlexibleContexts, OverloadedStrings #-} +-- |Build all messages defined in a ROS package. +module PkgBuilder where +import Analysis +import Control.Applicative +import Control.Concurrent (forkIO) +import Control.Concurrent (newEmptyMVar) +import Control.Concurrent (putMVar) +import Control.Concurrent (takeMVar) +import Control.DeepSeq (rnf) +import qualified Control.Exception as C +import Control.Monad (when, zipWithM_) +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Char8 as B +import Data.Char (isSpace) +import qualified Data.Foldable as F +import Data.List (intercalate, isSuffixOf, isPrefixOf, nub) +import Data.Version (versionBranch) +import Gen (generateMsgType, generateSrvTypes) +import Parse (parseMsg, parseSrv) +import Types (requestResponseNames, shortName) +import Paths_roshask (version, getBinDir) + +import Ros.Internal.DepFinder (findMessages, findDepsWithMessages, hasMsgsOrSrvs, findServices) +import Ros.Internal.PathUtil (codeGenDir, cap) +import System.Directory (createDirectoryIfMissing, getDirectoryContents, + doesDirectoryExist, removeFile) +import System.Exit (ExitCode(..)) +import System.FilePath +import System.IO (hGetContents, hClose) +import System.Process (createProcess, proc, CreateProcess(..), waitForProcess, StdStream(CreatePipe)) + +-- | Determine if we are working in a sandbox by checking of roshask +-- was installed in one. If so, return the immediate parent of the +-- sandbox directory. +sandboxDir :: IO (Maybe FilePath) +sandboxDir = do d <- splitDirectories <$> getBinDir + return $ case reverse d of + ("bin" : ".cabal-sandbox" : ds) -> + Just . joinPath $ reverse ds + _ -> Nothing + +-- | Information on how to invoke @ghc-pkg@ (or @cabal sandbox +-- hc-pkg@) and the @cabal@ executable. +data ToolPaths = ToolPaths { ghcPkg :: [String] -> CreateProcess + , cabalInstall :: [String] -> CreateProcess + , forceFlag :: [String] } + +-- | If we are not in a sandbox, then we can use 'ghc-pkg' to get a +-- list of installed packages, and 'cabal install' to install a +-- package. If we are in a sandbox, we must invoke the tools from the +-- directory containing the sandbox directory, and use @cabal sandbox +-- hc-pkg@ instead of @ghc-pkg@. +toolPaths :: IO ToolPaths +toolPaths = + sandboxDir >>= \md -> return $ case md of + Nothing -> ToolPaths (\args -> (proc "ghc-pkg" args) + {std_in=CreatePipe, std_out=CreatePipe}) + (\args -> proc "cabal" args) + ["--force"] + Just _ -> ToolPaths (\args -> (proc "cabal" ("sandbox":"hc-pkg":args)) + {cwd=md, std_out=CreatePipe}) + (\args -> (proc "cabal" args) {cwd=md}) + ["--", "--force"] + +-- The current version of roshask. We tag generated message packages +-- with the same version. +roshaskVersion :: B.ByteString +roshaskVersion = B.pack . intercalate "." $ map show (versionBranch version) + +-- The current version of roshask with the patch level changed to an +-- asterisk. The intension is to allow a compiled roshask package to +-- work with newer patch levels of roshask itself. +roshaskMajorMinor :: B.ByteString +roshaskMajorMinor = B.pack . intercalate "." $ + map show (take 2 (versionBranch version)) ++ ["*"] + +pathToRosPkg :: FilePath -> FilePath +pathToRosPkg = last . splitDirectories + +-- | Somewhat more flexibile than 'System.Process.readProcess'. Not as +-- robust to exceptions. +myReadProcess :: CreateProcess -> IO String +myReadProcess cp = + do (i, Just o, _, ph) <- createProcess cp + F.mapM_ hClose i + output <- hGetContents o + done <- newEmptyMVar + _ <- forkIO $ C.evaluate (rnf output) >> putMVar done () + takeMVar done + hClose o + ex <- waitForProcess ph + case ex of + ExitSuccess -> return output + ExitFailure e -> error $ "Error reading process: "++show e + +-- Determine if a roshask package is already registered with ghc-pkg +-- for the given ROS package. +packageRegistered :: ToolPaths -> FilePath -> IO Bool +packageRegistered tools pkg = + any (isPrefixOf cabalPkg . dropWhile isSpace) . lines <$> getList + where cabalPkg = (rosPkg2CabalPkg $ pathToRosPkg pkg) ++ + "-" ++ B.unpack roshaskVersion + getList = myReadProcess $ ghcPkg tools ["list", cabalPkg] + +-- | Build all messages defined by a ROS package unless the corresponding +-- Haskell package is already registered with ghc-pkg. +buildPkgMsgs :: FilePath -> MsgInfo () +buildPkgMsgs fname = do tools <- liftIO toolPaths + r <- liftIO $ packageRegistered tools fname + if r + then liftIO . putStrLn $ + "Using existing " ++ pathToRosPkg fname + else buildNewPkgMsgs tools fname + +parseErrorMsg :: Show a => a -> String -> Either String c -> c +parseErrorMsg = parseErrorHelper "message" + +parseErrorSrv :: Show a => a -> String -> Either String c -> c +parseErrorSrv = parseErrorHelper "service" + +parseErrorHelper :: Show a => String -> a -> String -> Either String c -> c +parseErrorHelper srvOrMsg pkgHier fileName = + either + (\s -> error $ "In package: " ++ show pkgHier ++ "Could not parse " ++ srvOrMsg ++ " in file " ++ fileName ++" . Got error :" ++ s) + id + +dirAndNameToFile :: FilePath -> String -> FilePath +dirAndNameToFile destDir = (destDir ) . (++ ".hs") + +-- | Given a FilePath to a service file, will parse the service, generate the Haskell +-- request and response types, and write these types to a directory. This requires +-- knowing the Haskell names for the other messages in the current package +parseGenWriteService :: ByteString -> String -> [ByteString] -> FilePath -> MsgInfo () +parseGenWriteService pkgHier destDir haskellPkgMsgNames srvFile = do + parsedSrv <- liftIO $ parseErrorSrv pkgHier srvFile <$> parseSrv srvFile + (request, response) <- generateSrvTypes pkgHier haskellPkgMsgNames parsedSrv + let fname = map (dirAndNameToFile destDir) $ requestResponseNames parsedSrv + liftIO $ zipWithM_ B.writeFile fname [request, response] + +-- | Given a FilePath to a message file, will parse the message and generate and write +-- the Haskell type to a directory. +parseGenWriteMsg :: ByteString -> String -> [ByteString] -> FilePath -> MsgInfo () +parseGenWriteMsg pkgHier destDir haskellPkgMsgNames msgFile = do + parsedMsg <- liftIO $ parseErrorMsg pkgHier msgFile <$> parseMsg msgFile + generatedMsg <- generateMsgType pkgHier haskellPkgMsgNames parsedMsg + let fname = dirAndNameToFile destDir $ shortName parsedMsg + liftIO $ B.writeFile fname generatedMsg + +-- | Generate Haskell implementations of all message definitions in +-- the given package. +buildNewPkgMsgs :: ToolPaths -> FilePath -> MsgInfo () +buildNewPkgMsgs tools fname = + do liftIO . putStrLn $ "Generating package " ++ fname + destDir <- liftIO $ codeGenDir fname + liftIO $ createDirectoryIfMissing True destDir + pkgMsgs <- liftIO $ findMessages fname + pkgSrvs <- liftIO $ findServices fname + let haskellMsgNames = map (B.pack . cap . dropExtension . takeFileName) pkgMsgs + mapM_ (parseGenWriteMsg pkgHier destDir haskellMsgNames) pkgMsgs + mapM_ (parseGenWriteService pkgHier destDir haskellMsgNames) pkgSrvs + liftIO $ do f <- hasMsgsOrSrvs fname + when f (removeOldCabal fname >> compileMsgs) + where pkgName = pathToRosPkg fname + pkgHier = B.pack $ "Ros." ++ cap pkgName ++ "." + compileMsgs = do cpath <- genMsgCabal fname pkgName + (_,_,_,procH) <- createProcess $ + cabalInstall tools ["install", cpath] + code <- waitForProcess procH + when (code /= ExitSuccess) + (error $ "Building messages for "++ + pkgName++" failed") + +-- |Convert a ROS package name to the corresponding Cabal package name +-- defining the ROS package's msg types. +rosPkg2CabalPkg :: String -> String +rosPkg2CabalPkg = ("ROS-"++) . addSuffix . map sanitize + where sanitize '_' = '-' + sanitize c = c + addSuffix n + | "msgs" `isSuffixOf` n = n + | otherwise = n ++ "-msgs" + +removeOldCabal :: FilePath -> IO () +removeOldCabal pkgPath = + do msgPath <- codeGenDir pkgPath + f <- doesDirectoryExist msgPath + when f (getDirectoryContents msgPath >>= + mapM_ (removeFile . (msgPath )) . + filter ((== ".cabal") . takeExtension)) + +-- Extract a Msg module name from a Path +path2MsgModule :: FilePath -> String +path2MsgModule = intercalate "." . map cap . reverse . take 3 . + reverse . splitDirectories . dropExtension + +getHaskellFiles :: FilePath -> String -> IO [FilePath] +getHaskellFiles pkgPath _pkgName = do + d <- codeGenDir pkgPath + map (d ) . filter ((== ".hs") . takeExtension) <$> getDirectoryContents d + +-- Generate a .cabal file to build this ROS package's messages. +genMsgCabal :: FilePath -> String -> IO FilePath +genMsgCabal pkgPath pkgName = + do deps' <- map (B.pack . rosPkg2CabalPkg) <$> + findDepsWithMessages pkgPath + cabalFilePath <- (cabalPkg++".cabal") . + joinPath . init . init . splitPath <$> + codeGenDir pkgPath + let deps + | pkgName == "std_msgs" = deps' + | otherwise = nub ("ROS-std-msgs":deps') + msgFiles <- getHaskellFiles pkgPath pkgName + let msgModules = map (B.pack . path2MsgModule) msgFiles + target = B.intercalate "\n" $ + [ "Library" + , B.append " Exposed-Modules: " + (if not (null msgModules) + then B.concat [ head msgModules + , "\n" + , B.intercalate "\n" + (map indent (tail msgModules)) ] + else "") + , "" + , " Build-Depends: base >= 4.2 && < 6," + , " vector > 0.7," + , " time >= 1.1," + , " data-default-generics >= 0.3," + , B.concat [ " roshask == " + , roshaskMajorMinor + , if null deps then "" else "," ] + , B.intercalate ",\n" $ + map (B.append " ") deps + , " GHC-Options: -O2" ] + pkgDesc = B.concat [preamble, "\n", target] + --cabalFilePath = pkgPath"msg""haskell"cabalPkg++".cabal" + B.writeFile cabalFilePath pkgDesc + return cabalFilePath + where cabalPkg = rosPkg2CabalPkg pkgName + preamble = format [ ("Name", B.pack cabalPkg) + , ("Version", roshaskVersion) + , ("Synopsis", B.append "ROS Messages from " + (B.pack pkgName)) + , ("Cabal-version", ">=1.6") + , ("Category", "Robotics") + , ("Build-type", "Simple") ] + indent = let spaces = B.replicate 19 ' ' in B.append spaces + +format :: [(ByteString, ByteString)] -> ByteString +format fields = B.concat $ map indent fields + where indent (k,v) = let spaces = flip B.replicate ' ' $ + 21 - B.length k - 1 + in B.concat [k,":",spaces,v,"\n"] diff --git a/src/executable/PkgInit.hs b/src/executable/PkgInit.hs --- a/src/executable/PkgInit.hs +++ b/src/executable/PkgInit.hs @@ -5,10 +5,12 @@ import qualified Data.ByteString.Char8 as B import Data.Char (toLower, toUpper) import Data.List (intercalate) +import Data.Version (versionBranch) import System.Directory (createDirectory) import System.FilePath (()) import System.Process (system) +import Paths_roshask (version) import PkgBuilder (rosPkg2CabalPkg) -- |Initialize a package with the given name in the eponymous @@ -39,6 +41,15 @@ prepCMakeLists pkgName = B.appendFile (pkgName"CMakeLists.txt") cmd where cmd = "\nadd_custom_target(roshask ALL roshask dep ${PROJECT_SOURCE_DIR} COMMAND cd ${PROJECT_SOURCE_DIR} && cabal install)\n" +-- | New packages are constrained to the same major version of roshask +-- that was used to create them. +roshaskVersionBound :: ByteString +roshaskVersionBound = B.pack . ("roshask == "++) + . intercalate "." + . (++["*"]) + . map show + $ take 2 (versionBranch version ++ [0..]) + -- Generate a .cabal file and a Setup.hs that will perform the -- necessary dependency tracking and code generation. prepCabal :: String -> ByteString -> IO () @@ -56,7 +67,7 @@ , " vector > 0.7," , " time >= 1.1," , " ROS-rosgraph-msgs," - , B.append " roshask == 0.1.*" moreDeps + , B.append " roshask == 0.2.*" moreDeps , rosDeps , " GHC-Options: -O2" , " Hs-Source-Dirs: src" @@ -67,7 +78,8 @@ , " Build-Depends: base >= 4.2 && < 6," , " vector > 0.7," , " time >= 1.1," - , B.append " roshask == 0.1.*" moreDeps + , B.concat [ + " ", roshaskVersionBound, moreDeps ] , rosDeps , " GHC-Options: -O2" , B.concat [" Exposed-Modules: ", pkgName'] @@ -109,4 +121,3 @@ , nodeName++" = return ()\n"] where pkgName' = toUpper (head pkgName) : tail pkgName nodeName = toLower (head pkgName) : tail pkgName - diff --git a/src/executable/Types.hs b/src/executable/Types.hs new file mode 100644 --- /dev/null +++ b/src/executable/Types.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE OverloadedStrings #-} +-- |ROS message types. +module Types (MsgType(..), MsgField(..), MsgConst(..), + MsgName, msgName, requestMsgName, responseMsgName, + shortName, rawName, fullRosMsgName, + fullRosSrvName, + Msg(..), hasHeader, Srv(..), + requestResponseNames) where +import Data.ByteString.Char8 (ByteString) +import Data.Char (toUpper) + +-- |A variant type describing the types that may be included in a ROS +-- message. +data MsgType = RBool | RInt8 | RUInt8 | RInt16 | RUInt16 + | RInt32 | RUInt32 | RInt64 | RUInt64 + | RFloat32 | RFloat64 | RString | RTime | RDuration + | RFixedArray Int MsgType | RVarArray MsgType + | RUserType ByteString | RByte | RChar + deriving (Show, Eq, Ord) + +data MsgField = MsgField { fieldName :: ByteString + , fieldType :: MsgType + , rawFieldName :: ByteString } + deriving Show + +data MsgConst = MsgConst { constName :: ByteString + , constType :: MsgType + , rawValue :: ByteString + , rawConstName :: ByteString } + deriving Show + +-- | A Haskell type name for a message definition. +data MsgName = MsgName { msgRawName :: String + , msgTypeName :: String } deriving Show + +-- | Build a Haskell type name for a message. This ensures the name is +-- a valid Haskell type name. +msgName :: String -> MsgName +msgName [] = error "An empty message name is impossible!" +msgName n@(x:xs) = MsgName n (toUpper x : xs) + +requestMsgName :: String -> MsgName +requestMsgName name = msgName $ name ++ "Request" + +responseMsgName :: String -> MsgName +responseMsgName name = msgName $ name ++ "Response" + +-- | Pull the Haskell type name for a message from a 'Msg'. +shortName :: Msg -> String +shortName = msgTypeName . shortTypeName + +-- | Extract the original, raw, name of a message definition. This may +-- differ from the 'shortName' in that 'shortName' will always be +-- capitalized. +rawName :: Msg -> String +rawName = msgRawName . shortTypeName + +-- | Get the full ROS name of a message type. This will be of the +-- form, @packageName/msgName@. +fullRosMsgName :: Msg -> String +fullRosMsgName m = msgPackage m ++ '/' : rawName m + +fullRosSrvName :: Srv -> String +fullRosSrvName s = srvPackage s ++ '/' : (msgRawName . srvName) s + +-- |A message has a short name, a long name, an md5 sum, and a list of +-- named, typed fields. +data Msg = Msg { shortTypeName :: MsgName + , msgPackage :: String + , msgSource :: ByteString + , fields :: [MsgField] + , constants :: [MsgConst] } + +instance Show Msg where + show (Msg sn ln _ f c) = unwords + ["Msg", show sn, show ln, show f, show c] + +hasHeader :: Msg -> Bool +hasHeader msg = case fields msg of + --((_, RUserType "Header"):_) -> True + (MsgField _ (RUserType "Header") _ : _) -> True + _ -> False + +-- |A service has a request message, a response message, and a name. +data Srv = Srv { srvName :: MsgName + , srvPackage :: String + , srvSource :: ByteString + , srvRequest :: Msg + , srvResponse :: Msg + } + +instance Show Srv where + show (Srv name package _ req res) = + unwords ["Srv", show name, show package, show req, show res] + +requestResponseNames :: Srv -> [String] +requestResponseNames srv = [reqName, resName] + where + reqName = shortName . srvRequest $ srv + resName = shortName . srvResponse $ srv