webapp: support box.com

Assistant/Threads/WebApp.hs

@@ -24,6 +24,9 @@ import Assistant.WebApp.Configurators.Pairing
 #ifdef WITH_S3
 import Assistant.WebApp.Configurators.S3
 #endif
+#ifdef WITH_WEBDAV
+import Assistant.WebApp.Configurators.WebDAV
+#endif
 import Assistant.WebApp.Configurators.XMPP
 import Assistant.WebApp.Documentation
 import Assistant.WebApp.OtherRepos

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
+		_ -> do
-  where
+			let authtoken = webAppFormAuthToken
-	showform form enctype = do
+			description <- lift $ runAnnex "" $
-		let authtoken = webAppFormAuthToken
+				T.pack . concat <$> Remote.prettyListUUIDs [uuid]
-		description <- lift $ runAnnex "" $
+			$(widgetFile "configurators/enables3")
-			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

Assistant/WebApp/routes

@@ -25,6 +25,7 @@
 /config/repository/add/ssh/make/rsync/#SshData MakeSshRsyncR GET
 /config/repository/add/cloud/rsync.net AddRsyncNetR GET
 /config/repository/add/cloud/S3 AddS3R GET
+/config/repository/add/cloud/box.com AddBoxComR GET
 
 /config/repository/pair/local/start StartLocalPairR GET
 /config/repository/pair/local/running/#SecretReminder RunningLocalPairR GET

Remote/S3.hs

@@ -5,7 +5,7 @@
  - Licensed under the GNU GPL version 3 or higher.
  -}
 
-module Remote.S3 (remote, s3SetCredsEnv) where
+module Remote.S3 (remote, setCredsEnv) where
 
 import Network.AWS.AWSConnection
 import Network.AWS.S3Object
@@ -276,5 +276,5 @@ s3Creds u = CredPairStorage
 	, credPairRemoteKey = Just "s3creds"
 	}
 
-s3SetCredsEnv :: (String, String) -> IO ()
+setCredsEnv :: (String, String) -> IO ()
-s3SetCredsEnv creds = setEnvCredPair creds $ s3Creds undefined
+setCredsEnv creds = setEnvCredPair creds $ s3Creds undefined

Remote/WebDAV.hs

@@ -7,7 +7,7 @@
 
 {-# LANGUAGE ScopedTypeVariables #-}
 
-module Remote.WebDAV (remote) where
+module Remote.WebDAV (remote, setCredsEnv) where
 
 import Network.Protocol.HTTP.DAV
 import qualified Data.Map as M
@@ -126,12 +126,9 @@ retrieve r k _f d = metered Nothing k $ \meterupdate ->
 	feeder user pass (url:urls) = do
 		mb <- davGetUrlContent url user pass
 		case mb of
-			Nothing -> throwDownloadFailed
+			Nothing -> throwIO "download failed"
 			Just b -> return (urls, L.toChunks b)
 
-throwDownloadFailed :: IO a
-throwDownloadFailed = ioError $ mkIOError userErrorType "download failed" Nothing Nothing
-
 retrieveEncrypted :: Remote -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
 retrieveEncrypted r (cipher, enck) k d = metered Nothing k $ \meterupdate ->
 	davAction r False $ \(baseurl, user, pass) -> liftIO $ catchBoolIO $
@@ -146,7 +143,7 @@ retrieveEncrypted r (cipher, enck) k d = metered Nothing k $ \meterupdate ->
 	feeder user pass (url:urls) c = do
 		mb <- davGetUrlContent url user pass
 		case mb of
-			Nothing -> throwDownloadFailed
+			Nothing -> throwIO "download failed"
 			Just b -> feeder user pass urls (b:c)
 
 remove :: Remote -> Key -> Annex Bool
@@ -228,9 +225,7 @@ davUrlExists url user pass = decode <$> catchHttp (getProps url user pass)
 	decode (Right _) = Right True
 	decode (Left (Left (StatusCodeException status _)))
 		| statusCode status == statusCode notFound404 = Right False
-		| otherwise = Left $ show $ statusMessage status
+	decode (Left e) = Left $ showEitherException e
-	decode (Left (Left httpexception)) = Left $ show httpexception
-	decode (Left (Right ioexception)) = Left $ show ioexception
 
 davGetUrlContent :: DavUrl -> DavUser -> DavPass -> IO  (Maybe L.ByteString)
 davGetUrlContent url user pass = fmap (snd . snd) <$>
@@ -266,27 +261,40 @@ catchMaybeHttp a = (Just <$> a) `E.catches`
 	]
 
 {- Catches HTTP and IO exceptions -}
