diff options
| -rw-r--r-- | Assistant/WebApp.hs | 5 | ||||
| -rw-r--r-- | Assistant/WebApp/DashBoard.hs | 36 | ||||
| -rw-r--r-- | Assistant/WebApp/routes | 4 | ||||
| -rw-r--r-- | Command/AddUnused.hs | 3 | ||||
| -rw-r--r-- | Command/DropKey.hs | 3 | ||||
| -rw-r--r-- | Command/Find.hs | 2 | ||||
| -rw-r--r-- | Command/FromKey.hs | 2 | ||||
| -rw-r--r-- | Command/Fsck.hs | 5 | ||||
| -rw-r--r-- | Command/ReKey.hs | 2 | ||||
| -rw-r--r-- | Command/Status.hs | 4 | ||||
| -rw-r--r-- | Command/Sync.hs | 5 | ||||
| -rw-r--r-- | Command/Unused.hs | 3 | ||||
| -rw-r--r-- | Crypto.hs | 2 | ||||
| -rw-r--r-- | Locations.hs | 8 | ||||
| -rw-r--r-- | Logs/Transfer.hs | 22 | ||||
| -rw-r--r-- | Logs/Unused.hs | 4 | ||||
| -rw-r--r-- | Logs/Web.hs | 3 | ||||
| -rw-r--r-- | Remote/Bup.hs | 3 | ||||
| -rw-r--r-- | Remote/Git.hs | 6 | ||||
| -rw-r--r-- | Remote/Hook.hs | 5 | ||||
| -rw-r--r-- | Remote/S3.hs | 2 | ||||
| -rw-r--r-- | Seek.hs | 2 | ||||
| -rw-r--r-- | Types/Key.hs | 35 | ||||
| -rw-r--r-- | Types/UUID.hs | 2 | ||||
| -rw-r--r-- | Upgrade/V1.hs | 2 | ||||
| -rw-r--r-- | templates/dashboard/transfers.hamlet | 8 | ||||
| -rw-r--r-- | test.hs | 8 |
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 @@ -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 @@ -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 → @@ -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> @@ -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" |