ginsu 0.8.0.2 → 0.8.1
raw patch · 18 files changed
+130/−165 lines, 18 filesdep ~base
Dependency ranges changed: base
Files
- ConfigFile.hs +4/−2
- Curses.hsc +1/−1
- Doc/DocLike.hs +1/−1
- ErrorLog.hs +30/−54
- Exception.hs +0/−7
- Filter.hs +2/−2
- Gale/Gale.hs +18/−17
- Gale/KeyCache.hs +18/−19
- Gale/Proto.hs +1/−1
- Gale/Puff.hs +4/−3
- GenUtil.hs +8/−7
- GinsuConfig.hs +5/−5
- Help.hs +4/−6
- Main.hs +10/−10
- Regex.hs +7/−9
- Screen.hs +9/−7
- SimpleParser.hs +3/−8
- ginsu.cabal +5/−6
ConfigFile.hs view
@@ -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
Curses.hsc view
@@ -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 () ------------------------------------------------------------------------
Doc/DocLike.hs view
@@ -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
ErrorLog.hs view
@@ -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
− Exception.hs
@@ -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
Filter.hs view
@@ -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
Gale/Gale.hs view
@@ -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
Gale/KeyCache.hs view
@@ -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
Gale/Proto.hs view
@@ -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
Gale/Puff.hs view
@@ -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
GenUtil.hs view
@@ -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)
GinsuConfig.hs view
@@ -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 [("<LOGIN>@$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
Help.hs view
@@ -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", " <http://repetae.net/john/computer/ginsu/>",- "To report a bug go to:",- " <http://bugs.ofb.net/cgi-bin/bugzilla/enter_bug.cgi?product=Ginsu>",+ "For current version information and maintainer, see",+ " <http://hackage.haskell.org/package/ginsu>", "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 <john@ugcs.caltech.edu> or file a bug report at",- "<http://bugs.ofb.net/cgi-bin/bugzilla/enter_bug.cgi?product=Ginsu>",+ "verify the output of ginsu --checkconfig", "Include the following text in any error report:" ]
Main.hs view
@@ -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')
Regex.hs view
@@ -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)))
Screen.hs view
@@ -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
SimpleParser.hs view
@@ -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
ginsu.cabal view
@@ -1,8 +1,8 @@ -- vim:et Name: ginsu-Version: 0.8.0.2+Version: 0.8.1 Copyright: 2002-2009 John Meacham <john@repetae.net>- 2011 Dylan Simon <dylan@dylex.net>+ 2011-2012 Dylan Simon <dylan@dylex.net> Author: John Meacham <john@foo.net> Dylan Simon <dylan@dylex.net> 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,