mafia install <package>

ambiata-mafia.cabal

@@ -47,6 +47,7 @@ library
 
   exposed-modules:
                     BuildInfo_ambiata_mafia
+                    Mafia.Bin
                     Mafia.Cabal
                     Mafia.Cabal.Dependencies
                     Mafia.Cabal.Index

main/mafia.hs

@@ -19,7 +19,7 @@ import           GHC.Conc (getNumProcessors)
 
 import           Mafia.Cabal
 import           Mafia.Error
-import           Mafia.Home
+import           Mafia.Bin
 import           Mafia.Hoogle
 import           Mafia.IO
 import           Mafia.Init
@@ -75,6 +75,7 @@ data MafiaCommand =
   | MafiaQuick [Flag] [GhciInclude] [File]
   | MafiaWatch [Flag] [GhciInclude] File [Argument]
   | MafiaHoogle [Argument]
+  | MafiaInstall InstallPackage
     deriving (Eq, Show)
 
 data GhciInclude =
@@ -113,6 +114,8 @@ run = \case
     mafiaWatch flags incs entry args
   MafiaHoogle args -> do
     mafiaHoogle args
+  MafiaInstall ipkg -> do
+    mafiaInstall ipkg
 
 parser :: Parser (SafeCommand MafiaCommand)
 parser = safeCommand . subparser . mconcat $ commands
@@ -129,7 +132,7 @@ commands =
             (pure MafiaHash)
 
  , command' "depends" "Show the transitive dependencies of the this package."
-            (MafiaDepends <$> pDependsUI <*> optional pPackageName <*> many pFlag)
+            (MafiaDepends <$> pDependsUI <*> optional pDependsPackageName <*> many pFlag)
 
  , command' "clean" "Clean up after build. Removes the sandbox and the dist directory."
             (pure MafiaClean)
@@ -163,6 +166,10 @@ commands =
 
  , command' "hoogle" ( "Run a hoogle query across the local dependencies" )
             (MafiaHoogle <$> many pCabalArgs)
+
+ , command' "install" ( "Install a hackage package and print the path to its bin directory. "
+                     <> "The general usage is as follows:  $(mafia install pretty-show)/ppsh" )
+            (MafiaInstall <$> pInstallPackage)
  ]
 
 pProfiling :: Parser Profiling
@@ -179,8 +186,20 @@ pDependsUI =
     <> short 't'
     <> help "Display dependencies as a tree."
 
-pPackageName :: Parser PackageName
-pPackageName =
+pInstallPackage :: Parser InstallPackage
+pInstallPackage =
+  let
+    parse txt =
+      fromMaybe
+        (InstallPackageName $ mkPackageName txt)
+        (fmap InstallPackageId $ parsePackageId txt)
+  in
+    fmap parse . argument textRead $
+         metavar "PACKAGE"
+      <> help "Install this <package> or (<package>-<version>) from Hackage."
+
+pDependsPackageName :: Parser PackageName
+pDependsPackageName =
   fmap mkPackageName . argument textRead $
        metavar "PACKAGE"
     <> help "Only include packages in the output which depend on this package."
@@ -254,15 +273,15 @@ mafiaHash = do
 mafiaDepends :: DependsUI -> Maybe PackageName -> [Flag] -> EitherT MafiaError IO ()
 mafiaDepends ui mpkg flags = do
   sdeps <- Set.toList <$> firstT MafiaInitError getSourceDependencies
-  deps <- firstT MafiaCabalError (findDependencies flags sdeps)
+  local <- firstT MafiaCabalError (findDependenciesForCurrentDirectory flags sdeps)
   let
-    deps' = maybe id filterPackages mpkg $ deps
+    deps = maybe id filterPackages mpkg $ pkgDeps local
   case ui of
     List -> do
-      let trans = Set.toList $ transitiveOfPackages deps'
+      let trans = Set.toList $ transitiveOfPackages deps
       traverse_ (liftIO . T.putStrLn . renderPackageRef . pkgRef) trans
     Tree ->
-      liftIO . TL.putStr $ renderTree deps'
+      liftIO . TL.putStr $ renderTree deps
 
 mafiaClean :: EitherT MafiaError IO ()
 mafiaClean = do
