summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--Assistant/WebApp.hs5
-rw-r--r--Assistant/WebApp/DashBoard.hs36
-rw-r--r--Assistant/WebApp/routes4
-rw-r--r--Command/AddUnused.hs3
-rw-r--r--Command/DropKey.hs3
-rw-r--r--Command/Find.hs2
-rw-r--r--Command/FromKey.hs2
-rw-r--r--Command/Fsck.hs5
-rw-r--r--Command/ReKey.hs2
-rw-r--r--Command/Status.hs4
-rw-r--r--Command/Sync.hs5
-rw-r--r--Command/Unused.hs3
-rw-r--r--Crypto.hs2
-rw-r--r--Locations.hs8
-rw-r--r--Logs/Transfer.hs22
-rw-r--r--Logs/Unused.hs4
-rw-r--r--Logs/Web.hs3
-rw-r--r--Remote/Bup.hs3
-rw-r--r--Remote/Git.hs6
-rw-r--r--Remote/Hook.hs5
-rw-r--r--Remote/S3.hs2
-rw-r--r--Seek.hs2
-rw-r--r--Types/Key.hs35
-rw-r--r--Types/UUID.hs2
-rw-r--r--Upgrade/V1.hs2
-rw-r--r--templates/dashboard/transfers.hamlet8
-rw-r--r--test.hs8
27 files changed, 118 insertions, 68 deletions
diff --git a/Assistant/WebApp.hs b/Assistant/WebApp.hs
index aa0834535..5bb2339b3 100644
--- a/Assistant/WebApp.hs
+++ b/Assistant/WebApp.hs
@@ -19,6 +19,7 @@ import Assistant.Alert
import Utility.NotificationBroadcaster
import Utility.WebApp
import Utility.Yesod
+import Logs.Transfer
import Yesod
import Yesod.Static
@@ -154,6 +155,10 @@ instance PathPiece AlertId where
toPathPiece = pack . show
fromPathPiece = readish . unpack
+instance PathPiece Transfer where
+ toPathPiece = pack . show
+ fromPathPiece = readish . unpack
+
{- Adds the auth parameter as a hidden field on a form. Must be put into
- every form. -}
webAppFormAuthToken :: Widget
diff --git a/Assistant/WebApp/DashBoard.hs b/Assistant/WebApp/DashBoard.hs
index 8e526fb1d..57d789831 100644
--- a/Assistant/WebApp/DashBoard.hs
+++ b/Assistant/WebApp/DashBoard.hs
@@ -42,13 +42,18 @@ transfersDisplay warnNoScript = do
queued <- liftIO $ getTransferQueue $ transferQueue webapp
let ident = "transfers"
autoUpdate ident NotifierTransfersR (10 :: Int) (10 :: Int)
- let transfers = current ++ queued
+ let transfers = current ++ queued ++ dummy
if null transfers
then ifM (lift $ showIntro <$> getWebAppState)
( introDisplay ident
, $(widgetFile "dashboard/transfers")
)
else $(widgetFile "dashboard/transfers")
+ where
+ dummy = [(t, i), (t, i)]
+ t = Transfer Download (UUID "00000000-0000-0000-0000-000000000001") k
+ k = Types.Key.Key "foo" "bar" Nothing Nothing
+ i = TransferInfo Nothing Nothing Nothing Nothing Nothing Nothing
{- Called by client to get a display of currently in process transfers.
-
@@ -98,7 +103,10 @@ postFileBrowserR = void openFileBrowser
{- Used by non-javascript browsers, where clicking on the link actually
- opens this page, so we redirect back to the referrer. -}
getFileBrowserR :: Handler ()
-getFileBrowserR = whenM openFileBrowser $ do
+getFileBrowserR = whenM openFileBrowser $ redirectBack
+
+redirectBack :: Handler ()
+redirectBack = do
clearUltDest
setUltDestReferer
redirectUltDest HomeR
@@ -130,3 +138,27 @@ openFileBrowser = do
#else
cmd = "xdg-open"
#endif
+
+{- Transfer controls. The GET is done in noscript mode and redirects back
+ - to the referring page. The POST is called by javascript. -}
+getPauseTransferR :: Transfer -> Handler ()
+getPauseTransferR t = pauseTransfer t >> redirectBack
+postPauseTransferR :: Transfer -> Handler ()
+postPauseTransferR t = pauseTransfer t
+getStartTransferR :: Transfer -> Handler ()
+getStartTransferR t = startTransfer t >> redirectBack
+postStartTransferR :: Transfer -> Handler ()
+postStartTransferR t = startTransfer t
+getCancelTransferR :: Transfer -> Handler ()
+getCancelTransferR t = cancelTransfer t >> redirectBack
+postCancelTransferR :: Transfer -> Handler ()
+postCancelTransferR t = cancelTransfer t
+
+pauseTransfer :: Transfer -> Handler ()
+pauseTransfer t = liftIO $ putStrLn "pause"
+
+startTransfer :: Transfer -> Handler ()
+startTransfer t = liftIO $ putStrLn "start"
+
+cancelTransfer :: Transfer -> Handler ()
+cancelTransfer t = liftIO $ putStrLn "cancel"
diff --git a/Assistant/WebApp/routes b/Assistant/WebApp/routes
index 60f56cf14..e3e7daf87 100644
--- a/Assistant/WebApp/routes
+++ b/Assistant/WebApp/routes
@@ -15,4 +15,8 @@
/closealert/#AlertId CloseAlert GET
/filebrowser FileBrowserR GET POST
+/transfer/pause/#Transfer PauseTransferR GET POST
+/transfer/start/#Transfer StartTransferR GET POST
+/transfer/cancel/#Transfer CancelTransferR GET POST
+
/static StaticR Static getStatic
diff --git a/Command/AddUnused.hs b/Command/AddUnused.hs
index c498216dc..f70500354 100644
--- a/Command/AddUnused.hs
+++ b/Command/AddUnused.hs
@@ -11,6 +11,7 @@ import Common.Annex
import Logs.Unused
import Command
import qualified Command.Add
+import Types.Key
def :: [Command]
def = [command "addunused" (paramRepeating paramNumRange)
@@ -25,7 +26,7 @@ start = startUnused "addunused" perform (performOther "bad") (performOther "tmp"
perform :: Key -> CommandPerform
perform key = next $ Command.Add.cleanup file key True
where
- file = "unused." ++ show key
+ file = "unused." ++ key2file key
{- The content is not in the annex, but in another directory, and
- it seems better to error out, rather than moving bad/tmp content into
diff --git a/Command/DropKey.hs b/Command/DropKey.hs
index 68fdbfdd9..d55c5e83a 100644
--- a/Command/DropKey.hs
+++ b/Command/DropKey.hs
@@ -12,6 +12,7 @@ import Command
import qualified Annex
import Logs.Location
import Annex.Content
+import Types.Key
def :: [Command]
def = [oneShot $ command "dropkey" (paramRepeating paramKey) seek
@@ -24,7 +25,7 @@ start :: Key -> CommandStart
start key = stopUnless (inAnnex key) $ do
unlessM (Annex.getState Annex.force) $
error "dropkey can cause data loss; use --force if you're sure you want to do this"
- showStart "dropkey" (show key)
+ showStart "dropkey" (key2file key)
next $ perform key
perform :: Key -> CommandPerform
diff --git a/Command/Find.hs b/Command/Find.hs
index e568c3510..177b794cd 100644
--- a/Command/Find.hs
+++ b/Command/Find.hs
@@ -53,7 +53,7 @@ start format file (key, _) = do
where
vars =
[ ("file", file)
- , ("key", show key)
+ , ("key", key2file key)
, ("backend", keyBackendName key)
, ("bytesize", size show)
, ("humansize", size $ roughSize storageUnits True)
diff --git a/Command/FromKey.hs b/Command/FromKey.hs
index f7841c977..f998fe1e6 100644
--- a/Command/FromKey.hs
+++ b/Command/FromKey.hs
@@ -22,7 +22,7 @@ seek = [withWords start]
start :: [String] -> CommandStart
start (keyname:file:[]) = notBareRepo $ do
- let key = fromMaybe (error "bad key") $ readKey keyname
+ let key = fromMaybe (error "bad key") $ file2key keyname
inbackend <- inAnnex key
unless inbackend $ error $
"key ("++ keyname ++") is not present in backend"
diff --git a/Command/Fsck.hs b/Command/Fsck.hs
index 0e3cc934c..89ba0eef8 100644
--- a/Command/Fsck.hs
+++ b/Command/Fsck.hs
@@ -26,6 +26,7 @@ import Utility.DataUnits
import Utility.FileMode
import Config
import qualified Option
+import Types.Key
def :: [Command]
def = [withOptions options $ command "fsck" paramPaths seek
@@ -114,7 +115,7 @@ startBare :: Key -> CommandStart
startBare key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName key) of
Nothing -> stop
Just backend -> do
- showStart "fsck" (show key)
+ showStart "fsck" (key2file key)
next $ performBare key backend
{- Note that numcopies cannot be checked in a bare repository, because
@@ -122,7 +123,7 @@ startBare key = case Backend.maybeLookupBackendName (Types.Key.keyBackendName ke
- files. -}
performBare :: Key -> Backend -> CommandPerform
performBare key backend = check
- [ verifyLocationLog key (show key)
+ [ verifyLocationLog key (key2file key)
, checkKeySize key
, checkBackend backend key
]
diff --git a/Command/ReKey.hs b/Command/ReKey.hs
index 6de7e45e3..5bd419ca3 100644
--- a/Command/ReKey.hs
+++ b/Command/ReKey.hs
@@ -26,7 +26,7 @@ seek = [withPairs start]
start :: (FilePath, String) -> CommandStart
start (file, keyname) = ifAnnexed file go stop
where
- newkey = fromMaybe (error "bad key") $ readKey keyname
+ newkey = fromMaybe (error "bad key") $ file2key keyname
go (oldkey, _)
| oldkey == newkey = stop
| otherwise = do
diff --git a/Command/Status.hs b/Command/Status.hs
index 2d63c525c..7bb4dc8ca 100644
--- a/Command/Status.hs
+++ b/Command/Status.hs
@@ -183,8 +183,8 @@ transfer_list = stat "transfers in progress" $ nojson $ lift $ do
pp _ c [] = c
pp uuidmap c ((t, i):xs) = "\n\t" ++ line uuidmap t i ++ pp uuidmap c xs
line uuidmap t i = unwords
- [ show (transferDirection t) ++ "ing"
- , fromMaybe (show $ transferKey t) (associatedFile i)
+ [ showLcDirection (transferDirection t) ++ "ing"
+ , fromMaybe (key2file $ transferKey t) (associatedFile i)
, if transferDirection t == Upload then "to" else "from"
, maybe (fromUUID $ transferUUID t) Remote.name $
M.lookup (transferUUID t) uuidmap
diff --git a/Command/Sync.hs b/Command/Sync.hs
index ab29c82b6..f40a2f621 100644
--- a/Command/Sync.hs
+++ b/Command/Sync.hs
@@ -25,6 +25,7 @@ import qualified Git
import Git.Types (BlobType(..))
import qualified Types.Remote
import qualified Remote.Git
+import Types.Key
import qualified Data.Map as M
import qualified Data.ByteString.Lazy as L
@@ -260,8 +261,8 @@ resolveMerge' u
-}
mergeFile :: FilePath -> Key -> FilePath
mergeFile file key
- | doubleconflict = go $ show key
- | otherwise = go $ shortHash $ show key
+ | doubleconflict = go $ key2file key
+ | otherwise = go $ shortHash $ key2file key
where
varmarker = ".variant-"
doubleconflict = varmarker `isSuffixOf` (dropExtension file)
diff --git a/Command/Unused.hs b/Command/Unused.hs
index 09b4be5df..39a7a59cf 100644
--- a/Command/Unused.hs
+++ b/Command/Unused.hs
@@ -34,6 +34,7 @@ import qualified Remote
import qualified Annex.Branch
import qualified Option
import Annex.CatFile
+import Types.Key
def :: [Command]
def = [withOptions [fromOption] $ command "unused" paramNothing seek
@@ -100,7 +101,7 @@ number n (x:xs) = (n+1, x) : number (n+1) xs
table :: [(Int, Key)] -> [String]
table l = " NUMBER KEY" : map cols l
where
- cols (n,k) = " " ++ pad 6 (show n) ++ " " ++ show k
+ cols (n,k) = " " ++ pad 6 (show n) ++ " " ++ key2file k
pad n s = s ++ replicate (n - length s) ' '
staleTmpMsg :: [(Int, Key)] -> String
diff --git a/Crypto.hs b/Crypto.hs
index 01322c403..3387be142 100644
--- a/Crypto.hs
+++ b/Crypto.hs
@@ -112,7 +112,7 @@ decryptCipher (EncryptedCipher t _) = Cipher <$> Gpg.pipeStrict decrypt t
- on content. It does need to be repeatable. -}
encryptKey :: Cipher -> Key -> Key
encryptKey c k = Key
- { keyName = hmacWithCipher c (show k)
+ { keyName = hmacWithCipher c (key2file k)
, keyBackendName = "GPGHMACSHA1"
, keySize = Nothing -- size and mtime omitted
, keyMtime = Nothing -- to avoid leaking data
diff --git a/Locations.hs b/Locations.hs
index cbd1e11ae..2606bef27 100644
--- a/Locations.hs
+++ b/Locations.hs
@@ -199,7 +199,7 @@ isLinkToAnnex s = ('/':d) `isInfixOf` s || d `isPrefixOf` s
-}
keyFile :: Key -> FilePath
keyFile key = replace "/" "%" $ replace ":" "&c" $
- replace "%" "&s" $ replace "&" "&a" $ show key
+ replace "%" "&s" $ replace "&" "&a" $ key2file key
{- A location to store a key on the filesystem. A directory hash is used,
- to protect against filesystems that dislike having many items in a
@@ -220,7 +220,7 @@ keyPaths key = map (keyPath key) annexHashes
{- Reverses keyFile, converting a filename fragment (ie, the basename of
- the symlink target) into a key. -}
fileKey :: FilePath -> Maybe Key
-fileKey file = readKey $
+fileKey file = file2key $
replace "&a" "&" $ replace "&s" "%" $
replace "&c" ":" $ replace "%" "/" file
@@ -242,12 +242,12 @@ hashDirMixed :: Hasher
hashDirMixed k = addTrailingPathSeparator $ take 2 dir </> drop 2 dir
where
dir = take 4 $ display_32bits_as_dir =<< [a,b,c,d]
- ABCD (a,b,c,d) = md5 $ encodeFilePath $ show k
+ ABCD (a,b,c,d) = md5 $ encodeFilePath $ key2file k
hashDirLower :: Hasher
hashDirLower k = addTrailingPathSeparator $ take 3 dir </> drop 3 dir
where
- dir = take 6 $ md5s $ encodeFilePath $ show k
+ dir = take 6 $ md5s $ encodeFilePath $ key2file k
{- modified version of display_32bits_as_hex from Data.Hash.MD5
- Copyright (C) 2001 Ian Lynagh
diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs
index b7074592e..eb5ab14fe 100644
--- a/Logs/Transfer.hs
+++ b/Logs/Transfer.hs
@@ -30,7 +30,7 @@ data Transfer = Transfer
, transferUUID :: UUID
, transferKey :: Key
}
- deriving (Show, Eq, Ord)
+ deriving (Eq, Ord, Read, Show)
{- Information about a Transfer, stored in the transfer information file.
-
@@ -49,16 +49,16 @@ data TransferInfo = TransferInfo
deriving (Show, Eq, Ord)
data Direction = Upload | Download
- deriving (Eq, Ord)
+ deriving (Eq, Ord, Read, Show)
-instance Show Direction where
- show Upload = "upload"
- show Download = "download"
+showLcDirection :: Direction -> String
+showLcDirection Upload = "upload"
+showLcDirection Download = "download"
-readDirection :: String -> Maybe Direction
-readDirection "upload" = Just Upload
-readDirection "download" = Just Download
-readDirection _ = Nothing
+readLcDirection :: String -> Maybe Direction
+readLcDirection "upload" = Just Upload
+readLcDirection "download" = Just Download
+readLcDirection _ = Nothing
percentComplete :: Transfer -> TransferInfo -> Maybe Percentage
percentComplete (Transfer { transferKey = key }) (TransferInfo { bytesComplete = Just complete }) =
@@ -144,7 +144,7 @@ getTransfers = do
{- The transfer information file to use for a given Transfer. -}
transferFile :: Transfer -> Git.Repo -> FilePath
transferFile (Transfer direction u key) r = gitAnnexTransferDir r
- </> show direction
+ </> showLcDirection direction
</> fromUUID u
</> keyFile key
@@ -159,7 +159,7 @@ parseTransferFile file
| "lck." `isPrefixOf` (takeFileName file) = Nothing
| otherwise = case drop (length bits - 3) bits of
[direction, u, key] -> Transfer
- <$> readDirection direction
+ <$> readLcDirection direction
<*> pure (toUUID u)
<*> fileKey key
_ -> Nothing
diff --git a/Logs/Unused.hs b/Logs/Unused.hs
index 7d240cfe3..522c523af 100644
--- a/Logs/Unused.hs
+++ b/Logs/Unused.hs
@@ -25,7 +25,7 @@ writeUnusedLog :: FilePath -> [(Int, Key)] -> Annex ()
writeUnusedLog prefix l = do
logfile <- fromRepo $ gitAnnexUnusedLog prefix
liftIO $ viaTmp writeFile logfile $
- unlines $ map (\(n, k) -> show n ++ " " ++ show k) l
+ unlines $ map (\(n, k) -> show n ++ " " ++ key2file k) l
readUnusedLog :: FilePath -> Annex UnusedMap
readUnusedLog prefix = do
@@ -37,7 +37,7 @@ readUnusedLog prefix = do
)
where
parse line =
- case (readish tag, readKey rest) of
+ case (readish tag, file2key rest) of
(Just num, Just key) -> Just (num, key)
_ -> Nothing
where
diff --git a/Logs/Web.hs b/Logs/Web.hs
index 607c81c5b..534bd5345 100644
--- a/Logs/Web.hs
+++ b/Logs/Web.hs
@@ -16,6 +16,7 @@ module Logs.Web (
import Common.Annex
import Logs.Presence
import Logs.Location
+import Types.Key
type URLString = String
@@ -29,7 +30,7 @@ urlLog key = hashDirLower key </> keyFile key ++ ".log.web"
{- Used to store the urls elsewhere. -}
oldurlLogs :: Key -> [FilePath]
oldurlLogs key =
- [ "remote/web" </> hashDirLower key </> show key ++ ".log"
+ [ "remote/web" </> hashDirLower key </> key2file key ++ ".log"
, "remote/web" </> hashDirLower key </> keyFile key ++ ".log"
]
diff --git a/Remote/Bup.hs b/Remote/Bup.hs
index 83739a3e1..56b8071ee 100644
--- a/Remote/Bup.hs
+++ b/Remote/Bup.hs
@@ -13,6 +13,7 @@ import System.Process
import Common.Annex
import Types.Remote
+import Types.Key
import qualified Git
import qualified Git.Command
import qualified Git.Config
@@ -243,7 +244,7 @@ bupRef k
| Git.Ref.legal True shown = shown
| otherwise = "git-annex-" ++ showDigest (sha256 (fromString shown))
where
- shown = show k
+ shown = key2file k
bupLocal :: BupRepo -> Bool
bupLocal = notElem ':'
diff --git a/Remote/Git.hs b/Remote/Git.hs
index f42a1d536..f12ef2fc7 100644
--- a/Remote/Git.hs
+++ b/Remote/Git.hs
@@ -183,7 +183,7 @@ inAnnex r key
v -> return v
checkremote = do
showAction $ "checking " ++ Git.repoDescribe r
- onRemote r (check, unknown) "inannex" [Param (show key)] []
+ onRemote r (check, unknown) "inannex" [Param (key2file key)] []
where
check c p = dispatch <$> safeSystem c p
dispatch ExitSuccess = Right True
@@ -228,7 +228,7 @@ dropKey r key
| Git.repoIsHttp r = error "dropping from http repo not supported"
| otherwise = commitOnCleanup r $ onRemote r (boolSystem, False) "dropkey"
[ Params "--quiet --force"
- , Param $ show key
+ , Param $ key2file key
]
[]
@@ -310,7 +310,7 @@ rsyncParamsRemote r sending key file afile = do
: maybe [] (\f -> [(Fields.associatedFile, f)]) afile
Just (shellcmd, shellparams) <- git_annex_shell r
(if sending then "sendkey" else "recvkey")
- [ Param $ show key ]
+ [ Param $ key2file key ]
fields
-- Convert the ssh command into rsync command line.
let eparam = rsyncShell (Param shellcmd:shellparams)
diff --git a/Remote/Hook.hs b/Remote/Hook.hs
index 9af851d14..5856b2a02 100644
--- a/Remote/Hook.hs
+++ b/Remote/Hook.hs
@@ -13,6 +13,7 @@ import System.Environment
import Common.Annex
import Types.Remote
+import Types.Key
import qualified Git
import Config
import Annex.Content
@@ -68,7 +69,7 @@ hookEnv k f = Just <$> mergeenv (fileenv f ++ keyenv)
<$> M.fromList <$> getEnvironment
env s v = ("ANNEX_" ++ s, v)
keyenv =
- [ env "KEY" (show k)
+ [ env "KEY" (key2file k)
, env "HASH_1" (hashbits !! 0)
, env "HASH_2" (hashbits !! 1)
]
@@ -133,7 +134,7 @@ checkPresent r h k = do
v <- lookupHook h "checkpresent"
liftIO $ catchMsgIO $ check v
where
- findkey s = show k `elem` lines s
+ findkey s = key2file k `elem` lines s
check Nothing = error "checkpresent hook misconfigured"
check (Just hook) = do
env <- hookEnv k Nothing
diff --git a/Remote/S3.hs b/Remote/S3.hs
index 6e249ec4d..7dbd096f7 100644
--- a/Remote/S3.hs
+++ b/Remote/S3.hs
@@ -211,7 +211,7 @@ s3Action r noconn action = do
_ -> return noconn
bucketFile :: Remote -> Key -> FilePath
-bucketFile r = munge . show
+bucketFile r = munge . key2file
where
munge s = case M.lookup "mungekeys" $ fromJust $ config r of
Just "ia" -> iaMunge s
diff --git a/Seek.hs b/Seek.hs
index 3306a02fc..0c703a20b 100644
--- a/Seek.hs
+++ b/Seek.hs
@@ -82,7 +82,7 @@ withFilesUnlocked' typechanged a params = do
withKeys :: (Key -> CommandStart) -> CommandSeek
withKeys a params = return $ map (a . parse) params
where
- parse p = fromMaybe (error "bad key") $ readKey p
+ parse p = fromMaybe (error "bad key") $ file2key p
withValue :: Annex v -> (v -> CommandSeek) -> CommandSeek
withValue v a params = do
diff --git a/Types/Key.hs b/Types/Key.hs
index f258f5c4c..619315aed 100644
--- a/Types/Key.hs
+++ b/Types/Key.hs
@@ -10,9 +10,10 @@
module Types.Key (
Key(..),
stubKey,
- readKey,
+ key2file,
+ file2key,
- prop_idempotent_key_read_show
+ prop_idempotent_key_encode
) where
import System.Posix.Types
@@ -26,7 +27,7 @@ data Key = Key {
keyBackendName :: String,
keySize :: Maybe Integer,
keyMtime :: Maybe EpochTime
-} deriving (Eq, Ord)
+} deriving (Eq, Ord, Read, Show)
stubKey :: Key
stubKey = Key {
@@ -39,21 +40,21 @@ stubKey = Key {
fieldSep :: Char
fieldSep = '-'
-{- Keys show as strings that are suitable for use as filenames.
+{- Converts a key to a strings that are suitable for use as a filename.
- The name field is always shown last, separated by doubled fieldSeps,
- and is the only field allowed to contain the fieldSep. -}
-instance Show Key where
- show Key { keyBackendName = b, keySize = s, keyMtime = m, keyName = n } =
- b +++ ('s' ?: s) +++ ('m' ?: m) +++ (fieldSep : n)
- where
- "" +++ y = y
- x +++ "" = x
- x +++ y = x ++ fieldSep:y
- c ?: (Just v) = c : show v
- _ ?: _ = ""
+key2file :: Key -> FilePath
+key2file Key { keyBackendName = b, keySize = s, keyMtime = m, keyName = n } =
+ b +++ ('s' ?: s) +++ ('m' ?: m) +++ (fieldSep : n)
+ where
+ "" +++ y = y
+ x +++ "" = x
+ x +++ y = x ++ fieldSep:y
+ c ?: (Just v) = c : show v
+ _ ?: _ = ""
-readKey :: String -> Maybe Key
-readKey s = if key == Just stubKey then Nothing else key
+file2key :: FilePath -> Maybe Key
+file2key s = if key == Just stubKey then Nothing else key
where
key = startbackend stubKey s
@@ -73,5 +74,5 @@ readKey s = if key == Just stubKey then Nothing else key
addfield 'm' k v = Just k { keyMtime = readish v }
addfield _ _ _ = Nothing
-prop_idempotent_key_read_show :: Key -> Bool
-prop_idempotent_key_read_show k = Just k == (readKey . show) k
+prop_idempotent_key_encode :: Key -> Bool
+prop_idempotent_key_encode k = Just k == (file2key . key2file) k
diff --git a/Types/UUID.hs b/Types/UUID.hs
index 767cd0dfe..88c261b6e 100644
--- a/Types/UUID.hs
+++ b/Types/UUID.hs
@@ -9,7 +9,7 @@ module Types.UUID where
-- A UUID is either an arbitrary opaque string, or UUID info may be missing.
data UUID = NoUUID | UUID String
- deriving (Eq, Ord, Show)
+ deriving (Eq, Ord, Show, Read)
fromUUID :: UUID -> String
fromUUID (UUID u) = u
diff --git a/Upgrade/V1.hs b/Upgrade/V1.hs
index 31c0210c0..b2f2f38c1 100644
--- a/Upgrade/V1.hs
+++ b/Upgrade/V1.hs
@@ -142,7 +142,7 @@ oldlog2key l
-- as the v2 key that it is.
readKey1 :: String -> Key
readKey1 v
- | mixup = fromJust $ readKey $ join ":" $ Prelude.tail bits
+ | mixup = fromJust $ file2key $ join ":" $ Prelude.tail bits
| otherwise = Key
{ keyName = n
, keyBackendName = b
diff --git a/templates/dashboard/transfers.hamlet b/templates/dashboard/transfers.hamlet
index 20d1b5e8a..150dcc296 100644
--- a/templates/dashboard/transfers.hamlet
+++ b/templates/dashboard/transfers.hamlet
@@ -11,7 +11,7 @@
$maybe file <- associatedFile info
#{file}
$nothing
- #{show $ transferKey transfer}
+ #{key2file $ transferKey transfer}
$case transferDirection transfer
$of Upload
&rarr;
@@ -28,10 +28,10 @@
<div .bar style="width: #{percent};">
<div .btn-group .span2>
$if isNothing (startedTime info)
- <button .btn>
+ <a .btn href="@{StartTransferR transfer}" onclick="(function( $ ) { $.post('@{StartTransferR transfer}'); })( jQuery ); return false;">
<i .icon-play title="start"></i>
$else
- <button .btn>
+ <a .btn href="@{PauseTransferR transfer}" onclick="(function( $ ) { $.post('@{PauseTransferR transfer}'); })( jQuery ); return false;">
<i .icon-pause title="pause"></i>
- <button .btn>
+ <a .btn href="@{CancelTransferR transfer}" onclick="(function( $ ) { $.post('@{CancelTransferR transfer}'); })( jQuery ); return false;">
<i .icon-remove title="cancel"></i>
diff --git a/test.hs b/test.hs
index a377057c2..384d02a71 100644
--- a/test.hs
+++ b/test.hs
@@ -77,7 +77,7 @@ quickcheck = TestLabel "quickcheck" $ TestList
[ qctest "prop_idempotent_deencode_git" Git.Filename.prop_idempotent_deencode
, qctest "prop_idempotent_deencode" Utility.Format.prop_idempotent_deencode
, qctest "prop_idempotent_fileKey" Locations.prop_idempotent_fileKey
- , qctest "prop_idempotent_key_read_show" Types.Key.prop_idempotent_key_read_show
+ , qctest "prop_idempotent_key_encode" Types.Key.prop_idempotent_key_encode
, qctest "prop_idempotent_shellEscape" Utility.SafeCommand.prop_idempotent_shellEscape
, qctest "prop_idempotent_shellEscape_multiword" Utility.SafeCommand.prop_idempotent_shellEscape_multiword
, qctest "prop_idempotent_configEscape" Logs.Remote.prop_idempotent_configEscape
@@ -175,7 +175,7 @@ test_reinject = "git-annex reinject/fromkey" ~: TestCase $ intmpclonerepo $ do
writeFile tmp $ content sha1annexedfile
r <- annexeval $ Types.Backend.getKey backendSHA1 $
Types.KeySource.KeySource { Types.KeySource.keyFilename = tmp, Types.KeySource.contentLocation = tmp }
- let key = show $ fromJust r
+ let key = Types.Key.key2file $ fromJust r
git_annex "reinject" [tmp, sha1annexedfile] @? "reinject failed"
git_annex "fromkey" [key, sha1annexedfiledup] @? "fromkey failed"
annexed_present sha1annexedfiledup
@@ -486,7 +486,7 @@ test_unused = "git-annex unused/dropunused" ~: intmpclonerepo $ do
checkunused [annexedfilekey, sha1annexedfilekey]
-- good opportunity to test dropkey also
- git_annex "dropkey" ["--force", show annexedfilekey]
+ git_annex "dropkey" ["--force", Types.Key.key2file annexedfilekey]
@? "dropkey failed"
checkunused [sha1annexedfilekey]
@@ -840,7 +840,7 @@ checklocationlog f expected = do
case r of
Just (k, _) -> do
uuids <- annexeval $ Remote.keyLocations k
- assertEqual ("bad content in location log for " ++ f ++ " key " ++ (show k) ++ " uuid " ++ show thisuuid)
+ assertEqual ("bad content in location log for " ++ f ++ " key " ++ (Types.Key.key2file k) ++ " uuid " ++ show thisuuid)
expected (thisuuid `elem` uuids)
_ -> assertFailure $ f ++ " failed to look up key"
generated by cgit v1.2.3 (git 2.39.1) at 2025-01-04 06:22:37 +0000