module Darcs.Global
(
atexit
, withAtexit
, SshSettings(..)
, defaultSsh
, timingsMode
, setTimingsMode
, whenDebugMode
, withDebugMode
, setDebugMode
, debugMessage
, debugFail
, putTiming
, addCRCWarning
, getCRCWarnings
, resetCRCWarnings
, addBadSource
, getBadSourcesList
, isBadSource
, darcsdir
, isReachableSource
, addReachableSource
, windows
) where
import Control.Applicative ( (<$>), (<*>) )
import Control.Monad ( when )
import Control.Concurrent.MVar
import Control.Exception.Extensible ( bracket_, catch, catchJust, SomeException
, block, unblock
)
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
import Data.IORef ( modifyIORef )
import Data.List ( isPrefixOf )
import System.Info ( os )
import System.IO.Unsafe (unsafePerformIO)
import System.IO (hPutStrLn, hPutStr, stderr)
import System.IO.Error ( ioeGetErrorType, isDoesNotExistErrorType )
import System.Process ( readProcessWithExitCode )
import System.Time ( calendarTimeToString, toCalendarTime, getClockTime )
import System.Environment ( getEnv )
import Prelude hiding (catch)
windows :: Bool
windows = "mingw" `isPrefixOf` os
atexitActions :: MVar (Maybe [IO ()])
atexitActions = unsafePerformIO (newMVar (Just []))
atexit :: IO ()
-> IO ()
atexit action =
modifyMVar_ atexitActions $ \ml ->
case ml of
Just l ->
return (Just (action : l))
Nothing -> do
hPutStrLn stderr "It's too late to use atexit"
return Nothing
withAtexit :: IO a -> IO a
withAtexit prog =
bracket_
(return ())
exit
prog
where
exit = block $ do
Just actions <- swapMVar atexitActions Nothing
mapM_ runAction actions
runAction action =
catch (unblock action) $ \(exn :: SomeException) -> do
hPutStrLn stderr $ "Exception thrown by an atexit registered action:"
hPutStrLn stderr $ show exn
_debugMode :: IORef Bool
_debugMode = unsafePerformIO $ newIORef False
setDebugMode :: IO ()
setDebugMode = writeIORef _debugMode True
whenDebugMode :: IO () -> IO ()
whenDebugMode j = do b <- readIORef _debugMode
when b j
withDebugMode :: (Bool -> IO a) -> IO a
withDebugMode j = readIORef _debugMode >>= j
debugMessage :: String -> IO ()
debugMessage m = whenDebugMode $ do putTiming; hPutStrLn stderr m
debugFail :: String -> IO a
debugFail m = debugMessage m >> fail m
putTiming :: IO ()
putTiming = when timingsMode $ do
t <- getClockTime >>= toCalendarTime
hPutStr stderr (calendarTimeToString t++": ")
_timingsMode :: IORef Bool
_timingsMode = unsafePerformIO $ newIORef False
setTimingsMode :: IO ()
setTimingsMode = writeIORef _timingsMode True
timingsMode :: Bool
timingsMode = unsafePerformIO $ readIORef _timingsMode
data SshSettings = SshSettings
{ ssh :: String
, scp :: String
, sftp :: String
} deriving (Show, Eq)
_defaultSsh :: IORef SshSettings
_defaultSsh = unsafePerformIO $ newIORef =<< detectSsh
detectSsh :: IO SshSettings
detectSsh = do
whenDebugMode (putStrLn "Detecting SSH settings")
vanilla <- if windows
then do
plinkStr <- (snd3 <$> readProcessWithExitCode "plink" [] "")
`catch` \(e :: SomeException) -> return (show e)
whenDebugMode $ putStrLn $
"SSH settings (plink): " ++
(concat . take 1 . lines $ plinkStr)
if "PuTTY" `isPrefixOf` plinkStr
then return (SshSettings "plink" "pscp -q" "psftp")
else return rawVanilla
else return rawVanilla
settings <- SshSettings <$> fromEnv (ssh vanilla) "DARCS_SSH"
<*> fromEnv (scp vanilla) "DARCS_SCP"
<*> fromEnv (sftp vanilla) "DARCS_SFTP"
whenDebugMode (putStrLn $ "SSH settings: " ++ show settings)
return settings
where
snd3 (_, x, _) = x
rawVanilla = SshSettings "ssh" "scp -q" "sftp"
fromEnv :: String -> String -> IO String
fromEnv d v = catchJust notFound
(getEnv v)
(const (return d))
notFound e = if isDoesNotExistErrorType (ioeGetErrorType e)
then Just ()
else Nothing
defaultSsh :: SshSettings
defaultSsh = unsafePerformIO $ readIORef _defaultSsh
type CRCWarningList = [FilePath]
_crcWarningList :: IORef CRCWarningList
_crcWarningList = unsafePerformIO $ newIORef []
addCRCWarning :: FilePath -> IO ()
addCRCWarning fp = modifyIORef _crcWarningList (fp:)
getCRCWarnings :: IO [FilePath]
getCRCWarnings = readIORef _crcWarningList
resetCRCWarnings :: IO ()
resetCRCWarnings = writeIORef _crcWarningList []
_badSourcesList :: IORef [String]
_badSourcesList = unsafePerformIO $ newIORef []
addBadSource :: String -> IO ()
addBadSource cache = modifyIORef _badSourcesList (cache:)
getBadSourcesList :: IO [String]
getBadSourcesList = readIORef _badSourcesList
isBadSource :: IO (String -> Bool)
isBadSource = do
badSources <- getBadSourcesList
return (`elem` badSources)
_reachableSourcesList :: IORef [String]
_reachableSourcesList = unsafePerformIO $ newIORef []
addReachableSource :: String -> IO ()
addReachableSource src = modifyIORef _reachableSourcesList (src:)
getReachableSources :: IO [String]
getReachableSources = readIORef _reachableSourcesList
isReachableSource :: IO (String -> Bool)
isReachableSource = do
reachableSources <- getReachableSources
return (`elem` reachableSources)
darcsdir :: String
darcsdir = "_darcs"