where indentation
This commit is contained in:
Joey Hess
parent
b8009a68e4
commit
88d1907278
32 changed files with 720 additions and 732 deletions
|
|
@ -158,11 +158,11 @@ makeAlertFiller success alert
|
||||||
, alertButton = Nothing
|
, alertButton = Nothing
|
||||||
, alertIcon = Just $ if success then SuccessIcon else ErrorIcon
|
, alertIcon = Just $ if success then SuccessIcon else ErrorIcon
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
c = alertClass alert
|
c = alertClass alert
|
||||||
c'
|
c'
|
||||||
| success = Success
|
| success = Success
|
||||||
| otherwise = Error
|
| otherwise = Error
|
||||||
|
|
||||||
isFiller :: Alert -> Bool
|
isFiller :: Alert -> Bool
|
||||||
isFiller alert = alertPriority alert == Filler
|
isFiller alert = alertPriority alert == Filler
|
||||||
|
|
@ -179,23 +179,23 @@ isFiller alert = alertPriority alert == Filler
|
||||||
-}
|
-}
|
||||||
mergeAlert :: AlertId -> Alert -> AlertMap -> AlertMap
|
mergeAlert :: AlertId -> Alert -> AlertMap -> AlertMap
|
||||||
mergeAlert i al m = maybe updatePrune updateCombine (alertCombiner al)
|
mergeAlert i al m = maybe updatePrune updateCombine (alertCombiner al)
|
||||||
where
|
where
|
||||||
pruneSame k al' = k == i || not (effectivelySameAlert al al')
|
pruneSame k al' = k == i || not (effectivelySameAlert al al')
|
||||||
pruneBloat m'
|
pruneBloat m'
|
||||||
| bloat > 0 = M.fromList $ pruneold $ M.toList m'
|
| bloat > 0 = M.fromList $ pruneold $ M.toList m'
|
||||||
| otherwise = m'
|
| otherwise = m'
|
||||||
where
|
where
|
||||||
bloat = M.size m' - maxAlerts
|
bloat = M.size m' - maxAlerts
|
||||||
pruneold l =
|
pruneold l =
|
||||||
let (f, rest) = partition (\(_, a) -> isFiller a) l
|
let (f, rest) = partition (\(_, a) -> isFiller a) l
|
||||||
in drop bloat f ++ rest
|
in drop bloat f ++ rest
|
||||||
updatePrune = pruneBloat $ M.filterWithKey pruneSame $
|
updatePrune = pruneBloat $ M.filterWithKey pruneSame $
|
||||||
M.insertWith' const i al m
|
M.insertWith' const i al m
|
||||||
updateCombine combiner =
|
updateCombine combiner =
|
||||||
let combined = M.mapMaybe (combiner al) m
|
let combined = M.mapMaybe (combiner al) m
|
||||||
in if M.null combined
|
in if M.null combined
|
||||||
then updatePrune
|
then updatePrune
|
||||||
else M.delete i $ M.union combined m
|
else M.delete i $ M.union combined m
|
||||||
|
|
||||||
baseActivityAlert :: Alert
|
baseActivityAlert :: Alert
|
||||||
baseActivityAlert = Alert
|
baseActivityAlert = Alert
|
||||||
|
|
@ -288,10 +288,10 @@ sanityCheckFixAlert msg = Alert
|
||||||
, alertCombiner = Just $ dataCombiner (++)
|
, alertCombiner = Just $ dataCombiner (++)
|
||||||
, alertButton = Nothing
|
, alertButton = Nothing
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
render dta = tenseWords $ alerthead : dta ++ [alertfoot]
|
render dta = tenseWords $ alerthead : dta ++ [alertfoot]
|
||||||
alerthead = "The daily sanity check found and fixed a problem:"
|
alerthead = "The daily sanity check found and fixed a problem:"
|
||||||
alertfoot = "If these problems persist, consider filing a bug report."
|
alertfoot = "If these problems persist, consider filing a bug report."
|
||||||
|
|
||||||
pairingAlert :: AlertButton -> Alert
|
pairingAlert :: AlertButton -> Alert
|
||||||
pairingAlert button = baseActivityAlert
|
pairingAlert button = baseActivityAlert
|
||||||
|
|
@ -344,10 +344,10 @@ fileAlert msg file = (activityAlert Nothing [f])
|
||||||
, alertMessageRender = render
|
, alertMessageRender = render
|
||||||
, alertCombiner = Just $ dataCombiner combiner
|
, alertCombiner = Just $ dataCombiner combiner
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
f = fromString $ shortFile $ takeFileName file
|
f = fromString $ shortFile $ takeFileName file
|
||||||
render fs = tenseWords $ msg : fs
|
render fs = tenseWords $ msg : fs
|
||||||
combiner new old = take 10 $ new ++ old
|
combiner new old = take 10 $ new ++ old
|
||||||
|
|
||||||
addFileAlert :: FilePath -> Alert
|
addFileAlert :: FilePath -> Alert
|
||||||
addFileAlert = fileAlert (Tensed "Adding" "Added")
|
addFileAlert = fileAlert (Tensed "Adding" "Added")
|
||||||
|
|
@ -372,8 +372,8 @@ shortFile :: FilePath -> String
|
||||||
shortFile f
|
shortFile f
|
||||||
| len < maxlen = f
|
| len < maxlen = f
|
||||||
| otherwise = take half f ++ ".." ++ drop (len - half) f
|
| otherwise = take half f ++ ".." ++ drop (len - half) f
|
||||||
where
|
where
|
||||||
len = length f
|
len = length f
|
||||||
maxlen = 20
|
maxlen = 20
|
||||||
half = (maxlen - 2) `div` 2
|
half = (maxlen - 2) `div` 2
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -77,34 +77,34 @@ startDaemonStatus = do
|
||||||
writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO ()
|
writeDaemonStatusFile :: FilePath -> DaemonStatus -> IO ()
|
||||||
writeDaemonStatusFile file status =
|
writeDaemonStatusFile file status =
|
||||||
viaTmp writeFile file =<< serialized <$> getPOSIXTime
|
viaTmp writeFile file =<< serialized <$> getPOSIXTime
|
||||||
where
|
where
|
||||||
serialized now = unlines
|
serialized now = unlines
|
||||||
[ "lastRunning:" ++ show now
|
[ "lastRunning:" ++ show now
|
||||||
, "scanComplete:" ++ show (scanComplete status)
|
, "scanComplete:" ++ show (scanComplete status)
|
||||||
, "sanityCheckRunning:" ++ show (sanityCheckRunning status)
|
, "sanityCheckRunning:" ++ show (sanityCheckRunning status)
|
||||||
, "lastSanityCheck:" ++ maybe "" show (lastSanityCheck status)
|
, "lastSanityCheck:" ++ maybe "" show (lastSanityCheck status)
|
||||||
]
|
]
|
||||||
|
|
||||||
readDaemonStatusFile :: FilePath -> IO DaemonStatus
|
readDaemonStatusFile :: FilePath -> IO DaemonStatus
|
||||||
readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file
|
readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file
|
||||||
where
|
where
|
||||||
parse status = foldr parseline status . lines
|
parse status = foldr parseline status . lines
|
||||||
parseline line status
|
parseline line status
|
||||||
| key == "lastRunning" = parseval readtime $ \v ->
|
| key == "lastRunning" = parseval readtime $ \v ->
|
||||||
status { lastRunning = Just v }
|
status { lastRunning = Just v }
|
||||||
| key == "scanComplete" = parseval readish $ \v ->
|
| key == "scanComplete" = parseval readish $ \v ->
|
||||||
status { scanComplete = v }
|
status { scanComplete = v }
|
||||||
| key == "sanityCheckRunning" = parseval readish $ \v ->
|
| key == "sanityCheckRunning" = parseval readish $ \v ->
|
||||||
status { sanityCheckRunning = v }
|
status { sanityCheckRunning = v }
|
||||||
| key == "lastSanityCheck" = parseval readtime $ \v ->
|
| key == "lastSanityCheck" = parseval readtime $ \v ->
|
||||||
status { lastSanityCheck = Just v }
|
status { lastSanityCheck = Just v }
|
||||||
| otherwise = status -- unparsable line
|
| otherwise = status -- unparsable line
|
||||||
where
|
where
|
||||||
(key, value) = separate (== ':') line
|
(key, value) = separate (== ':') line
|
||||||
parseval parser a = maybe status a (parser value)
|
parseval parser a = maybe status a (parser value)
|
||||||
readtime s = do
|
readtime s = do
|
||||||
d <- parseTime defaultTimeLocale "%s%Qs" s
|
d <- parseTime defaultTimeLocale "%s%Qs" s
|
||||||
Just $ utcTimeToPOSIXSeconds d
|
Just $ utcTimeToPOSIXSeconds d
|
||||||
|
|
||||||
{- Checks if a time stamp was made after the daemon was lastRunning.
|
{- Checks if a time stamp was made after the daemon was lastRunning.
|
||||||
-
|
-
|
||||||
|
|
@ -116,9 +116,9 @@ readDaemonStatusFile file = parse <$> newDaemonStatus <*> readFile file
|
||||||
-}
|
-}
|
||||||
afterLastDaemonRun :: EpochTime -> DaemonStatus -> Bool
|
afterLastDaemonRun :: EpochTime -> DaemonStatus -> Bool
|
||||||
afterLastDaemonRun timestamp status = maybe False (< t) (lastRunning status)
|
afterLastDaemonRun timestamp status = maybe False (< t) (lastRunning status)
|
||||||
where
|
where
|
||||||
t = realToFrac (timestamp + slop) :: POSIXTime
|
t = realToFrac (timestamp + slop) :: POSIXTime
|
||||||
slop = fromIntegral tenMinutes
|
slop = fromIntegral tenMinutes
|
||||||
|
|
||||||
tenMinutes :: Int
|
tenMinutes :: Int
|
||||||
tenMinutes = 10 * 60
|
tenMinutes = 10 * 60
|
||||||
|
|
@ -141,27 +141,27 @@ alterTransferInfo t a = updateTransferInfo' $ M.adjust a t
|
||||||
- transferPaused, and bytesComplete values, which are not written to disk. -}
|
- transferPaused, and bytesComplete values, which are not written to disk. -}
|
||||||
updateTransferInfo :: Transfer -> TransferInfo -> Assistant ()
|
updateTransferInfo :: Transfer -> TransferInfo -> Assistant ()
|
||||||
updateTransferInfo t info = updateTransferInfo' $ M.insertWith' merge t info
|
updateTransferInfo t info = updateTransferInfo' $ M.insertWith' merge t info
|
||||||
where
|
where
|
||||||
merge new old = new
|
merge new old = new
|
||||||
{ transferTid = maybe (transferTid new) Just (transferTid old)
|
{ transferTid = maybe (transferTid new) Just (transferTid old)
|
||||||
, transferPaused = transferPaused new || transferPaused old
|
, transferPaused = transferPaused new || transferPaused old
|
||||||
, bytesComplete = maybe (bytesComplete new) Just (bytesComplete old)
|
, bytesComplete = maybe (bytesComplete new) Just (bytesComplete old)
|
||||||
}
|
}
|
||||||
|
|
||||||
updateTransferInfo' :: (TransferMap -> TransferMap) -> Assistant ()
|
updateTransferInfo' :: (TransferMap -> TransferMap) -> Assistant ()
|
||||||
updateTransferInfo' a = notifyTransfer `after` modifyDaemonStatus_ update
|
updateTransferInfo' a = notifyTransfer `after` modifyDaemonStatus_ update
|
||||||
where
|
where
|
||||||
update s = s { currentTransfers = a (currentTransfers s) }
|
update s = s { currentTransfers = a (currentTransfers s) }
|
||||||
|
|
||||||
{- Removes a transfer from the map, and returns its info. -}
|
{- Removes a transfer from the map, and returns its info. -}
|
||||||
removeTransfer :: Transfer -> Assistant (Maybe TransferInfo)
|
removeTransfer :: Transfer -> Assistant (Maybe TransferInfo)
|
||||||
removeTransfer t = notifyTransfer `after` modifyDaemonStatus remove
|
removeTransfer t = notifyTransfer `after` modifyDaemonStatus remove
|
||||||
where
|
where
|
||||||
remove s =
|
remove s =
|
||||||
let (info, ts) = M.updateLookupWithKey
|
let (info, ts) = M.updateLookupWithKey
|
||||||
(\_k _v -> Nothing)
|
(\_k _v -> Nothing)
|
||||||
t (currentTransfers s)
|
t (currentTransfers s)
|
||||||
in (s { currentTransfers = ts }, info)
|
in (s { currentTransfers = ts }, info)
|
||||||
|
|
||||||
{- Send a notification when a transfer is changed. -}
|
{- Send a notification when a transfer is changed. -}
|
||||||
notifyTransfer :: Assistant ()
|
notifyTransfer :: Assistant ()
|
||||||
|
|
@ -180,11 +180,11 @@ notifyAlert = do
|
||||||
{- Returns the alert's identifier, which can be used to remove it. -}
|
{- Returns the alert's identifier, which can be used to remove it. -}
|
||||||
addAlert :: Alert -> Assistant AlertId
|
addAlert :: Alert -> Assistant AlertId
|
||||||
addAlert alert = notifyAlert `after` modifyDaemonStatus add
|
addAlert alert = notifyAlert `after` modifyDaemonStatus add
|
||||||
where
|
where
|
||||||
add s = (s { lastAlertId = i, alertMap = m }, i)
|
add s = (s { lastAlertId = i, alertMap = m }, i)
|
||||||
where
|
where
|
||||||
i = nextAlertId $ lastAlertId s
|
i = nextAlertId $ lastAlertId s
|
||||||
m = mergeAlert i alert (alertMap s)
|
m = mergeAlert i alert (alertMap s)
|
||||||
|
|
||||||
removeAlert :: AlertId -> Assistant ()
|
removeAlert :: AlertId -> Assistant ()
|
||||||
removeAlert i = updateAlert i (const Nothing)
|
removeAlert i = updateAlert i (const Nothing)
|
||||||
|
|
@ -194,8 +194,8 @@ updateAlert i a = updateAlertMap $ \m -> M.update a i m
|
||||||
|
|
||||||
updateAlertMap :: (AlertMap -> AlertMap) -> Assistant ()
|
updateAlertMap :: (AlertMap -> AlertMap) -> Assistant ()
|
||||||
updateAlertMap a = notifyAlert `after` modifyDaemonStatus_ update
|
updateAlertMap a = notifyAlert `after` modifyDaemonStatus_ update
|
||||||
where
|
where
|
||||||
update s = s { alertMap = a (alertMap s) }
|
update s = s { alertMap = a (alertMap s) }
|
||||||
|
|
||||||
{- Displays an alert while performing an activity that returns True on
|
{- Displays an alert while performing an activity that returns True on
|
||||||
- success.
|
- success.
|
||||||
|
|
|
||||||
|
|
@ -37,30 +37,29 @@ handleDrops' locs rs fromhere key (Just f)
|
||||||
then go rs =<< dropl n
|
then go rs =<< dropl n
|
||||||
else go rs n
|
else go rs n
|
||||||
| otherwise = go rs =<< getcopies
|
| otherwise = go rs =<< getcopies
|
||||||
where
|
where
|
||||||
getcopies = do
|
getcopies = do
|
||||||
have <- length . snd <$> trustPartition UnTrusted locs
|
have <- length . snd <$> trustPartition UnTrusted locs
|
||||||
numcopies <- getNumCopies =<< numCopies f
|
numcopies <- getNumCopies =<< numCopies f
|
||||||
return (have, numcopies)
|
return (have, numcopies)
|
||||||
checkcopies (have, numcopies) = have > numcopies
|
checkcopies (have, numcopies) = have > numcopies
|
||||||
decrcopies (have, numcopies) = (have - 1, numcopies)
|
decrcopies (have, numcopies) = (have - 1, numcopies)
|
||||||
|
|
||||||
go [] _ = noop
|
go [] _ = noop
|
||||||
go (r:rest) n
|
go (r:rest) n
|
||||||
| checkcopies n = dropr r n >>= go rest
|
| checkcopies n = dropr r n >>= go rest
|
||||||
| otherwise = noop
|
| otherwise = noop
|
||||||
|
|
||||||
checkdrop n@(_, numcopies) u a =
|
checkdrop n@(_, numcopies) u a = ifM (wantDrop u (Just f))
|
||||||
ifM (wantDrop u (Just f))
|
( ifM (doCommand $ a (Just numcopies))
|
||||||
( ifM (doCommand $ a (Just numcopies))
|
( return $ decrcopies n
|
||||||
( return $ decrcopies n
|
, return n
|
||||||
, return n
|
)
|
||||||
)
|
, return n
|
||||||
, return n
|
)
|
||||||
)
|
|
||||||
|
|
||||||
dropl n = checkdrop n Nothing $ \numcopies ->
|
dropl n = checkdrop n Nothing $ \numcopies ->
|
||||||
Command.Drop.startLocal f numcopies key
|
Command.Drop.startLocal f numcopies key
|
||||||
|
|
||||||
dropr r n = checkdrop n (Just $ Remote.uuid r) $ \numcopies ->
|
dropr r n = checkdrop n (Just $ Remote.uuid r) $ \numcopies ->
|
||||||
Command.Drop.startRemote f numcopies key r
|
Command.Drop.startRemote f numcopies key r
|
||||||
|
|
|
||||||
|
|
@ -36,36 +36,35 @@ standaloneAppBase = getEnv "GIT_ANNEX_APP_BASE"
|
||||||
-}
|
-}
|
||||||
ensureInstalled :: IO ()
|
ensureInstalled :: IO ()
|
||||||
ensureInstalled = go =<< standaloneAppBase
|
ensureInstalled = go =<< standaloneAppBase
|
||||||
where
|
where
|
||||||
go Nothing = noop
|
go Nothing = noop
|
||||||
go (Just base) = do
|
go (Just base) = do
|
||||||
let program = base ++ "runshell git-annex"
|
let program = base ++ "runshell git-annex"
|
||||||
programfile <- programFile
|
programfile <- programFile
|
||||||
createDirectoryIfMissing True (parentDir programfile)
|
createDirectoryIfMissing True (parentDir programfile)
|
||||||
writeFile programfile program
|
writeFile programfile program
|
||||||
|
|
||||||
#ifdef darwin_HOST_OS
|
#ifdef darwin_HOST_OS
|
||||||
autostartfile <- userAutoStart osxAutoStartLabel
|
autostartfile <- userAutoStart osxAutoStartLabel
|
||||||
#else
|
#else
|
||||||
autostartfile <- autoStartPath "git-annex"
|
autostartfile <- autoStartPath "git-annex" <$> userConfigDir
|
||||||
<$> userConfigDir
|
|
||||||
#endif
|
#endif
|
||||||
installAutoStart program autostartfile
|
installAutoStart program autostartfile
|
||||||
|
|
||||||
{- This shim is only updated if it doesn't
|
{- This shim is only updated if it doesn't
|
||||||
- already exist with the right content. This
|
- already exist with the right content. This
|
||||||
- ensures that there's no race where it would have
|
- ensures that there's no race where it would have
|
||||||
- worked, but is unavailable due to being updated. -}
|
- worked, but is unavailable due to being updated. -}
|
||||||
sshdir <- sshDir
|
sshdir <- sshDir
|
||||||
let shim = sshdir </> "git-annex-shell"
|
let shim = sshdir </> "git-annex-shell"
|
||||||
let content = unlines
|
let content = unlines
|
||||||
[ "#!/bin/sh"
|
[ "#!/bin/sh"
|
||||||
, "set -e"
|
, "set -e"
|
||||||
, "exec", base </> "runshell" ++
|
, "exec", base </> "runshell" ++
|
||||||
" git-annex-shell -c \"$SSH_ORIGINAL_COMMAND\""
|
" git-annex-shell -c \"$SSH_ORIGINAL_COMMAND\""
|
||||||
]
|
]
|
||||||
curr <- catchDefaultIO "" $ readFileStrict shim
|
curr <- catchDefaultIO "" $ readFileStrict shim
|
||||||
when (curr /= content) $ do
|
when (curr /= content) $ do
|
||||||
createDirectoryIfMissing True (parentDir shim)
|
createDirectoryIfMissing True (parentDir shim)
|
||||||
writeFile shim content
|
writeFile shim content
|
||||||
modifyFileMode shim $ addModes [ownerExecuteMode]
|
modifyFileMode shim $ addModes [ownerExecuteMode]
|
||||||
|
|
|
||||||
|
|
@ -31,21 +31,21 @@ makeSshRemote forcersync sshdata = do
|
||||||
addRemote $ maker (sshRepoName sshdata) sshurl
|
addRemote $ maker (sshRepoName sshdata) sshurl
|
||||||
syncNewRemote r
|
syncNewRemote r
|
||||||
return r
|
return r
|
||||||
where
|
where
|
||||||
rsync = forcersync || rsyncOnly sshdata
|
rsync = forcersync || rsyncOnly sshdata
|
||||||
maker
|
maker
|
||||||
| rsync = makeRsyncRemote
|
| rsync = makeRsyncRemote
|
||||||
| otherwise = makeGitRemote
|
| otherwise = makeGitRemote
|
||||||
sshurl = T.unpack $ T.concat $
|
sshurl = T.unpack $ T.concat $
|
||||||
if rsync
|
if rsync
|
||||||
then [u, h, T.pack ":", sshDirectory sshdata, T.pack "/"]
|
then [u, h, T.pack ":", sshDirectory sshdata, T.pack "/"]
|
||||||
else [T.pack "ssh://", u, h, d, T.pack "/"]
|
else [T.pack "ssh://", u, h, d, T.pack "/"]
|
||||||
where
|
where
|
||||||
u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata
|
u = maybe (T.pack "") (\v -> T.concat [v, T.pack "@"]) $ sshUserName sshdata
|
||||||
h = sshHostName sshdata
|
h = sshHostName sshdata
|
||||||
d
|
d
|
||||||
| T.pack "/" `T.isPrefixOf` sshDirectory sshdata = d
|
| T.pack "/" `T.isPrefixOf` sshDirectory sshdata = d
|
||||||
| otherwise = T.concat [T.pack "/~/", sshDirectory sshdata]
|
| otherwise = T.concat [T.pack "/~/", sshDirectory sshdata]
|
||||||
|
|
||||||
{- Runs an action that returns a name of the remote, and finishes adding it. -}
|
{- Runs an action that returns a name of the remote, and finishes adding it. -}
|
||||||
addRemote :: Annex String -> Annex Remote
|
addRemote :: Annex String -> Annex Remote
|
||||||
|
|
@ -58,12 +58,12 @@ addRemote a = do
|
||||||
makeRsyncRemote :: String -> String -> Annex String
|
makeRsyncRemote :: String -> String -> Annex String
|
||||||
makeRsyncRemote name location = makeRemote name location $
|
makeRsyncRemote name location = makeRemote name location $
|
||||||
const $ makeSpecialRemote name Rsync.remote config
|
const $ makeSpecialRemote name Rsync.remote config
|
||||||
where
|
where
|
||||||
config = M.fromList
|
config = M.fromList
|
||||||
[ ("encryption", "shared")
|
[ ("encryption", "shared")
|
||||||
, ("rsyncurl", location)
|
, ("rsyncurl", location)
|
||||||
, ("type", "rsync")
|
, ("type", "rsync")
|
||||||
]
|
]
|
||||||
|
|
||||||
{- Inits a special remote. -}
|
{- Inits a special remote. -}
|
||||||
makeSpecialRemote :: String -> RemoteType -> R.RemoteConfig -> Annex ()
|
makeSpecialRemote :: String -> RemoteType -> R.RemoteConfig -> Annex ()
|
||||||
|
|
@ -95,8 +95,8 @@ makeRemote basename location a = do
|
||||||
a name
|
a name
|
||||||
return name
|
return name
|
||||||
else return basename
|
else return basename
|
||||||
where
|
where
|
||||||
samelocation x = Git.repoLocation x == location
|
samelocation x = Git.repoLocation x == location
|
||||||
|
|
||||||
{- Generate an unused name for a remote, adding a number if
|
{- Generate an unused name for a remote, adding a number if
|
||||||
- necessary.
|
- necessary.
|
||||||
|
|
@ -106,12 +106,12 @@ uniqueRemoteName :: String -> Int -> Git.Repo -> String
|
||||||
uniqueRemoteName basename n r
|
uniqueRemoteName basename n r
|
||||||
| null namecollision = name
|
| null namecollision = name
|
||||||
| otherwise = uniqueRemoteName legalbasename (succ n) r
|
| otherwise = uniqueRemoteName legalbasename (succ n) r
|
||||||
where
|
where
|
||||||
namecollision = filter samename (Git.remotes r)
|
namecollision = filter samename (Git.remotes r)
|
||||||
samename x = Git.remoteName x == Just name
|
samename x = Git.remoteName x == Just name
|
||||||
name
|
name
|
||||||
| n == 0 = legalbasename
|
| n == 0 = legalbasename
|
||||||
| otherwise = legalbasename ++ show n
|
| otherwise = legalbasename ++ show n
|
||||||
legalbasename = filter legal basename
|
legalbasename = filter legal basename
|
||||||
legal '_' = True
|
legal '_' = True
|
||||||
legal c = isAlphaNum c
|
legal c = isAlphaNum c
|
||||||
|
|
|
||||||
|
|
@ -23,8 +23,8 @@ setupAuthorizedKeys msg = do
|
||||||
validateSshPubKey pubkey
|
validateSshPubKey pubkey
|
||||||
unlessM (liftIO $ addAuthorizedKeys False pubkey) $
|
unlessM (liftIO $ addAuthorizedKeys False pubkey) $
|
||||||
error "failed setting up ssh authorized keys"
|
error "failed setting up ssh authorized keys"
|
||||||
where
|
where
|
||||||
pubkey = remoteSshPubKey $ pairMsgData msg
|
pubkey = remoteSshPubKey $ pairMsgData msg
|
||||||
|
|
||||||
{- When pairing is complete, this is used to set up the remote for the host
|
{- When pairing is complete, this is used to set up the remote for the host
|
||||||
- we paired with. -}
|
- we paired with. -}
|
||||||
|
|
@ -78,12 +78,12 @@ bestHostName msg = case remoteHostName $ pairMsgData msg of
|
||||||
getAddrInfo Nothing (Just localname) Nothing
|
getAddrInfo Nothing (Just localname) Nothing
|
||||||
maybe fallback (const $ return localname) (headMaybe addrs)
|
maybe fallback (const $ return localname) (headMaybe addrs)
|
||||||
Nothing -> fallback
|
Nothing -> fallback
|
||||||
where
|
where
|
||||||
fallback = do
|
fallback = do
|
||||||
let a = pairMsgAddr msg
|
let a = pairMsgAddr msg
|
||||||
let sockaddr = case a of
|
let sockaddr = case a of
|
||||||
IPv4Addr addr -> SockAddrInet (PortNum 0) addr
|
IPv4Addr addr -> SockAddrInet (PortNum 0) addr
|
||||||
IPv6Addr addr -> SockAddrInet6 (PortNum 0) 0 addr 0
|
IPv6Addr addr -> SockAddrInet6 (PortNum 0) 0 addr 0
|
||||||
fromMaybe (showAddr a)
|
fromMaybe (showAddr a)
|
||||||
<$> catchDefaultIO Nothing
|
<$> catchDefaultIO Nothing
|
||||||
(fst <$> getNameInfo [] True False sockaddr)
|
(fst <$> getNameInfo [] True False sockaddr)
|
||||||
|
|
|
||||||
|
|
@ -62,13 +62,13 @@ multicastPairMsg repeats secret pairdata stage = go M.empty repeats
|
||||||
sendinterface _ (IPv6Addr _) = noop
|
sendinterface _ (IPv6Addr _) = noop
|
||||||
sendinterface cache i = void $ catchMaybeIO $
|
sendinterface cache i = void $ catchMaybeIO $
|
||||||
withSocketsDo $ bracket setup cleanup use
|
withSocketsDo $ bracket setup cleanup use
|
||||||
where
|
where
|
||||||
setup = multicastSender (multicastAddress i) pairingPort
|
setup = multicastSender (multicastAddress i) pairingPort
|
||||||
cleanup (sock, _) = sClose sock -- FIXME does not work
|
cleanup (sock, _) = sClose sock -- FIXME does not work
|
||||||
use (sock, addr) = do
|
use (sock, addr) = do
|
||||||
setInterface sock (showAddr i)
|
setInterface sock (showAddr i)
|
||||||
maybe noop (\s -> void $ sendTo sock s addr)
|
maybe noop (\s -> void $ sendTo sock s addr)
|
||||||
(M.lookup i cache)
|
(M.lookup i cache)
|
||||||
updatecache cache [] = cache
|
updatecache cache [] = cache
|
||||||
updatecache cache (i:is)
|
updatecache cache (i:is)
|
||||||
| M.member i cache = updatecache cache is
|
| M.member i cache = updatecache cache is
|
||||||
|
|
|
||||||
|
|
@ -26,20 +26,20 @@ getFailedPushesBefore duration = do
|
||||||
m <- atomically $ readTMVar v
|
m <- atomically $ readTMVar v
|
||||||
now <- getCurrentTime
|
now <- getCurrentTime
|
||||||
return $ M.keys $ M.filter (not . toorecent now) m
|
return $ M.keys $ M.filter (not . toorecent now) m
|
||||||
where
|
where
|
||||||
toorecent now time = now `diffUTCTime` time < duration
|
toorecent now time = now `diffUTCTime` time < duration
|
||||||
|
|
||||||
{- Modifies the map. -}
|
{- Modifies the map. -}
|
||||||
changeFailedPushMap :: (PushMap -> PushMap) -> Assistant ()
|
changeFailedPushMap :: (PushMap -> PushMap) -> Assistant ()
|
||||||
changeFailedPushMap a = do
|
changeFailedPushMap a = do
|
||||||
v <- getAssistant failedPushMap
|
v <- getAssistant failedPushMap
|
||||||
liftIO $ atomically $ store v . a . fromMaybe M.empty =<< tryTakeTMVar v
|
liftIO $ atomically $ store v . a . fromMaybe M.empty =<< tryTakeTMVar v
|
||||||
where
|
where
|
||||||
{- tryTakeTMVar empties the TMVar; refill it only if
|
{- tryTakeTMVar empties the TMVar; refill it only if
|
||||||
- the modified map is not itself empty -}
|
- the modified map is not itself empty -}
|
||||||
store v m
|
store v m
|
||||||
| m == M.empty = noop
|
| m == M.empty = noop
|
||||||
| otherwise = putTMVar v $! m
|
| otherwise = putTMVar v $! m
|
||||||
|
|
||||||
notifyPush :: [UUID] -> Assistant ()
|
notifyPush :: [UUID] -> Assistant ()
|
||||||
notifyPush us = flip putTSet us <<~ (pushNotifierSuccesses . pushNotifier)
|
notifyPush us = flip putTSet us <<~ (pushNotifierSuccesses . pushNotifier)
|
||||||
|
|
|
||||||
|
|
@ -33,9 +33,9 @@ addScanRemotes full rs = do
|
||||||
liftIO $ atomically $ do
|
liftIO $ atomically $ do
|
||||||
m <- fromMaybe M.empty <$> tryTakeTMVar v
|
m <- fromMaybe M.empty <$> tryTakeTMVar v
|
||||||
putTMVar v $ M.unionWith merge (M.fromList $ zip rs (map info rs)) m
|
putTMVar v $ M.unionWith merge (M.fromList $ zip rs (map info rs)) m
|
||||||
where
|
where
|
||||||
info r = ScanInfo (-1 * Remote.cost r) full
|
info r = ScanInfo (-1 * Remote.cost r) full
|
||||||
merge x y = ScanInfo
|
merge x y = ScanInfo
|
||||||
{ scanPriority = max (scanPriority x) (scanPriority y)
|
{ scanPriority = max (scanPriority x) (scanPriority y)
|
||||||
, fullScan = fullScan x || fullScan y
|
, fullScan = fullScan x || fullScan y
|
||||||
}
|
}
|
||||||
|
|
|
||||||
|
|
@ -56,9 +56,9 @@ genSshRepoName :: String -> FilePath -> String
|
||||||
genSshRepoName host dir
|
genSshRepoName host dir
|
||||||
| null dir = filter legal host
|
| null dir = filter legal host
|
||||||
| otherwise = filter legal $ host ++ "_" ++ replace "/" "_" dir
|
| otherwise = filter legal $ host ++ "_" ++ replace "/" "_" dir
|
||||||
where
|
where
|
||||||
legal '_' = True
|
legal '_' = True
|
||||||
legal c = isAlphaNum c
|
legal c = isAlphaNum c
|
||||||
|
|
||||||
{- The output of ssh, including both stdout and stderr. -}
|
{- The output of ssh, including both stdout and stderr. -}
|
||||||
sshTranscript :: [String] -> String -> IO (String, Bool)
|
sshTranscript :: [String] -> String -> IO (String, Bool)
|
||||||
|
|
@ -97,26 +97,26 @@ sshTranscript opts input = do
|
||||||
- command=foo, or other weirdness -}
|
- command=foo, or other weirdness -}
|
||||||
validateSshPubKey :: SshPubKey -> IO ()
|
validateSshPubKey :: SshPubKey -> IO ()
|
||||||
validateSshPubKey pubkey = either error return $ check $ words pubkey
|
validateSshPubKey pubkey = either error return $ check $ words pubkey
|
||||||
where
|
where
|
||||||
check [prefix, _key, comment] = do
|
check [prefix, _key, comment] = do
|
||||||
checkprefix prefix
|
|
||||||
checkcomment comment
|
|
||||||
check [prefix, _key] =
|
|
||||||
checkprefix prefix
|
|
||||||
check _ = err "wrong number of words in ssh public key"
|
|
||||||
|
|
||||||
ok = Right ()
|
|
||||||
err msg = Left $ unwords [msg, pubkey]
|
|
||||||
|
|
||||||
checkprefix prefix
|
checkprefix prefix
|
||||||
| ssh == "ssh" && all isAlphaNum keytype = ok
|
|
||||||
| otherwise = err "bad ssh public key prefix"
|
|
||||||
where
|
|
||||||
(ssh, keytype) = separate (== '-') prefix
|
|
||||||
|
|
||||||
checkcomment comment
|
checkcomment comment
|
||||||
| all (\c -> isAlphaNum c || c == '@' || c == '-' || c == '_') comment = ok
|
check [prefix, _key] =
|
||||||
| otherwise = err "bad comment in ssh public key"
|
checkprefix prefix
|
||||||
|
check _ = err "wrong number of words in ssh public key"
|
||||||
|
|
||||||
|
ok = Right ()
|
||||||
|
err msg = Left $ unwords [msg, pubkey]
|
||||||
|
|
||||||
|
checkprefix prefix
|
||||||
|
| ssh == "ssh" && all isAlphaNum keytype = ok
|
||||||
|
| otherwise = err "bad ssh public key prefix"
|
||||||
|
where
|
||||||
|
(ssh, keytype) = separate (== '-') prefix
|
||||||
|
|
||||||
|
checkcomment comment
|
||||||
|
| all (\c -> isAlphaNum c || c == '@' || c == '-' || c == '_') comment = ok
|
||||||
|
| otherwise = err "bad comment in ssh public key"
|
||||||
|
|
||||||
addAuthorizedKeys :: Bool -> SshPubKey -> IO Bool
|
addAuthorizedKeys :: Bool -> SshPubKey -> IO Bool
|
||||||
addAuthorizedKeys rsynconly pubkey = boolSystem "sh"
|
addAuthorizedKeys rsynconly pubkey = boolSystem "sh"
|
||||||
|
|
@ -153,14 +153,14 @@ addAuthorizedKeysCommand rsynconly pubkey = join "&&"
|
||||||
, ">>~/.ssh/authorized_keys"
|
, ">>~/.ssh/authorized_keys"
|
||||||
]
|
]
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
echoval v = "echo " ++ shellEscape v
|
echoval v = "echo " ++ shellEscape v
|
||||||
wrapper = "~/.ssh/git-annex-shell"
|
wrapper = "~/.ssh/git-annex-shell"
|
||||||
script =
|
script =
|
||||||
[ "#!/bin/sh"
|
[ "#!/bin/sh"
|
||||||
, "set -e"
|
, "set -e"
|
||||||
, "exec git-annex-shell -c \"$SSH_ORIGINAL_COMMAND\""
|
, "exec git-annex-shell -c \"$SSH_ORIGINAL_COMMAND\""
|
||||||
]
|
]
|
||||||
|
|
||||||
authorizedKeysLine :: Bool -> SshPubKey -> String
|
authorizedKeysLine :: Bool -> SshPubKey -> String
|
||||||
authorizedKeysLine rsynconly pubkey
|
authorizedKeysLine rsynconly pubkey
|
||||||
|
|
@ -168,8 +168,8 @@ authorizedKeysLine rsynconly pubkey
|
||||||
- long perl script. -}
|
- long perl script. -}
|
||||||
| rsynconly = pubkey
|
| rsynconly = pubkey
|
||||||
| otherwise = limitcommand ++ pubkey
|
| otherwise = limitcommand ++ pubkey
|
||||||
where
|
where
|
||||||
limitcommand = "command=\"~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding "
|
limitcommand = "command=\"~/.ssh/git-annex-shell\",no-agent-forwarding,no-port-forwarding,no-X11-forwarding "
|
||||||
|
|
||||||
{- Generates a ssh key pair. -}
|
{- Generates a ssh key pair. -}
|
||||||
genSshKeyPair :: IO SshKeyPair
|
genSshKeyPair :: IO SshKeyPair
|
||||||
|
|
@ -213,12 +213,12 @@ setupSshKeyPair sshkeypair sshdata = do
|
||||||
]
|
]
|
||||||
|
|
||||||
return $ sshdata { sshHostName = T.pack mangledhost }
|
return $ sshdata { sshHostName = T.pack mangledhost }
|
||||||
where
|
where
|
||||||
sshprivkeyfile = "key." ++ mangledhost
|
sshprivkeyfile = "key." ++ mangledhost
|
||||||
sshpubkeyfile = sshprivkeyfile ++ ".pub"
|
sshpubkeyfile = sshprivkeyfile ++ ".pub"
|
||||||
mangledhost = mangleSshHostName
|
mangledhost = mangleSshHostName
|
||||||
(T.unpack $ sshHostName sshdata)
|
(T.unpack $ sshHostName sshdata)
|
||||||
(T.unpack <$> sshUserName sshdata)
|
(T.unpack <$> sshUserName sshdata)
|
||||||
|
|
||||||
mangleSshHostName :: String -> Maybe String -> String
|
mangleSshHostName :: String -> Maybe String -> String
|
||||||
mangleSshHostName host user = "git-annex-" ++ host ++ (maybe "-" ('-':) user)
|
mangleSshHostName host user = "git-annex-" ++ host ++ (maybe "-" ('-':) user)
|
||||||
|
|
@ -227,8 +227,8 @@ unMangleSshHostName :: String -> String
|
||||||
unMangleSshHostName h
|
unMangleSshHostName h
|
||||||
| "git-annex-" `isPrefixOf` h = join "-" (beginning $ drop 2 dashbits)
|
| "git-annex-" `isPrefixOf` h = join "-" (beginning $ drop 2 dashbits)
|
||||||
| otherwise = h
|
| otherwise = h
|
||||||
where
|
where
|
||||||
dashbits = split "-" h
|
dashbits = split "-" h
|
||||||
|
|
||||||
{- Does ssh have known_hosts data for a hostname? -}
|
{- Does ssh have known_hosts data for a hostname? -}
|
||||||
knownHost :: Text -> IO Bool
|
knownHost :: Text -> IO Bool
|
||||||
|
|
@ -238,7 +238,7 @@ knownHost hostname = do
|
||||||
( not . null <$> checkhost
|
( not . null <$> checkhost
|
||||||
, return False
|
, return False
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
{- ssh-keygen -F can crash on some old known_hosts file -}
|
{- ssh-keygen -F can crash on some old known_hosts file -}
|
||||||
checkhost = catchDefaultIO "" $
|
checkhost = catchDefaultIO "" $
|
||||||
readProcess "ssh-keygen" ["-F", T.unpack hostname]
|
readProcess "ssh-keygen" ["-F", T.unpack hostname]
|
||||||
|
|
|
||||||
|
|
@ -133,15 +133,15 @@ pushToRemotes now notifypushes remotes = do
|
||||||
, Param $ refspec Annex.Branch.name
|
, Param $ refspec Annex.Branch.name
|
||||||
, Param $ refspec branch
|
, Param $ refspec branch
|
||||||
] g
|
] g
|
||||||
where
|
where
|
||||||
{- Push to refs/synced/uuid/branch; this
|
{- Push to refs/synced/uuid/branch; this
|
||||||
- avoids cluttering up the branch display. -}
|
- avoids cluttering up the branch display. -}
|
||||||
refspec b = concat
|
refspec b = concat
|
||||||
[ s
|
[ s
|
||||||
, ":"
|
, ":"
|
||||||
, "refs/synced/" ++ fromUUID u ++ "/" ++ s
|
, "refs/synced/" ++ fromUUID u ++ "/" ++ s
|
||||||
]
|
]
|
||||||
where s = show $ Git.Ref.base b
|
where s = show $ Git.Ref.base b
|
||||||
|
|
||||||
{- Manually pull from remotes and merge their branches. -}
|
{- Manually pull from remotes and merge their branches. -}
|
||||||
manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Bool], Bool)
|
manualPull :: Maybe Git.Ref -> [Remote] -> Assistant ([Bool], Bool)
|
||||||
|
|
|
||||||
|
|
@ -86,15 +86,15 @@ onAdd file
|
||||||
|
|
||||||
equivBranches :: Git.Ref -> Git.Ref -> Bool
|
equivBranches :: Git.Ref -> Git.Ref -> Bool
|
||||||
equivBranches x y = base x == base y
|
equivBranches x y = base x == base y
|
||||||
where
|
where
|
||||||
base = takeFileName . show
|
base = takeFileName . show
|
||||||
|
|
||||||
isAnnexBranch :: FilePath -> Bool
|
isAnnexBranch :: FilePath -> Bool
|
||||||
isAnnexBranch f = n `isSuffixOf` f
|
isAnnexBranch f = n `isSuffixOf` f
|
||||||
where
|
where
|
||||||
n = "/" ++ show Annex.Branch.name
|
n = "/" ++ show Annex.Branch.name
|
||||||
|
|
||||||
fileToBranch :: FilePath -> Git.Ref
|
fileToBranch :: FilePath -> Git.Ref
|
||||||
fileToBranch f = Git.Ref $ "refs" </> base
|
fileToBranch f = Git.Ref $ "refs" </> base
|
||||||
where
|
where
|
||||||
base = Prelude.last $ split "/refs/" f
|
base = Prelude.last $ split "/refs/" f
|
||||||
|
|
|
||||||
|
|
@ -119,36 +119,36 @@ startOneService client (x:xs) = do
|
||||||
{- Filter matching events recieved when drives are mounted and unmounted. -}
|
{- Filter matching events recieved when drives are mounted and unmounted. -}
|
||||||
mountChanged :: [MatchRule]
|
mountChanged :: [MatchRule]
|
||||||
mountChanged = [gvfs True, gvfs False, kde, kdefallback]
|
mountChanged = [gvfs True, gvfs False, kde, kdefallback]
|
||||||
where
|
where
|
||||||
{- gvfs reliably generates this event whenever a drive is mounted/unmounted,
|
{- gvfs reliably generates this event whenever a
|
||||||
- whether automatically, or manually -}
|
- drive is mounted/unmounted, whether automatically, or manually -}
|
||||||
gvfs mount = matchAny
|
gvfs mount = matchAny
|
||||||
{ matchInterface = Just "org.gtk.Private.RemoteVolumeMonitor"
|
{ matchInterface = Just "org.gtk.Private.RemoteVolumeMonitor"
|
||||||
, matchMember = Just $ if mount then "MountAdded" else "MountRemoved"
|
, matchMember = Just $ if mount then "MountAdded" else "MountRemoved"
|
||||||
}
|
}
|
||||||
{- This event fires when KDE prompts the user what to do with a drive,
|
{- This event fires when KDE prompts the user what to do with a drive,
|
||||||
- but maybe not at other times. And it's not received -}
|
- but maybe not at other times. And it's not received -}
|
||||||
kde = matchAny
|
kde = matchAny
|
||||||
{ matchInterface = Just "org.kde.Solid.Device"
|
{ matchInterface = Just "org.kde.Solid.Device"
|
||||||
, matchMember = Just "setupDone"
|
, matchMember = Just "setupDone"
|
||||||
}
|
}
|
||||||
{- This event may not be closely related to mounting a drive, but it's
|
{- This event may not be closely related to mounting a drive, but it's
|
||||||
- observed reliably when a drive gets mounted or unmounted. -}
|
- observed reliably when a drive gets mounted or unmounted. -}
|
||||||
kdefallback = matchAny
|
kdefallback = matchAny
|
||||||
{ matchInterface = Just "org.kde.KDirNotify"
|
{ matchInterface = Just "org.kde.KDirNotify"
|
||||||
, matchMember = Just "enteredDirectory"
|
, matchMember = Just "enteredDirectory"
|
||||||
}
|
}
|
||||||
|
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
pollingThread :: Assistant ()
|
pollingThread :: Assistant ()
|
||||||
pollingThread = go =<< liftIO currentMountPoints
|
pollingThread = go =<< liftIO currentMountPoints
|
||||||
where
|
where
|
||||||
go wasmounted = do
|
go wasmounted = do
|
||||||
liftIO $ threadDelaySeconds (Seconds 10)
|
liftIO $ threadDelaySeconds (Seconds 10)
|
||||||
nowmounted <- liftIO currentMountPoints
|
nowmounted <- liftIO currentMountPoints
|
||||||
handleMounts wasmounted nowmounted
|
handleMounts wasmounted nowmounted
|
||||||
go nowmounted
|
go nowmounted
|
||||||
|
|
||||||
handleMounts :: MountPoints -> MountPoints -> Assistant ()
|
handleMounts :: MountPoints -> MountPoints -> Assistant ()
|
||||||
handleMounts wasmounted nowmounted =
|
handleMounts wasmounted nowmounted =
|
||||||
|
|
@ -179,11 +179,11 @@ remotesUnder dir = do
|
||||||
liftAnnex $ Annex.changeState $ \s -> s { Annex.remotes = rs' }
|
liftAnnex $ Annex.changeState $ \s -> s { Annex.remotes = rs' }
|
||||||
updateSyncRemotes
|
updateSyncRemotes
|
||||||
return $ map snd $ filter fst pairs
|
return $ map snd $ filter fst pairs
|
||||||
where
|
where
|
||||||
checkremote repotop r = case Remote.localpath r of
|
checkremote repotop r = case Remote.localpath r of
|
||||||
Just p | dirContains dir (absPathFrom repotop p) ->
|
Just p | dirContains dir (absPathFrom repotop p) ->
|
||||||
(,) <$> pure True <*> updateRemote r
|
(,) <$> pure True <*> updateRemote r
|
||||||
_ -> return (False, r)
|
_ -> return (False, r)
|
||||||
|
|
||||||
type MountPoints = S.Set Mntent
|
type MountPoints = S.Set Mntent
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -96,8 +96,8 @@ pairListenerThread urlrenderer = NamedThread "PairListener" $ do
|
||||||
if n < chunksz
|
if n < chunksz
|
||||||
then return $ c ++ msg
|
then return $ c ++ msg
|
||||||
else getmsg sock $ c ++ msg
|
else getmsg sock $ c ++ msg
|
||||||
where
|
where
|
||||||
chunksz = 1024
|
chunksz = 1024
|
||||||
|
|
||||||
{- Show an alert when a PairReq is seen. -}
|
{- Show an alert when a PairReq is seen. -}
|
||||||
pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
|
pairReqReceived :: Bool -> UrlRenderer -> PairMsg -> Assistant ()
|
||||||
|
|
|
||||||
|
|
@ -34,8 +34,8 @@ pushRetryThread = NamedThread "PushRetrier" $ runEvery (Seconds halfhour) <~> do
|
||||||
void $ alertWhile (pushRetryAlert topush) $ do
|
void $ alertWhile (pushRetryAlert topush) $ do
|
||||||
now <- liftIO $ getCurrentTime
|
now <- liftIO $ getCurrentTime
|
||||||
pushToRemotes now True topush
|
pushToRemotes now True topush
|
||||||
where
|
where
|
||||||
halfhour = 1800
|
halfhour = 1800
|
||||||
|
|
||||||
{- This thread pushes git commits out to remotes soon after they are made. -}
|
{- This thread pushes git commits out to remotes soon after they are made. -}
|
||||||
pushThread :: NamedThread
|
pushThread :: NamedThread
|
||||||
|
|
|
||||||
|
|
@ -76,10 +76,10 @@ onModify file = do
|
||||||
case parseTransferFile file of
|
case parseTransferFile file of
|
||||||
Nothing -> noop
|
Nothing -> noop
|
||||||
Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
|
Just t -> go t =<< liftIO (readTransferInfoFile Nothing file)
|
||||||
where
|
where
|
||||||
go _ Nothing = noop
|
go _ Nothing = noop
|
||||||
go t (Just newinfo) = alterTransferInfo t $
|
go t (Just newinfo) = alterTransferInfo t $
|
||||||
\i -> i { bytesComplete = bytesComplete newinfo }
|
\i -> i { bytesComplete = bytesComplete newinfo }
|
||||||
|
|
||||||
{- This thread can only watch transfer sizes when the DirWatcher supports
|
{- This thread can only watch transfer sizes when the DirWatcher supports
|
||||||
- tracking modificatons to files. -}
|
- tracking modificatons to files. -}
|
||||||
|
|
|
||||||
|
|
@ -104,5 +104,5 @@ shouldTransfer t info
|
||||||
notElem (Remote.uuid remote)
|
notElem (Remote.uuid remote)
|
||||||
<$> loggedLocations key
|
<$> loggedLocations key
|
||||||
| otherwise = return False
|
| otherwise = return False
|
||||||
where
|
where
|
||||||
key = transferKey t
|
key = transferKey t
|
||||||
|
|
|
||||||
|
|
@ -54,20 +54,20 @@ runTransferThread (Just (t, info, a)) = do
|
||||||
|
|
||||||
runTransferThread' :: AssistantData -> IO () -> IO ()
|
runTransferThread' :: AssistantData -> IO () -> IO ()
|
||||||
runTransferThread' d a = go
|
runTransferThread' d a = go
|
||||||
where
|
where
|
||||||
go = catchPauseResume a
|
go = catchPauseResume a
|
||||||
pause = catchPauseResume $ runEvery (Seconds 86400) noop
|
pause = catchPauseResume $ runEvery (Seconds 86400) noop
|
||||||
{- Note: This must use E.try, rather than E.catch.
|
{- Note: This must use E.try, rather than E.catch.
|
||||||
- When E.catch is used, and has called go in its exception
|
- When E.catch is used, and has called go in its exception
|
||||||
- handler, Control.Concurrent.throwTo will block sometimes
|
- handler, Control.Concurrent.throwTo will block sometimes
|
||||||
- when signaling. Using E.try avoids the problem. -}
|
- when signaling. Using E.try avoids the problem. -}
|
||||||
catchPauseResume a' = do
|
catchPauseResume a' = do
|
||||||
r <- E.try a' :: IO (Either E.SomeException ())
|
r <- E.try a' :: IO (Either E.SomeException ())
|
||||||
case r of
|
case r of
|
||||||
Left e -> case E.fromException e of
|
Left e -> case E.fromException e of
|
||||||
Just PauseTransfer -> pause
|
Just PauseTransfer -> pause
|
||||||
Just ResumeTransfer -> go
|
Just ResumeTransfer -> go
|
||||||
_ -> done
|
|
||||||
_ -> done
|
_ -> done
|
||||||
done = flip runAssistant d $
|
_ -> done
|
||||||
flip MSemN.signal 1 <<~ transferSlots
|
done = flip runAssistant d $
|
||||||
|
flip MSemN.signal 1 <<~ transferSlots
|
||||||
|
|
|
||||||
|
|
@ -61,8 +61,8 @@ bootstrap navbaritem content = do
|
||||||
addScript $ StaticR js_bootstrap_modal_js
|
addScript $ StaticR js_bootstrap_modal_js
|
||||||
$(widgetFile "page")
|
$(widgetFile "page")
|
||||||
hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap")
|
hamletToRepHtml $(hamletFile $ hamletTemplate "bootstrap")
|
||||||
where
|
where
|
||||||
navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
|
navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
|
||||||
|
|
||||||
newWebAppState :: IO (TMVar WebAppState)
|
newWebAppState :: IO (TMVar WebAppState)
|
||||||
newWebAppState = do
|
newWebAppState = do
|
||||||
|
|
@ -79,10 +79,10 @@ getWebAppState = liftIO . atomically . readTMVar =<< webAppState <$> getYesod
|
||||||
|
|
||||||
modifyWebAppState :: forall sub. (WebAppState -> WebAppState) -> GHandler sub WebApp ()
|
modifyWebAppState :: forall sub. (WebAppState -> WebAppState) -> GHandler sub WebApp ()
|
||||||
modifyWebAppState a = go =<< webAppState <$> getYesod
|
modifyWebAppState a = go =<< webAppState <$> getYesod
|
||||||
where
|
where
|
||||||
go s = liftIO $ atomically $ do
|
go s = liftIO $ atomically $ do
|
||||||
v <- takeTMVar s
|
v <- takeTMVar s
|
||||||
putTMVar s $ a v
|
putTMVar s $ a v
|
||||||
|
|
||||||
{- Runs an Annex action from the webapp.
|
{- Runs an Annex action from the webapp.
|
||||||
-
|
-
|
||||||
|
|
|
||||||
|
|
@ -96,40 +96,40 @@ repoList :: Bool -> Bool -> Handler [(String, String, Actions)]
|
||||||
repoList onlyconfigured includehere
|
repoList onlyconfigured includehere
|
||||||
| onlyconfigured = list =<< configured
|
| onlyconfigured = list =<< configured
|
||||||
| otherwise = list =<< (++) <$> configured <*> rest
|
| otherwise = list =<< (++) <$> configured <*> rest
|
||||||
where
|
where
|
||||||
configured = do
|
configured = do
|
||||||
rs <- filter (not . Remote.readonly) . syncRemotes
|
rs <- filter (not . Remote.readonly) . syncRemotes
|
||||||
<$> liftAssistant getDaemonStatus
|
<$> liftAssistant getDaemonStatus
|
||||||
runAnnex [] $ do
|
runAnnex [] $ do
|
||||||
u <- getUUID
|
u <- getUUID
|
||||||
let l = map Remote.uuid rs
|
let l = map Remote.uuid rs
|
||||||
let l' = if includehere then u : l else l
|
let l' = if includehere then u : l else l
|
||||||
return $ zip l' $ map mkSyncingRepoActions l'
|
return $ zip l' $ map mkSyncingRepoActions l'
|
||||||
rest = runAnnex [] $ do
|
rest = runAnnex [] $ do
|
||||||
m <- readRemoteLog
|
m <- readRemoteLog
|
||||||
unconfigured <- catMaybes . map (findtype m) . snd
|
unconfigured <- catMaybes . map (findtype m) . snd
|
||||||
<$> (trustPartition DeadTrusted $ M.keys m)
|
<$> (trustPartition DeadTrusted $ M.keys m)
|
||||||
unsyncable <- map Remote.uuid <$>
|
unsyncable <- map Remote.uuid <$>
|
||||||
(filterM (\r -> not <$> repoSyncable (Remote.repo r))
|
(filterM (\r -> not <$> repoSyncable (Remote.repo r))
|
||||||
=<< Remote.enabledRemoteList)
|
=<< Remote.enabledRemoteList)
|
||||||
return $ zip unsyncable (map mkNotSyncingRepoActions unsyncable) ++ unconfigured
|
return $ zip unsyncable (map mkNotSyncingRepoActions unsyncable) ++ unconfigured
|
||||||
findtype m u = case M.lookup u m of
|
findtype m u = case M.lookup u m of
|
||||||
Nothing -> Nothing
|
Nothing -> Nothing
|
||||||
Just c -> case M.lookup "type" c of
|
Just c -> case M.lookup "type" c of
|
||||||
Just "rsync" -> u `enableswith` EnableRsyncR
|
Just "rsync" -> u `enableswith` EnableRsyncR
|
||||||
Just "directory" -> u `enableswith` EnableDirectoryR
|
Just "directory" -> u `enableswith` EnableDirectoryR
|
||||||
#ifdef WITH_S3
|
#ifdef WITH_S3
|
||||||
Just "S3" -> u `enableswith` EnableS3R
|
Just "S3" -> u `enableswith` EnableS3R
|
||||||
#endif
|
#endif
|
||||||
_ -> Nothing
|
_ -> Nothing
|
||||||
u `enableswith` r = Just (u, DisabledRepoActions $ r u)
|
u `enableswith` r = Just (u, DisabledRepoActions $ r u)
|
||||||
list l = runAnnex [] $ do
|
list l = runAnnex [] $ do
|
||||||
let l' = nubBy (\x y -> fst x == fst y) l
|
let l' = nubBy (\x y -> fst x == fst y) l
|
||||||
zip3
|
zip3
|
||||||
<$> pure counter
|
<$> pure counter
|
||||||
<*> Remote.prettyListUUIDs (map fst l')
|
<*> Remote.prettyListUUIDs (map fst l')
|
||||||
<*> pure (map snd l')
|
<*> pure (map snd l')
|
||||||
counter = map show ([1..] :: [Int])
|
counter = map show ([1..] :: [Int])
|
||||||
|
|
||||||
getEnableSyncR :: UUID -> Handler ()
|
getEnableSyncR :: UUID -> Handler ()
|
||||||
getEnableSyncR = flipSync True
|
getEnableSyncR = flipSync True
|
||||||
|
|
|
||||||
|
|
@ -51,12 +51,12 @@ getRepoConfig uuid r mremote = RepoConfig
|
||||||
<*> (maybe Nothing (Just . T.pack) . M.lookup uuid <$> uuidMap)
|
<*> (maybe Nothing (Just . T.pack) . M.lookup uuid <$> uuidMap)
|
||||||
<*> getrepogroup
|
<*> getrepogroup
|
||||||
<*> Config.repoSyncable r
|
<*> Config.repoSyncable r
|
||||||
where
|
where
|
||||||
getrepogroup = do
|
getrepogroup = do
|
||||||
groups <- lookupGroups uuid
|
groups <- lookupGroups uuid
|
||||||
return $
|
return $
|
||||||
maybe (RepoGroupCustom $ unwords $ S.toList groups) RepoGroupStandard
|
maybe (RepoGroupCustom $ unwords $ S.toList groups) RepoGroupStandard
|
||||||
(getStandardGroup groups)
|
(getStandardGroup groups)
|
||||||
|
|
||||||
setRepoConfig :: UUID -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler ()
|
setRepoConfig :: UUID -> Maybe Remote -> RepoConfig -> RepoConfig -> Handler ()
|
||||||
setRepoConfig uuid mremote oldc newc = do
|
setRepoConfig uuid mremote oldc newc = do
|
||||||
|
|
@ -86,14 +86,14 @@ editRepositoryAForm def = RepoConfig
|
||||||
<*> aopt textField "Description" (Just $ repoDescription def)
|
<*> aopt textField "Description" (Just $ repoDescription def)
|
||||||
<*> areq (selectFieldList $ customgroups++standardgroups) "Repository group" (Just $ repoGroup def)
|
<*> areq (selectFieldList $ customgroups++standardgroups) "Repository group" (Just $ repoGroup def)
|
||||||
<*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def)
|
<*> areq checkBoxField "Syncing enabled" (Just $ repoSyncable def)
|
||||||
where
|
where
|
||||||
standardgroups :: [(Text, RepoGroup)]
|
standardgroups :: [(Text, RepoGroup)]
|
||||||
standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g))
|
standardgroups = map (\g -> (T.pack $ descStandardGroup g , RepoGroupStandard g))
|
||||||
[minBound :: StandardGroup .. maxBound :: StandardGroup]
|
[minBound :: StandardGroup .. maxBound :: StandardGroup]
|
||||||
customgroups :: [(Text, RepoGroup)]
|
customgroups :: [(Text, RepoGroup)]
|
||||||
customgroups = case repoGroup def of
|
customgroups = case repoGroup def of
|
||||||
RepoGroupCustom s -> [(T.pack s, RepoGroupCustom s)]
|
RepoGroupCustom s -> [(T.pack s, RepoGroupCustom s)]
|
||||||
_ -> []
|
_ -> []
|
||||||
|
|
||||||
getEditRepositoryR :: UUID -> Handler RepHtml
|
getEditRepositoryR :: UUID -> Handler RepHtml
|
||||||
getEditRepositoryR = editForm False
|
getEditRepositoryR = editForm False
|
||||||
|
|
@ -118,8 +118,8 @@ editForm new uuid = bootstrap (Just Config) $ do
|
||||||
setRepoConfig uuid mremote curr input
|
setRepoConfig uuid mremote curr input
|
||||||
redirect RepositoriesR
|
redirect RepositoriesR
|
||||||
_ -> showform form enctype curr
|
_ -> showform form enctype curr
|
||||||
where
|
where
|
||||||
showform form enctype curr = do
|
showform form enctype curr = do
|
||||||
let istransfer = repoGroup curr == RepoGroupStandard TransferGroup
|
let istransfer = repoGroup curr == RepoGroupStandard TransferGroup
|
||||||
let authtoken = webAppFormAuthToken
|
let authtoken = webAppFormAuthToken
|
||||||
$(widgetFile "configurators/editrepository")
|
$(widgetFile "configurators/editrepository")
|
||||||
|
|
|
||||||
|
|
@ -50,17 +50,17 @@ data RepositoryPath = RepositoryPath Text
|
||||||
- to use as a repository. -}
|
- to use as a repository. -}
|
||||||
repositoryPathField :: forall sub. Bool -> Field sub WebApp Text
|
repositoryPathField :: forall sub. Bool -> Field sub WebApp Text
|
||||||
repositoryPathField autofocus = Field { fieldParse = parse, fieldView = view }
|
repositoryPathField autofocus = Field { fieldParse = parse, fieldView = view }
|
||||||
where
|
where
|
||||||
view idAttr nameAttr attrs val isReq =
|
view idAttr nameAttr attrs val isReq =
|
||||||
[whamlet|<input type="text" *{attrs} id="#{idAttr}" name="#{nameAttr}" :isReq:required :autofocus:autofocus value="#{either id id val}">|]
|
[whamlet|<input type="text" *{attrs} id="#{idAttr}" name="#{nameAttr}" :isReq:required :autofocus:autofocus value="#{either id id val}">|]
|
||||||
|
|
||||||
parse [path]
|
parse [path]
|
||||||
| T.null path = nopath
|
| T.null path = nopath
|
||||||
| otherwise = liftIO $ checkRepositoryPath path
|
| otherwise = liftIO $ checkRepositoryPath path
|
||||||
parse [] = return $ Right Nothing
|
parse [] = return $ Right Nothing
|
||||||
parse _ = nopath
|
parse _ = nopath
|
||||||
|
|
||||||
nopath = return $ Left "Enter a location for the repository"
|
nopath = return $ Left "Enter a location for the repository"
|
||||||
|
|
||||||
{- As well as checking the path for a lot of silly things, tilde is
|
{- As well as checking the path for a lot of silly things, tilde is
|
||||||
- expanded in the returned path. -}
|
- expanded in the returned path. -}
|
||||||
|
|
@ -83,14 +83,10 @@ checkRepositoryPath p = do
|
||||||
case headMaybe problems of
|
case headMaybe problems of
|
||||||
Nothing -> Right $ Just $ T.pack basepath
|
Nothing -> Right $ Just $ T.pack basepath
|
||||||
Just prob -> Left prob
|
Just prob -> Left prob
|
||||||
where
|
where
|
||||||
runcheck (chk, msg) = ifM (chk)
|
runcheck (chk, msg) = ifM (chk) ( return $ Just msg, return Nothing )
|
||||||
( return $ Just msg
|
expandTilde home ('~':'/':path) = home </> path
|
||||||
, return Nothing
|
expandTilde _ path = path
|
||||||
)
|
|
||||||
expandTilde home ('~':'/':path) = home </> path
|
|
||||||
expandTilde _ path = path
|
|
||||||
|
|
||||||
|
|
||||||
{- On first run, if run in the home directory, default to putting it in
|
{- On first run, if run in the home directory, default to putting it in
|
||||||
- ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise.
|
- ~/Desktop/annex, when a Desktop directory exists, and ~/annex otherwise.
|
||||||
|
|
@ -104,13 +100,13 @@ defaultRepositoryPath firstrun = do
|
||||||
if home == cwd && firstrun
|
if home == cwd && firstrun
|
||||||
then inhome
|
then inhome
|
||||||
else ifM (canWrite cwd) ( return cwd, inhome )
|
else ifM (canWrite cwd) ( return cwd, inhome )
|
||||||
where
|
where
|
||||||
inhome = do
|
inhome = do
|
||||||
desktop <- userDesktopDir
|
desktop <- userDesktopDir
|
||||||
ifM (doesDirectoryExist desktop)
|
ifM (doesDirectoryExist desktop)
|
||||||
( relHome $ desktop </> gitAnnexAssistantDefaultDir
|
( relHome $ desktop </> gitAnnexAssistantDefaultDir
|
||||||
, return $ "~" </> gitAnnexAssistantDefaultDir
|
, return $ "~" </> gitAnnexAssistantDefaultDir
|
||||||
)
|
)
|
||||||
|
|
||||||
newRepositoryForm :: FilePath -> Form RepositoryPath
|
newRepositoryForm :: FilePath -> Form RepositoryPath
|
||||||
newRepositoryForm defpath msg = do
|
newRepositoryForm defpath msg = do
|
||||||
|
|
@ -164,17 +160,17 @@ selectDriveForm :: [RemovableDrive] -> Maybe RemovableDrive -> Form RemovableDri
|
||||||
selectDriveForm drives def = renderBootstrap $ RemovableDrive
|
selectDriveForm drives def = renderBootstrap $ RemovableDrive
|
||||||
<$> pure Nothing
|
<$> pure Nothing
|
||||||
<*> areq (selectFieldList pairs) "Select drive:" (mountPoint <$> def)
|
<*> areq (selectFieldList pairs) "Select drive:" (mountPoint <$> def)
|
||||||
where
|
where
|
||||||
pairs = zip (map describe drives) (map mountPoint drives)
|
pairs = zip (map describe drives) (map mountPoint drives)
|
||||||
describe drive = case diskFree drive of
|
describe drive = case diskFree drive of
|
||||||
Nothing -> mountPoint drive
|
Nothing -> mountPoint drive
|
||||||
Just free ->
|
Just free ->
|
||||||
let sz = roughSize storageUnits True free
|
let sz = roughSize storageUnits True free
|
||||||
in T.unwords
|
in T.unwords
|
||||||
[ mountPoint drive
|
[ mountPoint drive
|
||||||
, T.concat ["(", T.pack sz]
|
, T.concat ["(", T.pack sz]
|
||||||
, "free)"
|
, "free)"
|
||||||
]
|
]
|
||||||
|
|
||||||
{- Adding a removable drive. -}
|
{- Adding a removable drive. -}
|
||||||
getAddDriveR :: Handler RepHtml
|
getAddDriveR :: Handler RepHtml
|
||||||
|
|
@ -192,33 +188,32 @@ getAddDriveR = bootstrap (Just Config) $ do
|
||||||
_ -> do
|
_ -> do
|
||||||
let authtoken = webAppFormAuthToken
|
let authtoken = webAppFormAuthToken
|
||||||
$(widgetFile "configurators/adddrive")
|
$(widgetFile "configurators/adddrive")
|
||||||
where
|
where
|
||||||
make mountpoint = do
|
make mountpoint = do
|
||||||
liftIO $ makerepo dir
|
liftIO $ makerepo dir
|
||||||
u <- liftIO $ initRepo dir $ Just remotename
|
u <- liftIO $ initRepo dir $ Just remotename
|
||||||
r <- addremote dir remotename
|
r <- addremote dir remotename
|
||||||
runAnnex () $ setStandardGroup u TransferGroup
|
runAnnex () $ setStandardGroup u TransferGroup
|
||||||
syncRemote r
|
syncRemote r
|
||||||
return u
|
return u
|
||||||
where
|
where
|
||||||
dir = mountpoint </> gitAnnexAssistantDefaultDir
|
dir = mountpoint </> gitAnnexAssistantDefaultDir
|
||||||
remotename = takeFileName mountpoint
|
remotename = takeFileName mountpoint
|
||||||
{- The repo may already exist, when adding removable media
|
{- The repo may already exist, when adding removable media
|
||||||
- that has already been used elsewhere. -}
|
- that has already been used elsewhere. -}
|
||||||
makerepo dir = liftIO $ do
|
makerepo dir = liftIO $ do
|
||||||
r <- E.try (inDir dir $ return True) :: IO (Either E.SomeException Bool)
|
r <- E.try (inDir dir $ return True) :: IO (Either E.SomeException Bool)
|
||||||
case r of
|
case r of
|
||||||
Right _ -> noop
|
Right _ -> noop
|
||||||
Left _e -> do
|
Left _e -> do
|
||||||
createDirectoryIfMissing True dir
|
createDirectoryIfMissing True dir
|
||||||
makeRepo dir True
|
makeRepo dir True
|
||||||
{- Each repository is made a remote of the other. -}
|
{- Each repository is made a remote of the other. -}
|
||||||
addremote dir name = runAnnex undefined $ do
|
addremote dir name = runAnnex undefined $ do
|
||||||
hostname <- maybe "host" id <$> liftIO getHostname
|
hostname <- maybe "host" id <$> liftIO getHostname
|
||||||
hostlocation <- fromRepo Git.repoLocation
|
hostlocation <- fromRepo Git.repoLocation
|
||||||
liftIO $ inDir dir $
|
liftIO $ inDir dir $ void $ makeGitRemote hostname hostlocation
|
||||||
void $ makeGitRemote hostname hostlocation
|
addRemote $ makeGitRemote name dir
|
||||||
addRemote $ makeGitRemote name dir
|
|
||||||
|
|
||||||
getEnableDirectoryR :: UUID -> Handler RepHtml
|
getEnableDirectoryR :: UUID -> Handler RepHtml
|
||||||
getEnableDirectoryR uuid = bootstrap (Just Config) $ do
|
getEnableDirectoryR uuid = bootstrap (Just Config) $ do
|
||||||
|
|
@ -231,23 +226,23 @@ getEnableDirectoryR uuid = bootstrap (Just Config) $ do
|
||||||
{- List of removable drives. -}
|
{- List of removable drives. -}
|
||||||
driveList :: IO [RemovableDrive]
|
driveList :: IO [RemovableDrive]
|
||||||
driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts
|
driveList = mapM (gen . mnt_dir) =<< filter sane <$> getMounts
|
||||||
where
|
where
|
||||||
gen dir = RemovableDrive
|
gen dir = RemovableDrive
|
||||||
<$> getDiskFree dir
|
<$> getDiskFree dir
|
||||||
<*> pure (T.pack dir)
|
<*> pure (T.pack dir)
|
||||||
-- filter out some things that are surely not removable drives
|
-- filter out some things that are surely not removable drives
|
||||||
sane Mntent { mnt_dir = dir, mnt_fsname = dev }
|
sane Mntent { mnt_dir = dir, mnt_fsname = dev }
|
||||||
{- We want real disks like /dev/foo, not
|
{- We want real disks like /dev/foo, not
|
||||||
- dummy mount points like proc or tmpfs or
|
- dummy mount points like proc or tmpfs or
|
||||||
- gvfs-fuse-daemon. -}
|
- gvfs-fuse-daemon. -}
|
||||||
| not ('/' `elem` dev) = False
|
| not ('/' `elem` dev) = False
|
||||||
{- Just in case: These mount points are surely not
|
{- Just in case: These mount points are surely not
|
||||||
- removable disks. -}
|
- removable disks. -}
|
||||||
| dir == "/" = False
|
| dir == "/" = False
|
||||||
| dir == "/tmp" = False
|
| dir == "/tmp" = False
|
||||||
| dir == "/run/shm" = False
|
| dir == "/run/shm" = False
|
||||||
| dir == "/run/lock" = False
|
| dir == "/run/lock" = False
|
||||||
| otherwise = True
|
| otherwise = True
|
||||||
|
|
||||||
{- Bootstraps from first run mode to a fully running assistant in a
|
{- Bootstraps from first run mode to a fully running assistant in a
|
||||||
- repository, by running the postFirstRun callback, which returns the
|
- repository, by running the postFirstRun callback, which returns the
|
||||||
|
|
@ -270,11 +265,11 @@ makeRepo :: FilePath -> Bool -> IO ()
|
||||||
makeRepo path bare = do
|
makeRepo path bare = do
|
||||||
unlessM (boolSystem "git" params) $
|
unlessM (boolSystem "git" params) $
|
||||||
error "git init failed!"
|
error "git init failed!"
|
||||||
where
|
where
|
||||||
baseparams = [Param "init", Param "--quiet"]
|
baseparams = [Param "init", Param "--quiet"]
|
||||||
params
|
params
|
||||||
| bare = baseparams ++ [Param "--bare", File path]
|
| bare = baseparams ++ [Param "--bare", File path]
|
||||||
| otherwise = baseparams ++ [File path]
|
| otherwise = baseparams ++ [File path]
|
||||||
|
|
||||||
{- Runs an action in the git-annex repository in the specified directory. -}
|
{- Runs an action in the git-annex repository in the specified directory. -}
|
||||||
inDir :: FilePath -> Annex a -> IO a
|
inDir :: FilePath -> Annex a -> IO a
|
||||||
|
|
@ -320,9 +315,9 @@ canMakeSymlink dir = ifM (doesDirectoryExist dir)
|
||||||
( catchBoolIO $ test dir
|
( catchBoolIO $ test dir
|
||||||
, canMakeSymlink (parentDir dir)
|
, canMakeSymlink (parentDir dir)
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
test d = do
|
test d = do
|
||||||
let link = d </> "delete.me"
|
let link = d </> "delete.me"
|
||||||
createSymbolicLink link link
|
createSymbolicLink link link
|
||||||
removeLink link
|
removeLink link
|
||||||
return True
|
return True
|
||||||
|
|
|
||||||
|
|
@ -55,12 +55,12 @@ getFinishPairR :: PairMsg -> Handler RepHtml
|
||||||
getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
|
getFinishPairR msg = promptSecret (Just msg) $ \_ secret -> do
|
||||||
liftIO $ setup
|
liftIO $ setup
|
||||||
startPairing PairAck cleanup alert uuid "" secret
|
startPairing PairAck cleanup alert uuid "" secret
|
||||||
where
|
where
|
||||||
alert = pairRequestAcknowledgedAlert (pairRepo msg) . Just
|
alert = pairRequestAcknowledgedAlert (pairRepo msg) . Just
|
||||||
setup = setupAuthorizedKeys msg
|
setup = setupAuthorizedKeys msg
|
||||||
cleanup = removeAuthorizedKeys False $
|
cleanup = removeAuthorizedKeys False $
|
||||||
remoteSshPubKey $ pairMsgData msg
|
remoteSshPubKey $ pairMsgData msg
|
||||||
uuid = Just $ pairUUID $ pairMsgData msg
|
uuid = Just $ pairUUID $ pairMsgData msg
|
||||||
#else
|
#else
|
||||||
getFinishPairR _ = noPairing
|
getFinishPairR _ = noPairing
|
||||||
#endif
|
#endif
|
||||||
|
|
@ -107,27 +107,27 @@ startPairing stage oncancel alert muuid displaysecret secret = do
|
||||||
void $ liftIO $ forkIO thread
|
void $ liftIO $ forkIO thread
|
||||||
|
|
||||||
lift $ redirect $ InprogressPairR $ toSecretReminder displaysecret
|
lift $ redirect $ InprogressPairR $ toSecretReminder displaysecret
|
||||||
where
|
where
|
||||||
{- Sends pairing messages until the thread is killed,
|
{- Sends pairing messages until the thread is killed,
|
||||||
- and shows an activity alert while doing it.
|
- and shows an activity alert while doing it.
|
||||||
-
|
-
|
||||||
- The cancel button returns the user to the HomeR. This is
|
- The cancel button returns the user to the HomeR. This is
|
||||||
- not ideal, but they have to be sent somewhere, and could
|
- not ideal, but they have to be sent somewhere, and could
|
||||||
- have been on a page specific to the in-process pairing
|
- have been on a page specific to the in-process pairing
|
||||||
- that just stopped, so can't go back there.
|
- that just stopped, so can't go back there.
|
||||||
-}
|
-}
|
||||||
mksendrequests urlrender sender _stage = do
|
mksendrequests urlrender sender _stage = do
|
||||||
tid <- liftIO myThreadId
|
tid <- liftIO myThreadId
|
||||||
let selfdestruct = AlertButton
|
let selfdestruct = AlertButton
|
||||||
{ buttonLabel = "Cancel"
|
{ buttonLabel = "Cancel"
|
||||||
, buttonUrl = urlrender HomeR
|
, buttonUrl = urlrender HomeR
|
||||||
, buttonAction = Just $ const $ do
|
, buttonAction = Just $ const $ do
|
||||||
oncancel
|
oncancel
|
||||||
killThread tid
|
killThread tid
|
||||||
}
|
}
|
||||||
alertDuring (alert selfdestruct) $ liftIO $ do
|
alertDuring (alert selfdestruct) $ liftIO $ do
|
||||||
_ <- E.try (sender stage) :: IO (Either E.SomeException ())
|
_ <- E.try (sender stage) :: IO (Either E.SomeException ())
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
data InputSecret = InputSecret { secretText :: Maybe Text }
|
data InputSecret = InputSecret { secretText :: Maybe Text }
|
||||||
|
|
||||||
|
|
@ -153,18 +153,18 @@ promptSecret msg cont = pairPage $ do
|
||||||
else showform form enctype $ Just
|
else showform form enctype $ Just
|
||||||
"That's not the right secret phrase."
|
"That's not the right secret phrase."
|
||||||
_ -> showform form enctype Nothing
|
_ -> showform form enctype Nothing
|
||||||
where
|
where
|
||||||
showform form enctype mproblem = do
|
showform form enctype mproblem = do
|
||||||
let start = isNothing msg
|
let start = isNothing msg
|
||||||
let badphrase = isJust mproblem
|
let badphrase = isJust mproblem
|
||||||
let problem = fromMaybe "" mproblem
|
let problem = fromMaybe "" mproblem
|
||||||
let (username, hostname) = maybe ("", "")
|
let (username, hostname) = maybe ("", "")
|
||||||
(\(_, v, a) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr a) (remoteHostName v)))
|
(\(_, v, a) -> (T.pack $ remoteUserName v, T.pack $ fromMaybe (showAddr a) (remoteHostName v)))
|
||||||
(verifiableVal . fromPairMsg <$> msg)
|
(verifiableVal . fromPairMsg <$> msg)
|
||||||
u <- T.pack <$> liftIO myUserName
|
u <- T.pack <$> liftIO myUserName
|
||||||
let sameusername = username == u
|
let sameusername = username == u
|
||||||
let authtoken = webAppFormAuthToken
|
let authtoken = webAppFormAuthToken
|
||||||
$(widgetFile "configurators/pairing/prompt")
|
$(widgetFile "configurators/pairing/prompt")
|
||||||
|
|
||||||
{- This counts unicode characters as more than one character,
|
{- This counts unicode characters as more than one character,
|
||||||
- but that's ok; they *do* provide additional entropy. -}
|
- but that's ok; they *do* provide additional entropy. -}
|
||||||
|
|
|
||||||
|
|
@ -62,12 +62,12 @@ s3InputAForm = S3Input
|
||||||
<*> areq textField "Datacenter" (Just "US")
|
<*> areq textField "Datacenter" (Just "US")
|
||||||
<*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy)
|
<*> areq (selectFieldList storageclasses) "Storage class" (Just StandardRedundancy)
|
||||||
<*> areq textField "Repository name" (Just "S3")
|
<*> areq textField "Repository name" (Just "S3")
|
||||||
where
|
where
|
||||||
storageclasses :: [(Text, StorageClass)]
|
storageclasses :: [(Text, StorageClass)]
|
||||||
storageclasses =
|
storageclasses =
|
||||||
[ ("Standard redundancy", StandardRedundancy)
|
[ ("Standard redundancy", StandardRedundancy)
|
||||||
, ("Reduced redundancy (costs less)", ReducedRedundancy)
|
, ("Reduced redundancy (costs less)", ReducedRedundancy)
|
||||||
]
|
]
|
||||||
|
|
||||||
s3CredsAForm :: AForm WebApp WebApp S3Creds
|
s3CredsAForm :: AForm WebApp WebApp S3Creds
|
||||||
s3CredsAForm = S3Creds
|
s3CredsAForm = S3Creds
|
||||||
|
|
@ -88,12 +88,12 @@ getAddS3R = s3Configurator $ do
|
||||||
, ("storageclass", show $ storageClass s3input)
|
, ("storageclass", show $ storageClass s3input)
|
||||||
]
|
]
|
||||||
_ -> showform form enctype
|
_ -> showform form enctype
|
||||||
where
|
where
|
||||||
showform form enctype = do
|
showform form enctype = do
|
||||||
let authtoken = webAppFormAuthToken
|
let authtoken = webAppFormAuthToken
|
||||||
$(widgetFile "configurators/adds3")
|
$(widgetFile "configurators/adds3")
|
||||||
setgroup r = runAnnex () $
|
setgroup r = runAnnex () $
|
||||||
setStandardGroup (Remote.uuid r) TransferGroup
|
setStandardGroup (Remote.uuid r) TransferGroup
|
||||||
|
|
||||||
getEnableS3R :: UUID -> Handler RepHtml
|
getEnableS3R :: UUID -> Handler RepHtml
|
||||||
getEnableS3R uuid = s3Configurator $ do
|
getEnableS3R uuid = s3Configurator $ do
|
||||||
|
|
@ -106,12 +106,12 @@ getEnableS3R uuid = s3Configurator $ do
|
||||||
fromJust $ M.lookup uuid m
|
fromJust $ M.lookup uuid m
|
||||||
makeS3Remote s3creds name (const noop) M.empty
|
makeS3Remote s3creds name (const noop) M.empty
|
||||||
_ -> showform form enctype
|
_ -> showform form enctype
|
||||||
where
|
where
|
||||||
showform form enctype = do
|
showform form enctype = do
|
||||||
let authtoken = webAppFormAuthToken
|
let authtoken = webAppFormAuthToken
|
||||||
description <- lift $ runAnnex "" $
|
description <- lift $ runAnnex "" $
|
||||||
T.pack . concat <$> Remote.prettyListUUIDs [uuid]
|
T.pack . concat <$> Remote.prettyListUUIDs [uuid]
|
||||||
$(widgetFile "configurators/enables3")
|
$(widgetFile "configurators/enables3")
|
||||||
|
|
||||||
makeS3Remote :: S3Creds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
|
makeS3Remote :: S3Creds -> String -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
|
||||||
makeS3Remote (S3Creds ak sk) name setup config = do
|
makeS3Remote (S3Creds ak sk) name setup config = do
|
||||||
|
|
|
||||||
|
|
@ -61,25 +61,25 @@ sshInputAForm def = SshInput
|
||||||
<$> aopt check_hostname "Host name" (Just $ hostname def)
|
<$> aopt check_hostname "Host name" (Just $ hostname def)
|
||||||
<*> aopt check_username "User name" (Just $ username def)
|
<*> aopt check_username "User name" (Just $ username def)
|
||||||
<*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ directory def)
|
<*> aopt textField "Directory" (Just $ Just $ fromMaybe (T.pack gitAnnexAssistantDefaultDir) $ directory def)
|
||||||
where
|
where
|
||||||
check_hostname = checkM (liftIO . checkdns) textField
|
check_hostname = checkM (liftIO . checkdns) textField
|
||||||
checkdns t = do
|
checkdns t = do
|
||||||
let h = T.unpack t
|
let h = T.unpack t
|
||||||
r <- catchMaybeIO $ getAddrInfo canonname (Just h) Nothing
|
r <- catchMaybeIO $ getAddrInfo canonname (Just h) Nothing
|
||||||
return $ case catMaybes . map addrCanonName <$> r of
|
return $ case catMaybes . map addrCanonName <$> r of
|
||||||
-- canonicalize input hostname if it had no dot
|
-- canonicalize input hostname if it had no dot
|
||||||
Just (fullname:_)
|
Just (fullname:_)
|
||||||
| '.' `elem` h -> Right t
|
| '.' `elem` h -> Right t
|
||||||
| otherwise -> Right $ T.pack fullname
|
| otherwise -> Right $ T.pack fullname
|
||||||
Just [] -> Right t
|
Just [] -> Right t
|
||||||
Nothing -> Left bad_hostname
|
Nothing -> Left bad_hostname
|
||||||
canonname = Just $ defaultHints { addrFlags = [AI_CANONNAME] }
|
canonname = Just $ defaultHints { addrFlags = [AI_CANONNAME] }
|
||||||
|
|
||||||
check_username = checkBool (all (`notElem` "/:@ \t") . T.unpack)
|
check_username = checkBool (all (`notElem` "/:@ \t") . T.unpack)
|
||||||
bad_username textField
|
bad_username textField
|
||||||
|
|
||||||
bad_hostname = "cannot resolve host name" :: Text
|
bad_hostname = "cannot resolve host name" :: Text
|
||||||
bad_username = "bad user name" :: Text
|
bad_username = "bad user name" :: Text
|
||||||
|
|
||||||
data ServerStatus
|
data ServerStatus
|
||||||
= UntestedServer
|
= UntestedServer
|
||||||
|
|
@ -107,10 +107,10 @@ getAddSshR = sshConfigurator $ do
|
||||||
Left status -> showform form enctype status
|
Left status -> showform form enctype status
|
||||||
Right sshdata -> lift $ redirect $ ConfirmSshR sshdata
|
Right sshdata -> lift $ redirect $ ConfirmSshR sshdata
|
||||||
_ -> showform form enctype UntestedServer
|
_ -> showform form enctype UntestedServer
|
||||||
where
|
where
|
||||||
showform form enctype status = do
|
showform form enctype status = do
|
||||||
let authtoken = webAppFormAuthToken
|
let authtoken = webAppFormAuthToken
|
||||||
$(widgetFile "configurators/ssh/add")
|
$(widgetFile "configurators/ssh/add")
|
||||||
|
|
||||||
{- To enable an existing rsync special remote, parse the SshInput from
|
{- To enable an existing rsync special remote, parse the SshInput from
|
||||||
- its rsyncurl, and display a form whose only real purpose is to check
|
- its rsyncurl, and display a form whose only real purpose is to check
|
||||||
|
|
@ -138,15 +138,14 @@ getEnableRsyncR u = do
|
||||||
Left status -> showform form enctype status
|
Left status -> showform form enctype status
|
||||||
Right sshdata -> enable sshdata
|
Right sshdata -> enable sshdata
|
||||||
_ -> showform form enctype UntestedServer
|
_ -> showform form enctype UntestedServer
|
||||||
where
|
where
|
||||||
showform form enctype status = do
|
showform form enctype status = do
|
||||||
description <- lift $ runAnnex "" $
|
description <- lift $ runAnnex "" $
|
||||||
T.pack . concat <$> prettyListUUIDs [u]
|
T.pack . concat <$> prettyListUUIDs [u]
|
||||||
let authtoken = webAppFormAuthToken
|
let authtoken = webAppFormAuthToken
|
||||||
$(widgetFile "configurators/ssh/enable")
|
$(widgetFile "configurators/ssh/enable")
|
||||||
enable sshdata =
|
enable sshdata = lift $ redirect $ ConfirmSshR $
|
||||||
lift $ redirect $ ConfirmSshR $
|
sshdata { rsyncOnly = True }
|
||||||
sshdata { rsyncOnly = True }
|
|
||||||
|
|
||||||
{- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync
|
{- Converts a rsyncurl value to a SshInput. But only if it's a ssh rsync
|
||||||
- url; rsync:// urls or bare path names are not supported.
|
- url; rsync:// urls or bare path names are not supported.
|
||||||
|
|
@ -163,12 +162,12 @@ parseSshRsyncUrl u
|
||||||
, username = if null user then Nothing else val user
|
, username = if null user then Nothing else val user
|
||||||
, directory = val dir
|
, directory = val dir
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
val = Just . T.pack
|
val = Just . T.pack
|
||||||
(userhost, dir) = separate (== ':') u
|
(userhost, dir) = separate (== ':') u
|
||||||
(user, host) = if '@' `elem` userhost
|
(user, host) = if '@' `elem` userhost
|
||||||
then separate (== '@') userhost
|
then separate (== '@') userhost
|
||||||
else (userhost, "")
|
else (userhost, "")
|
||||||
|
|
||||||
{- Test if we can ssh into the server.
|
{- Test if we can ssh into the server.
|
||||||
-
|
-
|
||||||
|
|
@ -178,7 +177,7 @@ parseSshRsyncUrl u
|
||||||
- a special ssh key will need to be generated just for this server.
|
- a special ssh key will need to be generated just for this server.
|
||||||
-
|
-
|
||||||
- Once logged into the server, probe to see if git-annex-shell is
|
- Once logged into the server, probe to see if git-annex-shell is
|
||||||
- available, or rsync. Note that on OSX, ~/.ssh/git-annex-shell may be
|
- available, or rsync. Note that, ~/.ssh/git-annex-shell may be
|
||||||
- present, while git-annex-shell is not in PATH.
|
- present, while git-annex-shell is not in PATH.
|
||||||
-}
|
-}
|
||||||
testServer :: SshInput -> IO (Either ServerStatus SshData)
|
testServer :: SshInput -> IO (Either ServerStatus SshData)
|
||||||
|
|
@ -193,44 +192,43 @@ testServer sshinput@(SshInput { hostname = Just hn }) = do
|
||||||
if usable status'
|
if usable status'
|
||||||
then ret status' True
|
then ret status' True
|
||||||
else return $ Left status'
|
else return $ Left status'
|
||||||
where
|
where
|
||||||
ret status needspubkey = return $ Right $
|
ret status needspubkey = return $ Right $ (mkSshData sshinput)
|
||||||
(mkSshData sshinput)
|
{ needsPubKey = needspubkey
|
||||||
{ needsPubKey = needspubkey
|
, rsyncOnly = status == UsableRsyncServer
|
||||||
, rsyncOnly = status == UsableRsyncServer
|
}
|
||||||
}
|
probe extraopts = do
|
||||||
probe extraopts = do
|
let remotecommand = join ";"
|
||||||
let remotecommand = join ";"
|
[ report "loggedin"
|
||||||
[ report "loggedin"
|
, checkcommand "git-annex-shell"
|
||||||
, checkcommand "git-annex-shell"
|
, checkcommand "rsync"
|
||||||
, checkcommand "rsync"
|
, checkcommand shim
|
||||||
, checkcommand osx_shim
|
]
|
||||||
]
|
knownhost <- knownHost hn
|
||||||
knownhost <- knownHost hn
|
let sshopts = filter (not . null) $ extraopts ++
|
||||||
let sshopts = filter (not . null) $ extraopts ++
|
{- If this is an already known host, let
|
||||||
{- If this is an already known host, let
|
- ssh check it as usual.
|
||||||
- ssh check it as usual.
|
- Otherwise, trust the host key. -}
|
||||||
- Otherwise, trust the host key. -}
|
[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
|
||||||
[ if knownhost then "" else sshOpt "StrictHostKeyChecking" "no"
|
, "-n" -- don't read from stdin
|
||||||
, "-n" -- don't read from stdin
|
, genSshHost (fromJust $ hostname sshinput) (username sshinput)
|
||||||
, genSshHost (fromJust $ hostname sshinput) (username sshinput)
|
, remotecommand
|
||||||
, remotecommand
|
]
|
||||||
]
|
parsetranscript . fst <$> sshTranscript sshopts ""
|
||||||
parsetranscript . fst <$> sshTranscript sshopts ""
|
parsetranscript s
|
||||||
parsetranscript s
|
| reported "git-annex-shell" = UsableSshInput
|
||||||
| reported "git-annex-shell" = UsableSshInput
|
| reported shim = UsableSshInput
|
||||||
| reported osx_shim = UsableSshInput
|
| reported "rsync" = UsableRsyncServer
|
||||||
| reported "rsync" = UsableRsyncServer
|
| reported "loggedin" = UnusableServer
|
||||||
| reported "loggedin" = UnusableServer
|
"Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?"
|
||||||
"Neither rsync nor git-annex are installed on the server. Perhaps you should go install them?"
|
| otherwise = UnusableServer $ T.pack $
|
||||||
| otherwise = UnusableServer $ T.pack $
|
"Failed to ssh to the server. Transcript: " ++ s
|
||||||
"Failed to ssh to the server. Transcript: " ++ s
|
where
|
||||||
where
|
reported r = token r `isInfixOf` s
|
||||||
reported r = token r `isInfixOf` s
|
checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"
|
||||||
checkcommand c = "if which " ++ c ++ "; then " ++ report c ++ "; fi"
|
token r = "git-annex-probe " ++ r
|
||||||
token r = "git-annex-probe " ++ r
|
report r = "echo " ++ token r
|
||||||
report r = "echo " ++ token r
|
shim = "~/.ssh/git-annex-shell"
|
||||||
osx_shim = "~/.ssh/git-annex-shell"
|
|
||||||
|
|
||||||
{- Runs a ssh command; if it fails shows the user the transcript,
|
{- Runs a ssh command; if it fails shows the user the transcript,
|
||||||
- and if it succeeds, runs an action. -}
|
- and if it succeeds, runs an action. -}
|
||||||
|
|
@ -268,18 +266,18 @@ makeSsh' :: Bool -> (Remote -> Handler ()) -> SshData -> Maybe SshKeyPair -> Han
|
||||||
makeSsh' rsync setup sshdata keypair =
|
makeSsh' rsync setup sshdata keypair =
|
||||||
sshSetup [sshhost, remoteCommand] "" $
|
sshSetup [sshhost, remoteCommand] "" $
|
||||||
makeSshRepo rsync setup sshdata
|
makeSshRepo rsync setup sshdata
|
||||||
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 = join "&&" $ catMaybes
|
remoteCommand = join "&&" $ 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 "git init --bare --shared"
|
, if rsync then Nothing else Just "git init --bare --shared"
|
||||||
, if rsync then Nothing else Just "git annex init"
|
, if rsync then Nothing else Just "git annex init"
|
||||||
, if needsPubKey sshdata
|
, if needsPubKey sshdata
|
||||||
then addAuthorizedKeysCommand (rsyncOnly sshdata) . sshPubKey <$> keypair
|
then addAuthorizedKeysCommand (rsyncOnly sshdata) . sshPubKey <$> keypair
|
||||||
else Nothing
|
else Nothing
|
||||||
]
|
]
|
||||||
|
|
||||||
makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
|
makeSshRepo :: Bool -> (Remote -> Handler ()) -> SshData -> Handler RepHtml
|
||||||
makeSshRepo forcersync setup sshdata = do
|
makeSshRepo forcersync setup sshdata = do
|
||||||
|
|
|
||||||
|
|
@ -57,11 +57,11 @@ getXMPPR = xmppPage $ do
|
||||||
FormSuccess f -> maybe (showform True) (lift . storecreds)
|
FormSuccess f -> maybe (showform True) (lift . storecreds)
|
||||||
=<< liftIO (validateForm f)
|
=<< liftIO (validateForm f)
|
||||||
_ -> showform False
|
_ -> showform False
|
||||||
where
|
where
|
||||||
storecreds creds = do
|
storecreds creds = do
|
||||||
void $ runAnnex undefined $ setXMPPCreds creds
|
void $ runAnnex undefined $ setXMPPCreds creds
|
||||||
liftAssistant notifyRestart
|
liftAssistant notifyRestart
|
||||||
redirect ConfigR
|
redirect ConfigR
|
||||||
#else
|
#else
|
||||||
getXMPPR = xmppPage $
|
getXMPPR = xmppPage $
|
||||||
$(widgetFile "configurators/xmpp/disabled")
|
$(widgetFile "configurators/xmpp/disabled")
|
||||||
|
|
@ -83,9 +83,9 @@ xmppAForm def = XMPPForm
|
||||||
|
|
||||||
jidField :: Field WebApp WebApp Text
|
jidField :: Field WebApp WebApp Text
|
||||||
jidField = checkBool (isJust . parseJID) bad textField
|
jidField = checkBool (isJust . parseJID) bad textField
|
||||||
where
|
where
|
||||||
bad :: Text
|
bad :: Text
|
||||||
bad = "This should look like an email address.."
|
bad = "This should look like an email address.."
|
||||||
|
|
||||||
validateForm :: XMPPForm -> IO (Maybe XMPPCreds)
|
validateForm :: XMPPForm -> IO (Maybe XMPPCreds)
|
||||||
validateForm f = do
|
validateForm f = do
|
||||||
|
|
|
||||||
|
|
@ -47,10 +47,10 @@ transfersDisplay warnNoScript = do
|
||||||
, $(widgetFile "dashboard/transfers")
|
, $(widgetFile "dashboard/transfers")
|
||||||
)
|
)
|
||||||
else $(widgetFile "dashboard/transfers")
|
else $(widgetFile "dashboard/transfers")
|
||||||
where
|
where
|
||||||
ident = "transfers"
|
ident = "transfers"
|
||||||
isrunning info = not $
|
isrunning info = not $
|
||||||
transferPaused info || isNothing (startedTime info)
|
transferPaused info || isNothing (startedTime info)
|
||||||
|
|
||||||
{- Simplifies a list of transfers, avoiding display of redundant
|
{- Simplifies a list of transfers, avoiding display of redundant
|
||||||
- equivilant transfers. -}
|
- equivilant transfers. -}
|
||||||
|
|
@ -136,11 +136,11 @@ openFileBrowser = do
|
||||||
void $ redirectUltDest HomeR
|
void $ redirectUltDest HomeR
|
||||||
return False
|
return False
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
#ifdef darwin_HOST_OS
|
#ifdef darwin_HOST_OS
|
||||||
cmd = "open"
|
cmd = "open"
|
||||||
#else
|
#else
|
||||||
cmd = "xdg-open"
|
cmd = "xdg-open"
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
{- Transfer controls. The GET is done in noscript mode and redirects back
|
{- Transfer controls. The GET is done in noscript mode and redirects back
|
||||||
|
|
|
||||||
|
|
@ -29,25 +29,23 @@ getSwitchToRepositoryR repo = do
|
||||||
liftIO startassistant
|
liftIO startassistant
|
||||||
url <- liftIO geturl
|
url <- liftIO geturl
|
||||||
redirect url
|
redirect url
|
||||||
where
|
where
|
||||||
startassistant = do
|
startassistant = do
|
||||||
program <- readProgramFile
|
program <- readProgramFile
|
||||||
void $ forkIO $ void $ createProcess $
|
void $ forkIO $ void $ createProcess $
|
||||||
(proc program ["assistant"])
|
(proc program ["assistant"]) { cwd = Just repo }
|
||||||
{ cwd = Just repo }
|
geturl = do
|
||||||
geturl = do
|
r <- Git.Config.read =<< Git.Construct.fromPath repo
|
||||||
r <- Git.Config.read =<< Git.Construct.fromPath repo
|
waiturl $ gitAnnexUrlFile r
|
||||||
waiturl $ gitAnnexUrlFile r
|
waiturl urlfile = do
|
||||||
waiturl urlfile = do
|
v <- tryIO $ readFile urlfile
|
||||||
v <- tryIO $ readFile urlfile
|
case v of
|
||||||
case v of
|
Left _ -> delayed $ waiturl urlfile
|
||||||
Left _ -> delayed $ waiturl urlfile
|
Right url -> ifM (listening url)
|
||||||
Right url -> ifM (listening url)
|
( return url
|
||||||
( return url
|
, delayed $ waiturl urlfile
|
||||||
, delayed $ waiturl urlfile
|
)
|
||||||
)
|
listening url = catchBoolIO $ fst <$> Url.exists url []
|
||||||
listening url = catchBoolIO $
|
delayed a = do
|
||||||
fst <$> Url.exists url []
|
threadDelay 100000 -- 1/10th of a second
|
||||||
delayed a = do
|
a
|
||||||
threadDelay 100000 -- 1/10th of a second
|
|
||||||
a
|
|
||||||
|
|
|
||||||
|
|
@ -34,20 +34,20 @@ sideBarDisplay = do
|
||||||
let ident = "sidebar"
|
let ident = "sidebar"
|
||||||
$(widgetFile "sidebar/main")
|
$(widgetFile "sidebar/main")
|
||||||
autoUpdate ident NotifierSideBarR (10 :: Int) (10 :: Int)
|
autoUpdate ident NotifierSideBarR (10 :: Int) (10 :: Int)
|
||||||
where
|
where
|
||||||
bootstrapclass :: AlertClass -> Text
|
bootstrapclass :: AlertClass -> Text
|
||||||
bootstrapclass Activity = "alert-info"
|
bootstrapclass Activity = "alert-info"
|
||||||
bootstrapclass Warning = "alert"
|
bootstrapclass Warning = "alert"
|
||||||
bootstrapclass Error = "alert-error"
|
bootstrapclass Error = "alert-error"
|
||||||
bootstrapclass Success = "alert-success"
|
bootstrapclass Success = "alert-success"
|
||||||
bootstrapclass Message = "alert-info"
|
bootstrapclass Message = "alert-info"
|
||||||
|
|
||||||
renderalert (aid, alert) = do
|
renderalert (aid, alert) = do
|
||||||
let alertid = show aid
|
let alertid = show aid
|
||||||
let closable = alertClosable alert
|
let closable = alertClosable alert
|
||||||
let block = alertBlockDisplay alert
|
let block = alertBlockDisplay alert
|
||||||
let divclass = bootstrapclass $ alertClass alert
|
let divclass = bootstrapclass $ alertClass alert
|
||||||
$(widgetFile "sidebar/alert")
|
$(widgetFile "sidebar/alert")
|
||||||
|
|
||||||
{- Called by client to get a sidebar display.
|
{- Called by client to get a sidebar display.
|
||||||
-
|
-
|
||||||
|
|
|
||||||
|
|
@ -44,9 +44,9 @@ instance Yesod WebApp where
|
||||||
{- Add the auth token to every url generated, except static subsite
|
{- Add the auth token to every url generated, except static subsite
|
||||||
- urls (which can show up in Permission Denied pages). -}
|
- urls (which can show up in Permission Denied pages). -}
|
||||||
joinPath = insertAuthToken secretToken excludeStatic
|
joinPath = insertAuthToken secretToken excludeStatic
|
||||||
where
|
where
|
||||||
excludeStatic [] = True
|
excludeStatic [] = True
|
||||||
excludeStatic (p:_) = p /= "static"
|
excludeStatic (p:_) = p /= "static"
|
||||||
|
|
||||||
makeSessionBackend = webAppSessionBackend
|
makeSessionBackend = webAppSessionBackend
|
||||||
jsLoader _ = BottomOfHeadBlocking
|
jsLoader _ = BottomOfHeadBlocking
|
||||||
|
|
|
||||||
|
|
@ -43,18 +43,18 @@ changeSyncable (Just r) False = do
|
||||||
mapM_ (cancelTransfer False) =<<
|
mapM_ (cancelTransfer False) =<<
|
||||||
filter tofrom . M.keys <$>
|
filter tofrom . M.keys <$>
|
||||||
liftAssistant (currentTransfers <$> getDaemonStatus)
|
liftAssistant (currentTransfers <$> getDaemonStatus)
|
||||||
where
|
where
|
||||||
tofrom t = transferUUID t == Remote.uuid r
|
tofrom t = transferUUID t == Remote.uuid r
|
||||||
|
|
||||||
changeSyncFlag :: Remote -> Bool -> Handler ()
|
changeSyncFlag :: Remote -> Bool -> Handler ()
|
||||||
changeSyncFlag r enabled = runAnnex undefined $ do
|
changeSyncFlag r enabled = runAnnex undefined $ do
|
||||||
Config.setConfig key value
|
Config.setConfig key value
|
||||||
void $ Remote.remoteListRefresh
|
void $ Remote.remoteListRefresh
|
||||||
where
|
where
|
||||||
key = Config.remoteConfig (Remote.repo r) "sync"
|
key = Config.remoteConfig (Remote.repo r) "sync"
|
||||||
value
|
value
|
||||||
| enabled = "true"
|
| enabled = "true"
|
||||||
| otherwise = "false"
|
| otherwise = "false"
|
||||||
|
|
||||||
{- Start syncing remote, using a background thread. -}
|
{- Start syncing remote, using a background thread. -}
|
||||||
syncRemote :: Remote -> Handler ()
|
syncRemote :: Remote -> Handler ()
|
||||||
|
|
@ -71,47 +71,46 @@ cancelTransfer pause t = do
|
||||||
void $ liftAssistant $ dequeueTransfers $ equivilantTransfer t
|
void $ liftAssistant $ dequeueTransfers $ equivilantTransfer t
|
||||||
{- stop running transfer -}
|
{- stop running transfer -}
|
||||||
maybe noop stop (M.lookup t m)
|
maybe noop stop (M.lookup t m)
|
||||||
where
|
where
|
||||||
stop info = liftAssistant $ do
|
stop info = liftAssistant $ do
|
||||||
{- When there's a thread associated with the
|
{- When there's a thread associated with the
|
||||||
- transfer, it's signaled first, to avoid it
|
- transfer, it's signaled first, to avoid it
|
||||||
- displaying any alert about the transfer having
|
- displaying any alert about the transfer having
|
||||||
- failed when the transfer process is killed. -}
|
- failed when the transfer process is killed. -}
|
||||||
liftIO $ maybe noop signalthread $ transferTid info
|
liftIO $ maybe noop signalthread $ transferTid info
|
||||||
liftIO $ maybe noop killproc $ transferPid info
|
liftIO $ maybe noop killproc $ transferPid info
|
||||||
if pause
|
if pause
|
||||||
then void $ alterTransferInfo t $
|
then void $ alterTransferInfo t $
|
||||||
\i -> i { transferPaused = True }
|
\i -> i { transferPaused = True }
|
||||||
else void $ removeTransfer t
|
else void $ removeTransfer t
|
||||||
signalthread tid
|
signalthread tid
|
||||||
| pause = throwTo tid PauseTransfer
|
| pause = throwTo tid PauseTransfer
|
||||||
| otherwise = killThread tid
|
| otherwise = killThread tid
|
||||||
{- In order to stop helper processes like rsync,
|
{- In order to stop helper processes like rsync,
|
||||||
- kill the whole process group of the process running the
|
- kill the whole process group of the process running the transfer. -}
|
||||||
- transfer. -}
|
killproc pid = do
|
||||||
killproc pid = do
|
g <- getProcessGroupIDOf pid
|
||||||
g <- getProcessGroupIDOf pid
|
void $ tryIO $ signalProcessGroup sigTERM g
|
||||||
void $ tryIO $ signalProcessGroup sigTERM g
|
threadDelay 50000 -- 0.05 second grace period
|
||||||
threadDelay 50000 -- 0.05 second grace period
|
void $ tryIO $ signalProcessGroup sigKILL g
|
||||||
void $ tryIO $ signalProcessGroup sigKILL g
|
|
||||||
|
|
||||||
startTransfer :: Transfer -> Handler ()
|
startTransfer :: Transfer -> Handler ()
|
||||||
startTransfer t = do
|
startTransfer t = do
|
||||||
m <- getCurrentTransfers
|
m <- getCurrentTransfers
|
||||||
maybe startqueued go (M.lookup t m)
|
maybe startqueued go (M.lookup t m)
|
||||||
where
|
where
|
||||||
go info = maybe (start info) resume $ transferTid info
|
go info = maybe (start info) resume $ transferTid info
|
||||||
startqueued = do
|
startqueued = do
|
||||||
is <- liftAssistant $ map snd <$> getMatchingTransfers (== t)
|
is <- liftAssistant $ map snd <$> getMatchingTransfers (== t)
|
||||||
maybe noop start $ headMaybe is
|
maybe noop start $ headMaybe is
|
||||||
resume tid = do
|
resume tid = do
|
||||||
liftAssistant $ alterTransferInfo t $
|
liftAssistant $ alterTransferInfo t $
|
||||||
\i -> i { transferPaused = False }
|
\i -> i { transferPaused = False }
|
||||||
liftIO $ throwTo tid ResumeTransfer
|
liftIO $ throwTo tid ResumeTransfer
|
||||||
start info = liftAssistant $ do
|
start info = liftAssistant $ do
|
||||||
program <- liftIO readProgramFile
|
program <- liftIO readProgramFile
|
||||||
inImmediateTransferSlot $
|
inImmediateTransferSlot $
|
||||||
Transferrer.startTransfer program t info
|
Transferrer.startTransfer program t info
|
||||||
|
|
||||||
getCurrentTransfers :: Handler TransferMap
|
getCurrentTransfers :: Handler TransferMap
|
||||||
getCurrentTransfers = currentTransfers <$> liftAssistant getDaemonStatus
|
getCurrentTransfers = currentTransfers <$> liftAssistant getDaemonStatus
|
||||||
|
|
|
||||||
|
|
@ -36,28 +36,28 @@ connectXMPP c a = case parseJID (xmppJID c) of
|
||||||
{- Do a SRV lookup, but if it fails, fall back to the cached xmppHostname. -}
|
{- Do a SRV lookup, but if it fails, fall back to the cached xmppHostname. -}
|
||||||
connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO (Either SomeException ())
|
connectXMPP' :: JID -> XMPPCreds -> (JID -> XMPP a) -> IO (Either SomeException ())
|
||||||
connectXMPP' jid c a = go =<< lookupSRV srvrecord
|
connectXMPP' jid c a = go =<< lookupSRV srvrecord
|
||||||
where
|
where
|
||||||
srvrecord = mkSRVTcp "xmpp-client" $
|
srvrecord = mkSRVTcp "xmpp-client" $
|
||||||
T.unpack $ strDomain $ jidDomain jid
|
T.unpack $ strDomain $ jidDomain jid
|
||||||
serverjid = JID Nothing (jidDomain jid) Nothing
|
serverjid = JID Nothing (jidDomain jid) Nothing
|
||||||
|
|
||||||
go [] = run (xmppHostname c)
|
go [] = run (xmppHostname c)
|
||||||
(PortNumber $ fromIntegral $ xmppPort c)
|
(PortNumber $ fromIntegral $ xmppPort c)
|
||||||
(a jid)
|
(a jid)
|
||||||
go ((h,p):rest) = do
|
go ((h,p):rest) = do
|
||||||
{- Try each SRV record in turn, until one connects,
|
{- Try each SRV record in turn, until one connects,
|
||||||
- at which point the MVar will be full. -}
|
- at which point the MVar will be full. -}
|
||||||
mv <- newEmptyMVar
|
mv <- newEmptyMVar
|
||||||
r <- run h p $ do
|
r <- run h p $ do
|
||||||
liftIO $ putMVar mv ()
|
liftIO $ putMVar mv ()
|
||||||
a jid
|
a jid
|
||||||
ifM (isEmptyMVar mv) (go rest, return r)
|
ifM (isEmptyMVar mv) (go rest, return r)
|
||||||
|
|
||||||
{- Async exceptions are let through so the XMPP thread can
|
{- Async exceptions are let through so the XMPP thread can
|
||||||
- be killed. -}
|
- be killed. -}
|
||||||
run h p a' = tryNonAsync $
|
run h p a' = tryNonAsync $
|
||||||
runClientError (Server serverjid h p) jid
|
runClientError (Server serverjid h p) jid
|
||||||
(xmppUsername c) (xmppPassword c) (void a')
|
(xmppUsername c) (xmppPassword c) (void a')
|
||||||
|
|
||||||
{- XMPP runClient, that throws errors rather than returning an Either -}
|
{- XMPP runClient, that throws errors rather than returning an Either -}
|
||||||
runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a
|
runClientError :: Server -> JID -> T.Text -> T.Text -> XMPP a -> IO a
|
||||||
|
|
@ -88,9 +88,9 @@ xmppCredsFile = do
|
||||||
gitAnnexPresence :: Element -> Presence
|
gitAnnexPresence :: Element -> Presence
|
||||||
gitAnnexPresence tag = (emptyPresence PresenceAvailable)
|
gitAnnexPresence tag = (emptyPresence PresenceAvailable)
|
||||||
{ presencePayloads = [extendedAway, tag] }
|
{ presencePayloads = [extendedAway, tag] }
|
||||||
where
|
where
|
||||||
extendedAway = Element (Name (T.pack "show") Nothing Nothing) []
|
extendedAway = Element (Name (T.pack "show") Nothing Nothing) []
|
||||||
[NodeContent $ ContentText $ T.pack "xa"]
|
[NodeContent $ ContentText $ T.pack "xa"]
|
||||||
|
|
||||||
{- Name of a git-annex tag, in our own XML namespace.
|
{- Name of a git-annex tag, in our own XML namespace.
|
||||||
- (Not using a namespace URL to avoid unnecessary bloat.) -}
|
- (Not using a namespace URL to avoid unnecessary bloat.) -}
|
||||||
|
|
@ -111,18 +111,18 @@ uuidSep = T.pack ","
|
||||||
encodePushNotification :: [UUID] -> Element
|
encodePushNotification :: [UUID] -> Element
|
||||||
encodePushNotification us = Element gitAnnexTagName
|
encodePushNotification us = Element gitAnnexTagName
|
||||||
[(pushAttr, [ContentText pushvalue])] []
|
[(pushAttr, [ContentText pushvalue])] []
|
||||||
where
|
where
|
||||||
pushvalue = T.intercalate uuidSep $
|
pushvalue = T.intercalate uuidSep $
|
||||||
map (T.pack . fromUUID) us
|
map (T.pack . fromUUID) us
|
||||||
|
|
||||||
decodePushNotification :: Element -> Maybe [UUID]
|
decodePushNotification :: Element -> Maybe [UUID]
|
||||||
decodePushNotification (Element name attrs _nodes)
|
decodePushNotification (Element name attrs _nodes)
|
||||||
| name == gitAnnexTagName && not (null us) = Just us
|
| name == gitAnnexTagName && not (null us) = Just us
|
||||||
| otherwise = Nothing
|
| otherwise = Nothing
|
||||||
where
|
where
|
||||||
us = map (toUUID . T.unpack) $
|
us = map (toUUID . T.unpack) $
|
||||||
concatMap (T.splitOn uuidSep . T.concat . map fromContent . snd) $
|
concatMap (T.splitOn uuidSep . T.concat . map fromContent . snd) $
|
||||||
filter ispush attrs
|
filter ispush attrs
|
||||||
ispush (k, _) = k == pushAttr
|
ispush (k, _) = k == pushAttr
|
||||||
fromContent (ContentText t) = t
|
fromContent (ContentText t) = t
|
||||||
fromContent (ContentEntity t) = t
|
fromContent (ContentEntity t) = t
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue