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