Merge branch 'master' into s3-aws

Conflicts:
	Remote/S3.hs
This commit is contained in:
Joey Hess 2014-10-22 17:14:38 -04:00
commit 35551d0ed0
502 changed files with 7127 additions and 2453 deletions

View file

@ -454,7 +454,7 @@ handleTransitions jl localts refs = do
ignoreRefs untransitionedrefs
return True
where
getreftransition ref = do
getreftransition ref = do
ts <- parseTransitionsStrictly "remote" . decodeBS
<$> catFile ref transitionsLog
return (ref, ts)
@ -470,7 +470,7 @@ ignoreRefs rs = do
getIgnoredRefs :: Annex (S.Set Git.Ref)
getIgnoredRefs = S.fromList . mapMaybe Git.Sha.extractSha . lines <$> content
where
content = do
content = do
f <- fromRepo gitAnnexIgnoredRefs
liftIO $ catchDefaultIO "" $ readFile f
@ -498,7 +498,7 @@ performTransitionsLocked jl ts neednewlocalbranch transitionedrefs = do
ref <- getBranch
commitIndex jl ref message (nub $ fullname:transitionedrefs)
where
message
message
| neednewlocalbranch && null transitionedrefs = "new branch for transition " ++ tdesc
| otherwise = "continuing transition " ++ tdesc
tdesc = show $ map describeTransition $ transitionList ts

View file

@ -19,6 +19,7 @@ import Types.TrustLevel
import Types.UUID
import qualified Data.Map as M
import Data.Default
data FileTransition
= ChangeFile String
@ -60,4 +61,4 @@ dropDeadFromPresenceLog :: TrustMap -> [Presence.LogLine] -> [Presence.LogLine]
dropDeadFromPresenceLog trustmap = filter $ notDead trustmap (toUUID . Presence.info)
notDead :: TrustMap -> (v -> UUID) -> v -> Bool
notDead trustmap a v = M.findWithDefault SemiTrusted (a v) trustmap /= DeadTrusted
notDead trustmap a v = M.findWithDefault def (a v) trustmap /= DeadTrusted

View file

@ -100,10 +100,10 @@ catKey' modeguaranteed sha mode
catLink :: Bool -> Sha -> Annex String
catLink modeguaranteed sha = fromInternalGitPath . decodeBS <$> get
where
-- If the mode is not guaranteed to be correct, avoid
-- If the mode is not guaranteed to be correct, avoid
-- buffering the whole file content, which might be large.
-- 8192 is enough if it really is a symlink.
get
get
| modeguaranteed = catObject sha
| otherwise = L.take 8192 <$> catObject sha
@ -120,7 +120,7 @@ catKeyChecked :: Bool -> Ref -> Annex (Maybe Key)
catKeyChecked needhead ref@(Ref r) =
catKey' False ref =<< findmode <$> catTree treeref
where
pathparts = split "/" r
pathparts = split "/" r
dir = intercalate "/" $ take (length pathparts - 1) pathparts
file = fromMaybe "" $ lastMaybe pathparts
treeref = Ref $ if needhead then "HEAD" ++ dir ++ "/" else dir ++ "/"

View file

@ -18,7 +18,7 @@ import qualified Annex
checkIgnored :: FilePath -> Annex Bool
checkIgnored file = go =<< checkIgnoreHandle
where
go Nothing = return False
go Nothing = return False
go (Just h) = liftIO $ Git.checkIgnored h file
checkIgnoreHandle :: Annex (Maybe Git.CheckIgnoreHandle)

View file

@ -456,7 +456,7 @@ removeAnnex (ContentLock key) = withObjectLoc key remove removedirect
secureErase :: FilePath -> Annex ()
secureErase file = maybe noop go =<< annexSecureEraseCommand <$> Annex.getGitConfig
where
go basecmd = void $ liftIO $
go basecmd = void $ liftIO $
boolSystem "sh" [Param "-c", Param $ gencmd basecmd]
gencmd = massReplace [ ("%file", shellEscape file) ]
@ -555,7 +555,7 @@ saveState nocommit = doSideAction $ do
downloadUrl :: [Url.URLString] -> FilePath -> Annex Bool
downloadUrl urls file = go =<< annexWebDownloadCommand <$> Annex.getGitConfig
where
go Nothing = Url.withUrlOptions $ \uo ->
go Nothing = Url.withUrlOptions $ \uo ->
anyM (\u -> Url.download u file uo) urls
go (Just basecmd) = liftIO $ anyM (downloadcmd basecmd) urls
downloadcmd basecmd url =

View file

@ -347,7 +347,7 @@ toDirectGen k f = do
(dloc:_) -> return $ Just $ fromdirect dloc
)
where
fromindirect loc = do
fromindirect loc = do
{- Move content from annex to direct file. -}
updateInodeCache k loc
void $ addAssociatedFile k f

View file

