summaryrefslogtreecommitdiff
path: root/Utility
diff options
context:
space:
mode:
Diffstat (limited to 'Utility')
-rw-r--r--Utility/DBus.hs9
-rw-r--r--Utility/Exception.hs17
-rw-r--r--Utility/SRV.hs82
-rw-r--r--Utility/State.hs4
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.