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