Global.hs

-- Copyright (C) 2005 Tomasz Zielonka
--
-- This program is free software; you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation; either version 2, or (at your option)
-- any later version.
--
-- This program is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program; see the file COPYING.  If not, write to
-- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
-- Boston, MA 02110-1301, USA.

{-# LANGUAGE CPP #-}
-- | This was originally Tomasz Zielonka's AtExit module, slightly generalised
-- to include global variables.  Here, we attempt to cover broad, global
-- features, such as exit handlers.  These features slightly break the Haskellian
-- purity of darcs, in favour of programming convenience.
module Darcs.Global ( atexit, withAtexit,
                      sshControlMasterDisabled, setSshControlMasterDisabled,
                      verboseMode, setVerboseMode,
                      timingsMode, setTimingsMode,
                      whenDebugMode, withDebugMode, setDebugMode,
                      debugMessage, debugFail, putTiming,
                      addCRCWarning, getCRCWarnings, resetCRCWarnings,
                      addBadCache, getBadCacheList, isBadCache, darcsdir,
                      isReachableHttp, addReachableHttp
    ) where

import Control.Monad ( when )
import Control.Concurrent.MVar
import Control.Exception.Extensible (bracket_, catch, block, unblock, SomeException)
import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
import Data.IORef ( modifyIORef )
import Data.List ( elem )
import System.IO.Unsafe (unsafePerformIO)
import System.IO (hPutStrLn, hPutStr, stderr)
import System.Time ( calendarTimeToString, toCalendarTime, getClockTime )
import Prelude hiding (catch)
import English ( englishNum, Noun(..) )

{-# NOINLINE atexitActions #-}
atexitActions :: MVar (Maybe [IO ()])
atexitActions = unsafePerformIO (newMVar (Just []))

-- | Registers an IO action to run just before darcs exits.  Useful
-- for removing temporary files and directories, for example.
atexit :: IO () -> IO ()
atexit action = do
    modifyMVar_ atexitActions $ \ml -> do
        case ml of
            Just l -> do
                return (Just (action : l))
            Nothing -> do
                hPutStrLn stderr "It's too late to use atexit"
                return Nothing

withAtexit :: IO a -> IO a
withAtexit prog = do
    bracket_
        (return ())
        exit
        prog
  where
    exit = block $ do
        Just actions <- swapMVar atexitActions Nothing
        -- from now on atexit will not register new actions
        mapM_ runAction actions
        badCaches <- getBadCacheList
        when ( not $ null badCaches ) $ reportBadCaches badCaches
    runAction action = do
        catch (unblock action) $ \(exn :: SomeException) -> do
            hPutStrLn stderr $ "Exception thrown by an atexit registered action:"
            hPutStrLn stderr $ show exn
    reportBadCaches caches = do
        hPutStrLn stderr $ "I could not reach the following " ++
          englishNum (length caches)  (Noun "repository") " (listed in _darcs/prefs/sources):"
        hPutStrLn stderr $ (unlines caches) ++  "\nIt is recommendable to delete those " ++
         englishNum (length caches)  (Noun "entry") " if not used"

-- Write-once-read-many global variables make it easier to implement flags, such
-- as --no-ssh-cm.  Using global variables reduces the number of parameters
-- that we have to pass around, but it is rather unsafe and should be used sparingly.

{-# NOINLINE _debugMode #-}
_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++": ")

{-# NOINLINE _timingsMode #-}
_timingsMode :: IORef Bool
_timingsMode = unsafePerformIO $ newIORef False

setTimingsMode :: IO ()
setTimingsMode = writeIORef _timingsMode True

{-# NOINLINE timingsMode #-}
timingsMode :: Bool
timingsMode = unsafePerformIO $ readIORef _timingsMode

{-# NOINLINE _verboseMode #-}
_verboseMode :: IORef Bool
_verboseMode = unsafePerformIO $ newIORef False

setVerboseMode :: IO ()
setVerboseMode = writeIORef _verboseMode True

{-# NOINLINE verboseMode #-}
verboseMode :: Bool
verboseMode = unsafePerformIO $ readIORef _verboseMode

{-# NOINLINE _sshControlMasterDisabled #-}
_sshControlMasterDisabled :: IORef Bool
_sshControlMasterDisabled = unsafePerformIO $ newIORef False

setSshControlMasterDisabled :: IO ()
setSshControlMasterDisabled = writeIORef _sshControlMasterDisabled True

{-# NOINLINE sshControlMasterDisabled #-}
sshControlMasterDisabled :: Bool
sshControlMasterDisabled = unsafePerformIO $ readIORef _sshControlMasterDisabled

type CRCWarningList = [FilePath]
{-# NOINLINE _crcWarningList #-}
_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 []

type BadCacheList = [String]
{- NOINLINE _badCacheList -}
_badCacheList :: IORef BadCacheList
_badCacheList = unsafePerformIO $ newIORef []

addBadCache :: String -> IO ()
addBadCache cache = modifyIORef _badCacheList (cache:)

getBadCacheList :: IO [String]
getBadCacheList = readIORef _badCacheList

isBadCache :: IO (String -> Bool)
isBadCache = do badCaches <- getBadCacheList
                return (`elem` badCaches)

{- NOINLINE _trustedHttpList -}
_reachableHttpList :: IORef [String]
_reachableHttpList = unsafePerformIO $ newIORef []

addReachableHttp :: String -> IO ()
addReachableHttp http = modifyIORef _reachableHttpList (http:)

getReachableHttps :: IO [String]
getReachableHttps = readIORef _reachableHttpList

isReachableHttp :: IO (String -> Bool)
isReachableHttp =  do reachableHttps <- getReachableHttps
                      return (`elem` reachableHttps)

darcsdir :: String
darcsdir = "_darcs"