where indentation
This commit is contained in:
Joey Hess
parent
b8009a68e4
commit
88d1907278
32 changed files with 720 additions and 732 deletions
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue