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 qualified Debian.Debianize.Types.BinaryDebDescription as B (package)
import qualified Debian.Debianize.Types.SourceDebDescription as S (source)
import Debian.Pretty (Pretty(pretty))
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)
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 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 (map pretty oldPackages) ++ ", found " ++ show (map 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