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)
import Control.Monad.Trans (MonadIO, liftIO)
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.Atoms (EnvSet)
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, zipMaps)
import qualified Debian.Debianize.Types as T
import Debian.Debianize.Types.BinaryDebDescription as B (package, canonical)
import qualified Debian.Debianize.Types.SourceDebDescription as S (source)
import Debian.Pretty (ppPrint, ppDisplay)
import Prelude hiding (unlines, writeFile, (.))
import System.Directory (createDirectoryIfMissing, doesFileExist, getPermissions, Permissions(executable), setPermissions)
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)
doDebianizeAction :: (MonadIO m, Functor m) => EnvSet -> DebT m ()
doDebianizeAction envset =
do new <- get
case () of
_ | getL T.validate new ->
do inputDebianization envset
old <- get
return $ validateDebianization old new
_ | getL T.dryRun new ->
do inputDebianization envset
old <- get
diff <- liftIO $ compareDebianization old new
liftIO $ putStr ("Debianization (dry run):\n" ++ diff)
_ -> writeDebianization
writeDebianization :: (MonadIO m, Functor m) => DebT 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) => 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 (canonical old)
newFiles <- evalDebT 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 (prettyDiff (text ("old" </> path)) (text ("new" </> path)) (text . unpack) (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 " ++ ppDisplay oldVersion ++ ", found " ++ ppDisplay newVersion))
| oldSource /= newSource -> throw (userError ("Source mismatch, expected " ++ ppDisplay oldSource ++ ", found " ++ ppDisplay 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 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