{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleInstances, OverloadedStrings, ScopedTypeVariables, StandaloneDeriving, TupleSections, TypeSynonymInstances, RankNTypes #-}
{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-}
module Debian.Debianize.Output
( finishDebianization
, runDebianizeScript
, writeDebianization
, describeDebianization
, compareDebianization
, validateDebianization
, performDebianization
, performDebianizationOfWebsite
, performDebianizationWith
) where
import Control.Exception as E (throw)
import Control.Lens
import Control.Monad.Fail (MonadFail)
import Control.Monad.State (get, put, StateT)
import Control.Monad.Trans (liftIO, MonadIO)
import Data.Algorithm.DiffContext (getContextDiff, prettyContextDiff)
import Data.Map as Map (elems, toList)
import Data.Maybe (fromMaybe)
import Data.Text as Text (split, Text, unpack)
import Debian.Debianize.CabalInfo (newCabalInfo)
import Debian.Changes (ChangeLog(..), ChangeLogEntry(..))
import Debian.Debianize.BasicInfo (dryRun, validate, upgrade, roundtrip)
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.Goodies (expandWebsite)
import Debian.Debianize.Monad (DebianT, CabalT, evalDebianT, evalCabalT)
import Debian.Debianize.Prelude (indent, replaceFile, zipMaps)
import Debian.Debianize.Finalize (debianizeWith)
import Debian.Debianize.Optparse
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.Directory (createDirectoryIfMissing, doesFileExist, getCurrentDirectory, 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 :: [[Char]] -> IO Bool
runDebianizeScript [[Char]]
args =
IO [Char]
getCurrentDirectory forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[Char]
here ->
[Char] -> IO Bool
doesFileExist [Char]
"debian/Debianize.hs" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Bool
exists ->
case Bool
exists of
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Bool
True -> do
let args' :: [[Char]]
args' = [[Char]
"-i.:src", [Char]
"debian/Debianize.hs"] forall a. [a] -> [a] -> [a]
++ [[Char]]
args
Handle -> [Char] -> IO ()
hPutStrLn Handle
stderr ([Char]
"running external debianization script in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
here forall a. [a] -> [a] -> [a]
++ [Char]
":\n " forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
showCommandForUser [Char]
"runhaskell" [[Char]]
args')
(ExitCode, [Char], [Char])
result <- [Char] -> [[Char]] -> [Char] -> IO (ExitCode, [Char], [Char])
readProcessWithExitCode [Char]
"runhaskell" [[Char]]
args' [Char]
""
case (ExitCode, [Char], [Char])
result of
(ExitCode
ExitSuccess, [Char]
_, [Char]
_) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
(ExitCode
code, [Char]
out, [Char]
err) -> forall a. HasCallStack => [Char] -> a
error ([Char]
" external debianization script failed:\n " forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
showCommandForUser [Char]
"runhaskell" [[Char]]
args' forall a. [a] -> [a] -> [a]
++ [Char]
" -> " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show ExitCode
code forall a. [a] -> [a] -> [a]
++
[Char]
"\n stdout: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
out forall a. [a] -> [a] -> [a]
++[Char]
"\n stderr: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show [Char]
err)
performDebianization :: CabalT IO () -> IO ()
performDebianization :: CabalT IO () -> IO ()
performDebianization = CabalT IO () -> CabalT IO () -> IO ()
performDebianizationWith (forall (m :: * -> *) a. Monad m => a -> m a
return ())
performDebianizationOfWebsite :: CabalT IO () -> IO ()
performDebianizationOfWebsite :: CabalT IO () -> IO ()
performDebianizationOfWebsite = CabalT IO () -> CabalT IO () -> IO ()
performDebianizationWith forall (m :: * -> *). Monad m => CabalT m ()
expandWebsite
performDebianizationWith :: CabalT IO () -> CabalT IO () -> IO ()
performDebianizationWith :: CabalT IO () -> CabalT IO () -> IO ()
performDebianizationWith CabalT IO ()
goodies CabalT IO ()
custom =
IO CommandLineOptions
parseProgramArguments forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \CommandLineOptions {Flags
BehaviorAdjustment
_adjustment :: CommandLineOptions -> BehaviorAdjustment
_flags :: CommandLineOptions -> Flags
_adjustment :: BehaviorAdjustment
_flags :: Flags
..} -> do
forall (m :: * -> *).
(MonadIO m, MonadMask m) =>
Flags -> m (Either [Char] CabalInfo)
newCabalInfo Flags
_flags forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
(forall a. HasCallStack => [Char] -> a
error forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"peformDebianization - " forall a. [a] -> [a] -> [a]
++))
(forall (m :: * -> *) a. Monad m => CabalT m a -> CabalInfo -> m a
evalCabalT forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
MonadIO m =>
BehaviorAdjustment -> CabalT m ()
handleBehaviorAdjustment BehaviorAdjustment
_adjustment
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
CabalT m () -> CabalT m () -> CabalT m ()
debianizeWith CabalT IO ()
goodies CabalT IO ()
custom
forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
StateT CabalInfo m ()
finishDebianization)
finishDebianization :: forall m. (MonadIO m, MonadFail m) => StateT CabalInfo m ()
finishDebianization :: forall (m :: * -> *).
(MonadIO m, MonadFail m) =>
StateT CabalInfo m ()
finishDebianization = forall (m :: * -> *) (n :: * -> *) s t c.
Zoom m n s t =>
LensLike' (Zoomed m c) t s -> m c -> n c
zoom Lens' CabalInfo DebInfo
debInfo forall a b. (a -> b) -> a -> b
$
do DebInfo
new <- forall s (m :: * -> *). MonadState s m => m s
get
case () of
()
_ | forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' DebInfo Flags
D.flags forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Flags Bool
validate) DebInfo
new ->
do forall (m :: * -> *). MonadIO m => DebianT m ()
inputDebianization
DebInfo
old <- forall s (m :: * -> *). MonadState s m => m s
get
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DebInfo -> DebInfo -> ()
validateDebianization DebInfo
old DebInfo
new
()
_ | forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' DebInfo Flags
D.flags forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Flags Bool
dryRun) DebInfo
new ->
do forall (m :: * -> *). MonadIO m => DebianT m ()
inputDebianization
DebInfo
old <- forall s (m :: * -> *). MonadState s m => m s
get
let diff :: [[Char]]
diff = DebInfo -> DebInfo -> [[Char]]
compareDebianization DebInfo
old DebInfo
new
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO ()
putStrLn ([Char]
"Debianization (dry run):\n" forall a. [a] -> [a] -> [a]
++ if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
diff then [Char]
" No changes\n" else forall a. Show a => a -> [Char]
show [[Char]]
diff)
()
_ | forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' DebInfo Flags
D.flags forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Flags Bool
upgrade) DebInfo
new ->
do forall (m :: * -> *). MonadIO m => DebianT m ()
inputDebianization
DebInfo
old <- forall s (m :: * -> *). MonadState s m => m s
get
let merged :: DebInfo
merged = DebInfo -> DebInfo -> DebInfo
mergeDebianization DebInfo
old DebInfo
new
forall s (m :: * -> *). MonadState s m => s -> m ()
put DebInfo
merged
forall (m :: * -> *). (MonadIO m, MonadFail m) => DebianT m ()
writeDebianization
()
_ | forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' DebInfo Flags
D.flags forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Flags Bool
roundtrip) DebInfo
new ->
do forall (m :: * -> *). MonadIO m => DebianT m ()
inputDebianization
forall (m :: * -> *). (MonadIO m, MonadFail m) => DebianT m ()
writeDebianization
()
_ -> forall (m :: * -> *). (MonadIO m, MonadFail m) => DebianT m ()
writeDebianization
writeDebianization :: (MonadIO m, MonadFail m) => DebianT m ()
writeDebianization :: forall (m :: * -> *). (MonadIO m, MonadFail m) => DebianT m ()
writeDebianization =
do Map [Char] Text
files <- forall (m :: * -> *). MonadFail m => DebianT m (Map [Char] Text)
debianizationFileMap
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Char] -> Text -> IO ()
doFile) (forall k a. Map k a -> [(k, a)]
Map.toList Map [Char] Text
files)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO Permissions
getPermissions [Char]
"debian/rules" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= [Char] -> Permissions -> IO ()
setPermissions [Char]
"debian/rules" forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ Permissions
p -> Permissions
p {executable :: Bool
executable = Bool
True})
where
doFile :: [Char] -> Text -> IO ()
doFile [Char]
path Text
text =
do Bool -> [Char] -> IO ()
createDirectoryIfMissing Bool
True ([Char] -> [Char]
takeDirectory [Char]
path)
[Char] -> [Char] -> IO ()
replaceFile [Char]
path (Text -> [Char]
unpack Text
text)
describeDebianization :: (MonadIO m, MonadFail m) => DebianT m String
describeDebianization :: forall (m :: * -> *). (MonadIO m, MonadFail m) => DebianT m [Char]
describeDebianization =
forall (m :: * -> *). MonadFail m => DebianT m (Map [Char] Text)
debianizationFileMap forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\ ([Char]
path, Text
text) -> [Char]
path forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ [Char] -> [Char] -> [Char]
indent [Char]
" > " (Text -> [Char]
unpack Text
text)) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [(k, a)]
Map.toList
mergeDebianization :: D.DebInfo -> D.DebInfo -> D.DebInfo
mergeDebianization :: DebInfo -> DebInfo -> DebInfo
mergeDebianization DebInfo
old DebInfo
new =
forall b. Lens' DebInfo b -> DebInfo -> DebInfo
override (Lens' DebInfo SourceDebDescription
D.control forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' SourceDebDescription Relations
S.buildDepends) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall b. Lens' DebInfo b -> DebInfo -> DebInfo
override (Lens' DebInfo SourceDebDescription
D.control forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' SourceDebDescription Relations
S.buildDependsIndep) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall b. Lens' DebInfo b -> DebInfo -> DebInfo
override (Lens' DebInfo SourceDebDescription
D.control forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' SourceDebDescription (Maybe Text)
S.homepage) forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall b. Lens' DebInfo b -> DebInfo -> DebInfo
override (Lens' DebInfo SourceDebDescription
D.control forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' SourceDebDescription (Set VersionControlSpec)
S.vcsFields) forall a b. (a -> b) -> a -> b
$
DebInfo
old
where
override :: forall b. Lens' D.DebInfo b -> (D.DebInfo -> D.DebInfo)
override :: forall b. Lens' DebInfo b -> DebInfo -> DebInfo
override Lens' DebInfo b
lens = forall s t a b. ASetter s t a b -> b -> s -> t
set Lens' DebInfo b
lens (DebInfo
new forall s a. s -> Getting a s a -> a
^. Lens' DebInfo b
lens)
compareDebianization :: D.DebInfo -> D.DebInfo -> [String]
compareDebianization :: DebInfo -> DebInfo -> [[Char]]
compareDebianization DebInfo
old DebInfo
new =
let ~(Just Map [Char] Text
oldFiles) = forall (m :: * -> *) a. Monad m => DebianT m a -> DebInfo -> m a
evalDebianT forall (m :: * -> *). MonadFail m => DebianT m (Map [Char] Text)
debianizationFileMap (forall a. Canonical a => a -> a
canonical DebInfo
old)
~(Just Map [Char] Text
newFiles) = forall (m :: * -> *) a. Monad m => DebianT m a -> DebInfo -> m a
evalDebianT forall (m :: * -> *). MonadFail m => DebianT m (Map [Char] Text)
debianizationFileMap (forall a. Canonical a => a -> a
canonical DebInfo
new) in
forall k a. Map k a -> [a]
elems forall a b. (a -> b) -> a -> b
$ forall k a b c.
Ord k =>
(k -> Maybe a -> Maybe b -> Maybe c)
-> Map k a -> Map k b -> Map k c
zipMaps [Char] -> Maybe Text -> Maybe Text -> Maybe [Char]
doFile Map [Char] Text
oldFiles Map [Char] Text
newFiles
where
doFile :: FilePath -> Maybe Text -> Maybe Text -> Maybe String
doFile :: [Char] -> Maybe Text -> Maybe Text -> Maybe [Char]
doFile [Char]
path (Just Text
_) Maybe Text
Nothing = forall a. a -> Maybe a
Just ([Char]
path forall a. [a] -> [a] -> [a]
++ [Char]
": Deleted\n")
doFile [Char]
path Maybe Text
Nothing (Just Text
n) = forall a. a -> Maybe a
Just ([Char]
path forall a. [a] -> [a] -> [a]
++ [Char]
": Created\n" forall a. [a] -> [a] -> [a]
++ [Char] -> [Char] -> [Char]
indent [Char]
" | " (Text -> [Char]
unpack Text
n))
doFile [Char]
path (Just Text
o) (Just Text
n) =
if Text
o forall a. Eq a => a -> a -> Bool
== Text
n
then forall a. Maybe a
Nothing
else forall a. a -> Maybe a
Just (forall a. Show a => a -> [Char]
show (forall c. Doc -> Doc -> (c -> Doc) -> ContextDiff c -> Doc
prettyContextDiff ([Char] -> Doc
text ([Char]
"old" [Char] -> [Char] -> [Char]
</> [Char]
path)) ([Char] -> Doc
text ([Char]
"new" [Char] -> [Char] -> [Char]
</> [Char]
path)) ([Char] -> Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
unpack) (forall a. Eq a => Int -> [a] -> [a] -> ContextDiff a
getContextDiff Int
2 ((Char -> Bool) -> Text -> [Text]
split (forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
o) ((Char -> Bool) -> Text -> [Text]
split (forall a. Eq a => a -> a -> Bool
== Char
'\n') Text
n))))
doFile [Char]
_path Maybe Text
Nothing Maybe Text
Nothing = forall a. HasCallStack => [Char] -> a
error [Char]
"Internal error in zipMaps"
validateDebianization :: D.DebInfo -> D.DebInfo -> ()
validateDebianization :: DebInfo -> DebInfo -> ()
validateDebianization DebInfo
old DebInfo
new =
case () of
()
_ | DebianVersion
oldVersion forall a. Eq a => a -> a -> Bool
/= DebianVersion
newVersion -> forall a e. Exception e => e -> a
throw ([Char] -> IOError
userError ([Char]
"Version mismatch, expected " forall a. [a] -> [a] -> [a]
++ forall a. Pretty (PP a) => a -> [Char]
ppShow DebianVersion
oldVersion forall a. [a] -> [a] -> [a]
++ [Char]
", found " forall a. [a] -> [a] -> [a]
++ forall a. Pretty (PP a) => a -> [Char]
ppShow DebianVersion
newVersion))
| Maybe SrcPkgName
oldSource forall a. Eq a => a -> a -> Bool
/= Maybe SrcPkgName
newSource -> forall a e. Exception e => e -> a
throw ([Char] -> IOError
userError ([Char]
"Source mismatch, expected " forall a. [a] -> [a] -> [a]
++ forall a. Pretty (PP a) => a -> [Char]
ppShow Maybe SrcPkgName
oldSource forall a. [a] -> [a] -> [a]
++ [Char]
", found " forall a. [a] -> [a] -> [a]
++ forall a. Pretty (PP a) => a -> [Char]
ppShow Maybe SrcPkgName
newSource))
| [BinPkgName]
oldPackages forall a. Eq a => a -> a -> Bool
/= [BinPkgName]
newPackages -> forall a e. Exception e => e -> a
throw ([Char] -> IOError
userError ([Char]
"Package mismatch, expected " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty (PP a) => a -> Doc
ppPrint [BinPkgName]
oldPackages) forall a. [a] -> [a] -> [a]
++ [Char]
", found " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a b. (a -> b) -> [a] -> [b]
map forall a. Pretty (PP a) => a -> Doc
ppPrint [BinPkgName]
newPackages)))
| Bool
True -> ()
where
oldVersion :: DebianVersion
oldVersion = ChangeLogEntry -> DebianVersion
logVersion (forall a. [a] -> a
head (ChangeLog -> [ChangeLogEntry]
unChangeLog (forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"Missing changelog") (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' DebInfo (Maybe ChangeLog)
D.changelog DebInfo
old))))
newVersion :: DebianVersion
newVersion = ChangeLogEntry -> DebianVersion
logVersion (forall a. [a] -> a
head (ChangeLog -> [ChangeLogEntry]
unChangeLog (forall a. a -> Maybe a -> a
fromMaybe (forall a. HasCallStack => [Char] -> a
error [Char]
"Missing changelog") (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' DebInfo (Maybe ChangeLog)
D.changelog DebInfo
new))))
oldSource :: Maybe SrcPkgName
oldSource = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' DebInfo SourceDebDescription
D.control forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' SourceDebDescription (Maybe SrcPkgName)
S.source) DebInfo
old
newSource :: Maybe SrcPkgName
newSource = forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' DebInfo SourceDebDescription
D.control forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' SourceDebDescription (Maybe SrcPkgName)
S.source) DebInfo
new
oldPackages :: [BinPkgName]
oldPackages = forall a b. (a -> b) -> [a] -> [b]
map (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' BinaryDebDescription BinPkgName
B.package) forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' DebInfo SourceDebDescription
D.control forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' SourceDebDescription [BinaryDebDescription]
S.binaryPackages) DebInfo
old
newPackages :: [BinPkgName]
newPackages = forall a b. (a -> b) -> [a] -> [b]
map (forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Lens' BinaryDebDescription BinPkgName
B.package) forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view (Lens' DebInfo SourceDebDescription
D.control forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' SourceDebDescription [BinaryDebDescription]
S.binaryPackages) DebInfo
new
unChangeLog :: ChangeLog -> [ChangeLogEntry]
unChangeLog :: ChangeLog -> [ChangeLogEntry]
unChangeLog (ChangeLog [ChangeLogEntry]
x) = [ChangeLogEntry]
x