{-# LANGUAGE DeriveDataTypeable #-}
{- |
   Module      : Data.FileStore.MercurialCommandServer
   Copyright   : Copyright (C) 2011 John Lenz (lenz@math.uic.edu)
   License     : BSD 3

   Maintainer  : John MacFarlane <jgm@berkeley.edu>
   Stability   : alpha
   Portability : GHC 6.10 required

   In version 1.9, mercurial introduced a command server which allows
   a single instance of mercurial to be launched and multiple commands
   can be executed without requiring mercurial to start and stop.  See
   http://mercurial.selenic.com/wiki/CommandServer
-}

module Data.FileStore.MercurialCommandServer
    ( runMercurialCommand
    , rawRunMercurialCommand
    )
where

import Control.Applicative ((<$>))
import Control.Exception (Exception, onException, throwIO)
import Control.Monad (when)
import Data.Bits (shiftL, shiftR, (.|.))
import Data.Char (isLower, isUpper)
import Data.FileStore.Utils (runShellCommand)
import Data.IORef (IORef, newIORef, readIORef, atomicModifyIORef)
import Data.List (intercalate, isPrefixOf)
import Data.List.Split (splitOn)
import Data.Typeable (Typeable)
import Data.Word (Word32)
import System.Exit (ExitCode(..))
import System.IO (Handle, hClose, hPutStr, hFlush)
import System.IO.Unsafe (unsafePerformIO)
import System.Process (runInteractiveProcess)

import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as UTF8
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.UTF8 as LUTF8
import qualified Data.Map as M
import qualified System.Info as SI

-- | Maximum number of servers to keep around
maxPoolSize :: Int
maxPoolSize :: Int
maxPoolSize = 2

-- | Run a mercurial command and return error status, error output, standard output.  The repository
-- is used as working directory.
runMercurialCommand :: FilePath -> String -> [String] -> IO (ExitCode, String, BL.ByteString)
runMercurialCommand :: FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
runMercurialCommand repo :: FilePath
repo command :: FilePath
command args :: [FilePath]
args = do
  Maybe (Handle, Handle, Handle)
server <- FilePath -> IO (Maybe (Handle, Handle, Handle))
getServer FilePath
repo
  case Maybe (Handle, Handle, Handle)
server of
     Nothing -> FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
rawRunMercurialCommand FilePath
repo FilePath
command [FilePath]
args
     Just h :: (Handle, Handle, Handle)
h  -> do (ExitCode, FilePath, ByteString)
ret <- FilePath
-> [FilePath]
-> (Handle, Handle, Handle)
-> IO (ExitCode, FilePath, ByteString)
runMercurialServer FilePath
command [FilePath]
args (Handle, Handle, Handle)
h IO (ExitCode, FilePath, ByteString)
-> IO () -> IO (ExitCode, FilePath, ByteString)
forall a b. IO a -> IO b -> IO a
`onException` (Handle, Handle, Handle) -> IO ()
cleanupServer (Handle, Handle, Handle)
h
                   FilePath -> (Handle, Handle, Handle) -> IO ()
putServer FilePath
repo (Handle, Handle, Handle)
h
                   (ExitCode, FilePath, ByteString)
-> IO (ExitCode, FilePath, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode, FilePath, ByteString)
ret

-- | Run a mercurial command directly without using the server.
rawRunMercurialCommand :: FilePath -> String -> [String] -> IO (ExitCode, String, BL.ByteString)
rawRunMercurialCommand :: FilePath
-> FilePath -> [FilePath] -> IO (ExitCode, FilePath, ByteString)
rawRunMercurialCommand repo :: FilePath
repo command :: FilePath
command args :: [FilePath]
args = do
   let env :: [(FilePath, FilePath)]
env = [("HGENCODING","utf8")]
   (status :: ExitCode
status, err :: ByteString
err, out :: ByteString
out) <- FilePath
-> Maybe [(FilePath, FilePath)]
-> FilePath
-> [FilePath]
-> IO (ExitCode, ByteString, ByteString)
runShellCommand FilePath
repo ([(FilePath, FilePath)] -> Maybe [(FilePath, FilePath)]
forall a. a -> Maybe a
Just [(FilePath, FilePath)]
env) "hg" (FilePath
command FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
args)
   (ExitCode, FilePath, ByteString)
-> IO (ExitCode, FilePath, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
status, ByteString -> FilePath
LUTF8.toString ByteString
err, ByteString
out)

-- | Create a new command server for the given repository
createServer :: FilePath -> IO (Handle,Handle,Handle)
createServer :: FilePath -> IO (Handle, Handle, Handle)
createServer repo :: FilePath
repo = do
    (hin :: Handle
hin,hout :: Handle
hout,herr :: Handle
herr,_) <- FilePath
-> [FilePath]
-> Maybe FilePath
-> Maybe [(FilePath, FilePath)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess "hg" ["serve", "--cmdserver", "pipe"] (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
repo) Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing
    MercurialMessage
hello <- Handle -> IO MercurialMessage
readMessage Handle
hout
    case MercurialMessage
hello of
       MessageO _ -> (Handle, Handle, Handle) -> IO (Handle, Handle, Handle)
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
hin,Handle
hout,Handle
herr)
       MessageE x :: ByteString
x -> MercurialServerException -> IO (Handle, Handle, Handle)
forall e a. Exception e => e -> IO a
throwIO (MercurialServerException -> IO (Handle, Handle, Handle))
-> MercurialServerException -> IO (Handle, Handle, Handle)
forall a b. (a -> b) -> a -> b
$ FilePath -> MercurialServerException
MercurialServerException (ByteString -> FilePath
UTF8.toString ByteString
x)
       _          -> MercurialServerException -> IO (Handle, Handle, Handle)
forall e a. Exception e => e -> IO a
throwIO (MercurialServerException -> IO (Handle, Handle, Handle))
-> MercurialServerException -> IO (Handle, Handle, Handle)
forall a b. (a -> b) -> a -> b
$ FilePath -> MercurialServerException
MercurialServerException "unknown hello message"

-- | Cleanup a command sever.  Mercurial will automatically exit itself
--   when the handles are closed.
cleanupServer :: (Handle,Handle,Handle) -> IO ()
cleanupServer :: (Handle, Handle, Handle) -> IO ()
cleanupServer (hin :: Handle
hin,hout :: Handle
hout,herr :: Handle
herr) = Handle -> IO ()
hClose Handle
hin IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
hout IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
herr

-- | format a command for sending to the server
formatCommand :: String -> [String] -> B.ByteString
formatCommand :: FilePath -> [FilePath] -> ByteString
formatCommand cmd :: FilePath
cmd args :: [FilePath]
args = FilePath -> ByteString
UTF8.fromString (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate "\0" ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
cmd FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
args

-- | run a command using the mercurial server
runMercurialServer :: String -> [String] -> (Handle,Handle,Handle) -> IO (ExitCode, String, BL.ByteString)
runMercurialServer :: FilePath
-> [FilePath]
-> (Handle, Handle, Handle)
-> IO (ExitCode, FilePath, ByteString)
runMercurialServer cmd :: FilePath
cmd args :: [FilePath]
args (hin :: Handle
hin,hout :: Handle
hout,herr :: Handle
herr) = do
    Handle -> FilePath -> IO ()
hPutStr Handle
hin "runcommand\n"
    let fcmd :: ByteString
fcmd = FilePath -> [FilePath] -> ByteString
formatCommand FilePath
cmd [FilePath]
args
    Handle -> Word32 -> IO ()
hWriteWord32be Handle
hin (Word32 -> IO ()) -> Word32 -> IO ()
forall a b. (a -> b) -> a -> b
$ Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> Word32) -> Int -> Word32
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
fcmd
    Handle -> ByteString -> IO ()
B.hPut Handle
hin ByteString
fcmd
    Handle -> IO ()
hFlush Handle
hin
    Handle -> Handle -> IO (ExitCode, FilePath, ByteString)
processUntilR Handle
hout Handle
herr

-- | Read messages from the server until the command finishes or an error message appears
processUntilR :: Handle -> Handle -> IO (ExitCode, String, BL.ByteString)
processUntilR :: Handle -> Handle -> IO (ExitCode, FilePath, ByteString)
processUntilR hout :: Handle
hout _ = ByteString -> ByteString -> IO (ExitCode, FilePath, ByteString)
loop ByteString
BL.empty ByteString
BL.empty
  where loop :: ByteString -> ByteString -> IO (ExitCode, FilePath, ByteString)
loop out :: ByteString
out err :: ByteString
err =
          do MercurialMessage
m <- Handle -> IO MercurialMessage
readMessage Handle
hout
             case MercurialMessage
m of
                MessageO x :: ByteString
x -> ByteString -> ByteString -> IO (ExitCode, FilePath, ByteString)
loop (ByteString -> ByteString -> ByteString
BL.append ByteString
out (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BL.fromChunks [ByteString
x]) ByteString
err
                MessageE x :: ByteString
x -> ByteString -> ByteString -> IO (ExitCode, FilePath, ByteString)
loop ByteString
out (ByteString -> ByteString -> ByteString
BL.append ByteString
err (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BL.fromChunks [ByteString
x])
                MessageR c :: Int
c -> if Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== 0
                                then (ExitCode, FilePath, ByteString)
-> IO (ExitCode, FilePath, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ExitSuccess, "", ByteString
out)
                                else (ExitCode, FilePath, ByteString)
-> IO (ExitCode, FilePath, ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure Int
c, ByteString -> FilePath
LUTF8.toString ByteString
err, ByteString
out)

data MercurialMessage = MessageO B.ByteString
                      | MessageE B.ByteString
                      | MessageR Int

data MercurialServerException = MercurialServerException String
  deriving (Int -> MercurialServerException -> ShowS
[MercurialServerException] -> ShowS
MercurialServerException -> FilePath
(Int -> MercurialServerException -> ShowS)
-> (MercurialServerException -> FilePath)
-> ([MercurialServerException] -> ShowS)
-> Show MercurialServerException
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [MercurialServerException] -> ShowS
$cshowList :: [MercurialServerException] -> ShowS
show :: MercurialServerException -> FilePath
$cshow :: MercurialServerException -> FilePath
showsPrec :: Int -> MercurialServerException -> ShowS
$cshowsPrec :: Int -> MercurialServerException -> ShowS
Show,Typeable)
instance Exception MercurialServerException

-- | Read a single message
readMessage :: Handle -> IO MercurialMessage
readMessage :: Handle -> IO MercurialMessage
readMessage hout :: Handle
hout = do
    ByteString
buf <- Handle -> Int -> IO ByteString
B.hGet Handle
hout 1
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
buf ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
B.empty) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       MercurialServerException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MercurialServerException -> IO ())
-> MercurialServerException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> MercurialServerException
MercurialServerException "Unknown channel"
    let c :: Char
c = ByteString -> Char
B8.head ByteString
buf
    -- Mercurial says unknown lower case channels can be ignored, but upper case channels
    -- must be handled.  Currently there are two upper case channels, 'I' and 'L' which
    -- are both used for user input/output.  So error on any upper case channel.
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char -> Bool
isUpper Char
c) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       MercurialServerException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MercurialServerException -> IO ())
-> MercurialServerException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> MercurialServerException
MercurialServerException (FilePath -> MercurialServerException)
-> FilePath -> MercurialServerException
forall a b. (a -> b) -> a -> b
$ "Unknown channel " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> FilePath
forall a. Show a => a -> FilePath
show Char
c
    Int
