module Debian.Debianize.Output
( doDebianizeAction
, runDebianizeScript
, writeDebianization
, describeDebianization
, compareDebianization
, validateDebianization
) where
import Control.Category ((.))
import Control.Exception as E (throw)
import Control.Monad.State (get, lift)
import Control.Monad.Trans (MonadIO)
import Data.Algorithm.Diff.Context (contextDiff)
import Data.Algorithm.Diff.Pretty (prettyDiff)
import Data.Lens.Lazy (getL)
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.Types (Top(unTop))
import Debian.Debianize.Files (debianizationFileMap)
import Debian.Debianize.Input (inputDebianization)
import Debian.Debianize.Monad (DebT, Atoms, evalDebT)
import Debian.Debianize.Options (putEnvironmentArgs)
import Debian.Debianize.Prelude (indent, replaceFile, withCurrentDirectory, zipMaps)
import qualified Debian.Debianize.Types as T
import qualified Debian.Debianize.Types.BinaryDebDescription as B (package)
import qualified Debian.Debianize.Types.SourceDebDescription as S (source)
import Prelude hiding (unlines, writeFile, (.))
import System.Directory (createDirectoryIfMissing, doesFileExist, getPermissions, Permissions(executable), setPermissions)
import System.Environment (getEnv)
import System.Exit (ExitCode(ExitSuccess))
import System.FilePath ((</>), takeDirectory)
import System.Process (readProcessWithExitCode)
import Text.PrettyPrint.ANSI.Leijen (Pretty(pretty))
runDebianizeScript :: [String] -> IO Bool
runDebianizeScript args =
getEnv "HOME" >>= \ home ->
doesFileExist "debian/Debianize.hs" >>= \ exists ->
case exists of
False -> return False
True ->
let autobuilderd = "-i.:" ++ home </> ".autobuilder.d" in
putEnvironmentArgs args >> readProcessWithExitCode "runhaskell" ([autobuilderd, "debian/Debianize.hs"] ++ args) "" >>= \ result ->
case result of
(ExitSuccess, _, _) -> return True
(code, out, err) ->
error ("runDebianize failed with " ++ show code ++ ":\n stdout: " ++ show out ++"\n stderr: " ++ show err)
doDebianizeAction :: Top -> DebT IO ()
doDebianizeAction top =
do new <- get
case () of
_ | getL T.validate new ->
do inputDebianization top
old <- get
return $ validateDebianization old new
_ | getL T.dryRun new ->
do inputDebianization top
old <- get
diff <- lift $ compareDebianization old new
lift $ putStr ("Debianization (dry run):\n" ++ diff)
_ -> writeDebianization top
writeDebianization :: Top -> DebT IO ()
writeDebianization top =
do files <- debianizationFileMap
lift $ withCurrentDirectory (unTop top) $ mapM_ (uncurry doFile) (Map.toList files)
lift $ getPermissions (unTop top </> "debian/rules") >>= setPermissions (unTop top </> "debian/rules") . (\ p -> p {executable = True})
where
doFile path text =
do createDirectoryIfMissing True (takeDirectory path)
replaceFile path (unpack text)
describeDebianization :: (MonadIO m, Functor m) => DebT m String
describeDebianization =
debianizationFileMap >>= return . concatMap (\ (path, text) -> path ++ ": " ++ indent " > " (unpack text)) . Map.toList
compareDebianization :: Atoms -> Atoms -> IO String
compareDebianization old new =
do oldFiles <- evalDebT debianizationFileMap old
newFiles <- evalDebT debianizationFileMap 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 (prettyDiff ("old" </> path) ("new" </> path) (contextDiff 2 (split (== '\n') o) (split (== '\n') n))))
doFile _path Nothing Nothing = error "Internal error in zipMaps"
validateDebianization :: Atoms -> Atoms -> ()
validateDebianization old new =
case () of
_ | oldVersion /= newVersion -> throw (userError ("Version mismatch, expected " ++ show (pretty oldVersion) ++ ", found " ++ show (pretty newVersion)))
| oldSource /= newSource -> throw (userError ("Source mismatch, expected " ++ show (pretty oldSource) ++ ", found " ++ show (pretty newSource)))
| oldPackages /= newPackages -> throw (userError ("Package mismatch, expected " ++ show (pretty oldPackages) ++ ", found " ++ show (pretty newPackages)))
| True -> ()
where
oldVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL T.changelog old))))
newVersion = logVersion (head (unChangeLog (fromMaybe (error "Missing changelog") (getL T.changelog new))))
oldSource = getL (S.source . T.control) old
newSource = getL (S.source . T.control) new
oldPackages = map (getL B.package) $ getL T.binaryPackages old
newPackages = map (getL B.package) $ getL T.binaryPackages new
unChangeLog :: ChangeLog -> [ChangeLogEntry]
unChangeLog (ChangeLog x) = x