centralized "yes"/"no" parsing

This commit was sponsored by Jack Hill on Patreon.

Annex/Export.hs

@@ -12,9 +12,11 @@ import Annex.CatFile
 import Types.Key
 import Types.Remote
 import qualified Git
+import Config
 
 import qualified Data.Map as M
 import Control.Applicative
+import Data.Maybe
 import Prelude
 
 -- An export includes both annexed files and files stored in git.
@@ -40,6 +42,4 @@ exportKey sha = mk <$> catKey sha
 		}
 
 exportTree :: RemoteConfig -> Bool
-exportTree c = case M.lookup "exporttree" c of
-	Just "yes" -> True
-	_ -> False
+exportTree c = fromMaybe False $ yesNo =<< M.lookup "exporttree" c

Config.hs

@@ -102,3 +102,8 @@ setCrippledFileSystem :: Bool -> Annex ()
 setCrippledFileSystem b = do
 	setConfig (annexConfig "crippledfilesystem") (Git.Config.boolConfig b)
 	Annex.changeGitConfig $ \c -> c { annexCrippledFileSystem = b }
+
+yesNo :: String -> Maybe Bool
+yesNo "yes" = Just True
+yesNo "no" = Just False
+yesNo _ = Nothing

Remote/Helper/Encryptable.hs

@@ -25,6 +25,7 @@ import qualified Data.ByteString as B
 
 import Annex.Common
 import Types.Remote
+import Config
 import Crypto
 import Types.Crypto
 import qualified Annex
@@ -128,11 +129,9 @@ remoteCipher' c gc = go $ extractCipher c
  - Not when a shared cipher is used.
  -}
 embedCreds :: RemoteConfig -> Bool
-embedCreds c
-	| M.lookup "embedcreds" c == Just "yes" = True
-	| M.lookup "embedcreds" c == Just "no" = False
-	| isJust (M.lookup "cipherkeys" c) && isJust (M.lookup "cipher" c) = True
-	| otherwise = False
+embedCreds c = case yesNo =<< M.lookup "embedcreds" c of
+	Just v -> v
+	Nothing -> isJust (M.lookup "cipherkeys" c) && isJust (M.lookup "cipher" c)
 
 {- Gets encryption Cipher, and key encryptor. -}
 cipherKey :: RemoteConfig -> RemoteGitConfig -> Annex (Maybe (Cipher, EncKey))

Remote/Helper/Export.hs

@@ -17,6 +17,7 @@ import Backend
 import Remote.Helper.Encryptable (isEncrypted)
 import Database.Export
 import Annex.Export
+import Config
 
 import qualified Data.Map as M
 import Control.Concurrent.STM
@@ -69,15 +70,16 @@ adjustExportableRemoteType rt = rt { setup = setup' }
 -- remote to be an export.
 adjustExportable :: Remote -> Annex Remote
 adjustExportable r = case M.lookup "exporttree" (config r) of
-	Just "yes" -> ifM (isExportSupported r)
-		( isexport
-		, notexport
-		)
 	Nothing -> notexport
-	Just "no" -> notexport
-	Just _ -> do
-		warning $ "bad exporttree value for " ++ name r ++ ", assuming not an export"
-		notexport
+	Just c -> case yesNo c of
+		Just True -> ifM (isExportSupported r)
+			( isexport
+			, notexport
+			)
+		Just False -> notexport
+		Nothing -> do
+			warning $ "bad exporttree value for " ++ name r ++ ", assuming not an export"
+			notexport
   where
 	notexport = return $ r 
 		{ exportActions = exportUnsupported

Remote/Rsync.hs

@@ -114,7 +114,7 @@ genRsyncOpts c gc transport url = RsyncOpts
 	, rsyncOptions = transport ++ opts []
 	, rsyncUploadOptions = transport ++ opts (remoteAnnexRsyncUploadOptions gc)
 	, rsyncDownloadOptions = transport ++ opts (remoteAnnexRsyncDownloadOptions gc)
-	, rsyncShellEscape = M.lookup "shellescape" c /= Just "no"
+	, rsyncShellEscape = (yesNo =<< M.lookup "shellescape" c) /= Just False
 	}
   where
 	opts specificopts = map Param $ filter safe $

Remote/S3.hs

@@ -605,9 +605,7 @@ extractS3Info c = do
 		, host = M.lookup "host" c
 		}
   where
-	boolcfg k = case M.lookup k c of
-		Just "yes" -> True
-		_ -> False
+	boolcfg k = fromMaybe False $ yesNo =<< M.lookup k c
 
 putObject :: S3Info -> T.Text -> RequestBody -> S3.PutObject
 putObject info file rbody = (S3.putObject (bucket info) file rbody)

Remote/Tahoe.hs

@@ -104,7 +104,7 @@ tahoeSetup _ mu _ c _ = do
 	u <- maybe (liftIO genUUID) return mu
 	configdir <- liftIO $ defaultTahoeConfigDir u
 	scs <- liftIO $ tahoeConfigure configdir furl (M.lookup scsk c)
-	let c' = if M.lookup "embedcreds" c == Just "yes"
+	let c' = if (yesNo =<< M.lookup "embedcreds" c) == Just True
 		then flip M.union c $ M.fromList
 			[ (furlk, furl)
 			, (scsk, scs)