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