    {-# 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
      server <- String -> IO (Maybe (Handle, Handle, Handle))
    getServer String
    repo
      case 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 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
                       putServer repo h
                       return 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")]
       (status, err, 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)
       return (status, LUTF8.toString err, 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
        (hin,hout,herr,_) <- 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
        hello <- readMessage hout
        case 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. (HasCallStack, 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. (HasCallStack, 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 m <- Handle -> IO MercurialMessage
    readMessage Handle
    hout
                 case 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
        buf <- Handle -> Int -> IO ByteString
    B.hGet Handle
    hout Int
    1
        when (buf == B.empty) $
           throwIO $ MercurialServerException "Unknown channel"
        let 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.
        when (isUpper c) $
           throwIO $ MercurialServerException $ "Unknown channel " ++ show c
        len <- hReadWord32be hout
        bdata <- B.hGet hout len
        when (B.length bdata /= len) $
           throwIO $ MercurialServerException "Mercurial did not produce enough output"
        case 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. (HasCallStack, 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. (HasCallStack, 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
        s <- Handle -> Int -> IO ByteString
    B.hGet Handle
    h Int
    4
        when (B.length s /= 4) $
          throwIO $ MercurialServerException "unable to read int"
        return $ bsReadWord32be 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
        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 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 isok <- IO Bool
    checkVersion
                           atomicModifyIORef mercurialGlobalVar $ \MercurialGlobalState
    state ->
                              (MercurialGlobalState
    state { useCommandServer = Just isok }, ())
                           getServer 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
        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 = M.insert repo xs (serverHandles 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 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
        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 = M.insert repo (h:xs) (serverHandles state)}, () -> Either () ()
    forall a b. a -> Either a b
    Left ())
                      Maybe [(Handle, Handle, Handle)]
    Nothing -> (MercurialGlobalState
    state { serverHandles = M.insert repo [h] (serverHandles state)}, () -> Either () ()
    forall a b. a -> Either a b
    Left ())
        case 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
            (status,_,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 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