clean up some ugly code
This commit is contained in:
parent
d6883dcd7f
commit
c6032b0dab
5 changed files with 40 additions and 24 deletions
|
@ -28,6 +28,7 @@ import Utility.Process as X
|
||||||
import Utility.Path as X
|
import Utility.Path as X
|
||||||
import Utility.Directory as X
|
import Utility.Directory as X
|
||||||
import Utility.Monad as X
|
import Utility.Monad as X
|
||||||
|
import Utility.Data as X
|
||||||
import Utility.Applicative as X
|
import Utility.Applicative as X
|
||||||
import Utility.FileSystemEncoding as X
|
import Utility.FileSystemEncoding as X
|
||||||
|
|
||||||
|
|
|
@ -14,6 +14,7 @@ module Remote.GCrypt (
|
||||||
|
|
||||||
import qualified Data.Map as M
|
import qualified Data.Map as M
|
||||||
import qualified Data.ByteString.Lazy as L
|
import qualified Data.ByteString.Lazy as L
|
||||||
|
import Control.Exception.Extensible
|
||||||
|
|
||||||
import Common.Annex
|
import Common.Annex
|
||||||
import Types.Remote
|
import Types.Remote
|
||||||
|
@ -374,22 +375,24 @@ coreGCryptId = "core.gcrypt-id"
|
||||||
- (Also returns a version of input repo with its config read.) -}
|
- (Also returns a version of input repo with its config read.) -}
|
||||||
getGCryptId :: Bool -> Git.Repo -> Annex (Maybe Git.GCrypt.GCryptId, Git.Repo)
|
getGCryptId :: Bool -> Git.Repo -> Annex (Maybe Git.GCrypt.GCryptId, Git.Repo)
|
||||||
getGCryptId fast r
|
getGCryptId fast r
|
||||||
| Git.repoIsLocal r = extract
|
| Git.repoIsLocal r = extract <$>
|
||||||
=<< liftIO (catchDefaultIO r $ Git.Config.read r)
|
liftIO (catchMaybeIO $ Git.Config.read r)
|
||||||
| not fast = do
|
| not fast = extract . liftM fst <$> getM (eitherToMaybe <$>)
|
||||||
fromshell <- Ssh.onRemote r (Git.Config.fromPipe r, Left undefined) "configlist" [] []
|
[ Ssh.onRemote r (Git.Config.fromPipe r, Left undefined) "configlist" [] []
|
||||||
case fromshell of
|
, getConfigViaRsync r
|
||||||
Right (r', _) -> extract r'
|
]
|
||||||
Left _ -> do
|
| otherwise = return (Nothing, r)
|
||||||
|
where
|
||||||
|
extract Nothing = (Nothing, r)
|
||||||
|
extract (Just r') = (Git.Config.getMaybe coreGCryptId r', r')
|
||||||
|
|
||||||
|
getConfigViaRsync :: Git.Repo -> Annex (Either SomeException (Git.Repo, String))
|
||||||
|
getConfigViaRsync r = do
|
||||||
(rsynctransport, rsyncurl, _) <- rsyncTransport r
|
(rsynctransport, rsyncurl, _) <- rsyncTransport r
|
||||||
fromrsync <- liftIO $ do
|
liftIO $ do
|
||||||
withTmpFile "tmpconfig" $ \tmpconfig _ -> do
|
withTmpFile "tmpconfig" $ \tmpconfig _ -> do
|
||||||
void $ rsync $ rsynctransport ++
|
void $ rsync $ rsynctransport ++
|
||||||
[ Param $ rsyncurl ++ "/config"
|
[ Param $ rsyncurl ++ "/config"
|
||||||
, Param tmpconfig
|
, Param tmpconfig
|
||||||
]
|
]
|
||||||
Git.Config.fromFile r tmpconfig
|
Git.Config.fromFile r tmpconfig
|
||||||
extract $ either (const r) fst fromrsync
|
|
||||||
| otherwise = return (Nothing, r)
|
|
||||||
where
|
|
||||||
extract r' = return (Git.Config.getMaybe coreGCryptId r', r')
|
|
||||||
|
|
17
Utility/Data.hs
Normal file
17
Utility/Data.hs
Normal file
|
@ -0,0 +1,17 @@
|
||||||
|
{- utilities for simple data types
|
||||||
|
-
|
||||||
|
- Copyright 2013 Joey Hess <joey@kitenet.net>
|
||||||
|
-
|
||||||
|
- Licensed under the GNU GPL version 3 or higher.
|
||||||
|
-}
|
||||||
|
|
||||||
|
module Utility.Data where
|
||||||
|
|
||||||
|
{- First item in the list that is not Nothing. -}
|
||||||
|
firstJust :: Eq a => [Maybe a] -> Maybe a
|
||||||
|
firstJust ms = case dropWhile (== Nothing) ms of
|
||||||
|
[] -> Nothing
|
||||||
|
(md:_) -> md
|
||||||
|
|
||||||
|
eitherToMaybe :: Either a b -> Maybe b
|
||||||
|
eitherToMaybe = either (const Nothing) Just
|
|
@ -14,6 +14,7 @@ import qualified Control.Exception as E
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import System.IO.Error (isDoesNotExistError)
|
import System.IO.Error (isDoesNotExistError)
|
||||||
|
import Utility.Data
|
||||||
|
|
||||||
{- Catches IO errors and returns a Bool -}
|
{- Catches IO errors and returns a Bool -}
|
||||||
catchBoolIO :: IO Bool -> IO Bool
|
catchBoolIO :: IO Bool -> IO Bool
|
||||||
|
@ -54,5 +55,5 @@ tryNonAsync a = (Right <$> a) `catchNonAsync` (return . Left)
|
||||||
|
|
||||||
{- Catches only DoesNotExist exceptions, and lets all others through. -}
|
{- Catches only DoesNotExist exceptions, and lets all others through. -}
|
||||||
tryWhenExists :: IO a -> IO (Maybe a)
|
tryWhenExists :: IO a -> IO (Maybe a)
|
||||||
tryWhenExists a = either (const Nothing) Just <$>
|
tryWhenExists a = eitherToMaybe <$>
|
||||||
tryJust (guard . isDoesNotExistError) a
|
tryJust (guard . isDoesNotExistError) a
|
||||||
|
|
|
@ -91,12 +91,6 @@ massReplace vs = go [] vs
|
||||||
go (replacement:acc) vs (drop (length val) s)
|
go (replacement:acc) vs (drop (length val) s)
|
||||||
| otherwise = go acc rest s
|
| otherwise = go acc rest s
|
||||||
|
|
||||||
{- First item in the list that is not Nothing. -}
|
|
||||||
firstJust :: Eq a => [Maybe a] -> Maybe a
|
|
||||||
firstJust ms = case dropWhile (== Nothing) ms of
|
|
||||||
[] -> Nothing
|
|
||||||
(md:_) -> md
|
|
||||||
|
|
||||||
{- Given two orderings, returns the second if the first is EQ and returns
|
{- Given two orderings, returns the second if the first is EQ and returns
|
||||||
- the first otherwise.
|
- the first otherwise.
|
||||||
-
|
-
|
||||||
|
|
Loading…
Reference in a new issue