[Lsb-messages] /var/www/bzr/lsb/devel/repogen r209: Really archive non-symlink files when migrating packages in the FTP dir.

Jeff Licquia licquia at linuxfoundation.org
Wed Jun 19 21:05:40 UTC 2013


------------------------------------------------------------
revno: 209
committer: Jeff Licquia <licquia at linuxfoundation.org>
branch nick: repogen
timestamp: Wed 2013-06-19 14:05:40 -0700
message:
  Really archive non-symlink files when migrating packages in the FTP dir.
modified:
  migrate-pkg.hs
-------------- next part --------------
=== modified file 'migrate-pkg.hs'
--- a/migrate-pkg.hs	2013-06-17 20:41:44 +0000
+++ b/migrate-pkg.hs	2013-06-19 21:05:40 +0000
@@ -63,10 +63,28 @@
 
 -- Archive the given file.
 
+findArchiveDir :: FilePath -> IO (Maybe FilePath)
+findArchiveDir "/" = return Nothing
+findArchiveDir p = do
+    let archivePath = p </> "archive"
+    archiveExist <- doesDirectoryExist archivePath
+    if archiveExist then return $ Just archivePath
+                    else findArchiveDir $ takeDirectory p
+
 archiveFile :: FilePath -> IO ()
 archiveFile f = do
-    putStrLn $ "removing " ++ f
-    removeFile f
+    symlink <- liftM isSymbolicLink $ getFileStatus f
+    if symlink then do
+        putStrLn $ "removing " ++ f
+        removeFile f
+    else do
+        maybeArchiveDest <- findArchiveDir f
+        if isJust maybeArchiveDest
+            then do
+                let archiveDest = fromJust maybeArchiveDest
+                putStrLn $ "archiving " ++ f ++ " to " ++ archiveDest
+                renameFile f $ archiveDest </> (takeFileName f)
+            else hPutStrLn stderr $ "warning: could not find archive dir, not changing " ++ f
 
 -- Identical packages are equivalent, but we don't want to pick them up.
 



More information about the lsb-messages mailing list