@ -13,10 +13,7 @@ import Common.Annex
import Utility.UserInfo
import qualified Git.Config
import Config
#ifndef mingw32_HOST_OS
import Utility.Env
#endif
{- Checks that the system's environment allows git to function.
- Git requires a GECOS username, or suitable git configuration, or
@ -35,31 +32,26 @@ checkEnvironment = do
liftIO checkEnvironmentIO
checkEnvironmentIO :: IO ()
checkEnvironmentIO =
#ifdef mingw32_HOST_OS
noop
#else
whenM (null <$> myUserGecos) $ do
username <- myUserName
ensureEnv "GIT_AUTHOR_NAME" username
ensureEnv "GIT_COMMITTER_NAME" username
checkEnvironmentIO = whenM (null <$> myUserGecos) $ do
username <- myUserName
ensureEnv "GIT_AUTHOR_NAME" username
ensureEnv "GIT_COMMITTER_NAME" username
where
#ifndef __ANDROID__
-- existing environment is not overwritten
ensureEnv var val = void $ setEnv var val False
-- existing environment is not overwritten
ensureEnv var val = setEnv var val False
#else
-- Environment setting is broken on Android, so this is dealt with
-- in runshell instead.
ensureEnv _ _ = noop
#endif
#endif
{- Runs an action that commits to the repository, and if it fails,
- sets user.email and user.name to a dummy value and tries the action again. -}
ensureCommit :: Annex a -> Annex a
ensureCommit a = either retry return =<< tryNonAsync a
where
retry _ = do
retry _ = do
name <- liftIO myUserName
setConfig (ConfigKey "user.name") name
setConfig (ConfigKey "user.email") name

View file

@ -106,7 +106,7 @@ tokenizeMatcher = filter (not . null ) . concatMap splitparens . words
largeFilesMatcher :: Annex (FileMatcher Annex)
largeFilesMatcher = go =<< annexLargeFiles <$> Annex.getGitConfig
where
go Nothing = return matchAll
go Nothing = return matchAll
go (Just expr) = do
gm <- groupMap
rc <- readRemoteLog

View file

@ -33,7 +33,7 @@ replaceFileOr file action rollback = do
tmpfile <- liftIO $ setup tmpdir
go tmpfile `catchNonAsync` (const $ rollback tmpfile)
where
setup tmpdir = do
setup tmpdir = do
(tmpfile, h) <- openTempFileWithDefaultPermissions tmpdir "tmp"
hClose h
return tmpfile

View file

@ -78,10 +78,10 @@ bestSocketPath abssocketfile = do
then Just socketfile
else Nothing
where
-- ssh appends a 16 char extension to the socket when setting it
-- ssh appends a 16 char extension to the socket when setting it
-- up, which needs to be taken into account when checking
-- that a valid socket was constructed.
sshgarbage = replicate (1+16) 'X'
sshgarbage = replicate (1+16) 'X'
sshConnectionCachingParams :: FilePath -> [CommandParam]
sshConnectionCachingParams socketfile =

View file

@ -49,13 +49,13 @@ fromTaggedBranch b = case split "/" $ Git.fromRef b of
taggedPush :: UUID -> Maybe String -> Git.Ref -> Remote -> Git.Repo -> IO Bool
taggedPush u info branch remote = Git.Command.runBool
[ Param "push"
, Param $ Remote.name remote
[ Param "push"
, Param $ Remote.name remote
{- Using forcePush here is safe because we "own" the tagged branch
- we're pushing; it has no other writers. Ensures it is pushed
- even if it has been rewritten by a transition. -}
, Param $ Git.Branch.forcePush $ refspec Annex.Branch.name
, Param $ refspec branch
]
, Param $ Git.Branch.forcePush $ refspec Annex.Branch.name
, Param $ refspec branch
]
where
refspec b = Git.fromRef b ++ ":" ++ Git.fromRef (toTaggedBranch u info b)

View file

@ -69,7 +69,7 @@ runTransfer' ignorelock t file shouldretry a = do
return False
else do
ok <- retry info metervar $
bracketIO (return fd) (cleanup tfile) (const $ a meter)
bracketIO (return fd) (cleanup tfile) (const $ a meter)
unless ok $ recordFailedTransfer t info
return ok
where

View file

@ -102,7 +102,7 @@ refineView origview = checksize . calc Unchanged origview
let (components', viewchanges) = runWriter $
mapM (\c -> updateViewComponent c field vf) (viewComponents view)
viewchange = if field `elem` map viewField (viewComponents origview)
then maximum viewchanges
then maximum viewchanges
else Narrowing
in (view { viewComponents = components' }, viewchange)
| otherwise =
@ -207,7 +207,7 @@ viewComponentMatcher :: ViewComponent -> (MetaData -> Maybe [MetaValue])
viewComponentMatcher viewcomponent = \metadata ->
matcher (currentMetaDataValues metafield metadata)
where
metafield = viewField viewcomponent
metafield = viewField viewcomponent
matcher = case viewFilter viewcomponent of
FilterValues s -> \values -> setmatches $
S.intersection s values
@ -236,8 +236,8 @@ toViewPath = concatMap escapeslash . fromMetaValue
fromViewPath :: FilePath -> MetaValue
fromViewPath = toMetaValue . deescapeslash []
where
deescapeslash s [] = reverse s
deescapeslash s (c:cs)
deescapeslash s [] = reverse s
deescapeslash s (c:cs)
| c == pseudoSlash = case cs of
(c':cs')
| c' == pseudoSlash -> deescapeslash (pseudoSlash:s) cs'

View file

@ -58,7 +58,7 @@ viewedFileReuse = takeFileName
dirFromViewedFile :: ViewedFile -> FilePath
dirFromViewedFile = joinPath . drop 1 . sep [] ""
where
sep l _ [] = reverse l
sep l _ [] = reverse l
sep l curr (c:cs)
| c == '%' = sep (reverse curr:l) "" cs
| c == '\\' = case cs of

View file

@ -119,7 +119,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
)
#endif
where
desc
desc
| assistant = "assistant"
| otherwise = "watch"
start daemonize webappwaiter = withThreadState $ \st -> do
@ -147,7 +147,7 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
let threads = if isJust cannotrun
then webappthread
else webappthread ++
[ watch $ commitThread
[ watch commitThread
#ifdef WITH_WEBAPP
#ifdef WITH_PAIRING
, assist $ pairListenerThread urlrenderer
@ -158,29 +158,29 @@ startDaemon assistant foreground startdelay cannotrun listenhost startbrowser =
, assist $ xmppReceivePackThread urlrenderer
#endif
#endif
, assist $ pushThread
, assist $ pushRetryThread
, assist $ mergeThread
, assist $ transferWatcherThread
, assist $ transferPollerThread
, assist $ transfererThread
, assist $ remoteControlThread
, assist $ daemonStatusThread
, assist pushThread
, assist pushRetryThread
, assist mergeThread
, assist transferWatcherThread
, assist transferPollerThread
, assist transfererThread
, assist remoteControlThread
, assist daemonStatusThread
, assist $ sanityCheckerDailyThread urlrenderer
, assist $ sanityCheckerHourlyThread
, assist sanityCheckerHourlyThread
, assist $ problemFixerThread urlrenderer
#ifdef WITH_CLIBS
, assist $ mountWatcherThread urlrenderer
#endif
, assist $ netWatcherThread
, assist netWatcherThread
, assist $ upgraderThread urlrenderer
, assist $ upgradeWatcherThread urlrenderer
, assist $ netWatcherFallbackThread
, assist netWatcherFallbackThread
, assist $ transferScannerThread urlrenderer
, assist $ cronnerThread urlrenderer
, assist $ configMonitorThread
, assist $ glacierThread
, watch $ watchThread
, assist configMonitorThread
, assist glacierThread
, watch watchThread
-- must come last so that all threads that wait
-- on it have already started waiting
, watch $ sanityCheckerStartupThread startdelay

View file

@ -145,7 +145,7 @@ syncResultAlert' succeeded failed = makeAlertFiller (not $ null succeeded) $
, alertHeader = Just $ tenseWords msg
}
where
msg
msg
| null succeeded = ["Failed to sync with", showRemotes failed]
| null failed = ["Synced with", showRemotes succeeded]
| otherwise =

View file

@ -119,7 +119,7 @@ mergeAlert i al m = maybe updatePrune updateCombine (alertCombiner al)
where
bloat = M.size m' - maxAlerts
pruneold l =
let (f, rest) = partition (\(_, a) -> isFiller a) l
let (f, rest) = partition (\(_, a) -> isFiller a) l
in drop bloat f ++ rest
updatePrune = pruneBloat $ M.filterWithKey pruneSame $
M.insertWith' const i al m

View file

@ -65,7 +65,7 @@ calcSyncRemotes = do
, syncingToCloudRemote = any iscloud syncdata
}
where
iscloud r = not (Remote.readonly r) && Remote.availability r == Remote.GloballyAvailable
iscloud r = not (Remote.readonly r) && Remote.availability r == Remote.GloballyAvailable
{- Updates the syncRemotes list from the list of all remotes in Annex state. -}
updateSyncRemotes :: Assistant ()

View file

@ -62,7 +62,7 @@ removableRemote urlrenderer uuid = do
<$> liftAnnex (Remote.remoteFromUUID uuid)
mapM_ (queueremaining r) keys
where
queueremaining r k =
queueremaining r k =
queueTransferWhenSmall "remaining object in unwanted remote"
Nothing (Transfer Download uuid k) r
{- Scanning for keys can take a long time; do not tie up

View file

@ -20,7 +20,7 @@ newUserId :: IO UserId
newUserId = do
oldkeys <- secretKeys
username <- myUserName
let basekeyname = username ++ "'s git-annex encryption key"
let basekeyname = username ++ "'s git-annex encryption key"
return $ Prelude.head $ filter (\n -> M.null $ M.filter (== n) oldkeys)
( basekeyname
: map (\n -> basekeyname ++ show n) ([2..] :: [Int])

View file

@ -48,7 +48,7 @@ makeRsyncRemote :: RemoteName -> String -> Annex String
makeRsyncRemote name location = makeRemote name location $ const $ void $
go =<< Command.InitRemote.findExisting name
where
go Nothing = setupSpecialRemote name Rsync.remote config Nothing
go Nothing = setupSpecialRemote name Rsync.remote config Nothing
(Nothing, Command.InitRemote.newConfig name)
go (Just (u, c)) = setupSpecialRemote name Rsync.remote config Nothing
(Just u, c)

View file

@ -80,7 +80,7 @@ checkImportantNetMessages (storedclient, sentclient) = go <<~ netMessager
queuePushInitiation :: NetMessage -> Assistant ()
queuePushInitiation msg@(Pushing clientid stage) = do
tv <- getPushInitiationQueue side
liftIO $ atomically $ do
liftIO $ atomically $ do
r <- tryTakeTMVar tv
case r of
Nothing -> putTMVar tv [msg]
@ -88,7 +88,7 @@ queuePushInitiation msg@(Pushing clientid stage) = do
let !l' = msg : filter differentclient l
putTMVar tv l'
where
side = pushDestinationSide stage
side = pushDestinationSide stage
differentclient (Pushing cid _) = cid /= clientid
differentclient _ = True
queuePushInitiation _ = noop

View file

@ -63,7 +63,7 @@ runRepair u mrmt destructiverepair = do
return ok
where
localrepair fsckresults = do
localrepair fsckresults = do
-- Stop the watcher from running while running repairs.
changeSyncable Nothing False
@ -140,9 +140,9 @@ repairStaleGitLocks r = do
repairStaleLocks :: [FilePath] -> Assistant ()
repairStaleLocks lockfiles = go =<< getsizes
where
getsize lf = catchMaybeIO $
getsize lf = catchMaybeIO $
(\s -> (lf, fileSize s)) <$> getFileStatus lf
getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles
getsizes = liftIO $ catMaybes <$> mapM getsize lockfiles
go [] = return ()
go l = ifM (liftIO $ null <$> Lsof.query ("--" : map fst l))
( do

View file

@ -92,7 +92,7 @@ parseSshUrl u
, sshCapabilities = []
}
where
(user, host) = if '@' `elem` userhost
(user, host) = if '@' `elem` userhost
then separate (== '@') userhost
else ("", userhost)
fromrsync s
@ -260,7 +260,7 @@ setupSshKeyPair sshkeypair sshdata = do
fixSshKeyPairIdentitiesOnly :: IO ()
fixSshKeyPairIdentitiesOnly = changeUserSshConfig $ unlines . go [] . lines
where
go c [] = reverse c
go c [] = reverse c
go c (l:[])
| all (`isInfixOf` l) indicators = go (fixedline l:l:c) []
| otherwise = go (l:c) []
@ -268,7 +268,7 @@ fixSshKeyPairIdentitiesOnly = changeUserSshConfig $ unlines . go [] . lines
| all (`isInfixOf` l) indicators && not ("IdentitiesOnly" `isInfixOf` next) =
go (fixedline l:l:c) (next:rest)
| otherwise = go (l:c) (next:rest)
indicators = ["IdentityFile", "key.git-annex"]
indicators = ["IdentityFile", "key.git-annex"]
fixedline tmpl = takeWhile isSpace tmpl ++ "IdentitiesOnly yes"
{- Add StrictHostKeyChecking to any ssh config stanzas that were written

View file

@ -164,8 +164,8 @@ waitChangeTime a = waitchanges 0
-}
aftermaxcommit oldchanges = loop (30 :: Int)
where
loop 0 = continue oldchanges
loop n = do
loop 0 = continue oldchanges
loop n = do
liftAnnex noop -- ensure Annex state is free
liftIO $ threadDelaySeconds (Seconds 1)
changes <- getAnyChanges
@ -301,7 +301,7 @@ handleAdds havelsof delayadd cs = returnWhen (null incomplete) $ do
add change@(InProcessAddChange { keySource = ks }) =
catchDefaultIO Nothing <~> doadd
where
doadd = sanitycheck ks $ do
doadd = sanitycheck ks $ do
(mkey, mcache) <- liftAnnex $ do
showStart "add" $ keyFilename ks
Command.Add.ingest $ Just ks

View file

@ -87,7 +87,7 @@ cronnerThread urlrenderer = namedThreadUnchecked "Cronner" $ do
liftIO $ waitNotification h
debug ["reloading changed activities"]
go h amap' nmap'
startactivities as lastruntimes = forM as $ \activity ->
startactivities as lastruntimes = forM as $ \activity ->
case connectActivityUUID activity of
Nothing -> do
runner <- asIO2 (sleepingActivityThread urlrenderer)
@ -108,8 +108,8 @@ cronnerThread urlrenderer = namedThreadUnchecked "Cronner" $ do
sleepingActivityThread :: UrlRenderer -> ScheduledActivity -> Maybe LocalTime -> Assistant ()
sleepingActivityThread urlrenderer activity lasttime = go lasttime =<< getnexttime lasttime
where
getnexttime = liftIO . nextTime schedule
go _ Nothing = debug ["no scheduled events left for", desc]
getnexttime = liftIO . nextTime schedule
go _ Nothing = debug ["no scheduled events left for", desc]
go l (Just (NextTimeExactly t)) = waitrun l t Nothing
go l (Just (NextTimeWindow windowstart windowend)) =
waitrun l windowstart (Just windowend)
@ -129,7 +129,7 @@ sleepingActivityThread urlrenderer activity lasttime = go lasttime =<< getnextti
go l =<< getnexttime l
else run nowt
where
tolate nowt tz = case mmaxt of
tolate nowt tz = case mmaxt of
Just maxt -> nowt > maxt
-- allow the job to start 10 minutes late
Nothing ->diffUTCTime

View file

@ -258,7 +258,7 @@ checkOldUnused :: UrlRenderer -> Assistant ()
checkOldUnused urlrenderer = go =<< annexExpireUnused <$> liftAnnex Annex.getGitConfig
where
go (Just Nothing) = noop
go (Just (Just expireunused)) = expireUnused (Just expireunused)
go (Just (Just expireunused)) = expireUnused (Just expireunused)
go Nothing = maybe noop prompt =<< describeUnusedWhenBig
prompt msg =

View file

@ -51,9 +51,9 @@ upgradeWatcherThread urlrenderer = namedThread "UpgradeWatcher" $ do
let depth = length (splitPath dir) + 1
let nosubdirs f = length (splitPath f) == depth
void $ liftIO $ watchDir dir nosubdirs False hooks (startup mvar)
-- Ignore bogus events generated during the startup scan.
-- Ignore bogus events generated during the startup scan.
-- We ask the watcher to not generate them, but just to be safe..
startup mvar scanner = do
startup mvar scanner = do
r <- scanner
void $ swapMVar mvar Started
return r

View file

@ -39,7 +39,7 @@ upgraderThread urlrenderer = namedThread "Upgrader" $
h <- liftIO . newNotificationHandle False . networkConnectedNotifier =<< getDaemonStatus
go h =<< liftIO getCurrentTime
where
{- Wait for a network connection event. Then see if it's been
{- Wait for a network connection event. Then see if it's been
- half a day since the last upgrade check. If so, proceed with
- check. -}
go h lastchecked = do

View file

@ -72,7 +72,7 @@ needLsof = error $ unlines
{- A special exception that can be thrown to pause or resume the watcher. -}
data WatcherControl = PauseWatcher | ResumeWatcher
deriving (Show, Eq, Typeable)
deriving (Show, Eq, Typeable)
instance E.Exception WatcherControl
@ -192,7 +192,7 @@ runHandler handler file filestatus = void $ do
liftAnnex Annex.Queue.flushWhenFull
recordChange change
where
normalize f
normalize f
| "./" `isPrefixOf` file = drop 2 f
| otherwise = f
@ -246,7 +246,7 @@ onAddDirect symlinkssupported matcher file fs = do
debug ["add direct", file]
add matcher file
where
{- On a filesystem without symlinks, we'll get changes for regular
{- On a filesystem without symlinks, we'll get changes for regular
- files that git uses to stand-in for symlinks. Detect when
- this happens, and stage the symlink, rather than annexing the
- file. -}
@ -276,7 +276,7 @@ onAddSymlink isdirect file filestatus = unlessIgnored file $ do
onAddSymlink' :: Maybe String -> Maybe Key -> Bool -> Handler
onAddSymlink' linktarget mk isdirect file filestatus = go mk
where
go (Just key) = do
go (Just key) = do
when isdirect $
liftAnnex $ void $ addAssociatedFile key file
link <- liftAnnex $ inRepo $ gitAnnexLink file key

View file

@ -6,6 +6,7 @@
-}
{-# LANGUAGE TemplateHaskell, MultiParamTypeClasses #-}
{-# LANGUAGE ViewPatterns, OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
@ -97,7 +98,7 @@ webAppThread assistantdata urlrenderer noannex cannotrun postfirstrun listenhost
urlfile <- getAnnex' $ fromRepo gitAnnexUrlFile
go tlssettings addr webapp htmlshim (Just urlfile)
where
-- The webapp thread does not wait for the startupSanityCheckThread
-- The webapp thread does not wait for the startupSanityCheckThread
-- to finish, so that the user interface remains responsive while
-- that's going on.
thread = namedThreadUnchecked "WebApp"

View file

@ -131,7 +131,7 @@ xmppClient urlrenderer d creds xmppuuid =
{- XEP-0199 says that the server will respond with either
- a ping response or an error message. Either will
- cause traffic, so good enough. -}
pingstanza = xmppPing selfjid
pingstanza = xmppPing selfjid
handlemsg selfjid (PresenceMessage p) = do
void $ inAssistant $

View file

@ -34,7 +34,7 @@ xmppReceivePackThread = pusherThread "XMPPReceivePack" ReceivePack
pusherThread :: String -> PushSide -> UrlRenderer -> NamedThread
pusherThread threadname side urlrenderer = namedThread threadname $ go Nothing
where
go lastpushedto = do
go lastpushedto = do
msg <- waitPushInitiation side $ selectNextPush lastpushedto
debug ["started running push", logNetMessage msg]
@ -78,4 +78,4 @@ selectNextPush lastpushedto l = go [] l
(Pushing clientid _)
| Just clientid /= lastpushedto -> (m, rejected ++ ms)
_ -> go (m:rejected) ms
go [] [] = undefined
go [] [] = undefined

View file

@ -92,7 +92,7 @@ queueTransfersMatching matching reason schedule k f direction
filterM (wantSend True (Just k) f . Remote.uuid) $
filter (\r -> not (inset s r || Remote.readonly r)) rs
where
locs = S.fromList <$> Remote.keyLocations k
locs = S.fromList <$> Remote.keyLocations k
inset s r = S.member (Remote.uuid r) s
gentransfer r = Transfer
{ transferDirection = direction

View file

@ -85,7 +85,7 @@ logNetMessage (Pushing c stage) = show $ Pushing (logClientID c) $
SendPackOutput n _ -> SendPackOutput n elided
s -> s
where
elided = T.encodeUtf8 $ T.pack "<elided>"
elided = T.encodeUtf8 $ T.pack "<elided>"
logNetMessage (PairingNotification stage c uuid) =
show $ PairingNotification stage (logClientID c) uuid
logNetMessage m = show m

View file

@ -52,7 +52,7 @@ unattendedUpgrade = do
prepUpgrade :: Assistant ()
prepUpgrade = do
void $ addAlert upgradingAlert
void $ liftIO $ setEnv upgradedEnv "1" True
liftIO $ setEnv upgradedEnv "1" True
prepRestart
postUpgrade :: URLString -> Assistant ()
@ -78,7 +78,7 @@ upgradedEnv = "GIT_ANNEX_UPGRADED"
startDistributionDownload :: GitAnnexDistribution -> Assistant ()
startDistributionDownload d = go =<< liftIO . newVersionLocation d =<< liftIO oldVersionLocation
where
go Nothing = debug ["Skipping redundant upgrade"]
go Nothing = debug ["Skipping redundant upgrade"]
go (Just dest) = do
liftAnnex $ setUrlPresent k u
hook <- asIO1 $ distributionDownloadComplete d dest cleanup

View file

@ -1,7 +1,6 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE CPP #-}
-- | Helper functions for creating forms when using Bootstrap v3.
-- This is a copy of the Yesod.Form.Bootstrap3 module that has been slightly
-- modified to be compatible with Yesod 1.0.1
@ -149,20 +148,13 @@ data BootstrapFormLayout =
-- > ^{bootstrapSubmit MsgSubmit}
--
-- Since: yesod-form 1.3.8
#if MIN_VERSION_yesod(1,2,0)
renderBootstrap3 :: Monad m => BootstrapFormLayout -> FormRender m a
#else
renderBootstrap3 :: BootstrapFormLayout -> FormRender sub master a
#endif
renderBootstrap3 formLayout aform fragment = do
(res, views') <- aFormToForm aform
let views = views' []
has (Just _) = True
has Nothing = False
widget = [whamlet|
#if MIN_VERSION_yesod(1,2,0)
$newline never
#endif
#{fragment}
$forall view <- views
<div .form-group :fvRequired view:.required :not $ fvRequired view:.optional :has $ fvErrors view:.has-error>
@ -193,11 +185,7 @@ renderBootstrap3 formLayout aform fragment = do
nequals a b = a /= b -- work around older hamlet versions not liking /=
-- | (Internal) Render a help widget for tooltips and errors.
#if MIN_VERSION_yesod(1,2,0)
helpWidget :: FieldView site -> WidgetT site IO ()
#else
helpWidget :: FieldView sub master -> GWidget sub master ()
#endif
helpWidget view = [whamlet|
$maybe tt <- fvTooltip view
<span .help-block>#{tt}
@ -242,13 +230,7 @@ instance IsString msg => IsString (BootstrapSubmit msg) where
-- layout.
--
-- Since: yesod-form 1.3.8
#if MIN_VERSION_yesod(1,2,0)
bootstrapSubmit
:: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
=> BootstrapSubmit msg -> AForm m ()
#else
bootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> AForm sub master ()
#endif
bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
@ -257,13 +239,7 @@ bootstrapSubmit = formToAForm . liftM (second return) . mbootstrapSubmit
-- anyway.
--
-- Since: yesod-form 1.3.8
#if MIN_VERSION_yesod(1,2,0)
mbootstrapSubmit
:: (RenderMessage site msg, HandlerSite m ~ site, MonadHandler m)
=> BootstrapSubmit msg -> MForm m (FormResult (), FieldView site)
#else
mbootstrapSubmit :: (RenderMessage master msg) => BootstrapSubmit msg -> MForm sub master (FormResult (), FieldView sub master)
#endif
mbootstrapSubmit (BootstrapSubmit msg classes attrs) =
let res = FormSuccess ()
widget = [whamlet|<button class="btn #{classes}" type=submit *{attrs}>_{msg}|]

View file

@ -162,7 +162,7 @@ getEnableS3R :: UUID -> Handler Html
#ifdef WITH_S3
getEnableS3R uuid = do
m <- liftAnnex readRemoteLog
if isIARemoteConfig $ fromJust $ M.lookup uuid m
if maybe False S3.isIA (M.lookup uuid m)
then redirect $ EnableIAR uuid
else postEnableS3R uuid
#else
@ -207,7 +207,7 @@ makeAWSRemote maker remotetype defaultgroup (AWSCreds ak sk) name config =
setupCloudRemote defaultgroup Nothing $
maker hostname remotetype (Just creds) config
where
creds = (T.unpack ak, T.unpack sk)
creds = (T.unpack ak, T.unpack sk)
{- AWS services use the remote name as the basis for a host
- name, so filter it to contain valid characters. -}
hostname = case filter isAlphaNum name of
@ -220,12 +220,9 @@ getRepoInfo c = [whamlet|S3 remote using bucket: #{bucket}|]
bucket = fromMaybe "" $ M.lookup "bucket" c
#ifdef WITH_S3
isIARemoteConfig :: RemoteConfig -> Bool
isIARemoteConfig = S3.isIAHost . fromMaybe "" . M.lookup "host"
previouslyUsedAWSCreds :: Annex (Maybe CredPair)
previouslyUsedAWSCreds = getM gettype [S3.remote, Glacier.remote]
where
gettype t = previouslyUsedCredPair AWS.creds t $
not . isIARemoteConfig . Remote.config
not . S3.isIA . Remote.config
#endif

View file

@ -36,7 +36,7 @@ notCurrentRepo uuid a = do
then redirect DeleteCurrentRepositoryR
else go =<< liftAnnex (Remote.remoteFromUUID uuid)
where
go Nothing = error "Unknown UUID"
go Nothing = error "Unknown UUID"
go (Just _) = a
handleXMPPRemoval :: UUID -> Handler Html -> Handler Html

View file

@ -136,7 +136,7 @@ setRepoConfig uuid mremote oldc newc = do
when syncableChanged $
liftAssistant $ changeSyncable mremote (repoSyncable newc)
where
syncableChanged = repoSyncable oldc /= repoSyncable newc
syncableChanged = repoSyncable oldc /= repoSyncable newc
associatedDirectoryChanged = repoAssociatedDirectory oldc /= repoAssociatedDirectory newc
groupChanged = repoGroup oldc /= repoGroup newc
nameChanged = isJust mremote && legalName oldc /= legalName newc
@ -255,7 +255,7 @@ getGitRepoInfo r = do
getRepoEncryption :: Maybe Remote.Remote -> Maybe Remote.RemoteConfig -> Widget
getRepoEncryption (Just _) (Just c) = case extractCipher c of
Nothing ->
Nothing ->
[whamlet|not encrypted|]
(Just (SharedCipher _)) ->
[whamlet|encrypted: encryption key stored in git repository|]
@ -274,7 +274,7 @@ getUpgradeRepositoryR :: RepoId -> Handler ()
getUpgradeRepositoryR (RepoUUID _) = redirect DashboardR
getUpgradeRepositoryR r = go =<< liftAnnex (repoIdRemote r)
where
go Nothing = redirect DashboardR
go Nothing = redirect DashboardR
go (Just rmt) = do
liftIO fixSshKeyPairIdentitiesOnly
liftAnnex $ setConfig

View file

@ -60,7 +60,7 @@ runFsckForm new activity = case activity of
ScheduledSelfFsck s d -> go s d =<< liftAnnex getUUID
ScheduledRemoteFsck ru s d -> go s d ru
where
go (Schedule r t) d ru = do
go (Schedule r t) d ru = do
u <- liftAnnex getUUID
repolist <- liftAssistant (getrepolist ru)
runFormPostNoToken $ \msg -> do

View file

@ -101,13 +101,13 @@ itemNameHelp = [whamlet|
iaCredsAForm :: Maybe CredPair -> MkAForm AWS.AWSCreds
iaCredsAForm defcreds = AWS.AWSCreds
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
<$> accessKeyIDFieldWithHelp (T.pack . fst <$> defcreds)
<*> AWS.secretAccessKeyField (T.pack . snd <$> defcreds)
#ifdef WITH_S3
previouslyUsedIACreds :: Annex (Maybe CredPair)
previouslyUsedIACreds = previouslyUsedCredPair AWS.creds S3.remote $
AWS.isIARemoteConfig . Remote.config
S3.isIA . Remote.config
#endif
accessKeyIDFieldWithHelp :: Maybe Text -> MkAForm Text
@ -201,7 +201,7 @@ $if (not exists)
have been uploaded, and the Internet Archive has processed them.
|]
where
bucket = fromMaybe "" $ M.lookup "bucket" c
bucket = fromMaybe "" $ M.lookup "bucket" c
#ifdef WITH_S3
url = S3.iaItemUrl bucket
#else

View file

@ -175,7 +175,7 @@ getAndroidCameraRepositoryR :: Handler ()
getAndroidCameraRepositoryR =
startFullAssistant "/sdcard/DCIM" SourceGroup $ Just addignore
where
addignore = do
addignore = do
liftIO $ unlessM (doesFileExist ".gitignore") $
writeFile ".gitignore" ".thumbnails"
void $ inRepo $
@ -274,8 +274,8 @@ getConfirmAddDriveR drive = ifM (liftIO $ probeRepoExists dir)
, newrepo
)
where
dir = removableDriveRepository drive
newrepo = do
dir = removableDriveRepository drive
newrepo = do
secretkeys <- sortBy (comparing snd) . M.toList
<$> liftIO secretKeys
page "Encrypt repository?" (Just Configuration) $
@ -338,7 +338,7 @@ getFinishAddDriveR drive = go
liftAnnex $ defaultStandardGroup u TransferGroup
liftAssistant $ immediateSyncRemote r
redirect $ EditNewRepositoryR u
mountpoint = T.unpack (mountPoint drive)
mountpoint = T.unpack (mountPoint drive)
dir = removableDriveRepository drive
remotename = takeFileName mountpoint

View file

@ -72,7 +72,7 @@ getStartXMPPPairSelfR :: Handler Html
#ifdef WITH_XMPP
getStartXMPPPairSelfR = go =<< liftAnnex getXMPPCreds
where
go Nothing = do
go Nothing = do
-- go get XMPP configured, then come back
redirect XMPPConfigForPairSelfR
go (Just creds) = do

View file

@ -193,7 +193,7 @@ postEnableSshGCryptR :: UUID -> Handler Html
postEnableSshGCryptR u = whenGcryptInstalled $
enableSshRemote getsshinput enableRsyncNetGCrypt enablegcrypt u
where
enablegcrypt sshdata _ = prepSsh False sshdata $ \sshdata' ->
enablegcrypt sshdata _ = prepSsh False sshdata $ \sshdata' ->
sshConfigurator $
checkExistingGCrypt sshdata' $
error "Expected to find an encrypted git repository, but did not."
@ -232,7 +232,7 @@ enableSshRemote getsshinput rsyncnetsetup genericsetup u = do
_ -> showform form enctype UntestedServer
_ -> redirect AddSshR
where
unmangle sshdata = sshdata
unmangle sshdata = sshdata
{ sshHostName = T.pack $ unMangleSshHostName $
T.unpack $ sshHostName sshdata
}
@ -423,7 +423,7 @@ getConfirmSshR sshdata u
secretkeys <- sortBy (comparing snd) . M.toList
<$> liftIO secretKeys
$(widgetFile "configurators/ssh/confirm")
handleexisting Nothing = sshConfigurator $
handleexisting Nothing = sshConfigurator $
-- Not a UUID we know, so prompt about combining.
$(widgetFile "configurators/ssh/combine")
handleexisting (Just _) = prepSsh False sshdata $ \sshdata' -> do
@ -471,7 +471,7 @@ checkExistingGCrypt sshdata nope = checkGCryptRepoEncryption repourl nope nope $
combineExistingGCrypt sshdata u
Nothing -> error "The location contains a gcrypt repository that is not a git-annex special remote. This is not supported."
where
repourl = genSshUrl sshdata
repourl = genSshUrl sshdata
{- Enables an existing gcrypt special remote. -}
enableGCrypt :: SshData -> RemoteName -> Handler Html
@ -488,7 +488,7 @@ combineExistingGCrypt sshdata u = do
reponame <- liftAnnex $ getGCryptRemoteName u repourl
enableGCrypt sshdata reponame
where
repourl = genSshUrl sshdata
repourl = genSshUrl sshdata
{- Sets up remote repository for ssh, or directory for rsync. -}
prepSsh :: Bool -> SshData -> (SshData -> Handler Html) -> Handler Html
@ -579,7 +579,7 @@ postAddRsyncNetR = do
"That is not a rsync.net host name."
_ -> showform UntestedServer
where
inpage = page "Add a Rsync.net repository" (Just Configuration)
inpage = page "Add a Rsync.net repository" (Just Configuration)
hostnamefield = textField `withExpandableNote` ("Help", help)
help = [whamlet|
<div>

View file

@ -150,7 +150,7 @@ getXMPPRemotes :: Assistant [(JID, Remote)]
getXMPPRemotes = catMaybes . map pair . filter Remote.isXMPPRemote . syncGitRemotes
<$> getDaemonStatus
where
pair r = maybe Nothing (\jid -> Just (jid, r)) $
pair r = maybe Nothing (\jid -> Just (jid, r)) $
parseJID $ getXMPPClientID r
data XMPPForm = XMPPForm
@ -197,8 +197,8 @@ testXMPP creds = do
}
_ -> return $ Left $ intercalate "; " $ map formatlog bad
where
formatlog ((h, p), Left e) = "host " ++ h ++ ":" ++ showport p ++ " failed: " ++ show e
formatlog _ = ""
formatlog ((h, p), Left e) = "host " ++ h ++ ":" ++ showport p ++ " failed: " ++ show e
formatlog _ = ""
showport (PortNumber n) = show n
showport (Service s) = s

View file

@ -25,8 +25,12 @@ import Data.String (IsString (..))
import Control.Monad (unless)
import Data.Maybe (listToMaybe)
#endif
#if MIN_VERSION_yesod_form(1,3,8)
import Yesod.Form.Bootstrap3 as Y hiding (bfs)
#else
import Assistant.WebApp.Bootstrap3 as Y hiding (bfs)
#endif
import Data.Text (Text)
import Assistant.WebApp.Bootstrap3 hiding (bfs)
{- Yesod's textField sets the required attribute for required fields.
- We don't want this, because many of the forms used in this webapp
@ -129,7 +133,7 @@ withExpandableNote field (toggle, note) = withNote field $ [whamlet|
^{note}
|]
where
ident = "toggle_" ++ toggle
ident = "toggle_" ++ toggle
{- Adds a check box to an AForm to control encryption. -}
#if MIN_VERSION_yesod(1,2,0)

View file

@ -16,7 +16,7 @@ import qualified Remote
data RepoId
= RepoUUID UUID
| RepoName RemoteName
deriving (Eq, Ord, Show, Read)
deriving (Eq, Ord, Show, Read)
mkRepoId :: Remote -> RepoId
mkRepoId r = case Remote.uuid r of

View file

@ -196,7 +196,7 @@ repoList reposelector
_ -> Nothing
_ -> Nothing
where
getconfig k = M.lookup k =<< M.lookup u m
getconfig k = M.lookup k =<< M.lookup u m
val iscloud r = Just (iscloud, (RepoUUID u, DisabledRepoActions $ r u))
list l = do
cc <- currentlyConnectedRemotes <$> liftAssistant getDaemonStatus
@ -232,13 +232,13 @@ getRepositoriesReorderR = do
liftAssistant updateSyncRemotes
where
go _ Nothing = noop
go list (Just remote) = do
go list (Just remote) = do
rs <- catMaybes <$> mapM repoIdRemote list
forM_ (reorderCosts remote rs) $ \(r, newcost) ->
when (Remote.cost r /= newcost) $
setRemoteCost (Remote.repo r) newcost
void remoteListRefresh
fromjs = fromMaybe (RepoUUID NoUUID) . readish . T.unpack
fromjs = fromMaybe (RepoUUID NoUUID) . readish . T.unpack
reorderCosts :: Remote -> [Remote] -> [(Remote, Cost)]
reorderCosts remote rs = zip rs'' (insertCostAfter costs i)

View file

@ -7,7 +7,7 @@
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell, OverloadedStrings, RankNTypes #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances, FlexibleContexts, ViewPatterns #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

View file

@ -195,7 +195,7 @@ decodeMessage m = decode =<< gitAnnexTagInfo m
<*> a i
gen c i = c . toUUID <$> headMaybe (words (T.unpack (tagValue i)))
seqgen c i = do
packet <- decodeTagContent $ tagElement i
packet <- decodeTagContent $ tagElement i
let seqnum = fromMaybe 0 $ readish $ T.unpack $ tagValue i
return $ c seqnum packet
shasgen c i = do

View file

@ -152,7 +152,7 @@ xmppPush cid gitpush = do
fromxmpp outh controlh = withPushMessagesInSequence cid SendPack handlemsg
where
handlemsg (Just (Pushing _ (ReceivePackOutput _ b))) =
handlemsg (Just (Pushing _ (ReceivePackOutput _ b))) =
liftIO $ writeChunk outh b
handlemsg (Just (Pushing _ (ReceivePackDone exitcode))) =
liftIO $ do
@ -266,7 +266,7 @@ xmppReceivePack cid = do
relaytoxmpp seqnum' outh
relayfromxmpp inh = withPushMessagesInSequence cid ReceivePack handlemsg
where
handlemsg (Just (Pushing _ (SendPackOutput _ b))) =
handlemsg (Just (Pushing _ (SendPackOutput _ b))) =
liftIO $ writeChunk inh b
handlemsg (Just _) = noop
handlemsg Nothing = do
@ -337,7 +337,7 @@ handlePushNotice (Pushing cid (CanPush theiruuid shas)) =
, go
)
where
go = do
go = do
u <- liftAnnex getUUID
sendNetMessage $ Pushing cid (PushRequest u)
haveall l = liftAnnex $ not <$> anyM donthave l
@ -359,9 +359,9 @@ writeChunk h b = do
withPushMessagesInSequence :: ClientID -> PushSide -> (Maybe NetMessage -> Assistant ()) -> Assistant ()
withPushMessagesInSequence cid side a = loop 0
where
loop seqnum = do
loop seqnum = do
m <- timeout xmppTimeout <~> waitInbox cid side
let go s = a m >> loop s
let go s = a m >> loop s
let next = seqnum + 1
case extractSequence =<< m of
Just seqnum'

View file

@ -144,7 +144,7 @@ trivialMigrate oldkey newbackend
hashFile :: Hash -> FilePath -> Integer -> Annex String
hashFile hash file filesize = liftIO $ go hash
where
go (SHAHash hashsize) = case shaHasher hashsize filesize of
go (SHAHash hashsize) = case shaHasher hashsize filesize of
Left sha -> sha <$> L.readFile file
Right command ->
either error return

View file

@ -58,13 +58,13 @@ parseGccLink = do
collect2params <- restOfLine
return $ CmdParams (path ++ collectcmd) (escapeDosPaths collect2params) cenv
where
collectcmd = "collect2.exe"
collectgccenv = "COLLECT_GCC"
collectcmd = "collect2.exe"
collectgccenv = "COLLECT_GCC"
collectltoenv = "COLLECT_LTO_WRAPPER"
pathenv = "COMPILER_PATH"
libpathenv = "LIBRARY_PATH"
optenv = "COLLECT_GCC_OPTIONS"
collectenv = do
optenv = "COLLECT_GCC_OPTIONS"
collectenv = do
void $ many1 $ do
notFollowedBy $ string collectgccenv
restOfLine
@ -148,7 +148,7 @@ runAtFile p s f extraparams = do
removeFile f
return out
where
c = case parse p "" s of
c = case parse p "" s of
Left e -> error $
(show e) ++
"\n<<<\n" ++ s ++ "\n>>>"

View file

@ -86,7 +86,7 @@ number = read <$> many1 digit
coordsParser :: Parser (Coord, Coord)
coordsParser = (try singleline <|> try weird <|> multiline) <?> "Coords"
where
singleline = do
singleline = do
line <- number
void $ char ':'
startcol <- number
@ -151,7 +151,7 @@ spliceParser = do
(unlines codelines)
splicetype
where
tosplicetype "declarations" = SpliceDeclaration
tosplicetype "declarations" = SpliceDeclaration
tosplicetype "expression" = SpliceExpression
tosplicetype s = error $ "unknown splice type: " ++ s
@ -177,7 +177,7 @@ spliceParser = do
splicesExtractor :: Parser [Splice]
splicesExtractor = rights <$> many extract
where
extract = try (Right <$> spliceParser) <|> (Left <$> compilerJunkLine)
extract = try (Right <$> spliceParser) <|> (Left <$> compilerJunkLine)
compilerJunkLine = restOfLine
{- Modifies the source file, expanding the splices, which all must
@ -214,8 +214,8 @@ applySplices destdir imports splices@(first:_) = do
hPutStr h newcontent
hClose h
where
expand lls [] = lls
expand lls (s:rest)
expand lls [] = lls
expand lls (s:rest)
| isExpressionSplice s = expand (expandExpressionSplice s lls) rest
| otherwise = expand (expandDeclarationSplice s lls) rest
@ -291,12 +291,12 @@ expandExpressionSplice sp lls = concat [before, spliced:padding, end]
-- ie: bar $(splice)
| otherwise = s ++ " $ "
where
s' = filter (not . isSpace) s
s' = filter (not . isSpace) s
findindent = length . takeWhile isSpace
addindent n = unlines . map (i ++) . lines
where
i = take n $ repeat ' '
i = take n $ repeat ' '
{- Tweaks code output by GHC in splices to actually build. Yipes. -}
mangleCode :: String -> String
@ -315,7 +315,7 @@ mangleCode = flip_colon
. remove_package_version
. emptylambda
where
{- Lambdas are often output without parens around them.
{- Lambdas are often output without parens around them.
- This breaks when the lambda is immediately applied to a
- parameter.
-
@ -409,7 +409,7 @@ mangleCode = flip_colon
restofline = manyTill (noneOf "\n") newline
{- For some reason, GHC sometimes doesn't like the multiline
{- For some reason, GHC sometimes doesn't like the multiline
- strings it creates. It seems to get hung up on \{ at the
- start of a new line sometimes, wanting it to not be escaped.
-
@ -646,7 +646,7 @@ parsecAndReplace p s = case parse find "" s of
Left _e -> s
Right l -> concatMap (either return id) l
where
find :: Parser [Either Char String]
find :: Parser [Either Char String]
find = many $ try (Right <$> p) <|> (Left <$> anyChar)
main :: IO ()
@ -654,7 +654,7 @@ main = go =<< getArgs
where
go (destdir:log:header:[]) = run destdir log (Just header)
go (destdir:log:[]) = run destdir log Nothing
go _ = error "usage: EvilSplicer destdir logfile [headerfile]"
go _ = error "usage: EvilSplicer destdir logfile [headerfile]"
run destdir log mheader = do
r <- parseFromFile splicesExtractor log

View file

@ -103,7 +103,7 @@ makeInstaller gitannex license extrabins launchers = nsis $ do
name "git-annex"
outFile $ str installer
{- Installing into the same directory as git avoids needing to modify
- path myself, since the git installer already does it. -}
- path myself, since the git installer already does it. -}
installDir gitInstallDir
requestExecutionLevel Admin

View file

@ -112,7 +112,7 @@ expand_rpath libs replacement_libs cmd
return $ map (replacem m) libs
| otherwise = return libs
where
probe c = "DYLD_PRINT_RPATHS=1 " ++ c ++ " --getting-rpath-dummy-option 2>&1 | grep RPATH"
probe c = "DYLD_PRINT_RPATHS=1 " ++ c ++ " --getting-rpath-dummy-option 2>&1 | grep RPATH"
parse s = case words s of
("RPATH":"successful":"expansion":"of":old:"to:":new:[]) ->
Just (old, new)

View file

@ -40,7 +40,7 @@ main :: IO ()
main = getArgs >>= go
where
go [] = error "specify topdir"
go (topdir:_) = do
go (topdir:_) = do
let dir = progDir topdir
createDirectoryIfMissing True dir
installed <- forM bundledPrograms $ installProg dir

View file

@ -35,7 +35,7 @@ noDaemonRunning :: Command -> Command
noDaemonRunning = addCheck $ whenM (isJust <$> daemonpid) $
error "You cannot run this command while git-annex watch or git-annex assistant is running."
where
daemonpid = liftIO . checkDaemon =<< fromRepo gitAnnexPidFile
daemonpid = liftIO . checkDaemon =<< fromRepo gitAnnexPidFile
dontCheck :: CommandCheck -> Command -> Command
dontCheck check cmd = mutateCheck cmd $ \c -> filter (/= check) c

View file

@ -6,7 +6,6 @@
-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE BangPatterns #-}
module CmdLine (
dispatch,
@ -58,7 +57,7 @@ dispatch fuzzyok allargs allcmds commonoptions fields header getgitrepo = do
shutdown $ cmdnocommit cmd
go _flags params (Left e) = do
when fuzzy $
autocorrect =<< Git.Config.global
autocorrect =<< Git.Config.global
maybe (throw e) (\a -> a params) (cmdnorepo cmd)
err msg = msg ++ "\n\n" ++ usage header allcmds
cmd = Prelude.head cmds

View file

@ -107,91 +107,91 @@ import System.Remote.Monitoring
cmds :: [Command]
cmds = concat
[ Command.Add.def
, Command.Get.def
, Command.Drop.def
, Command.Move.def
, Command.Copy.def
, Command.Unlock.def
, Command.Lock.def
, Command.Sync.def
, Command.Mirror.def
, Command.AddUrl.def
[ Command.Add.cmd
, Command.Get.cmd
, Command.Drop.cmd
, Command.Move.cmd
, Command.Copy.cmd
, Command.Unlock.cmd
, Command.Lock.cmd
, Command.Sync.cmd
, Command.Mirror.cmd
, Command.AddUrl.cmd
#ifdef WITH_FEED
, Command.ImportFeed.def
, Command.ImportFeed.cmd
#endif
, Command.RmUrl.def
, Command.Import.def
, Command.Init.def
, Command.Describe.def
, Command.InitRemote.def
, Command.EnableRemote.def
, Command.Reinject.def
, Command.Unannex.def
, Command.Uninit.def
, Command.Reinit.def
, Command.PreCommit.def
, Command.NumCopies.def
, Command.Trust.def
, Command.Untrust.def
, Command.Semitrust.def
, Command.Dead.def
, Command.Group.def
, Command.Wanted.def
, Command.Schedule.def
, Command.Ungroup.def
, Command.Vicfg.def
, Command.LookupKey.def
, Command.ExamineKey.def
, Command.FromKey.def
, Command.DropKey.def
, Command.TransferKey.def
, Command.TransferKeys.def
, Command.ReKey.def
, Command.MetaData.def
, Command.View.def
, Command.VAdd.def
, Command.VFilter.def
, Command.VPop.def
, Command.VCycle.def
, Command.Fix.def
, Command.Fsck.def
, Command.Repair.def
, Command.Unused.def
, Command.DropUnused.def
, Command.AddUnused.def
, Command.Find.def
, Command.FindRef.def
, Command.Whereis.def
, Command.List.def
, Command.Log.def
, Command.Merge.def
, Command.ResolveMerge.def
, Command.Info.def
, Command.Status.def
, Command.Migrate.def
, Command.Map.def
, Command.Direct.def
, Command.Indirect.def
, Command.Upgrade.def
, Command.Forget.def
, Command.Version.def
, Command.Help.def
, Command.RmUrl.cmd
, Command.Import.cmd
, Command.Init.cmd
, Command.Describe.cmd
, Command.InitRemote.cmd
, Command.EnableRemote.cmd
, Command.Reinject.cmd
, Command.Unannex.cmd
, Command.Uninit.cmd
, Command.Reinit.cmd
, Command.PreCommit.cmd
, Command.NumCopies.cmd
, Command.Trust.cmd
, Command.Untrust.cmd
, Command.Semitrust.cmd
, Command.Dead.cmd
, Command.Group.cmd
, Command.Wanted.cmd
, Command.Schedule.cmd
, Command.Ungroup.cmd
, Command.Vicfg.cmd
, Command.LookupKey.cmd
, Command.ExamineKey.cmd
, Command.FromKey.cmd
, Command.DropKey.cmd
, Command.TransferKey.cmd
, Command.TransferKeys.cmd
, Command.ReKey.cmd
, Command.MetaData.cmd
, Command.View.cmd
, Command.VAdd.cmd
, Command.VFilter.cmd
, Command.VPop.cmd
, Command.VCycle.cmd
, Command.Fix.cmd
, Command.Fsck.cmd
, Command.Repair.cmd
, Command.Unused.cmd
, Command.DropUnused.cmd
, Command.AddUnused.cmd
, Command.Find.cmd
, Command.FindRef.cmd
, Command.Whereis.cmd
, Command.List.cmd
, Command.Log.cmd
, Command.Merge.cmd
, Command.ResolveMerge.cmd
, Command.Info.cmd
, Command.Status.cmd
, Command.Migrate.cmd
, Command.Map.cmd
, Command.Direct.cmd
, Command.Indirect.cmd
, Command.Upgrade.cmd
, Command.Forget.cmd
, Command.Version.cmd
, Command.Help.cmd
#ifdef WITH_ASSISTANT
, Command.Watch.def
, Command.Assistant.def
, Command.Watch.cmd
, Command.Assistant.cmd
#ifdef WITH_WEBAPP
, Command.WebApp.def
, Command.WebApp.cmd
#endif
#ifdef WITH_XMPP
, Command.XMPPGit.def
, Command.XMPPGit.cmd
#endif
, Command.RemoteDaemon.def
, Command.RemoteDaemon.cmd
#endif
, Command.Test.def
, Command.Test.cmd
#ifdef WITH_TESTSUITE
, Command.FuzzTest.def
, Command.TestRemote.def
, Command.FuzzTest.cmd
, Command.TestRemote.cmd
#endif
]

View file

@ -34,19 +34,19 @@ import qualified Command.GCryptSetup
cmds_readonly :: [Command]
cmds_readonly = concat
[ gitAnnexShellCheck Command.ConfigList.def
, gitAnnexShellCheck Command.InAnnex.def
, gitAnnexShellCheck Command.SendKey.def
, gitAnnexShellCheck Command.TransferInfo.def
, gitAnnexShellCheck Command.NotifyChanges.def
[ gitAnnexShellCheck Command.ConfigList.cmd
, gitAnnexShellCheck Command.InAnnex.cmd
, gitAnnexShellCheck Command.SendKey.cmd
, gitAnnexShellCheck Command.TransferInfo.cmd
, gitAnnexShellCheck Command.NotifyChanges.cmd
]
cmds_notreadonly :: [Command]
cmds_notreadonly = concat
[ gitAnnexShellCheck Command.RecvKey.def
, gitAnnexShellCheck Command.DropKey.def
, gitAnnexShellCheck Command.Commit.def
, Command.GCryptSetup.def
[ gitAnnexShellCheck Command.RecvKey.cmd
, gitAnnexShellCheck Command.DropKey.cmd
, gitAnnexShellCheck Command.Commit.cmd
, Command.GCryptSetup.cmd
]
cmds :: [Command]
@ -66,7 +66,7 @@ options = commonOptions ++
check u = unexpectedUUID expected u
checkGCryptUUID expected = check =<< getGCryptUUID True =<< gitRepo
where
check (Just u) | u == toUUID expected = noop
check (Just u) | u == toUUID expected = noop
check Nothing = unexpected expected "uninitialized repository"
check (Just u) = unexpectedUUID expected u
unexpectedUUID expected u = unexpected expected $ "UUID " ++ fromUUID u

View file

@ -107,7 +107,7 @@ withFilesUnlocked' :: ([FilePath] -> Git.Repo -> IO ([FilePath], IO Bool)) -> (F
withFilesUnlocked' typechanged a params = seekActions $
prepFiltered a unlockedfiles
where
check f = liftIO (notSymlink f) <&&>
check f = liftIO (notSymlink f) <&&>
(isJust <$> catKeyFile f <||> isJust <$> catKeyFileHEAD f)
unlockedfiles = filterM check =<< seekHelper typechanged params
@ -165,7 +165,7 @@ withKeyOptions keyop fallbackop params = do
Just k -> go auto $ return [k]
_ -> error "Can only specify one of file names, --all, --unused, or --key"
where
go True _ = error "Cannot use --auto with --all or --unused or --key"
go True _ = error "Cannot use --auto with --all or --unused or --key"
go False a = do
matcher <- Limit.getMatcher
seekActions $ map (process matcher) <$> a

View file

@ -103,6 +103,8 @@ paramSize :: String
paramSize = "SIZE"
paramAddress :: String
paramAddress = "ADDRESS"
paramItem :: String
paramItem = "ITEM"
paramKeyValue :: String
paramKeyValue = "K=V"
paramNothing :: String

View file

@ -34,8 +34,8 @@ import Utility.Tmp
import Control.Exception (IOException)
def :: [Command]
def = [notBareRepo $ withOptions [includeDotFilesOption] $
cmd :: [Command]
cmd = [notBareRepo $ withOptions [includeDotFilesOption] $
command "add" paramPaths seek SectionCommon
"add files to annex"]
@ -125,7 +125,7 @@ lockDown' file = ifM crippledFileSystem
- This is not done in direct mode, because files there need to
- remain writable at all times.
-}
go tmp = do
go tmp = do
unlessM isDirect $
freezeContent file
withTSDelta $ \delta -> liftIO $ do
@ -134,7 +134,7 @@ lockDown' file = ifM crippledFileSystem
hClose h
nukeFile tmpfile
withhardlink delta tmpfile `catchIO` const (nohardlink delta)
nohardlink delta = do
nohardlink delta = do
cache <- genInodeCache file delta
return KeySource
{ keyFilename = file
@ -177,14 +177,14 @@ ingest (Just source) = withTSDelta $ \delta -> do
(undo (keyFilename source) key)
maybe noop (genMetaData key (keyFilename source)) ms
liftIO $ nukeFile $ keyFilename source
return $ (Just key, mcache)
return (Just key, mcache)
goindirect _ _ _ = failure "failed to generate a key"
godirect (Just (key, _)) (Just cache) ms = do
addInodeCache key cache
maybe noop (genMetaData key (keyFilename source)) ms
finishIngestDirect key source
return $ (Just key, Just cache)
return (Just key, Just cache)
godirect _ _ _ = failure "failed to generate a key"
failure msg = do
@ -207,7 +207,7 @@ finishIngestDirect key source = do
perform :: FilePath -> CommandPerform
perform file = lockDown file >>= ingest >>= go
where
go (Just key, cache) = next $ cleanup file key cache True
go (Just key, cache) = next $ cleanup file key cache True
go (Nothing, _) = stop
{- On error, put the file back so it doesn't seem to have vanished.

View file

@ -14,8 +14,8 @@ import qualified Command.Add
import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
import Types.Key
def :: [Command]
def = [notDirect $ command "addunused" (paramRepeating paramNumRange)
cmd :: [Command]
cmd = [notDirect $ command "addunused" (paramRepeating paramNumRange)
seek SectionMaintenance "add back unused files"]
seek :: CommandSeek

View file

@ -32,8 +32,8 @@ import Annex.Quvi
import qualified Utility.Quvi as Quvi
#endif
def :: [Command]
def = [notBareRepo $ withOptions [fileOption, pathdepthOption, relaxedOption] $
cmd :: [Command]
cmd = [notBareRepo $ withOptions [fileOption, pathdepthOption, relaxedOption] $
command "addurl" (paramRepeating paramUrl) seek
SectionCommon "add urls to annex"]
@ -56,7 +56,7 @@ seek ps = do
start :: Bool -> Maybe FilePath -> Maybe Int -> String -> CommandStart
start relaxed optfile pathdepth s = go $ fromMaybe bad $ parseURI s
where
(s', downloader) = getDownloader s
(s', downloader) = getDownloader s
bad = fromMaybe (error $ "bad url " ++ s') $
parseURI $ escapeURIString isUnescapedInURI s'
choosefile = flip fromMaybe optfile
@ -95,8 +95,8 @@ start relaxed optfile pathdepth s = go $ fromMaybe bad $ parseURI s
performQuvi :: Bool -> URLString -> URLString -> FilePath -> CommandPerform
performQuvi relaxed pageurl videourl file = ifAnnexed file addurl geturl
where
quviurl = setDownloader pageurl QuviDownloader
addurl key = next $ cleanup quviurl file key Nothing
quviurl = setDownloader pageurl QuviDownloader
addurl key = next $ cleanup quviurl file key Nothing
geturl = next $ isJust <$> addUrlFileQuvi relaxed quviurl videourl file
#endif
@ -189,7 +189,7 @@ download url file = do
, return Nothing
)
where
runtransfer dummykey tmp = Transfer.notifyTransfer Transfer.Download (Just file) $
runtransfer dummykey tmp = Transfer.notifyTransfer Transfer.Download (Just file) $
Transfer.download webUUID dummykey (Just file) Transfer.forwardRetry $ const $ do
liftIO $ createDirectoryIfMissing True (parentDir tmp)
downloadUrl [url] tmp

View file

@ -18,8 +18,8 @@ import Assistant.Install
import System.Environment
def :: [Command]
def = [noRepo checkAutoStart $ dontCheck repoExists $ withOptions options $
cmd :: [Command]
cmd = [noRepo checkAutoStart $ dontCheck repoExists $ withOptions options $
notBareRepo $ command "assistant" paramNothing seek SectionCommon
"automatically handle changes"]

View file

@ -12,8 +12,8 @@ import Command
import qualified Annex.Branch
import qualified Git
def :: [Command]
def = [command "commit" paramNothing seek
cmd :: [Command]
cmd = [command "commit" paramNothing seek
SectionPlumbing "commits any staged changes to the git-annex branch"]
seek :: CommandSeek

View file

@ -15,8 +15,8 @@ import qualified Annex.Branch
import qualified Git.Config
import Remote.GCrypt (coreGCryptId)
def :: [Command]
def = [noCommit $ command "configlist" paramNothing seek
cmd :: [Command]
cmd = [noCommit $ command "configlist" paramNothing seek
SectionPlumbing "outputs relevant git configuration"]
seek :: CommandSeek
@ -29,7 +29,7 @@ start = do
showConfig coreGCryptId =<< fromRepo (Git.Config.get coreGCryptId "")
stop
where
showConfig k v = liftIO $ putStrLn $ k ++ "=" ++ v
showConfig k v = liftIO $ putStrLn $ k ++ "=" ++ v
{- The repository may not yet have a UUID; automatically initialize it
- when there's a git-annex branch available. -}

View file

@ -14,8 +14,8 @@ import qualified Remote
import Annex.Wanted
import Config.NumCopies
def :: [Command]
def = [withOptions Command.Move.moveOptions $ command "copy" paramPaths seek
cmd :: [Command]
cmd = [withOptions Command.Move.moveOptions $ command "copy" paramPaths seek
SectionCommon "copy content of files to/from another repository"]
seek :: CommandSeek
@ -23,7 +23,7 @@ seek ps = do
to <- getOptionField toOption Remote.byNameWithUUID
from <- getOptionField fromOption Remote.byNameWithUUID
withKeyOptions
(Command.Move.startKey to from False)
(Command.Move.startKey to from False)
(withFilesInGit $ whenAnnexed $ start to from)
ps

View file

@ -11,8 +11,8 @@ import Command
import Types.TrustLevel
import Command.Trust (trustCommand)
def :: [Command]
def = [command "dead" (paramRepeating paramRemote) seek
cmd :: [Command]
cmd = [command "dead" (paramRepeating paramRemote) seek
SectionSetup "hide a lost repository"]
seek :: CommandSeek

View file

@ -12,8 +12,8 @@ import Command
import qualified Remote
import Logs.UUID
def :: [Command]
def = [command "describe" (paramPair paramRemote paramDesc) seek
cmd :: [Command]
cmd = [command "describe" (paramPair paramRemote paramDesc) seek
SectionSetup "change description of a repository"]
seek :: CommandSeek

View file

@ -15,8 +15,8 @@ import qualified Git.Branch
import Config
import Annex.Direct
def :: [Command]
def = [notBareRepo $ noDaemonRunning $
cmd :: [Command]
cmd = [notBareRepo $ noDaemonRunning $
command "direct" paramNothing seek
SectionSetup "switch repository to direct mode"]

View file

@ -22,8 +22,8 @@ import Annex.Notification
import qualified Data.Set as S
def :: [Command]
def = [withOptions [dropFromOption] $ command "drop" paramPaths seek
cmd :: [Command]
cmd = [withOptions [dropFromOption] $ command "drop" paramPaths seek
SectionCommon "indicate content of files not currently wanted"]
dropFromOption :: Option

View file

@ -13,8 +13,8 @@ import qualified Annex
import Logs.Location
import Annex.Content
def :: [Command]
def = [noCommit $ command "dropkey" (paramRepeating paramKey) seek
cmd :: [Command]
cmd = [noCommit $ command "dropkey" (paramRepeating paramKey) seek
SectionPlumbing "drops annexed content for specified keys"]
seek :: CommandSeek

View file

@ -16,8 +16,8 @@ import qualified Git
import Command.Unused (withUnusedMaps, UnusedMaps(..), startUnused)
import Config.NumCopies
def :: [Command]
def = [withOptions [Command.Drop.dropFromOption] $
cmd :: [Command]
cmd = [withOptions [Command.Drop.dropFromOption] $
command "dropunused" (paramRepeating paramNumRange)
seek SectionMaintenance "drop unused file content"]

View file

@ -15,8 +15,8 @@ import qualified Command.InitRemote as InitRemote
import qualified Data.Map as M
def :: [Command]
def = [command "enableremote"
cmd :: [Command]
cmd = [command "enableremote"
(paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
seek SectionSetup "enables use of an existing special remote"]
@ -29,7 +29,7 @@ start (name:ws) = go =<< InitRemote.findExisting name
where
config = Logs.Remote.keyValToConfig ws
go Nothing = unknownNameError "Unknown special remote name."
go Nothing = unknownNameError "Unknown special remote name."
go (Just (u, c)) = do
let fullconfig = config `M.union` c
t <- InitRemote.findType fullconfig

View file

@ -13,8 +13,8 @@ import qualified Utility.Format
import Command.Find (formatOption, getFormat, showFormatted, keyVars)
import Types.Key
def :: [Command]
def = [noCommit $ noMessages $ withOptions [formatOption, jsonOption] $
cmd :: [Command]
cmd = [noCommit $ noMessages $ withOptions [formatOption, jsonOption] $
command "examinekey" (paramRepeating paramKey) seek
SectionPlumbing "prints information from a key"]

View file

@ -18,8 +18,8 @@ import qualified Utility.Format
import Utility.DataUnits
import Types.Key
def :: [Command]
def = [mkCommand $ command "find" paramPaths seek SectionQuery "lists available files"]
cmd :: [Command]
cmd = [mkCommand $ command "find" paramPaths seek SectionQuery "lists available files"]
mkCommand :: Command -> Command
mkCommand = noCommit . noMessages . withOptions [formatOption, print0Option, jsonOption]

View file

@ -10,8 +10,8 @@ module Command.FindRef where
import Command
import qualified Command.Find as Find
def :: [Command]
def = [Find.mkCommand $ command "findref" paramRef seek SectionPlumbing
cmd :: [Command]
cmd = [Find.mkCommand $ command "findref" paramRef seek SectionPlumbing
"lists files in a git ref"]
seek :: CommandSeek

View file

@ -18,8 +18,8 @@ import Utility.Touch
#endif
#endif
def :: [Command]
def = [notDirect $ noCommit $ command "fix" paramPaths seek
cmd :: [Command]
cmd = [notDirect $ noCommit $ command "fix" paramPaths seek
SectionMaintenance "fix up symlinks to point to annexed content"]
seek :: CommandSeek

View file

@ -15,8 +15,8 @@ import qualified Annex
import Data.Time.Clock.POSIX
def :: [Command]
def = [withOptions forgetOptions $ command "forget" paramNothing seek
cmd :: [Command]
cmd = [withOptions forgetOptions $ command "forget" paramNothing seek
SectionMaintenance "prune git-annex branch history"]
forgetOptions :: [Option]

View file

@ -13,8 +13,8 @@ import qualified Annex.Queue
import Annex.Content
import Types.Key
def :: [Command]
def = [notDirect $ notBareRepo $
cmd :: [Command]
cmd = [notDirect $ notBareRepo $
command "fromkey" (paramPair paramKey paramPath) seek
SectionPlumbing "adds a file using a specific key"]

View file

@ -39,8 +39,8 @@ import Data.Time
import System.Posix.Types (EpochTime)
import System.Locale
def :: [Command]
def = [withOptions fsckOptions $ command "fsck" paramPaths seek
cmd :: [Command]
cmd = [withOptions fsckOptions $ command "fsck" paramPaths seek
SectionMaintenance "check for problems"]
fsckFromOption :: Option
@ -282,7 +282,7 @@ verifyDirectMode key file = do
- the key's metadata, if available.
-
- Not checked in direct mode, because files can be changed directly.
-}
-}
checkKeySize :: Key -> Annex Bool
checkKeySize key = ifM isDirect
( return True
@ -329,7 +329,7 @@ checkKeySizeOr bad key file = case Types.Key.keySize key of
checkBackend :: Backend -> Key -> Maybe FilePath -> Annex Bool
checkBackend backend key mfile = go =<< isDirect
where
go False = do
go False = do
content <- calcRepo $ gitAnnexLocation key
checkBackendOr badContent backend key content
go True = maybe nocheck checkdirect mfile

View file

@ -20,8 +20,8 @@ import System.Random (getStdRandom, random, randomR)
import Test.QuickCheck
import Control.Concurrent
def :: [Command]
def = [ notBareRepo $ command "fuzztest" paramNothing seek SectionTesting
cmd :: [Command]
cmd = [ notBareRepo $ command "fuzztest" paramNothing seek SectionTesting
"generates fuzz test files"]
seek :: CommandSeek
@ -47,7 +47,7 @@ guardTest = unlessM (fromMaybe False . Git.Config.isTrue <$> getConfig key "") $
, "Refusing to run fuzz tests, since " ++ keyname ++ " is not set!"
]
where
key = annexConfig "eat-my-repository"
key = annexConfig "eat-my-repository"
(ConfigKey keyname) = key
@ -257,7 +257,7 @@ existingDir = do
newFile :: IO (Maybe FuzzFile)
newFile = go (100 :: Int)
where
go 0 = return Nothing
go 0 = return Nothing
go n = do
f <- genFuzzFile
ifM (doesnotexist (toFilePath f))
@ -268,7 +268,7 @@ newFile = go (100 :: Int)
newDir :: FilePath -> IO (Maybe FuzzDir)
newDir parent = go (100 :: Int)
where
go 0 = return Nothing
go 0 = return Nothing
go n = do
(FuzzDir d) <- genFuzzDir
ifM (doesnotexist (parent </> d))

View file

@ -13,8 +13,8 @@ import Annex.UUID
import qualified Remote.GCrypt
import qualified Git
def :: [Command]
def = [dontCheck repoExists $ noCommit $
cmd :: [Command]
cmd = [dontCheck repoExists $ noCommit $
command "gcryptsetup" paramValue seek
SectionPlumbing "sets up gcrypt repository"]
@ -30,7 +30,7 @@ start gcryptid = next $ next $ do
g <- gitRepo
gu <- Remote.GCrypt.getGCryptUUID True g
let newgu = genUUIDInNameSpace gCryptNameSpace gcryptid
if gu == Nothing || gu == Just newgu
if isNothing gu || gu == Just newgu
then if Git.repoIsLocalBare g
then do
void $ Remote.GCrypt.setupRepo gcryptid g

View file

@ -16,8 +16,8 @@ import Config.NumCopies
import Annex.Wanted
import qualified Command.Move
def :: [Command]
def = [withOptions getOptions $ command "get" paramPaths seek
cmd :: [Command]
cmd = [withOptions getOptions $ command "get" paramPaths seek
SectionCommon "make content of annexed files available"]
getOptions :: [Option]
@ -48,7 +48,7 @@ start' expensivecheck from key afile = stopUnless (not <$> inAnnex key) $
stopUnless (Command.Move.fromOk src key) $
go $ Command.Move.fromPerform src False key afile
where
go a = do
go a = do
showStart' "get" key afile
next a

View file

@ -15,8 +15,8 @@ import Types.Group
import qualified Data.Set as S
def :: [Command]
def = [command "group" (paramPair paramRemote paramDesc) seek
cmd :: [Command]
cmd = [command "group" (paramPair paramRemote paramDesc) seek
SectionSetup "add a repository to a group"]
seek :: CommandSeek

View file

@ -21,8 +21,8 @@ import qualified Command.Fsck
import System.Console.GetOpt
def :: [Command]
def = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $
cmd :: [Command]
cmd = [noCommit $ noRepo startNoRepo $ dontCheck repoExists $
command "help" paramNothing seek SectionQuery "display help"]
seek :: CommandSeek
@ -47,15 +47,15 @@ showGeneralHelp :: IO ()
showGeneralHelp = putStrLn $ unlines
[ "The most frequently used git-annex commands are:"
, unlines $ map cmdline $ concat
[ Command.Init.def
, Command.Add.def
, Command.Drop.def
, Command.Get.def
, Command.Move.def
, Command.Copy.def
, Command.Sync.def
, Command.Whereis.def
, Command.Fsck.def
[ Command.Init.cmd
, Command.Add.cmd
, Command.Drop.cmd
, Command.Get.cmd
, Command.Move.cmd
, Command.Copy.cmd
, Command.Sync.cmd
, Command.Whereis.cmd
, Command.Fsck.cmd
]
, "Run 'git-annex' for a complete command list."
, "Run 'git-annex command --help' for help on a specific command."

View file

@ -16,8 +16,8 @@ import Backend
import Remote
import Types.KeySource
def :: [Command]
def = [withOptions opts $ notBareRepo $ command "import" paramPaths seek
cmd :: [Command]
cmd = [withOptions opts $ notBareRepo $ command "import" paramPaths seek
SectionCommon "move and add files from outside git working copy"]
opts :: [Option]
@ -50,8 +50,8 @@ getDuplicateMode = gen
<*> getflag cleanDuplicatesOption
<*> getflag skipDuplicatesOption
where
getflag = Annex.getFlag . optionName
gen False False False False = Default
getflag = Annex.getFlag . optionName
gen False False False False = Default
gen True False False False = Duplicate
gen False True False False = DeDuplicate
gen False False True False = CleanDuplicates
@ -96,7 +96,7 @@ start mode (srcfile, destfile) =
handleexisting Nothing = noop
handleexisting (Just s)
| isDirectory s = notoverwriting "(is a directory)"
| otherwise = ifM (Annex.getState Annex.force) $
| otherwise = ifM (Annex.getState Annex.force)
( liftIO $ nukeFile destfile
, notoverwriting "(use --force to override)"
)

View file

@ -37,8 +37,8 @@ import Types.MetaData
import Logs.MetaData
import Annex.MetaData
def :: [Command]
def = [notBareRepo $ withOptions [templateOption, relaxedOption] $
cmd :: [Command]
cmd = [notBareRepo $ withOptions [templateOption, relaxedOption] $
command "importfeed" (paramRepeating paramUrl) seek
SectionCommon "import files from podcast feeds"]
@ -153,7 +153,7 @@ performDownload relaxed cache todownload = case location todownload of
rundownload videourl ("." ++ Quvi.linkSuffix link) $
addUrlFileQuvi relaxed quviurl videourl
where
forced = Annex.getState Annex.force
forced = Annex.getState Annex.force
{- Avoids downloading any urls that are already known to be
- associated with a file in the annex, unless forced. -}
@ -192,7 +192,7 @@ performDownload relaxed cache todownload = case location todownload of
, return $ Just f
)
where
f = if n < 2
f = if n < 2
then file
else
let (d, base) = splitFileName file

View file

@ -11,8 +11,8 @@ import Common.Annex
import Command
import Annex.Content
def :: [Command]
def = [noCommit $ command "inannex" (paramRepeating paramKey) seek
cmd :: [Command]
cmd = [noCommit $ command "inannex" (paramRepeating paramKey) seek
SectionPlumbing "checks if keys are present in the annex"]
seek :: CommandSeek

View file

@ -22,8 +22,8 @@ import Annex.CatFile
import Annex.Init
import qualified Command.Add
def :: [Command]
def = [notBareRepo $ noDaemonRunning $
cmd :: [Command]
cmd = [notBareRepo $ noDaemonRunning $
command "indirect" paramNothing seek
SectionSetup "switch repository to indirect mode"]
@ -94,7 +94,7 @@ perform = do
warnlocked
showEndOk
warnlocked :: SomeException -> Annex ()
warnlocked :: SomeException -> Annex ()
warnlocked e = do
warning $ show e
warning "leaving this file as-is; correct this problem and run git annex add on it"

View file

@ -1,6 +1,6 @@
{- git-annex command
-
- Copyright 2011 Joey Hess <joey@kitenet.net>
- Copyright 2011-2014 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU GPL version 3 or higher.
-}
@ -16,14 +16,16 @@ import Data.Tuple
import Data.Ord
import Common.Annex
import qualified Remote
import qualified Command.Unused
import qualified Git
import qualified Annex
import qualified Remote
import qualified Types.Remote as Remote
import Command
import Utility.DataUnits
import Utility.DiskFree
import Annex.Content
import Annex.Link
import Types.Key
import Logs.UUID
import Logs.Trust
@ -65,42 +67,67 @@ data StatInfo = StatInfo
, referencedData :: Maybe KeyData
, numCopiesStats :: Maybe NumCopiesStats
}
emptyStatInfo :: StatInfo
emptyStatInfo = StatInfo Nothing Nothing Nothing
-- a state monad for running Stats in
type StatState = StateT StatInfo Annex
def :: [Command]
def = [noCommit $ dontCheck repoExists $ withOptions [jsonOption] $
command "info" paramPaths seek SectionQuery
"shows general information about the annex"]
cmd :: [Command]
cmd = [noCommit $ dontCheck repoExists $ withOptions [jsonOption] $
command "info" (paramOptional $ paramRepeating paramItem) seek SectionQuery
"shows information about the specified item or the repository as a whole"]
seek :: CommandSeek
seek = withWords start
start :: [FilePath] -> CommandStart
start :: [String] -> CommandStart
start [] = do
globalInfo
stop
start ps = do
mapM_ localInfo =<< filterM isdir ps
mapM_ itemInfo ps
stop
where
isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus)
globalInfo :: Annex ()
globalInfo = do
stats <- selStats global_fast_stats global_slow_stats
showCustom "info" $ do
evalStateT (mapM_ showStat stats) (StatInfo Nothing Nothing Nothing)
evalStateT (mapM_ showStat stats) emptyStatInfo
return True
localInfo :: FilePath -> Annex ()
localInfo dir = showCustom (unwords ["info", dir]) $ do
stats <- selStats (tostats local_fast_stats) (tostats local_slow_stats)
evalStateT (mapM_ showStat stats) =<< getLocalStatInfo dir
itemInfo :: String -> Annex ()
itemInfo p = ifM (isdir p)
( dirInfo p
, do
v <- Remote.byName' p
case v of
Right r -> remoteInfo r
Left _ -> maybe noinfo (fileInfo p) =<< isAnnexLink p
)
where
isdir = liftIO . catchBoolIO . (isDirectory <$$> getFileStatus)
noinfo = error $ p ++ " is not a directory or an annexed file or a remote"
dirInfo :: FilePath -> Annex ()
dirInfo dir = showCustom (unwords ["info", dir]) $ do
stats <- selStats (tostats dir_fast_stats) (tostats dir_slow_stats)
evalStateT (mapM_ showStat stats) =<< getDirStatInfo dir
return True
where
tostats = map (\s -> s dir)
tostats = map (\s -> s dir)
fileInfo :: FilePath -> Key -> Annex ()
fileInfo file k = showCustom (unwords ["info", file]) $ do
evalStateT (mapM_ showStat (file_stats file k)) emptyStatInfo
return True
remoteInfo :: Remote -> Annex ()
remoteInfo r = showCustom (unwords ["info", Remote.name r]) $ do
info <- map (\(k, v) -> simpleStat k (pure v)) <$> Remote.getInfo r
evalStateT (mapM_ showStat (remote_stats r ++ info)) emptyStatInfo
return True
selStats :: [Stat] -> [Stat] -> Annex [Stat]
selStats fast_stats slow_stats = do
@ -132,22 +159,42 @@ global_slow_stats =
, bloom_info
, backend_usage
]
local_fast_stats :: [FilePath -> Stat]
local_fast_stats =
[ local_dir
dir_fast_stats :: [FilePath -> Stat]
dir_fast_stats =
[ dir_name
, const local_annex_keys
, const local_annex_size
, const known_annex_files
, const known_annex_size
]
local_slow_stats :: [FilePath -> Stat]
local_slow_stats =
dir_slow_stats :: [FilePath -> Stat]
dir_slow_stats =
[ const numcopies_stats
]
file_stats :: FilePath -> Key -> [Stat]
file_stats f k =
[ file_name f
, key_size k
, key_name k
]
remote_stats :: Remote -> [Stat]
remote_stats r = map (\s -> s r)
[ remote_name
, remote_description
, remote_uuid
, remote_cost
, remote_type
]
stat :: String -> (String -> StatState String) -> Stat
stat desc a = return $ Just (desc, a desc)
-- The json simply contains the same string that is displayed.
simpleStat :: String -> StatState String -> Stat
simpleStat desc getval = stat desc $ json id getval
nostat :: Stat
nostat = return Nothing
@ -168,7 +215,7 @@ showStat s = maybe noop calc =<< s
lift . showRaw =<< a
repository_mode :: Stat
repository_mode = stat "repository mode" $ json id $ lift $
repository_mode = simpleStat "repository mode" $ lift $
ifM isDirect
( return "direct", return "indirect" )
@ -181,15 +228,37 @@ remote_list level = stat n $ nojson $ lift $ do
where
n = showTrustLevel level ++ " repositories"
local_dir :: FilePath -> Stat
local_dir dir = stat "directory" $ json id $ return dir
dir_name :: FilePath -> Stat
dir_name dir = simpleStat "directory" $ pure dir
file_name :: FilePath -> Stat
file_name file = simpleStat "file" $ pure file
remote_name :: Remote -> Stat
remote_name r = simpleStat "remote" $ pure (Remote.name r)
remote_description :: Remote -> Stat
remote_description r = simpleStat "description" $ lift $
Remote.prettyUUID (Remote.uuid r)
remote_uuid :: Remote -> Stat
remote_uuid r = simpleStat "uuid" $ pure $
fromUUID $ Remote.uuid r
remote_cost :: Remote -> Stat
remote_cost r = simpleStat "cost" $ pure $
show $ Remote.cost r
remote_type :: Remote -> Stat
remote_type r = simpleStat "type" $ pure $
Remote.typename $ Remote.remotetype r
local_annex_keys :: Stat
local_annex_keys = stat "local annex keys" $ json show $
countKeys <$> cachedPresentData
local_annex_size :: Stat
local_annex_size = stat "local annex size" $ json id $
local_annex_size = simpleStat "local annex size" $
showSizeKeys <$> cachedPresentData
known_annex_files :: Stat
@ -197,7 +266,7 @@ known_annex_files = stat "annexed files in working tree" $ json show $
countKeys <$> cachedReferencedData
known_annex_size :: Stat
known_annex_size = stat "size of annexed files in working tree" $ json id $
known_annex_size = simpleStat "size of annexed files in working tree" $
showSizeKeys <$> cachedReferencedData
tmp_size :: Stat
@ -206,8 +275,14 @@ tmp_size = staleSize "temporary object directory size" gitAnnexTmpObjectDir
bad_data_size :: Stat
bad_data_size = staleSize "bad keys size" gitAnnexBadDir
key_size :: Key -> Stat
key_size k = simpleStat "size" $ pure $ showSizeKeys $ foldKeys [k]
key_name :: Key -> Stat
key_name k = simpleStat "key" $ pure $ key2file k
bloom_info :: Stat
bloom_info = stat "bloom filter size" $ json id $ do
bloom_info = simpleStat "bloom filter size" $ do
localkeys <- countKeys <$> cachedPresentData
capacity <- fromIntegral <$> lift Command.Unused.bloomCapacity
let note = aside $
@ -240,7 +315,7 @@ transfer_list = stat "transfers in progress" $ nojson $ lift $ do
]
disk_size :: Stat
disk_size = stat "available local disk space" $ json id $ lift $
disk_size = simpleStat "available local disk space" $ lift $
calcfree
<$> (annexDiskReserve <$> Annex.getGitConfig)
<*> inRepo (getDiskFree . gitAnnexDir)
@ -264,7 +339,7 @@ backend_usage = stat "backend usage" $ nojson $
where
calc x y = multiLine $
map (\(n, b) -> b ++ ": " ++ show n) $
reverse $ sort $ map swap $ M.toList $
sortBy (flip compare) $ map swap $ M.toList $
M.unionWith (+) x y
numcopies_stats :: Stat
@ -273,7 +348,7 @@ numcopies_stats = stat "numcopies stats" $ nojson $
where
calc = multiLine
. map (\(variance, count) -> show variance ++ ": " ++ show count)
. reverse . sortBy (comparing snd) . M.toList
. sortBy (flip (comparing snd)) . M.toList
cachedPresentData :: StatState KeyData
cachedPresentData = do
@ -296,12 +371,12 @@ cachedReferencedData = do
put s { referencedData = Just v }
return v
-- currently only available for local info
-- currently only available for directory info
cachedNumCopiesStats :: StatState (Maybe NumCopiesStats)
cachedNumCopiesStats = numCopiesStats <$> get
getLocalStatInfo :: FilePath -> Annex StatInfo
getLocalStatInfo dir = do
getDirStatInfo :: FilePath -> Annex StatInfo
getDirStatInfo dir = do
fast <- Annex.getState Annex.fast
matcher <- Limit.getMatcher
(presentdata, referenceddata, numcopiesstats) <-

View file

@ -11,8 +11,8 @@ import Common.Annex
import Command
import Annex.Init
def :: [Command]
def = [dontCheck repoExists $
cmd :: [Command]
cmd = [dontCheck repoExists $
command "init" paramDesc seek SectionSetup "initialize git-annex"]
seek :: CommandSeek

View file

@ -19,8 +19,8 @@ import Logs.Trust
import Data.Ord
def :: [Command]
def = [command "initremote"
cmd :: [Command]
cmd = [command "initremote"
(paramPair paramName $ paramOptional $ paramRepeating paramKeyValue)
seek SectionSetup "creates a special (non-git) remote"]
@ -33,11 +33,15 @@ start (name:ws) = ifM (isJust <$> findExisting name)
( error $ "There is already a special remote named \"" ++ name ++
"\". (Use enableremote to enable an existing special remote.)"
, do
let c = newConfig name
t <- findType config
ifM (isJust <$> Remote.byNameOnly name)
( error $ "There is already a remote named \"" ++ name ++ "\""
, do
let c = newConfig name
t <- findType config
showStart "initremote" name
next $ perform t name $ M.union config c
showStart "initremote" name
next $ perform t name $ M.union config c
)
)
where
config = Logs.Remote.keyValToConfig ws
@ -63,7 +67,7 @@ findExisting name = do
return $ headMaybe matches
newConfig :: String -> R.RemoteConfig
newConfig name = M.singleton nameKey name
newConfig = M.singleton nameKey
findByName :: String -> M.Map UUID R.RemoteConfig -> [(UUID, R.RemoteConfig)]
findByName n = filter (matching . snd) . M.toList

View file

@ -23,8 +23,8 @@ import Annex.UUID
import qualified Annex
import Git.Types (RemoteName)
def :: [Command]
def = [noCommit $ withOptions [allrepos] $ command "list" paramPaths seek
cmd :: [Command]
cmd = [noCommit $ withOptions [allrepos] $ command "list" paramPaths seek
SectionQuery "show which remotes contain files"]
allrepos :: Option
@ -71,15 +71,15 @@ type Present = Bool
header :: [(RemoteName, TrustLevel)] -> String
header remotes = unlines (zipWith formatheader [0..] remotes) ++ pipes (length remotes)
where
formatheader n (remotename, trustlevel) = pipes n ++ remotename ++ trust trustlevel
pipes = flip replicate '|'
trust UnTrusted = " (untrusted)"
trust _ = ""
formatheader n (remotename, trustlevel) = pipes n ++ remotename ++ trust trustlevel
pipes = flip replicate '|'
trust UnTrusted = " (untrusted)"
trust _ = ""
format :: [(TrustLevel, Present)] -> FilePath -> String
format remotes file = thereMap ++ " " ++ file
where
thereMap = concatMap there remotes
there (UnTrusted, True) = "x"
there (_, True) = "X"
there (_, False) = "_"
thereMap = concatMap there remotes
there (UnTrusted, True) = "x"
there (_, True) = "X"
there (_, False) = "_"

View file

@ -12,8 +12,8 @@ import Command
import qualified Annex.Queue
import qualified Annex
def :: [Command]
def = [notDirect $ command "lock" paramPaths seek SectionCommon
cmd :: [Command]
cmd = [notDirect $ command "lock" paramPaths seek SectionCommon
"undo unlock command"]
seek :: CommandSeek

View file

@ -34,8 +34,8 @@ data RefChange = RefChange
type Outputter = Bool -> POSIXTime -> [UUID] -> Annex ()
def :: [Command]
def = [withOptions options $
cmd :: [Command]
cmd = [withOptions options $
command "log" paramPaths seek SectionQuery "shows location log"]
options :: [Option]

Some files were not shown because too many files have changed in this diff Show more