{-# 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 = 2
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
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)
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"
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
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
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
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
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
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
_ -> 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
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
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) )
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 [
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
]
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)
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))
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
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
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 ()
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]
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
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