diff --git a/Changelog.md b/Changelog.md --- a/Changelog.md +++ b/Changelog.md @@ -1,3 +1,9 @@ +### 0.6.1.0 + +- Added a new module *NgxExport.Distribution.Compat.Verbosity* to support + different implementations of the *verbosity* mechanism in Cabal *3.16* and + *3.18*. + ### 0.6.0.2 - *nhm-tool*: GHC's *Project Unit Id* must be considered in Cabal *3.12* and diff --git a/NgxExport/Distribution.hs b/NgxExport/Distribution.hs --- a/NgxExport/Distribution.hs +++ b/NgxExport/Distribution.hs @@ -46,6 +46,7 @@ ,defaultMain ) where +import NgxExport.Distribution.Compat.Verbosity import Distribution.Simple hiding (defaultMain) import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program @@ -441,7 +442,8 @@ archiveArg = ["-a", prettyShow $ package desc] nhmToolP <- fst <$> requireProgram verbosity nhmTool (withPrograms lbi) let nhmToolR = programInvocation nhmToolP $ "dist" : lib : - verbosityArg verbosity ++ rpathArg ++ dirArg ++ archiveArg + verbosityArg (toVerbosityFlags verbosity) ++ + rpathArg ++ dirArg ++ archiveArg runProgramInvocation verbosity nhmToolR -- | Build hooks. @@ -459,17 +461,20 @@ ngxExportHooks = simpleUserHooks { hookedPrograms = [nhmTool] , confHook = \desc flags -> do - let verbosity = toVerbosity $ configVerbosity flags + let cFlags = configVerbosity flags + verbosity = toVerbosity $ + extractVerbosityFlags cFlags pdb = configPrograms flags _ <- requireProgram verbosity nhmTool pdb >>= requireProgram verbosity patchelf . snd confHook simpleUserHooks desc flags , buildHook = \desc lbi _ flags -> do - let verbosity = toVerbosity $ buildVerbosity flags + let bFlags = buildVerbosity flags + verbosity = toVerbosity $ + extractVerbosityFlags bFlags buildSharedLib verbosity desc lbi flags >>= \lib -> patchAndCollectDependentLibs verbosity lib desc lbi } - where toVerbosity = fromFlagOrDefault normal -- | A simple implementation of /main/ for a Cabal setup script. -- diff --git a/NgxExport/Distribution/Compat/Verbosity.hs b/NgxExport/Distribution/Compat/Verbosity.hs new file mode 100644 --- /dev/null +++ b/NgxExport/Distribution/Compat/Verbosity.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE CPP #-} + +----------------------------------------------------------------------------- +-- | +-- Module : NgxExport.Distribution.Compat.Verbosity +-- Copyright : (c) Alexey Radkov 2026 +-- License : BSD-style +-- +-- Maintainer : alexey.radkov@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Utility functions to extract and combine different Cabal verbosity object +-- parts. The functions are meant to be used internally and only exported for +-- usage in utility /nhm-tool/. +-- +----------------------------------------------------------------------------- + +module NgxExport.Distribution.Compat.Verbosity ( + -- * Compatibility layer between Cabal /3.16/ and /3.18/ + toVerbosityFlags + ,toVerbosity + ,extractVerbosityFlags + ,defaultVerbosity + ) where + +import Distribution.Simple.Flag (Flag, fromFlagOrDefault) + +#if MIN_VERSION_Cabal(3,18,0) +#define VERBOSITY_FLAGS VerbosityFlags +#define VERBOSITY_HANDLES VerbosityHandles +#define TO_VERBOSITY_FLAGS(verbosity) (verbosityFlags (verbosity)) +#define TO_VERBOSITY(flags, handles) (Verbosity (flags) (handles)) +import Distribution.Verbosity (Verbosity (..) + ,VerbosityFlags, verbosityFlags, normal + ,VerbosityHandles, defaultVerbosityHandles + ) +defaultVerbosityHandles_ :: VERBOSITY_HANDLES +defaultVerbosityHandles_ = defaultVerbosityHandles +#else +#define VERBOSITY_FLAGS Verbosity +#define VERBOSITY_HANDLES () +#define TO_VERBOSITY_FLAGS(verbosity) (verbosity) +#define TO_VERBOSITY(flags, handles) (flags) +import Distribution.Verbosity (Verbosity, normal) +#endif + +-- | Extracts /verbosity flags/ from 'Verbosity'. +-- +-- With Cabal /3.16/ and older it simply returns the passed argument. +toVerbosityFlags :: Verbosity -> VERBOSITY_FLAGS +toVerbosityFlags verbosity = TO_VERBOSITY_FLAGS(verbosity) +{-# ANN toVerbosityFlags "HLint: ignore Redundant bracket" #-} + +-- | Builds 'Verbosity' from the passed /verbosity flags/ and default +-- /verbosity handles/. +-- +-- With Cabal /3.16/ and older it simply returns the passed argument. +toVerbosity :: VERBOSITY_FLAGS -> Verbosity +toVerbosity flags = TO_VERBOSITY(flags, defaultVerbosityHandles_) +{-# ANN toVerbosity "HLint: ignore Redundant bracket" #-} + +-- | Extracts /verbosity flags/ from the passed flag. +-- +-- Returns the extracted /verbosity flags/ or 'normal' on failure. +extractVerbosityFlags :: Flag VERBOSITY_FLAGS -> VERBOSITY_FLAGS +extractVerbosityFlags = fromFlagOrDefault $ toVerbosityFlags defaultVerbosity + +-- | Builds verbosity from default /verbosity flags/ and /verbosity handles/. +-- +-- With Cabal /3.16/ and older it simply returns 'normal'. With Cabal /3.18/ +-- and newer it combines 'normal' and default /verbosity handles/ into +-- 'Verbosity'. +defaultVerbosity :: Verbosity +defaultVerbosity = toVerbosity normal + diff --git a/ngx-export-distribution.cabal b/ngx-export-distribution.cabal --- a/ngx-export-distribution.cabal +++ b/ngx-export-distribution.cabal @@ -1,5 +1,5 @@ name: ngx-export-distribution -version: 0.6.0.2 +version: 0.6.1.0 synopsis: Build custom libraries for Nginx Haskell module description: Build custom libraries for . @@ -23,6 +23,7 @@ , filepath exposed-modules: NgxExport.Distribution + , NgxExport.Distribution.Compat.Verbosity ghc-options: -Wall @@ -37,7 +38,9 @@ , ansi-terminal >= 0.6.2 , cabal-plan , parsec >= 3.0.0 + , ngx-export-distribution + hs-source-dirs: nhm-tool main-is: nhm-tool.hs other-modules: Paths_ngx_export_distribution diff --git a/nhm-tool.hs b/nhm-tool.hs deleted file mode 100644 --- a/nhm-tool.hs +++ /dev/null @@ -1,664 +0,0 @@ -{-# LANGUAGE RecordWildCards, LambdaCase, MultiWayIf, ViewPatterns #-} -{-# LANGUAGE OverloadedStrings #-} - -module Main where - -import Text.Parsec hiding (uncons) -import Distribution.Simple.Program -import Distribution.Verbosity -import Cabal.Plan -import Control.Monad -import qualified Data.Text as T -import qualified Data.Text.IO as T -import Data.Text (Text) -import qualified Data.Map as M -import qualified Data.Set as S -import Data.Maybe -import Data.Char -import Data.List -import System.Console.ANSI -import System.Environment -import System.Directory -import System.FilePath -import System.Exit -import System.IO -import Data.Version (showVersion) -import Paths_ngx_export_distribution (version) - -data DistData = DistData { distDataDir :: String - , distDataArchive :: String - , distDataTargetDir :: String - , distDataPatchOnly :: Bool - , distDataTargetLib :: String - , distDataOwnVerbosity :: Verbosity - , distDataOtherVerbosity :: Verbosity - , distDataWaitArg :: Maybe String - , distDataHelp :: Bool - } - -defaultDistDataDir :: String -defaultDistDataDir = ".hslibs" - -data PlanData = PlanData { planDataBuilddir :: String - , planDataQuery :: Maybe PlanDataQuery - , planDataWaitArg :: Maybe String - , planDataWaitProjectName :: Bool - , planDataHelp :: Bool - } - -data PlanDataQuery = PlanDataQueryDeps String - | PlanDataQueryAbi - -data InitData = InitData { initDataPrefix :: String - , initDataNoThreaded :: Bool - , initDataForce :: Bool - , initDataToStdout :: Bool - , initDataProject :: String - , initDataGhcOptions :: [String] - , initDataWaitArg :: Maybe String - , initDataHelp :: Bool - } - -defaultInitDataPrefix :: String -defaultInitDataPrefix = "/var/lib/nginx" - -data LddRec = LibHS String (Maybe FilePath) - | LibFFI String (Maybe FilePath) - | LibOther String (Maybe FilePath) - deriving Show - -data HelpSection = HelpDist | HelpPlan | HelpDeps | HelpInit deriving Eq - -replaceChar :: Char -> Char -> String -> String -replaceChar from to = map $ \v -> if v == from then to else v - -progVersion :: String -progVersion = "nhm-tool " ++ showVersion version - -usage :: Maybe HelpSection -> Bool -> IO () -usage section success = do - when (isNothing section) $ - putStrLn $ progVersion ++ - ": help building custom Haskell handlers for Nginx,\n\ - \this is a tool from \ - \https://github.com/lyokha/nginx-haskell-module\n" - putStrLn "Usage:" - when (isNothing section || section == Just HelpDist) $ - T.putStrLn $ T.concat ["\n\ - \ * nhm-tool dist [-d dir -a ar | -p] [-t target_dir] [-v | -vv] \ - \lib\n\n\ - \ collect Haskell libraries on which 'lib' depends,\n\ - \ patch 'lib' to enable loading dependent libraries from \ - \'target_dir'\n\n\ - \ 'dir' is a directory where dependent libraries will be collected\n\ - \ (default is ", T.pack defaultDistDataDir, ")\n\ - \ 'target_dir' is a directory where dependent libraries will be\n\ - \ installed (no default, 'lib' will not be patched if omitted)\n\ - \ 'ar' is the base name of the archive to contain 'lib' and\n\ - \ 'dir' (no default, the archive will not be created if omitted)\n\ - \ if '-p' (patch-only) is specified then dependent libraries will\n\ - \ neither be collected nor archived\n\ - \ use options '-v' and '-vv' to increase verbosity level\n\ - \ special value '-' for 'dir', 'target_dir', and 'ar' resets them\n\ - \ (with -d- being equivalent to -p)" - ] - when (isNothing section || section `elem` map Just [HelpPlan, HelpDeps]) $ - T.putStrLn "\n\ - \ * nhm-tool plan [-d dir] [deps project-name | abi]\n\n\ - \ print build plan or its derivatives:\n\ - \ 'deps' print all direct dependencies of 'project-name',\n\ - \ the output is compatible with the format of GHC environment \ - \files\n\ - \ 'abi' print 'Arch-Os-CompilerId' bundle in GHC style\n\n\ - \ 'dir' is the cabal build directory where the build plan is \ - \located\n\ - \ (default is dist-newstyle)" - when (isNothing section || section == Just HelpDeps) $ - T.putStrLn "\n\ - \ * nhm-tool deps [-d dir] project-name\n\n\ - \ synonym for 'nhm-tool plan [-d dir] deps project-name'" - when (isNothing section || section == Just HelpInit) $ - T.putStrLn $ T.concat ["\n\ - \ * nhm-tool init [-p dir] [-no-threaded] [-f | -to-stdout] \ - \project-name\n\n\ - \ bootstrap environment to build custom Haskell handlers\n\n\ - \ '-p' prefix for install dir, default is ", - T.pack defaultInitDataPrefix, "\n\ - \ '-no-threaded' use base RTS library\n\ - \ '-f' force re-writing of existing files (except the source file)\n\ - \ '-to-stdout' do not write files but dump what will be written" - ] - when (isNothing section) $ - T.putStrLn "\n\ - \ * nhm-tool [-h | -help | --help | -v | -version | --version]\n\n\ - \ show this help message or version and exit,\n\ - \ help options are applicable in sub-commands as well" - if success - then exitSuccess - else exitFailure - -main :: IO () -main = do - args <- getArgs - case args of - "dist" : args' -> do - let distData = foldl parseDistArg (Just defaultArgs) args' - defaultArgs = DistData defaultDistDataDir "" "" False "" - normal normal Nothing False - case distData of - Nothing -> usage (Just HelpDist) False - Just (normalizeDistData -> distData'@DistData {..}) -> - if | distDataHelp -> - usage (Just HelpDist) $ length args' == 1 - | isJust distDataWaitArg - || null distDataTargetLib -> - usage (Just HelpDist) False - | otherwise -> cmdDist distData' - "plan" : args' -> do - let planData = foldl parsePlanArg (Just defaultArgs) args' - defaultArgs = PlanData "" Nothing Nothing False False - case planData of - Nothing -> usage (Just HelpPlan) False - Just planData'@PlanData {..} -> - if | planDataHelp -> - usage (Just HelpPlan) $ length args' == 1 - | isJust planDataWaitArg - || planDataWaitProjectName -> - usage (Just HelpPlan) False - | otherwise -> cmdPlan planData' - "deps" : args' -> do - let planData = foldl parsePlanArg (Just defaultArgs) args' - defaultArgs = PlanData "" Nothing Nothing True False - case planData of - Nothing -> usage (Just HelpDeps) False - Just planData'@PlanData {..} -> - if | planDataHelp -> - usage (Just HelpDeps) $ length args' == 1 - | isJust planDataWaitArg - || planDataWaitProjectName -> - usage (Just HelpDeps) False - | otherwise -> cmdPlan planData' - "init" : args' -> do - let initData = foldl parseInitArg (Just defaultArgs) args' - defaultArgs = InitData defaultInitDataPrefix False False False - "" ["-Wall", "-O2"] Nothing False - case initData of - Nothing -> usage (Just HelpInit) False - Just initData'@InitData {..} -> - if | initDataHelp -> - usage (Just HelpInit) $ length args' == 1 - | isJust initDataWaitArg - || null initDataProject - || initDataForce && initDataToStdout -> - usage (Just HelpInit) False - | otherwise -> cmdInit initData' - [arg] | arg `elem` ["-h", "-help", "--help"] -> - usage Nothing True - | arg `elem` ["-v", "-version", "--version"] -> - putStrLn progVersion >> exitSuccess - args' -> usage Nothing $ null args' - where normalizeDistData dist@DistData { distDataDir = "-" } = - normalizeDistData dist { distDataDir = defaultDistDataDir - , distDataPatchOnly = True - } - normalizeDistData dist@DistData { distDataArchive = "-" } = - normalizeDistData dist { distDataArchive = "" } - normalizeDistData dist@DistData { distDataTargetDir = "-" } = - normalizeDistData dist { distDataTargetDir = "" } - normalizeDistData dist@DistData { distDataDir = "" } = - normalizeDistData dist { distDataDir = defaultDistDataDir } - normalizeDistData dist = dist - -parseDistArg :: Maybe DistData -> String -> Maybe DistData -parseDistArg Nothing _ = Nothing -parseDistArg (Just dist@DistData {..}) arg = - case distDataWaitArg of - Nothing -> - let (opt, value) = splitAt 2 arg - in if | "-d" == opt -> - Just $ if null value - then dist { distDataWaitArg = Just opt } - else dist' { distDataDir = value } - | "-t" == opt -> - Just $ if null value - then dist { distDataWaitArg = Just opt } - else dist' { distDataTargetDir = value } - | "-a" == opt -> - Just $ if null value - then dist { distDataWaitArg = Just opt } - else dist' { distDataArchive = value } - | "-p" == arg -> - Just dist' { distDataPatchOnly = True } - | "-v" == arg -> - Just dist' { distDataOwnVerbosity = verbose } - | "-vv" == arg -> - Just dist' { distDataOwnVerbosity = verbose - , distDataOtherVerbosity = verbose - } - | (`elem` ["-h", "-help", "--help"]) arg -> - Just dist' { distDataHelp = True } - | Just '-' == (fst <$> uncons arg) -> - Nothing - | null distDataTargetLib -> - Just dist' { distDataTargetLib = arg } - | otherwise -> - Nothing - Just "-d" -> Just dist' { distDataDir = arg } - Just "-t" -> Just dist' { distDataTargetDir = arg } - Just "-a" -> Just dist' { distDataArchive = arg } - Just _ -> undefined - where dist' = dist { distDataWaitArg = Nothing } - -parsePlanArg :: Maybe PlanData -> String -> Maybe PlanData -parsePlanArg Nothing _ = Nothing -parsePlanArg (Just plan@PlanData {..}) arg = - case planDataWaitArg of - Nothing -> - let (opt, value) = splitAt 2 arg - in if | "deps" == arg && not hasDataQuery -> - Just plan' { planDataWaitProjectName = True } - | "abi" == arg && not hasDataQuery -> - Just plan' { planDataQuery = Just PlanDataQueryAbi } - | "-d" == opt -> - Just $ if null value - then plan { planDataWaitArg = Just opt } - else plan' { planDataBuilddir = value } - | (`elem` ["-h", "-help", "--help"]) arg -> - Just plan' { planDataHelp = True } - | Just '-' == (fst <$> uncons arg) -> - Nothing - | planDataWaitProjectName -> - Just plan' - { planDataQuery = Just $ PlanDataQueryDeps arg - , planDataWaitProjectName = False - } - | otherwise -> - Nothing - Just "-d" -> Just plan' { planDataBuilddir = arg } - Just _ -> undefined - where plan' = plan { planDataWaitArg = Nothing } - hasDataQuery = isJust planDataQuery || planDataWaitProjectName - -parseInitArg :: Maybe InitData -> String -> Maybe InitData -parseInitArg Nothing _ = Nothing -parseInitArg (Just init'@InitData {..}) arg = - case initDataWaitArg of - Nothing -> - let (opt, value) = splitAt 2 arg - in if | "-p" == opt -> - Just $ if null value - then init' { initDataWaitArg = Just opt } - else init'' { initDataPrefix = value } - | "-no-threaded" == arg -> - Just init'' { initDataNoThreaded = True } - | "-f" == arg -> - Just init'' { initDataForce = True } - | "-to-stdout" == arg -> - Just init'' { initDataToStdout = True } - | (`elem` ["-h", "-help", "--help"]) arg -> - Just init'' { initDataHelp = True } - | Just '-' == (fst <$> uncons arg) -> - Nothing - | null initDataProject -> - Just init'' { initDataProject = arg } - | otherwise -> - Nothing - Just "-p" -> Just init'' { initDataPrefix = arg } - Just _ -> undefined - where init'' = init' { initDataWaitArg = Nothing } - -cmdDist :: DistData -> IO () -cmdDist DistData {..} = do - patchelf <- requireProgram' $ simpleProgram "patchelf" - if distDataPatchOnly - then patchTargetLib patchelf - else do - ldd <- requireProgram' $ simpleProgram "ldd" - putStrLn' "---> Collecting libraries" - lddOut <- getProgramOutput' ldd [distDataTargetLib] - case parseLddOutput lddOut of - Left err -> do - hPutStrLn stderr $ show err ++ " in\n" ++ lddOut - exitFailure - Right recs -> do - tar' <- requireProgram' tarProgram - collectLibs recs lddOut - unless (null distDataTargetDir) $ - putStrLn' "" >> patchTargetLib patchelf - unless (null distDataArchive) $ - putStrLn' "" >> archiveLibs tar' - where patchTargetLib patchelf = unless (null distDataTargetDir) $ do - putStrLn' $ "---> Patching " ++ distDataTargetLib - let printRpath = getProgramOutput' - patchelf ["--print-rpath", distDataTargetLib] - patchelfOut <- printRpath - case parsePatchelfRpathOutput patchelfOut of - Left err -> do - hPutStrLn stderr $ show err ++ " in\n" ++ patchelfOut - exitFailure - Right paths -> do - unless (distDataTargetDir `elem` paths) $ runProgram' - patchelf ["--set-rpath" - ,distDataTargetDir ++ ':' : patchelfOut - ,distDataTargetLib - ] - printRpath >>= putStrLnTrim - collectLibs recs lddOut = do - let recsLibHS = M.fromList $ - mapMaybe (\case - LibHS name path -> Just (name, path) - LibFFI name path -> Just (name, path) - _ -> Nothing - ) recs - if M.null recsLibHS - then do - hPutStrLn stderr $ - "No Haskell libraries were collected in\n" ++ lddOut - exitFailure - else do - let (M.mapMaybe id -> recsLibHS', recsLibHSNotFound) = - M.partition isJust recsLibHS - if M.null recsLibHSNotFound - then do - createDirectoryIfMissing False distDataDir - forM_ (M.elems recsLibHS') $ \path -> do - let dst = distDataDir takeFileName path - putStrLn' $ path ++ " -> " ++ dst - copyFile path dst - else do - hPutStrLn stderr $ - "Haskell libraries " ++ - show (M.keys recsLibHSNotFound) ++ - " were not found in\n" ++ lddOut - exitFailure - archiveLibs tar' = unless (null distDataArchive) $ do - putStrLn' "---> Archiving artifacts" - tarOut <- getProgramOutput' - tar' ["czvf" - ,distDataArchive <.> ".tar.gz" - ,distDataTargetLib - ,distDataDir - ] - putStrLnTrim tarOut - requireProgram' = fmap fst . - flip (requireProgram distDataOtherVerbosity) emptyProgramDb - getProgramOutput' = getProgramOutput distDataOtherVerbosity - runProgram' = runProgram distDataOtherVerbosity - putStrLn' = when (distDataOwnVerbosity == verbose) . putStrLn - putStrLnTrim = putStrLn' . dropWhileEnd (== '\n') - -parsePatchelfRpathOutput :: String -> Either ParseError [String] -parsePatchelfRpathOutput = - parse (many (satisfy (/= colon)) `sepBy` char colon) "patchelf_rpath" - where colon = ':' - -parseLddOutput :: String -> Either ParseError [LddRec] -parseLddOutput = flip parse "ldd" $ manyLines $ - try (toLddRec <$> - anyCharsTill arrow <*> - ((Just .) . (:) <$> char '/' <*> right - <|> Nothing <$ string "not found" - ) - ) - <|> (`LibOther` Nothing) <$> (try right <|> anyCharsTill (arrow *> addr)) - where manyLines = many . (spaces *>) . (<* newline) - toLddRec lib | "libHS" `isPrefixOf` lib = LibHS lib - | "libffi.so" `isPrefixOf` lib = LibFFI lib - | otherwise = LibOther lib - anyCharsTill = manyTill $ satisfy (/= '\n') - right = anyCharsTill $ spaces1 *> addr - addr = string "(0x" *> many1 hexDigit *> char ')' - arrow = spaces1 *> string "=>" *> spaces1 - spaces1 = skipMany1 space - -cmdPlan :: PlanData -> IO () -cmdPlan PlanData {..} = do - let buildDir | null planDataBuilddir = ProjectRelativeToDir "." - | otherwise = InBuildDir planDataBuilddir - path <- findPlanJson buildDir - case planDataQuery of - Nothing -> - readFile path >>= putStrLn - Just (PlanDataQueryDeps proj) -> do - units <- pjUnits <$> decodePlanJson path - let comps = [ uComps - | Unit {..} <- M.elems units - , uType == UnitTypeLocal - , let uPkgName = (\(PkgId (PkgName pkg) _) -> pkg) uPId - , uPkgName == T.pack proj - ] - when (null comps) $ do - hPutStrLn stderr $ "Failed to find plan for " ++ proj - exitFailure - let deps = foldl (\a curComps -> - let libComps = M.filterWithKey - (const . (== CompNameLib)) curComps - in M.foldr S.union a $ - M.map ciLibDeps libComps - ) S.empty comps - forM_ (S.toList deps) $ \(UnitId unit) -> - putStrLn $ "package-id " ++ T.unpack unit - Just PlanDataQueryAbi -> do - PlanJson {..} <- decodePlanJson path - T.putStrLn $ - T.intercalate "-" [pjArch, pjOs, dispPkgId pjCompilerId] - -cmdInit :: InitData -> IO () -cmdInit init'@InitData {..} = do - let files = [("cabal.project", cabalProject init', True) - ,("Setup.hs", setupHs init', True) - ,(initDataProject ++ ".cabal", projectCabal init', True) - ,("Makefile", makefile init', True) - ,(replaceChar '-' '_' initDataProject ++ ".hs" - ,projectHs init' - ,False - ) - ,("hie.yaml", hieYaml init', True) - ] - forM_ files $ \(name, file, overridable) -> - if initDataToStdout - then printHeader (name ++ "\n") >> T.putStrLn file - else do - exists <- doesFileExist name - if exists - then if initDataForce && overridable - then T.writeFile name file - else hPutStrLn stderr $ - if overridable - then useForceMsg name - else existsMsg name - else T.writeFile name file - where printHeader header = do - isANSITerm <- hSupportsANSI stdout - if isANSITerm - then do - setSGR [SetColor Foreground Dull Blue - ,SetUnderlining SingleUnderline - ] - putStrLn header - setSGR [Reset] - else putStrLn $ " ~~~ " ++ header - existsMsg name = "File " ++ name ++ " exists" - useForceMsg name = existsMsg name ++ ", use option -f to override it" - -cabalProject :: InitData -> Text -cabalProject InitData {..} = T.concat - ["packages: ", T.pack initDataProject, ".cabal\n"] - -setupHs :: InitData -> Text -setupHs = const - "import NgxExport.Distribution\n\ - \main = defaultMain\n" - -projectCabal :: InitData -> Text -projectCabal InitData {..} = T.concat - ["name: ", T.pack initDataProject, "\n\ - \version: 0.1.0.0\n\ - \build-type: Custom\n\ - \cabal-version: 2.0\n\ - \\n\ - \custom-setup\n\ - \ setup-depends: base >= 4.8 && < 5\n\ - \ , ngx-export-distribution\n\ - \\n\ - \library\n\ - \ default-language: Haskell2010\n\ - \ build-tool-depends: ngx-export-distribution:nhm-tool\n\ - \ build-depends: base >= 4.8 && < 5\n\ - \ , ngx-export\n\ - \\n\ - \ ghc-options: ", T.pack $ unwords initDataGhcOptions, "\n" - ,if initDataNoThreaded - then "" - else - "\n\ - \ if impl(ghc >= 9.0.1)\n\ - \ ghc-options: -threaded\n" - ] - -makefile :: InitData -> Text -makefile InitData {..} = T.concat - ["NAME := ", T.pack $ replaceChar '-' '_' initDataProject, "\n\ - \PKGNAME := $(subst _,-,$(NAME))\n\ - \PKGVER := 0.1.0.0\n\ - \\n\ - \PREFIX := ", T.pack initDataPrefix, "\n\ - \MACHINE := $(shell uname -m)\n\ - \KERNEL := $(shell uname -s | tr A-Z a-z)\n\ - \\n\ - \PKGDISTR := ngx-export-distribution\n\ - \NHMTOOL := nhm-tool\n\ - \\n\ - \SRC := $(NAME).hs\n\ - \LIB := $(NAME).so\n\ - \DISTR := $(PKGNAME)-$(PKGVER).tar.gz\n\ - \\n\ - \override OBJS := $(SRC:.hs=.o)\n\ - \override HIOBJS := $(SRC:.hs=.hi)\n\ - \override DYNOBJS := $(SRC:.hs=.dyn_o)\n\ - \override DYNHIOBJS := $(SRC:.hs=.dyn_hi)\n\ - \override STUBS := $(SRC:.hs=_stub.h)\n\ - \\n\ - \GHC := ghc\n\ - \CABAL := cabal\n\ - \GHCVER := $(shell $(GHC) --numeric-version)\n\ - \CABALVER := $(shell $(CABAL) --numeric-version)\n\ - \GHCPUID := $(shell \\\n\ - \ if printf '3.12\\n$(CABALVER)' | sort -VC && \\\n\ - \ printf '9.8\\n$(GHCVER)' | sort -VC; \\\n\ - \ then ghcpuid=`$(GHC) --info | sed -n \\\n\ - \ 's/^.*\\x28\"Project Unit Id\",\"\\(.*\\)\"\\x29.*$$/\ - \\\1/ip'`; \\\n\ - \ if test -z \"$$ghcpuid\"; \\\n\ - \ then echo \"ghc-$(GHCVER)\"; \\\n\ - \ else echo \"$$ghcpuid\"; \\\n\ - \ fi; \\\n\ - \ else echo \"ghc-$(GHCVER)\"; \\\n\ - \ fi)\n\ - \GHCENV := .ghc.environment.$(MACHINE)-$(KERNEL)-$(GHCVER)\n\ - \GHCENVLNK := ", ghcEnvLnk, "\n\ - \DEPLIBS := $(MACHINE)-$(KERNEL)-$(GHCPUID)\n\ - \BUILDDIR := dist-nhm\n\ - \SETUPCONFIG := $(BUILDDIR)/setup-config\n\ - \\n\ - \.PHONY: all env config install clean clean-all\n\ - \\n\ - \all: $(DISTR)\n\ - \\n\ - \env: $(GHCENVLNK)\n\ - \\n\ - \config: $(SETUPCONFIG)\n\ - \\n\ - \$(GHCENVLNK): cabal.project $(PKGNAME).cabal\n\ - \\trm -f \"$(GHCENVLNK)\"\n\ - \\t$(CABAL) install --builddir=\"$(BUILDDIR)\" --lib --only-dependencies \ - \\\\n\ - \\t --package-env .\n\ - \\tsed -i 's/\\(^package-id \\)/--\\1/' \"$(GHCENV)\"\n", - updatePath, - "\t$(NHMTOOL) deps \"$(PKGNAME)\" -d \"$(BUILDDIR)\" >> \"$(GHCENV)\"\n\ - \\tln -sf \"$(GHCENV)\" \"$(GHCENVLNK)\"\n\ - \\n\ - \$(SETUPCONFIG): $(GHCENVLNK)\n", - updatePath, - "\trunhaskell --ghc-arg=-package=base \\\n\ - \\t --ghc-arg=-package=\"$(PKGDISTR)\" Setup.hs configure \\\n\ - \\t --builddir=\"$(BUILDDIR)\" \\\n\ - \\t --package-db=clear --package-db=global \\\n\ - \\t $$(sed -n 's/^\\(package-db\\)\\s\\+/--\\1=/p' \"$(GHCENV)\") \\\n\ - \\t $$(sed -n 's/^package-id\\s\\+\\(.*\\)'` \\\n\ - \\t `'\\(-\\([0-9]\\+\\.\\)*[0-9]\\+\\($$\\|-.*\\)\\)/'` \\\n\ - \\t `'--dependency=\\1=\\1\\2/p' \\\n\ - \\t \"$(GHCENV)\") \\\n\ - \\t --prefix=\"$(PREFIX)\"\n\ - \\n\ - \$(DISTR): $(SETUPCONFIG) $(SRC)\n", - updatePath, - "\trunhaskell --ghc-arg=-package=base \\\n\ - \\t --ghc-arg=-package=\"$(PKGDISTR)\" Setup.hs build \\\n\ - \\t --builddir=\"$(BUILDDIR)\" \\\n\ - \\t --ghc-options=\"$(SRC) -o $(LIB) -package-env $(GHCENVLNK) \ - \$(LINKRTS)\"\n\ - \\n\ - \install: $(DISTR)\n\ - \\tinstall -d \"$(PREFIX)\"\n\ - \\ttar xf \"$(DISTR)\" -C \"$(PREFIX)\" --no-same-owner\n\ - \\n\ - \clean:\n\ - \\trm -rf \"$(DEPLIBS)\"\n\ - \\trm -f $(OBJS) $(HIOBJS) $(DYNOBJS) $(DYNHIOBJS) $(STUBS)\n\ - \\trm -f \"$(LIB)\"\n\ - \\n\ - \clean-all: clean\n\ - \\trm -rf \"$(BUILDDIR)\"\n\ - \\trm -f \"$(GHCENV)\" \"$(GHCENVLNK)\" \"$(DISTR)\"\n" - ] - where updatePath = - "\tif test \"$(NHMTOOL)\" = nhm-tool && ! command -v nhm-tool \ - \>/dev/null; \\\n\ - \\tthen \\\n\ - \\t PATH=$$(dirname $$($(CABAL) list-bin \"$(PKGDISTR)\" \\\n\ - \\t --builddir=\"$(BUILDDIR)\")):$$PATH; \\\n\ - \\tfi; \\\n" - -projectHs :: InitData -> Text -projectHs InitData {..} = T.concat - ["{-# LANGUAGE TemplateHaskell #-}\n\n\ - \module " - ,T.pack $ foldr (\v -> if v == '-' || v == '_' - then maybe [] (uncurry $ (:) . toUpper) . uncons - else (v :) - ) "" $ '_' : initDataProject - ," where\n\n" - ] - -hieYaml :: InitData -> Text -hieYaml InitData {..} = T.concat - ["cradle:\n\ - \ bios:\n\ - \ shell: |\n\ - \ if [ -L ", ghcEnvLnk, " ]\n\ - \ then\n\ - \ printf \"" - ,T.replace "-" "\\055" $ T.pack $ intercalate "\\n" initDataGhcOptions - ,"\\n\" > \"$HIE_BIOS_OUTPUT\"\n\ - \ find . -name '[A-Z]*.hs' -exec sh -c '\n\ - \ file=$(echo \"$1\" | cut -c 3-)\n\ - \ if grep -q \"^\\s*module $(echo \"$file\" |\n\ - \ sed '\\''s/^\\(.*\\)\\..*/\\1/;s/\\//./g'\\'')\" \ - \\"$file\"\n\ - \ then\n\ - \ echo \"$file\" >> \"$HIE_BIOS_OUTPUT\"\n\ - \ fi\n\ - \ ' sh {} \\;\n\ - \ else\n\ - \ echo \"Ghc environment file wasn't found, \"`\n\ - \ `\"run \\\"make env\\\" and restart \ - \language server.\" >&2\n\ - \ exit 1\n\ - \ fi\n" - ] - -ghcEnvLnk :: Text -ghcEnvLnk = ".ghc.environment.lnk" - diff --git a/nhm-tool/nhm-tool.hs b/nhm-tool/nhm-tool.hs new file mode 100644 --- /dev/null +++ b/nhm-tool/nhm-tool.hs @@ -0,0 +1,668 @@ +{-# LANGUAGE RecordWildCards, LambdaCase, MultiWayIf, ViewPatterns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Main where + +import NgxExport.Distribution.Compat.Verbosity +import Text.Parsec hiding (uncons) +import Distribution.Simple.Program +import Distribution.Verbosity +import Cabal.Plan +import Control.Monad +import qualified Data.Text as T +import qualified Data.Text.IO as T +import Data.Text (Text) +import qualified Data.Map as M +import qualified Data.Set as S +import Data.Maybe +import Data.Char +import Data.List +import System.Console.ANSI +import System.Environment +import System.Directory +import System.FilePath +import System.Exit +import System.IO +import Data.Version (showVersion) +import Paths_ngx_export_distribution (version) + +data DistData = DistData { distDataDir :: String + , distDataArchive :: String + , distDataTargetDir :: String + , distDataPatchOnly :: Bool + , distDataTargetLib :: String + , distDataOwnVerbosity :: Verbosity + , distDataOtherVerbosity :: Verbosity + , distDataWaitArg :: Maybe String + , distDataHelp :: Bool + } + +defaultDistDataDir :: String +defaultDistDataDir = ".hslibs" + +data PlanData = PlanData { planDataBuilddir :: String + , planDataQuery :: Maybe PlanDataQuery + , planDataWaitArg :: Maybe String + , planDataWaitProjectName :: Bool + , planDataHelp :: Bool + } + +data PlanDataQuery = PlanDataQueryDeps String + | PlanDataQueryAbi + +data InitData = InitData { initDataPrefix :: String + , initDataNoThreaded :: Bool + , initDataForce :: Bool + , initDataToStdout :: Bool + , initDataProject :: String + , initDataGhcOptions :: [String] + , initDataWaitArg :: Maybe String + , initDataHelp :: Bool + } + +defaultInitDataPrefix :: String +defaultInitDataPrefix = "/var/lib/nginx" + +data LddRec = LibHS String (Maybe FilePath) + | LibFFI String (Maybe FilePath) + | LibOther String (Maybe FilePath) + deriving Show + +data HelpSection = HelpDist | HelpPlan | HelpDeps | HelpInit deriving Eq + +replaceChar :: Char -> Char -> String -> String +replaceChar from to = map $ \v -> if v == from then to else v + +progVersion :: String +progVersion = "nhm-tool " ++ showVersion version + +usage :: Maybe HelpSection -> Bool -> IO () +usage section success = do + when (isNothing section) $ + putStrLn $ progVersion ++ + ": help building custom Haskell handlers for Nginx,\n\ + \this is a tool from \ + \https://github.com/lyokha/nginx-haskell-module\n" + putStrLn "Usage:" + when (isNothing section || section == Just HelpDist) $ + T.putStrLn $ T.concat ["\n\ + \ * nhm-tool dist [-d dir -a ar | -p] [-t target_dir] [-v | -vv] \ + \lib\n\n\ + \ collect Haskell libraries on which 'lib' depends,\n\ + \ patch 'lib' to enable loading dependent libraries from \ + \'target_dir'\n\n\ + \ 'dir' is a directory where dependent libraries will be collected\n\ + \ (default is ", T.pack defaultDistDataDir, ")\n\ + \ 'target_dir' is a directory where dependent libraries will be\n\ + \ installed (no default, 'lib' will not be patched if omitted)\n\ + \ 'ar' is the base name of the archive to contain 'lib' and\n\ + \ 'dir' (no default, the archive will not be created if omitted)\n\ + \ if '-p' (patch-only) is specified then dependent libraries will\n\ + \ neither be collected nor archived\n\ + \ use options '-v' and '-vv' to increase verbosity level\n\ + \ special value '-' for 'dir', 'target_dir', and 'ar' resets them\n\ + \ (with -d- being equivalent to -p)" + ] + when (isNothing section || section `elem` map Just [HelpPlan, HelpDeps]) $ + T.putStrLn "\n\ + \ * nhm-tool plan [-d dir] [deps project-name | abi]\n\n\ + \ print build plan or its derivatives:\n\ + \ 'deps' print all direct dependencies of 'project-name',\n\ + \ the output is compatible with the format of GHC environment \ + \files\n\ + \ 'abi' print 'Arch-Os-CompilerId' bundle in GHC style\n\n\ + \ 'dir' is the cabal build directory where the build plan is \ + \located\n\ + \ (default is dist-newstyle)" + when (isNothing section || section == Just HelpDeps) $ + T.putStrLn "\n\ + \ * nhm-tool deps [-d dir] project-name\n\n\ + \ synonym for 'nhm-tool plan [-d dir] deps project-name'" + when (isNothing section || section == Just HelpInit) $ + T.putStrLn $ T.concat ["\n\ + \ * nhm-tool init [-p dir] [-no-threaded] [-f | -to-stdout] \ + \project-name\n\n\ + \ bootstrap environment to build custom Haskell handlers\n\n\ + \ '-p' prefix for install dir, default is ", + T.pack defaultInitDataPrefix, "\n\ + \ '-no-threaded' use base RTS library\n\ + \ '-f' force re-writing of existing files (except the source file)\n\ + \ '-to-stdout' do not write files but dump what will be written" + ] + when (isNothing section) $ + T.putStrLn "\n\ + \ * nhm-tool [-h | -help | --help | -v | -version | --version]\n\n\ + \ show this help message or version and exit,\n\ + \ help options are applicable in sub-commands as well" + if success + then exitSuccess + else exitFailure + +main :: IO () +main = do + args <- getArgs + case args of + "dist" : args' -> do + let distData = foldl parseDistArg (Just defaultArgs) args' + verbosity = defaultVerbosity + defaultArgs = DistData defaultDistDataDir "" "" False "" + verbosity verbosity Nothing False + case distData of + Nothing -> usage (Just HelpDist) False + Just (normalizeDistData -> distData'@DistData {..}) -> + if | distDataHelp -> + usage (Just HelpDist) $ length args' == 1 + | isJust distDataWaitArg + || null distDataTargetLib -> + usage (Just HelpDist) False + | otherwise -> cmdDist distData' + "plan" : args' -> do + let planData = foldl parsePlanArg (Just defaultArgs) args' + defaultArgs = PlanData "" Nothing Nothing False False + case planData of + Nothing -> usage (Just HelpPlan) False + Just planData'@PlanData {..} -> + if | planDataHelp -> + usage (Just HelpPlan) $ length args' == 1 + | isJust planDataWaitArg + || planDataWaitProjectName -> + usage (Just HelpPlan) False + | otherwise -> cmdPlan planData' + "deps" : args' -> do + let planData = foldl parsePlanArg (Just defaultArgs) args' + defaultArgs = PlanData "" Nothing Nothing True False + case planData of + Nothing -> usage (Just HelpDeps) False + Just planData'@PlanData {..} -> + if | planDataHelp -> + usage (Just HelpDeps) $ length args' == 1 + | isJust planDataWaitArg + || planDataWaitProjectName -> + usage (Just HelpDeps) False + | otherwise -> cmdPlan planData' + "init" : args' -> do + let initData = foldl parseInitArg (Just defaultArgs) args' + defaultArgs = InitData defaultInitDataPrefix False False False + "" ["-Wall", "-O2"] Nothing False + case initData of + Nothing -> usage (Just HelpInit) False + Just initData'@InitData {..} -> + if | initDataHelp -> + usage (Just HelpInit) $ length args' == 1 + | isJust initDataWaitArg + || null initDataProject + || initDataForce && initDataToStdout -> + usage (Just HelpInit) False + | otherwise -> cmdInit initData' + [arg] | arg `elem` ["-h", "-help", "--help"] -> + usage Nothing True + | arg `elem` ["-v", "-version", "--version"] -> + putStrLn progVersion >> exitSuccess + args' -> usage Nothing $ null args' + where normalizeDistData dist@DistData { distDataDir = "-" } = + normalizeDistData dist { distDataDir = defaultDistDataDir + , distDataPatchOnly = True + } + normalizeDistData dist@DistData { distDataArchive = "-" } = + normalizeDistData dist { distDataArchive = "" } + normalizeDistData dist@DistData { distDataTargetDir = "-" } = + normalizeDistData dist { distDataTargetDir = "" } + normalizeDistData dist@DistData { distDataDir = "" } = + normalizeDistData dist { distDataDir = defaultDistDataDir } + normalizeDistData dist = dist + +parseDistArg :: Maybe DistData -> String -> Maybe DistData +parseDistArg Nothing _ = Nothing +parseDistArg (Just dist@DistData {..}) arg = + case distDataWaitArg of + Nothing -> + let (opt, value) = splitAt 2 arg + in if | "-d" == opt -> + Just $ if null value + then dist { distDataWaitArg = Just opt } + else dist' { distDataDir = value } + | "-t" == opt -> + Just $ if null value + then dist { distDataWaitArg = Just opt } + else dist' { distDataTargetDir = value } + | "-a" == opt -> + Just $ if null value + then dist { distDataWaitArg = Just opt } + else dist' { distDataArchive = value } + | "-p" == arg -> + Just dist' { distDataPatchOnly = True } + | "-v" == arg -> + Just dist' { distDataOwnVerbosity = verbose' } + | "-vv" == arg -> + Just dist' { distDataOwnVerbosity = verbose' + , distDataOtherVerbosity = verbose' + } + | (`elem` ["-h", "-help", "--help"]) arg -> + Just dist' { distDataHelp = True } + | Just '-' == (fst <$> uncons arg) -> + Nothing + | null distDataTargetLib -> + Just dist' { distDataTargetLib = arg } + | otherwise -> + Nothing + Just "-d" -> Just dist' { distDataDir = arg } + Just "-t" -> Just dist' { distDataTargetDir = arg } + Just "-a" -> Just dist' { distDataArchive = arg } + Just _ -> undefined + where dist' = dist { distDataWaitArg = Nothing } + verbose' = toVerbosity verbose + +parsePlanArg :: Maybe PlanData -> String -> Maybe PlanData +parsePlanArg Nothing _ = Nothing +parsePlanArg (Just plan@PlanData {..}) arg = + case planDataWaitArg of + Nothing -> + let (opt, value) = splitAt 2 arg + in if | "deps" == arg && not hasDataQuery -> + Just plan' { planDataWaitProjectName = True } + | "abi" == arg && not hasDataQuery -> + Just plan' { planDataQuery = Just PlanDataQueryAbi } + | "-d" == opt -> + Just $ if null value + then plan { planDataWaitArg = Just opt } + else plan' { planDataBuilddir = value } + | (`elem` ["-h", "-help", "--help"]) arg -> + Just plan' { planDataHelp = True } + | Just '-' == (fst <$> uncons arg) -> + Nothing + | planDataWaitProjectName -> + Just plan' + { planDataQuery = Just $ PlanDataQueryDeps arg + , planDataWaitProjectName = False + } + | otherwise -> + Nothing + Just "-d" -> Just plan' { planDataBuilddir = arg } + Just _ -> undefined + where plan' = plan { planDataWaitArg = Nothing } + hasDataQuery = isJust planDataQuery || planDataWaitProjectName + +parseInitArg :: Maybe InitData -> String -> Maybe InitData +parseInitArg Nothing _ = Nothing +parseInitArg (Just init'@InitData {..}) arg = + case initDataWaitArg of + Nothing -> + let (opt, value) = splitAt 2 arg + in if | "-p" == opt -> + Just $ if null value + then init' { initDataWaitArg = Just opt } + else init'' { initDataPrefix = value } + | "-no-threaded" == arg -> + Just init'' { initDataNoThreaded = True } + | "-f" == arg -> + Just init'' { initDataForce = True } + | "-to-stdout" == arg -> + Just init'' { initDataToStdout = True } + | (`elem` ["-h", "-help", "--help"]) arg -> + Just init'' { initDataHelp = True } + | Just '-' == (fst <$> uncons arg) -> + Nothing + | null initDataProject -> + Just init'' { initDataProject = arg } + | otherwise -> + Nothing + Just "-p" -> Just init'' { initDataPrefix = arg } + Just _ -> undefined + where init'' = init' { initDataWaitArg = Nothing } + +cmdDist :: DistData -> IO () +cmdDist DistData {..} = do + patchelf <- requireProgram' $ simpleProgram "patchelf" + if distDataPatchOnly + then patchTargetLib patchelf + else do + ldd <- requireProgram' $ simpleProgram "ldd" + putStrLn' "---> Collecting libraries" + lddOut <- getProgramOutput' ldd [distDataTargetLib] + case parseLddOutput lddOut of + Left err -> do + hPutStrLn stderr $ show err ++ " in\n" ++ lddOut + exitFailure + Right recs -> do + tar' <- requireProgram' tarProgram + collectLibs recs lddOut + unless (null distDataTargetDir) $ + putStrLn' "" >> patchTargetLib patchelf + unless (null distDataArchive) $ + putStrLn' "" >> archiveLibs tar' + where patchTargetLib patchelf = unless (null distDataTargetDir) $ do + putStrLn' $ "---> Patching " ++ distDataTargetLib + let printRpath = getProgramOutput' + patchelf ["--print-rpath", distDataTargetLib] + patchelfOut <- printRpath + case parsePatchelfRpathOutput patchelfOut of + Left err -> do + hPutStrLn stderr $ show err ++ " in\n" ++ patchelfOut + exitFailure + Right paths -> do + unless (distDataTargetDir `elem` paths) $ runProgram' + patchelf ["--set-rpath" + ,distDataTargetDir ++ ':' : patchelfOut + ,distDataTargetLib + ] + printRpath >>= putStrLnTrim + collectLibs recs lddOut = do + let recsLibHS = M.fromList $ + mapMaybe (\case + LibHS name path -> Just (name, path) + LibFFI name path -> Just (name, path) + _ -> Nothing + ) recs + if M.null recsLibHS + then do + hPutStrLn stderr $ + "No Haskell libraries were collected in\n" ++ lddOut + exitFailure + else do + let (M.mapMaybe id -> recsLibHS', recsLibHSNotFound) = + M.partition isJust recsLibHS + if M.null recsLibHSNotFound + then do + createDirectoryIfMissing False distDataDir + forM_ (M.elems recsLibHS') $ \path -> do + let dst = distDataDir takeFileName path + putStrLn' $ path ++ " -> " ++ dst + copyFile path dst + else do + hPutStrLn stderr $ + "Haskell libraries " ++ + show (M.keys recsLibHSNotFound) ++ + " were not found in\n" ++ lddOut + exitFailure + archiveLibs tar' = unless (null distDataArchive) $ do + putStrLn' "---> Archiving artifacts" + tarOut <- getProgramOutput' + tar' ["czvf" + ,distDataArchive <.> ".tar.gz" + ,distDataTargetLib + ,distDataDir + ] + putStrLnTrim tarOut + requireProgram' = fmap fst . + flip (requireProgram distDataOtherVerbosity) emptyProgramDb + getProgramOutput' = getProgramOutput distDataOtherVerbosity + runProgram' = runProgram distDataOtherVerbosity + putStrLn' = when (toVerbosityFlags distDataOwnVerbosity == verbose) . + putStrLn + putStrLnTrim = putStrLn' . dropWhileEnd (== '\n') + +parsePatchelfRpathOutput :: String -> Either ParseError [String] +parsePatchelfRpathOutput = + parse (many (satisfy (/= colon)) `sepBy` char colon) "patchelf_rpath" + where colon = ':' + +parseLddOutput :: String -> Either ParseError [LddRec] +parseLddOutput = flip parse "ldd" $ manyLines $ + try (toLddRec <$> + anyCharsTill arrow <*> + ((Just .) . (:) <$> char '/' <*> right + <|> Nothing <$ string "not found" + ) + ) + <|> (`LibOther` Nothing) <$> (try right <|> anyCharsTill (arrow *> addr)) + where manyLines = many . (spaces *>) . (<* newline) + toLddRec lib | "libHS" `isPrefixOf` lib = LibHS lib + | "libffi.so" `isPrefixOf` lib = LibFFI lib + | otherwise = LibOther lib + anyCharsTill = manyTill $ satisfy (/= '\n') + right = anyCharsTill $ spaces1 *> addr + addr = string "(0x" *> many1 hexDigit *> char ')' + arrow = spaces1 *> string "=>" *> spaces1 + spaces1 = skipMany1 space + +cmdPlan :: PlanData -> IO () +cmdPlan PlanData {..} = do + let buildDir | null planDataBuilddir = ProjectRelativeToDir "." + | otherwise = InBuildDir planDataBuilddir + path <- findPlanJson buildDir + case planDataQuery of + Nothing -> + readFile path >>= putStrLn + Just (PlanDataQueryDeps proj) -> do + units <- pjUnits <$> decodePlanJson path + let comps = [ uComps + | Unit {..} <- M.elems units + , uType == UnitTypeLocal + , let uPkgName = (\(PkgId (PkgName pkg) _) -> pkg) uPId + , uPkgName == T.pack proj + ] + when (null comps) $ do + hPutStrLn stderr $ "Failed to find plan for " ++ proj + exitFailure + let deps = foldl (\a curComps -> + let libComps = M.filterWithKey + (const . (== CompNameLib)) curComps + in M.foldr S.union a $ + M.map ciLibDeps libComps + ) S.empty comps + forM_ (S.toList deps) $ \(UnitId unit) -> + putStrLn $ "package-id " ++ T.unpack unit + Just PlanDataQueryAbi -> do + PlanJson {..} <- decodePlanJson path + T.putStrLn $ + T.intercalate "-" [pjArch, pjOs, dispPkgId pjCompilerId] + +cmdInit :: InitData -> IO () +cmdInit init'@InitData {..} = do + let files = [("cabal.project", cabalProject init', True) + ,("Setup.hs", setupHs init', True) + ,(initDataProject ++ ".cabal", projectCabal init', True) + ,("Makefile", makefile init', True) + ,(replaceChar '-' '_' initDataProject ++ ".hs" + ,projectHs init' + ,False + ) + ,("hie.yaml", hieYaml init', True) + ] + forM_ files $ \(name, file, overridable) -> + if initDataToStdout + then printHeader (name ++ "\n") >> T.putStrLn file + else do + exists <- doesFileExist name + if exists + then if initDataForce && overridable + then T.writeFile name file + else hPutStrLn stderr $ + if overridable + then useForceMsg name + else existsMsg name + else T.writeFile name file + where printHeader header = do + isANSITerm <- hSupportsANSI stdout + if isANSITerm + then do + setSGR [SetColor Foreground Dull Blue + ,SetUnderlining SingleUnderline + ] + putStrLn header + setSGR [Reset] + else putStrLn $ " ~~~ " ++ header + existsMsg name = "File " ++ name ++ " exists" + useForceMsg name = existsMsg name ++ ", use option -f to override it" + +cabalProject :: InitData -> Text +cabalProject InitData {..} = T.concat + ["packages: ", T.pack initDataProject, ".cabal\n"] + +setupHs :: InitData -> Text +setupHs = const + "import NgxExport.Distribution\n\ + \main = defaultMain\n" + +projectCabal :: InitData -> Text +projectCabal InitData {..} = T.concat + ["name: ", T.pack initDataProject, "\n\ + \version: 0.1.0.0\n\ + \build-type: Custom\n\ + \cabal-version: 2.0\n\ + \\n\ + \custom-setup\n\ + \ setup-depends: base >= 4.8 && < 5\n\ + \ , ngx-export-distribution\n\ + \\n\ + \library\n\ + \ default-language: Haskell2010\n\ + \ build-tool-depends: ngx-export-distribution:nhm-tool\n\ + \ build-depends: base >= 4.8 && < 5\n\ + \ , ngx-export\n\ + \\n\ + \ ghc-options: ", T.pack $ unwords initDataGhcOptions, "\n" + ,if initDataNoThreaded + then "" + else + "\n\ + \ if impl(ghc >= 9.0.1)\n\ + \ ghc-options: -threaded\n" + ] + +makefile :: InitData -> Text +makefile InitData {..} = T.concat + ["NAME := ", T.pack $ replaceChar '-' '_' initDataProject, "\n\ + \PKGNAME := $(subst _,-,$(NAME))\n\ + \PKGVER := 0.1.0.0\n\ + \\n\ + \PREFIX := ", T.pack initDataPrefix, "\n\ + \MACHINE := $(shell uname -m)\n\ + \KERNEL := $(shell uname -s | tr A-Z a-z)\n\ + \\n\ + \PKGDISTR := ngx-export-distribution\n\ + \NHMTOOL := nhm-tool\n\ + \\n\ + \SRC := $(NAME).hs\n\ + \LIB := $(NAME).so\n\ + \DISTR := $(PKGNAME)-$(PKGVER).tar.gz\n\ + \\n\ + \override OBJS := $(SRC:.hs=.o)\n\ + \override HIOBJS := $(SRC:.hs=.hi)\n\ + \override DYNOBJS := $(SRC:.hs=.dyn_o)\n\ + \override DYNHIOBJS := $(SRC:.hs=.dyn_hi)\n\ + \override STUBS := $(SRC:.hs=_stub.h)\n\ + \\n\ + \GHC := ghc\n\ + \CABAL := cabal\n\ + \GHCVER := $(shell $(GHC) --numeric-version)\n\ + \CABALVER := $(shell $(CABAL) --numeric-version)\n\ + \GHCPUID := $(shell \\\n\ + \ if printf '3.12\\n$(CABALVER)' | sort -VC && \\\n\ + \ printf '9.8\\n$(GHCVER)' | sort -VC; \\\n\ + \ then ghcpuid=`$(GHC) --info | sed -n \\\n\ + \ 's/^.*\\x28\"Project Unit Id\",\"\\(.*\\)\"\\x29.*$$/\ + \\\1/ip'`; \\\n\ + \ if test -z \"$$ghcpuid\"; \\\n\ + \ then echo \"ghc-$(GHCVER)\"; \\\n\ + \ else echo \"$$ghcpuid\"; \\\n\ + \ fi; \\\n\ + \ else echo \"ghc-$(GHCVER)\"; \\\n\ + \ fi)\n\ + \GHCENV := .ghc.environment.$(MACHINE)-$(KERNEL)-$(GHCVER)\n\ + \GHCENVLNK := ", ghcEnvLnk, "\n\ + \DEPLIBS := $(MACHINE)-$(KERNEL)-$(GHCPUID)\n\ + \BUILDDIR := dist-nhm\n\ + \SETUPCONFIG := $(BUILDDIR)/setup-config\n\ + \\n\ + \.PHONY: all env config install clean clean-all\n\ + \\n\ + \all: $(DISTR)\n\ + \\n\ + \env: $(GHCENVLNK)\n\ + \\n\ + \config: $(SETUPCONFIG)\n\ + \\n\ + \$(GHCENVLNK): cabal.project $(PKGNAME).cabal\n\ + \\trm -f \"$(GHCENVLNK)\"\n\ + \\t$(CABAL) install --builddir=\"$(BUILDDIR)\" --lib --only-dependencies \ + \\\\n\ + \\t --package-env .\n\ + \\tsed -i 's/\\(^package-id \\)/--\\1/' \"$(GHCENV)\"\n", + updatePath, + "\t$(NHMTOOL) deps \"$(PKGNAME)\" -d \"$(BUILDDIR)\" >> \"$(GHCENV)\"\n\ + \\tln -sf \"$(GHCENV)\" \"$(GHCENVLNK)\"\n\ + \\n\ + \$(SETUPCONFIG): $(GHCENVLNK)\n", + updatePath, + "\trunhaskell --ghc-arg=-package=base \\\n\ + \\t --ghc-arg=-package=\"$(PKGDISTR)\" Setup.hs configure \\\n\ + \\t --builddir=\"$(BUILDDIR)\" \\\n\ + \\t --package-db=clear --package-db=global \\\n\ + \\t $$(sed -n 's/^\\(package-db\\)\\s\\+/--\\1=/p' \"$(GHCENV)\") \\\n\ + \\t $$(sed -n 's/^package-id\\s\\+\\(.*\\)'` \\\n\ + \\t `'\\(-\\([0-9]\\+\\.\\)*[0-9]\\+\\($$\\|-.*\\)\\)/'` \\\n\ + \\t `'--dependency=\\1=\\1\\2/p' \\\n\ + \\t \"$(GHCENV)\") \\\n\ + \\t --prefix=\"$(PREFIX)\"\n\ + \\n\ + \$(DISTR): $(SETUPCONFIG) $(SRC)\n", + updatePath, + "\trunhaskell --ghc-arg=-package=base \\\n\ + \\t --ghc-arg=-package=\"$(PKGDISTR)\" Setup.hs build \\\n\ + \\t --builddir=\"$(BUILDDIR)\" \\\n\ + \\t --ghc-options=\"$(SRC) -o $(LIB) -package-env $(GHCENVLNK) \ + \$(LINKRTS)\"\n\ + \\n\ + \install: $(DISTR)\n\ + \\tinstall -d \"$(PREFIX)\"\n\ + \\ttar xf \"$(DISTR)\" -C \"$(PREFIX)\" --no-same-owner\n\ + \\n\ + \clean:\n\ + \\trm -rf \"$(DEPLIBS)\"\n\ + \\trm -f $(OBJS) $(HIOBJS) $(DYNOBJS) $(DYNHIOBJS) $(STUBS)\n\ + \\trm -f \"$(LIB)\"\n\ + \\n\ + \clean-all: clean\n\ + \\trm -rf \"$(BUILDDIR)\"\n\ + \\trm -f \"$(GHCENV)\" \"$(GHCENVLNK)\" \"$(DISTR)\"\n" + ] + where updatePath = + "\tif test \"$(NHMTOOL)\" = nhm-tool && ! command -v nhm-tool \ + \>/dev/null; \\\n\ + \\tthen \\\n\ + \\t PATH=$$(dirname $$($(CABAL) list-bin \"$(PKGDISTR)\" \\\n\ + \\t --builddir=\"$(BUILDDIR)\")):$$PATH; \\\n\ + \\tfi; \\\n" + +projectHs :: InitData -> Text +projectHs InitData {..} = T.concat + ["{-# LANGUAGE TemplateHaskell #-}\n\n\ + \module " + ,T.pack $ foldr (\v -> if v == '-' || v == '_' + then maybe [] (uncurry $ (:) . toUpper) . uncons + else (v :) + ) "" $ '_' : initDataProject + ," where\n\n" + ] + +hieYaml :: InitData -> Text +hieYaml InitData {..} = T.concat + ["cradle:\n\ + \ bios:\n\ + \ shell: |\n\ + \ if [ -L ", ghcEnvLnk, " ]\n\ + \ then\n\ + \ printf \"" + ,T.replace "-" "\\055" $ T.pack $ intercalate "\\n" initDataGhcOptions + ,"\\n\" > \"$HIE_BIOS_OUTPUT\"\n\ + \ find . -name '[A-Z]*.hs' -exec sh -c '\n\ + \ file=$(echo \"$1\" | cut -c 3-)\n\ + \ if grep -q \"^\\s*module $(echo \"$file\" |\n\ + \ sed '\\''s/^\\(.*\\)\\..*/\\1/;s/\\//./g'\\'')\" \ + \\"$file\"\n\ + \ then\n\ + \ echo \"$file\" >> \"$HIE_BIOS_OUTPUT\"\n\ + \ fi\n\ + \ ' sh {} \\;\n\ + \ else\n\ + \ echo \"Ghc environment file wasn't found, \"`\n\ + \ `\"run \\\"make env\\\" and restart \ + \language server.\" >&2\n\ + \ exit 1\n\ + \ fi\n" + ] + +ghcEnvLnk :: Text +ghcEnvLnk = ".ghc.environment.lnk" +