@@ -304,7 +323,7 @@ mafiaQuick flags extraIncludes paths = do
 
 mafiaWatch :: [Flag] -> [GhciInclude] -> File -> [Argument] -> EitherT MafiaError IO ()
 mafiaWatch flags extraIncludes path extraArgs = do
-  ghcidExe <- bimapT MafiaProcessError (</> "ghcid") $ installBinary (packageId "ghcid" [0, 5]) []
+  ghcidExe <- bimapT MafiaBinError (</> "ghcid") $ installBinary (ipackageId "ghcid" [0, 5])
   args <- ghciArgs extraIncludes [path]
   initMafia DisableProfiling flags
   exec MafiaProcessError ghcidExe $ [ "-c", T.unwords ("ghci" : args) ] <> extraArgs
@@ -315,6 +334,10 @@ mafiaHoogle args = do
   firstT MafiaInitError (initialize Nothing Nothing)
   hoogle hkg args
 
+mafiaInstall :: InstallPackage -> EitherT MafiaError IO ()
+mafiaInstall ipkg =
+  liftIO . T.putStrLn =<< firstT MafiaBinError (installBinary ipkg)
+
 ghciArgs :: [GhciInclude] -> [File] -> EitherT MafiaError IO [Argument]
 ghciArgs extraIncludes paths = do
   mapM_ checkEntryPoint paths
@@ -366,7 +389,7 @@ initMafia prof flags = do
 
   let ensureExeOnPath' e pkg =
         lookupEnv e >>= mapM_ (\b -> when (b == "true") $ ensureExeOnPath pkg)
-  firstT MafiaProcessError $ ensureExeOnPath' "MAFIA_HAPPY" (packageId "happy" [1, 19, 5])
-  firstT MafiaProcessError $ ensureExeOnPath' "MAFIA_ALEX" (packageId "alex" [3, 1, 6])
-  firstT MafiaProcessError $ ensureExeOnPath' "MAFIA_CPPHS" (packageId "cpphs" [1, 19, 3])
+  firstT MafiaBinError $ ensureExeOnPath' "MAFIA_HAPPY" (ipackageId "happy" [1, 19, 5])
+  firstT MafiaBinError $ ensureExeOnPath' "MAFIA_ALEX" (ipackageId "alex" [3, 1, 6])
+  firstT MafiaBinError $ ensureExeOnPath' "MAFIA_CPPHS" (ipackageId "cpphs" [1, 19, 3])
   firstT MafiaInitError $ initialize (Just prof) (Just flags)

src/Mafia/Bin.hs