len <- Handle -> IO Int
hReadWord32be Handle
hout
    ByteString
bdata <- Handle -> Int -> IO ByteString
B.hGet Handle
hout Int
len
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
bdata Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
len) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
       MercurialServerException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MercurialServerException -> IO ())
-> MercurialServerException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> MercurialServerException
MercurialServerException "Mercurial did not produce enough output"
    case Char
c of
      'r' | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= 4 -> MercurialMessage -> IO MercurialMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (MercurialMessage -> IO MercurialMessage)
-> MercurialMessage -> IO MercurialMessage
forall a b. (a -> b) -> a -> b
$ Int -> MercurialMessage
MessageR (Int -> MercurialMessage) -> Int -> MercurialMessage
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
bsReadWord32be ByteString
bdata
      'r'            -> MercurialServerException -> IO MercurialMessage
forall e a. Exception e => e -> IO a
throwIO (MercurialServerException -> IO MercurialMessage)
-> MercurialServerException -> IO MercurialMessage
forall a b. (a -> b) -> a -> b
$ FilePath -> MercurialServerException
MercurialServerException (FilePath -> MercurialServerException)
-> FilePath -> MercurialServerException
forall a b. (a -> b) -> a -> b
$ "return value is fewer than 4 bytes"
      'o'            -> MercurialMessage -> IO MercurialMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (MercurialMessage -> IO MercurialMessage)
