{-# 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 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
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 (forall a. a -> Maybe a
Just [(String, String)]
env) String
"hg" (String
command forall a. a -> [a] -> [a]
: [String]
args)
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"] (forall a. a -> Maybe a
Just String
repo) forall a. Maybe a
Nothing
MercurialMessage
hello <- Handle -> IO MercurialMessage
readMessage Handle
hout
case MercurialMessage
hello of
MessageO ByteString
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Handle
hin,Handle
hout,Handle
herr)
MessageE ByteString
x -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> MercurialServerException
MercurialServerException (ByteString -> String
UTF8.toString ByteString
x)
MercurialMessage
_ -> forall e a. Exception e => e -> IO a
throwIO 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 forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hClose Handle
hout 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 forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [[a]] -> [a]
intercalate String
"\0" forall a b. (a -> b) -> a -> b
$ String
cmd 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 forall a b. (a -> b) -> a -> b
$ forall a b. (Integral a, Num b) => a -> b
fromIntegral 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 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 forall a b. (a -> b) -> a -> b
$ [ByteString] -> ByteString
BL.fromChunks [ByteString
x])
MessageR Int
c -> if Int
c forall a. Eq a => a -> a -> Bool
== Int
0
then forall (m :: * -> *) a. Monad m => a -> m a
return (ExitCode
ExitSuccess, String
"", ByteString
out)
else 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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MercurialServerException] -> ShowS
$cshowList :: [MercurialServerException] -> ShowS
show :: MercurialServerException -> String
$cshow :: MercurialServerException -> String
showsPrec :: Int -> MercurialServerException -> ShowS
$cshowsPrec :: Int -> 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString
buf forall a. Eq a => a -> a -> Bool
== ByteString
B.empty) forall a b. (a -> b) -> a -> b
$
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> MercurialServerException
MercurialServerException String
"Unknown channel"
let c :: Char
c = ByteString -> Char
B8.head ByteString
buf
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Char -> Bool
isUpper Char
c) forall a b. (a -> b) -> a -> b
$
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> MercurialServerException
MercurialServerException forall a b. (a -> b) -> a -> b
$ String
"Unknown channel " forall a. [a] -> [a] -> [a]
++ 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
bdata forall a. Eq a => a -> a -> Bool
/= Int
len) forall a b. (a -> b) -> a -> b
$
forall e a. Exception e => e -> IO a
throwIO 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 forall a. Ord a => a -> a -> Bool
>= Int
4 -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> MercurialMessage
MessageR forall a b. (a -> b) -> a -> b
$ ByteString -> Int
bsReadWord32be ByteString
bdata
Char
'r' -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> MercurialServerException
MercurialServerException forall a b. (a -> b) -> a -> b
$ String
"return value is fewer than 4 bytes"
Char
'o' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> MercurialMessage
MessageO ByteString
bdata
Char
'e' -> forall (m :: * -> *) a. Monad m => a -> m a
return 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
_ -> forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> MercurialServerException
MercurialServerException forall a b. (a -> b) -> a -> b
$ String
"Unknown channel " forall a. [a] -> [a] -> [a]
++ 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
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ByteString -> Int
B.length ByteString
s forall a. Eq a => a -> a -> Bool
/= Int
4) forall a b. (a -> b) -> a -> b
$
forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> MercurialServerException
MercurialServerException String
"unable to read int"
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ByteString -> Int
bsReadWord32be ByteString
s
bsReadWord32be :: B.ByteString -> Int
bsReadWord32be :: ByteString -> Int
bsReadWord32be ByteString
s = (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString
s HasCallStack => ByteString -> Int -> Word8
`B.index` Int
0) forall a. Bits a => a -> Int -> a
`shiftL` Int
24) forall a. Bits a => a -> a -> a
.|.
(forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString
s HasCallStack => ByteString -> Int -> Word8
`B.index` Int
1) forall a. Bits a => a -> Int -> a
`shiftL` Int
16) forall a. Bits a => a -> a -> a
.|.
(forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString
s HasCallStack => ByteString -> Int -> Word8
`B.index` Int
2) forall a. Bits a => a -> Int -> a
`shiftL` Int
8) forall a. Bits a => a -> a -> a
.|.
(forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString
s HasCallStack => 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 [
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w forall a. Bits a => a -> Int -> a
`shiftR` Int
24),
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w forall a. Bits a => a -> Int -> a
`shiftR` Int
16),
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32
w forall a. Bits a => a -> Int -> a
`shiftR` Int
8),
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
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MercurialGlobalState] -> ShowS
$cshowList :: [MercurialGlobalState] -> ShowS
show :: MercurialGlobalState -> String
$cshow :: MercurialGlobalState -> String
showsPrec :: Int -> MercurialGlobalState -> ShowS
$cshowsPrec :: Int -> MercurialGlobalState -> ShowS
Show)
mercurialGlobalVar :: IORef MercurialGlobalState
{-# NOINLINE mercurialGlobalVar #-}
mercurialGlobalVar :: IORef MercurialGlobalState
mercurialGlobalVar = forall a. IO a -> a
unsafePerformIO (forall a. a -> IO (IORef a)
newIORef (Maybe Bool
-> Map String [(Handle, Handle, Handle)] -> MercurialGlobalState
MercurialGlobalState forall a. Maybe a
Nothing 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef IORef MercurialGlobalState
mercurialGlobalVar
case Maybe Bool
use of
Just Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Maybe Bool
Nothing -> do Bool
isok <- IO Bool
checkVersion
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef MercurialGlobalState
mercurialGlobalVar forall a b. (a -> b) -> a -> b
$ \MercurialGlobalState
state ->
(MercurialGlobalState
state { useCommandServer :: Maybe Bool
useCommandServer = 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 <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef MercurialGlobalState
mercurialGlobalVar forall a b. (a -> b) -> a -> b
$ \MercurialGlobalState
state ->
case 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 = 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)}, forall a b. b -> Either a b
Right (Handle, Handle, Handle)
x)
Maybe [(Handle, Handle, Handle)]
_ -> (MercurialGlobalState
state, forall a b. a -> Either a b
Left ())
case Either () (Handle, Handle, Handle)
ret of
Right (Handle, Handle, Handle)
x -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (Handle, Handle, Handle)
x
Left () -> forall a. a -> Maybe a
Just 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 <- forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef IORef MercurialGlobalState
mercurialGlobalVar forall a b. (a -> b) -> a -> b
$ \MercurialGlobalState
state -> do
case 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 | forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Handle, Handle, Handle)]
xs forall a. Ord a => a -> a -> Bool
>= Int
maxPoolSize -> (MercurialGlobalState
state, forall a b. b -> Either a b
Right ())
Just [(Handle, Handle, Handle)]
xs -> (MercurialGlobalState
state { serverHandles :: Map String [(Handle, Handle, Handle)]
serverHandles = forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert String
repo ((Handle, Handle, Handle)
hforall a. a -> [a] -> [a]
:[(Handle, Handle, Handle)]
xs) (MercurialGlobalState -> Map String [(Handle, Handle, Handle)]
serverHandles MercurialGlobalState
state)}, forall a b. a -> Either a b
Left ())
Maybe [(Handle, Handle, Handle)]
Nothing -> (MercurialGlobalState
state { serverHandles :: Map String [(Handle, Handle, Handle)]
serverHandles = 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)}, forall a b. a -> Either a b
Left ())
case Either () ()
ret of
Right () -> (Handle, Handle, Handle) -> IO ()
cleanupServer (Handle, Handle, Handle)
h
Left () -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkVersion :: IO Bool
checkVersion :: IO Bool
checkVersion
| String -> Bool
isOperatingSystem String
"mingw32" = 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
"." forall a. Maybe a
Nothing String
"hg" [String
"version", String
"-q"]
case ExitCode
status of
ExitFailure Int
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
ExitCode
ExitSuccess -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ String -> [Int]
parseVersion (ByteString -> String
LUTF8.toString ByteString
out) forall a. Ord a => a -> a -> Bool
>= [Int
2,Int
0]
isOperatingSystem :: String -> Bool
isOperatingSystem :: String -> Bool
isOperatingSystem String
sys = String
SI.os 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 = forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf String
msg String
b
ver :: String
ver = forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
')') forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length String
msg) String
b
verLst :: [Int]
verLst = forall a b. (a -> b) -> [a] -> [b]
map forall a. Read a => String -> a
read forall a b. (a -> b) -> a -> b
$ forall a. Eq a => [a] -> [a] -> [[a]]
splitOn String
"." String
ver