{-# 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 = Int
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 :: String -> String -> [String] -> IO (ExitCode, String, ByteString)
runMercurialCommand String
repo String
command [String]
args = do
  Maybe (Handle, Handle, Handle)
server <- String -> IO (Maybe (Handle, Handle, Handle))
getServer String
repo
  case Maybe (Handle, Handle, Handle)
server of
     Maybe (Handle, Handle, Handle)
Nothing -> String -> String -> [String] -> IO (ExitCode, String, ByteString)
rawRunMercurialCommand String
repo String
command [String]
args
     Just (Handle, Handle, Handle)
h  -> do (ExitCode, String, ByteString)
ret <- String
-> [String]
-> (Handle, Handle, Handle)
-> IO (ExitCode, String, ByteString)
runMercurialServer String
command [String]
args (Handle, Handle, Handle)
h IO (ExitCode, String, ByteString)
-> IO () -> IO (ExitCode, String, ByteString)
forall a b. IO a -> IO b -> IO a
`onException` (Handle, Handle, Handle) -> IO ()
cleanupServer (Handle, Handle, Handle)
h
                   String -> (Handle, Handle, Handle) -> IO ()
putServer String
repo (Handle, Handle, Handle)
h
                   (ExitCode, String, ByteString) -> IO (ExitCode, String, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode, String, ByteString)
ret

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

-- | Create a new command server for the given repository
createServer :: FilePath -> IO (Handle,Handle,Handle)
createServer :: String -> IO (Handle, Handle, Handle)
createServer String
repo = do
    (Handle
hin,Handle
hout,Handle
herr,ProcessHandle
_) <- String
-> [String]
-> Maybe String
-> Maybe [(String, String)]
-> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveProcess String
"hg" [String
"serve", String
"--cmdserver", String
"pipe"] (String -> Maybe String
forall a. a -> Maybe a
Just String
repo) Maybe [(String, String)]
forall a. Maybe a
Nothing
    MercurialMessage
hello <- Handle -> IO MercurialMessage
readMessage Handle
hout
    case MercurialMessage
hello of
       MessageO ByteString
_ -> (Handle, Handle, Handle) -> IO (Handle, Handle, Handle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
hin,Handle
hout,Handle
herr)
       MessageE 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
$ String -> MercurialServerException
MercurialServerException (ByteString -> String
UTF8.toString ByteString
x)
       MercurialMessage
_          -> 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
$ String -> MercurialServerException
MercurialServerException String
"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 (Handle
hin,Handle
hout,Handle
herr) = Handle -> IO ()
hClose Handle
hin IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
hout IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
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 :: String -> [String] -> ByteString
formatCommand String
cmd [String]
args = String -> ByteString
UTF8.fromString (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"\0" ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ String
cmd String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
args

-- | run a command using the mercurial server
runMercurialServer :: String -> [String] -> (Handle,Handle,Handle) -> IO (ExitCode, String, BL.ByteString)
runMercurialServer :: String
-> [String]
-> (Handle, Handle, Handle)
-> IO (ExitCode, String, ByteString)
runMercurialServer String
cmd [String]
args (Handle
hin,Handle
hout,Handle
herr) = do
    Handle -> String -> IO ()
hPutStr Handle
hin String
"runcommand\n"
    let fcmd :: ByteString
fcmd = String -> [String] -> ByteString
formatCommand String
cmd [String]
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, String, 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, String, ByteString)
processUntilR Handle
hout Handle
_ = ByteString -> ByteString -> IO (ExitCode, String, ByteString)
loop ByteString
BL.empty ByteString
BL.empty
  where loop :: ByteString -> ByteString -> IO (ExitCode, String, ByteString)
loop ByteString
out ByteString
err =
          do MercurialMessage
m <- Handle -> IO MercurialMessage
readMessage Handle
hout
             case MercurialMessage
m of
                MessageO ByteString
