SourceTree.hs

-- |Type to represent an unpacked debian source tree.  In order to
-- support Debian's .orig.tar.gz mechanism, the source tree root
-- directory is contained inside another parent directory.
--
-- Author: David Fox
module Linspire.Debian.SourceTree 
    (SourceTree(SourceTreeWithParent, SourceTreeNoParent),
     -- * Accessor
     parent,			-- SourceTree -> FilePath
     path,			-- SourceTree -> FilePath
     -- * Constructors
     -- makeTree,		-- FilePath -> SourceTree
     findTrees,			-- FilePath -> IO [SourceTree]
     findTree,			-- FilePath -> IO SourceTree
     copy,			-- [Style] -> SourceTree -> FilePath -> IO SourceTree
     chroot,			-- FilePath -> FilePath -> SourceTree -> SourceTree
     -- * Inquiry
     controlFile,		-- SourceTree -> IO Control
     latestChange,		-- SourceTree -> IO ChangeLogEntry
     findChanges,		-- SourceTree -> IO Paths.EnvPath
     -- * Modify
     addLogEntry,		-- SourceTree -> ChangeLogEntry -> IO ()
     -- * Helper
     findOrigTar,		-- Paragraph -> Maybe FilePath
     packageName		-- Control -> String
    ) where

import Control.Exception
import Control.Monad
import Data.List
import Data.Maybe
import System.Directory
import System.IO
import Text.Regex
import Linspire.Unix.Progress as Progress
import Linspire.Debian.ChangeLog as ChangeLog
import Linspire.Debian.Control
import Linspire.Debian.Version
import Linspire.Unix.FilePath

data SourceTree
    = SourceTreeWithParent FilePath String |
      SourceTreeNoParent FilePath
    deriving Show
{-
instance Show SourceTree where
    show (SourceTree (Just parent) name) = "SourceTree (Just \"" ++ parent ++ "\") \"" ++ name ++ "\""
    show (SourceTree Nothing path)
    show (No reason) = "No - " ++ reason
-}

-- |Return the location of the source tree.  If the parent
-- is Nothing the path is assumed to be an absolute pathname,
-- otherwise it should be a directory name.
path :: SourceTree -> FilePath
path (SourceTreeWithParent parent subdir) = parent ++ "/" ++ subdir
path (SourceTreeNoParent dir) = dir

-- |Return the location of the source tree's parent directory
-- if that directory is controlled by the source tree.
parent :: SourceTree -> FilePath
parent (SourceTreeWithParent parent _) = parent
parent (SourceTreeNoParent _) = error "Source tree doesn't own its parent"

{-
makeTree :: FilePath -> SourceTree
makeTree path = SourceTree Nothing path
-}

-- |Examine a directory and return any SourceTree objects that can be
-- found there.  The directory should either contain a debian
-- directory with the proper control files, or it should contain a
-- .orig.tar.gz file and a directory containing such a debian
-- directory.
findTrees :: FilePath -> IO [SourceTree]
findTrees dir =
    do
      names <- doesDirectoryExist dir >>= bool (return []) (getDirectoryContents dir)
      let top = SourceTreeNoParent dir
      topValid <- valid top
      case topValid of
        True -> return [top]
        False -> filterM valid (map (SourceTreeWithParent dir) names)

bool :: a -> a -> Bool -> a
bool x _ False = x
bool _ x True = x

findTree :: FilePath -> IO SourceTree
findTree dir =
    do
      trees <- findTrees dir
      case trees of
        [tree] -> return tree
        [] -> error ("No SourceTree found in " ++ dir)
        _ -> error ("Multiple SourceTrees found in " ++ dir)
{-
      case trees of
        [] -> error ("No Debian source tree found in " ++ dir)
        [tree] -> return tree
      case elem "debian" names of
        True ->
            do
      trees <- filterM isSourceTree names
      case trees of
        [name] -> return $ SourceTree (Just dir) name
        [] -> error ("No Debian source tree found in " ++ dir)
        names -> error ("Multiple Debian source trees found in " ++ dir ++ ": " ++ show names)
    where
      isSourceTree dir = doesFileExist (dir ++ "/debian/changelog")
-}

valid :: SourceTree -> IO Bool
valid tree =
    mapM doesFileExist
             [path tree ++ "/debian/changelog",	-- A debian source tree
              path tree ++ "/series"] >>=		-- A quilt patches directory
    return . any id

chroot :: FilePath -> FilePath -> SourceTree -> SourceTree
chroot oldRoot newRoot (SourceTreeWithParent parent name) =
    case changePrefix oldRoot newRoot parent of
      Nothing -> error ("Can't change prefix of parent " ++ parent ++ " from " ++ oldRoot ++ " to " ++ newRoot)
      Just result -> SourceTreeWithParent result name
chroot oldRoot newRoot (SourceTreeNoParent path) =
    case changePrefix oldRoot newRoot path of
      Nothing -> error ("Can't change prefix of path " ++ path ++ " from " ++ oldRoot ++ " to " ++ newRoot)
      Just result -> SourceTreeNoParent result

-- examples
-- copy (SourceTree (Just "/tmp/skipjack/apt/haskell-hsql") "haskell-hsql-1.6") "/tmp/marlin/clean-lax/work/build/haskell-hsql" ->
-- rsync -aHxSpDt --delete '/tmp/skipjack/apt/haskell-hsql/' '/tmp/marlin/clean-lax/work/build/haskell-hsql'

