yarn2nix-0.10.1: NodePackageTool.hs

{-# LANGUAGE RecordWildCards, NoImplicitPrelude, LambdaCase, FlexibleContexts, NamedFieldPuns, OverloadedStrings #-}
import Protolude
import qualified Data.Text as T
import qualified Data.Text.IO as TIO
import qualified Control.Monad.Except as ExcT
import qualified Control.Exception as Exc
import qualified System.IO.Error as IOErr
import qualified Data.ByteString.Lazy as BL
import qualified System.FilePath as FP
import qualified System.Directory as Dir
import qualified System.Posix.Files as PosixFiles
import Options.Applicative

import qualified Distribution.Nodejs.Package as NP
import qualified Data.Aeson.KeyMap as KeyMap
import qualified Data.Aeson.Key as Key

data Args
  = Args
    { argsPackageDir :: FilePath
    , argsMode :: Mode }

data Mode
  = LinkBin
    { linkBinTargetDir :: FilePath }
  | SetBinExecFlag

args :: Parser Args
args = subparser
    (  command "link-bin"
       (info (modeCommands linkBinSubcommands)
         (progDesc "link package dependecies’ bin files"))
    <> command "set-bin-exec-flag"
       (info (modeCommands setBinExecFlagSubcommands)
         (progDesc "make all bin scripts executable")) )
  where
    modeCommands modeSubcommands = Args
      <$> strOption
        ( long "package"
        <> metavar "FOLDER"
        <> help "folder with the node package" )
      <*> modeSubcommands
    linkBinSubcommands = LinkBin
      <$> strOption
        ( long "to"
        <> metavar "LINK_TARGET"
        <> help "folder to link to (absolute or relative from package folder)" )
    setBinExecFlagSubcommands = pure SetBinExecFlag


type ErrorLogger = ExceptT [Char] IO

-- | Print a warning to stdout.
warn :: [Text] -> ErrorLogger ()
warn ws = for_ ws $ \w -> liftIO $ TIO.hPutStrLn stderr ("Warning: " <> w)

-- | On Exception rethrow with annotation.
tryIOMsg :: ([Char] -> [Char]) -> IO a -> ErrorLogger a
tryIOMsg errAnn = ExcT.withExceptT (errAnn . Exc.displayException) . tryIO


main :: IO ()
main = execParser (info (args <**> helper)
                    (progDesc "Tool for various node package maintenance tasks"))
       >>= realMain

realMain :: Args -> IO ()
realMain Args{..} = do
  -- basic sanity checks
  let packageJsonPath = argsPackageDir FP.</> "package.json"
  unlessM (Dir.doesFileExist packageJsonPath)
    $ die $ toS $ packageJsonPath <> " does not exist."
  case argsMode of
    LinkBin{..} -> do
      unlessM (Dir.doesDirectoryExist linkBinTargetDir)
        $ die $ toS $ linkBinTargetDir <> " is not a directory."
    _ -> pass

  -- parse & decode & run logic
  runExceptT
    (tryRead packageJsonPath >>= tryDecode packageJsonPath >>= go)
    >>= \case
      (Left err) -> die $ toS $ "ERROR: " <> err
      (Right _) -> pass

  where
    tryRead :: FilePath -> ErrorLogger BL.ByteString
    tryRead fp = tryIOMsg exc $ BL.readFile fp
      where exc e = fp <> " cannot be read:\n" <> e
    tryDecode :: FilePath -> BL.ByteString -> ExceptT [Char] IO NP.Package
    tryDecode fp fileBs = do
      (pkg, warnings) <- NP.unLoggingPackage
                      <$> ExcT.ExceptT (pure $ first exc $ NP.decode fileBs)
      warn $ fmap ((\w -> toS fp <> ": " <> w) . NP.formatWarning) warnings
      pure pkg
      where exc e = fp <> " cannot be decoded\n" <> toS e

    tryAccess :: IO a -> IO (Maybe a)
    tryAccess io =
      hush <$> tryJust
        (\e -> guard (IOErr.isDoesNotExistError e ||
                      IOErr.isPermissionError e))
          io

    qte s = "\"" <> s <> "\""

    go :: NP.Package -> ErrorLogger ()
    go NP.Package{bin} = do
     binFiles <- readBinFiles bin
     for_ binFiles $ case argsMode of
        -- Link all dependency binaries to their target folder
        LinkBin{..} -> linkBin linkBinTargetDir
        -- Set the executable flag of all package binaries
        SetBinExecFlag -> setBinExecFlag . snd

    -- | Read the binary files and return their names & paths.
    readBinFiles :: NP.Bin -> ErrorLogger [(Text, FilePath)]
    readBinFiles bin = case bin of
      -- files with names how they should be linked
      (NP.BinFiles bs) -> pure $ (bs & KeyMap.toList <&> first Key.toText)
      -- a whole folder where everything should be linked
      (NP.BinFolder bf) -> do
        dirM <- liftIO $ tryAccess (Dir.listDirectory bf)
        case dirM of
          Nothing -> do
            warn ["Binary folder " <> toS (qte bf) <> " could not be accessed."]
            pure []
          (Just dir) ->
            pure $ fmap (\f -> (toS f, bf FP.</> f)) dir

    -- | Canonicalize the path.
    canon :: FilePath -> ErrorLogger FilePath
    canon fp = tryIOMsg
      (\e -> "Couldn’t canonicalize path " <> qte fp <> ": " <> e)
      (Dir.canonicalizePath fp)

    -- | Canonicalize relative to our package
    -- and ensure that the relative path is not outside.
    canonPkg :: FilePath -> ErrorLogger FilePath
    canonPkg relPath = do
      pkgDir <- canon argsPackageDir
      resPath <- canon $ argsPackageDir FP.</> relPath
      when (not $ pkgDir `isPrefixOf` resPath)
        $ throwError $ mconcat
          [ "The link to executable file "
          , qte relPath
          , " lies outside of the package folder!\n"
          , "That’s a security risk, aborting." ]
      pure resPath

    -- | Link a binary file to @targetDir/name@.
    -- @relBinPath@ is relative from the package dir.
    linkBin :: FilePath -> (Text, FilePath) -> ErrorLogger ()
    linkBin targetDir_ (name_, relBinPath) = do
      binPath <- canonPkg relBinPath
      (name, targetDir) <- traverse canon $
        symlinkTarget name_ targetDir_
      tryIOMsg (\e -> "Directory could not be created: " <> e) $
        Dir.createDirectoryIfMissing False targetDir
      tryIOMsg (\e -> "Symlink could not be created: " <> e) $
        PosixFiles.createSymbolicLink binPath $ targetDir FP.</> toS name

    -- | Given a name and a target directory, return
    --   the basename and the target (sub) directory
    --   of the target file
    symlinkTarget :: Text -> FilePath -> (FilePath, FilePath)
    symlinkTarget name targetDir =
      if "/" `T.isInfixOf` name
        then (FP.takeFileName name', targetDir FP.</> FP.takeDirectory name')
        else (name', targetDir)
      where name' = T.unpack name

    -- | Set executable flag of the file.
    setBinExecFlag :: FilePath -> ErrorLogger ()
    setBinExecFlag file_ = do
      file <- canonPkg file_
      res <- liftIO $ tryAccess $ do
        perm <- Dir.getPermissions file
        Dir.setPermissions file
          $ Dir.setOwnerExecutable True perm
      case res of
        Nothing ->
          warn ["Cannot set executable bit on " <> toS file]
        Just () -> pass