summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Assistant/Threads/WebApp.hs1
-rw-r--r--Assistant/WebApp.hs65
-rw-r--r--Assistant/WebApp/Configurators.hs1
-rw-r--r--Assistant/WebApp/Configurators/Local.hs1
-rw-r--r--Assistant/WebApp/Configurators/Ssh.hs57
-rw-r--r--Assistant/WebApp/DashBoard.hs1
-rw-r--r--Assistant/WebApp/Documentation.hs1
-rw-r--r--Assistant/WebApp/Notifications.hs1
-rw-r--r--Assistant/WebApp/SideBar.hs1
-rw-r--r--Assistant/WebApp/Types.hs95
-rw-r--r--Assistant/WebApp/routes2
-rw-r--r--templates/configurators/addssh.hamlet29
-rw-r--r--templates/configurators/confirmssh.hamlet31
-rw-r--r--templates/configurators/repositories.hamlet2
14 files changed, 191 insertions, 97 deletions
diff --git a/Assistant/Threads/WebApp.hs b/Assistant/Threads/WebApp.hs
index 6733e5a40..7da3c82e5 100644
--- a/Assistant/Threads/WebApp.hs
+++ b/Assistant/Threads/WebApp.hs
@@ -12,6 +12,7 @@ module Assistant.Threads.WebApp where
import Assistant.Common
import Assistant.WebApp
+import Assistant.WebApp.Types
import Assistant.WebApp.DashBoard
import Assistant.WebApp.SideBar
import Assistant.WebApp.Notifications
diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs
index 721257294..d2c41a3c3 100644
--- a/Assistant/WebApp.hs
+++ b/Assistant/WebApp.hs
@@ -1,4 +1,4 @@
-{- git-annex assistant webapp data types
+{- git-annex assistant webapp core
-
- Copyright 2012 Joey Hess <joey@kitenet.net>
-
@@ -6,45 +6,21 @@
-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
module Assistant.WebApp where
+import Assistant.WebApp.Types
import Assistant.Common
import Assistant.ThreadedMonad
import Assistant.DaemonStatus
-import Assistant.ScanRemotes
-import Assistant.TransferQueue
-import Assistant.TransferSlots
-import Assistant.Alert
import Utility.NotificationBroadcaster
-import Utility.WebApp
import Utility.Yesod
-import Logs.Transfer
import Yesod
-import Yesod.Static
import Text.Hamlet
-import Data.Text (Text, pack, unpack)
+import Data.Text (Text)
import Control.Concurrent.STM
-staticFiles "static"
-
-mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
-
-data WebApp = WebApp
- { threadState :: Maybe ThreadState
- , daemonStatus :: DaemonStatusHandle
- , scanRemotes :: ScanRemoteMap
- , transferQueue :: TransferQueue
- , transferSlots :: TransferSlots
- , secretToken :: Text
- , relDir :: Maybe FilePath
- , getStatic :: Static
- , webAppState :: TMVar WebAppState
- , postFirstRun :: Maybe (IO String)
- }
-
data NavBarItem = DashBoard | Config | About
deriving (Eq)
@@ -87,29 +63,6 @@ bootstrap navbaritem content = do
where
navdetails i = (navBarName i, navBarRoute i, Just i == navbaritem)
-instance Yesod WebApp where
- {- Require an auth token be set when accessing any (non-static route) -}
- isAuthorized _ _ = checkAuthToken secretToken
-
- {- 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"
-
- makeSessionBackend = webAppSessionBackend
- jsLoader _ = BottomOfHeadBlocking
-
-instance RenderMessage WebApp FormMessage where
- renderMessage _ _ = defaultFormMessage
-
-type Form x = Html -> MForm WebApp WebApp (FormResult x, Widget)
-
-data WebAppState = WebAppState
- { showIntro :: Bool
- }
-
newWebAppState :: IO (TMVar WebAppState)
newWebAppState = liftIO $ atomically $
newTMVar $ WebAppState { showIntro = True }
@@ -149,18 +102,6 @@ getNotifier selector = do
webapp <- getYesod
liftIO $ selector <$> getDaemonStatus (daemonStatus webapp)
-instance PathPiece NotificationId where
- toPathPiece = pack . show
- fromPathPiece = readish . unpack
-
-instance PathPiece AlertId where
- toPathPiece = pack . show
- fromPathPiece = readish . unpack
-
-instance PathPiece Transfer where
- toPathPiece = pack . show
- fromPathPiece = readish . unpack
-
{- Adds the auth parameter as a hidden field on a form. Must be put into
- every form. -}
webAppFormAuthToken :: Widget
diff --git a/Assistant/WebApp/Configurators.hs b/Assistant/WebApp/Configurators.hs
index 4d4d5c916..ec0a53ea8 100644
--- a/Assistant/WebApp/Configurators.hs
+++ b/Assistant/WebApp/Configurators.hs
@@ -11,6 +11,7 @@ module Assistant.WebApp.Configurators where
import Assistant.Common
import Assistant.WebApp
+import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Assistant.DaemonStatus
import Assistant.WebApp.Configurators.Local
diff --git a/Assistant/WebApp/Configurators/Local.hs b/Assistant/WebApp/Configurators/Local.hs
index beb41e1f1..42628fedf 100644
--- a/Assistant/WebApp/Configurators/Local.hs
+++ b/Assistant/WebApp/Configurators/Local.hs
@@ -11,6 +11,7 @@ module Assistant.WebApp.Configurators.Local where
import Assistant.Common
import Assistant.WebApp
+import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Assistant.Threads.MountWatcher (handleMount)
import Utility.Yesod
diff --git a/Assistant/WebApp/Configurators/Ssh.hs b/Assistant/WebApp/Configurators/Ssh.hs
index 9d728ce7e..0dd3a30ec 100644
--- a/Assistant/WebApp/Configurators/Ssh.hs
+++ b/Assistant/WebApp/Configurators/Ssh.hs
@@ -11,6 +11,7 @@ module Assistant.WebApp.Configurators.Ssh where
import Assistant.Common
import Assistant.WebApp
+import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod
@@ -26,9 +27,7 @@ data SshServer = SshServer
, username :: Maybe Text
, directory :: Maybe Text
}
- deriving Show
-
-type PubKey = String
+ deriving (Show)
sshServerAForm :: Text -> AForm WebApp WebApp SshServer
sshServerAForm localusername = SshServer
@@ -58,6 +57,7 @@ data ServerStatus
| UnusableServer Text -- reason why it's not usable
| UsableRsyncServer
| UsableSshServer
+ deriving (Eq)
usable :: ServerStatus -> Bool
usable UntestedServer = False
@@ -77,7 +77,14 @@ getAddSshR = bootstrap (Just Config) $ do
FormSuccess sshserver -> do
(status, sshserver', pubkey) <- liftIO $ testServer sshserver
if usable status
- then error $ "TODO " ++ show sshserver'
+ then lift $ redirect $ ConfirmSshR $
+ SshData
+ { sshHostName = fromJust $ hostname sshserver'
+ , sshUserName = username sshserver'
+ , sshDirectory = fromMaybe "" $ directory sshserver'
+ , pubKey = pubkey
+ , rsyncOnly = (status == UsableRsyncServer)
+ }
else showform form enctype status
_ -> showform form enctype UntestedServer
where
@@ -85,15 +92,6 @@ getAddSshR = bootstrap (Just Config) $ do
let authtoken = webAppFormAuthToken
$(widgetFile "configurators/addssh")
- buttonText :: ServerStatus -> Text
- buttonText UsableRsyncServer = "Make rsync repository"
- buttonText UsableSshServer = "Clone repository to ssh server"
- buttonText _ = "Check this server"
-
- willTest UntestedServer = True
- willTest (UnusableServer _) = True
- willTest _ = False
-
{- Test if we can ssh into the server.
-
- Two probe attempts are made. First, try sshing in using the existing
@@ -153,6 +151,7 @@ testServer sshserver = do
report r = "echo " ++ token r
sshopt k v = concat ["-o", k, "=", v]
+{- The output of ssh, including both stdout and stderr. -}
sshTranscript :: [String] -> IO String
sshTranscript opts = do
(readf, writef) <- createPipe
@@ -210,9 +209,29 @@ knownHost sshdir (SshServer { hostname = Just h }) =
, return False
)
-makeAuthorizedKeys pubkey = Just $ join ";"
- [ "mkdir -p ~/.ssh"
- , "touch ~/.ssh/authorized_keys"
- , "chmod 600 ~/.ssh/authorized_keys"
- , "echo " ++ shellEscape pubkey ++ " >>~/.ssh/authorized_keys"
- ]
+genSshUrl :: SshData -> Text
+genSshUrl s = T.concat ["ssh://", u, h, d, "/"]
+ where
+ u = maybe "" (\v -> T.concat [v, "@"]) $ sshUserName s
+ h = sshHostName s
+ d
+ | "/" `T.isPrefixOf` sshDirectory s = d
+ | otherwise = T.concat ["/~/", sshDirectory s]
+
+getConfirmSshR :: SshData -> Handler RepHtml
+getConfirmSshR sshdata = bootstrap (Just Config) $ do
+ sideBarDisplay
+ setTitle "Add a remote server"
+ let authtoken = webAppFormAuthToken
+ let haspubkey = isJust $ pubKey sshdata
+ $(widgetFile "configurators/confirmssh")
+
+getMakeSshR :: SshData -> Handler RepHtml
+getMakeSshR sshdata = error "TODO"
+ where
+ makeAuthorizedKeys pubkey = Just $ join ";"
+ [ "mkdir -p ~/.ssh"
+ , "touch ~/.ssh/authorized_keys"
+ , "chmod 600 ~/.ssh/authorized_keys"
+ , "echo " ++ shellEscape pubkey ++ " >>~/.ssh/authorized_keys"
+ ]
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index 1b052d84f..992e6ba26 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/Assistant/WebApp/DashBoard.hs
@@ -11,6 +11,7 @@ module Assistant.WebApp.DashBoard where
import Assistant.Common
import Assistant.WebApp
+import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Assistant.WebApp.Notifications
import Assistant.WebApp.Configurators
diff --git a/Assistant/WebApp/Documentation.hs b/Assistant/WebApp/Documentation.hs
index b0a9e4d98..3fc0f2374 100644
--- a/Assistant/WebApp/Documentation.hs
+++ b/Assistant/WebApp/Documentation.hs
@@ -10,6 +10,7 @@
module Assistant.WebApp.Documentation where
import Assistant.WebApp
+import Assistant.WebApp.Types
import Assistant.WebApp.SideBar
import Utility.Yesod
diff --git a/Assistant/WebApp/Notifications.hs b/Assistant/WebApp/Notifications.hs
index 3aa56424a..0ef890f68 100644
--- a/Assistant/WebApp/Notifications.hs
+++ b/Assistant/WebApp/Notifications.hs
@@ -11,6 +11,7 @@ module Assistant.WebApp.Notifications where
import Assistant.Common
import Assistant.WebApp
+import Assistant.WebApp.Types
import Assistant.DaemonStatus
import Utility.NotificationBroadcaster
import Utility.Yesod
diff --git a/Assistant/WebApp/SideBar.hs b/Assistant/WebApp/SideBar.hs
index d44c75d43..20fd09c2e 100644
--- a/Assistant/WebApp/SideBar.hs
+++ b/Assistant/WebApp/SideBar.hs
@@ -11,6 +11,7 @@ module Assistant.WebApp.SideBar where
import Assistant.Common
import Assistant.WebApp
+import Assistant.WebApp.Types
import Assistant.WebApp.Notifications
import Assistant.DaemonStatus
import Assistant.Alert
diff --git a/Assistant/WebApp/Types.hs b/Assistant/WebApp/Types.hs
new file mode 100644
index 000000000..988f909d7
--- /dev/null
+++ b/Assistant/WebApp/Types.hs
@@ -0,0 +1,95 @@
+{- git-annex assistant webapp types
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+module Assistant.WebApp.Types where
+
+import Assistant.Common
+import Assistant.ThreadedMonad
+import Assistant.DaemonStatus
+import Assistant.ScanRemotes
+import Assistant.TransferQueue
+import Assistant.TransferSlots
+import Assistant.Alert
+import Utility.NotificationBroadcaster
+import Utility.WebApp
+import Logs.Transfer
+
+import Yesod
+import Yesod.Static
+import Data.Text (Text, pack, unpack)
+import Control.Concurrent.STM
+
+staticFiles "static"
+
+mkYesodData "WebApp" $(parseRoutesFile "Assistant/WebApp/routes")
+
+data WebApp = WebApp
+ { threadState :: Maybe ThreadState
+ , daemonStatus :: DaemonStatusHandle
+ , scanRemotes :: ScanRemoteMap
+ , transferQueue :: TransferQueue
+ , transferSlots :: TransferSlots
+ , secretToken :: Text
+ , relDir :: Maybe FilePath
+ , getStatic :: Static
+ , webAppState :: TMVar WebAppState
+ , postFirstRun :: Maybe (IO String)
+ }
+
+instance Yesod WebApp where
+ {- Require an auth token be set when accessing any (non-static route) -}
+ isAuthorized _ _ = checkAuthToken secretToken
+
+ {- 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"
+
+ makeSessionBackend = webAppSessionBackend
+ jsLoader _ = BottomOfHeadBlocking
+
+instance RenderMessage WebApp FormMessage where
+ renderMessage _ _ = defaultFormMessage
+
+type Form x = Html -> MForm WebApp WebApp (FormResult x, Widget)
+
+data WebAppState = WebAppState
+ { showIntro :: Bool
+ }
+
+type PubKey = String
+
+data SshData = SshData
+ { sshHostName :: Text
+ , sshUserName :: Maybe Text
+ , sshDirectory :: Text
+ , pubKey :: Maybe PubKey
+ , rsyncOnly :: Bool
+ }
+ deriving (Read, Show, Eq)
+
+instance PathPiece SshData where
+ toPathPiece = pack . show
+ fromPathPiece = readish . unpack
+
+
+instance PathPiece NotificationId where
+ toPathPiece = pack . show
+ fromPathPiece = readish . unpack
+
+instance PathPiece AlertId where
+ toPathPiece = pack . show
+ fromPathPiece = readish . unpack
+
+instance PathPiece Transfer where
+ toPathPiece = pack . show
+ fromPathPiece = readish . unpack
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index eaa5ac7d1..d22e689dd 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -7,6 +7,8 @@
/config/repository RepositoriesR GET
/config/repository/add/drive AddDriveR GET
/config/repository/add/ssh AddSshR GET
+/config/repository/add/ssh/confirm/#SshData ConfirmSshR GET
+/config/repository/add/ssh/make/#SshData MakeSshR GET
/config/repository/first FirstRepositoryR GET
/transfers/#NotificationId TransfersR GET
diff --git a/templates/configurators/addssh.hamlet b/templates/configurators/addssh.hamlet
index 3fa72d9b9..03a99fd96 100644
--- a/templates/configurators/addssh.hamlet
+++ b/templates/configurators/addssh.hamlet
@@ -1,13 +1,13 @@
<div .span9 .hero-unit>
<h2>
- Adding a remote server using ssh or rsync
+ Adding a remote server using ssh
<p>
- Clone this repository to a ssh or rsync server. Your data will be #
+ Clone this repository to a ssh server. Your data will be #
uploaded to the server. If you set up other devices to use the same #
server, they will all be kept in sync, using the server as a central #
hub.
<p>
- You can use nearly any server that has ssh or rsync. For example, you #
+ You can use nearly any server that has ssh and rsync. For example, you #
could use a <a href="http://linode.com/">Linode</a> or another VPS, or #
an account on a friend's server.
<p>
@@ -25,15 +25,14 @@
^{form}
^{authtoken}
<div .form-actions>
- <button .btn .btn-primary type=submit :willTest status:onclick="$('#testmodal').modal('show');">
- #{buttonText status}
-$if willTest status
- <div .modal .fade #testmodal>
- <div .modal-header>
- <h3>
- Testing server ...
- <div .modal-body>
- <p>
- Checking ssh connection to the server. This could take a minute.
- <p>
- You may be prompted for your password to log into the server.
+ <button .btn .btn-primary type=submit onclick="$('#testmodal').modal('show');">
+ Check this server
+<div .modal .fade #testmodal>
+ <div .modal-header>
+ <h3>
+ Testing server ...
+ <div .modal-body>
+ <p>
+ Checking ssh connection to the server. This could take a minute.
+ <p>
+ You may be prompted for your password to log into the server.
diff --git a/templates/configurators/confirmssh.hamlet b/templates/configurators/confirmssh.hamlet
new file mode 100644
index 000000000..75e27f708
--- /dev/null
+++ b/templates/configurators/confirmssh.hamlet
@@ -0,0 +1,31 @@
+<div .span9 .hero-unit>
+ <h2>
+ Ready to add remote server
+ <div .row-fluid>
+ <div .span8>
+ <p>
+ The server at #{sshHostName sshdata} has been verified to be usable.
+ <br>
+ Everything checks out!
+ <p>
+ <a .btn .btn-primary href="@{MakeSshR sshdata}" onclick="$('#setupmodal').modal('show');">
+ Clone this repository to the remote server
+ <div .span4>
+ $if haspubkey
+ <div .alert .alert-info>
+ <i .icon-info-sign></i> #
+ <p>
+ A ssh key will be installed on the server, allowing git-annex to #
+ access it securely without a password.
+<div .modal .fade #setupmodal>
+ <div .modal-header>
+ <h3>
+ Testing server ...
+ <div .modal-body>
+ <p>
+ Setting up repository on the remote server. This could take a minute.
+ $if haspubkey
+ <p>
+ You will be prompted once more for your ssh password. A ssh key
+ is being installed on the server, allowing git-annex to access it
+ securely without a password.
diff --git a/templates/configurators/repositories.hamlet b/templates/configurators/repositories.hamlet
index 06c1b3299..ee822671f 100644
--- a/templates/configurators/repositories.hamlet
+++ b/templates/configurators/repositories.hamlet
@@ -54,6 +54,6 @@
<i .icon-plus-sign></i> Remote server
<p>
Set up a repository on a remote server using #
- <tt>ssh</tt> or <tt>rsync</tt>.
+ <tt>ssh</tt>.
<p>
To build your own personal cloud.
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-01 04:04:58 +0000