git-annex/Command/DropUnused.hs

{- git-annex command
 -
 - Copyright 2010 Joey Hess <joey@kitenet.net>
 -
 - Licensed under the GNU GPL version 3 or higher.
 -}

module Command.DropUnused where

import qualified Data.Map as M

import Common.Annex
import Command
import qualified Annex
import qualified Command.Drop
import qualified Remote
import qualified Git
import Types.Key

type UnusedMap = M.Map String Key

def :: [Command]
def = [dontCheck fromOpt $ command "dropunused" (paramRepeating paramNumber)
	seek "drop unused file content"]

seek :: [CommandSeek]
seek = [withUnusedMaps]

{- Read unused logs once, and pass the maps to each start action. -}
withUnusedMaps :: CommandSeek
withUnusedMaps params = do
	unused <- readUnusedLog ""
	unusedbad <- readUnusedLog "bad"
	unusedtmp <- readUnusedLog "tmp"
	return $ map (start (unused, unusedbad, unusedtmp)) params

start :: (UnusedMap, UnusedMap, UnusedMap) -> FilePath -> CommandStart
start (unused, unusedbad, unusedtmp) s = search
	[ (unused, perform)
	, (unusedbad, performOther gitAnnexBadLocation)
	, (unusedtmp, performOther gitAnnexTmpLocation)
	]
	where
		search [] = stop
		search ((m, a):rest) =
			case M.lookup s m of
				Nothing -> search rest
				Just key -> do
					showStart "dropunused" s
					next $ a key

perform :: Key -> CommandPerform
perform key = maybe droplocal dropremote =<< Annex.getState Annex.fromremote
	where
		dropremote name = do
			r <- Remote.byName name
			showAction $ "from " ++ Remote.name r
			next $ Command.Drop.cleanupRemote key r
		droplocal = Command.Drop.performLocal key (Just 0) -- force drop

performOther :: (Git.Repo -> Key -> FilePath) -> Key -> CommandPerform
performOther filespec key = do
	g <- gitRepo
	let f = filespec g key
	liftIO $ whenM (doesFileExist f) $ removeFile f
	next $ return True

readUnusedLog :: FilePath -> Annex UnusedMap
readUnusedLog prefix = do
	g <- gitRepo
	let f = gitAnnexUnusedLog prefix g
	e <- liftIO $ doesFileExist f
	if e
		then M.fromList . map parse . lines <$> liftIO (readFile f)
		else return M.empty
	where
		parse line = (head ws, fromJust $ readKey $ unwords $ tail ws)
			where
				ws = words line