diff --git a/ConfigFile.hs b/ConfigFile.hs --- a/ConfigFile.hs +++ b/ConfigFile.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module ConfigFile( configLookupBool, configLookup, @@ -19,6 +20,7 @@ ) where +import qualified Control.Exception as E import Data.Char import System.Environment import System.IO.Unsafe @@ -89,13 +91,13 @@ case lookup fn cf of Just cl -> basicLookup fn cl k Nothing -> do - cl <- catchMost (fmap parseConfigFile $ readFile fn) (\_ -> return []) + cl <- E.catch (fmap parseConfigFile $ readFile fn) (\(_ :: E.IOException) -> return []) mapVal config_files_var ((fn,cl):) basicLookup fn cl k configEnv :: Config configEnv = Config $ \k -> do - ev <- catch (fmap return $ getEnv k) (\_ -> return []) + ev <- E.catch (fmap return $ getEnv k) (\(_ :: E.IOException) -> return []) return $ fmap (\v -> ("enviornment", (k,v))) ev mapConfig :: (String -> String) -> Config -> Config diff --git a/Curses.hsc b/Curses.hsc --- a/Curses.hsc +++ b/Curses.hsc @@ -149,7 +149,7 @@ throwIfErr s = throwIf (== (#const ERR)) (\a -> "Curses[" ++ show a ++ "]:" ++ s) throwIfErr_ :: (Num a, Eq a, Show a) => String -> IO a -> IO () -throwIfErr_ name act = void $ throwIfErr name act +throwIfErr_ name act = throwIfErr name act >> return () ------------------------------------------------------------------------ diff --git a/Doc/DocLike.hs b/Doc/DocLike.hs --- a/Doc/DocLike.hs +++ b/Doc/DocLike.hs @@ -1,7 +1,7 @@ {-# LANGUAGE UndecidableInstances, OverlappingInstances, TypeSynonymInstances, FlexibleInstances #-} module Doc.DocLike where -import Data.Monoid hiding ((<>)) +-- import Data.Monoid hiding ((<>)) import Control.Monad.Reader() import Data.List import qualified Text.PrettyPrint.HughesPJ as P diff --git a/ErrorLog.hs b/ErrorLog.hs --- a/ErrorLog.hs +++ b/ErrorLog.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} -- Copyright (c) 2002 John Meacham (john@foo.net) -- -- Permission is hereby granted, free of charge, to any person obtaining a @@ -35,20 +36,19 @@ putLogLn,putLog, putLogException, -- ** annotating exceptions - emapM, eannM, + -- emapM, eannM, -- ** exception-aware composition - retry, - first, - tryMap, tryMapM, + retryIO, + firstIO, + tryMapM, trySeveral, -- ** random functions - attempt, tryElse, tryMost, tryMost_, catchMost, - handleMost, - ioElse, + attemptIO, tryIO, indent ) where -import Control.OldException as E +import Control.Exception as E +import Data.Either import System.IO import System.IO.Unsafe import Control.Monad @@ -102,7 +102,7 @@ withStartEndEntrys n action = do gct >>= \ct -> putLogLn (ct ++ " " ++ n ++ " Starting") handle - (\e -> gct >>= \ct -> putLogException (ct ++ " " ++ n ++ " Ending due to Exception:" ) e >> throw e) + (\(e :: SomeException) -> gct >>= \ct -> putLogException (ct ++ " " ++ n ++ " Ending due to Exception:" ) e >> throw e) (action >>= \r -> gct >>= \ct -> putLogLn (ct ++ " " ++ n ++ " Ending") >> return r) where gct = getClockTime >>= \ct -> return $ "[" ++ show ct ++ "]" @@ -111,8 +111,8 @@ -- this is similar to 'withStartEndEntrys' but only adds an entry on error. withErrorMessage :: String -> IO a -> IO a withErrorMessage n action = do - handleMost - (\e -> gct >>= \ct -> putLogLn (normalize n ++ ct ++ " Ending due to Exception:\n" ++ indent 4 (show e) ) >> throw e ) + handle + (\(e :: SomeException) -> gct >>= \ct -> putLogLn (normalize n ++ ct ++ " Ending due to Exception:\n" ++ indent 4 (show e) ) >> throw e ) action where gct = getClockTime >>= \ct -> return $ "[" ++ show ct ++ "]" @@ -152,6 +152,7 @@ cll <- readMVar log_level when (ll <= cll) $ putLogLn s +{- -- | transform an exception with a function. emapM :: (Exception -> Exception) -> IO a -> IO a emapM f action = do @@ -165,67 +166,42 @@ eannM s action = emapM f action where f (ErrorCall es) = ErrorCall $ normalize s ++ normalize es f e = ErrorCall $ normalize s ++ normalize (show e) +-} -- | attempt an action, add a log entry with the exception if it -- fails -attempt :: IO a -> IO () -attempt action = tryMost action >>= \x -> case x of - Left e -> putLogException "attempt ExceptionCaught" e - Right _ -> return () - - -tryElse r x = tryMost x >>= \y -> case y of - Left e -> putLogException "tryElse ExceptionCaught" e >> return r - Right v -> return v - -tryMost_ x = tryMost x >> return () - -tryMap :: (a -> b) -> [a] -> IO [b] -tryMap f xs = do - ys <- mapM (tryMost . evaluate . f ) xs - return [y|(Right y) <- ys] +attemptIO :: IO a -> IO () +attemptIO action = E.catch (action >> return ()) + (\(e :: IOException) -> putLogException "attempt ExceptionCaught" e) tryMapM :: (a -> IO b) -> [a] -> IO [b] tryMapM f xs = do - ys <- mapM (tryMost . f ) xs - return [y|(Right y) <- ys] - -tryMost = E.tryJust passKilled - -passKilled (AsyncException ThreadKilled) = Nothing -passKilled x = Just x + ys <- mapM (tryIO . f) xs + return $ rights ys -catchMost = E.catchJust passKilled -handleMost = E.handleJust passKilled +tryIO :: IO a -> IO (Either IOException a) +tryIO = E.try -- | return the first non-excepting action. if all actions throw exceptions, -- the last actions exception is rethrown. -first :: [IO a] -> IO a -first [] = fail "empty argument to first" -first [x] = x -first (x:xs) = E.try x >>= \z -> case z of - Left e@(AsyncException ThreadKilled) -> throw e - Left _ -> first xs - Right v -> return v - -ioElse :: IO a -> IO a -> IO a -ioElse a b = tryMost a >>= \x -> case x of - Left _ -> b - Right x -> return x +firstIO :: [IO a] -> IO a +firstIO [] = fail "empty argument to first" +firstIO [x] = x +firstIO (x:xs) = E.try x >>= either (\(_ :: IOException) -> firstIO xs) return indent :: Int -> String -> String indent n s = unlines $ map (replicate n ' ' ++)$ lines s --- | Retry an action untill it succeeds. -retry :: Float -- ^ number of seconds to pause between trys +-- | Retry an action until it succeeds. +retryIO :: Float -- ^ number of seconds to pause between trys -> String -- ^ string to annotate log entries with when retrying -> IO a -- ^ action to retry -> IO a -retry delay n action = do - handleMost (\e -> putLogException (n ++ " (retrying in " ++ show delay ++ "s):") e >> threadDelay (floor $ 1000000 * delay) >> retry delay n action) action +retryIO delay n action = do + handle (\(e :: IOException) -> putLogException (n ++ " (retrying in " ++ show delay ++ "s):") e >> threadDelay (floor $ 1000000 * delay) >> retryIO delay n action) action -putLogException :: String -> Exception -> IO () +putLogException :: Exception e => String -> e -> IO () putLogException n e = putLog LogError (n ++ "\n" ++ indent 4 (show e)) @@ -239,7 +215,7 @@ g v ts where f v arm = do t <- myThreadId - r <- tryMost arm + r <- tryIO arm putMVar v (t,r) g v ts = do (t,r) <- takeMVar v diff --git a/Exception.hs b/Exception.hs deleted file mode 100644 --- a/Exception.hs +++ /dev/null @@ -1,7 +0,0 @@ -{-# LANGUAGE CPP #-} -#if MIN_VERSION_base(4,0,0) -#define MODULE Control.OldException -#else -#define MODULE Control.Exception -#endif -module Exception (module MODULE) where import MODULE diff --git a/Filter.hs b/Filter.hs --- a/Filter.hs +++ b/Filter.hs @@ -83,9 +83,9 @@ qstring = between (char '\'') (char '\'') $ many ((char '\'' >> char '\'' >> return '\'') <|> noneOf "'") -parseFilter :: Monad m => String -> m Filter +parseFilter :: String -> Either String Filter parseFilter s = case parse (between spaces eof pb) "" s of - Left e -> fail (show e) + Left e -> Left (show e) Right x -> return x where pb = parseBoolean' spaces parseTrue parseFalse parseBasic diff --git a/Gale/Gale.hs b/Gale/Gale.hs --- a/Gale/Gale.hs +++ b/Gale/Gale.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverlappingInstances, FlexibleInstances, PatternGuards #-} +{-# LANGUAGE OverlappingInstances, FlexibleInstances, PatternGuards, ScopedTypeVariables #-} module Gale.Gale( GaleContext, galeNextPuff, @@ -164,7 +164,7 @@ hFlush h connectThread :: GaleContext -> [String] -> MVar Handle -> IO () -connectThread gc _ hv = retry 5.0 ("ConnectionError") doit where +connectThread gc _ hv = retryIO 5.0 ("ConnectionError") doit where openHandle = do ds <- readMVar $ proxy gc swapMVar (connectionStatus gc) $ Left $ "Attempting to connect to: " ++ unwords ds @@ -181,8 +181,8 @@ bs <- LBS.hGet h (fromIntegral l) when (w == 0) $ do let hash = sha1 bs - let (cat,puff) = runGet decodePuff bs - cat <- tryMapM parseCategoryOld (spc $ cat) + (catl,puff) = runGet decodePuff bs + cat = mapMaybe parseCategoryOld (spc catl) ct <- getClockTime let ef = \xs -> ((fromString "_ginsu.timestamp",FragmentTime ct):(fromString "_ginsu.spumbuster", FragmentText (packString (bsToHex hash))):xs) p' <- galeDecryptPuff gc Puff { signature = [], cats = cat, fragments = ef puff} @@ -217,7 +217,7 @@ reconnectGaleContext gc = do -- p <- readMVar $ proxy gc - void $ forkIO $ attempt $ readMVar (gHandle gc) >>= hClose + void $ forkIO $ attemptIO $ readMVar (gHandle gc) >>= hClose galeSendPuff :: GaleContext -> Puff -> IO PuffStatus @@ -226,13 +226,13 @@ puff' <- expandEncryptionList gc puff writeChan (channel gc) puff' d <- createPuff gc False puff' - retry 3.0 "error sending puff" $ withMVar (gHandle gc) $ \h -> LBS.hPut h d >> hFlush h + retryIO 3.0 "error sending puff" $ withMVar (gHandle gc) $ \h -> LBS.hPut h d >> hFlush h galeWillPuff :: GaleContext -> Puff -> IO () galeWillPuff gc puff = void $ forkIO $ do putLog LogDebug $ "willing puff:\n" ++ (indent 4 $ showPuff puff) d <- createPuff gc True puff - retry 3.0 "error sending puff" $ withMVar (gHandle gc) $ \h -> LBS.hPut h d >> hFlush h + retryIO 3.0 "error sending puff" $ withMVar (gHandle gc) $ \h -> LBS.hPut h d >> hFlush h getPrivateKey kc kn = getPKey kc kn >>= \n -> case n of @@ -341,7 +341,7 @@ catfixes = [ ("/", ".|"), (".", "/"), (":", "..") ] -parseCategoryOld :: Monad m => String -> m Category +parseCategoryOld :: String -> Maybe Category parseCategoryOld = parser p where con cs | [nv] <- [x ++ (con $ drop (length y) cs) |(x,y) <- catfixes, y `isPrefixOf` cs] = nv con (c:cs) = c:con cs @@ -368,17 +368,18 @@ -------------------- galeDecryptPuff :: GaleContext -> Puff -> IO Puff -galeDecryptPuff gc p | (Just xs) <- getFragmentData p (f_securitySignature) = tryElse p $ do +galeDecryptPuff gc p = handle (\(_ :: IOException) -> return p) $ galeDecryptPuff' gc p +galeDecryptPuff' gc p | (Just xs) <- getFragmentData p f_securitySignature = do let (l,xs') = xdrReadUInt (BS.unpack xs) (sb,xs'') = xdrReadUInt (drop 4 xs') fl = (decodeFragments $ drop (fromIntegral l + 4) xs') ++ [f|f <- fragments p, fst f /= f_securitySignature] - key <- parseKey $ take (fromIntegral (l - (8 + sb))) (drop (fromIntegral sb) xs'') - galeDecryptPuff gc $ p {signature = (Unverifyable key): signature p, fragments = fl} -galeDecryptPuff gc p | (Just xs) <- getFragmentData p f_securityEncryption = tryElse p $ do - (cd,ks) <- parser pe (BS.unpack xs) - dfl <- first (map (td' (BS.pack cd)) [ (BS.pack x,y,BS.pack z) | (x,y,z) <- ks]) + key <- maybe (fail "parseKey") return $ parseKey $ take (fromIntegral (l - (8 + sb))) (drop (fromIntegral sb) xs'') + galeDecryptPuff' gc $ p {signature = (Unverifyable key): signature p, fragments = fl} +galeDecryptPuff' gc p | (Just xs) <- getFragmentData p f_securityEncryption = do + (cd,ks) <- maybe (fail "parseKey") return $ parser pe (BS.unpack xs) + dfl <- firstIO (map (td' (BS.pack cd)) [ (BS.pack x,y,BS.pack z) | (x,y,z) <- ks]) let dfl' = dfl ++ [f|f <- fragments p, fst f /= f_securityEncryption] - galeDecryptPuff gc $ p {signature = (Encrypted (map (\(_,n,_) -> n) ks)): signature p, fragments = dfl'} where + galeDecryptPuff' gc $ p {signature = (Encrypted (map (\(_,n,_) -> n) ks)): signature p, fragments = dfl'} where pe = (parseExact cipher_magic1 >> pr parseNullString) <|> (parseExact cipher_magic2 >> pr parseLenString) pk pkname iv = do kname <- pkname @@ -395,7 +396,7 @@ dd <- decryptAll keydata iv pkey cd --let dfl = decodeFragments (drop 4 (BS.unpack dd)) return $ runGet decodeFrags (LBS.fromChunks [BS.drop 4 dd]) -galeDecryptPuff _ x = return x +galeDecryptPuff' _ x = return x --data DestinationStatus = DSPublic { dsComment :: String } | DSPrivate { dsComment :: String } | DSGroup { dsComment :: String, dsComponents :: [DestinationStatus] } | DSUnknown @@ -506,7 +507,7 @@ galeAddCategories gc [Category ("_gale.key", categoryCell c)] d <- createPuff gc False $ keyRequestPuff c' putLog LogDebug $ "sending request for: " ++ c' - retry 3.0 "error sending puff" $ withMVar (gHandle gc) $ \h -> LBS.hPut h d >> hFlush h + retryIO 3.0 "error sending puff" $ withMVar (gHandle gc) $ \h -> LBS.hPut h d >> hFlush h findDest gc c = fd c >>= res where diff --git a/Gale/KeyCache.hs b/Gale/KeyCache.hs --- a/Gale/KeyCache.hs +++ b/Gale/KeyCache.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE PatternGuards, ScopedTypeVariables #-} module Gale.KeyCache( dumpKey, KeyCache, @@ -20,6 +20,7 @@ import Data.Bits import Data.Char import Control.Concurrent +import qualified Control.Exception as E import System.Directory import EIO import ErrorLog @@ -166,19 +167,17 @@ return (Map.insert kn n kkeyCache, ()) - - putKey :: KeyCache -> BS.ByteString -> IO () putKey kc xs = do - mk <- first [fmap Just (parseKey $ BS.unpack xs),return Nothing] + let mk = parseKey $ BS.unpack xs case mk of Nothing -> return () Just v'@(Key kn _) -> do modifyMVar (kkeyCache kc) f where f kkeyCache | Just _ <- Map.lookup kn kkeyCache = return (kkeyCache, ()) f kkeyCache = do - first [createDirectory $ galeDir kc ++ "/auth/", return ()] - first [createDirectory $ galeDir kc ++ "/auth/cache/", return ()] + E.catch (createDirectory $ galeDir kc ++ "/auth/") (\(_ :: E.IOException) -> return ()) + E.catch (createDirectory $ galeDir kc ++ "/auth/cache/") (\(_ :: E.IOException) -> return ()) --xs <- unsafeThaw xs --bnds <- getBounds xs atomicWrite (galeDir kc ++ "/auth/cache/" ++ kn ++ ".gpub") $ @@ -196,10 +195,10 @@ Nothing -> g kkeyCache f kkeyCache = g kkeyCache g kkeyCache = do - v <- ioM getFromDisk + v <- tryIO getFromDisk case v of - Nothing -> return (kkeyCache, Nothing) - Just v' -> do + Left _ -> return (kkeyCache, Nothing) + Right v' -> do v'' <- mkWeakPtr v' Nothing return (Map.insert kn v'' kkeyCache, Just v') getFromDisk :: IO Key @@ -207,10 +206,10 @@ let pc = galeDir kc ++ "/auth/cache/" pp = galeDir kc ++ "/auth/private/" knames = [ pp ++ kn ++ ".gpri", pp ++ kn ++ ".gpub", pp ++ kn , pc ++ kn ++ ".gpub" ] - gn = (map (\fn -> (readRawFile fn >>= parseKey >>= \c -> return (c,fn))) knames) + gf fn = readRawFile fn >>= return . (,) fn . parseKey --putLog LogDebug $ "Looking for: " ++ show knames - xs <- mapM tryMost gn - let ks = [ k | Right (k@(Key n _),_) <- xs, kn == n] + xs <- tryMapM gf knames + let ks = [ k | (_,Just k@(Key n _)) <- xs, kn == n] let nk = foldr (\(Key _ fl) (Key n fl') -> Key n (fl `mergeFrags` fl')) (Key kn []) ks --(key_c, fn) <- (first gn) --key <- parseKey key_c @@ -350,12 +349,12 @@ (f_rsaBits, FragmentInt $ fromIntegral bits)] -parser :: Monad m => ReadP a -> BS.ByteString -> m a +parser :: ReadP a -> BS.ByteString -> Maybe a parser p bs = case readP_to_S p bs of - [(a,bs)] | BS.null bs -> return a - _ -> fail "parser failed" + [(a,bs)] | BS.null bs -> Just a + _ -> Nothing -parseKey :: [Word8] -> IO Key +parseKey :: [Word8] -> Maybe Key parseKey xs = do (Key kn fl) <- parser keyParse (BS.pack xs) fl <- unsignFragments fl @@ -413,7 +412,7 @@ -unsignData :: [Word8] -> IO (FragmentList,Key) +unsignData :: [Word8] -> Maybe (FragmentList,Key) unsignData xs = do key <- parseKey $ take (fromIntegral (l - (8 + sb))) (drop (fromIntegral sb) xs'') return (fl,key) where @@ -421,7 +420,7 @@ (sb,xs'') = xdrReadUInt (drop 4 xs') fl = (decodeFragments $ drop (fromIntegral l + 4) xs') -unsignFragments :: FragmentList -> IO FragmentList +unsignFragments :: FragmentList -> Maybe FragmentList unsignFragments tfl | (xs:_) <- [xs | (n,FragmentData xs) <- tfl, n == f_securitySignature] = do (fl,_) <- unsignData (BS.unpack xs) unsignFragments fl @@ -441,7 +440,7 @@ Just key -> return key Nothing -> do c <- readRawFile arg - parseKey c + maybe (fail "parseKey") return $ parseKey c putStrLn $ showKey key diff --git a/Gale/Proto.hs b/Gale/Proto.hs --- a/Gale/Proto.hs +++ b/Gale/Proto.hs @@ -83,7 +83,7 @@ getGaleDir :: IO String getGaleDir = do - gd <- lookupEnv "GALE_DIR" + gd <- GenUtil.lookupEnv "GALE_DIR" case gd of Just v -> return $ v ++ "/" Nothing -> do diff --git a/Gale/Puff.hs b/Gale/Puff.hs --- a/Gale/Puff.hs +++ b/Gale/Puff.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving #-} +{-# LANGUAGE TypeSynonymInstances, FlexibleInstances, GeneralizedNewtypeDeriving, ScopedTypeVariables #-} module Gale.Puff( Puff(..), Fragment(..), @@ -47,6 +47,7 @@ import Atom import Data.Binary +import qualified Control.Exception as E import EIO import ErrorLog import GenUtil @@ -264,10 +265,10 @@ ---------------- writePuffs :: String -> [Puff] -> IO () -writePuffs fn ps = attempt $ putFile fn ps +writePuffs fn ps = attemptIO $ putFile fn ps readPuffs :: String -> IO [Puff] -readPuffs fn = tryElse [] $ getFile fn +readPuffs fn = E.handle (\(e :: E.IOException) -> return []) $ getFile fn putFile fn a = atomicWrite fn $ \h -> do diff --git a/GenUtil.hs b/GenUtil.hs --- a/GenUtil.hs +++ b/GenUtil.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE ParallelListComp #-} +{-# LANGUAGE ParallelListComp, ScopedTypeVariables #-} -- Copyright (c) 2002 John Meacham (john@foo.net) -- -- Permission is hereby granted, free of charge, to any person obtaining a @@ -55,7 +55,7 @@ -- ** Monad routines perhapsM, repeatM, repeatM_, replicateM, replicateM_, maybeToMonad, - toMonadM, ioM, ioMp, foldlM, foldlM_, foldl1M, foldl1M_, + toMonadM, foldlM, foldlM_, foldl1M, foldl1M_, -- ** Text Routines -- *** Quoting shellQuote, simpleQuote, simpleUnquote, @@ -117,6 +117,7 @@ import Data.Char(isAlphaNum, isSpace, toLower, ord, chr) import Data.List +import Control.Exception import Control.Monad import qualified System.IO as IO import qualified System.IO.Error as IO @@ -334,12 +335,10 @@ snds = map snd {-# INLINE repeatM #-} -{-# SPECIALIZE repeatM :: IO a -> IO [a] #-} repeatM :: Monad m => m a -> m [a] repeatM x = sequence $ repeat x {-# INLINE repeatM_ #-} -{-# SPECIALIZE repeatM_ :: IO a -> IO () #-} repeatM_ :: Monad m => m a -> m () repeatM_ x = sequence_ $ repeat x @@ -417,13 +416,15 @@ lefts :: [Either a b] -> [a] lefts xs = [x | Left x <- xs] +{- -- | Trasform IO errors into the failing of an arbitrary monad. ioM :: Monad m => IO a -> IO (m a) -ioM action = catch (fmap return action) (\e -> return (fail (show e))) +ioM action = catch (fmap return action) (\(e :: IOException) -> return (fail (show e))) -- | Trasform IO errors into the mzero of an arbitrary member of MonadPlus. ioMp :: MonadPlus m => IO a -> IO (m a) -ioMp action = catch (fmap return action) (\_ -> return mzero) +ioMp action = catch (fmap return action) (\(_ :: IOException) -> return mzero) +-} -- | reformat a string to not be wider than a given width, breaking it up -- between words. @@ -537,7 +538,7 @@ -- | looks up an enviornment variable and returns it in an arbitrary Monad rather -- than raising an exception if the variable is not set. lookupEnv :: Monad m => String -> IO (m String) -lookupEnv s = catch (fmap return $ System.getEnv s) (\e -> if IO.isDoesNotExistError e then return (fail (show e)) else ioError e) +lookupEnv s = catchJust (guard . IO.isDoesNotExistError) (fmap return $ System.getEnv s) (\e -> return (fail (show e))) {-# SPECIALIZE fmapLeft :: (a -> c) -> [(Either a b)] -> [(Either c b)] #-} fmapLeft :: Functor f => (a -> c) -> f (Either a b) -> f (Either c b) diff --git a/GinsuConfig.hs b/GinsuConfig.hs --- a/GinsuConfig.hs +++ b/GinsuConfig.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE ScopedTypeVariables #-} module GinsuConfig( checkConfigIsGood, configureGinsu, @@ -11,7 +12,7 @@ ) where import ConfigFile -import Exception +import Control.Exception import Data.Monoid import System.Directory import ErrorLog @@ -75,7 +76,7 @@ configBuilder = toConfig cb where cb "GALE_ID" = do - n <- first [getEnv "LOGNAME", getEnv "USER", Posix.getLoginName] + n <- firstIO [getEnv "LOGNAME", getEnv "USER", Posix.getLoginName] d <- configLookup "GALE_DOMAIN" case d of Just d -> return [("@$GALE_DOMAIN",("GALE_ID", n ++ "@" ++ d))] @@ -114,15 +115,14 @@ getGaleAliases :: IO [(String,Category)] getGaleAliases = do v <- galeFile "aliases/" - fs <- handle (\_ -> return []) $ getDirectoryContents v + fs <- handle (\(_ :: IOException) -> return []) $ getDirectoryContents v --putLog LogDebug $ "aliases/ " ++ show fs let f fn = do --fc <- first [readFile (v ++ fn), readSymbolicLink (v ++ fn)] fc <- readAlias (v ++ fn) --putLog LogDebug $ "readAlias " ++ (v ++ fn) ++ " " ++ fc return (fn, catParseNew fc) - ks <- mapM (\x -> tryMost (f x)) fs - return [x | (Right x) <- ks] + tryMapM f fs readAlias :: String -> IO String diff --git a/Help.hs b/Help.hs --- a/Help.hs +++ b/Help.hs @@ -20,18 +20,16 @@ usageHeader = "Usage: ginsu [OPTION...] categories..." usageTrailer = unlines [ - "For more information see the homepage at", + "For more information see the (unmaintained) homepage at", " ", - "To report a bug go to:", - " ", + "For current version information and maintainer, see", + " ", "When reporting a bug, include the last few lines of ~/.gale/ginsu.errorlog if it seems appropriate." ] bugMsg = unlines [ "There has been an internal error", - "verify the output of ginsu --checkconfig and", - "please inform or file a bug report at", - "", + "verify the output of ginsu --checkconfig", "Include the following text in any error report:" ] diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverlappingInstances, PatternGuards #-} +{-# LANGUAGE OverlappingInstances, PatternGuards, ScopedTypeVariables #-} module Main(main) where import Data.Char @@ -10,7 +10,7 @@ import System.Random import Control.Concurrent -import Exception as Control.Exception +import Control.Exception import Data.Array.IO import Data.IORef import Data.Unique @@ -462,7 +462,7 @@ pn <- getClockTime Hash.insert idleHash author $ fromJust $ max mt (Just pn) v <- configLookupList "BEEP" - let f = or (catMaybes (map parseFilter v)) + let f = or (rights (map parseFilter v)) when (filterAp f p) Curses.beep n <- readVal next_r mapVal next_r (+1) @@ -560,7 +560,7 @@ rp y (((i,p),n):rest) = do when ((0,ys) `overlaps` (y - yo, y - yo + n)) $ renderPuff p xs stdScr (y - yo) (xs,ys) (i == selected) (if isRot13 then rot13 else id) rp (y + n) rest - attempt (rp 0 (reverse ps)) + attemptIO (rp 0 (reverse ps)) select_perhaps a = do ps <- getFilteredPuffs n <- readVal selected_r @@ -761,7 +761,7 @@ pcw <- puffConfirm gc (setRenderWidget rc fw) p ic setRenderWidget rc pcw continue - "redraw_screen" -> attempt (touchWin stdScr) >> resizeRenderContext rc (return ()) >> continue + "redraw_screen" -> attemptIO (touchWin stdScr) >> resizeRenderContext rc (return ()) >> continue "show_help_screen" -> setRenderWidget rc (keyCatcherWidget (\_ -> setRenderWidget rc fw >> return True) hw) >> continue "show_status_screen" -> setRenderWidget rc (keyCatcherWidget (\_ -> setRenderWidget rc fw >> return True) statusWidget) >> continue "show_presence_status" -> setRenderWidget rc (keyCatcherWidget (\_ -> setRenderWidget rc fw >> return True) presenceWidget) >> continue @@ -891,9 +891,9 @@ -- Curses routines ------------------ -waddstr w s = Control.Exception.try (wAddStr w s) >> return () -mvwaddstr w y x s = Control.Exception.try (mvWAddStr w y x s) >> return () -wmove w y x = Control.Exception.try (wMove w y x) >> return () +waddstr w s = tryIO (wAddStr w s) >> return () +mvwaddstr w y x s = tryIO (mvWAddStr w y x s) >> return () +wmove w y x = tryIO (wMove w y x) >> return () space w = waddstr w " " @@ -963,7 +963,7 @@ bgcmd <- if bgedit then configLookupList "BACKGROUND_COMMAND" else return [] let (cmd:args) = (concatMap words bgcmd) ++ [e] ++ (concatMap words eo) ++ [fn] let after = editPuffDone fn ic done it puff - let handle = do st <- try $ Posix.getAnyProcessStatus False False + let handle = do st <- tryIO $ Posix.getAnyProcessStatus False False case st of Right (Just _) -> handle _ -> after if bgedit then do @@ -976,7 +976,7 @@ editPuffDone :: String -> Chan MainEvent -> IO () -> [String] -> Puff -> IO () editPuffDone fn ic done it puff = do pn <- fmap (lines . bytesToString)$ readRawFile fn - handleMost (\_ -> return ()) (removeFile fn) + handle (\(_ :: IOException) -> return ()) (removeFile fn) ep <- if not (length pn > 1 && pn /= it) then return Nothing else do let (cs',kwds') = readDestination (drop 4 (head pn)) ncats <- expandAliases (cs') diff --git a/Regex.hs b/Regex.hs --- a/Regex.hs +++ b/Regex.hs @@ -3,7 +3,7 @@ import Data.Char import ConfigFile -import Exception +import Control.Exception import GenUtil import Data.Maybe import Control.Monad @@ -23,9 +23,9 @@ matches :: Regex -> String -> [[String]] -matches rx s = case unsafePerformIO (regexec rx s >>= fromWrapError) of - Nothing -> [] - Just (_,v,r,xs) -> (v:xs):matches rx r +matches rx s = case unsafePerformIO (regexec rx s) of + Right (Just (_,v,r,xs)) -> (v:xs):matches rx r + _ -> [] matchWords :: [(Regex,String,String)] -> String -> [(String,String)] @@ -45,13 +45,10 @@ return zs -fromWrapError (Left r) = fail (show r) -fromWrapError (Right x) = return x - data Rx = Rx { rxString :: String, rxRegex :: Regex } compileRx :: Monad m => String -> m Rx -compileRx re = liftM (Rx re) $ unsafePerformIO ( handle (\e -> return (fail $ show e)) (compile flags execBlank re' >>= fromWrapError >>= (return . return))) where +compileRx re = either (fail . snd) return $ liftM (Rx re) $ unsafePerformIO $ compile flags execBlank re' where flags = compExtended + ci + ml ci = if 'i' `elem` fl then compIgnoreCase else 0 ml = if 'm' `elem` fl then compNewline else 0 @@ -63,5 +60,6 @@ instance Show Rx where show (Rx s _) = s -matchRx re body = isJust (unsafePerformIO (regexec (rxRegex re) (unpackPS body) >>= fromWrapError)) +matchRx :: Rx -> PackedString -> Bool +matchRx re body = either (const False) isJust (unsafePerformIO (regexec (rxRegex re) (unpackPS body))) diff --git a/Screen.hs b/Screen.hs --- a/Screen.hs +++ b/Screen.hs @@ -29,7 +29,7 @@ ) where import Control.Concurrent -import Exception as E +import Control.Exception as E import Data.Bits import Control.Monad @@ -116,9 +116,9 @@ tryDrawRenderContext rc = do y <- swapMVar (needsResize rc) False - withMVar (drawingStuff rc) $ \(z,_,_) -> when (True) $ do + withMVar (drawingStuff rc) $ \(z,_,_) -> do erase - when y (attempt endWin >> refresh) + when y (attemptIO endWin >> refresh) z refresh @@ -135,7 +135,8 @@ return (wdr, processKey w, return (){-, nf-}) where wdr = do c <- newCanvas - eannM ("doRender " ++ show c) $ render w c + {- eannM ("doRender " ++ show c) $ -} + render w c keyRenderContext :: RenderContext -> Key -> IO Bool keyRenderContext _ KeyResize = return True @@ -146,7 +147,8 @@ doRender w = do erase c <- newCanvas - eannM ("doRender " ++ show c) $ render w c + {- eannM ("doRender " ++ show c) $ -} + render w c refresh newCanvas = do @@ -175,8 +177,8 @@ drawString :: Canvas -> String -> IO () -drawString canvas s = eannM (fmtSs "drawString %s %s" [(show canvas), s]) $ ds ml yb (origin canvas) where - ds (s:ls) yb (x,y) | yb > 0 = E.try (mvWAddStr (window canvas) y x (take xb s)) >> ds ls (yb - 1) (x,y + 1) +drawString canvas s = {- eannM (fmtSs "drawString %s %s" [(show canvas), s]) $ -} ds ml yb (origin canvas) where + ds (s:ls) yb (x,y) | yb > 0 = tryIO (mvWAddStr (window canvas) y x (take xb s)) >> ds ls (yb - 1) (x,y + 1) ds _ _ _ = return () (xb,yb) = bounds canvas ls = lines s diff --git a/SimpleParser.hs b/SimpleParser.hs --- a/SimpleParser.hs +++ b/SimpleParser.hs @@ -125,15 +125,10 @@ w <- word if w == s then return w else mzero -{-# SPECIALIZE parser :: GenParser c a -> [c] -> Maybe a #-} -{-# SPECIALIZE parser :: GenParser c a -> [c] -> IO a #-} -{-# SPECIALIZE parser :: GenParser Char a -> String -> Maybe a #-} -{-# SPECIALIZE parser :: GenParser Char a -> String -> IO a #-} - -parser :: Monad m => GenParser c a -> [c] -> m a +parser :: GenParser c a -> [c] -> Maybe a parser (MkP fn) s = case fn s of - Just (v,[]) -> return v - _ -> fail "parser failed" + Just (v,[]) -> Just v + _ -> Nothing {- parseIO p xs = case parser p xs of diff --git a/ginsu.cabal b/ginsu.cabal --- a/ginsu.cabal +++ b/ginsu.cabal @@ -1,8 +1,8 @@ -- vim:et Name: ginsu -Version: 0.8.0.2 +Version: 0.8.1 Copyright: 2002-2009 John Meacham - 2011 Dylan Simon + 2011-2012 Dylan Simon Author: John Meacham Dylan Simon Maintainer: dylan@dylex.net @@ -14,7 +14,7 @@ Category: Network,Console Build-Type: Custom Cabal-Version: >= 1.6 -tested-with: GHC == 6.12.3, GHC == 7.0.2, GHC == 7.4.1 +tested-with: GHC == 6.12.3, GHC == 7.6.1 extra-source-files: configure ginsu.buildinfo.in @@ -34,7 +34,7 @@ Source-Repository head Type: darcs - Location: http://dylex.net/src/ginsu + Location: http://hub.darcs.net/dylex/ginsu Executable ginsu Main-is: Main.hs @@ -52,7 +52,6 @@ EIO ErrorLog ExampleConf - Exception Filter Format Gale.Gale @@ -80,7 +79,7 @@ my_rsa.c Include-Dirs: . Build-Depends: - base >= 3 && < 5, + base >= 4 && < 5, bytestring, old-locale, containers,