hackport (empty) → 0.2.1
raw patch · 24 files changed
+1950/−0 lines, 24 filesdep +Cabaldep +HTTPdep +basesetup-changed
Dependencies added: Cabal, HTTP, base, bytestring, containers, directory, filepath, mtl, network, old-time, parsec, process, regex-compat, tar, zlib
Files
- Action.hs +121/−0
- AnsiColor.hs +63/−0
- Bash.hs +45/−0
- BlingBling.hs +15/−0
- Cabal2Ebuild.hs +401/−0
- Cache.hs +93/−0
- CacheFile.hs +12/−0
- Config.hs +125/−0
- Diff.hs +70/−0
- Error.hs +55/−0
- Fetch.hs +75/−0
- GenerateEbuild.hs +60/−0
- Index.hs +45/−0
- Main.hs +136/−0
- MaybeRead.hs +14/−0
- Overlays.hs +59/−0
- P2.hs +106/−0
- Package.hs +76/−0
- Portage.hs +20/−0
- Setup.hs +7/−0
- Status.hs +159/−0
- Utils.hs +7/−0
- Version.hs +122/−0
- hackport.cabal +64/−0
+ Action.hs view
@@ -0,0 +1,121 @@+module Action where++import Config+import Error++import Control.Monad.State+import Control.Monad.Error+import Network.URI (parseURI)+import System.IO+import System.Environment++type HPAction = ErrorT HackPortError (StateT HPState IO)++data HPState = HPState+ { config :: Config+ , indention :: Int+ }++verbose :: HPAction a -> (String,a->String) -> HPAction a+verbose action (premsg,postmsg) = do+ echoIndent+ echo premsg+ flush+ res <- indent action+ echoLn (postmsg res)+ return res++sayNormal :: HPAction a -> (String,a->String) -> HPAction a+sayNormal action strs = do+ cfg <- getCfg+ case verbosity cfg of+ Silent -> action+ _ -> action `verbose` strs++sayDebug :: HPAction a -> (String,a->String) -> HPAction a+sayDebug action strs = do+ cfg <- getCfg+ case verbosity cfg of+ Debug -> action `verbose` strs+ _ -> action++info :: String -> HPAction ()+info str = do+ cfg <- getCfg+ case verbosity cfg of+ Silent -> return ()+ _ -> echoLn str++-- | Prints a string iff in debug output mode+whisper :: String -> HPAction ()+whisper str = do+ cfg <- getCfg+ case verbosity cfg of+ Debug -> echoLn str+ _ -> return ()++getCfg :: HPAction Config+getCfg = gets config++setOverlayPath :: Maybe String -> HPAction ()+setOverlayPath mt = modify $ \hps ->+ hps { config = (config hps) { overlayPath = mt } }++setPortagePath :: Maybe String -> HPAction ()+setPortagePath mt = modify $ \hps ->+ hps { config = (config hps) { portagePath = mt } }++lessIndent :: HPAction ()+lessIndent = modify $ \s -> s { indention = indention s - 1 }++moreIndent :: HPAction ()+moreIndent = modify $ \s -> s { indention = indention s + 1 }++echoIndent :: HPAction ()+echoIndent = do+ ind <- gets indention+ echo (replicate ind '\t')++indent :: HPAction a -> HPAction a+indent action = do+ moreIndent+ res <- action+ lessIndent+ return res++echo :: String -> HPAction ()+echo str = liftIO $ hPutStr stderr str++flush :: HPAction ()+flush = liftIO (hFlush stderr)++echoLn :: String -> HPAction ()+echoLn str = echoIndent >> echo str >> liftIO (hPutChar stderr '\n')++loadConfig :: HPAction OperationMode+loadConfig = do+ args <- liftIO getArgs+ case parseConfig args of+ Left errmsg -> throwError (ArgumentError errmsg)+ Right (opts,opmode) -> do+ cfg <- foldM optionToConfig defaultConfig opts+ modify $ \s -> s { config = cfg }+ return opmode++optionToConfig :: Config -> HackPortOptions -> HPAction Config+optionToConfig cfg opt = case opt of+ OverlayPath str -> return cfg { overlayPath = Just str }+ PortagePath str -> return cfg { portagePath = Just str }+ Server str -> case parseURI str of+ Nothing -> throwError (InvalidServer str)+ Just uri -> return cfg { server = uri }+ TempDir str -> return cfg { tmp = str }+ Verbosity str -> case parseVerbosity str of+ Nothing -> throwError (UnknownVerbosityLevel str)+ Just verb -> return cfg { verbosity=verb }+ Help -> return cfg+ RefreshCache -> return cfg { refreshCache = True }++performHPAction :: HPAction a -> IO (Either HackPortError a)+performHPAction action =+ evalStateT (runErrorT action) (HPState defaultConfig 0)
+ AnsiColor.hs view
@@ -0,0 +1,63 @@+{-|+ Maintainer : Andres Loeh <kosmikus@gentoo.org>+ Stability : provisional+ Portability : haskell98++ Simplistic ANSI color support.+-}++module AnsiColor+ where++import Data.List++data Color = Black+ | Red+ | Green+ | Yellow+ | Blue+ | Magenta+ | Cyan+ | White+ | Default+ deriving Enum++esc :: [String] -> String+esc [] = ""+esc xs = "\ESC[" ++ (concat . intersperse ";" $ xs) ++ "m"++col :: Color -> Bool -> Color -> [String]+col fg bf bg = show (fromEnum fg + 30) : bf' [show (fromEnum bg + 40)]+ where bf' | bf = ("01" :)+ | otherwise = id++inColor :: Color -> Bool -> Color -> String -> String+inColor c bf bg txt = esc (col c bf bg) ++ txt ++ esc ["00"]++bold, italic, underline, inverse :: String -> String+bold = ansi "1" "22"+italic = ansi "3" "23"+underline = ansi "4" "24"+inverse = ansi "7" "27"++ansi :: String -> String -> String -> String+ansi on off txt = esc [on] ++ txt ++ esc [off]++{-+data Doc = Doc (Bool -> String -> String)++char chr = Doc (\_ c -> chr:c)++text str = Doc (\_ c -> str ++ c)++(Doc t) <> (Doc u) = Doc (\b c -> t b (u b c))++t <+> u = t <> char ' ' <> u++showDoc (Doc d) b = d b ""++color (Doc d) color = Doc (\ b c ->+ if not b+ then d b c+ else inColor color False Default (d b ""))+-}
+ Bash.hs view
@@ -0,0 +1,45 @@+module Bash where++import Control.Monad.Error+import System.Process+import System.Directory+import System.IO+import System.Exit++import Action+import Config+import Error++getSystemPortdir :: HPAction String+getSystemPortdir = do+ dir <- runBash "source /etc/make.conf;echo -n $PORTDIR"+ case dir of+ "" -> return "/usr/portage"+ _ -> return dir++getPortdir :: HPAction String+getPortdir = do+ cfg <- getCfg+ case portagePath cfg of+ Just dir -> return dir+ Nothing -> do+ sys <- getSystemPortdir+ setPortagePath (Just sys)+ return sys++runBash ::+ String -> -- ^ The command line+ HPAction String -- ^ The command-line's output+runBash command = do+ mpath <- liftIO $ findExecutable "bash"+ bash <- maybe (throwError BashNotFound) return mpath+ (inp,outp,err,pid) <- liftIO $ runInteractiveProcess bash ["-c",command] Nothing Nothing+ liftIO $ hClose inp+ result <- liftIO $ hGetContents outp+ errors <- liftIO $ hGetContents err+ length result `seq` liftIO (hClose outp)+ length errors `seq` liftIO (hClose err)+ exitCode <- liftIO $ waitForProcess pid+ case exitCode of+ ExitFailure _ -> throwError $ BashError errors+ ExitSuccess -> return result
+ BlingBling.hs view
@@ -0,0 +1,15 @@+module BlingBling where++import System.IO++-- what nobody needs but everyone wants...++-- FIXME: do something more fun here+forMbling :: [a] -> (a -> IO b) -> IO [b]+forMbling lst f = do+ origBuffering <- hGetBuffering stdout+ hSetBuffering stdout NoBuffering+ xs <- mapM (\x -> putStr "." >> f x) lst+ putStrLn ""+ hSetBuffering stdout origBuffering+ return xs
+ Cabal2Ebuild.hs view
@@ -0,0 +1,401 @@+-- A program for generating a Gentoo ebuild from a .cabal file+--+-- Author : Duncan Coutts <dcoutts@gentoo.org>+--+-- Created: 21 July 2005+--+-- Copyright (C) 2005 Duncan Coutts+--+-- This library is free software; you can redistribute it and/or+-- modify it under the terms of the GNU General Public License+-- as published by the Free Software Foundation; either version 2+-- of the License, or (at your option) any later version.+--+-- This library is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+-- General Public License for more details.+--+-- |+-- Maintainer : haskell@gentoo.org+--+-- cabal2ebuild - a program for generating a Gentoo ebuild from a .cabal file+--+module Cabal2Ebuild+ (EBuild(..)+ ,cabal2ebuild+ ,showEBuild) where++import qualified Distribution.PackageDescription as Cabal+ (PackageDescription(..))+import qualified Distribution.Package as Cabal (PackageIdentifier(..), Dependency(..))+import qualified Distribution.Version as Cabal (VersionRange(..), versionBranch, Version)+import qualified Distribution.License as Cabal (License(..))+import qualified Distribution.Text as Cabal (display)+--import qualified Distribution.Compiler as Cabal (CompilerFlavor(..))++import Data.Char (toLower,isUpper)+import Data.List (intercalate, groupBy, partition, nub, sortBy, init, last)+import Data.Ord (comparing)+import Data.Maybe (catMaybes, fromJust)++data EBuild = EBuild {+ name :: String,+ version :: String,+ description :: String,+ homepage :: String,+ src_uri :: String,+ license :: String,+ slot :: String,+ keywords :: [String],+ iuse :: [String],+ depend :: [Dependency],+ features :: [String],+ -- comments on various fields for communicating stuff to the user+ licenseComments :: String,+ my_pn :: Maybe String --If the package's name contains upper-case+ }++type Package = String+newtype Version = Version [Int] deriving (Ord, Eq)+type UseFlag = String+data Dependency = AnyVersionOf Package+ | ThisVersionOf Version Package -- =package-version+ | LaterVersionOf Version Package -- >package-version+ | EarlierVersionOf Version Package -- <package-version+ | OrLaterVersionOf Version Package -- >=package-version+ | OrEarlierVersionOf Version Package -- <=package-version+ | DependEither Dependency Dependency -- depend || depend+ | DependIfUse UseFlag Dependency -- use? ( depend )+ | ThisMajorOf Version Package -- =package-version*+ deriving Eq++ebuildTemplate :: EBuild+ebuildTemplate = EBuild {+ name = "foobar",+ version = "0.1",+ description = "",+ homepage = "",+ src_uri = "",+ license = "",+ slot = "0",+ keywords = ["~amd64","~x86"],+ iuse = [],+ depend = [],+ features = [],+ licenseComments = "",+ my_pn = Nothing+ }++++cabal2ebuild :: Cabal.PackageDescription -> EBuild+cabal2ebuild pkg = ebuildTemplate {+ name = map toLower cabalPkgName,+ version = Cabal.display (Cabal.pkgVersion (Cabal.package pkg)),+ description = if null (Cabal.synopsis pkg) then Cabal.description pkg+ else Cabal.synopsis pkg,+ homepage = Cabal.homepage pkg,+ src_uri = Cabal.pkgUrl pkg,+ license = convertLicense (Cabal.license pkg),+ licenseComments = licenseComment (Cabal.license pkg),+ depend = defaultDepGHC+ : (simplify_deps $+ convertDependency (Cabal.Dependency "Cabal"+ (Cabal.descCabalVersion pkg))+ ++ convertDependencies (Cabal.buildDepends pkg)),+ my_pn = if any isUpper cabalPkgName then Just cabalPkgName else Nothing,+ features = features ebuildTemplate+ ++ (if null (Cabal.executables pkg) then [] else ["bin"])+ ++ maybe [] (const ["lib","profile","haddock"]) (Cabal.library pkg)+ } where+ cabalPkgName = Cabal.pkgName (Cabal.package pkg)++defaultDepGHC :: Dependency+defaultDepGHC = OrLaterVersionOf (Version [6,6,1]) "dev-lang/ghc"++-- map the cabal license type to the gentoo license string format+convertLicense :: Cabal.License -> String+convertLicense Cabal.GPL = "GPL-2" -- almost certainly version 2+convertLicense Cabal.LGPL = "LGPL-2.1" -- probably version 2.1+convertLicense Cabal.BSD3 = "BSD" -- do we really not+convertLicense Cabal.BSD4 = "BSD" -- distinguish between these?+convertLicense Cabal.PublicDomain = "public-domain"+convertLicense Cabal.AllRightsReserved = ""+convertLicense _ = ""++licenseComment :: Cabal.License -> String+licenseComment Cabal.AllRightsReserved =+ "Note: packages without a license cannot be included in portage"+licenseComment Cabal.OtherLicense =+ "Fixme: \"OtherLicense\", please fill in manually"+licenseComment _ = ""++convertDependencies :: [Cabal.Dependency] -> [Dependency]+convertDependencies = concatMap convertDependency++convertDependency :: Cabal.Dependency -> [Dependency]+convertDependency (Cabal.Dependency pname _)+ | pname `elem` coreLibs = [] -- no explicit dep on core libs+convertDependency (Cabal.Dependency pname versionRange)+ = case versionRange of+ (Cabal.IntersectVersionRanges v1 v2) -> [convert v1, convert v2]+ v -> [convert v]++ where+ ebuildName = "dev-haskell/" ++ map toLower pname++ convert :: Cabal.VersionRange -> Dependency+ convert Cabal.AnyVersion = AnyVersionOf ebuildName+ convert (Cabal.ThisVersion v) = ThisVersionOf (cabalVtoHPv v) ebuildName+ convert (Cabal.LaterVersion v) = LaterVersionOf (cabalVtoHPv v) ebuildName+ convert (Cabal.EarlierVersion v) = EarlierVersionOf (cabalVtoHPv v) ebuildName+ convert (Cabal.UnionVersionRanges (Cabal.ThisVersion v1) (Cabal.LaterVersion v2))+ | v1 == v2 = OrLaterVersionOf (cabalVtoHPv v1) ebuildName+ convert (Cabal.UnionVersionRanges (Cabal.ThisVersion v1) (Cabal.EarlierVersion v2))+ | v1 == v2 = OrEarlierVersionOf (cabalVtoHPv v1) ebuildName+ convert (Cabal.UnionVersionRanges r1 r2)+ = DependEither (convert r1) (convert r2)++-- converts Cabal versiion type to hackopr version+cabalVtoHPv :: Cabal.Version -> Version+cabalVtoHPv = Version . Cabal.versionBranch++instance Show Version where+ show (Version v) = intercalate "." $ map show v++coreLibs :: [String]+coreLibs =+ ["array"+ ,"base"+--,"bytestring" --already has ebuild+ ,"containers"+ ,"directory"+--,"filepath" --already has ebuild+ ,"ghc"+ ,"haskell98"+ ,"hpc" --has ebuild, but only in the overlay+ ,"old-locale"+ ,"old-time"+ ,"packedstring"+ ,"pretty"+ ,"process"+ ,"random"+ ,"readline" --has ebuild, but only in the overlay+ ,"rts"+ ,"template-haskell"+ ,"unix" --has ebuild, but only in the overlay+ ]++showEBuild :: EBuild -> String+showEBuild ebuild =+ ss "# Copyright 1999-2008 Gentoo Foundation". nl.+ ss "# Distributed under the terms of the GNU General Public License v2". nl.+ ss "# $Header: $". nl.+ nl.+ ss "CABAL_FEATURES=". quote' (sepBy " " $ features ebuild). nl.+ ss "inherit haskell-cabal". nl.+ nl.+ (case my_pn ebuild of+ Nothing -> id+ Just pn -> ss "MY_PN=". quote pn. nl.+ ss "MY_P=". quote "${MY_PN}-${PV}". nl. nl).+ ss "DESCRIPTION=". quote (description ebuild). nl.+ ss "HOMEPAGE=". quote (homepage ebuild). nl.+ ss "SRC_URI=". quote (replaceVars (src_uri ebuild)).+ (if null (src_uri ebuild) then ss "\t#Fixme: please fill in manually"+ else id). nl.+ nl.+ ss "LICENSE=". quote (license ebuild).+ (if null (licenseComments ebuild) then id+ else ss "\t#". ss (licenseComments ebuild)). nl.+ ss "SLOT=". quote (slot ebuild). nl.+ ss "KEYWORDS=". quote' (sepBy " " $ keywords ebuild).nl.+ ss "IUSE=". quote' (sepBy ", " $ iuse ebuild). nl.+ nl.+ ss "DEPEND=". quote' (sepBy "\n\t\t" $ map showDepend $ depend ebuild). nl.+ (case my_pn ebuild of+ Nothing -> id+ Just _ -> nl. ss "S=". quote ("${WORKDIR}/${MY_P}"). nl)+ $ []+ where replaceVars = replaceCommonVars (name ebuild) (my_pn ebuild) (version ebuild)++showDepend :: Dependency -> Package+showDepend (AnyVersionOf p) = p+showDepend (ThisVersionOf v p) = "~" ++ p ++ "-" ++ show v+showDepend (LaterVersionOf v p) = ">" ++ p ++ "-" ++ show v+showDepend (EarlierVersionOf v p) = "<" ++ p ++ "-" ++ show v+showDepend (OrLaterVersionOf v p) = ">=" ++ p ++ "-" ++ show v+showDepend (OrEarlierVersionOf v p) = "<=" ++ p ++ "-" ++ show v+showDepend (DependEither dep1 dep2) = showDepend dep1+ ++ " || " ++ showDepend dep2+showDepend (DependIfUse useflag dep@(DependEither _ _)) + = useflag ++ "? " ++ showDepend dep+showDepend (DependIfUse useflag dep) = useflag ++ "? ( " ++ showDepend dep++ " )"+showDepend (ThisMajorOf v p) = "=" ++ p ++ "-" ++ show v ++ "*"++ss :: String -> String -> String+ss = showString++sc :: Char -> String -> String+sc = showChar++nl :: String -> String+nl = sc '\n'++quote :: String -> String -> String+quote str = sc '"'. ss str. sc '"'++quote' :: (String -> String) -> String -> String+quote' str = sc '"'. str. sc '"'++sepBy :: String -> [String] -> ShowS+sepBy _ [] = id+sepBy _ [x] = ss x+sepBy s (x:xs) = ss x. ss s. sepBy s xs++getRestIfPrefix ::+ String -> -- ^ the prefix+ String -> -- ^ the string+ Maybe String+getRestIfPrefix (p:ps) (x:xs) = if p==x then getRestIfPrefix ps xs else Nothing+getRestIfPrefix [] rest = Just rest+getRestIfPrefix _ [] = Nothing++subStr ::+ String -> -- ^ the search string+ String -> -- ^ the string to be searched+ Maybe (String,String) -- ^ Just (pre,post) if string is found+subStr sstr str = case getRestIfPrefix sstr str of+ Nothing -> if null str then Nothing else case subStr sstr (tail str) of+ Nothing -> Nothing+ Just (pre,post) -> Just (head str:pre,post)+ Just rest -> Just ([],rest)++replaceMultiVars ::+ [(String,String)] -> -- ^ pairs of variable name and content+ String -> -- ^ string to be searched+ String -- ^ the result+replaceMultiVars [] str = str+replaceMultiVars whole@((pname,cont):rest) str = case subStr cont str of+ Nothing -> replaceMultiVars rest str+ Just (pre,post) -> (replaceMultiVars rest pre)++pname++(replaceMultiVars whole post)++replaceCommonVars ::+ String -> -- ^ PN+ Maybe String -> -- ^ MYPN+ String -> -- ^ PV+ String -> -- ^ the string to be replaced+ String+replaceCommonVars pn mypn pv str+ = replaceMultiVars+ ([("${P}",pn++"-"++pv)]+ ++ maybe [] (\x->[("${MY_P}",x++"-"++pv)]) mypn+ ++[("${PN}",pn)]+ ++ maybe [] (\x->[("${MY_PN}",x)]) mypn+ ++[("${PV}",pv)]) str+++{- Here goes code for dependencies simplification -}++simplify_group_table :: Package ->+ Maybe Version ->+ Maybe Version ->+ Maybe Version ->+ Maybe Version ->+ Maybe Version -> [Dependency]++-- simplify_group_table p ol l e oe exact +-- 1) trivial cases:+simplify_group_table p Nothing Nothing Nothing Nothing Nothing = error $ p ++ ": unsolvable constraints"+simplify_group_table p (Just v) Nothing Nothing Nothing Nothing = [OrLaterVersionOf v p]+simplify_group_table p Nothing (Just v) Nothing Nothing Nothing = [LaterVersionOf v p]+simplify_group_table p Nothing Nothing (Just v) Nothing Nothing = [EarlierVersionOf v p]+simplify_group_table p Nothing Nothing Nothing (Just v) Nothing = [OrEarlierVersionOf v p]+simplify_group_table p Nothing Nothing Nothing Nothing (Just v) = [ThisVersionOf v p]++-- 2) simplification passes+simplify_group_table p (Just (Version v1)) Nothing (Just (Version v2)) Nothing Nothing+ -- specian case: >=a-v.N a<v.(N+1) => =a-v.N*+ | (init v1 == init v2) && (last v2 == last v1 + 1) = [ThisMajorOf (Version v1) p]+ | otherwise = [OrLaterVersionOf (Version v1) p, EarlierVersionOf (Version v2) p]++-- TODO: simplify constraints of type: >=a-v1; > a-v2 and such++-- o3) therwise sink:+simplify_group_table p (Just v) l@(_) e@(_) oe@(_) exact@(_) = OrLaterVersionOf v p : simplify_group_table p Nothing l e oe exact+simplify_group_table p ol@(Nothing) (Just v) e@(_) oe@(_) exact@(_) = LaterVersionOf v p : simplify_group_table p ol Nothing e oe exact+simplify_group_table p ol@(Nothing) l@(Nothing) (Just v) oe@(_) exact@(_) = EarlierVersionOf v p : simplify_group_table p ol l Nothing oe exact+simplify_group_table p ol@(Nothing) l@(Nothing) e@(Nothing) (Just v) exact@(_) = OrEarlierVersionOf v p : simplify_group_table p ol l e Nothing exact+-- already defined earlier+-- simplify_group_table p ol@(Nothing) l@(Nothing) e@(Nothing) oe@(Nothing) (Just v) = OrEarlierVersionOf v p : simplify_group_table p ol l e oe Nothing++-- >a-v1 >a-v2 => >a-(max v1 v2)+-- key idea: all constraints are enforcing constraints, so we can't get+-- more, than one interval.+simplify_group :: [Dependency] -> [Dependency]+simplify_group [dep@(AnyVersionOf _package)] = [dep]+simplify_group deps = simplify_group_table package+ min_or_later_v -- >=+ min_later_v -- >+ max_earlier_v -- <+ max_or_earlier_v -- <=+ exact_this_v -- ==+ where+ package = fromJust.getPackage $ head deps+ max_earlier_v = safe_minimum $ map earlier_v deps+ max_or_earlier_v = safe_minimum $ map or_earlier_v deps+ min_later_v = safe_maximum $ map later_v deps+ min_or_later_v = safe_maximum $ map or_later_v deps+ exact_this_v = case catMaybes (map this_v deps) of+ [] -> Nothing+ [v] -> Just v+ xs -> error $ "too many exact versions:" ++ show xs+ --+ earlier_v (EarlierVersionOf v _p) = Just v+ earlier_v _ = Nothing++ or_earlier_v (OrEarlierVersionOf v _p) = Just v+ or_earlier_v _ = Nothing++ later_v (LaterVersionOf v _p) = Just v+ later_v _ = Nothing++ or_later_v (OrLaterVersionOf v _p) = Just v+ or_later_v _ = Nothing++ this_v (ThisVersionOf v _p) = Just v+ this_v _ = Nothing+ --+ safe_minimum xs = case catMaybes xs of+ [] -> Nothing+ xs' -> Just $ minimum xs'+ safe_maximum xs = case catMaybes xs of+ [] -> Nothing+ xs' -> Just $ maximum xs'++-- divide packages to groups (by package name), simplify groups, merge again+simplify_deps :: [Dependency] -> [Dependency]+simplify_deps deps = (concatMap (simplify_group.nub) $+ groupBy cmpPkgName $+ sortBy (comparing getPackageString) groupable)+ ++ ungroupable+ where (ungroupable, groupable) = partition ((==Nothing).getPackage) deps+ --+ cmpPkgName p1 p2 = cmpMaybe (getPackage p1) (getPackage p2)+ cmpMaybe (Just p1) (Just p2) = p1 == p2+ cmpMaybe _ _ = False+ --+getPackage :: Dependency -> Maybe Package+getPackage (AnyVersionOf package) = Just package+getPackage (ThisVersionOf _version package) = Just package+getPackage (LaterVersionOf _version package) = Just package+getPackage (EarlierVersionOf _version package) = Just package+getPackage (OrLaterVersionOf _version package) = Just package+getPackage (OrEarlierVersionOf _version package) = Just package+getPackage (DependEither _dependency _Dependency) = Nothing+getPackage (DependIfUse _useFlag _Dependency) = Nothing+getPackage (ThisMajorOf _version package) = Just package+--+getPackageString :: Dependency -> Package+getPackageString dep = maybe "" id $ getPackage dep
+ Cache.hs view
@@ -0,0 +1,93 @@+module Cache where++import Action+import CacheFile+import Config+import Error+import Index+import P2+import Version+import Overlays++import Distribution.Text ( simpleParse )++import Control.Arrow+import Data.Char+import Data.List+import Network.URI (URI, uriPath)+import Network.HTTP (Request(..), RequestMethod(GET), simpleHTTP, rspBody)+import qualified Data.ByteString.Lazy as L+import System.Time+import System.FilePath+import Control.Monad.Error(throwError)+import Control.Monad.Writer+import Control.Monad (unless)+import System.Directory (doesFileExist,createDirectoryIfMissing)++import qualified Data.Map as Map++-- | A long time. Used in checkCacheDate+alarmingLongTime :: TimeDiff+alarmingLongTime = TimeDiff+ { tdYear = 0+ , tdMonth = 0+ , tdDay = 7+ , tdHour = 0+ , tdMin = 0+ , tdSec = 0+ , tdPicosec = 0+ }++cacheURI :: URI -> URI+cacheURI uri = uri {uriPath = uriPath uri </> indexFile}++updateCache :: HPAction ()+updateCache = do+ path <- getOverlayPath+ cfg <- getCfg+ let cache = cacheURI $ server cfg+ res <- (liftIO $ simpleHTTP (Request cache GET [] "")) `sayNormal` ("Fetching cache from "++show cache++"...",const "done.")+ case res of+ Left err -> throwError (ConnectionFailed (show cache) (show err))+ Right resp -> liftIO $ do+ createDirectoryIfMissing False (path </> hackportDir)+ Prelude.writeFile (cacheFile path) (rspBody resp)++readCache :: FilePath -> HPAction Index+readCache portdir = do+ let cachePath = cacheFile portdir+ exists <- liftIO $ doesFileExist cachePath+ unless exists $ do+ info "No cache file present, attempting to update..."+ updateCache+ str <- liftIO $ L.readFile cachePath+ return $ readIndex str++readDefaultCache :: HPAction Index+readDefaultCache = do+ overlayPath <- getOverlayPath+ readCache overlayPath++indexToPortage :: Index -> Portage -> (Portage, [String])+indexToPortage index port = second nub . runWriter $ do+ pkgs <- forM index $ \(pkg_h_name, pkg_h_ver, pkg_desc) -> do+ let pkg_name = map toLower pkg_h_name+ pkg_cat <- lookupCat pkg_name+ Just ver <- return . simpleParse $ pkg_h_ver+ return $ Ebuild (P pkg_cat pkg_name)+ (fromCabalVersion ver)+ "<hackage>"+ (Just pkg_desc)+ return $ Map.map sort $ Map.fromListWith (++) [ (ePackage e, [e]) | e <- pkgs ]+ where+ catMap = Map.fromListWith (++) [ (p, [c]) | P c p <- Map.keys port ]+ lookupCat :: String -> Writer [String] String+ lookupCat p = do+ case Map.lookup p catMap of+ Nothing -> return "hackage"+ Just [x] -> return x+ Just xs -> do+ let c | elem "dev-haskell" xs = "dev-haskell"+ | otherwise = head xs+ tell ["WARNING: Category clash for package " ++ p ++ ", defaulting to " ++ c ++ ". Other categories: " ++ unwords (delete c xs)]+ return c
+ CacheFile.hs view
@@ -0,0 +1,12 @@+module CacheFile where++import System.FilePath++indexFile :: String+indexFile = "00-index.tar.gz"++hackportDir :: String+hackportDir = ".hackport"++cacheFile :: FilePath -> FilePath+cacheFile tree = tree </> hackportDir </> indexFile
+ Config.hs view
@@ -0,0 +1,125 @@+module Config where++import Network.URI+import System.Console.GetOpt+import Text.Regex++data HackPortOptions+ = OverlayPath String+ | PortagePath String+ | Server String+ | TempDir String+ | Verbosity String+ | Help+ | RefreshCache++data OperationMode+ = List String+ | Merge String+ | DiffTree DiffMode+ | Update+ | ShowHelp+ | Status String+ | MakeEbuild String++data DiffMode+ = ShowAll+ | ShowMissing+ | ShowAdditions+ | ShowNewer+ | ShowCommon+ deriving Eq++data Config = Config+ { overlayPath ::Maybe String+ , portagePath ::Maybe String+ , server ::URI+ , tmp ::String+ , verbosity ::Verbosity+ , refreshCache ::Bool+ }++data Verbosity+ = Debug+ | Normal+ | Silent++packageRegex :: Regex+packageRegex = mkRegex "^(.*?)-([0-9].*)$"++defaultConfig :: Config+defaultConfig = Config+ { overlayPath = Nothing+ , portagePath = Nothing+ , server = URI "http:" (Just $ URIAuth "" "hackage.haskell.org" "") "/packages/archive/" "" ""+ , tmp = "/tmp"+ , verbosity = Normal+ , refreshCache = False+ }++hackageOptions :: [OptDescr HackPortOptions]+hackageOptions =+ [Option ['o'] ["overlay-path"] (ReqArg OverlayPath "PATH") "The overlay tree to merge to"+ ,Option ['p'] ["portdir"] (ReqArg PortagePath "PATH") "The portage directory to use"+ ,Option ['s'] ["server"] (ReqArg Server "URL") "The Hackage server to query"+ ,Option ['t'] ["temp-dir"] (ReqArg TempDir "PATH") "A temp directory where tarballs can be stored"+ ,Option ['v'] ["verbosity"] (ReqArg Verbosity "debug|normal|silent") "Set verbosity level (default is 'normal')"+ ,Option ['h', '?'] ["help"] (NoArg Help) "Display this help message"+ ,Option ['r'] ["refresh-cache"] (NoArg RefreshCache) "Refresh the hackport cache before running the command"+ ]++parseConfig :: [String] -> Either String ([HackPortOptions],OperationMode)+parseConfig opts = let+ (popts,args,errs) = getOpt Permute hackageOptions opts+ mode | not (null errs) = Left $ "Error while parsing flags:\n"+ ++ concat errs+ | not (null [ () | Help <- popts ]) = Right ShowHelp+ | otherwise = case args of+ "merge":[] -> Left "Need a package's name and version to merge it.\n"+ "merge":package:[] -> Right (Merge package)+ "merge":_:rest -> Left ("'merge' takes 1 argument("++show ((length rest)+1)++" given).\n")+ "list":[] -> Right (List "")+ "list":package:[] -> Right (List package)+ "list":rest -> Left ("'list' takes at most one argument ("++show (length rest)++" given).\n")+ "diff":[] -> Right (DiffTree ShowAll)+ "diff":"all":[] -> Right (DiffTree ShowAll)+ "diff":"missing":[] -> Right (DiffTree ShowMissing)+ "diff":"additions":[] -> Right (DiffTree ShowAdditions)+ "diff":"newer":[] -> Right (DiffTree ShowNewer)+ "diff":"common":[] -> Right (DiffTree ShowCommon)+ "diff":arg:[] -> Left ("Unknown argument to diff: '" ++ arg ++ "'. Use all,missing,additions,newer or common.\n")+ "diff":_:xs -> Left ("'diff' takes one argument("++show ((length xs)+1)++" given).\n")+ "update":[] -> Right Update+ "update":rest -> Left ("'update' takes zero arguments("++show (length rest)++" given).\n")+ "status":[] -> Right (Status "")+ "status":"toportage":[] -> Right (Status "toportage")+ "status":xs-> Left ("invalid argument(s) to 'status': " ++ show xs)+ "make-ebuild":[] -> Left "Need .cabal file to make ebuild."+ "make-ebuild":package:[] -> Right (MakeEbuild package)+ "make-ebuild":_:rest -> Left ("'make-ebuild' takes 1 argument("++show ((length rest)+1)++" given).\n")++ [] -> Right ShowHelp+ _ -> Left "Unknown opertation mode\n"+ in case mode of+ Left err -> Left err+ Right m -> Right (popts,m)++hackageUsage :: IO ()+hackageUsage = putStr $ flip usageInfo hackageOptions $ unlines+ [ "Usage:"+ , "\t\"hackport [OPTION] MODE [MODETARGET]\""+ , "\t\"hackport [OPTION] list [PKG]\" lists all packages or packages matching search term"+ , "\t\"hackport [OPTION] merge PKG-VERSION\" merges a package into the portage tree"+ , "\t\"hackport [OPTION] diff\" prints the difference between the portage-tree and the server's packages"+ , "\t\"hackport [OPTION] update\" updates the local cache"+ , "\t\"hackport [OPTION] status\" compares the overlay with the portage tree"+ , "\t\"hackport [OPTION] make-ebuild\" creates standalone ebuild from given .cabal file"+ , "Options:"+ ]++parseVerbosity :: String -> Maybe Verbosity+parseVerbosity "debug" = Just Debug+parseVerbosity "normal" = Just Normal+parseVerbosity "silent" = Just Silent+parseVerbosity _ = Nothing+
+ Diff.hs view
@@ -0,0 +1,70 @@+module Diff+ ( diffAction+ ) where++import qualified Data.Map as Map++import Control.Monad.Trans+import Data.Char++import Action+import Cache+import Config (DiffMode(..))+import P2+import Version+import Overlays++data DiffState a+ = OnlyLeft a+ | OnlyRight a+ | Both a a++tabs :: String -> String+tabs str = let len = length str in str++(if len < 3*8+ then replicate (3*8-len) ' '+ else "")++showDiffState :: Package -> DiffState Version -> String+showDiffState pkg st = (tabs (show pkg)) ++ " [" ++ (case st of+ Both x y -> showVersion x ++ (case compare x y of+ EQ -> "="+ GT -> ">"+ LT -> "<") ++ showVersion y+ OnlyLeft x -> showVersion x ++ ">none"+ OnlyRight y -> "none<"++showVersion y)++"]"+++diffAction :: DiffMode -> HPAction ()+diffAction dm = do+ overlayPath <- getOverlayPath+ cache <- readCache overlayPath+ overlayTree <- liftIO $ readPortageTree overlayPath+ let (hackageTree, clashes) = indexToPortage cache overlayTree+ liftIO $ mapM_ putStrLn clashes+ diff hackageTree overlayTree dm++diff :: Portage -> Portage -> DiffMode -> HPAction ()+diff pt1 pt2 mode = do+ let pkgs1 = Map.map (OnlyLeft . eVersion . maximum) pt1+ let pkgs2 = Map.map (OnlyRight . eVersion . maximum) pt2+ let union = Map.unionWith (\(OnlyLeft x) (OnlyRight y) -> Both x y) pkgs1 pkgs2+ let showFilter st = case mode of+ ShowAll -> True+ ShowMissing -> case st of+ OnlyLeft _ -> True+ Both x y -> x > y+ OnlyRight _ -> False+ ShowAdditions -> case st of+ OnlyLeft _ -> False+ Both x y -> x < y+ OnlyRight _ -> True+ ShowNewer -> case st of+ OnlyLeft _ -> False+ Both x y -> x > y+ OnlyRight _ -> False+ ShowCommon -> case st of+ OnlyLeft _ -> False+ Both x y -> x == y+ OnlyRight _ -> False+ let packages = filter (showFilter . snd) (Map.assocs union)+ mapM_ (info . uncurry showDiffState) packages
+ Error.hs view
@@ -0,0 +1,55 @@+{-# OPTIONS -fglasgow-exts #-}+module Error where++import Data.Typeable+import Control.Monad.Error (Error)++data HackPortError+ = ArgumentError String+ | ConnectionFailed String String+ | PackageNotFound String+ | InvalidTarballURL String String+ | InvalidSignatureURL String String+ | VerificationFailed String String+ | DownloadFailed String String+ | UnknownCompression String+ | UnpackingFailed String Int+ | NoCabalFound String+ | ExtractionFailed String String Int+ | CabalParseFailed String String+ | BashNotFound+ | BashError String+ | NoOverlay+ | MultipleOverlays [String]+ | UnknownVerbosityLevel String+ -- | WrongCacheVersion+ -- | InvalidCache+ | InvalidServer String+ deriving (Typeable)++instance Error HackPortError++type HackPortResult a = Either++hackPortShowError :: HackPortError -> String+hackPortShowError err = case err of+ ArgumentError str -> "Argument error: "++str+ ConnectionFailed server reason -> "Connection to hackage server '"++server++"' failed: "++reason+ PackageNotFound pkg -> "Package '"++ pkg ++"' not found on server."+ InvalidTarballURL url reason -> "Error while downloading tarball '"++url++"': "++reason+ InvalidSignatureURL url reason -> "Error while downloading signature '"++url++"': "++reason+ VerificationFailed file signature -> "Error while checking signature('"++signature++"') of '"++file++"'"+ DownloadFailed url reason -> "Error while downloading '"++url++"': "++reason+ UnknownCompression tarball -> "Couldn't guess compression type of '"++tarball++"'"+ UnpackingFailed tarball code -> "Unpacking '"++tarball++"' failed with exit code '"++show code++"'"+ NoCabalFound tarball -> "Tarball '"++tarball++"' doesn't contain a cabal file"+ ExtractionFailed tarball file code -> "Extracting '"++file++"' from '"++tarball++"' failed with '"++show code++"'"+ CabalParseFailed file reason -> "Error while parsing cabal file '"++file++"': "++reason+ BashNotFound -> "The 'bash' executable was not found. It is required to figure out your portage-overlay. If you don't want to install bash, use '-p path-to-overlay'"+ BashError str -> "Error while guessing your portage-overlay. Either set PORTDIR_OVERLAY in /etc/make.conf or use '-p path-to-overlay'.\nThe error was: \""++str++"\""+ MultipleOverlays overlays -> "You have the following overlays available: '"++unwords overlays++"'. Please choose one by using '-p path-to-overlay'"+ NoOverlay -> "You don't have PORTDIR_OVERLAY set in '/etc/make.conf'. Please set it or use '-p path-to-overlay'"+ UnknownVerbosityLevel str -> "The verbosity level '"++str++"' is invalid. Please use debug,normal or silent"+ InvalidServer srv -> "Invalid server address, could not parse: " ++ srv+ --WrongCacheVersion -> "The version of the cache is too old. Please update the cache using 'hackport update'"+ --InvalidCache -> "Could not read the cache. Please ensure that it's up to date using 'hackport update'"
+ Fetch.hs view
@@ -0,0 +1,75 @@+module Fetch(downloadTarball,downloadFileVerify) where++import Prelude hiding (catch)++import Network.HTTP (ConnError(..),Request(..),simpleHTTP+ ,Response(..),RequestMethod(..))+import Network.URI (URI,uriPath,parseURI)+import Text.Regex (Regex,mkRegex,matchRegex)+import System.GPG+import Control.Monad.Error+import System.Directory+import System.FilePath+import Data.Typeable++import Error+import Action++filenameRegex :: Regex+filenameRegex = mkRegex "^.*?/([^/]*?)"++uriToFileName :: URI -> Maybe FilePath+uriToFileName uri = maybe Nothing (\x->Just (head x)) (matchRegex filenameRegex (uriPath uri))++downloadURI :: FilePath -- ^ a directory to store the file+ -> URI -- ^ the url+ -> HPAction FilePath -- ^ the path of the downloaded file+downloadURI path uri = do+ fileName <- maybe (throwError $ InvalidTarballURL (show uri) "URL doesn't contain a filename") return (uriToFileName uri)+ httpResult <- liftIO $ simpleHTTP request+ Response {rspCode=code,rspBody=body,rspReason=reason} <- either (\x->throwError $ DownloadFailed (show uri) "Connection failed") return httpResult+ if code==(2,0,0) then (do+ let writePath=path </> fileName+ liftIO $ writeFile writePath body+ return writePath) else throwError $ DownloadFailed (show uri) ("Code "++show code++":"++reason)+ where+ request = Request+ {rqURI=uri+ ,rqMethod=GET+ ,rqHeaders=[]+ ,rqBody=""}+++downloadFileVerify ::+ FilePath -> -- ^ the directory to store the files+ String -> -- ^ the url of the tarball+ String -> -- ^ the url of the signature+ HPAction (FilePath,FilePath) -- ^ the tarballs and signatures path+downloadFileVerify path url sigurl = do+ tarballPath <- downloadTarball path url+ sigPath <- downloadSig path sigurl `catchError` (\x->liftIO (removeFile tarballPath) >> throwError x)+ verified <- liftIO $ verifyFile stdOptions tarballPath sigPath+ if verified then return (tarballPath,sigPath) else (do+ liftIO $ removeFile tarballPath+ liftIO $ removeFile sigPath+ throwError $ VerificationFailed url sigurl)++downloadTarball ::+ FilePath ->+ String ->+ HPAction FilePath+downloadTarball dir url = download dir url InvalidTarballURL++downloadSig ::+ FilePath ->+ String ->+ HPAction FilePath+downloadSig dir url = download dir url InvalidSignatureURL++download :: FilePath -- ^ the folder to store the file in+ -> String -- ^ the url+ -> (String -> String -> HackPortError) -- ^ a function to construct an error+ -> HPAction FilePath -- ^ the resulting file's path+download dir url errFunc = do+ parsedURL <- maybe (throwError $ errFunc url "Parsing failed") return (parseURI url)+ downloadURI dir parsedURL
+ GenerateEbuild.hs view
@@ -0,0 +1,60 @@+module GenerateEbuild where++import Action+import Cabal2Ebuild+import Config++import Prelude hiding (catch)+import Control.Monad.Error+import Distribution.Package+import Data.Version (showVersion)+import Network.URI+import System.Directory+import System.FilePath++mergeEbuild :: FilePath -> String -> EBuild -> IO ()+mergeEbuild target category ebuild = do+ let edir = target </> category </> name ebuild+ let epath = edir </> name ebuild ++"-"++ version ebuild <.> "ebuild"+ createDirectoryIfMissing True edir+ writeFile epath (showEBuild ebuild)++fixSrc :: PackageIdentifier -> EBuild -> HPAction EBuild+fixSrc p ebuild = do+ cfg <- getCfg+ return $ ebuild {+ src_uri = show $ (server cfg) {+ uriPath = (uriPath (server cfg))+ </> pkgName p+ </> showVersion (pkgVersion p)+ </> pkgName p ++ "-" +++ showVersion (pkgVersion p)+ <.> "tar.gz"+ }+ }++{-hackage2ebuild ::+ (PackageIdentifier,String,String) -> -- ^ the package+ HPAction EBuild+hackage2ebuild (pkg,tarball,sig) = do+ cfg <- getCfg+ tarballPath <- (if verify cfg then (do+ (tarPath,sigPath) <- downloadFileVerify (tmp cfg) tarball sig+ liftIO $ removeFile sigPath+ return tarPath) else (downloadTarball (tmp cfg) tarball))+ `sayNormal` ("Downloading tarball from '"++tarball++"' to '"++(tmp cfg)++"'... ",const "done.")+ tarType <- maybe (liftIO (removeFile tarballPath) >> throwError (UnknownCompression tarball)) return (tarballGetType tarballPath)+ `sayDebug` ("Guessing compression type of tarball... ",const "done.")+ filesInTarball <- tarballGetFiles (tarCommand cfg) tarballPath tarType+ `sayDebug` ("Getting list of files from tarball... ",const "done.")+ `catchError` (\x->liftIO (removeFile tarballPath) >> throwError x)+ (cabalDir,cabalName) <- maybe (throwError $ NoCabalFound tarball) return (findCabal filesInTarball)+ `sayDebug` ("Trying to find cabal file... ",\(dir,name)->"Found cabal file '"++name++"' in '"++dir++"'.")+ cabalFile <- tarballExtractFile tarballPath tarType (cabalDir++"/"++cabalName)+ `sayDebug` ("Extracting cabal file... ",const "done.")+ packageDescription <- case parseDescription cabalFile of+ ParseFailed err -> throwError $ CabalParseFailed cabalName (showError err)+ ParseOk descr -> return descr+ `sayDebug` ("Parsing '"++cabalName++"'... ",const "done.")+ let ebuild=cabal2ebuild (packageDescription{pkgUrl=tarball}) --we don't trust the cabal file as we just successfully downloaded the tarbal somewhere+ return ebuild {cabalPath=Just cabalDir}-}
+ Index.hs view
@@ -0,0 +1,45 @@+module Index where++import qualified Data.Set as Set+import qualified Data.Map as Map+import Data.Version (Version,parseVersion)+import Codec.Compression.GZip(decompress)+import Data.ByteString.Lazy.Char8(ByteString,unpack)+import Codec.Archive.Tar+import Distribution.PackageDescription+import Distribution.Package+import System.FilePath.Posix+import MaybeRead (readPMaybe)++type Index = [(String,String,GenericPackageDescription)]+type IndexMap = Map.Map String (Set.Set Version)++readIndex :: ByteString -> Index+readIndex str = do+ let unziped = decompress str+ untared = readTarArchive unziped+ entr <- archiveEntries untared+ case splitDirectories (tarFileName (entryHeader entr)) of+ [".",pkgname,vers,file] -> do+ let descr = case parsePackageDescription (unpack (entryData entr)) of+ ParseOk _ pkg_desc -> pkg_desc+ _ -> error $ "Couldn't read cabal file "++show file+ return (pkgname,vers,descr)+ _ -> fail "doesn't look like the proper path"++filterIndexByPV :: (String -> String -> Bool) -> Index -> Index+filterIndexByPV cond index = [ x | x@(p,v,_d) <- index, cond p v]++indexMapFromList :: [PackageIdentifier] -> IndexMap+indexMapFromList pids = Map.unionsWith Set.union $+ [ Map.singleton name (Set.singleton vers)+ | (PackageIdentifier {pkgName = name,pkgVersion = vers}) <- pids ]++indexToPackageIdentifier :: Index -> [PackageIdentifier]+indexToPackageIdentifier index = do+ (name,vers_str,_) <- index+ Just vers <- return $ readPMaybe parseVersion vers_str+ return $ PackageIdentifier {pkgName = name,pkgVersion = vers}++bestVersions :: IndexMap -> Map.Map String Version+bestVersions = Map.map Set.findMax
+ Main.hs view
@@ -0,0 +1,136 @@+module Main where++import Control.Monad.Error+import Data.Char+import Data.Maybe+import Data.List+import Data.Version+import Distribution.Package+import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC))+import Distribution.PackageDescription.Configuration+ ( finalizePackageDescription, flattenPackageDescription )+import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Text (display)+import System.IO+import Distribution.System (buildOS, buildArch)+import qualified Data.Map as Map+import Text.ParserCombinators.Parsec++import Action+import qualified Cabal2Ebuild as E+import Cache+import Config+import Diff+import Error+import GenerateEbuild+import Index+import Status+import Package+import Overlays+import P2++import qualified Distribution.PackageDescription as Cabal+import Distribution.Verbosity (normal)+import Cabal2Ebuild++list :: String -> HPAction ()+list name = do+ index <- readCache =<< getOverlayPath+ let index' | null name = index+ | otherwise = filterIndexByPV matchSubstringCaseInsensitive index+ pkgs = [ pkg ++ "-" ++ ver | (pkg,ver,_) <- index']+ if null pkgs+ then throwError (PackageNotFound name)+ else liftIO . putStr . unlines . sort $ pkgs+ where+ matchSubstringCaseInsensitive pName _pVver =+ map toLower name `isInfixOf` map toLower pName++merge :: String -> HPAction ()+merge pstr = do+ (m_category, pname, m_version) <- case parsePVC of+ Right v -> return v+ Left err -> throwError (ArgumentError ("Could not parse [category/]package[-version]: " ++ show err))+ portdir <- getOverlayPath+ overlay <- liftIO $ readPortageTree portdir+ cache <- readCache portdir+ let (indexTree,clashes) = indexToPortage cache overlay+ mapM_ (liftIO . putStrLn) clashes+ whisper $ "Searching for: "++ pstr+ let pkgs =+ Map.elems+ . Map.filterWithKey (\(P _ pname') _ -> map toLower pname' == map toLower pname)+ $ indexTree+ return ()+ pkg <- case pkgs of+ [] -> throwError (PackageNotFound pname)+ [xs] -> case m_version of+ Nothing -> return (maximum xs) -- highest version+ Just v -> do+ let ebuilds = filter (\e -> eVersion e == v) xs+ case ebuilds of+ [] -> throwError (PackageNotFound (pname ++ '-':show v))+ [e] -> return e+ _ -> fail "the impossible happened"+ _ -> fail "the impossible happened"+ category <- do+ case m_category of+ Just cat -> return cat+ Nothing -> do+ case pCategory (ePackage pkg) of+ "hackage" -> return "dev-haskell"+ c -> return c+ let Just genericDesc = ePkgDesc pkg+ Right (desc, _) = finalizePackageDescription []+ (Nothing :: Maybe (PackageIndex PackageIdentifier))+ buildOS buildArch+ (CompilerId GHC (Version [6,8,2] []))+ [] genericDesc+ ebuild <- fixSrc (packageId desc) (E.cabal2ebuild desc)+ liftIO $ do+ putStrLn $ "Merging " ++ category ++ '/': pname ++ "-" ++ display (pkgVersion (packageId desc))+ putStrLn $ "Destination: " ++ portdir+ mergeEbuild portdir category ebuild+ where+ parsePVC = parse readPVC "" pstr+ readPVC = do+ mc <- option Nothing $ try $ do+ c <- readCat+ char '/'+ return (Just c)+ (p, mv) <- readPkgAndVer+ eof+ return (mc, p, mv)++makeEbuild :: String -> HPAction ()+makeEbuild cabalFileName = liftIO $ do+ pkg <- Cabal.readPackageDescription normal cabalFileName+ let ebuild = cabal2ebuild (flattenPackageDescription pkg)+ let ebuildFileName = name ebuild ++ "-" ++ version ebuild ++ ".ebuild"+ writeFile ebuildFileName (showEBuild ebuild)++hpmain :: HPAction ()+hpmain = do+ mode <- loadConfig+ requestedUpdate <- fmap refreshCache getCfg+ when requestedUpdate $+ case mode of+ Update -> return ()+ _ -> updateCache+ case mode of+ ShowHelp -> liftIO hackageUsage+ List pkg -> list pkg+ Merge pkg -> merge pkg+ DiffTree dtmode -> diffAction dtmode+ Update -> updateCache+ Status action -> statusAction action+ MakeEbuild cabalFileName -> makeEbuild cabalFileName++main :: IO ()+main = do+ res <- performHPAction hpmain+ case res of+ Right _ -> return ()+ Left err -> do+ hPutStrLn stderr "An error occurred. To get more info run with --verbosity=debug"+ hPutStrLn stderr (hackPortShowError err)
+ MaybeRead.hs view
@@ -0,0 +1,14 @@+module MaybeRead where++import Data.List(find)+import Text.Read+import Text.ParserCombinators.ReadP++readMaybe :: Read a => String -> Maybe a+readMaybe = readsMaybe reads++readsMaybe :: ReadS a -> String -> Maybe a+readsMaybe func str = maybe Nothing (\x->Just (fst x)) (find (null.snd) (func str))++readPMaybe :: ReadP a -> String -> Maybe a+readPMaybe = readsMaybe.readP_to_S
+ Overlays.hs view
@@ -0,0 +1,59 @@+module Overlays where++import Control.Monad.Error+import System.Directory+import Data.Maybe+import Data.List (nub)++import Bash+import Action+import Config+import Error+import CacheFile++getOverlayPath :: HPAction String+getOverlayPath = do+ cfg <- getCfg+ case overlayPath cfg of+ Nothing -> do+ tree <- getOverlay `sayDebug` ("Guessing overlay...\n",\tree->"Found '"++tree++"'")+ setOverlayPath $ Just tree+ return tree+ Just tree -> return tree++getOverlay :: HPAction String+getOverlay = do+ overlays <- getOverlays+ case overlays of+ [] -> throwError NoOverlay+ [x] -> return x+ mul -> search mul+ where+ search :: [String] -> HPAction String+ search mul = do+ let loop [] = throwError $ MultipleOverlays mul+ loop (x:xs) = (do+ found <- liftIO (doesFileExist (cacheFile x))+ `sayDebug` ("Checking '"++x++"'...\n",\res->if res then "found.\n" else "not found.")+ if found+ then return x+ else loop xs)+ whisper "There are several overlays in your /etc/make.conf"+ mapM (\x-> whisper (" * " ++x)) mul+ whisper "Looking for one with a HackPort cache..."+ overlay <- loop mul+ whisper ("I choose " ++ overlay)+ whisper "Override my decision with hackport -p /my/overlay"+ return overlay++portageOverlays :: HPAction [String]+portageOverlays = runBash "source /etc/make.conf;echo -n $PORTDIR_OVERLAY" >>= (return.words)++paludisOverlays :: HPAction [String]+paludisOverlays = return []++getOverlays :: HPAction [String]+getOverlays = do+ portage <- portageOverlays+ paludis <- paludisOverlays+ return (nub (portage ++ paludis))
+ P2.hs view
@@ -0,0 +1,106 @@+module P2 where++-- Module that respect categories.+-- Possibly to replace Portage.hs when the rest of the project has been+-- ported to this style.++import BlingBling++import Control.Arrow+import Control.Monad++import qualified Distribution.PackageDescription as Cabal++import Data.Map (Map)+import qualified Data.Map as Map+import Data.Maybe+import qualified Data.List as List++import System.Directory+import System.IO+import System.FilePath++import Text.Regex++import Version++type Portage = PortageMap [Ebuild]+type PortageMap a = Map Package a++data Ebuild = Ebuild {+ ePackage :: Package,+ eVersion :: Version,+ eFilePath :: FilePath,+ ePkgDesc :: Maybe Cabal.GenericPackageDescription }+ deriving (Show)++data Package = P { pCategory :: String, pPackage :: String }+ deriving (Eq, Ord)++instance Show Package where+ show (P c p) = c ++ '/':p++instance Eq Ebuild where+ e1 == e2 = (ePackage e1, eVersion e1) == (ePackage e2, eVersion e2)++instance Ord Ebuild where+ compare e1 e2 = compare (ePackage e1, eVersion e1)+ (ePackage e2, eVersion e2)++lookupEbuildWith :: Portage -> Package -> (Ebuild -> Bool) -> Maybe Ebuild+lookupEbuildWith portage package comp = do+ es <- Map.lookup package portage+ List.find comp es++getPackageList :: FilePath -> IO [Package]+getPackageList portdir = do+ categories <- getDirectories portdir+ packages <- fmap concat $ forMbling categories $ \c -> do+ pkg <- getDirectories (portdir </> c)+ return (map (P c) pkg)+ return packages++readPortagePackages :: FilePath -> [Package] -> IO Portage+readPortagePackages portdir packages0 = do+ packages <- filterM (doesDirectoryExist . (portdir </>) . show) packages0+ ebuild_map0 <- forM packages $ \package -> do+ ebuilds <- getPackageVersions package+ return (package, List.sort ebuilds)+ let ebuild_map = filter (not . null . snd) ebuild_map0+ return $ Map.fromList ebuild_map++ where+ getPackageVersions :: Package -> IO [Ebuild]+ getPackageVersions (P category package) = do+ files <- getDirectoryContents (portdir </> category </> package)+ let ebuilds = [ (v, portdir </> category </> package </> fn)+ | (Just v, fn) <- map ((filterVersion package) &&& id) files ]+ return (map (uncurry (\v f -> Ebuild (P category package) v f Nothing)) ebuilds)++ filterVersion :: String -> String -> Maybe Version+ filterVersion p fn = do+ [vstring] <- matchRegex (ebuildVersionRegex p) fn+ case (parseVersion vstring) of+ Left e -> fail (show e)+ Right v -> return v++ ebuildVersionRegex name = mkRegex ("^"++name++"-(.*)\\.ebuild$")++readPortageTree :: FilePath -> IO Portage+readPortageTree portdir = do+ packages <- getPackageList portdir+ readPortagePackages portdir packages++getDirectories :: FilePath -> IO [String]+getDirectories fp = do+ files <- fmap (filter (`notElem` [".", ".."])) $ getDirectoryContents fp+ filterM (doesDirectoryExist . (fp </>)) files++printPortage :: Portage -> IO ()+printPortage port =+ forM_ (Map.toAscList port) $ \(package, ebuilds) -> do+ let (P c p) = package+ putStr $ c ++ '/':p+ putStr " "+ forM_ ebuilds (\e -> putStr (show $ eVersion e) >> putChar ' ')+ putStrLn ""
+ Package.hs view
@@ -0,0 +1,76 @@+{-|+ Maintainer : Andres Loeh <kosmikus@gentoo.org>+ Stability : provisional+ Portability : haskell98++ Parser for categories and packages.++ Shamelessly borrowed from exi, somewhat modified+-}++module Package+ where++import Control.Monad+import Text.ParserCombinators.Parsec++import Version++type Category = String+type Package = String+type Slot = String++getPV :: String -> (Category, Package, Version)+getPV xs = case parsePV xs of+ Left e ->+ error $ "getPV: cat/pkg-ver parse error '" ++ xs ++ "'\n" ++ show e+ Right x -> x++getP :: String -> (Category, Package)+getP xs = case parseP xs of+ Left e ->+ error $ "getCatPkg: cat/pkg parse error '" ++ xs ++ "'\n" ++ show e+ Right x -> x++parsePV :: String -> Either ParseError (Category, Package, Version)+parsePV = parse (readPV >>= \x -> eof >> return x) "<cat/pkg-ver>"++readPV :: GenParser Char st (Category, Package, Version)+readPV = do cat <- readCat+ char '/'+ (pkg,mver) <- readPkgAndVer+ case mver of+ Nothing -> fail "readPV: version expected"+ Just ver -> return (cat, pkg, ver)++parseP :: String -> Either ParseError (Category, Package)+parseP = parse (readP >>= \x -> eof >> return x) "<cat/pkg>"++readP :: GenParser Char st (Category, Package)+readP = do cat <- readCat+ char '/'+ (pkg,mver) <- readPkgAndVer+ case mver of+ Nothing -> return (cat, pkg)+ Just _ -> error "readCatPkg: unexpected version"++readCat :: CharParser st Category+readPkgAndVer :: CharParser st (Package,Maybe Version)++readCat = many1 (letter <|> digit <|> oneOf "_-")+readPkgAndVer = do pre <- many1 (letter <|> digit <|> oneOf "_+")+ (p,v) <- option ("",Nothing)+ (do char '-'+ liftM (\v -> ("",Just v)) readVerOrFail+ <|> liftM (\(p,v) -> ('-':p,v)) readPkgAndVer+ )+ return (pre ++ p,v)++readVerOrFail :: CharParser st Version+readVerOrFail = try $+ do ver <- many1 (letter <|> digit <|> oneOf "_+.-")+ case parseVersion ver of+ Left _ -> + fail $ "version parse error"+ Right x -> return x+
+ Portage.hs view
@@ -0,0 +1,20 @@+module Portage where++import System.Directory+import Text.Regex+import Data.Maybe++ebuildVersionRegex :: String -> Regex+ebuildVersionRegex name = mkRegex ("^"++name++"-(.*)\\.ebuild$")++filterPackages :: String -> [String] -> IO [String]+filterPackages _ [] = return []+filterPackages base (x:xs) = do+ ak <- case x of+ "." -> return Nothing+ ".." -> return Nothing+ dir -> do+ exists <- doesDirectoryExist (base++dir)+ return (if exists then Just dir else Nothing)+ rest <- filterPackages base xs+ return (maybe rest (:rest) ak)
+ Setup.hs view
@@ -0,0 +1,7 @@+#!/usr/bin/runhaskell+module Main where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ Status.hs view
@@ -0,0 +1,159 @@+module Status+ ( FileStatus(..)+ , fromStatus+ , status+ , statusAction+ ) where++import Action+import AnsiColor+import Bash+import P2+import Utils+import Overlays++import Control.Monad.State++import qualified Data.List as List++import qualified Data.ByteString.Lazy.Char8 as L++import Data.Char+import qualified Data.Map as Map+import Data.Map as Map (Map)++import qualified Data.Traversable as T++data FileStatus a+ = Same a+ | Differs a a+ | OverlayOnly a+ | PortageOnly a+ deriving (Show,Eq)++instance Ord a => Ord (FileStatus a) where+ compare x y = compare (fromStatus x) (fromStatus y)++instance Functor FileStatus where+ fmap f st =+ case st of+ Same a -> Same (f a)+ Differs a b -> Differs (f a) (f b)+ OverlayOnly a -> OverlayOnly (f a)+ PortageOnly a -> PortageOnly (f a)++fromStatus :: FileStatus a -> a+fromStatus fs =+ case fs of+ Same a -> a+ Differs a _ -> a -- second status is lost+ OverlayOnly a -> a+ PortageOnly a -> a++status :: HPAction (Map Package [FileStatus Ebuild])+status = do+ portdir <- getPortdir+ overlayPath <- getOverlayPath+ overlay <- liftIO $ readPortageTree overlayPath+ portage <- liftIO $ readPortagePackages portdir (Map.keys overlay)+ let (over, both, port) = portageDiff overlay portage++ both' <- T.forM both $ mapM $ \e -> liftIO $ do+ -- can't fail, we know the ebuild exists in both portagedirs+ -- also, one of them is already bound to 'e'+ let (Just e1) = lookupEbuildWith portage (ePackage e) (comparing eVersion e)+ (Just e2) = lookupEbuildWith overlay (ePackage e) (comparing eVersion e)+ eq <- equals (eFilePath e1) (eFilePath e2)+ return $ if eq+ then Same e+ else Differs e1 e2++ let meld = Map.unionsWith (\a b -> List.sort (a++b))+ [ Map.map (map PortageOnly) port+ , both'+ , Map.map (map OverlayOnly) over+ ]+ return meld++statusAction :: String -> HPAction ()+statusAction action = do+ let pkgFilter =+ case action of+ "" -> id+ "toportage" -> toPortageFilter+ pkgs <- status+ statusPrinter (pkgFilter pkgs)++-- |Only return packages that seems interesting to sync to portage;+--+-- * Ebuild differs, or+-- * Newer version in overlay than in portage+toPortageFilter :: Map Package [FileStatus Ebuild] -> Map Package [FileStatus Ebuild]+toPortageFilter = Map.mapMaybe $ \ sts ->+ let inPortage = flip filter sts $ \st ->+ case st of+ OverlayOnly _ -> False+ _ -> True+ latestPortageVersion = List.maximum $ map (eVersion . fromStatus) inPortage+ interestingPackages = flip filter sts $ \st ->+ case st of+ Differs _ _ -> True+ _ | eVersion (fromStatus st) > latestPortageVersion -> True+ | otherwise -> False+ in if not (null inPortage) && not (null interestingPackages)+ then Just sts+ else Nothing++statusPrinter :: Map Package [FileStatus Ebuild] -> HPAction ()+statusPrinter packages = do+ liftIO $ putStrLn $ toColor (Same "Green") ++ ": package in portage and overlay are the same"+ liftIO $ putStrLn $ toColor (Differs "Yellow" "") ++ ": package in portage and overlay differs"+ liftIO $ putStrLn $ toColor (OverlayOnly "Red") ++ ": package only exist in the overlay"+ liftIO $ putStrLn $ toColor (PortageOnly "Magenta") ++ ": package only exist in the portage tree"+ forM_ (Map.toAscList packages) $ \(pkg, ebuilds) -> liftIO $ do+ let (P c p) = pkg+ putStr $ c ++ '/' : bold p+ putStr " "+ forM_ ebuilds $ \e -> do+ putStr $ toColor (fmap (show . eVersion) e)+ putChar ' '+ putStrLn ""++toColor :: FileStatus String -> String+toColor st = inColor c False Default (fromStatus st)+ where+ c = case st of+ (Same _) -> Green+ (Differs _ _) -> Yellow+ (OverlayOnly _) -> Red+ (PortageOnly _) -> Magenta++portageDiff :: Portage -> Portage -> (Portage, Portage, Portage)+portageDiff p1 p2 = (in1, ins, in2)+ where ins = Map.filter (not . null) $+ Map.intersectionWith (List.intersectBy $ comparing eVersion) p1 p2+ in1 = difference p1 p2+ in2 = difference p2 p1+ difference x y = Map.filter (not . null) $+ Map.differenceWith (\xs ys ->+ let lst = foldr (List.deleteBy (comparing eVersion)) xs ys in+ if null lst+ then Nothing+ else Just lst+ ) x y++-- | Compares two ebuilds, returns True if they are equal.+-- Disregards comments.+equals :: FilePath -> FilePath -> IO Bool+equals fp1 fp2 = do+ f1 <- L.readFile fp1+ f2 <- L.readFile fp2+ return (equal' f1 f2)++equal' :: L.ByteString -> L.ByteString -> Bool+equal' = comparing essence+ where+ essence = filter (not . isEmpty) . filter (not . isComment) . L.lines+ isComment = L.isPrefixOf (L.pack "#") . L.dropWhile isSpace+ isEmpty = L.null . L.dropWhile isSpace+
+ Utils.hs view
@@ -0,0 +1,7 @@+module Utils where++comparing :: (Eq b) => (a -> b) -> a -> a -> Bool+comparing f x y = f x == f y++compareWith :: (Ord b) => (a -> b) -> a -> a -> Ordering+compareWith f x y = compare (f x) (f y)
+ Version.hs view
@@ -0,0 +1,122 @@+{-|+ Maintainer : Andres Loeh <kosmikus@gentoo.org>+ Stability : provisional+ Portability : haskell98++ Version parser, according to Portage spec.++ Shamelessly borrowed from exi, somewhat modified++-}++module Version+ (+ Version(),+ Suffix(..),+ fromCabalVersion,+ showVersion,+ showSuffix,+ readVersion,+ parseVersion,+ getVersion,+ showRevPR+ ) where++import qualified Distribution.Version as Cabal+import Control.Monad+import Data.List+import Data.Maybe+import Text.ParserCombinators.Parsec++data Version = Version [Int] -- [1,42,3] ~= 1.42.3+ (Maybe Char) -- optional letter+ [Suffix]+ Int -- revision, 0 means none+ deriving (Eq, Ord)++data Suffix = Alpha Int | Beta Int | Pre Int | RC Int | P_ Int+ deriving (Eq,Ord)++instance Show Version where+ show = showVersion++instance Show Suffix where+ show = showSuffix++showVersion :: Version -> String+showVersion (Version ver c suf rev)+ = showver ++ showc ++ concatMap showSuffix suf ++ showRev rev+ where showver = concat . intersperse "." . map show $ ver+ showc = maybe "" (:[]) c++showSuffix :: Suffix -> String+showSuffix (Alpha n) = "_alpha" ++ showPos n+showSuffix (Beta n) = "_beta" ++ showPos n+showSuffix (Pre n) = "_pre" ++ showPos n+showSuffix (RC n) = "_rc" ++ showPos n+showSuffix (P_ n) = "_p" ++ showPos n++showPos :: Int -> String+showPos 0 = ""+showPos n = show n++showRev :: Int -> String+showRev 0 = ""+showRev n = "-r" ++ show n++showRevPR :: Int -> String+showRevPR n = "r" ++ show n++fromCabalVersion :: Cabal.Version -> Version+fromCabalVersion (Cabal.Version nums _tags) =+ Version nums Nothing [] 0++-- | Function to call if you want to parse a version number.+getVersion :: String -> Version+getVersion ver = case parseVersion ver of+ Left _ ->+ error $ "getVersion: version parse error '" ++ ver ++ "'"+ Right x -> x++parseVersion :: String -> Either ParseError Version+parseVersion = parse (readVersion >>= \x -> eof >> return x) "<version number>"++readVersion :: CharParser st Version+readVersion = do (ver, _verr) <- readVer+ (c, _cr ) <- readC+ (suf, _sufr) <- readSufs+ (rev, _revr) <- readRev+ return (Version ver c suf rev)++readVer :: CharParser st ([Int], String)+readNum :: CharParser st (Int, String)+readC :: CharParser st (Maybe Char, String)+readSuf :: CharParser st (Suffix, String)+readSufType :: CharParser st (Int -> Suffix, String)+readSufs :: CharParser st ([Suffix], String)+readRev :: CharParser st (Int, String)++readVer = liftM ((\(x,y) -> (x, concat . intersperse "." $ y)) . unzip) (sepBy1 readNum (char '.'))+readNum = do ds <- many1 digit+ case read ds of+ n -> return (n,ds)+readC = option (Nothing, "") (liftM (\x -> (Just x, [x])) letter)+readSuf = do char '_'+ (f,sr) <- readSufType+ (n,nr) <- option (0, "") readNum+ return (f n,"_" ++ sr ++ nr)++readSufType = choice [+ liftM (\x -> (Alpha, x)) (try $ string "alpha"),+ liftM (\x -> (Beta, x)) (try $ string "beta" ),+ liftM (\x -> (Pre, x)) (try $ string "pre" ),+ liftM (\x -> (RC, x)) (try $ string "rc" ),+ liftM (\x -> (P_, x)) (try $ string "p" )+ ]++readSufs = fmap ( ( \ (x,y) -> (x, concat y) ) . unzip ) (many readSuf)++readRev = option (0, "") ( do rr <- string "-r"+ (n,nr) <- readNum+ return (n,rr ++ nr)+ )
+ hackport.cabal view
@@ -0,0 +1,64 @@+Name: hackport+Version: 0.2.1+License: GPL+Author: Henning Günther, Duncan Coutts, Lennart Kolmodin+Maintainer: Gentoo Haskell team <haskell@gentoo.org>+Category: Distribution+Synopsis: Hackage and Portage integration tool+Description: A command line tool to manage an overlay of Gentoo ebuilds+ that are generated from a hackage repo of Cabal packages.+Build-Type: Simple+Cabal-Version: >=1.2++Flag split-base++Executable hackport+ Main-Is: Main.hs+ Build-Depends:+ base >= 2.0,+ filepath,+ parsec,+ mtl,+ network,+ regex-compat,+ Cabal >= 1.4 && < 1.5,+ HTTP >= 3000 && < 3002,+ zlib,+ tar++ if flag(split-base)+ Build-Depends:+ base >= 3,+ directory,+ containers,+ process,+ old-time,+ bytestring+ else+ Build-Depends: base < 3++ ghc-options: -Wall+ other-modules:+ Action+ AnsiColor+ Bash+ BlingBling+ Cabal2Ebuild+ Cache+ CacheFile+ Config+ Diff+ Error+ Fetch+ GenerateEbuild+ Index+ Main+ MaybeRead+ Overlays+ P2+ Package+ Portage+ Setup+ Status+ Utils+ Version