summaryrefslogtreecommitdiff
path: root/Remote/Web.hs
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2011-07-01 17:15:46 -0400
committerGravatar Joey Hess <joey@kitenet.net>2011-07-01 17:15:46 -0400
commit6bddebdb79ca8ed168e143d533a6101c7d469628 (patch)
treefdcd6745973e01e5dcbd1ae4ebd591e92a4046ff /Remote/Web.hs
parenta140f7148f3ea0bef2d8c060c7847b3d1be4d25e (diff)
add the addurl command
Diffstat (limited to 'Remote/Web.hs')
-rw-r--r--Remote/Web.hs69
1 files changed, 42 insertions, 27 deletions
diff --git a/Remote/Web.hs b/Remote/Web.hs
index 201f923cf..342acef91 100644
--- a/Remote/Web.hs
+++ b/Remote/Web.hs
@@ -6,7 +6,9 @@
-}
module Remote.Web (
- remote
+ remote,
+ setUrl,
+ download
) where
import Control.Monad.State (liftIO)
@@ -20,11 +22,13 @@ import Network.Curl.Code
import Types
import Types.Remote
import qualified Git
+import qualified Annex
import Messages
import Utility
import UUID
import Config
import PresenceLog
+import LocationLog
remote :: RemoteType Annex
remote = RemoteType {
@@ -50,10 +54,10 @@ gen r _ _ =
uuid = webUUID,
cost = expensiveRemoteCost,
name = Git.repoDescribe r,
- storeKey = upload,
- retrieveKeyFile = download,
- removeKey = remove,
- hasKey = check,
+ storeKey = uploadKey,
+ retrieveKeyFile = downloadKey,
+ removeKey = dropKey,
+ hasKey = checkKey,
hasKeyCheap = False,
config = Nothing
}
@@ -62,40 +66,44 @@ gen r _ _ =
urlLog :: Key -> FilePath
urlLog key = "remote/web" </> show key ++ ".log"
-urls :: Key -> Annex [URLString]
-urls key = currentLog (urlLog key)
+getUrls :: Key -> Annex [URLString]
+getUrls key = currentLog (urlLog key)
-download :: Key -> FilePath -> Annex Bool
-download key file = download' file =<< urls key
-download' :: FilePath -> [URLString] -> Annex Bool
-download' _ [] = return False
-download' file (url:us) = do
- showProgress -- make way for curl progress bar
- ok <- liftIO $ boolSystem "curl" [Params "-# -o", File file, File url]
- if ok then return ok else download' file us
+{- Records a change in an url for a key. -}
+setUrl :: Key -> URLString -> LogStatus -> Annex ()
+setUrl key url status = do
+ g <- Annex.gitRepo
+ addLog (urlLog key) =<< logNow status url
+
+ -- update location log to indicate that the web has the key, or not
+ us <- getUrls key
+ logChange g key webUUID (if null us then InfoMissing else InfoPresent)
+
+downloadKey :: Key -> FilePath -> Annex Bool
+downloadKey key file = download file =<< getUrls key
-upload :: Key -> Annex Bool
-upload _ = do
+uploadKey :: Key -> Annex Bool
+uploadKey _ = do
warning "upload to web not supported"
return False
-remove :: Key -> Annex Bool
-remove _ = do
+dropKey :: Key -> Annex Bool
+dropKey _ = do
warning "removal from web not supported"
return False
-check :: Key -> Annex (Either IOException Bool)
-check key = do
- us <- urls key
+checkKey :: Key -> Annex (Either IOException Bool)
+checkKey key = do
+ us <- getUrls key
if null us
then return $ Right False
- else return . Right =<< check' us
-check' :: [URLString] -> Annex Bool
-check' [] = return False
-check' (u:us) = do
+ else return . Right =<< checkKey' us
+checkKey' :: [URLString] -> Annex Bool
+checkKey' [] = return False
+checkKey' (u:us) = do
showNote ("checking " ++ u)
e <- liftIO $ urlexists u
- if e then return e else check' us
+ if e then return e else checkKey' us
urlexists :: URLString -> IO Bool
urlexists url = do
@@ -105,3 +113,10 @@ urlexists url = do
_ <- setopt curl (CurlFailOnError True)
res <- perform curl
return $ res == CurlOK
+
+download :: FilePath -> [URLString] -> Annex Bool
+download _ [] = return False
+download file (url:us) = do
+ showProgress -- make way for curl progress bar
+ ok <- liftIO $ boolSystem "curl" [Params "-# -o", File file, File url]
+ if ok then return ok else download file us