diff options
Diffstat (limited to 'Utility')
-rw-r--r-- | Utility/DBus.hs | 9 | ||||
-rw-r--r-- | Utility/Exception.hs | 17 | ||||
-rw-r--r-- | Utility/SRV.hs | 82 | ||||
-rw-r--r-- | Utility/State.hs | 4 |
4 files changed, 105 insertions, 7 deletions
diff --git a/Utility/DBus.hs b/Utility/DBus.hs index a1a4c4804..d31c20d54 100644 --- a/Utility/DBus.hs +++ b/Utility/DBus.hs @@ -9,6 +9,8 @@ module Utility.DBus where +import Utility.Exception + import DBus.Client import DBus import Data.Maybe @@ -70,10 +72,7 @@ persistentClient :: IO (Maybe Address) -> v -> (SomeException -> v -> IO v) -> ( persistentClient getaddr v onretry clientaction = {- runClient can fail with not just ClientError, but also other - things, if dbus is not running. Let async exceptions through. -} - runClient getaddr clientaction `E.catches` - [ Handler (\ (e :: AsyncException) -> E.throw e) - , Handler (\ (e :: SomeException) -> retry e) - ] + runClient getaddr clientaction `catchNonAsync` retry where retry e = do v' <- onretry e v @@ -81,5 +80,5 @@ persistentClient getaddr v onretry clientaction = {- Catches only ClientError -} catchClientError :: IO () -> (ClientError -> IO ()) -> IO () -catchClientError io handler = do +catchClientError io handler = either handler return =<< (E.try io :: IO (Either ClientError ())) diff --git a/Utility/Exception.hs b/Utility/Exception.hs index 8b6077743..45f2aecec 100644 --- a/Utility/Exception.hs +++ b/Utility/Exception.hs @@ -1,10 +1,12 @@ -{- Simple IO exception handling +{- Simple IO exception handling (and some more) - - Copyright 2011-2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE ScopedTypeVariables #-} + module Utility.Exception where import Prelude hiding (catch) @@ -34,3 +36,16 @@ catchIO = catch {- try specialized for IO errors only -} tryIO :: IO a -> IO (Either IOException a) tryIO = try + +{- Catches all exceptions except for async exceptions. + - This is often better to use than catching them all, so that + - ThreadKilled and UserInterrupt get through. + -} +catchNonAsync :: IO a -> (SomeException -> IO a) -> IO a +catchNonAsync a onerr = a `catches` + [ Handler (\ (e :: AsyncException) -> throw e) + , Handler (\ (e :: SomeException) -> onerr e) + ] + +tryNonAsync :: IO a -> IO (Either SomeException a) +tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left) diff --git a/Utility/SRV.hs b/Utility/SRV.hs new file mode 100644 index 000000000..4f2db680b --- /dev/null +++ b/Utility/SRV.hs @@ -0,0 +1,82 @@ +{- SRV record lookup + - + - Uses either the ADNS Haskell library, or if it's not installed, + - the host command. + - + - Copyright 2012 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +{-# LANGUAGE CPP #-} + +module Utility.SRV ( + mkSRVTcp, + mkSRV, + lookupSRV, +) where + +import qualified Build.SysConfig +import Utility.Process +import Utility.Exception +import Utility.PartialPrelude + +import Network +import Data.Function +import Data.List +import Control.Applicative +import Data.Maybe + +#ifdef WITH_ADNS +import ADNS.Resolver +import Data.Either +#endif + +newtype SRV = SRV String + deriving (Show, Eq) + +type HostPort = (HostName, PortID) + +mkSRV :: String -> String -> HostName -> SRV +mkSRV transport protocol host = SRV $ concat + ["_", protocol, "._", transport, ".", host] + +mkSRVTcp :: String -> HostName -> SRV +mkSRVTcp = mkSRV "tcp" + +{- Returns an ordered list, with highest priority hosts first. + - + - On error, returns an empty list. -} +lookupSRV :: SRV -> IO [HostPort] +#ifdef WITH_ADNS +lookupSRV srv = initResolver [] $ \resolver -> do + r <- catchDefaultIO (Right []) $ + resolveSRV resolver srv + return $ either (\_ -> []) id r +#else +lookupSRV = lookupSRVHost +#endif + +lookupSRVHost :: SRV -> IO [HostPort] +lookupSRVHost (SRV srv) + | Build.SysConfig.host = catchDefaultIO [] $ + parseSrvHost <$> readProcessEnv "host" ["-t", "SRV", "--", srv] + -- clear environment, to avoid LANG affecting output + (Just []) + | otherwise = return [] + +parseSrvHost :: String -> [HostPort] +parseSrvHost = map snd . reverse . sortBy cost . catMaybes . map parse . lines + where + cost = compare `on` fst + parse l = case words l of + [_, _, _, _, priority, weight, sport, hostname] -> do + let v = readish sport :: Maybe Int + case v of + Nothing -> Nothing + Just port -> Just + ( (priority, weight) + , (hostname, PortNumber $ fromIntegral port) + ) + _ -> Nothing + diff --git a/Utility/State.hs b/Utility/State.hs index c27f3c261..7f8919082 100644 --- a/Utility/State.hs +++ b/Utility/State.hs @@ -5,9 +5,11 @@ - Licensed under the GNU GPL version 3 or higher. -} +{-# LANGUAGE PackageImports #-} + module Utility.State where -import Control.Monad.State.Strict +import "mtl" Control.Monad.State.Strict {- Modifies Control.Monad.State's state, forcing a strict update. - This avoids building thunks in the state and leaking. |