webapp: support box.com

Assistant/WebApp/Configurators/S3.hs

@@ -87,11 +87,10 @@ getAddS3R = s3Configurator $ do
 				, ("datacenter", T.unpack $ datacenter s3input)
 				, ("storageclass", show $ storageClass s3input)
 				]
-		_ -> showform form enctype
+		_ -> do
+			let authtoken = webAppFormAuthToken
+			$(widgetFile "configurators/adds3")
   where
-	showform form enctype = do
-		let authtoken = webAppFormAuthToken
-		$(widgetFile "configurators/adds3")
 	setgroup r = runAnnex () $
 		setStandardGroup (Remote.uuid r) TransferGroup
 
@@ -105,18 +104,16 @@ getEnableS3R uuid = s3Configurator $ do
 			let name = fromJust $ M.lookup "name" $
 				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")
+		_ -> 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
 	remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
-	liftIO $ S3.s3SetCredsEnv (T.unpack ak, T.unpack sk)
+	liftIO $ S3.setCredsEnv (T.unpack ak, T.unpack sk)
 	r <- liftAssistant $ liftAnnex $ addRemote $ do
 		makeSpecialRemote name S3.remote config
 		return remotename

Assistant/WebApp/Configurators/WebDAV.hs

@@ -0,0 +1,79 @@
+{- git-annex assistant webapp configurators for WebDAV remotes
+ -
+ - Copyright 2012 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU AGPL version 3 or higher.
+ -}
+
+{-# LANGUAGE TypeFamilies, QuasiQuotes, MultiParamTypeClasses, TemplateHaskell, OverloadedStrings, RankNTypes #-}
+
+module Assistant.WebApp.Configurators.WebDAV where
+
+import Assistant.Common
+import Assistant.MakeRemote
+import Assistant.Sync
+import Assistant.WebApp
+import Assistant.WebApp.Types
+import Assistant.WebApp.SideBar
+import Utility.Yesod
+import qualified Remote.WebDAV as WebDAV
+import qualified Remote
+import Types.Remote (RemoteConfig)
+import Types.StandardGroups
+import Logs.PreferredContent
+
+import Yesod
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Map as M
+
+boxConfigurator :: Widget -> Handler RepHtml
+boxConfigurator a = bootstrap (Just Config) $ do
+	sideBarDisplay
+	setTitle "Add a Box.com repository"
+	a
+
+data WebDAVInput = WebDAVInput
+	{ user :: Text
+	, password :: Text
+	, directory :: Text
+	}
+
+boxComAForm :: AForm WebApp WebApp WebDAVInput
+boxComAForm = WebDAVInput
+	<$> areq textField "Username or Email" Nothing
+	<*> areq passwordField "Box.com Password" Nothing
+	<*> areq textField "Directory" (Just "annex")
+
+getAddBoxComR :: Handler RepHtml
+getAddBoxComR = boxConfigurator $ do
+	((result, form), enctype) <- lift $
+		runFormGet $ renderBootstrap boxComAForm
+	case result of
+		FormSuccess input -> lift $ 
+			makeWebDavRemote "box.com" input setgroup $ M.fromList
+				[ ("encryption", "shared")
+				, ("type", "webdav")
+				, ("url", "https://www.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")
+				]
+		_ -> do
+			let authtoken = webAppFormAuthToken
+			$(widgetFile "configurators/addbox.com")
+  where
+	setgroup r = runAnnex () $
+		setStandardGroup (Remote.uuid r) TransferGroup
+
+makeWebDavRemote :: String -> WebDAVInput -> (Remote -> Handler ()) -> RemoteConfig -> Handler ()
+makeWebDavRemote name input setup config = do
+	remotename <- runAnnex name $ fromRepo $ uniqueRemoteName name 0
+	liftIO $ WebDAV.setCredsEnv (T.unpack $ user input, T.unpack $ password input)
+	r <- liftAssistant $ liftAnnex $ addRemote $ do
+		makeSpecialRemote name WebDAV.remote config
+		return remotename
+	setup r
+	liftAssistant $ syncNewRemote r
+	redirect $ EditNewCloudRepositoryR $ Remote.uuid r