Output.hs

-- | Wrappers around the debianization function to perform various
-- tasks - output, describe, validate a debianization, run an external
-- script to produce a debianization.

{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving, TupleSections, TypeSynonymInstances #-}
{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-}

module Debian.Debianize.Output
    ( finishDebianization
    , runDebianizeScript
    , writeDebianization
    , describeDebianization
    , compareDebianization
    , validateDebianization
    ) where

import OldLens (getL)

import Control.Category ((.))
import Control.Exception as E (throw)
import Control.Lens (zoom)
import Control.Monad.State (get, StateT)
import Control.Monad.Trans (liftIO, MonadIO)
import Data.Algorithm.DiffContext (getContextDiff, prettyContextDiff)
import Data.List (unlines)
import Data.Map as Map (elems, toList)
import Data.Maybe (fromMaybe)
import Data.Text as Text (split, Text, unpack)
import Debian.Changes (ChangeLog(..), ChangeLogEntry(..))
import Debian.Debianize.BasicInfo (DebAction(Usage), debAction, dryRun, validate)
import Debian.Debianize.CabalInfo (CabalInfo, debInfo)
import qualified Debian.Debianize.DebInfo as D
import Debian.Debianize.Files (debianizationFileMap)
import Debian.Debianize.InputDebian (inputDebianization)
import Debian.Debianize.Monad (DebianT, evalDebianT)
import Debian.Debianize.Options (options, putEnvironmentArgs)
import Debian.Debianize.Prelude (indent, replaceFile, zipMaps)
import Debian.Debianize.BinaryDebDescription as B (canonical, package)
import qualified Debian.Debianize.SourceDebDescription as S
import Debian.Pretty (ppShow, ppPrint)
import Prelude hiding ((.), unlines, writeFile)
import System.Console.GetOpt (OptDescr, usageInfo)
import System.Directory (createDirectoryIfMissing, doesFileExist, getPermissions, Permissions(executable), setPermissions)
import System.Environment (getProgName)
import System.Exit (ExitCode(ExitSuccess))
import System.FilePath ((</>), takeDirectory)
import System.IO (hPutStrLn, stderr)
import System.Process (readProcessWithExitCode, showCommandForUser)
import Text.PrettyPrint.HughesPJClass (text)

-- | Run the script in @debian/Debianize.hs@ with the given command
-- line arguments.  Returns @True@ if the script exists and succeeds.
-- In this case it may be assumed that a debianization was created (or
-- updated) in the debian subdirectory of the current directory.  In
-- this way we can include a script in a package to produce a
-- customized debianization more sophisticated than the one that would
-- be produced by the cabal-debian executable.  An example is included
-- in the debian subdirectory of this library.
runDebianizeScript :: [String] -> IO Bool
runDebianizeScript args =
    -- getEnv "HOME" >>= \ home ->
    doesFileExist "debian/Debianize.hs" >>= \ exists ->
    case exists of
      False -> return False
      True -> do
        let args' = ["debian/Debianize.hs"] ++ args
        putEnvironmentArgs args
        hPutStrLn stderr (showCommandForUser "runhaskell" args')
        result <- readProcessWithExitCode "runhaskell" args' ""
        case result of
          (ExitSuccess, _, _) -> return True
          (code, out, err) -> error ("runDebianizeScript: " ++ showCommandForUser "runhaskell" args' ++ " -> " ++ show code ++
                                     "\n stdout: " ++ show out ++"\n stderr: " ++ show err)

-- | Depending on the options in @atoms@, either validate, describe,
-- or write the generated debianization.
finishDebianization :: forall m. (MonadIO m, Functor m) => StateT CabalInfo m ()
finishDebianization = zoom debInfo $
    do new <- get
       case () of
         _ | getL (D.flags . debAction) new == Usage ->
               do progName <- liftIO getProgName
                  liftIO $ putStrLn (usageInfo (usageHeader progName) (options :: [OptDescr (StateT CabalInfo m ())]))
         _ | getL (D.flags . validate) new ->
               do inputDebianization
                  old <- get
                  return $ validateDebianization old new
         _ | getL (D.flags . dryRun) new ->
               do inputDebianization
                  old <- get
                  diff <- liftIO $ compareDebianization old new
                  liftIO $ putStrLn ("Debianization (dry run):\n" ++ if null diff then "  No changes\n" else diff)
         _ -> writeDebianization
    where
      usageHeader progName =
          unlines [ "Typical usage is to cd to the top directory of the package's unpacked source and run: "
                  , ""
                  , "    " ++ progName ++ " --maintainer 'Maintainer Name <maintainer@email>'."
                  , ""
                  , "This will read the package's cabal file and any existing debian/changelog file and"
                  , "deduce what it can about the debianization, then it will create or modify files in"
                  , "the debian subdirectory.  Note that it will not remove any files in debian, and"
                  , "these could affect the operation of the debianization in unknown ways.  For this"
                  , "reason I recommend either using a pristine unpacked directory each time, or else"
                  , "using a revision control system to revert the package to a known state before running."
                  , "The following additional options are available:" ]

-- | Write the files of the debianization @d@ to ./debian
writeDebianization :: (MonadIO m, Functor m) => DebianT m ()
writeDebianization =
    do files <- debianizationFileMap
       liftIO $ mapM_ (uncurry doFile) (Map.toList files)
       liftIO $ getPermissions "debian/rules" >>= setPermissions "debian/rules" . (\ p -> p {executable = True})
    where
      doFile path text =
          do createDirectoryIfMissing True (takeDirectory path)
             replaceFile path (unpack text)

-- | Return a string describing the debianization - a list of file
-- names and their contents in a somewhat human readable format.
describeDebianization :: (MonadIO m, Functor m) => DebianT m String
describeDebianization =
    debianizationFileMap >>= return . concatMap (\ (path, text) -> path ++ ": " ++ indent " > " (unpack text)) . Map.toList

-- | Compare the old and new debianizations, returning a string
-- describing the differences.
compareDebianization :: D.DebInfo -> D.DebInfo -> IO String
compareDebianization old new =
    do oldFiles <- evalDebianT debianizationFileMap (canonical old)
       newFiles <- evalDebianT debianizationFileMap (canonical new)
       return $ concat $ Map.elems $ zipMaps doFile oldFiles newFiles
    where
      doFile :: FilePath -> Maybe Text -> Maybe Text -> Maybe String
      doFile path (Just _) Nothing = Just (path ++ ": Deleted\n")
      doFile path Nothing (Just n) = Just (path ++ ": Created\n" ++ indent " | " (unpack n))
      doFile path (Just o) (Just n) =
          if o == n
          then Nothing -- Just (path ++ ": Unchanged\n")
          else Just (show (prettyContextDiff (text ("old" </> path)) (text ("new" </> path)) (text . unpack) (getContextDiff 2 (split (== '\n') o) (split (== '\n') n))))
      doFile _path Nothing Nothing = error "Internal error in zipMaps"

-- | Make sure the new debianization matches the existing
-- debianization in several ways - specifically, version number, and
-- the names of the source and binary packages.  Some debian packages
-- come with a skeleton debianization that needs to be filled in, this
-- can be used to make sure the debianization we produce is usable.
validateDebianization :: D.DebInfo -> D.DebInfo -> ()
validateDebianization old new =
    case () of
      _ | oldVersion /= newVersion -> throw (userError ("Version mismatch, expected " ++ ppShow oldVersion ++ ", found " ++ ppShow newVersion))
        | oldSource /= newSource -> throw (userError ("Source mismatch, expected " ++ ppShow oldSource ++ ", found " ++ ppShow newSource))
        | oldPackages /= newPackages -> throw (userError ("Package mismatch, expected " ++ show (map ppPrint oldPackages) ++ ", found " ++ show (map ppPrint newPackages)))
        | True -> ()
    where
      oldVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL D.changelog old))))
      newVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL D.changelog new))))
      oldSource = getL (D.control . S.source) old
      newSource = getL (D.control . S.source) new
      oldPackages = map (getL B.package) $ getL (D.control . S.binaryPackages) old
      newPackages = map (getL B.package) $ getL (D.control . S.binaryPackages) new
      unChangeLog :: ChangeLog -> [ChangeLogEntry]
      unChangeLog (ChangeLog x) = x