-> MercurialMessage -> IO MercurialMessage
forall a b. (a -> b) -> a -> b
$ ByteString -> MercurialMessage
MessageO ByteString
bdata
      'e'            -> MercurialMessage -> IO MercurialMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (MercurialMessage -> IO MercurialMessage)
-> MercurialMessage -> IO MercurialMessage
forall a b. (a -> b) -> a -> b
$ ByteString -> MercurialMessage
MessageE ByteString
bdata
      _ | Char -> Bool
isLower Char
c  -> Handle -> IO MercurialMessage
readMessage Handle
hout -- skip this message
      _              -> MercurialServerException -> IO MercurialMessage
forall e a. Exception e => e -> IO a
throwIO (MercurialServerException -> IO MercurialMessage)
-> MercurialServerException -> IO MercurialMessage
forall a b. (a -> b) -> a -> b
$ FilePath -> MercurialServerException
MercurialServerException (FilePath -> MercurialServerException)
-> FilePath -> MercurialServerException
forall a b. (a -> b) -> a -> b
$ "Unknown channel " FilePath -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> FilePath
forall a. Show a => a -> FilePath
show Char
c

-- | Read a 32-bit big-endian into an Int
hReadWord32be :: Handle -> IO Int
hReadWord32be :: Handle -> IO Int
hReadWord32be h :: Handle
h = do
    ByteString
