expose Control.Monad.join
I think I've been looking for that function for some time. Ie, I remember wanting to collapse Just Nothing to Nothing.
This commit is contained in:
parent
2a84deb271
commit
8a2d1988d3
19 changed files with 30 additions and 32 deletions
|
@ -30,7 +30,7 @@ import Utility.Base64
|
||||||
- refs, per git-check-ref-format.
|
- refs, per git-check-ref-format.
|
||||||
-}
|
-}
|
||||||
toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Branch
|
toTaggedBranch :: UUID -> Maybe String -> Git.Branch -> Git.Branch
|
||||||
toTaggedBranch u info b = Git.Ref $ join "/" $ catMaybes
|
toTaggedBranch u info b = Git.Ref $ intercalate "/" $ catMaybes
|
||||||
[ Just "refs/synced"
|
[ Just "refs/synced"
|
||||||
, Just $ fromUUID u
|
, Just $ fromUUID u
|
||||||
, toB64 <$> info
|
, toB64 <$> info
|
||||||
|
|
|
@ -105,11 +105,11 @@ removeAuthorizedKeys rsynconly dir pubkey = do
|
||||||
- present.
|
- present.
|
||||||
-}
|
-}
|
||||||
addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String
|
addAuthorizedKeysCommand :: Bool -> FilePath -> SshPubKey -> String
|
||||||
addAuthorizedKeysCommand rsynconly dir pubkey = join "&&"
|
addAuthorizedKeysCommand rsynconly dir pubkey = intercalate "&&"
|
||||||
[ "mkdir -p ~/.ssh"
|
[ "mkdir -p ~/.ssh"
|
||||||
, join "; "
|
, intercalate "; "
|
||||||
[ "if [ ! -e " ++ wrapper ++ " ]"
|
[ "if [ ! -e " ++ wrapper ++ " ]"
|
||||||
, "then (" ++ join ";" (map echoval script) ++ ") > " ++ wrapper
|
, "then (" ++ intercalate ";" (map echoval script) ++ ") > " ++ wrapper
|
||||||
, "fi"
|
, "fi"
|
||||||
]
|
]
|
||||||
, "chmod 700 " ++ wrapper
|
, "chmod 700 " ++ wrapper
|
||||||
|
@ -217,7 +217,7 @@ mangleSshHostName :: SshData -> String
|
||||||
mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata)
|
mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata)
|
||||||
++ "-" ++ filter safe extra
|
++ "-" ++ filter safe extra
|
||||||
where
|
where
|
||||||
extra = join "_" $ map T.unpack $ catMaybes
|
extra = intercalate "_" $ map T.unpack $ catMaybes
|
||||||
[ sshUserName sshdata
|
[ sshUserName sshdata
|
||||||
, Just $ sshDirectory sshdata
|
, Just $ sshDirectory sshdata
|
||||||
]
|
]
|
||||||
|
@ -229,7 +229,7 @@ mangleSshHostName sshdata = "git-annex-" ++ T.unpack (sshHostName sshdata)
|
||||||
{- Extracts the real hostname from a mangled ssh hostname. -}
|
{- Extracts the real hostname from a mangled ssh hostname. -}
|
||||||
unMangleSshHostName :: String -> String
|
unMangleSshHostName :: String -> String
|
||||||
unMangleSshHostName h = case split "-" h of
|
unMangleSshHostName h = case split "-" h of
|
||||||
("git":"annex":rest) -> join "-" (beginning rest)
|
("git":"annex":rest) -> intercalate "-" (beginning rest)
|
||||||
_ -> h
|
_ -> h
|
||||||
|
|
||||||
{- Does ssh have known_hosts data for a hostname? -}
|
{- Does ssh have known_hosts data for a hostname? -}
|
||||||
|
|
|
@ -205,7 +205,7 @@ testServer sshinput@(SshInput { inputHostname = Just hn }) = do
|
||||||
, rsyncOnly = status == UsableRsyncServer
|
, rsyncOnly = status == UsableRsyncServer
|
||||||
}
|
}
|
||||||
probe extraopts = do
|
probe extraopts = do
|
||||||
let remotecommand = shellWrap $ join ";"
|
let remotecommand = shellWrap $ intercalate ";"
|
||||||
[ report "loggedin"
|
[ report "loggedin"
|
||||||
, checkcommand "git-annex-shell"
|
, checkcommand "git-annex-shell"
|
||||||
, checkcommand "rsync"
|
, checkcommand "rsync"
|
||||||
|
@ -287,7 +287,7 @@ makeSsh' rsync setup sshdata keypair =
|
||||||
where
|
where
|
||||||
sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
|
sshhost = genSshHost (sshHostName sshdata) (sshUserName sshdata)
|
||||||
remotedir = T.unpack $ sshDirectory sshdata
|
remotedir = T.unpack $ sshDirectory sshdata
|
||||||
remoteCommand = shellWrap $ join "&&" $ catMaybes
|
remoteCommand = shellWrap $ intercalate "&&" $ catMaybes
|
||||||
[ Just $ "mkdir -p " ++ shellEscape remotedir
|
[ Just $ "mkdir -p " ++ shellEscape remotedir
|
||||||
, Just $ "cd " ++ shellEscape remotedir
|
, Just $ "cd " ++ shellEscape remotedir
|
||||||
, if rsync then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared; fi"
|
, if rsync then Nothing else Just "if [ ! -d .git ]; then git init --bare --shared; fi"
|
||||||
|
@ -353,7 +353,7 @@ makeRsyncNet sshinput reponame setup = do
|
||||||
- one recommended by rsync.net documentation. I touch the file first
|
- one recommended by rsync.net documentation. I touch the file first
|
||||||
- to not need to use a different method to create it.
|
- to not need to use a different method to create it.
|
||||||
-}
|
-}
|
||||||
let remotecommand = join ";"
|
let remotecommand = intercalate ";"
|
||||||
[ "mkdir -p .ssh"
|
[ "mkdir -p .ssh"
|
||||||
, "touch .ssh/authorized_keys"
|
, "touch .ssh/authorized_keys"
|
||||||
, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
|
, "dd of=.ssh/authorized_keys oflag=append conv=notrunc"
|
||||||
|
|
|
@ -97,7 +97,7 @@ xmppPush cid gitpush handledeferred = runPush SendPack cid handledeferred $ do
|
||||||
env <- liftIO getEnvironment
|
env <- liftIO getEnvironment
|
||||||
path <- liftIO getSearchPath
|
path <- liftIO getSearchPath
|
||||||
let myenv = M.fromList
|
let myenv = M.fromList
|
||||||
[ ("PATH", join [searchPathSeparator] $ tmpdir:path)
|
[ ("PATH", intercalate [searchPathSeparator] $ tmpdir:path)
|
||||||
, (relayIn, show inf)
|
, (relayIn, show inf)
|
||||||
, (relayOut, show outf)
|
, (relayOut, show outf)
|
||||||
, (relayControl, show controlf)
|
, (relayControl, show controlf)
|
||||||
|
|
|
@ -121,7 +121,7 @@ keyValueE size source = keyValue size source >>= maybe (return Nothing) addE
|
||||||
selectExtension :: FilePath -> String
|
selectExtension :: FilePath -> String
|
||||||
selectExtension f
|
selectExtension f
|
||||||
| null es = ""
|
| null es = ""
|
||||||
| otherwise = join "." ("":es)
|
| otherwise = intercalate "." ("":es)
|
||||||
where
|
where
|
||||||
es = filter (not . null) $ reverse $
|
es = filter (not . null) $ reverse $
|
||||||
take 2 $ takeWhile shortenough $
|
take 2 $ takeWhile shortenough $
|
||||||
|
|
|
@ -156,7 +156,7 @@ url2file url pathdepth = case pathdepth of
|
||||||
| otherwise -> error "bad --pathdepth"
|
| otherwise -> error "bad --pathdepth"
|
||||||
where
|
where
|
||||||
fullurl = uriRegName auth ++ uriPath url ++ uriQuery url
|
fullurl = uriRegName auth ++ uriPath url ++ uriQuery url
|
||||||
frombits a = join "/" $ a urlbits
|
frombits a = intercalate "/" $ a urlbits
|
||||||
urlbits = map (filesize . escape) $ filter (not . null) $ split "/" fullurl
|
urlbits = map (filesize . escape) $ filter (not . null) $ split "/" fullurl
|
||||||
auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url
|
auth = fromMaybe (error $ "bad url " ++ show url) $ uriAuthority url
|
||||||
filesize = take 255
|
filesize = take 255
|
||||||
|
|
|
@ -31,7 +31,7 @@ start [] = do
|
||||||
error $ "Specify a name for the remote. " ++
|
error $ "Specify a name for the remote. " ++
|
||||||
if null names
|
if null names
|
||||||
then ""
|
then ""
|
||||||
else "Either a new name, or one of these existing special remotes: " ++ join " " names
|
else "Either a new name, or one of these existing special remotes: " ++ intercalate " " names
|
||||||
start (name:ws) = do
|
start (name:ws) = do
|
||||||
(u, c) <- findByName name
|
(u, c) <- findByName name
|
||||||
let fullconfig = config `M.union` c
|
let fullconfig = config `M.union` c
|
||||||
|
|
|
@ -95,7 +95,7 @@ runRequests readh writeh a = do
|
||||||
|
|
||||||
sendRequest :: Transfer -> AssociatedFile -> Handle -> IO ()
|
sendRequest :: Transfer -> AssociatedFile -> Handle -> IO ()
|
||||||
sendRequest t f h = do
|
sendRequest t f h = do
|
||||||
hPutStr h $ join fieldSep
|
hPutStr h $ intercalate fieldSep
|
||||||
[ serialize (transferDirection t)
|
[ serialize (transferDirection t)
|
||||||
, serialize (transferUUID t)
|
, serialize (transferUUID t)
|
||||||
, serialize (transferKey t)
|
, serialize (transferKey t)
|
||||||
|
|
|
@ -27,12 +27,10 @@ start = do
|
||||||
showPackageVersion
|
showPackageVersion
|
||||||
putStrLn $ "local repository version: " ++ fromMaybe "unknown" v
|
putStrLn $ "local repository version: " ++ fromMaybe "unknown" v
|
||||||
putStrLn $ "default repository version: " ++ defaultVersion
|
putStrLn $ "default repository version: " ++ defaultVersion
|
||||||
putStrLn $ "supported repository versions: " ++ vs supportedVersions
|
putStrLn $ "supported repository versions: " ++ unwords supportedVersions
|
||||||
putStrLn $ "upgrade supported from repository versions: " ++ vs upgradableVersions
|
putStrLn $ "upgrade supported from repository versions: " ++ unwords upgradableVersions
|
||||||
putStrLn $ "build flags: " ++ unwords buildFlags
|
putStrLn $ "build flags: " ++ unwords buildFlags
|
||||||
stop
|
stop
|
||||||
where
|
|
||||||
vs = join " "
|
|
||||||
|
|
||||||
showPackageVersion :: IO ()
|
showPackageVersion :: IO ()
|
||||||
showPackageVersion = putStrLn $ "git-annex version: " ++ SysConfig.packageversion
|
showPackageVersion = putStrLn $ "git-annex version: " ++ SysConfig.packageversion
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
|
|
||||||
module Common (module X) where
|
module Common (module X) where
|
||||||
|
|
||||||
import Control.Monad as X hiding (join)
|
import Control.Monad as X
|
||||||
import Control.Monad.IfElse as X
|
import Control.Monad.IfElse as X
|
||||||
import Control.Applicative as X
|
import Control.Applicative as X
|
||||||
import "mtl" Control.Monad.State.Strict as X (liftIO)
|
import "mtl" Control.Monad.State.Strict as X (liftIO)
|
||||||
|
@ -10,7 +10,7 @@ import Control.Exception.Extensible as X (IOException)
|
||||||
|
|
||||||
import Data.Maybe as X
|
import Data.Maybe as X
|
||||||
import Data.List as X hiding (head, tail, init, last)
|
import Data.List as X hiding (head, tail, init, last)
|
||||||
import Data.String.Utils as X
|
import Data.String.Utils as X hiding (join)
|
||||||
|
|
||||||
import "MissingH" System.Path as X
|
import "MissingH" System.Path as X
|
||||||
import System.FilePath as X
|
import System.FilePath as X
|
||||||
|
|
|
@ -130,7 +130,8 @@ remoteNamed n constructor = do
|
||||||
remoteNamedFromKey :: String -> IO Repo -> IO Repo
|
remoteNamedFromKey :: String -> IO Repo -> IO Repo
|
||||||
remoteNamedFromKey k = remoteNamed basename
|
remoteNamedFromKey k = remoteNamed basename
|
||||||
where
|
where
|
||||||
basename = join "." $ reverse $ drop 1 $ reverse $ drop 1 $ split "." k
|
basename = intercalate "." $
|
||||||
|
reverse $ drop 1 $ reverse $ drop 1 $ split "." k
|
||||||
|
|
||||||
{- Constructs a new Repo for one of a Repo's remotes using a given
|
{- Constructs a new Repo for one of a Repo's remotes using a given
|
||||||
- location (ie, an url). -}
|
- location (ie, an url). -}
|
||||||
|
|
|
@ -20,7 +20,6 @@ module Git.Queue (
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import System.IO
|
import System.IO
|
||||||
import System.Process
|
import System.Process
|
||||||
import Data.String.Utils
|
|
||||||
|
|
||||||
import Utility.SafeCommand
|
import Utility.SafeCommand
|
||||||
import Common
|
import Common
|
||||||
|
@ -151,7 +150,7 @@ runAction repo (UpdateIndexAction streamers) =
|
||||||
runAction repo action@(CommandAction {}) =
|
runAction repo action@(CommandAction {}) =
|
||||||
withHandle StdinHandle createProcessSuccess p $ \h -> do
|
withHandle StdinHandle createProcessSuccess p $ \h -> do
|
||||||
fileEncoding h
|
fileEncoding h
|
||||||
hPutStr h $ join "\0" $ getFiles action
|
hPutStr h $ intercalate "\0" $ getFiles action
|
||||||
hClose h
|
hClose h
|
||||||
where
|
where
|
||||||
p = (proc "xargs" params) { env = gitEnv repo }
|
p = (proc "xargs" params) { env = gitEnv repo }
|
||||||
|
|
|
@ -179,7 +179,7 @@ fileNotFound file = do
|
||||||
[ "git-annex:", file, "not found" ]
|
[ "git-annex:", file, "not found" ]
|
||||||
|
|
||||||
indent :: String -> String
|
indent :: String -> String
|
||||||
indent = join "\n" . map (\l -> " " ++ l) . lines
|
indent = intercalate "\n" . map (\l -> " " ++ l) . lines
|
||||||
|
|
||||||
{- Shows a JSON fragment only when in json mode. -}
|
{- Shows a JSON fragment only when in json mode. -}
|
||||||
maybeShowJSON :: JSON a => [(String, a)] -> Annex ()
|
maybeShowJSON :: JSON a => [(String, a)] -> Annex ()
|
||||||
|
|
|
@ -238,7 +238,7 @@ showTriedRemotes :: [Remote] -> Annex ()
|
||||||
showTriedRemotes [] = noop
|
showTriedRemotes [] = noop
|
||||||
showTriedRemotes remotes =
|
showTriedRemotes remotes =
|
||||||
showLongNote $ "Unable to access these remotes: " ++
|
showLongNote $ "Unable to access these remotes: " ++
|
||||||
join ", " (map name remotes)
|
intercalate ", " (map name remotes)
|
||||||
|
|
||||||
forceTrust :: TrustLevel -> String -> Annex ()
|
forceTrust :: TrustLevel -> String -> Annex ()
|
||||||
forceTrust level remotename = do
|
forceTrust level remotename = do
|
||||||
|
|
|
@ -257,7 +257,7 @@ bup2GitRemote r
|
||||||
where
|
where
|
||||||
bits = split ":" r
|
bits = split ":" r
|
||||||
host = Prelude.head bits
|
host = Prelude.head bits
|
||||||
dir = join ":" $ drop 1 bits
|
dir = intercalate ":" $ drop 1 bits
|
||||||
-- "host:~user/dir" is not supported specially by bup;
|
-- "host:~user/dir" is not supported specially by bup;
|
||||||
-- "host:dir" is relative to the home directory;
|
-- "host:dir" is relative to the home directory;
|
||||||
-- "host:" goes in ~/.bup
|
-- "host:" goes in ~/.bup
|
||||||
|
|
|
@ -123,7 +123,7 @@ storeCipher c (SharedCipher t) = M.insert "cipher" (toB64 t) c
|
||||||
storeCipher c (EncryptedCipher t ks) =
|
storeCipher c (EncryptedCipher t ks) =
|
||||||
M.insert "cipher" (toB64 t) $ M.insert "cipherkeys" (showkeys ks) c
|
M.insert "cipher" (toB64 t) $ M.insert "cipherkeys" (showkeys ks) c
|
||||||
where
|
where
|
||||||
showkeys (KeyIds l) = join "," l
|
showkeys (KeyIds l) = intercalate "," l
|
||||||
|
|
||||||
{- Extracts an StorableCipher from a remote's configuration. -}
|
{- Extracts an StorableCipher from a remote's configuration. -}
|
||||||
extractCipher :: RemoteConfig -> Maybe StorableCipher
|
extractCipher :: RemoteConfig -> Maybe StorableCipher
|
||||||
|
|
|
@ -143,7 +143,7 @@ oldlog2key l
|
||||||
-- as the v2 key that it is.
|
-- as the v2 key that it is.
|
||||||
readKey1 :: String -> Key
|
readKey1 :: String -> Key
|
||||||
readKey1 v
|
readKey1 v
|
||||||
| mixup = fromJust $ file2key $ join ":" $ Prelude.tail bits
|
| mixup = fromJust $ file2key $ intercalate ":" $ Prelude.tail bits
|
||||||
| otherwise = Key
|
| otherwise = Key
|
||||||
{ keyName = n
|
{ keyName = n
|
||||||
, keyBackendName = b
|
, keyBackendName = b
|
||||||
|
@ -153,7 +153,7 @@ readKey1 v
|
||||||
where
|
where
|
||||||
bits = split ":" v
|
bits = split ":" v
|
||||||
b = Prelude.head bits
|
b = Prelude.head bits
|
||||||
n = join ":" $ drop (if wormy then 3 else 1) bits
|
n = intercalate ":" $ drop (if wormy then 3 else 1) bits
|
||||||
t = if wormy
|
t = if wormy
|
||||||
then Just (Prelude.read (bits !! 1) :: EpochTime)
|
then Just (Prelude.read (bits !! 1) :: EpochTime)
|
||||||
else Nothing
|
else Nothing
|
||||||
|
@ -165,7 +165,7 @@ readKey1 v
|
||||||
|
|
||||||
showKey1 :: Key -> String
|
showKey1 :: Key -> String
|
||||||
showKey1 Key { keyName = n , keyBackendName = b, keySize = s, keyMtime = t } =
|
showKey1 Key { keyName = n , keyBackendName = b, keySize = s, keyMtime = t } =
|
||||||
join ":" $ filter (not . null) [b, showifhere t, showifhere s, n]
|
intercalate ":" $ filter (not . null) [b, showifhere t, showifhere s, n]
|
||||||
where
|
where
|
||||||
showifhere Nothing = ""
|
showifhere Nothing = ""
|
||||||
showifhere (Just v) = show v
|
showifhere (Just v) = show v
|
||||||
|
|
|
@ -32,7 +32,7 @@ setupLsof = do
|
||||||
when (isAbsolute cmd) $ do
|
when (isAbsolute cmd) $ do
|
||||||
path <- getSearchPath
|
path <- getSearchPath
|
||||||
let path' = takeDirectory cmd : path
|
let path' = takeDirectory cmd : path
|
||||||
setEnv "PATH" (join [searchPathSeparator] path') True
|
setEnv "PATH" (intercalate [searchPathSeparator] path') True
|
||||||
|
|
||||||
{- Checks each of the files in a directory to find open files.
|
{- Checks each of the files in a directory to find open files.
|
||||||
- Note that this will find hard links to files elsewhere that are open. -}
|
- Note that this will find hard links to files elsewhere that are open. -}
|
||||||
|
|
|
@ -22,7 +22,7 @@ rsyncShell command = [Param "-e", Param $ unwords $ map escape (toCommand comman
|
||||||
{- rsync requires some weird, non-shell like quoting in
|
{- rsync requires some weird, non-shell like quoting in
|
||||||
- here. A doubled single quote inside the single quoted
|
- here. A doubled single quote inside the single quoted
|
||||||
- string is a single quote. -}
|
- string is a single quote. -}
|
||||||
escape s = "'" ++ join "''" (split "'" s) ++ "'"
|
escape s = "'" ++ intercalate "''" (split "'" s) ++ "'"
|
||||||
|
|
||||||
{- Runs rsync in server mode to send a file. -}
|
{- Runs rsync in server mode to send a file. -}
|
||||||
rsyncServerSend :: [CommandParam] -> FilePath -> IO Bool
|
rsyncServerSend :: [CommandParam] -> FilePath -> IO Bool
|
||||||
|
|
Loading…
Reference in a new issue