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)
runDebianizeScript :: [String] -> IO Bool
runDebianizeScript args =
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)
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:" ]
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)
describeDebianization :: (MonadIO m, Functor m) => DebianT m String
describeDebianization =
debianizationFileMap >>= return . concatMap (\ (path, text) -> path ++ ": " ++ indent " > " (unpack text)) . Map.toList
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
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"
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