PkgBuilder.hs

{-# 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"]