1 -- Copyright (C) 2005 Tomasz Zielonka
    2 --
    3 -- This program is free software; you can redistribute it and/or modify
    4 -- it under the terms of the GNU General Public License as published by
    5 -- the Free Software Foundation; either version 2, or (at your option)
    6 -- any later version.
    7 --
    8 -- This program is distributed in the hope that it will be useful,
    9 -- but WITHOUT ANY WARRANTY; without even the implied warranty of
   10 -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   11 -- GNU General Public License for more details.
   12 --
   13 -- You should have received a copy of the GNU General Public License
   14 -- along with this program; see the file COPYING.  If not, write to
   15 -- the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
   16 -- Boston, MA 02110-1301, USA.
   17 
   18 {-# LANGUAGE CPP #-}
   19 -- | This was originally Tomasz Zielonka's AtExit module, slightly generalised
   20 -- to include global variables.  Here, we attempt to cover broad, global
   21 -- features, such as exit handlers.  These features slightly break the Haskellian
   22 -- purity of darcs, in favour of programming convenience.
   23 module Darcs.Global ( atexit, with_atexit,
   24                       sshControlMasterDisabled, setSshControlMasterDisabled,
   25                       verboseMode, setVerboseMode,
   26                       timingsMode, setTimingsMode,
   27                       whenDebugMode, withDebugMode, setDebugMode,
   28                       debugMessage, debugFail, putTiming,
   29                       addCRCWarning, getCRCWarnings, resetCRCWarnings,
   30                       darcsdir
   31     ) where
   32 
   33 import Control.Monad ( when )
   34 import Control.Concurrent.MVar
   35 import Control.Exception (bracket_, catch, block, unblock)
   36 import Data.IORef ( IORef, newIORef, readIORef, writeIORef )
   37 import Data.IORef ( modifyIORef )
   38 import System.IO.Unsafe (unsafePerformIO)
   39 import System.IO (hPutStrLn, hPutStr, stderr)
   40 import System.Time ( calendarTimeToString, toCalendarTime, getClockTime )
   41 import Prelude hiding (catch)
   42 
   43 {-# NOINLINE atexit_actions #-}
   44 atexit_actions :: MVar (Maybe [IO ()])
   45 atexit_actions = unsafePerformIO (newMVar (Just []))
   46 
   47 -- | Registers an IO action to run just before darcs exits.  Useful
   48 -- for removing temporary files and directories, for example.
   49 atexit :: IO () -> IO ()
   50 atexit action = do
   51     modifyMVar_ atexit_actions $ \ml -> do
   52         case ml of
   53             Just l -> do
   54                 return (Just (action : l))
   55             Nothing -> do
   56                 hPutStrLn stderr "It's too late to use atexit"
   57                 return Nothing
   58 
   59 with_atexit :: IO a -> IO a
   60 with_atexit prog = do
   61     bracket_
   62         (return ())
   63         exit
   64         prog
   65   where
   66     exit = block $ do
   67         Just actions <- swapMVar atexit_actions Nothing
   68         -- from now on atexit will not register new actions
   69         mapM_ runAction actions
   70     runAction action = do
   71         catch (unblock action) $ \exn -> do
   72             hPutStrLn stderr $ "Exception thrown by an atexit registered action:"
   73             hPutStrLn stderr $ show exn
   74 
   75 
   76 -- Write-once-read-many global variables make it easier to implement flags, such
   77 -- as --no-ssh-cm.  Using global variables reduces the number of parameters
   78 -- that we have to pass around, but it is rather unsafe and should be used sparingly.
   79 
   80 {-# NOINLINE _debugMode #-}
   81 _debugMode :: IORef Bool
   82 _debugMode = unsafePerformIO $ newIORef False
   83 
   84 setDebugMode :: IO ()
   85 setDebugMode = writeIORef _debugMode True
   86 
   87 whenDebugMode :: IO () -> IO ()
   88 whenDebugMode j = do b <- readIORef _debugMode
   89                      when b j
   90 
   91 withDebugMode :: (Bool -> IO a) -> IO a
   92 withDebugMode j = readIORef _debugMode >>= j
   93 
   94 
   95 debugMessage :: String -> IO ()
   96 debugMessage m = whenDebugMode $ do putTiming; hPutStrLn stderr m
   97 
   98 debugFail :: String -> IO a
   99 debugFail m = debugMessage m >> fail m
  100 
  101 putTiming :: IO ()
  102 putTiming = when timingsMode $ do t <- getClockTime >>= toCalendarTime
  103                                   hPutStr stderr (calendarTimeToString t++": ")
  104 
  105 {-# NOINLINE _timingsMode #-}
  106 _timingsMode :: IORef Bool
  107 _timingsMode = unsafePerformIO $ newIORef False
  108 
  109 setTimingsMode :: IO ()
  110 setTimingsMode = writeIORef _timingsMode True
  111 
  112 {-# NOINLINE timingsMode #-}
  113 timingsMode :: Bool
  114 timingsMode = unsafePerformIO $ readIORef _timingsMode
  115 
  116 {-# NOINLINE _verboseMode #-}
  117 _verboseMode :: IORef Bool
  118 _verboseMode = unsafePerformIO $ newIORef False
  119 
  120 setVerboseMode :: IO ()
  121 setVerboseMode = writeIORef _verboseMode True
  122 
  123 {-# NOINLINE verboseMode #-}
  124 verboseMode :: Bool
  125 verboseMode = unsafePerformIO $ readIORef _verboseMode
  126 
  127 {-# NOINLINE _sshControlMasterDisabled #-}
  128 _sshControlMasterDisabled :: IORef Bool
  129 _sshControlMasterDisabled = unsafePerformIO $ newIORef False
  130 
  131 setSshControlMasterDisabled :: IO ()
  132 setSshControlMasterDisabled = writeIORef _sshControlMasterDisabled True
  133 
  134 {-# NOINLINE sshControlMasterDisabled #-}
  135 sshControlMasterDisabled :: Bool
  136 sshControlMasterDisabled = unsafePerformIO $ readIORef _sshControlMasterDisabled
  137 
  138 type CRCWarningList = [FilePath]
  139 {-# NOINLINE _crcWarningList #-}
  140 _crcWarningList :: IORef CRCWarningList
  141 _crcWarningList = unsafePerformIO $ newIORef []
  142 
  143 addCRCWarning :: FilePath -> IO ()
  144 addCRCWarning fp = modifyIORef _crcWarningList (fp:)
  145 
  146 getCRCWarnings :: IO [FilePath]
  147 getCRCWarnings = readIORef _crcWarningList
  148 
  149 resetCRCWarnings :: IO ()
  150 resetCRCWarnings = writeIORef _crcWarningList []
  151 
  152 darcsdir :: String
  153 darcsdir = "_darcs"