diff --git a/Cabin/Internal.hs b/Cabin/Internal.hs new file mode 100644 --- /dev/null +++ b/Cabin/Internal.hs @@ -0,0 +1,57 @@ +module Cabin.Internal where + +import Control.Applicative +import Data.Maybe (fromMaybe) + +import System.Directory (findExecutable, getAppUserDataDirectory) +import System.Exit (exitWith, ExitCode(..)) +import System.FilePath +import System.IO +import System.Process + +-------------------------------------------------------------------------------- +-- Paths +-------------------------------------------------------------------------------- + +getDataDir :: IO FilePath +getDataDir = getAppUserDataDirectory "cabin" + +-- | Location of cabins +getCabinPath :: IO FilePath +getCabinPath = fmap ( "cabins") getDataDir + +-- | Binary path (cabin binaries will be linked here) +getBinaryPath :: IO FilePath +getBinaryPath = fmap ( "bin") getDataDir + +-- | Package DB +getCabinDBPath :: IO FilePath +getCabinDBPath = fmap ( "cabin.db") getDataDir + +getLoadedPath :: IO FilePath +getLoadedPath = fmap ( "loaded") getDataDir + +cabinBinaryDir :: FilePath -> FilePath +cabinBinaryDir = ( ".cabal-sandbox/bin") + +getCabalPath :: IO FilePath +getCabalPath = findExecutable "cabal" >>= return . fromMaybe "/usr/bin/cabal" + +-------------------------------------------------------------------------------- +-- Utility +-------------------------------------------------------------------------------- + +-- | Executes a sequence of commands, where the execution of one command is +-- predicated upon the successful completion of the next. +cmdSeq :: [CreateProcess] -> IO ExitCode +cmdSeq [] = return ExitSuccess +cmdSeq (x : xs) = do + x <- do + (_,_,_,ph) <- createProcess x + waitForProcess ph + case x of + ExitSuccess -> cmdSeq xs + a -> return a + +(|>) :: Functor f => f a -> (a -> b) -> f b +(|>) = flip (<$>) diff --git a/Cabin/Package.hs b/Cabin/Package.hs new file mode 100644 --- /dev/null +++ b/Cabin/Package.hs @@ -0,0 +1,132 @@ +{-# LANGUAGE DeriveGeneric #-} +module Cabin.Package where + +import Cabin.Internal +import Control.Monad (liftM, filterM) +import Control.Exception (IOException, catch) + +import Data.Binary +import Data.List (delete, find) +import Data.Monoid + +import GHC.Generics (Generic) + +import System.Directory (doesFileExist, getDirectoryContents, removeFile) +import System.FilePath +import System.IO (stderr, hPutStrLn) +import System.Process (readProcess) + +-------------------------------------------------------------------------------- +-- Datatypes +-------------------------------------------------------------------------------- + +data CabinInfo = CabinInfo { + cPackages :: [String] + , cBinaries :: [String] +} deriving (Generic, Show) + +instance Binary CabinInfo + +data Cabin = Cabin String CabinInfo deriving (Show, Generic) + +instance Binary Cabin + +-- | Get the name of a cabin +cabinName :: Cabin -> String +cabinName (Cabin name _) = name + +data Status = Loaded | Unloaded deriving (Eq, Show) + +data CabinDB = CabinDB [Cabin] + deriving (Generic) + +instance Binary CabinDB + +instance Monoid CabinDB where + mempty = CabinDB [] + (CabinDB a) `mappend` (CabinDB b) = CabinDB $ a `mappend` b + +-------------------------------------------------------------------------------- +-- Working with the package DB +-------------------------------------------------------------------------------- + +listCabins :: CabinDB -> [Cabin] +listCabins (CabinDB cabs) = cabs + +findCabin :: (Cabin -> Bool) -> CabinDB -> Maybe Cabin +findCabin f (CabinDB cabs) = find f cabs + +findCabinByName :: String -> CabinDB -> Maybe Cabin +findCabinByName name = findCabin (\(Cabin name' _) -> name == name') + +readCabinDB :: IO CabinDB +readCabinDB = catch + (getCabinDBPath >>= \path -> (decodeFile path :: IO CabinDB)) + ((\_ -> do + return mempty + ) :: (IOException -> IO CabinDB)) + +writeCabinDB :: CabinDB + -> IO () +writeCabinDB db = catch + (getCabinDBPath >>= \path -> encodeFile path db) + (\e -> do + let err = show (e :: IOException) + hPutStrLn stderr ("Error: Couldn't write to cabin DB:\n\t" ++ err) + ) + +-------------------------------------------------------------------------------- +-- Querying packages +-------------------------------------------------------------------------------- + +infoCabin :: FilePath -> IO Cabin +infoCabin path = do + cabal <- getCabalPath + pkgs <- fmap lines $ readProcess cabal [ + "--sandbox=" ++ sandboxPath + , "sandbox" + , "hc-pkg" + , "--" + , "list" + ] "" + bins <- getDirectoryContents binDir + |> liftM (binDir ) + >>= filterM doesFileExist + return $ Cabin name $ CabinInfo pkgs bins + where + name = takeBaseName path + sandboxPath = path "cabal.sandbox.config" + binDir = cabinBinaryDir path + +-------------------------------------------------------------------------------- +-- Working with the status DB +-------------------------------------------------------------------------------- + +loadedCabins :: IO [String] +loadedCabins = do + loadedDir <- getLoadedPath + loaded <- (getDirectoryContents loadedDir + |> liftM (loadedDir ) + >>= filterM doesFileExist) + |> liftM takeFileName + return loaded + +cabinStatus :: Cabin -> IO Status +cabinStatus (Cabin name _) = do + loadedDir <- getLoadedPath + exists <- doesFileExist $ loadedDir name + return $ case exists of + True -> Loaded + False -> Unloaded + +writeCabinStatus :: Cabin -> Status -> IO () +writeCabinStatus c@(Cabin name _) stat = do + oldStatus <- cabinStatus c + case (stat, oldStatus) of + (Loaded, Unloaded) -> do -- Mark as loaded + loadedDir <- getLoadedPath + writeFile (loadedDir name) "" + (Unloaded, Loaded) -> do -- Mark as unloaded + loadedDir <- getLoadedPath + removeFile (loadedDir name) + diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Nicholas Clarke + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Nicholas Clarke nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,200 @@ +module Main where + +import Cabin.Package +import Cabin.Internal +import Control.Monad (filterM, liftM) + +import Data.Maybe (fromMaybe) +import Data.Monoid (mempty, (<>)) + +import Options.Applicative +import Options.Applicative.Types (Parser(NilP)) + +import System.Directory +import System.Environment (lookupEnv) +import System.Exit (exitWith, ExitCode(..)) +import System.FilePath +import System.Posix.Files (createSymbolicLink) +import System.Process + +-------------------------------------------------------------------------------- +-- Parsers +-------------------------------------------------------------------------------- + +data InstallOpts = InstallOpts { + ioName :: Maybe String + , ioPackages :: [String] +} + +installOpts :: Parser InstallOpts +installOpts = InstallOpts + <$> optional (strOption ( + long "name" + <> short 'n' + <> metavar "NAME" + <> help ("Name for the new cabin. If not provided, the first package " + ++ "name is used.") + )) + <*> some (argument str (metavar "PACKAGES...")) + +data LoadOpts = LoadOpts { + loNames :: [String] +} + +loadOpts :: Parser LoadOpts +loadOpts = LoadOpts + <$> some (argument str (metavar "CABINS...")) + +data ListOpts = ListOpts { + loOnlyActive :: Bool +} + +listOpts :: Parser ListOpts +listOpts = ListOpts + <$> switch ( long "active" + <> short 'a' + <> help "Show only active cabins." + ) + +emptyOpts :: Parser () +emptyOpts = NilP $ Just () + +data Command = Install InstallOpts + | List ListOpts + | Load LoadOpts + | Unload LoadOpts + | Reindex () + +commandParser :: Parser Command +commandParser = subparser ( + command "install" (info (fmap Install installOpts) + (progDesc "Install a program into a new cabin.")) + <> command "list" (info (fmap List listOpts) ( + progDesc "List available cabins.")) + <> command "load" (info (fmap Load loadOpts) ( + progDesc "Load an installed cabin.")) + <> command "unload" (info (fmap Unload loadOpts) ( + progDesc "Unload a loaded cabin.")) + <> command "reindex" (info (fmap Reindex emptyOpts) ( + progDesc "Rebuild the cabin DB.")) + ) + +-------------------------------------------------------------------------------- +-- Main +-------------------------------------------------------------------------------- + +main :: IO () +main = execParser opts >>= run where + opts = info (helper <*> commandParser) ( + fullDesc + <> progDesc "Cabin - cabal binary tool." + <> header "Cabin." + ) + +run :: Command -> IO () +run (Install opts) = install opts +run (List opts) = list opts +run (Reindex _) = reindex +run (Load opts) = load opts +run (Unload opts) = unload opts +-------------------------------------------------------------------------------- +-- Commands +-------------------------------------------------------------------------------- + +install :: InstallOpts -> IO () +install opts = do + prepareEnvironment + let pkgs = ioPackages opts + name = fromMaybe (head pkgs) $ ioName opts + cabal <- getCabalPath + cabinPath <- fmap ( name) getCabinPath + cabinDB <- readCabinDB + -- Create directory, sandbox init, cabal init + createDirectoryIfMissing True cabinPath + let sboxInitProc = (proc cabal ["sandbox","init"]) { + cwd = Just cabinPath + } + cabalInstallProc = (proc cabal ("install" : pkgs)) { + cwd = Just cabinPath + } + ec <- cmdSeq [sboxInitProc, cabalInstallProc] + case ec of + ExitSuccess -> do + cabin <- infoCabin cabinPath + let cabinDB' = cabinDB <> (CabinDB [cabin]) + writeCabinDB cabinDB' + ExitFailure _ -> removeDirectoryRecursive cabinPath + exitWith ec + +list :: ListOpts -> IO () +list opts = do + dataDir <- getCabinPath + createDirectoryIfMissing True dataDir + cabs <- readCabinDB + cabStats <- mapM (\a -> cabinStatus a >>= \b -> return (a,b)) $ listCabins cabs + mapM_ (putStrLn . showCab) cabStats + where showCab ((Cabin name _, status)) = name ++ " (" ++ show status ++ ")" + +load :: LoadOpts -> IO () +load opts = do + prepareEnvironment + cdb <- readCabinDB + binPath <- getBinaryPath + mapM_ (go cdb binPath) $ loNames opts + where + go cdb binPath name = + let cabin = findCabinByName name cdb + linkPath a = binPath (takeFileName a) + in case cabin of + Nothing -> putStrLn $ "No cabin "++name++" found!" + Just c@(Cabin _ (CabinInfo _ bins)) -> do + stat <- cabinStatus c + case stat of + Loaded -> return () + Unloaded -> do + mapM_ (\a -> createSymbolicLink a (linkPath a)) bins + writeCabinStatus c Loaded + +unload :: LoadOpts -> IO () +unload opts = do + prepareEnvironment + cdb <- readCabinDB + binPath <- getBinaryPath + mapM_ (go cdb binPath) $ loNames opts + where + go cdb binPath name = + let cabin = findCabinByName name cdb + linkPath a = binPath (takeFileName a) + in case cabin of + Nothing -> putStrLn $ "No cabin "++name++" found!" + Just c@(Cabin _ (CabinInfo _ bins)) -> do + stat <- cabinStatus c + case stat of + Unloaded -> return () + Loaded -> do + mapM_ (\a -> removeFile $ linkPath a) bins + writeCabinStatus c Unloaded + +reindex :: IO () +reindex = do + prepareEnvironment + cp <- getCabinPath + putativeCabins <- liftM (filter ( + \a -> notElem (takeFileName a) [".", ".."] + )) $ + getDirectoryContents cp + |> liftM (cp ) + >>= filterM doesDirectoryExist + putStrLn . show $ putativeCabins + cabins <- mapM infoCabin putativeCabins + writeCabinDB $ CabinDB cabins + +-------------------------------------------------------------------------------- +-- Helpers +-------------------------------------------------------------------------------- + +prepareEnvironment :: IO () +prepareEnvironment = do + getCabinPath >>= createDirectoryIfMissing True + getBinaryPath >>= createDirectoryIfMissing True + getLoadedPath >>= createDirectoryIfMissing True diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cabin.cabal b/cabin.cabal new file mode 100644 --- /dev/null +++ b/cabin.cabal @@ -0,0 +1,75 @@ +-- Initial cabin.cabal generated by cabal init. For further documentation, +-- see http://haskell.org/cabal/users-guide/ + +-- The name of the package. +name: cabin + +-- The package version. See the Haskell package versioning policy (PVP) +-- for standards guiding when and how versions should be incremented. +-- http://www.haskell.org/haskellwiki/Package_versioning_policy +-- PVP summary: +-+------- breaking API changes +-- | | +----- non-breaking API additions +-- | | | +--- code changes with no API change +version: 0.1.0.2 +-- A short (one-line) description of the package. +synopsis: Cabal binary sandboxes. + +-- A longer description of the package. +description: A simple package manager for cabal binary packages. Each + binary package is installed to a separate sandbox and can + be loaded into the users profile individually. + +-- The license under which the package is released. +license: BSD3 + +-- The file containing the license text. +license-file: LICENSE + +-- The package author(s). +author: Nicholas Clarke + +-- An email address to which users can send suggestions, bug reports, and +-- patches. +maintainer: nick@topos.org.uk + +-- A copyright notice. +-- copyright: + +category: Distribution + +build-type: Simple + +-- Extra files to be distributed with the package, such as examples or a +-- README. +-- extra-source-files: + +-- Constraint on the version of Cabal needed to build this package. +cabal-version: >=1.10 + + +executable cabin + -- .hs or .lhs file containing the Main module. + main-is: Main.hs + + -- Modules included in this executable, other than Main. + other-modules: Cabin.Package, + Cabin.Internal + + -- LANGUAGE extensions used by modules in this package. + -- other-extensions: + + -- Other library packages from which modules are imported. + build-depends: base >=4.7 && <4.8, + filepath, + process, + directory, + optparse-applicative, + binary, + bytestring, + unix + + -- Directories containing source files. + -- hs-source-dirs: + + -- Base language which the package is written in. + default-language: Haskell2010