x -> ByteString -> ByteString -> IO (ExitCode, String, 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 ByteString
x -> ByteString -> ByteString -> IO (ExitCode, String, 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 Int
c -> if Int
c Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0
                                then (ExitCode, String, ByteString) -> IO (ExitCode, String, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ExitSuccess, String
"", ByteString
out)
                                else (ExitCode, String, ByteString) -> IO (ExitCode, String, ByteString)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> ExitCode
ExitFailure Int
c, ByteString -> String
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 -> String
(Int -> MercurialServerException -> ShowS)
-> (MercurialServerException -> String)
-> ([MercurialServerException] -> ShowS)
-> Show MercurialServerException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MercurialServerException -> ShowS
showsPrec :: Int -> MercurialServerException -> ShowS
$cshow :: MercurialServerException -> String
show :: MercurialServerException -> String
$cshowList :: [MercurialServerException] -> ShowS
showList :: [MercurialServerException] -> ShowS
Show,Typeable)
instance Exception MercurialServerException

-- | Read a single message
readMessage :: Handle -> IO MercurialMessage
readMessage :: Handle -> IO MercurialMessage
readMessage Handle
hout = do
    ByteString
buf <- Handle -> Int -> IO ByteString
B.hGet Handle
hout Int
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
$ String -> MercurialServerException
MercurialServerException String
"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
$ String -> MercurialServerException
MercurialServerException (String -> MercurialServerException)
-> String -> MercurialServerException
forall a b. (a -> b) -> a -> b
$ String
"Unknown channel " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
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
$ String -> MercurialServerException
MercurialServerException String
"Mercurial did not produce enough output"
    case Char
c of
      Char
'r' | Int
len Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
4 -> MercurialMessage -> IO MercurialMessage
forall a. a -> IO a
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
      Char
'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
$ String -> MercurialServerException
MercurialServerException (String -> MercurialServerException)
-> String -> MercurialServerException
forall a b. (a -> b) -> a -> b
$ String
"return value is fewer than 4 bytes"
      Char
'o'            -> MercurialMessage -> IO MercurialMessage
forall a. a -> IO a
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
      Char
'e'            -> MercurialMessage -> IO MercurialMessage
forall a. a -> IO a
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
_ | Char -> Bool
isLower Char
c  -> Handle -> IO MercurialMessage
readMessage Handle
hout -- skip this message
      Char
_              -> 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
$ String -> MercurialServerException
MercurialServerException (String -> MercurialServerException)
-> String -> MercurialServerException
forall a b. (a -> b) -> a -> b
$ String
"Unknown channel " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Char -> String
forall a. Show a => a -> String
show Char
c

-- | Read a 32-bit big-endian into an Int
hReadWord32be :: Handle -> IO Int
hReadWord32be :: Handle -> IO Int
hReadWord32be Handle
h = do
    ByteString
s <- Handle -> Int -> IO ByteString
B.hGet Handle
h Int
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
/= Int
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
$ String -> MercurialServerException
MercurialServerException String
"unable to read int"
    Int -> IO Int
forall a. a -> IO a
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 ByteString
s = (Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString
s HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
`B.index` Int
0) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
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 HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
`B.index` Int
1) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL` Int
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 HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
`B.index` Int
2) Int -> Int -> Int
forall a. Bits a => a -> Int -> a
`shiftL`  Int
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 HasCallStack => ByteString -> Int -> Word8
ByteString -> Int -> Word8
`B.index` Int
3) )

-- | Write a Word32 in big-endian to the handle
hWriteWord32be :: Handle -> Word32 -> IO ()
hWriteWord32be :: Handle -> Word32 -> IO ()
hWriteWord32be Handle
h 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` Int
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` Int
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`  Int
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 String [(Handle, Handle, Handle)]
serverHandles    :: M.Map FilePath [(Handle,Handle,Handle)]
} deriving (Int -> MercurialGlobalState -> ShowS
[MercurialGlobalState] -> ShowS
MercurialGlobalState -> String
(Int -> MercurialGlobalState -> ShowS)
-> (MercurialGlobalState -> String)
-> ([MercurialGlobalState] -> ShowS)
-> Show MercurialGlobalState
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MercurialGlobalState -> ShowS
showsPrec :: Int -> MercurialGlobalState -> ShowS
$cshow :: MercurialGlobalState -> String
show :: MercurialGlobalState -> String
$cshowList :: [MercurialGlobalState] -> ShowS
showList :: [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 String [(Handle, Handle, Handle)] -> MercurialGlobalState
MercurialGlobalState Maybe Bool
forall a. Maybe a
Nothing Map String [(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 :: String -> IO (Maybe (Handle, Handle, Handle))
getServer String
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 Bool
False -> Maybe (Handle, Handle, Handle)
-> IO (Maybe (Handle, Handle, Handle))
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Handle, Handle, Handle)
forall a. Maybe a
Nothing
      Maybe Bool
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
$ \MercurialGlobalState
state ->
                          (MercurialGlobalState
state { useCommandServer :: Maybe Bool
useCommandServer = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
isok }, ())
                       String -> IO (Maybe (Handle, Handle, Handle))
getServer String
repo
      Just Bool
True  -> String -> IO (Maybe (Handle, Handle, Handle))
allocateServer String
repo

-- | Helper function called once we know that mercurial supports servers
allocateServer :: FilePath -> IO (Maybe (Handle, Handle, Handle))
allocateServer :: String -> IO (Maybe (Handle, Handle, Handle))
allocateServer String
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
$ \MercurialGlobalState
state ->
             case String
-> Map String [(Handle, Handle, Handle)]
-> Maybe [(Handle, Handle, Handle)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
repo (MercurialGlobalState -> Map String [(Handle, Handle, Handle)]
serverHandles MercurialGlobalState
state) of
                Just ((Handle, Handle, Handle)
x:[(Handle, Handle, Handle)]
xs) -> (MercurialGlobalState
state { serverHandles :: Map String [(Handle, Handle, Handle)]
serverHandles = String
-> [(Handle, Handle, Handle)]
-> Map String [(Handle, Handle, Handle)]
-> Map String [(Handle, Handle, Handle)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
repo [(Handle, Handle, Handle)]
xs (MercurialGlobalState -> Map String [(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)
                Maybe [(Handle, Handle, Handle)]
_           -> (MercurialGlobalState
state, () -> Either () (Handle, Handle, Handle)
forall a b. a -> Either a b
Left ())
    case Either () (Handle, Handle, Handle)
ret of
      Right (Handle, Handle, Handle)
x -> Maybe (Handle, Handle, Handle)
-> IO (Maybe (Handle, Handle, Handle))
forall a. a -> IO a
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
<$> String -> IO (Handle, Handle, Handle)
createServer String
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 :: String -> (Handle, Handle, Handle) -> IO ()
putServer String
repo (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
$ \MercurialGlobalState
state -> do
              case String
-> Map String [(Handle, Handle, Handle)]
-> Maybe [(Handle, Handle, Handle)]
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup String
repo (MercurialGlobalState -> Map String [(Handle, Handle, Handle)]
serverHandles MercurialGlobalState
state) of
                  Just [(Handle, Handle, Handle)]
xs | [(Handle, Handle, Handle)] -> Int
forall a. [a] -> 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 [(Handle, Handle, Handle)]
xs -> (MercurialGlobalState
state { serverHandles :: Map String [(Handle, Handle, Handle)]
serverHandles = String
-> [(Handle, Handle, Handle)]
-> Map String [(Handle, Handle, Handle)]
-> Map String [(Handle, Handle, Handle)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
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 String [(Handle, Handle, Handle)]
serverHandles MercurialGlobalState
state)}, () -> Either () ()
forall a b. a -> Either a b
Left ())
                  Maybe [(Handle, Handle, Handle)]
Nothing -> (MercurialGlobalState
state { serverHandles :: Map String [(Handle, Handle, Handle)]
serverHandles = String
-> [(Handle, Handle, Handle)]
-> Map String [(Handle, Handle, Handle)]
-> Map String [(Handle, Handle, Handle)]
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
repo [(Handle, Handle, Handle)
h] (MercurialGlobalState -> Map String [(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 a. a -> IO a
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
    | String -> Bool
isOperatingSystem String
"mingw32" = Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    | Bool
otherwise                   = do
        (ExitCode
status,ByteString
_,ByteString
out) <- String
-> Maybe [(String, String)]
-> String
-> [String]
-> IO (ExitCode, ByteString, ByteString)
runShellCommand String
"." Maybe [(String, String)]
forall a. Maybe a
Nothing String
"hg" [String
"version", String
"-q"]
        case ExitCode
status of
          ExitFailure Int
_ -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
          ExitCode
ExitSuccess   -> Bool -> IO Bool
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ String -> [Int]
parseVersion (ByteString -> String
LUTF8.toString ByteString
out) [Int] -> [Int] -> Bool
forall a. Ord a => a -> a -> Bool
>= [Int
2,Int
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 :: String -> Bool
isOperatingSystem String
sys = String
SI.os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
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 :: String -> [Int]
parseVersion String
b = if Bool
starts then [Int]
verLst else [Int
0]
  where msg :: String
msg = String
"Mercurial Distributed SCM (version "
        starts :: Bool
starts = String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
msg String
b
        ver :: String
ver    = (Char -> Bool) -> ShowS
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
')') ShowS -> ShowS
forall a b. (a -> b) -> a -> b
$ Int -> ShowS
forall a. Int -> [a] -> [a]
drop (String -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
msg) String
b
        verLst :: [Int]
verLst = (String -> Int) -> [String] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map String -> Int
forall a. Read a => String -> a
read ([String] -> [Int]) -> [String] -> [Int]
forall a b. (a -> b) -> a -> b
$ String -> String -> [String]
forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." String
ver