cabin (empty) → 0.1.0.2
raw patch · 6 files changed
+496/−0 lines, 6 filesdep +basedep +binarydep +bytestringsetup-changed
Dependencies added: base, binary, bytestring, directory, filepath, optparse-applicative, process, unix
Files
- Cabin/Internal.hs +57/−0
- Cabin/Package.hs +132/−0
- LICENSE +30/−0
- Main.hs +200/−0
- Setup.hs +2/−0
- cabin.cabal +75/−0
+ Cabin/Internal.hs view
@@ -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 (<$>)
+ Cabin/Package.hs view
@@ -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)+
+ LICENSE view
@@ -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.
+ Main.hs view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabin.cabal view
@@ -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