-- |Copy a source tree.  The resulting tree will be a sub-directory of
-- the dest filepath.  If the parent directory contains a .orig.tar.gz
-- file that is copied too.
copy :: [Style] -> SourceTree -> FilePath -> IO SourceTree
copy style source dest =
    do
      -- ePut ("copy " ++ show source ++ " " ++ show dest)
      createDirectoryIfMissing True dest
      systemTask copyStyle ("rsync -aHxSpDt --delete " ++ src source ++ " '" ++ dest ++ "'")

      log <- readFile (path source ++ "/debian/changelog") >>= return . ChangeLog.parse
      let origTar =
              case log of
                (entry : _) ->
                    path source ++ "/../" ++
                    ChangeLog.package entry ++ "_" ++
                    Linspire.Debian.Version.version (ChangeLog.version entry) ++ ".orig.tar.gz"
                [] -> error "Couldn't find changelog entry" 
      exists <- doesFileExist origTar
      case exists of
        False -> return noTimeDiff -- ePut ("No " ++ origTar ++ " found.")
        True -> systemTask tarballStyle ("cp -p " ++ origTar ++ " " ++ dest)
      -- ePut (" -> " ++ show (newTree source))
      return $ newTree source
    where
      src (SourceTreeWithParent parent _) = "'" ++ parent ++ "/'" 
      src (SourceTreeNoParent path) = "'" ++ path ++ "'" 
      newTree (SourceTreeWithParent _ name) = SourceTreeWithParent dest name
      newTree (SourceTreeNoParent path) = SourceTreeWithParent dest (baseName path)
      copyStyle = setStyles [Start ("Copying clean source (" ++ stripDist dest ++ ")"),
                          Error ("Could not copy source tree from " ++ path source ++ " to " ++ dest)] style
      tarballStyle = setStyles [Start ("Copying original tarball"),
                                Error ("Could not copy original tarball from " ++ path source ++ " to " ++ dest)] style

-- |Return the contents of debian\/control.    
controlFile :: SourceTree -> IO Control
controlFile source =
    do
      let controlPath = (path source ++ "/debian/control")
      result <- parseControlFromFile controlPath
      case result of
        -- A valid control file must have a source paragraph and at
        -- least one binary paragraph.
        Right control@(Control (_ : _ : _)) -> return control
        Right control -> error ("Invalid control file: " ++ show control)
        Left e -> error ("Couldn't read control file: " ++ show e)

latestChange :: SourceTree -> IO ChangeLogEntry
latestChange tree =
    do
      let changelog = path tree ++ "/debian/changelog"
      text <- try $ readFile changelog
      let entries = either (error ("Error reading changelog in " ++ changelog)) ChangeLog.parse text
      case entries of
        [] -> error ("Empty changelog: " ++ changelog)
        (entry : _) -> return entry

-- |Find the .changes file which is generated by a successful run of
-- dpkg-buildpackage.
findChanges :: SourceTree -> IO FilePath
findChanges source =
    do
      buildFiles <- getDirectoryContents (parent source)
      let changesFileList = filter isChangesFile buildFiles
      case changesFileList of
        [] -> error ("No .changes file in " ++ parent source)
        [name] -> return $ parent source ++ "/" ++ name
        names -> error ("Multiple .changes files to upload: " ++ show names)
    where
      isChangesFile name = maybe False (\ _ -> True) (matchRegex changesRE name)
      changesRE = mkRegex "\\.changes$"

-- |Rewrite the changelog with an added entry.
addLogEntry :: SourceTree -> ChangeLogEntry -> IO ()
addLogEntry source entry =
    do
      let changelogPath = path source ++ "/debian/changelog"
      original <- readFile changelogPath
      -- date <- getRFC822Date
      let newtext = show entry
      -- ePut ("Adding changelog entry:\n" ++ show entry)

      -- This is delicate - we unlink the file here while its contents
      -- are still being read into the the lazy list 'text'.  If we
      -- don't remove the file before writing it, text ends up looking
      -- like an empty list.
      removeFile changelogPath
      writeFile changelogPath (newtext ++ original)

-- |Get the name of the .orig.tar.gz file of a source package by
-- examining the Files section of a paragraph from a Sources.gz, or as
-- output by apt-cache showsrc.
findOrigTar :: Paragraph -> Maybe FilePath
findOrigTar control =
    maybe Nothing (\ (Field (_, value)) ->
                       find (isSuffixOf ".orig.tar.gz") (parseFiles (stripWS value)))
              (lookupP "Files" control)
    where
      -- Parse the three-field "Files" entry of section output by apt-cache showsrc:
      -- md5sum size name
      parseFiles text =
          case (text, matchRegexAll re text) of
            ("", _) -> []
            (_, Just (_, _, remaining, [filename])) ->
                filename : parseFiles remaining
            _ -> error ("Parse error in Files section of changes file: '" ++ text)
      re = mkRegex ("^[ \t\n]*" ++ t ++ w ++ t ++ w ++ "(" ++ t ++ ")" ++ "[ \t\n]*")
      t = "[^ \t\n]+"
      w = "[ \t]+"

-- |Get the source package name from the control file.
packageName :: Control -> String
packageName (Control (paragraph : _)) =
    maybe (error "Missing Source field in control file") id (fieldValue "Source" paragraph)
packageName _ = error "Invalid control file"

changePrefix :: (Eq a) => [a] -> [a] -> [a] -> Maybe [a]
changePrefix old new s = maybe Nothing (Just . (new ++)) (Linspire.Debian.SourceTree.dropPrefix old s)

dropPrefix :: (Eq a) => [a] -> [a] -> Maybe [a]
dropPrefix prefix s =
    case isPrefixOf prefix s of
      True -> Just (drop (length prefix) s)
      False -> Nothing

ePut :: String -> IO ()
ePut s = hPutStrLn stderr s