mirrors/git-annex
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages 1 Wiki Activity Actions

UI for enabling existing webdav remotes

Browse source
This commit is contained in:
Joey Hess 2012-11-17 15:58:27 -04:00
parent 7addb89dc1
commit 453587d392
6 changed files with 67 additions and 4 deletions
Download patch file Download diff file Expand all files Collapse all files

37
Assistant/WebApp/Configurators/WebDAV.hs
View file

@ -21,12 +21,19 @@ import qualified Remote
import Types.Remote (RemoteConfig)
import Types.StandardGroups
import Logs.PreferredContent
import Logs.Remote
import Yesod
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Map as M
webDAVConfigurator :: Widget -> Handler RepHtml
webDAVConfigurator a = bootstrap (Just Config) $ do
sideBarDisplay
setTitle "Add a WebDAV repository"
a
boxConfigurator :: Widget -> Handler RepHtml
boxConfigurator a = bootstrap (Just Config) $ do
sideBarDisplay
@ -45,6 +52,12 @@ boxComAForm = WebDAVInput
<*> areq passwordField "Box.com Password" Nothing
<*> areq textField "Directory" (Just "annex")
webDAVCredsAForm :: AForm WebApp WebApp WebDAVInput
webDAVCredsAForm = WebDAVInput
<$> areq textField "Username or Email" Nothing
<*> areq passwordField "Password" Nothing
<*> pure (T.empty)
getAddBoxComR :: Handler RepHtml
getAddBoxComR = boxConfigurator $ do
((result, form), enctype) <- lift $
@ -67,6 +80,30 @@ getAddBoxComR = boxConfigurator $ do
setgroup r = runAnnex () $
setStandardGroup (Remote.uuid r) TransferGroup
getEnableWebDAVR :: UUID -> Handler RepHtml
getEnableWebDAVR uuid = do
m <- runAnnex M.empty readRemoteLog
let c = fromJust $ M.lookup uuid m
let name = fromJust $ M.lookup "name" c
let url = fromJust $ M.lookup "url" c
go name url
where
go name url
| "box.com/" `isInfixOf` url = boxConfigurator $ enable name url
| otherwise = webDAVConfigurator $ enable name url
enable name url = do
((result, form), enctype) <- lift $
runFormGet $ renderBootstrap webDAVCredsAForm
case result of
FormSuccess creds -> lift $
makeWebDavRemote name creds (const noop) M.empty
_ -> do
let authtoken = webAppFormAuthToken
description <- lift $ runAnnex "" $
T.pack . concat <$> Remote.prettyListUUIDs [uuid]
$(widgetFile "configurators/enablewebdav")
makeWebDavRemote :: String -> WebDAVInput -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
makeWebDavRemote name input setup config = do
remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0