s <- Handle -> Int -> IO ByteString
B.hGet Handle
h 4
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
s Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= 4) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      MercurialServerException -> IO ()
forall e a. Exception e => e -> IO a
throwIO (MercurialServerException -> IO ())
-> MercurialServerException -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> MercurialServerException
MercurialServerException "unable to read int"
    Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> IO Int) -> Int -> IO Int
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
bsReadWord32be ByteString
s

-- | Read a 32-bit big-endian from a bytestring into an Int
bsReadWord32be :: B.ByteString -> Int
bsReadWord32be :: ByteString -> Int
bsReadWord32be s :: ByteString
s = (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString
s ByteString -> Int -> Word8
`B.index` 0) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` 24) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|.
                   (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString
s ByteString -> Int -> Word8
`B.index` 1) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` 16) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|.
                   (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString
s ByteString -> Int -> Word8
`B.index` 2) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL`  8) Int -> Int -> Int
forall a. Bits a => a -> a -> a
.|.
                   (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString
s ByteString -> Int -> Word8
`B.index` 3) )

-- | Write a Word32 in big-endian to the handle
hWriteWord32be :: Handle -> Word32 -> IO ()
hWriteWord32be :: Handle -> Word32 -> IO ()
hWriteWord32be h :: Handle
h w :: Word32
w = Handle -> ByteString -> IO ()
B.hPut Handle
h ByteString
buf
  where buf :: ByteString
buf = [Word8] -> ByteString
B.pack [  -- fromIntegeral to convert to Word8
                Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` 24),
                Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR` 16),
                Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w Word32 -> Int -> Word32
forall a. Bits a => a -> Int -> a
`shiftR`  8),
                Word32 -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
w
              ]

-------------------------------------------------------------------
-- Maintain a pool of mercurial servers.  Currently stored in a
-- global IORef.  The code must provide two functions, to get
-- and put a server from the pool.  The code above takes care of
-- cleaning up if an exception occurs.
-------------------------------------------------------------------

data MercurialGlobalState = MercurialGlobalState {
    MercurialGlobalState -> Maybe Bool
useCommandServer :: Maybe Bool
  , MercurialGlobalState -> Map FilePath [(Handle, Handle, Handle)]
serverHandles    :: M.Map FilePath [(Handle,Handle,Handle)]
} deriving (Int -> MercurialGlobalState -> ShowS
[MercurialGlobalState] -> ShowS
MercurialGlobalState -> FilePath
(Int -> MercurialGlobalState -> ShowS)
-> (MercurialGlobalState -> FilePath)
-> ([MercurialGlobalState] -> ShowS)
-> Show MercurialGlobalState
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [MercurialGlobalState] -> ShowS
$cshowList :: [MercurialGlobalState] -> ShowS
show :: MercurialGlobalState -> FilePath
$cshow :: MercurialGlobalState -> FilePath
showsPrec :: Int -> MercurialGlobalState -> ShowS
$cshowsPrec :: Int -> MercurialGlobalState -> ShowS
Show)

-- | See http://www.haskell.org/haskellwiki/Top_level_mutable_state
mercurialGlobalVar :: IORef MercurialGlobalState
{-# NOINLINE mercurialGlobalVar #-}
mercurialGlobalVar :: IORef MercurialGlobalState
mercurialGlobalVar = IO (IORef MercurialGlobalState) -> IORef MercurialGlobalState
forall a. IO a -> a
unsafePerformIO (MercurialGlobalState -> IO (IORef MercurialGlobalState)
forall a. a -> IO (IORef a)
newIORef (Maybe Bool
-> Map FilePath [(Handle, Handle, Handle)] -> MercurialGlobalState
MercurialGlobalState Maybe Bool
forall a. Maybe a
Nothing Map FilePath [(Handle, Handle, Handle)]
forall k a. Map k a
M.empty))

-- | Pull a server out of the pool.  Returns nothing if the mercurial version
--   does not support servers.
getServer :: FilePath -> IO (Maybe (Handle, Handle, Handle))
getServer :: FilePath -> IO (Maybe (Handle, Handle, Handle))
getServer repo :: FilePath
repo = do
    Maybe Bool
use <- MercurialGlobalState -> Maybe Bool
useCommandServer (MercurialGlobalState -> Maybe Bool)
-> IO MercurialGlobalState -> IO (Maybe Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef MercurialGlobalState -> IO MercurialGlobalState
forall a. IORef a -> IO a
readIORef IORef MercurialGlobalState
mercurialGlobalVar
    case Maybe Bool
use of
      Just False -> Maybe (Handle, Handle, Handle)
-> IO (Maybe (Handle, Handle, Handle))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Handle, Handle, Handle)
forall a. Maybe a
Nothing
      Nothing    -> do Bool
isok <- IO Bool
checkVersion
                       IORef MercurialGlobalState
-> (MercurialGlobalState -> (MercurialGlobalState, ())) -> IO ()
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef MercurialGlobalState
mercurialGlobalVar ((MercurialGlobalState -> (MercurialGlobalState, ())) -> IO ())
-> (MercurialGlobalState -> (MercurialGlobalState, ())) -> IO ()
forall a b. (a -> b) -> a -> b
$ \state :: MercurialGlobalState
state ->
                          (MercurialGlobalState
state { useCommandServer :: Maybe Bool
useCommandServer = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
isok }, ())
                       FilePath -> IO (Maybe (Handle, Handle, Handle))
getServer FilePath
repo
      Just True  -> FilePath -> IO (Maybe (Handle, Handle, Handle))
allocateServer FilePath
repo

-- | Helper function called once we know that mercurial supports servers
allocateServer :: FilePath -> IO (Maybe (Handle, Handle, Handle))
allocateServer :: FilePath -> IO (Maybe (Handle, Handle, Handle))
allocateServer repo :: FilePath
repo = do
    Either () (Handle, Handle, Handle)
ret <- IORef MercurialGlobalState
-> (MercurialGlobalState
    -> (MercurialGlobalState, Either () (Handle, Handle, Handle)))
-> IO (Either () (Handle, Handle, Handle))
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef MercurialGlobalState
mercurialGlobalVar ((MercurialGlobalState
  -> (MercurialGlobalState, Either () (Handle, Handle, Handle)))
 -> IO (Either () (Handle, Handle, Handle)))
-> (MercurialGlobalState
    -> (MercurialGlobalState, Either () (Handle, Handle, Handle)))
-> IO (Either () (Handle, Handle, Handle))
forall a b. (a -> b) -> a -> b
$ \state :: MercurialGlobalState
state ->
             case FilePath
-> Map FilePath [(Handle, Handle, Handle)]
-> Maybe [(Handle, Handle, Handle)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
repo (MercurialGlobalState -> Map FilePath [(Handle, Handle, Handle)]
serverHandles MercurialGlobalState
state) of
                Just (x :: (Handle, Handle, Handle)
x:xs :: [(Handle, Handle, Handle)]
xs) -> (MercurialGlobalState
state { serverHandles :: Map FilePath [(Handle, Handle, Handle)]
serverHandles = FilePath
-> [(Handle, Handle, Handle)]
-> Map FilePath [(Handle, Handle, Handle)]
-> Map FilePath [(Handle, Handle, Handle)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
repo [(Handle, Handle, Handle)]
xs (MercurialGlobalState -> Map FilePath [(Handle, Handle, Handle)]
serverHandles MercurialGlobalState
state)}, (Handle, Handle, Handle) -> Either () (Handle, Handle, Handle)
forall a b. b -> Either a b
Right (Handle, Handle, Handle)
x)
                _           -> (MercurialGlobalState
state, () -> Either () (Handle, Handle, Handle)
forall a b. a -> Either a b
Left ())
    case Either () (Handle, Handle, Handle)
ret of
      Right x :: (Handle, Handle, Handle)
x -> Maybe (Handle, Handle, Handle)
-> IO (Maybe (Handle, Handle, Handle))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Handle, Handle, Handle)
 -> IO (Maybe (Handle, Handle, Handle)))
-> Maybe (Handle, Handle, Handle)
-> IO (Maybe (Handle, Handle, Handle))
forall a b. (a -> b) -> a -> b
$ (Handle, Handle, Handle) -> Maybe (Handle, Handle, Handle)
forall a. a -> Maybe a
Just (Handle, Handle, Handle)
x
      Left () -> (Handle, Handle, Handle) -> Maybe (Handle, Handle, Handle)
forall a. a -> Maybe a
Just ((Handle, Handle, Handle) -> Maybe (Handle, Handle, Handle))
-> IO (Handle, Handle, Handle)
-> IO (Maybe (Handle, Handle, Handle))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO (Handle, Handle, Handle)
createServer FilePath
repo

-- | Puts a server back in the pool if the pool is not full,
--   otherwise closes the server.
putServer :: FilePath -> (Handle,Handle,Handle) -> IO ()
putServer :: FilePath -> (Handle, Handle, Handle) -> IO ()
putServer repo :: FilePath
repo h :: (Handle, Handle, Handle)
h = do
    Either () ()
ret <- IORef MercurialGlobalState
-> (MercurialGlobalState -> (MercurialGlobalState, Either () ()))
-> IO (Either () ())
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef MercurialGlobalState
mercurialGlobalVar ((MercurialGlobalState -> (MercurialGlobalState, Either () ()))
 -> IO (Either () ()))
-> (MercurialGlobalState -> (MercurialGlobalState, Either () ()))
-> IO (Either () ())
forall a b. (a -> b) -> a -> b
$ \state :: MercurialGlobalState
state -> do
              case FilePath
-> Map FilePath [(Handle, Handle, Handle)]
-> Maybe [(Handle, Handle, Handle)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup FilePath
repo (MercurialGlobalState -> Map FilePath [(Handle, Handle, Handle)]
serverHandles MercurialGlobalState
state) of
                  Just xs :: [(Handle, Handle, Handle)]
xs | [(Handle, Handle, Handle)] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Handle, Handle, Handle)]
xs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
maxPoolSize -> (MercurialGlobalState
state, () -> Either () ()
forall a b. b -> Either a b
Right ())
                  Just xs :: [(Handle, Handle, Handle)]
xs -> (MercurialGlobalState
state { serverHandles :: Map FilePath [(Handle, Handle, Handle)]
serverHandles = FilePath
-> [(Handle, Handle, Handle)]
-> Map FilePath [(Handle, Handle, Handle)]
-> Map FilePath [(Handle, Handle, Handle)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
repo ((Handle, Handle, Handle)
h(Handle, Handle, Handle)
-> [(Handle, Handle, Handle)] -> [(Handle, Handle, Handle)]
forall a. a -> [a] -> [a]
:[(Handle, Handle, Handle)]
xs) (MercurialGlobalState -> Map FilePath [(Handle, Handle, Handle)]
serverHandles MercurialGlobalState
state)}, () -> Either () ()
forall a b. a -> Either a b
Left ())
                  Nothing -> (MercurialGlobalState
state { serverHandles :: Map FilePath [(Handle, Handle, Handle)]
serverHandles = FilePath
-> [(Handle, Handle, Handle)]
-> Map FilePath [(Handle, Handle, Handle)]
-> Map FilePath [(Handle, Handle, Handle)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert FilePath
repo [(Handle, Handle, Handle)
h] (MercurialGlobalState -> Map FilePath [(Handle, Handle, Handle)]
serverHandles MercurialGlobalState
state)}, () -> Either () ()
forall a b. a -> Either a b
Left ())
    case Either () ()
ret of
      Right () -> (Handle, Handle, Handle) -> IO ()
cleanupServer (Handle, Handle, Handle)
h
      Left  () -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | Check if the mercurial version supports servers
--   On windows, don't even try because talking to hg over a pipe does not
--   currently work correctly.
checkVersion :: IO Bool
checkVersion :: IO Bool
checkVersion
    | FilePath -> Bool
isOperatingSystem "mingw32" = Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    | Bool
otherwise                   = do
        (status :: ExitCode
status,_,out :: ByteString
out) <- FilePath
-> Maybe [(FilePath, FilePath)]
-> FilePath
-> [FilePath]
-> IO (ExitCode, ByteString, ByteString)
runShellCommand "." Maybe [(FilePath, FilePath)]
forall a. Maybe a
Nothing "hg" ["version", "-q"]
        case ExitCode
status of
          ExitFailure _ -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          ExitSuccess   -> Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ FilePath -> [Int]
parseVersion (ByteString -> FilePath
LUTF8.toString ByteString
out) [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
>= [2,0]

-- | Helps to find out what operating system we are on
--   Example usage:
--      isOperatingSystem "mingw32" (on windows)
--      isOperatingSystem "darwin"
--      isOperatingSystem "linux"
isOperatingSystem :: String -> Bool
isOperatingSystem :: FilePath -> Bool
isOperatingSystem sys :: FilePath
sys = FilePath
SI.os FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
sys

-- | hg version -q returns something like "Mercurial Distributed SCM (version 1.9.1)"
--   This function returns the list [1,9,1]
parseVersion :: String -> [Int]
parseVersion :: FilePath -> [Int]
parseVersion b :: FilePath
b = if Bool
starts then [Int]
verLst else [0]
  where msg :: FilePath
msg = "Mercurial Distributed SCM (version "
        starts :: Bool
starts = FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf FilePath
msg FilePath
b
        ver :: FilePath
ver    = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= ')') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
msg) FilePath
b
        verLst :: [Int]
verLst = (FilePath -> Int) -> [FilePath] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> Int
forall a. Read a => FilePath -> a
read ([FilePath] -> [Int]) -> [FilePath] -> [Int]
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> [FilePath]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn "." FilePath
ver