import Control.Monad ( unless, when ) import Data.List ( isSuffixOf ) import Data.Maybe ( isNothing ) import Distribution.Package ( PackageId , PackageIdentifier (pkgName, pkgVersion) ) import Distribution.PackageDescription ( GenericPackageDescription (packageDescription) , PackageDescription (package) ) import Distribution.PackageDescription.Parsec ( readGenericPackageDescription ) import Distribution.Pretty ( prettyShow ) import Distribution.Simple.Utils ( copyDirectoryRecursive ) import Distribution.Types.PackageName ( unPackageName ) import Distribution.Verbosity ( normal ) import HSInstall.Resources ( getRsrcDir ) import qualified System.Directory as Dir import System.Environment ( getArgs ) import System.Exit ( exitSuccess ) import System.FilePath ( (), (<.>), takeDirectory ) import System.Process ( callProcess ) import Text.Printf ( printf ) import HSInstall.Except ( HSInstallException (NoCabalFiles, OneExePerAppImage) , withExceptionHandling, throwM ) import HSInstall.Opts ( AppImageExe (getExe), Options (..) , formattedVersion, parseOpts, usageText ) import Paths_hsinstall ( getDataDir ) main :: IO () main = withExceptionHandling $ do (opts, mbAppImageExe) <- getOpts when (optDumpIcon opts) $ dumpStockIcon Nothing >> exitSuccess dirs <- constructDirs opts mbAppImageExe cleanup opts dirs deployApplication mbAppImageExe dirs maybe (return ()) (\aie -> when (optMkAppImage opts) $ prepAppImageFiles aie >>= mkAppImage aie dirs ) mbAppImageExe getOpts :: IO (Options, Maybe AppImageExe) getOpts = do -- Parse args allOpts@(opts, mbAppImageExe) <- parseOpts =<< getArgs -- User asked for help when (optHelp opts) $ usageText >>= putStrLn >> exitSuccess -- User asked for version when (optVersion opts) $ formattedVersion >>= putStrLn >> exitSuccess when (isNothing mbAppImageExe && optMkAppImage opts) $ do throwM OneExePerAppImage return allOpts dumpStockIcon :: Maybe FilePath -> IO () dumpStockIcon mbDestPath = do resourcesDir <- getRsrcDir getDataDir let iconFilename = "unix-terminal" <.> "svg" let iconSourcePath = resourcesDir iconFilename let destPath = maybe iconFilename id mbDestPath Dir.copyFile iconSourcePath destPath data Dirs = Dirs { prefixDir :: FilePath , binDir :: FilePath , shareDir :: FilePath , docDir :: FilePath , rsrcDir :: FilePath } constructDirs :: Options -> Maybe AppImageExe -> IO Dirs constructDirs opts mbAppImageExe = do -- Locate cabal file cabalFiles <- (filter $ isSuffixOf ".cabal") <$> Dir.getDirectoryContents "." when (null cabalFiles) $ throwM NoCabalFiles -- Parse the cabal file and extract things we need from it -- then pass a pile of what we know to a function to create the -- installation dirs constructDirs' opts mbAppImageExe . package . packageDescription <$> readGenericPackageDescription normal (head cabalFiles) constructDirs' :: Options -> Maybe AppImageExe -> PackageId -> Dirs constructDirs' opts mbAppImageExe pkgId = Dirs prefixDir' binDir' shareDir' (shareDir' "doc") (shareDir' "resources") where prefixDir' = maybe (optPrefix opts) (\e -> "AppDir_" ++ getExe e "usr") $ mbAppImageExe binDir' = prefixDir' "bin" project = unPackageName . pkgName $ pkgId version' = prettyShow . pkgVersion $ pkgId shareDir' = prefixDir' "share" (printf "%s-%s" project version') cleanup :: Options -> Dirs -> IO () cleanup opts dirs= do -- Remove existing application directory (the one down in PREFIX/share) shareDirExists <- Dir.doesDirectoryExist $ shareDir dirs when (optDelete opts && shareDirExists) $ do putStrLn $ "Removing existing directory " ++ (shareDir dirs) Dir.removeDirectoryRecursive $ shareDir dirs -- Clean before building when (optClean opts) $ callProcess "stack" ["clean"] deployApplication :: Maybe AppImageExe -> Dirs -> IO () deployApplication mbAppImageExe dirs = do -- Copy the binaries Dir.createDirectoryIfMissing True $ binDir dirs callProcess "stack" [ "install", maybe "" (\aie -> ':' : getExe aie) $ mbAppImageExe , "--local-bin-path=" ++ binDir dirs ] -- Copy additional scripts {- putStrLn "Copying additional scripts" mapM_ (\f -> copyFile ("util" f) (binDir dirs f)) [ "script1.sh", "script2.hs" ] -} -- Copy the license let licenseFile = "LICENSE" licenseFileExists <- Dir.doesFileExist licenseFile when licenseFileExists $ do printf "\nCopying %s\n" licenseFile Dir.createDirectoryIfMissing True $ docDir dirs Dir.copyFile licenseFile (docDir dirs licenseFile) -- Copy the resources let rsrcDirSrc = "." "resources" rsrcsExist <- Dir.doesDirectoryExist rsrcDirSrc when rsrcsExist $ do putStrLn $ "\nCopying resources" copyDirectoryRecursive normal rsrcDirSrc (rsrcDir dirs) data DesktopFileStatus = CreateNewDesktop | DesktopExists appImageRsrcDir :: FilePath appImageRsrcDir = "util" "resources" "appimage" prepAppImageFiles :: AppImageExe -> IO DesktopFileStatus prepAppImageFiles appImageExe = do let exe = getExe appImageExe -- Check and possibly create new icon let iconPath = appImageRsrcDir exe <.> "svg" iconExists <- Dir.doesFileExist iconPath unless iconExists $ do Dir.createDirectoryIfMissing True appImageRsrcDir dumpStockIcon $ Just iconPath -- Check desktop file, return status to caller let desktopPath = appImageRsrcDir exe <.> "desktop" desktopFileExists <- Dir.doesFileExist desktopPath return $ if desktopFileExists then DesktopExists else CreateNewDesktop mkAppImage :: AppImageExe -> Dirs -> DesktopFileStatus -> IO () mkAppImage appImageExe dirs DesktopExists = do let desktopArg = "--desktop-file=" ++ (appImageRsrcDir getExe appImageExe <.> "desktop") mkAppImage' appImageExe dirs desktopArg mkAppImage appImageExe dirs CreateNewDesktop = do mkAppImage' appImageExe dirs "--create-desktop-file" -- Now copy the freshly-created .desktop file into the project sources let desktopFile = getExe appImageExe <.> "desktop" Dir.copyFile (prefixDir dirs "share" "applications" desktopFile) (appImageRsrcDir desktopFile) mkAppImage' :: AppImageExe -> Dirs -> String -> IO () mkAppImage' appImageExe dirs desktopArg = do let executable = getExe appImageExe callProcess "linuxdeploy-x86_64.AppImage" [ "--appdir=" ++ (takeDirectory $ prefixDir dirs) , "--executable=" ++ (binDir dirs executable) , desktopArg , "--icon-file=" ++ (appImageRsrcDir executable <.> "svg") , "--output=appimage" ]