@@ -0,0 +1,109 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternSynonyms #-}
+module Mafia.Bin
+  ( BinError(..)
+  , renderBinError
+
+  , InstallPackage(..)
+  , ipackageId
+  , renderInstallPackage
+  , ipkgName
+  , ipkgVersion
+
+  , installBinary
+  , ensureExeOnPath
+  ) where
+
+import           Control.Monad.IO.Class (MonadIO(..))
+
+import           Data.Text (Text)
+import qualified Data.Text as T
+
+import           Mafia.Home
+import           Mafia.IO
+import           Mafia.Install
+import           Mafia.Package
+import           Mafia.Path
+import           Mafia.Cabal.Types
+import           P
+
+import           System.IO (IO)
+import           System.Posix.Files (createSymbolicLink)
+
+import           X.Control.Monad.Trans.Either (EitherT, left)
+
+
+data BinError =
+    BinInstallError InstallError
+  | BinNotExecutable PackageId
+    deriving (Show)
+
+renderBinError :: BinError -> Text
+renderBinError = \case
+  BinInstallError err ->
+    renderInstallError err
+  BinNotExecutable pid ->
+    "Cannot link bin/ directory for " <> renderPackageId pid <> " as no executables were installed."
+
+data InstallPackage =
+    InstallPackageName PackageName
+  | InstallPackageId PackageId
+    deriving (Eq, Ord, Show)
+
+ipackageId :: Text -> [Int] -> InstallPackage
+ipackageId name ver =
+  InstallPackageId (packageId name ver)
+
+renderInstallPackage :: InstallPackage -> Text
+renderInstallPackage = \case
+  InstallPackageName name ->
+    unPackageName name
+  InstallPackageId pid ->
+    renderPackageId pid
+
+ipkgName :: InstallPackage -> PackageName
+ipkgName = \case
+  InstallPackageName name ->
+    name
+  InstallPackageId pid ->
+    pkgName pid
+
+ipkgVersion :: InstallPackage -> Maybe Version
+ipkgVersion = \case
+  InstallPackageName _ ->
+    Nothing
+  InstallPackageId pid ->
+    Just (pkgVersion pid)
+
+-- | Installs a given cabal package at a specific version and return a directory containing all executables
+installBinary :: InstallPackage -> EitherT BinError IO Directory
+installBinary ipkg = do
+  bin <- ensureMafiaDir "bin"
+
+  let
+    plink = bin </> renderInstallPackage ipkg
+    pdir = plink <> "/"
+    pbin = plink <> "/bin"
+
+  unlessM (doesDirectoryExist pdir) $ do
+    -- if the directory doesn't exist, but there happens to be a file there, we
+    -- must have a dead symlink, so lets remove it and install it again.
+    ignoreIO $ removeFile plink
+
+    pkg <- firstT BinInstallError $ installPackage (ipkgName ipkg) (ipkgVersion ipkg)
+    env <- firstT BinInstallError $ getPackageEnv
+    let gdir = packageSandboxDir env pkg
+
+    unlessM (doesDirectoryExist $ gdir </> "bin") $
+      left (BinNotExecutable . refId $ pkgRef pkg)
+
+    liftIO $ createSymbolicLink (T.unpack gdir) (T.unpack plink)
+
+  return pbin
+
+ensureExeOnPath :: InstallPackage -> EitherT BinError IO ()
+ensureExeOnPath pkg = do
+  dir <- installBinary pkg
+  setEnv "PATH" . maybe dir (\path -> dir <> ":" <> path) =<< lookupEnv "PATH"

src/Mafia/Cabal/Dependencies.hs

