1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
|
{- git-annex assistant webapp configurators for WebDAV remotes
-
- Copyright 2012, 2013 Joey Hess <joey@kitenet.net>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE CPP, TemplateHaskell, OverloadedStrings #-}
module Assistant.WebApp.Configurators.WebDAV where
import Assistant.WebApp.Common
import Creds
#ifdef WITH_WEBDAV
import qualified Remote.WebDAV as WebDAV
import Assistant.WebApp.MakeRemote
import qualified Remote
import Types.Remote (RemoteConfig)
import Types.StandardGroups
import Logs.Remote
import Git.Types (RemoteName)
import qualified Data.Map as M
#endif
import qualified Data.Text as T
import Network.URI
import Assistant.Gpg
webDAVConfigurator :: Widget -> Handler Html
webDAVConfigurator = page "Add a WebDAV repository" (Just Configuration)
boxConfigurator :: Widget -> Handler Html
boxConfigurator = page "Add a Box.com repository" (Just Configuration)
data WebDAVInput = WebDAVInput
{ user :: Text
, password :: Text
, embedCreds :: Bool
, directory :: Text
, enableEncryption :: EnableEncryption
}
toCredPair :: WebDAVInput -> CredPair
toCredPair input = (T.unpack $ user input, T.unpack $ password input)
boxComAForm :: Maybe CredPair -> MkAForm WebDAVInput
boxComAForm defcreds = WebDAVInput
<$> areq textField (bfs "Username or Email") (T.pack . fst <$> defcreds)
<*> areq passwordField (bfs "Box.com Password") (T.pack . snd <$> defcreds)
<*> areq checkBoxField "Share this account with other devices and friends?" (Just True)
<*> areq textField (bfs "Directory") (Just "annex")
<*> enableEncryptionField
webDAVCredsAForm :: Maybe CredPair -> MkAForm WebDAVInput
webDAVCredsAForm defcreds = WebDAVInput
<$> areq textField (bfs "Username or Email") (T.pack . fst <$> defcreds)
<*> areq passwordField (bfs "Password") (T.pack . snd <$> defcreds)
<*> pure False
<*> pure T.empty
<*> pure NoEncryption -- not used!
getAddBoxComR :: Handler Html
getAddBoxComR = postAddBoxComR
postAddBoxComR :: Handler Html
#ifdef WITH_WEBDAV
postAddBoxComR = boxConfigurator $ do
defcreds <- liftAnnex $ previouslyUsedWebDAVCreds "box.com"
((result, form), enctype) <- liftH $
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout
$ boxComAForm defcreds
case result of
FormSuccess input -> liftH $
makeWebDavRemote initSpecialRemote "box.com" (toCredPair input) $ M.fromList
[ configureEncryption $ enableEncryption input
, ("embedcreds", if embedCreds input then "yes" else "no")
, ("type", "webdav")
, ("url", "https://dav.box.com/dav/" ++ T.unpack (directory input))
-- Box.com has a max file size of 100 mb, but
-- using smaller chunks has better memory
-- performance.
, ("chunksize", "10mb")
]
_ -> $(widgetFile "configurators/addbox.com")
#else
postAddBoxComR = error "WebDAV not supported by this build"
#endif
getEnableWebDAVR :: UUID -> Handler Html
getEnableWebDAVR = postEnableWebDAVR
postEnableWebDAVR :: UUID -> Handler Html
#ifdef WITH_WEBDAV
postEnableWebDAVR uuid = do
m <- liftAnnex readRemoteLog
let c = fromJust $ M.lookup uuid m
let name = fromJust $ M.lookup "name" c
let url = fromJust $ M.lookup "url" c
mcreds <- liftAnnex $
getRemoteCredPairFor "webdav" c (WebDAV.davCreds uuid)
case mcreds of
Just creds -> webDAVConfigurator $ liftH $
makeWebDavRemote enableSpecialRemote name creds M.empty
Nothing
| "box.com/" `isInfixOf` url ->
boxConfigurator $ showform name url
| otherwise ->
webDAVConfigurator $ showform name url
where
showform name url = do
defcreds <- liftAnnex $
maybe (pure Nothing) previouslyUsedWebDAVCreds $
urlHost url
((result, form), enctype) <- liftH $
runFormPostNoToken $ renderBootstrap3 bootstrapFormLayout $
webDAVCredsAForm defcreds
case result of
FormSuccess input -> liftH $
makeWebDavRemote enableSpecialRemote name (toCredPair input) M.empty
_ -> do
description <- liftAnnex $
T.pack <$> Remote.prettyUUID uuid
$(widgetFile "configurators/enablewebdav")
#else
postEnableWebDAVR _ = error "WebDAV not supported by this build"
#endif
#ifdef WITH_WEBDAV
makeWebDavRemote :: SpecialRemoteMaker -> RemoteName -> CredPair -> RemoteConfig -> Handler ()
makeWebDavRemote maker name creds config =
setupCloudRemote TransferGroup Nothing $
maker name WebDAV.remote (Just creds) config
{- Only returns creds previously used for the same hostname. -}
previouslyUsedWebDAVCreds :: String -> Annex (Maybe CredPair)
previouslyUsedWebDAVCreds hostname =
previouslyUsedCredPair WebDAV.davCreds WebDAV.remote samehost
where
samehost url = case urlHost =<< WebDAV.configUrl url of
Nothing -> False
Just h -> h == hostname
#endif
urlHost :: String -> Maybe String
urlHost url = uriRegName <$> (uriAuthority =<< parseURI url)
|
