{-# LANGUAGE DeriveDataTypeable #-}
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
maxPoolSize :: Int
maxPoolSize :: Int
maxPoolSize = Int
2
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
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)
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"
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
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
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
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
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
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
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
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
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) )
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 [
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
]
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)
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))
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
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
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 ()
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]
isOperatingSystem :: String -> Bool
isOperatingSystem :: String -> Bool
isOperatingSystem String
sys = String
SI.os String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
sys
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