diff options
| -rw-r--r-- | Assistant/Upgrade.hs | 2 | ||||
| -rw-r--r-- | Build/DistributionUpdate.hs | 3 | ||||
| -rw-r--r-- | Command/Info.hs | 4 | ||||
| -rw-r--r-- | Logs/Transfer.hs | 15 | ||||
| -rw-r--r-- | Types/Distribution.hs | 42 | ||||
| -rw-r--r-- | Types/Transfer.hs | 14 |
6 files changed, 59 insertions, 21 deletions
diff --git a/Assistant/Upgrade.hs b/Assistant/Upgrade.hs index f91fde06c..a2f6f9e0a 100644 --- a/Assistant/Upgrade.hs +++ b/Assistant/Upgrade.hs @@ -324,7 +324,7 @@ downloadDistributionInfo = do ifM (Url.downloadQuiet distributionInfoUrl infof uo <&&> Url.downloadQuiet distributionInfoSigUrl sigf uo <&&> verifyDistributionSig gpgcmd sigf) - ( readish <$> readFileStrict infof + ( parseInfoFile <$> readFileStrict infof , return Nothing ) diff --git a/Build/DistributionUpdate.hs b/Build/DistributionUpdate.hs index dd18a7883..e026d655b 100644 --- a/Build/DistributionUpdate.hs +++ b/Build/DistributionUpdate.hs @@ -119,13 +119,14 @@ makeinfos updated version = do Just k -> whenM (inAnnex k) $ do liftIO $ putStrLn f let infofile = f ++ ".info" - liftIO $ writeFile infofile $ show $ GitAnnexDistribution + let d = GitAnnexDistribution { distributionUrl = mkUrl f , distributionKey = k , distributionVersion = bv , distributionReleasedate = now , distributionUrgentUpgrade = Nothing } + liftIO $ writeFile infofile $ formatInfoFile d void $ inRepo $ runBool [Param "add", File infofile] signFile infofile signFile f diff --git a/Command/Info.hs b/Command/Info.hs index 835a8498d..aaee08fe1 100644 --- a/Command/Info.hs +++ b/Command/Info.hs @@ -419,14 +419,14 @@ transfer_list = stat desc $ nojson $ lift $ do where desc = "transfers in progress" line uuidmap t i = unwords - [ showLcDirection (transferDirection t) ++ "ing" + [ formatDirection (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 ] jsonify t i = object $ map (\(k, v) -> (T.pack k, v)) $ - [ ("transfer", toJSON (showLcDirection (transferDirection t))) + [ ("transfer", toJSON (formatDirection (transferDirection t))) , ("key", toJSON (key2file (transferKey t))) , ("file", toJSON (associatedFile i)) , ("remote", toJSON (fromUUID (transferUUID t))) diff --git a/Logs/Transfer.hs b/Logs/Transfer.hs index 903db96fe..ce2a7d299 100644 --- a/Logs/Transfer.hs +++ b/Logs/Transfer.hs @@ -23,15 +23,6 @@ import Data.Time.Clock import Data.Time.Clock.POSIX import Control.Concurrent -showLcDirection :: Direction -> String -showLcDirection Upload = "upload" -showLcDirection Download = "download" - -readLcDirection :: String -> Maybe Direction -readLcDirection "upload" = Just Upload -readLcDirection "download" = Just Download -readLcDirection _ = Nothing - describeTransfer :: Transfer -> TransferInfo -> String describeTransfer t info = unwords [ show $ transferDirection t @@ -212,7 +203,7 @@ parseTransferFile file | "lck." `isPrefixOf` takeFileName file = Nothing | otherwise = case drop (length bits - 3) bits of [direction, u, key] -> Transfer - <$> readLcDirection direction + <$> parseDirection direction <*> pure (toUUID u) <*> fileKey key _ -> Nothing @@ -279,14 +270,14 @@ readTransferInfo mpid s = TransferInfo {- The directory holding transfer information files for a given Direction. -} transferDir :: Direction -> Git.Repo -> FilePath -transferDir direction r = gitAnnexTransferDir r </> showLcDirection direction +transferDir direction r = gitAnnexTransferDir r </> formatDirection direction {- The directory holding failed transfer information files for a given - Direction and UUID -} failedTransferDir :: UUID -> Direction -> Git.Repo -> FilePath failedTransferDir u direction r = gitAnnexTransferDir r </> "failed" - </> showLcDirection direction + </> formatDirection direction </> filter (/= '/') (fromUUID u) prop_read_write_transferinfo :: TransferInfo -> Bool diff --git a/Types/Distribution.hs b/Types/Distribution.hs index d4de7a79b..a7e2f4c95 100644 --- a/Types/Distribution.hs +++ b/Types/Distribution.hs @@ -1,16 +1,22 @@ {- Data type for a distribution of git-annex - - - Copyright 2013 Joey Hess <id@joeyh.name> + - Copyright 2013, 2017 Joey Hess <id@joeyh.name> - - Licensed under the GNU GPL version 3 or higher. -} module Types.Distribution where +import Utility.PartialPrelude import Types.Key +import Key import Data.Time.Clock import Git.Config (isTrue, boolConfig) +import Data.String.Utils + +type GitAnnexVersion = String + data GitAnnexDistribution = GitAnnexDistribution { distributionUrl :: String , distributionKey :: Key @@ -20,7 +26,39 @@ data GitAnnexDistribution = GitAnnexDistribution } deriving (Read, Show, Eq) -type GitAnnexVersion = String +{- The first line of the info file is in the format old versions of + - git-annex expect to read a GitAnnexDistribution. + - The remainder of the file is in the new format. + - This works because old versions of git-annex used readish to parse + - the file, and that ignores the second line. + -} +formatInfoFile :: GitAnnexDistribution -> String +formatInfoFile d = replace "keyVariant = " "keyBackendName = " (show d) ++ + "\n" ++ formatGitAnnexDistribution d + +parseInfoFile :: String -> Maybe GitAnnexDistribution +parseInfoFile s = case lines s of + (_oldformat:rest) -> parseGitAnnexDistribution (unlines rest) + _ -> Nothing + +formatGitAnnexDistribution :: GitAnnexDistribution -> String +formatGitAnnexDistribution d = unlines + [ distributionUrl d + , key2file (distributionKey d) + , distributionVersion d + , show (distributionReleasedate d) + , maybe "" show (distributionUrgentUpgrade d) + ] + +parseGitAnnexDistribution :: String -> Maybe GitAnnexDistribution +parseGitAnnexDistribution s = case lines s of + (u:k:v:d:uu:_) -> GitAnnexDistribution + <$> pure u + <*> file2key k + <*> pure v + <*> readish d + <*> pure (readish uu) + _ -> Nothing data AutoUpgrade = AskUpgrade | AutoUpgrade | NoAutoUpgrade deriving (Eq) diff --git a/Types/Transfer.hs b/Types/Transfer.hs index 1920bc73b..349eccf4b 100644 --- a/Types/Transfer.hs +++ b/Types/Transfer.hs @@ -16,8 +16,7 @@ import Control.Concurrent import Control.Applicative import Prelude -{- Enough information to uniquely identify a transfer, used as the filename - - of the transfer information file. -} +{- Enough information to uniquely identify a transfer. -} data Transfer = Transfer { transferDirection :: Direction , transferUUID :: UUID @@ -46,7 +45,16 @@ stubTransferInfo :: TransferInfo stubTransferInfo = TransferInfo Nothing Nothing Nothing Nothing Nothing Nothing False data Direction = Upload | Download - deriving (Eq, Ord, Read, Show) + deriving (Eq, Ord, Show, Read) + +formatDirection :: Direction -> String +formatDirection Upload = "upload" +formatDirection Download = "download" + +parseDirection :: String -> Maybe Direction +parseDirection "upload" = Just Upload +parseDirection "download" = Just Download +parseDirection _ = Nothing instance Arbitrary TransferInfo where arbitrary = TransferInfo |