summaryrefslogtreecommitdiff
path: root/Utility
diff options
context:
space:
mode:
Diffstat (limited to 'Utility')
-rw-r--r--Utility/Bloom.hs2
-rw-r--r--Utility/Exception.hs5
-rw-r--r--Utility/Gpg.hs90
-rw-r--r--Utility/Matcher.hs9
-rw-r--r--Utility/Misc.hs2
-rw-r--r--Utility/OptParse.hs1
-rw-r--r--Utility/Process.hs9
-rw-r--r--Utility/Scheduled.hs2
-rw-r--r--Utility/SshConfig.hs10
-rw-r--r--Utility/Url.hs38
-rw-r--r--Utility/libdiskfree.c9
11 files changed, 107 insertions, 70 deletions
diff --git a/Utility/Bloom.hs b/Utility/Bloom.hs
index 668901f76..67841225c 100644
--- a/Utility/Bloom.hs
+++ b/Utility/Bloom.hs
@@ -53,7 +53,7 @@ notElemB :: a -> Bloom a -> Bool
notElemB = Bloom.notElemB
elemB :: a -> Bloom a -> Bool
-elemB = Bloom.elem
+elemB = Bloom.elemB
newMB :: (a -> [Bloom.Hash]) -> Int -> ST s (Bloom.MBloom s a)
newMB = Bloom.newMB
diff --git a/Utility/Exception.hs b/Utility/Exception.hs
index 30bcc9245..13000e033 100644
--- a/Utility/Exception.hs
+++ b/Utility/Exception.hs
@@ -39,10 +39,7 @@ catchBoolIO = catchDefaultIO False
{- Catches IO errors and returns a Maybe -}
catchMaybeIO :: MonadCatch m => m a -> m (Maybe a)
-catchMaybeIO a = do
- catchDefaultIO Nothing $ do
- v <- a
- return (Just v)
+catchMaybeIO a = catchDefaultIO Nothing $ a >>= (return . Just)
{- Catches IO errors and returns a default value. -}
catchDefaultIO :: MonadCatch m => a -> m a -> m a
diff --git a/Utility/Gpg.hs b/Utility/Gpg.hs
index 3e3a58013..1ac03ef54 100644
--- a/Utility/Gpg.hs
+++ b/Utility/Gpg.hs
@@ -30,10 +30,16 @@ type KeyId = String
newtype KeyIds = KeyIds { keyIds :: [KeyId] }
deriving (Ord, Eq)
-{- If a specific gpg command was found at configure time, use it.
- - Otherwise, try to run gpg. -}
-gpgcmd :: FilePath
-gpgcmd = fromMaybe "gpg" SysConfig.gpg
+newtype GpgCmd = GpgCmd { unGpgCmd :: String }
+
+{- Get gpg command to use, Just what's specified or, if a specific gpg
+ - command was found at configure time, use it, or otherwise, "gpg". -}
+mkGpgCmd :: Maybe FilePath -> GpgCmd
+mkGpgCmd (Just c) = GpgCmd c
+mkGpgCmd Nothing = GpgCmd (fromMaybe "gpg" SysConfig.gpg)
+
+boolGpgCmd :: GpgCmd -> [CommandParam] -> IO Bool
+boolGpgCmd (GpgCmd cmd) = boolSystem cmd
-- Generate an argument list to asymetrically encrypt to the given recipients.
pkEncTo :: [String] -> [CommandParam]
@@ -76,19 +82,19 @@ stdEncryptionParams symmetric = enc symmetric ++
]
{- Runs gpg with some params and returns its stdout, strictly. -}
-readStrict :: [CommandParam] -> IO String
-readStrict params = do
+readStrict :: GpgCmd -> [CommandParam] -> IO String
+readStrict (GpgCmd cmd) params = do
params' <- stdParams params
- withHandle StdoutHandle createProcessSuccess (proc gpgcmd params') $ \h -> do
+ withHandle StdoutHandle createProcessSuccess (proc cmd params') $ \h -> do
hSetBinaryMode h True
hGetContentsStrict h
{- Runs gpg, piping an input value to it, and returning its stdout,
- strictly. -}
-pipeStrict :: [CommandParam] -> String -> IO String
-pipeStrict params input = do
+pipeStrict :: GpgCmd -> [CommandParam] -> String -> IO String
+pipeStrict (GpgCmd cmd) params input = do
params' <- stdParams params
- withIOHandles createProcessSuccess (proc gpgcmd params') $ \(to, from) -> do
+ withIOHandles createProcessSuccess (proc cmd params') $ \(to, from) -> do
hSetBinaryMode to True
hSetBinaryMode from True
hPutStr to input
@@ -106,8 +112,8 @@ pipeStrict params input = do
-
- Note that to avoid deadlock with the cleanup stage,
- the reader must fully consume gpg's input before returning. -}
-feedRead :: (MonadIO m, MonadMask m) => [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> m a) -> m a
-feedRead params passphrase feeder reader = do
+feedRead :: (MonadIO m, MonadMask m) => GpgCmd -> [CommandParam] -> String -> (Handle -> IO ()) -> (Handle -> m a) -> m a
+feedRead cmd params passphrase feeder reader = do
#ifndef mingw32_HOST_OS
-- pipe the passphrase into gpg on a fd
(frompipe, topipe) <- liftIO System.Posix.IO.createPipe
@@ -127,13 +133,13 @@ feedRead params passphrase feeder reader = do
go $ passphrasefile ++ params
#endif
where
- go params' = pipeLazy params' feeder reader
+ go params' = pipeLazy cmd params' feeder reader
{- Like feedRead, but without passphrase. -}
-pipeLazy :: (MonadIO m, MonadMask m) => [CommandParam] -> (Handle -> IO ()) -> (Handle -> m a) -> m a
-pipeLazy params feeder reader = do
+pipeLazy :: (MonadIO m, MonadMask m) => GpgCmd -> [CommandParam] -> (Handle -> IO ()) -> (Handle -> m a) -> m a
+pipeLazy (GpgCmd cmd) params feeder reader = do
params' <- liftIO $ stdParams $ Param "--batch" : params
- let p = (proc gpgcmd params')
+ let p = (proc cmd params')
{ std_in = CreatePipe
, std_out = CreatePipe
, std_err = Inherit
@@ -152,8 +158,8 @@ pipeLazy params feeder reader = do
{- Finds gpg public keys matching some string. (Could be an email address,
- a key id, or a name; See the section 'HOW TO SPECIFY A USER ID' of
- GnuPG's manpage.) -}
-findPubKeys :: String -> IO KeyIds
-findPubKeys for = KeyIds . parse . lines <$> readStrict params
+findPubKeys :: GpgCmd -> String -> IO KeyIds
+findPubKeys cmd for = KeyIds . parse . lines <$> readStrict cmd params
where
params = [Param "--with-colons", Param "--list-public-keys", Param for]
parse = mapMaybe (keyIdField . split ":")
@@ -164,10 +170,10 @@ type UserId = String
{- All of the user's secret keys, with their UserIds.
- Note that the UserId may be empty. -}
-secretKeys :: IO (M.Map KeyId UserId)
-secretKeys = catchDefaultIO M.empty makemap
+secretKeys :: GpgCmd -> IO (M.Map KeyId UserId)
+secretKeys cmd = catchDefaultIO M.empty makemap
where
- makemap = M.fromList . parse . lines <$> readStrict params
+ makemap = M.fromList . parse . lines <$> readStrict cmd params
params = [Param "--with-colons", Param "--list-secret-keys", Param "--fixed-list-mode"]
parse = extract [] Nothing . map (split ":")
extract c (Just keyid) (("uid":_:_:_:_:_:_:_:_:userid:_):rest) =
@@ -193,9 +199,9 @@ maxRecommendedKeySize = 4096
- The key is added to the secret key ring.
- Can take a very long time, depending on system entropy levels.
-}
-genSecretKey :: KeyType -> Passphrase -> UserId -> Size -> IO ()
-genSecretKey keytype passphrase userid keysize =
- withHandle StdinHandle createProcessSuccess (proc gpgcmd params) feeder
+genSecretKey :: GpgCmd -> KeyType -> Passphrase -> UserId -> Size -> IO ()
+genSecretKey (GpgCmd cmd) keytype passphrase userid keysize =
+ withHandle StdinHandle createProcessSuccess (proc cmd params) feeder
where
params = ["--batch", "--gen-key"]
feeder h = do
@@ -217,8 +223,8 @@ genSecretKey keytype passphrase userid keysize =
{- Creates a block of high-quality random data suitable to use as a cipher.
- It is armored, to avoid newlines, since gpg only reads ciphers up to the
- first newline. -}
-genRandom :: Bool -> Size -> IO String
-genRandom highQuality size = checksize <$> readStrict params
+genRandom :: GpgCmd -> Bool -> Size -> IO String
+genRandom cmd highQuality size = checksize <$> readStrict cmd params
where
params =
[ Param "--gen-random"
@@ -327,8 +333,8 @@ keyBlock public ls = unlines
#ifndef mingw32_HOST_OS
{- Runs an action using gpg in a test harness, in which gpg does
- not use ~/.gpg/, but a directory with the test key set up to be used. -}
-testHarness :: IO a -> IO a
-testHarness a = do
+testHarness :: GpgCmd -> IO a -> IO a
+testHarness cmd a = do
orig <- getEnv var
bracket setup (cleanup orig) (const a)
where
@@ -339,8 +345,8 @@ testHarness a = do
dir <- mktmpdir $ base </> "gpgtmpXXXXXX"
setEnv var dir True
-- For some reason, recent gpg needs a trustdb to be set up.
- _ <- pipeStrict [Param "--trust-model", Param "auto", Param "--update-trustdb"] []
- _ <- pipeStrict [Param "--import", Param "-q"] $ unlines
+ _ <- pipeStrict cmd [Param "--trust-model", Param "auto", Param "--update-trustdb"] []
+ _ <- pipeStrict cmd [Param "--import", Param "-q"] $ unlines
[testSecretKey, testKey]
return dir
@@ -349,22 +355,22 @@ testHarness a = do
reset _ = unsetEnv var
{- Tests the test harness. -}
-testTestHarness :: IO Bool
-testTestHarness = do
- keys <- testHarness $ findPubKeys testKeyId
+testTestHarness :: GpgCmd -> IO Bool
+testTestHarness cmd = do
+ keys <- testHarness cmd $ findPubKeys cmd testKeyId
return $ KeyIds [testKeyId] == keys
#endif
#ifndef mingw32_HOST_OS
-checkEncryptionFile :: FilePath -> Maybe KeyIds -> IO Bool
-checkEncryptionFile filename keys =
- checkGpgPackets keys =<< readStrict params
+checkEncryptionFile :: GpgCmd -> FilePath -> Maybe KeyIds -> IO Bool
+checkEncryptionFile cmd filename keys =
+ checkGpgPackets cmd keys =<< readStrict cmd params
where
params = [Param "--list-packets", Param "--list-only", File filename]
-checkEncryptionStream :: String -> Maybe KeyIds -> IO Bool
-checkEncryptionStream stream keys =
- checkGpgPackets keys =<< pipeStrict params stream
+checkEncryptionStream :: GpgCmd -> String -> Maybe KeyIds -> IO Bool
+checkEncryptionStream cmd stream keys =
+ checkGpgPackets cmd keys =<< pipeStrict cmd params stream
where
params = [Param "--list-packets", Param "--list-only"]
@@ -372,8 +378,8 @@ checkEncryptionStream stream keys =
- symmetrically encrypted (keys is Nothing), or encrypted to some
- public key(s).
- /!\ The key needs to be in the keyring! -}
-checkGpgPackets :: Maybe KeyIds -> String -> IO Bool
-checkGpgPackets keys str = do
+checkGpgPackets :: GpgCmd -> Maybe KeyIds -> String -> IO Bool
+checkGpgPackets cmd keys str = do
let (asym,sym) = partition (pubkeyEncPacket `isPrefixOf`) $
filter (\l' -> pubkeyEncPacket `isPrefixOf` l' ||
symkeyEncPacket `isPrefixOf` l') $
@@ -384,7 +390,7 @@ checkGpgPackets keys str = do
(Just (KeyIds ks), ls, []) -> do
-- Find the master key associated with the
-- encryption subkey.
- ks' <- concat <$> mapM (keyIds <$$> findPubKeys)
+ ks' <- concat <$> mapM (keyIds <$$> findPubKeys cmd)
[ k | k:"keyid":_ <- map (reverse . words) ls ]
return $ sort (nub ks) == sort (nub ks')
_ -> return False
diff --git a/Utility/Matcher.hs b/Utility/Matcher.hs
index 19a77201c..badf72acf 100644
--- a/Utility/Matcher.hs
+++ b/Utility/Matcher.hs
@@ -27,6 +27,7 @@ module Utility.Matcher (
matchM,
matchMrun,
isEmpty,
+ combineMatchers,
prop_matcher_sane
) where
@@ -142,6 +143,14 @@ isEmpty :: Matcher a -> Bool
isEmpty MAny = True
isEmpty _ = False
+{- Combines two matchers, yielding a matcher that will match anything
+ - both do. But, if one matcher contains no limits, yield the other one. -}
+combineMatchers :: Matcher a -> Matcher a -> Matcher a
+combineMatchers a b
+ | isEmpty a = b
+ | isEmpty b = a
+ | otherwise = a `MOr` b
+
prop_matcher_sane :: Bool
prop_matcher_sane = all (\m -> match dummy m ()) $ map generate
[ [Operation True]
diff --git a/Utility/Misc.hs b/Utility/Misc.hs
index 45d5a0639..ebb42576b 100644
--- a/Utility/Misc.hs
+++ b/Utility/Misc.hs
@@ -136,7 +136,7 @@ hGetSomeString h sz = do
- if this reap gets there first. -}
reapZombies :: IO ()
#ifndef mingw32_HOST_OS
-reapZombies = do
+reapZombies =
-- throws an exception when there are no child processes
catchDefaultIO Nothing (getAnyProcessStatus False True)
>>= maybe (return ()) (const reapZombies)
diff --git a/Utility/OptParse.hs b/Utility/OptParse.hs
index f58e8fadf..c65a18c24 100644
--- a/Utility/OptParse.hs
+++ b/Utility/OptParse.hs
@@ -9,6 +9,7 @@ module Utility.OptParse where
import Options.Applicative
import Data.Monoid
+import Prelude
-- | A switch that can be enabled using --foo and disabled using --no-foo.
--
diff --git a/Utility/Process.hs b/Utility/Process.hs
index ae9ce49c8..cc1138678 100644
--- a/Utility/Process.hs
+++ b/Utility/Process.hs
@@ -376,11 +376,10 @@ createProcess p = do
-- | Debugging trace for a CreateProcess.
debugProcess :: CreateProcess -> IO ()
-debugProcess p = do
- debugM "Utility.Process" $ unwords
- [ action ++ ":"
- , showCmd p
- ]
+debugProcess p = debugM "Utility.Process" $ unwords
+ [ action ++ ":"
+ , showCmd p
+ ]
where
action
| piped (std_in p) && piped (std_out p) = "chat"
diff --git a/Utility/Scheduled.hs b/Utility/Scheduled.hs
index b3813323d..5e813d4a2 100644
--- a/Utility/Scheduled.hs
+++ b/Utility/Scheduled.hs
@@ -286,7 +286,7 @@ fromScheduledTime AnyTime = "any time"
fromScheduledTime (SpecificTime h m) =
show h' ++ (if m > 0 then ":" ++ pad 2 (show m) else "") ++ " " ++ ampm
where
- pad n s = take (n - length s) (repeat '0') ++ s
+ pad n s = replicate (n - length s) '0' ++ s
(h', ampm)
| h == 0 = (12, "AM")
| h < 12 = (h, "AM")
diff --git a/Utility/SshConfig.hs b/Utility/SshConfig.hs
index ca336a4b8..1f8581a28 100644
--- a/Utility/SshConfig.hs
+++ b/Utility/SshConfig.hs
@@ -81,7 +81,8 @@ genSshConfig = unlines . concatMap gen
gen (GlobalConfig s) = [setting s]
gen (HostConfig h cs) = ("Host " ++ h) : map (either comment setting) cs
- setting (SshSetting indent k v) = indent ++ k ++ " " ++ v
+ setting (SshSetting indent k v) = indent ++ k ++
+ if null v then "" else " " ++ v
comment (Comment indent c) = indent ++ c
findHostConfigKey :: SshConfig -> Key -> Maybe Value
@@ -117,8 +118,11 @@ changeUserSshConfig modifier = do
whenM (doesFileExist configfile) $ do
c <- readFileStrict configfile
let c' = modifier c
- when (c /= c') $
- viaTmp writeSshConfig configfile c'
+ when (c /= c') $ do
+ -- If it's a symlink, replace the file it
+ -- points to.
+ f <- catchDefaultIO configfile (canonicalizePath configfile)
+ viaTmp writeSshConfig f c'
writeSshConfig :: FilePath -> String -> IO ()
writeSshConfig f s = do
diff --git a/Utility/Url.hs b/Utility/Url.hs
index 976fe975d..19568fda8 100644
--- a/Utility/Url.hs
+++ b/Utility/Url.hs
@@ -11,6 +11,7 @@
{-# LANGUAGE FlexibleContexts #-}
module Utility.Url (
+ closeManager,
URLString,
UserAgent,
UrlOptions,
@@ -31,11 +32,21 @@ import Utility.Tmp
import qualified Build.SysConfig
import Network.URI
-import Network.HTTP.Conduit
import Network.HTTP.Types
import qualified Data.CaseInsensitive as CI
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as B8
+import Control.Monad.Trans.Resource
+import Network.HTTP.Conduit hiding (closeManager)
+
+-- closeManager is needed with older versions of http-client,
+-- but not new versions, which warn about using it. Urgh.
+#if ! MIN_VERSION_http_client(0,4,18)
+import Network.HTTP.Client (closeManager)
+#else
+closeManager :: Manager -> IO ()
+closeManager _ = return ()
+#endif
type URLString = String
@@ -164,16 +175,23 @@ getUrlInfo url uo = case parseURIRelaxed url of
firstheader h = headMaybe . map snd .
filter (\p -> fst p == h) . responseHeaders
- existsconduit req = withManager $ \mgr -> do
+ existsconduit req = do
+ mgr <- newManager
+#if MIN_VERSION_http_conduit(2,1,7)
+ tlsManagerSettings
+#else
+ conduitManagerSettings
+#endif
let req' = headRequest (applyRequest uo req)
- resp <- http req' mgr
- -- forces processing the response before the
- -- manager is closed
- ret <- liftIO $ if responseStatus resp == ok200
- then found
- (extractlen resp)
- (extractfilename resp)
- else dne
+ ret <- runResourceT $ do
+ resp <- http req' mgr
+ -- forces processing the response before the
+ -- manager is closed
+ liftIO $ if responseStatus resp == ok200
+ then found
+ (extractlen resp)
+ (extractfilename resp)
+ else dne
liftIO $ closeManager mgr
return ret
diff --git a/Utility/libdiskfree.c b/Utility/libdiskfree.c
index c2f8368f0..12d70e259 100644
--- a/Utility/libdiskfree.c
+++ b/Utility/libdiskfree.c
@@ -13,23 +13,26 @@
# include <sys/mount.h>
# define STATCALL statfs
# define STATSTRUCT statfs64
+# define BSIZE f_bsize
#else
#if defined (__FreeBSD__)
# include <sys/param.h>
# include <sys/mount.h>
# define STATCALL statfs /* statfs64 not yet tested on a real FreeBSD machine */
# define STATSTRUCT statfs
+# define BSIZE f_bsize
#else
#if defined __ANDROID__
# warning free space checking code not available for Android
# define UNKNOWN
#else
-#if defined (__linux__) || defined (__FreeBSD_kernel__)
-/* Linux or Debian kFreeBSD */
+#if defined (__linux__) || defined (__FreeBSD_kernel__) || (defined (__SVR4) && defined (__sun))
+/* Linux or Debian kFreeBSD or Solaris */
/* This is a POSIX standard, so might also work elsewhere too. */
# include <sys/statvfs.h>
# define STATCALL statvfs
# define STATSTRUCT statvfs
+# define BSIZE f_frsize
#else
# warning free space checking code not available for this OS
# define UNKNOWN
@@ -65,7 +68,7 @@ unsigned long long int get(const char *path, int req) {
v = 0;
}
- blocksize = buf.f_bsize;
+ blocksize = buf.BSIZE;
return v * blocksize;
#endif
}
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-05 21:45:02 +0000