-catchHttp :: IO a -> IO (Either (Either HttpException E.IOException) a)
+catchHttp :: IO a -> IO (Either EitherException a)
 catchHttp a = (Right <$> a) `E.catches`
 	[ E.Handler $ \(e :: HttpException) -> return $ Left $ Left e
 	, E.Handler $ \(e :: E.IOException) -> return $ Left $ Right e
 	]
 
+type EitherException = Either HttpException E.IOException
+
+showEitherException :: EitherException -> String
+showEitherException (Left (StatusCodeException status _)) = show $ statusMessage status
+showEitherException (Left httpexception) = show httpexception
+showEitherException (Right ioexception) = show ioexception
+
+throwIO :: String -> IO a
+throwIO msg = ioError $ mkIOError userErrorType msg Nothing Nothing
+
 urlParent :: DavUrl -> DavUrl
 urlParent url = reverse $ dropWhile (== '/') $ reverse $
 	normalizePathSegments (url ++ "/..")
 
 {- Test if a WebDAV store is usable, by writing to a test file, and then
- - deleting the file. Exits with an error if not. -}
+ - deleting the file. Exits with an IO error if not. -}
 testDav :: String -> Maybe CredPair -> Annex ()
 testDav baseurl (Just (u, p)) = do
 	showSideAction "testing WebDAV server"
-	liftIO $ do
+	liftIO $ either (throwIO . showEitherException) (const noop)
+		=<< catchHttp go
+  where
+	go = do
 		davMkdir baseurl user pass
 		putContentAndProps testurl user pass
 			(noProps, (contentType, L.empty))
 		deleteContent testurl user pass
-  where
+
 	user = toDavUser u
 	pass = toDavPass p
 	testurl = davUrl baseurl "git-annex-test"
@@ -318,3 +326,6 @@ davCreds u = CredPairStorage
         , credPairEnvironment = ("WEBDAV_USERNAME", "WEBDAV_PASSWORD")
         , credPairRemoteKey = Just "davcreds"
         }
+
+setCredsEnv :: (String, String) -> IO ()
+setCredsEnv creds = setEnvCredPair creds $ davCreds undefined

templates/configurators/addbox.com.hamlet

@@ -0,0 +1,26 @@
+<div .span9 .hero-unit>
+  <h2>
+    Adding a Box.com repository
+  <p>
+    <a href="http://box.com">Box.com</a> offers a small quantity of storage #
+    for free, and larger quantities for a fee.
+  <p>
+    Even a small amount of free storage is useful, as a transfer point #
+    between your repositories.
+  <p>
+    All data will be encrypted before being sent to Box.com.
+  <p>
+    <form .form-horizontal enctype=#{enctype}>
+      <fieldset>
+        ^{form}
+        ^{authtoken}
+        <div .form-actions>
+          <button .btn .btn-primary type=submit onclick="$('#workingmodal').modal('show');">
+            Add repository
+<div .modal .fade #workingmodal>
+  <div .modal-header>
+    <h3>
+      Making repository ...
+  <div .modal-body>
+    <p>
+      Setting up your Box.com repository. This could take a minute.

templates/configurators/repositories/cloud.hamlet

@@ -16,9 +16,10 @@
   Low cost offline data archival.
 
 <h3>
-  <i .icon-plus-sign></i> Box.com
+  <a href="@{AddBoxComR}">
+    <i .icon-plus-sign></i> Box.com
 <p>
-  Provides free cloud storage for small amounts of data.
+  Provides <b>free</b> cloud storage for small amounts of data.
 
 <h3>
   <a href="@{AddSshR}">