{-# LANGUAGE RecordWildCards, LambdaCase, MultiWayIf, ViewPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where
import Text.Parsec
import Distribution.Simple.Program.Types
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
data DistData = DistData { distDataDir :: String
, distDataArchive :: String
, distDataTargetDir :: String
, distDataPatchOnly :: Bool
, distDataTargetLib :: String
, distDataWait :: Maybe ArgWait
, distDataOwnVerbosity :: Verbosity
, distDataOtherVerbosity :: Verbosity
, distDataHelp :: Bool
}
defaultDistDataDir :: String
defaultDistDataDir = ".hslibs"
data DepsData = DepsData { depsDataProject :: String
, depsDataHelp :: Bool
}
data InitData = InitData { initDataPrefix :: String
, initDataNoThreaded :: Bool
, initDataForce :: Bool
, initDataToStdout :: Bool
, initDataProject :: String
, initDataWait :: Maybe ArgWait
, initDataHelp :: Bool
}
defaultInitDataPrefix :: String
defaultInitDataPrefix = "/var/lib/nginx"
data ArgWait = ArgWaitA | ArgWaitD | ArgWaitT | ArgWaitP
data LddRec = LibHS String (Maybe FilePath)
| LibOther String (Maybe FilePath)
deriving Show
data HelpSection = HelpDist | HelpDeps | HelpInit deriving Eq
usage :: Maybe HelpSection -> Bool -> IO ()
usage section success = do
when (isNothing section) $
putStrLn "nhm-tool: 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\n\
\ collected (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 == Just HelpDeps) $
T.putStrLn "\n\
\ * nhm-tool deps project-name\n\n\
\ print all direct dependencies of 'project-name',\n\
\ the output is compatible with the format of GHC environment files"
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]\n\n\
\ show this help message and exit, applicable in sub-commands \
\as well"
if success
then exitSuccess
else exitFailure
main :: IO ()
main = do
args <- getArgs
when (null args) $ usage Nothing True
case head args of
"dist" -> do
let distData = foldl parseDistArgs (Just defaultArgs) $ tail args
defaultArgs = DistData defaultDistDataDir "" "" False ""
Nothing normal normal False
case distData of
Nothing -> usage (Just HelpDist) False
Just (normalizeDistData -> distData'@DistData {..}) ->
if distDataHelp
then usage (Just HelpDist) True
else if isJust distDataWait || null distDataTargetLib
then usage (Just HelpDist) False
else cmdDist distData'
"deps" -> do
let depsData = foldl parseDepsArgs (Just defaultArgs) $ tail args
defaultArgs = DepsData "" False
case depsData of
Nothing -> usage (Just HelpDeps) False
Just depsData'@DepsData {..} ->
if depsDataHelp
then usage (Just HelpDeps) True
else if null depsDataProject
then usage (Just HelpDeps) False
else cmdDeps depsData'
"init" -> do
let initData = foldl parseInitArgs (Just defaultArgs) $ tail args
defaultArgs = InitData defaultInitDataPrefix False False False
"" Nothing False
case initData of
Nothing -> usage (Just HelpInit) False
Just initData'@InitData {..} ->
if initDataHelp
then usage (Just HelpInit) True
else if isJust initDataWait || null initDataProject ||
initDataForce && initDataToStdout
then usage (Just HelpInit) False
else cmdInit initData'
"-h" -> usage Nothing True
"-help" -> usage Nothing True
"--help" -> usage Nothing True
_ -> usage Nothing False
where normalizeDistData dist@DistData {..} =
dist { distDataTargetDir =
if distDataTargetDir == "-"
then ""
else distDataTargetDir
, distDataArchive =
if distDataArchive == "-"
then ""
else distDataArchive
, distDataPatchOnly =
distDataDir == "-" || distDataPatchOnly
}
parseDistArgs :: Maybe DistData -> String -> Maybe DistData
parseDistArgs Nothing _ = Nothing
parseDistArgs (Just dist@DistData {..}) arg =
case distDataWait of
Nothing ->
let optLong = length arg > 2
optValue = drop 2 arg
in if | "-d" `isPrefixOf` arg ->
if optLong
then Just dist' { distDataDir = optValue }
else Just dist { distDataWait = Just ArgWaitD }
| "-t" `isPrefixOf` arg ->
if optLong
then Just dist' { distDataTargetDir = optValue }
else Just dist { distDataWait = Just ArgWaitT }
| "-a" `isPrefixOf` arg ->
if optLong
then Just dist' { distDataArchive = optValue }
else Just dist { distDataWait = Just ArgWaitA }
| "-p" == arg ->
Just dist' { distDataPatchOnly = True }
| "-v" == arg ->
Just dist' { distDataOwnVerbosity = verbose }
| "-vv" == arg ->
Just dist' { distDataOwnVerbosity = verbose
, distDataOtherVerbosity = verbose
}
| "-h" == arg || "-help" == arg || "--help" == arg ->
Just dist' { distDataHelp = True }
| "-" `isPrefixOf` arg -> Nothing
| otherwise ->
if null distDataTargetLib
then Just dist' { distDataTargetLib = arg }
else Nothing
Just ArgWaitD -> Just dist' { distDataDir = arg }
Just ArgWaitT -> Just dist' { distDataTargetDir = arg }
Just ArgWaitA -> Just dist' { distDataArchive = arg }
Just _ -> undefined
where dist' = dist { distDataWait = Nothing }
parseDepsArgs :: Maybe DepsData -> String -> Maybe DepsData
parseDepsArgs Nothing _ = Nothing
parseDepsArgs (Just deps@DepsData {..}) arg =
if | "-h" == arg || "-help" == arg || "--help" == arg ->
Just deps { depsDataHelp = True }
| "-" `isPrefixOf` arg -> Nothing
| otherwise ->
if null depsDataProject
then Just deps { depsDataProject = arg }
else Nothing
parseInitArgs :: Maybe InitData -> String -> Maybe InitData
parseInitArgs Nothing _ = Nothing
parseInitArgs (Just init'@InitData {..}) arg =
case initDataWait of
Nothing ->
let optLong = length arg > 2
optValue = drop 2 arg
in if | "-p" `isPrefixOf` arg ->
if optLong
then Just init'' { initDataPrefix = optValue }
else Just init' { initDataWait = Just ArgWaitP }
| "-no-threaded" == arg ->
Just init'' { initDataNoThreaded = True }
| "-f" == arg ->
Just init'' { initDataForce = True }
| "-to-stdout" == arg ->
Just init'' { initDataToStdout = True }
| "-h" == arg || "-help" == arg || "--help" == arg ->
Just init'' { initDataHelp = True }
| "-" `isPrefixOf` arg -> Nothing
| otherwise ->
if null initDataProject
then Just init'' { initDataProject = arg }
else Nothing
Just ArgWaitP -> Just init'' { initDataPrefix = arg }
Just _ -> undefined
where init'' = init' { initDataWait = Nothing }
cmdDist :: DistData -> IO ()
cmdDist DistData {..} = do
let pdb = emptyProgramDb
patchelf = simpleProgram "patchelf"
ldd = simpleProgram "ldd"
(patchelf', pdb') <- requireProgram distDataOtherVerbosity patchelf pdb
if distDataPatchOnly
then patchTargetLib patchelf'
else do
(ldd', pdb'') <- requireProgram distDataOtherVerbosity ldd pdb'
putStrLn' "---> Collecting libraries"
lddOut <- getProgramOutput distDataOtherVerbosity
ldd' [distDataTargetLib]
case parseLddOutput lddOut of
Left err -> do
hPutStrLn stderr $ show err ++ " in\n" ++ lddOut
exitFailure
Right recs -> do
(tar', _) <- requireProgram distDataOtherVerbosity
tarProgram pdb''
collectLibs recs lddOut
unless (null distDataTargetDir) $ putStrLn' ""
patchTargetLib patchelf'
putStrLn' ""
archiveLibs tar'
where patchTargetLib patchelf' =
unless (null distDataTargetDir) $ do
putStrLn' $ "---> Patching " ++ distDataTargetLib
patchelfOut <- getProgramOutput distDataOtherVerbosity
patchelf' ["--print-rpath", distDataTargetLib]
case parsePatchelfRpathOutput patchelfOut of
Left err -> do
hPutStrLn stderr $ show err ++ " in\n" ++ patchelfOut
exitFailure
Right paths -> do
unless (distDataTargetDir `elem` paths) $
runProgram distDataOtherVerbosity patchelf'
["--set-rpath"
,distDataTargetDir ++ ':' : patchelfOut
,distDataTargetLib
]
patchelfOut' <- getProgramOutput
distDataOtherVerbosity
patchelf' ["--print-rpath"
,distDataTargetLib
]
putStrLnTrim patchelfOut'
collectLibs recs lddOut = do
let recsLibHS = M.fromList $
mapMaybe (\case
LibHS 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 distDataOtherVerbosity tar'
["czvf"
,distDataArchive <.> ".tar.gz"
,distDataTargetLib
,distDataDir
]
putStrLnTrim tarOut
putStrLn' = when (distDataOwnVerbosity == verbose) . putStrLn
putStrLnTrim = putStrLn' . trimEnd '\n'
trimEnd end = fst . foldr (\v a@(vs, skipped) ->
if skipped || v /= end
then (v : vs, True)
else a
) ("", False)
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" $ many $
spaces *>
(try (toLddRec <$>
manyTill anyChar' sep <*>
((Just .) . (:) <$> char '/' <*> right
<|> Nothing <$ string "not found"
)
)
-- FIXME: in some documents, vdso record has an arrow in the middle
-- linux-vdso.so.1 => (0x00007fffd33f2000)
-- this format is not supported here, not sure if it should be.
<|> (`LibOther` Nothing) <$> right
)
where toLddRec lib | "libHS" `isPrefixOf` lib = LibHS lib
| otherwise = LibOther lib
right = manyTill anyChar' $ spaces1 *> addr *> newline
addr = string "(0x" *> many1 hexDigit *> char ')'
anyChar' = satisfy (/= '\n')
sep = spaces1 *> string "=>" *> spaces1
spaces1 = skipMany1 space
cmdDeps :: DepsData -> IO ()
cmdDeps DepsData {..} = do
units <- pjUnits <$> findAndDecodePlanJson (ProjectRelativeToDir ".")
let comps = [ uComps
| Unit {..} <- M.elems units
, uType == UnitTypeLocal
, toPkgName uPId == T.pack depsDataProject
]
when (null comps) $ do
hPutStrLn stderr $ "Failed to find plan for " ++ depsDataProject
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
where toPkgName (PkgId (PkgName name) _) = name
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)
,(replace '-' '_' initDataProject ++ ".hs"
,projectHs init'
,False
)
]
forM_ files $
if initDataToStdout
then \(name, file, _) ->
printHeader (name ++ "\n") >> T.putStrLn file
else \(name, file, overridable) -> 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 replace from to = foldr (\v -> ((if v == from then to else v) :)) ""
printHeader header = do
isTerm <- hIsTerminalDevice stdout
if isTerm
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: 1.24\n\
\\n\
\custom-setup\n\
\ setup-depends: base >= 4.8 && < 5\n\
\ , ngx-export-distribution\n\
\\n\
\library\n\
\ default-language: Haskell2010\n\
\ build-depends: base >= 4.8 && < 5\n\
\ , ngx-export\n\
\\n\
\ ghc-options: -Wall -O2\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.replace "-" "_" $ T.pack 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\
\\n\
\SRC := $(NAME).hs\n\
\LIB := $(NAME).so\n\
\STUB := $(NAME)_stub.h\n\
\DISTR := $(PKGNAME)-$(PKGVER).tar.gz\n\
\\n\
\GHCVER := $(shell ghc --numeric-version)\n\
\GHCENV := .ghc.environment.$(MACHINE)-$(KERNEL)-$(GHCVER)\n\
\DEPLIBS := $(MACHINE)-$(KERNEL)-ghc-$(GHCVER)\n\
\DISTDIR := dist\n\
\DISTV2DIR := dist-newstyle\n\
\\n\
\all: $(DISTR)\n\
\\n\
\$(DISTR): $(SRC)\n\
\\tcabal install --lib --only-dependencies --package-env .\n\
\\tsed -i 's/\\(^package-id \\)/--\\1/' $(GHCENV)\n\
\\trunhaskell --ghc-arg=-package=base \\\n\
\\t --ghc-arg=-package=$(PKGDISTR) Setup.hs configure \\\n\
\\t --package-db=clear --package-db=global \\\n\
\\t $$(sed -n 's/^\\(package-db\\)\\s\\+/--\\1=/p' $(GHCENV)) \\\n\
\\t --prefix=$(PREFIX)\n\
\\tnhm-tool deps $(PKGNAME) >> $(GHCENV)\n\
\\trunhaskell --ghc-arg=-package=base \\\n\
\\t --ghc-arg=-package=$(PKGDISTR) Setup.hs build \\\n\
\\t --ghc-options=\"$(SRC) -o $(LIB) $(LINKRTS)\"\n\
\\n\
\install: $(DISTR)\n\
\\tinstall -d $(PREFIX)\n\
\\ttar xf $(DISTR) -C $(PREFIX) --no-same-owner\n\
\\n\
\.PHONY: clean\n\
\\n\
\clean:\n\
\\trm -rf $(DISTDIR) $(DISTV2DIR) $(DEPLIBS)\n\
\\trm -f $(GHCENV) $(STUB) $(NAME).hi $(NAME).o\n\
\\trm -f $(LIB)\n\
\\n\
\clean-all: clean\n\
\\trm -f $(DISTR)\n"
]
projectHs :: InitData -> Text
projectHs InitData {..} = T.concat
["{-# LANGUAGE TemplateHaskell #-}\n\n\
\module "
,T.pack $ fst $
foldl (\(a, tr) v -> if v == '-' || v == '_'
then (a, True)
else if tr || null a
then (a ++ [toUpper v], False)
else (a ++ [v], False)
) ("", False) initDataProject
, " where\n\n"
]