@@ -5,8 +5,10 @@
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Mafia.Cabal.Dependencies
-  ( filterPackages
-  , findDependencies
+  ( findDependenciesForCurrentDirectory
+  , findDependenciesForPackage
+
+  , filterPackages
   , flagArg
 
     -- exported for testing
@@ -64,20 +66,19 @@ filterPackage name = \case
 
 ------------------------------------------------------------------------
 
-findDependencies :: [Flag] -> [SourcePackage] -> EitherT CabalError IO (Set Package)
-findDependencies flags spkgs = do
-  fromInstallPlan spkgs <$> calculateInstallPlan flags spkgs
+findDependenciesForCurrentDirectory :: [Flag] -> [SourcePackage] -> EitherT CabalError IO Package
+findDependenciesForCurrentDirectory flags spkgs = do
+  hoistEither . fromInstallPlan spkgs =<< installPlanForCurrentDirectory flags spkgs
+
+findDependenciesForPackage :: PackageName -> Maybe Version -> EitherT CabalError IO Package
+findDependenciesForPackage name mver = do
+  hoistEither . fromInstallPlan [] =<< installPlanForPackage name mver
 
-fromInstallPlan :: [SourcePackage] -> [PackagePlan] -> Set Package
+fromInstallPlan :: [SourcePackage] -> [PackagePlan] -> Either CabalError Package
 fromInstallPlan spkgs rdeps =
   let rdMap =
         mapFromList (refId . ppRef) rdeps
 
-      topLevels =
-        Map.fromList .
-        fmap (\pp -> (refId $ ppRef pp, ())) $
-        filter (null . ppDeps) rdeps
-
       spCombine s r =
         r { ppRef = (ppRef r) { refSrcPkg = Just s } }
 
@@ -111,12 +112,22 @@ fromInstallPlan spkgs rdeps =
       lookupRef ref =
         fromMaybe (mkPackage ref Set.empty) (Map.lookup ref dependencies)
 
+      topLevels =
+        fmap (refId . ppRef) $
+        filter (null . ppDeps) rdeps
+
   in
-    Set.unions .
-    fmap pkgDeps .
-    Map.elems .
-    fmap lookupRef $
-    Map.intersection packageRefs topLevels
+    case topLevels of
+      [] ->
+        Left CabalNoTopLevelPackage
+      [topLevel] ->
+        case fmap lookupRef (Map.lookup topLevel packageRefs) of
+          Nothing ->
+            Left (CabalTopLevelPackageNotFoundInPlan topLevel)
+          Just pkg ->
+            Right pkg
+      xs ->
+        Left (CabalMultipleTopLevelPackages xs)
 
 reifyPackageRefs :: Map PackageRef (Set PackageRef) -> Map PackageRef Package
 reifyPackageRefs refs =
@@ -135,38 +146,55 @@ toGraphKey pp = (pp, refId (ppRef pp), ppDeps pp)
 fromGraphKey :: (PackagePlan, PackageId, [PackageId]) -> PackageRef
 fromGraphKey (pp, _, _) = ppRef pp
 
-calculateInstallPlan :: [Flag] -> [SourcePackage] -> EitherT CabalError IO [PackagePlan]
-calculateInstallPlan flags spkgs = do
+installPlanForCurrentDirectory :: [Flag] -> [SourcePackage] -> EitherT CabalError IO [PackagePlan]
+installPlanForCurrentDirectory flags spkgs = do
+  let
+    -- Make sure we can only install the source package by pinning its version
+    -- explicitly. This makes cabal fail if the .cabal file would have caused
+    -- the hackage version to be installed instead.
+    constraints =
+      concatMap spConstraintArgs spkgs
+
+    flagArgs =
+      fmap flagArg flags
+
+    args =
+      [ "--enable-tests"
+      , "--enable-benchmarks"
+      , "--enable-profiling" ]
+
+  dir <- getCurrentDirectory
+  makeInstallPlan (Just dir) (fmap spDirectory spkgs) (args <> constraints <> flagArgs)
+
+installPlanForPackage :: PackageName -> Maybe Version -> EitherT CabalError IO [PackagePlan]
+installPlanForPackage name = \case
+  Nothing ->
+    makeInstallPlan Nothing [] [unPackageName name]
+  Just ver ->
+    makeInstallPlan Nothing [] [renderPackageId (PackageId name ver)]
+
+makeInstallPlan :: Maybe Directory -> [Directory] -> [Argument] -> EitherT CabalError IO [PackagePlan]
+makeInstallPlan mdir sourcePkgs installArgs = do
   (_ :: GhcVersion) <- firstT CabalGhcError getGhcVersion -- check ghc is on the path
   checkCabalVersion
 
   withSystemTempDirectory "mafia-deps-" $ \tmp -> do
-    dir <- getCurrentDirectory
-
-    let cabal = cabalFrom dir (Just (tmp </> "sandbox.config"))
+    let
+      dir = fromMaybe tmp mdir
+      cabal = cabalFrom dir (Just (tmp </> "sandbox.config"))
 
     Hush <- cabal "sandbox" ["init", "--sandbox", tmp]
 
     -- this is a fast 'cabal sandbox add-source'
-    createIndexFile (fmap spDirectory spkgs) tmp
-
-    -- make sure we're installing the source package by
-    -- pinning its version explicitly
-    let constraints =
-          concatMap spConstraintArgs spkgs
-
-        flagArgs =
-          fmap flagArg flags
-
-        installDryRun args =
-          cabal "install" $
-            [ "--enable-tests"
-            , "--enable-benchmarks"
-            , "--enable-profiling"
-            , "--reorder-goals"
-            , "--max-backjumps=-1"
-            , "--avoid-reinstalls"
-            , "--dry-run" ] <> flagArgs <> constraints <> args
+    createIndexFile sourcePkgs tmp
+
+    let
+      installDryRun args =
+        cabal "install" $
+          [ "--reorder-goals"
+          , "--max-backjumps=-1"
+          , "--avoid-reinstalls"
+          , "--dry-run" ] <> installArgs <> args
 
     result <- liftIO . runEitherT $ installDryRun ["-v2"]
     case result of