cabal2nix-1.8: src/Hackage4Nix.hs
{-# LANGUAGE OverloadedStrings, PatternGuards #-}
module Main ( main ) where
import System.IO
import System.FilePath
import System.Directory
import System.Environment
import System.Exit
import Data.List
import qualified Data.Set as Set
import Control.Monad.State
import Control.Exception ( bracket )
import qualified Data.ByteString.Char8 as BS
import Text.Regex.Posix
import Data.Version
import Text.ParserCombinators.ReadP ( readP_to_S )
import Distribution.PackageDescription.Parse ( parsePackageDescription, ParseResult(..) )
import Distribution.PackageDescription ( GenericPackageDescription() )
import System.Console.GetOpt ( OptDescr(..), ArgDescr(..), ArgOrder(..), usageInfo, getOpt )
import Cabal2Nix.Package ( cabal2nix, showNixPkg, PkgName, PkgSHA256, PkgPlatforms, PkgMaintainers )
type ByteString = BS.ByteString
pack :: String -> ByteString
pack = BS.pack
unpack :: ByteString -> String
unpack = BS.unpack
type PkgSet = Set.Set Pkg
data Configuration = Configuration
{ _msgDebug :: String -> IO ()
, _msgInfo :: String -> IO ()
, _hackageDb :: FilePath
, _pkgset :: PkgSet
}
defaultConfiguration :: Configuration
defaultConfiguration = Configuration
{ _msgDebug = hPutStrLn stderr
, _msgInfo = hPutStrLn stderr
, _hackageDb = "/dev/shm/hackage"
, _pkgset = Set.empty
}
type Hackage4Nix a = StateT Configuration IO a
io :: (MonadIO m) => IO a -> m a
io = liftIO
readDirectory :: FilePath -> IO [FilePath]
readDirectory dirpath = do
entries <- getDirectoryContents dirpath
return [ x | x <- entries, x /= ".", x /= ".." ]
msgDebug, msgInfo :: String -> Hackage4Nix ()
msgDebug msg = get >>= \s -> io (_msgDebug s msg)
msgInfo msg = get >>= \s -> io (_msgInfo s msg)
readCabalFile :: String -> String -> Hackage4Nix GenericPackageDescription
readCabalFile name vers = do
hackageDir <- gets _hackageDb
let cabal = hackageDir </> name </> vers </> name <.> "cabal"
pkg' <- fmap parsePackageDescription (io (readFile cabal))
pkg <- case pkg' of
ParseOk _ a -> return a
ParseFailed err -> fail ("cannot parse cabal file " ++ cabal ++ ": " ++ show err)
return pkg
discoverNixFiles :: (FilePath -> Hackage4Nix ()) -> FilePath -> Hackage4Nix ()
discoverNixFiles yield dirOrFile
| "." `isPrefixOf` takeFileName dirOrFile = msgDebug $ "ignore file or directory " ++ dirOrFile
| otherwise = do
isFile <- io (doesFileExist dirOrFile)
case (isFile, takeExtension dirOrFile) of
(True,".nix") -> do
msgDebug ("discovered file " ++ dirOrFile)
yield dirOrFile
(True,_) -> msgDebug $ "ignore file " ++ dirOrFile
(False,_) -> do
msgDebug ("discovered dir " ++ dirOrFile)
io (readDirectory dirOrFile) >>= mapM_ (discoverNixFiles yield . (dirOrFile </>))
type PkgVersion = String
data Pkg = Pkg PkgName PkgVersion PkgSHA256 PkgPlatforms PkgMaintainers FilePath
deriving (Show, Eq, Ord)
regmatch :: ByteString -> String -> Bool
regmatch buf patt = match (makeRegexOpts compExtended execBlank (pack patt)) buf
regsubmatch :: ByteString -> String -> [ByteString]
regsubmatch buf patt = let (_,_,_,x) = f in x
where f :: (ByteString,ByteString,ByteString,[ByteString])
f = match (makeRegexOpts compExtended execBlank (pack patt)) buf
normalizeMaintainer :: String -> String
normalizeMaintainer x
| "self.stdenv.lib.maintainers." `isPrefixOf` x = drop 28 x
| otherwise = x
parseNixFile :: FilePath -> ByteString -> Hackage4Nix (Maybe Pkg)
parseNixFile path buf
| True <- (pack path) `regmatch` (concat (intersperse "|" badPackages))
= msgDebug ("ignore known bad package " ++ path) >> return Nothing
| True <- buf `regmatch` "src = (fetchgit|sourceFromHead)"
= msgDebug ("ignore non-hackage package " ++ path) >> return Nothing
| True <- buf `regmatch` "noHaddock"
= msgDebug ("ignore non-haddock package " ++ path) >> return Nothing
| True <- buf =~ pack "cabal.mkDerivation"
, [name] <- buf `regsubmatch` "name *= *\"([^\"]+)\""
, [vers] <- buf `regsubmatch` "version *= *\"([^\"]+)\""
, [sha] <- buf `regsubmatch` "sha256 *= *\"([^\"]+)\""
, plats <- buf `regsubmatch` "platforms *= *([^;]+);"
, maint <- buf `regsubmatch` "maintainers *= *\\[([^\"]+)]"
= let plats' = concatMap BS.words (map (BS.map (\c -> if c == '+' then ' ' else c)) plats)
maint' = concatMap BS.words maint
in
return $ Just $ Pkg (unpack name)
(unpack vers)
(unpack sha)
(map unpack plats')
(map (normalizeMaintainer . unpack) maint')
(path)
| True <- buf `regmatch` "cabal.mkDerivation"
= msgInfo ("failed to parse file " ++ path) >> return Nothing
| otherwise = return Nothing
readVersion :: String -> Version
readVersion str =
case [ v | (v,[]) <- readP_to_S parseVersion str ] of
[ v' ] -> v'
_ -> error ("invalid version specifier " ++ show str)
selectLatestVersions :: PkgSet -> PkgSet
selectLatestVersions = Set.fromList . nubBy f2 . sortBy f1 . Set.toList
where
f1 (Pkg n1 v1 _ _ _ _) (Pkg n2 v2 _ _ _ _)
| n1 == n2 = compare v2 v1
| otherwise = compare n1 n2
f2 (Pkg n1 _ _ _ _ _) (Pkg n2 _ _ _ _ _)
= n1 == n2
discoverUpdates :: PkgName -> PkgVersion -> Hackage4Nix [PkgVersion]
discoverUpdates name vers = do
hackage <- gets _hackageDb
versionStrings <- io $ readDirectory (hackage </> name)
let versions = map readVersion versionStrings
return [ showVersion v | v <- versions, v > readVersion vers ]
updateNixPkgs :: [FilePath] -> Hackage4Nix ()
updateNixPkgs paths = do
msgDebug $ "updating = " ++ show paths
flip mapM_ paths $ \fileOrDir ->
flip discoverNixFiles fileOrDir $ \file -> do
nix' <- io (BS.readFile file) >>= parseNixFile file
flip (maybe (return ())) nix' $ \nix -> do
let Pkg name vers sha plats maints path = nix
maints' = nub (sort (maints ++ ["andres","simons"]))
plats'
| null plats && not (null maints) = ["self.ghc.meta.platforms"]
| otherwise = plats
msgDebug ("re-generate " ++ path)
when (null maints) (msgInfo ("warning: no maintainers configured for " ++ path))
pkg <- readCabalFile name vers
io $ writeFile path (showNixPkg (cabal2nix pkg sha plats' maints'))
modify $ \cfg -> cfg { _pkgset = Set.insert nix (_pkgset cfg) }
pkgset <- gets (selectLatestVersions . _pkgset)
updates' <- flip mapM (Set.elems pkgset) $ \pkg -> do
let Pkg name vers _ _ _ _ = pkg
updates <- discoverUpdates name vers
return (pkg,updates)
let updates = [ u | u@(_,(_:_)) <- updates' ]
when (not (null updates)) $ do
msgInfo "The following updates are available:"
flip mapM_ updates $ \(pkg,versions) -> do
let Pkg name vers _ plats maints path = pkg
msgInfo ""
msgInfo $ name ++ "-" ++ vers ++ ":"
flip mapM_ versions $ \newVersion -> do
msgInfo $ " " ++ genCabal2NixCmdline (Pkg name newVersion undefined plats maints path)
return ()
genCabal2NixCmdline :: Pkg -> String
genCabal2NixCmdline (Pkg name vers _ plats maints path) = unwords $ ["cabal2nix"] ++ opts ++ [">"++path']
where
opts = [cabal] ++ maints' ++ plats'
cabal = "cabal://" ++ name ++ "-" ++ vers
maints' = [ "--maintainer=" ++ m | m <- maints ]
plats'
| ["self.ghc.meta.platforms"] == plats = []
| otherwise = [ "--platform=" ++ p | p <- plats ]
path'
| pack path `regmatch` "/[0-9\\.]+\\.nix$" = replaceFileName path (vers <.> "nix")
| otherwise = path
data CliOption = PrintHelp | Verbose | HackageDB FilePath
deriving (Eq)
main :: IO ()
main = bracket (return ()) (\() -> hFlush stdout >> hFlush stderr) $ \() -> do
let options :: [OptDescr CliOption]
options =
[ Option ['h'] ["help"] (NoArg PrintHelp) "show this help text"
, Option ['v'] ["verbose"] (NoArg Verbose) "enable noisy debug output"
, Option [] ["hackage"] (ReqArg HackageDB "HACKAGE-DIR") "path to hackage database"
]
usage :: String
usage = usageInfo "Usage: hackage4nix [options] [dir-or-file ...]" options ++
"\n\
\The purpose of 'hackage4nix' is to keep all Haskell packages in our\n\
\repository packages up-to-date. It scans a checked-out copy of\n\
\Nixpkgs for expressions that use 'cabal.mkDerivation', and\n\
\re-generates them in-place with cabal2nix.\n\
\\n\
\Because we don't want to generate a barrage of HTTP requests during\n\
\that procedure, the tool expects a copy of the Hackage database\n\
\available at some local path, i.e. \"/dev/shm/hackage\" by default.\n\
\That directory can be set up as follows:\n\
\\n\
\ cabal update\n\
\ mkdir -p /dev/shm/hackage\n\
\ tar xf ~/.cabal/packages/hackage.haskell.org/00-index.tar -C /dev/shm/hackage\n"
cmdlineError :: String -> IO a
cmdlineError "" = hPutStrLn stderr usage >> exitFailure
cmdlineError errMsg = hPutStrLn stderr errMsg >> cmdlineError ""
args' <- getArgs
(opts,args) <- case getOpt Permute options args' of
(o,n,[] ) -> return (o,n)
(_,_,errs) -> cmdlineError (concatMap (\e -> '*':'*':'*':' ':e) errs)
when (PrintHelp `elem` opts) (cmdlineError "")
let cfg = defaultConfiguration
{ _msgDebug = if Verbose `elem` opts then _msgDebug defaultConfiguration else const (return ())
, _hackageDb = last $ _hackageDb defaultConfiguration : [ p | HackageDB p <- opts ]
}
flip evalStateT cfg (updateNixPkgs args)
-- Packages that we cannot regenerate automatically yet. This list
-- should be empty.
badPackages :: [String]
badPackages = [ "/"++p++"/" | p <- names ]
where names =
[ "alex"
, "cairo"
, "citeproc"
, "citeproc-hs"
, "editline"
, "flapjax"
, "ghc-events"
, "glade"
, "glib"
, "glut"
, "GLUT"
, "gtk"
, "gtksourceview2"
, "haddock"
, "haskell-platform"
, "haskell-src"
, "hfuse"
, "hmatrix"
, "hp2any-graph"
, "idris"
, "LambdaHack"
, "lhs2tex"
, "MazesOfMonad"
, "OpenAL"
, "OpenGL"
, "pango"
, "readline"
, "repa-examples"
, "scion"
, "SDL"
, "SDL-image"
, "SDL-mixer"
, "SDL-ttf"
, "svgcairo"
, "tar"
, "terminfo"
, "threadscope"
, "vacuum"
, "wxHaskell"
, "X11"
, "X11-xft"
, "xmobar"
]