diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for cabal2nixe + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2018, Moritz Angermann + +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 Moritz Angermann 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/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/cabal2nix/Main.hs b/cabal2nix/Main.hs new file mode 100644 --- /dev/null +++ b/cabal2nix/Main.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE LambdaCase, RecordWildCards #-} + +module Main where + +import System.Environment (getArgs) + +import System.Directory +import System.FilePath +import Control.Monad + +import Nix.Pretty (prettyNix) +import Nix.Expr + +import Data.String (fromString) + +import Cabal2Nix +import Cabal2Nix.Util + +import Data.Text.Prettyprint.Doc (Doc) +import Data.Text.Prettyprint.Doc.Render.Text (hPutDoc) +import System.IO +import Distribution.Nixpkgs.Fetch +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe +import Data.ByteString (ByteString) + +import Data.List (isPrefixOf, isSuffixOf) + +import qualified Hpack +import qualified Hpack.Config as Hpack +import qualified Hpack.Render as Hpack +import qualified Data.Text as T +import qualified Data.Text.Encoding as T + + +writeDoc :: FilePath -> Doc ann -> IO () +writeDoc file doc = + do handle <- openFile file WriteMode + hPutDoc handle doc + hClose handle + +main :: IO () +main = getArgs >>= \case + [url,hash] | "http" `isPrefixOf` url -> + let subdir = "." in + fetch (\dir -> cabalFromPath url hash subdir $ dir subdir) + (Source url mempty UnknownHash subdir) >>= \case + (Just (DerivationSource{..}, genBindings)) -> genBindings derivHash + _ -> return () + [path,file] -> doesDirectoryExist file >>= \case + False -> print . prettyNix =<< cabal2nix False MinimalDetails (Just (Path path)) (OnDisk file) + True -> print . prettyNix =<< cabalexprs file + [file] -> doesDirectoryExist file >>= \case + False -> print . prettyNix =<< cabal2nix False MinimalDetails (Just (Path ".")) (OnDisk file) + True -> print . prettyNix =<< cabalexprs file + _ -> putStrLn "call with cabalfile (Cabal2Nix file.cabal)." + +cabalFromPath + :: String -- URL + -> String -- Revision + -> FilePath -- Subdir + -> FilePath -- Local Directory + -> MaybeT IO (String -> IO ()) +cabalFromPath url rev subdir path = do + d <- liftIO $ doesDirectoryExist path + unless d $ fail ("not a directory: " ++ path) + cabalFiles <- liftIO $ findCabalFiles path + when (length cabalFiles > 1) $ fail ("multiple cabal files detected: " ++ show cabalFiles) + return $ \sha256 -> + void . forM cabalFiles $ \cabalFile -> do + let pkg = cabalFilePkgName cabalFile + subdir' = if subdir == "." then Nothing + else Just subdir + src = Just $ Git url rev (Just sha256) subdir' + print . prettyNix =<< cabal2nix False MinimalDetails src cabalFile + +findCabalFiles :: FilePath -> IO [CabalFile] +findCabalFiles path = doesFileExist (path Hpack.packageConfig) >>= \case + False -> fmap (OnDisk . (path )) . filter (isSuffixOf ".cabal") <$> listDirectory path + True -> do + mbPkg <- Hpack.readPackageConfig Hpack.defaultDecodeOptions {Hpack.decodeOptionsTarget = path Hpack.packageConfig} + case mbPkg of + Left e -> error e + Right r -> + return $ [InMemory (Just Hpack) + (Hpack.decodeResultCabalFile r) + (encodeUtf8 $ Hpack.renderPackage [] (Hpack.decodeResultPackage r))] + + where encodeUtf8 :: String -> ByteString + encodeUtf8 = T.encodeUtf8 . T.pack + + +expr :: FilePath -> String -> String -> IO (Binding NExpr) +expr p pkg version = do + let cabal = OnDisk $ p pkg version pkg <.> "cabal" + -- prefix packages by the truncated sha256 + -- over their name to prevent case insensitivity + -- issues. We truncate just to be in line with + -- how the /nix/store path's look. + pkg' = (take 32 $ sha256 pkg) ++ "-" ++ pkg + nix = pkg' version <.> "nix" + version' = fromString . quoted $ version + doesFileExist (cabalFilePath cabal) >>= \case + True -> + do createDirectoryIfMissing True pkg' + writeDoc nix =<< prettyNix <$> cabal2nix False MinimalDetails Nothing cabal + pure $ version' $= mkRelPath nix + False -> pure $ version' $= mkNull + +cabalexprs :: FilePath -> IO NExpr +cabalexprs p = + do pkgs <- listDirectories p + fmap mkNonRecSet . forM pkgs $ \pkg -> + do versions <- listDirectories (p pkg) + let pkg' = fromString . quoted $ pkg + fmap (bindTo pkg' . mkNonRecSet) . forM versions $ \version -> + expr p pkg version diff --git a/hackage2nix/Main.hs b/hackage2nix/Main.hs new file mode 100644 --- /dev/null +++ b/hackage2nix/Main.hs @@ -0,0 +1,123 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NamedFieldPuns #-} + +module Main where + +import Cabal2Nix +import Cabal2Nix.Util ( quoted ) +import Control.Applicative ( liftA2 ) +import Control.Monad.Trans.State.Strict +import Crypto.Hash.SHA256 ( hashlazy ) +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BL +import Data.Foldable ( toList + , for_ + ) +import Data.List ( intersperse ) +import Data.Map ( Map ) +import qualified Data.Map as Map +import Data.Semigroup as Sem +import Data.Sequence ( Seq ) +import qualified Data.Sequence as Seq +import Data.String ( IsString(fromString) + ) +import Data.Text ( Text ) +import Data.Text.Encoding ( decodeUtf8 ) +import Distribution.Hackage.DB ( hackageTarball ) +import qualified Distribution.Hackage.DB.Parsed + as P +import qualified Distribution.Hackage.DB.Unparsed + as U +import Distribution.Pretty ( prettyShow + , Pretty + ) +import Distribution.Types.PackageName ( PackageName ) +import Distribution.Types.Version ( Version ) +import Nix.Expr +import Nix.Pretty ( prettyNix ) +import System.Directory ( createDirectoryIfMissing + ) +import System.Environment ( getArgs ) +import System.FilePath ( () + , (<.>) + ) + +main :: IO () +main = do + [out] <- getArgs + db <- U.readTarball Nothing =<< hackageTarball + + let (defaultNix, cabalFiles) = + runState (fmap seqToSet $ foldMapWithKeyA package2nix db) mempty + + createDirectoryIfMissing False out + writeFile (out "default.nix") $ show $ prettyNix defaultNix + createDirectoryIfMissing False (out "hackage") + + for_ cabalFiles $ \(cabalFile, pname, path) -> do + gpd <- cabal2nix False MinimalDetails Nothing $ InMemory Nothing pname $ BL.toStrict cabalFile + writeFile (out path) $ show $ prettyNix gpd + +type GPDWriter = State (Seq (BL.ByteString, String, FilePath)) + +newtype ApplicativeMonoid f a = ApplicativeMonoid { unApplicativeMonoid :: f a } +instance (Applicative f, Semigroup a) => Sem.Semigroup (ApplicativeMonoid f a) where + ApplicativeMonoid a <> ApplicativeMonoid b = ApplicativeMonoid $ liftA2 (Sem.<>) a b +instance (Applicative f, Monoid a) => Monoid (ApplicativeMonoid f a) where + mempty = ApplicativeMonoid $ pure mempty + mappend = (Sem.<>) + +foldMapWithKeyA + :: (Applicative f, Monoid b) => (k -> a -> f b) -> Map k a -> f b +foldMapWithKeyA f = + unApplicativeMonoid . Map.foldMapWithKey (\k -> ApplicativeMonoid . f k) + +seqToSet :: Seq (Binding NExpr) -> NExpr +seqToSet = mkNonRecSet . toList + +fromPretty :: (Pretty a, IsString b) => a -> b +fromPretty = fromString . prettyShow + +package2nix :: PackageName -> U.PackageData -> GPDWriter (Seq (Binding NExpr)) +package2nix pname (U.PackageData { U.versions }) = do + versionBindings <- foldMapWithKeyA (version2nix pname) versions + return $ Seq.singleton $ quoted (fromPretty pname) $= seqToSet versionBindings + +version2nix + :: PackageName -> Version -> U.VersionData -> GPDWriter (Seq (Binding NExpr)) +version2nix pname vnum (U.VersionData { U.cabalFileRevisions, U.metaFile }) = + do + revisionBindings <- sequenceA + $ zipWith (revBinding pname vnum) cabalFileRevisions [0 ..] + return $ Seq.singleton $ quoted (fromPretty vnum) $= mkRecSet + [ "sha256" $= mkStr + (fromString $ P.parseMetaData pname vnum metaFile Map.! "sha256") + , "revisions" $= mkNonRecSet + ( fmap (uncurry ($=)) revisionBindings + ++ ["default" $= (mkSym "revisions" @. fst (last revisionBindings))] + ) + ] + +revBinding + :: PackageName + -> Version + -> BL.ByteString + -> Integer + -> GPDWriter (Text, NExpr) +revBinding pname vnum cabalFile revNum = do + let qualifiedName = mconcat $ intersperse + "-" + [prettyPname, fromPretty vnum, revName, BS.unpack cabalHash] + revName :: (Semigroup a, IsString a) => a + revName = "r" <> fromString (show revNum) + revPath = "." "hackage" qualifiedName <.> "nix" + prettyPname = fromPretty pname + cabalHash = Base16.encode $ hashlazy cabalFile + modify' $ mappend $ Seq.singleton + (cabalFile, prettyPname ++ ".cabal", revPath) + return $ (,) revName $ mkNonRecSet + [ "outPath" $= mkRelPath revPath + , "revNum" $= mkInt revNum + , "sha256" $= mkStr (decodeUtf8 cabalHash) + ] diff --git a/hashes2nix/Main.hs b/hashes2nix/Main.hs new file mode 100644 --- /dev/null +++ b/hashes2nix/Main.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import System.Environment (getArgs) +import System.Directory +import System.FilePath +import Control.Monad + +import Nix.Pretty (prettyNix) +import Nix.Expr + +import Data.Aeson +import Lens.Micro +import Lens.Micro.Aeson + +import Data.String (fromString) + +import Cabal2Nix.Util + +main :: IO () +main = getArgs >>= \case + [path] -> do + print . prettyNix =<< hashes path + _ -> putStrLn "call with /path/to/all-cabal-hashes (Hashes2Nix /path/to/all-cabal-hashes)" + +hash :: FilePath -> String -> String -> IO (Binding NExpr) +hash p pkg version = do + let json = p pkg version pkg <.> "json" + version' = fromString . quoted $ version + doesFileExist json >>= \case + True -> decodeValue json >>= \case + Just obj -> case obj ^? key "package-hashes" . key "SHA256" . _String of + Just hash -> pure $ version' $= mkStr hash + Nothing -> pure $ version' $= mkNull + Nothing -> pure $ version' $= mkNull + False -> pure $ version' $= mkNull + where decodeValue :: FilePath -> IO (Maybe Value) + decodeValue = decodeFileStrict' + +hashes :: FilePath -> IO NExpr +hashes p = + do pkgs <- listDirectories p + fmap mkNonRecSet . forM pkgs $ \pkg -> + do versions <- listDirectories (p pkg) + let pkg' = fromString . quoted $ pkg + fmap (bindTo pkg' . mkNonRecSet) . forM versions $ \version -> + hash p pkg version + diff --git a/lib/Cabal2Nix.hs b/lib/Cabal2Nix.hs new file mode 100644 --- /dev/null +++ b/lib/Cabal2Nix.hs @@ -0,0 +1,426 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} + +module Cabal2Nix (cabal2nix, gpd2nix, Src(..), CabalFile(..), CabalFileGenerator(..), cabalFilePath, cabalFilePkgName, CabalDetailLevel(..)) where + +import Distribution.PackageDescription.Parsec (readGenericPackageDescription, parseGenericPackageDescription, runParseResult) +import Distribution.Verbosity (normal) +import Distribution.Text (disp) +import Distribution.Pretty (pretty) +import Data.Char (toUpper) +import System.FilePath +import Data.ByteString (ByteString) +import Data.Maybe (catMaybes, maybeToList) + +import Distribution.Types.CondTree +import Distribution.Types.Library +import Distribution.Types.ForeignLib +import Distribution.PackageDescription hiding (Git) +import Distribution.Types.Dependency +import Distribution.Types.ExeDependency +import Distribution.Types.LegacyExeDependency +import Distribution.Types.PkgconfigDependency +import Distribution.Types.PkgconfigName +import Distribution.Types.VersionRange +import Distribution.Compiler +import Distribution.Types.PackageName (PackageName, mkPackageName) +import Distribution.Simple.BuildToolDepends (desugarBuildTool) +import Distribution.ModuleName (ModuleName) +import qualified Distribution.ModuleName as ModuleName + +import Data.String (fromString, IsString) + +-- import Distribution.Types.GenericPackageDescription +-- import Distribution.Types.PackageDescription +import Distribution.Types.PackageId +--import Distribution.Types.Condition +import Distribution.Types.UnqualComponentName +import Nix.Expr +import Data.Fix(Fix(..)) +import Data.Text (Text) + +import Cabal2Nix.Util (quoted, selectOr, mkThrow) + +data Src + = Path FilePath + | Git String String (Maybe String) (Maybe String) + deriving Show + +pkgs, hsPkgs, pkgconfPkgs, flags :: Text +pkgs = "pkgs" +hsPkgs = "hsPkgs" +pkgconfPkgs = "pkgconfPkgs" +flags = "flags" + +buildDepError, sysDepError, pkgConfDepError, exeDepError, legacyExeDepError, buildToolDepError :: Text +buildDepError = "buildDepError" +sysDepError = "sysDepError" +pkgConfDepError = "pkgConfDepError" +exeDepError = "exeDepError" +legacyExeDepError = "legacyExeDepError" +buildToolDepError = "buildToolDepError" + +($//?) :: NExpr -> Maybe NExpr -> NExpr +lhs $//? (Just e) = lhs $// e +lhs $//? Nothing = lhs + +data CabalFileGenerator + = Hpack + deriving Show + +data CabalFile + = OnDisk FilePath + | InMemory (Maybe CabalFileGenerator) FilePath ByteString + deriving Show + + +cabalFilePath :: CabalFile -> String +cabalFilePath (OnDisk fp) = fp +cabalFilePath (InMemory _ fp _) = fp + +cabalFilePkgName :: CabalFile -> String +cabalFilePkgName = dropExtension . takeFileName . cabalFilePath + +genExtra :: CabalFileGenerator -> NExpr +genExtra Hpack = mkNonRecSet [ "cabal-generator" $= mkStr "hpack" ] + +data CabalDetailLevel = MinimalDetails | FullDetails deriving (Show, Eq) + +cabal2nix :: Bool -> CabalDetailLevel -> Maybe Src -> CabalFile -> IO NExpr +cabal2nix isLocal fileDetails src = \case + (OnDisk path) -> gpd2nix isLocal fileDetails src Nothing + <$> readGenericPackageDescription normal path + (InMemory gen _ body) -> gpd2nix isLocal fileDetails src (genExtra <$> gen) + <$> case runParseResult (parseGenericPackageDescription body) of + (_, Left (_, err)) -> error ("Failed to parse in-memory cabal file: " ++ show err) + (_, Right desc) -> pure desc + +gpd2nix :: Bool -> CabalDetailLevel -> Maybe Src -> Maybe NExpr -> GenericPackageDescription -> NExpr +gpd2nix isLocal fileDetails src extra gpd = mkLets errorFunctions $ mkFunction args $ toNixGenericPackageDescription isLocal fileDetails gpd $//? (toNix <$> src) $//? extra + where args :: Params NExpr + args = mkParamset [ ("system", Nothing) + , ("compiler", Nothing) + , ("flags", Nothing) + , (pkgs, Nothing) + , (hsPkgs, Nothing) + , (pkgconfPkgs, Nothing)] + True + +errorFunctions :: [Binding NExpr] +errorFunctions = + [ buildDepError $= mkFunction "pkg" (mkThrow $ + Fix $ NStr $ Indented 0 + [ Plain "The Haskell package set does not contain the package: " + , Antiquoted "pkg" + , Plain " (build dependency).\n\n" + , Plain haskellUpdateSnippet + ]) + , sysDepError $= mkFunction "pkg" (mkThrow $ + Fix $ NStr $ Indented 0 + [ Plain "The Nixpkgs package set does not contain the package: " + , Antiquoted "pkg" + , Plain " (system dependency).\n\n" + , Plain systemUpdateSnippet + ]) + , pkgConfDepError $= mkFunction "pkg" (mkThrow $ + Fix $ NStr $ Indented 0 + [ Plain "The pkg-conf packages does not contain the package: " + , Antiquoted "pkg" + , Plain " (pkg-conf dependency).\n\n" + , Plain "You may need to augment the pkg-conf package mapping in haskell.nix so that it can be found." + ]) + , exeDepError $= mkFunction "pkg" (mkThrow $ + Fix $ NStr $ Indented 0 + [ Plain "The local executable components do not include the component: " + , Antiquoted "pkg" + , Plain " (executable dependency)." + ]) + , legacyExeDepError $= mkFunction "pkg" (mkThrow $ + Fix $ NStr $ Indented 0 + [ Plain "The Haskell package set does not contain the package: " + , Antiquoted "pkg" + , Plain " (executable dependency).\n\n" + , Plain haskellUpdateSnippet + ]) + , buildToolDepError $= mkFunction "pkg" (mkThrow $ + Fix $ NStr $ Indented 0 + [ Plain "Neither the Haskell package set or the Nixpkgs package set contain the package: " + , Antiquoted "pkg" + , Plain " (build tool dependency).\n\n" + , Plain "If this is a system dependency:\n" + , Plain systemUpdateSnippet + , Plain "\n\n" + , Plain "If this is a Haskell dependency:\n" + , Plain haskellUpdateSnippet + ]) + ] + where + systemUpdateSnippet = "You may need to augment the system package mapping in haskell.nix so that it can be found." + haskellUpdateSnippet = "If you are using Stackage, make sure that you are using a snapshot that contains the package. Otherwise you may need to update the Hackage snapshot you are using, usually by updating haskell.nix." + +class IsComponent a where + getBuildInfo :: a -> BuildInfo + getMainPath :: a -> Maybe FilePath + getMainPath _ = Nothing + modules :: a -> [ModuleName] + modules = otherModules . getBuildInfo + +instance IsComponent Library where + getBuildInfo = libBuildInfo + modules a = otherModules (getBuildInfo a) + <> exposedModules a + <> signatures a + +instance IsComponent ForeignLib where + getBuildInfo = foreignLibBuildInfo + +instance IsComponent Executable where + getBuildInfo = buildInfo + getMainPath Executable {modulePath = p} = Just p + +instance IsComponent TestSuite where + getBuildInfo = testBuildInfo + getMainPath TestSuite {testInterface = (TestSuiteExeV10 _ p)} = Just p + getMainPath _ = Nothing + +instance IsComponent Benchmark where + getBuildInfo = benchmarkBuildInfo + +--- Clean the Tree from empty nodes +-- CondBranch is empty if the true and false branch are empty. +shakeTree :: (Foldable t, Foldable f) => CondTree v (t c) (f a) -> Maybe (CondTree v (t c) (f a)) +shakeTree (CondNode d c bs) = case (null d, null bs') of + (True, True) -> Nothing + _ -> Just (CondNode d c bs') + where bs' = catMaybes (shakeBranch <$> bs) + +shakeBranch :: (Foldable t, Foldable f) => CondBranch v (t c) (f a) -> Maybe (CondBranch v (t c) (f a)) +shakeBranch (CondBranch c t f) = case (shakeTree t, f >>= shakeTree) of + (Nothing, Nothing) -> Nothing + (Nothing, Just f') -> shakeBranch (CondBranch (CNot c) f' Nothing) + (Just t', f') -> Just (CondBranch c t' f') + +--- String helper +transformFst :: (Char -> Char) -> String -> String +transformFst _ [] = [] +transformFst f (x:xs) = f x : xs +capitalize :: String -> String +capitalize = transformFst toUpper + +--- Turn something into a NExpr + +class ToNixExpr a where + toNix :: a -> NExpr + +class ToNixBinding a where + toNixBinding :: a -> Binding NExpr + +instance ToNixExpr Src where + toNix (Path p) = mkRecSet [ "src" $= applyMkDefault (mkRelPath p) ] + toNix (Git url rev mbSha256 mbPath) + = mkNonRecSet $ + [ "src" $= applyMkDefault (mkSym pkgs @. "fetchgit" @@ mkNonRecSet + [ "url" $= mkStr (fromString url) + , "rev" $= mkStr (fromString rev) + , "sha256" $= case mbSha256 of + Just sha256 -> mkStr (fromString sha256) + Nothing -> mkNull + ]) + ] <> + [ "postUnpack" + $= mkStr (fromString $ "sourceRoot+=/" <> root <> "; echo source root reset to $sourceRoot") + | Just root <- [mbPath] ] + +applyMkDefault :: NExpr -> NExpr +applyMkDefault expr = mkSym pkgs @. "lib" @. "mkDefault" @@ expr + +instance ToNixExpr PackageIdentifier where + toNix ident = mkNonRecSet [ "name" $= mkStr (fromString (show (disp (pkgName ident)))) + , "version" $= mkStr (fromString (show (disp (pkgVersion ident))))] + +toNixPackageDescription :: Bool -> CabalDetailLevel -> PackageDescription -> NExpr +toNixPackageDescription isLocal detailLevel pd = mkNonRecSet $ + [ "specVersion" $= mkStr (fromString (show (disp (specVersion pd)))) + , "identifier" $= toNix (package pd) + , "license" $= mkStr (fromString (show (pretty (license pd)))) + + , "copyright" $= mkStr (fromString (copyright pd)) + , "maintainer" $= mkStr (fromString (maintainer pd)) + , "author" $= mkStr (fromString (author pd)) + + , "homepage" $= mkStr (fromString (homepage pd)) + , "url" $= mkStr (fromString (pkgUrl pd)) + + , "synopsis" $= mkStr (fromString (synopsis pd)) + , "description" $= mkStr (fromString (description pd)) + + , "buildType" $= mkStr (fromString (show (pretty (buildType pd)))) + ] ++ + [ "isLocal" $= mkBool True | isLocal + ] ++ + [ "setup-depends" $= toNix (BuildToolDependency . depPkgName <$> deps) | Just deps <- [setupDepends <$> setupBuildInfo pd ]] ++ + if detailLevel == MinimalDetails + then [] + else + [ "detailLevel" $= mkStr (fromString (show detailLevel)) + , "licenseFiles" $= toNix (licenseFiles pd) + , "dataDir" $= mkStr (fromString (dataDir pd)) + , "dataFiles" $= toNix (dataFiles pd) + , "extraSrcFiles" $= toNix (extraSrcFiles pd) + , "extraTmpFiles" $= toNix (extraTmpFiles pd) + , "extraDocFiles" $= toNix (extraDocFiles pd) + ] + +newtype SysDependency = SysDependency { unSysDependency :: String } deriving (Show, Eq, Ord) +newtype BuildToolDependency = BuildToolDependency { unBuildToolDependency :: PackageName } deriving (Show, Eq, Ord) + +mkSysDep :: String -> SysDependency +mkSysDep = SysDependency + +toNixGenericPackageDescription :: Bool -> CabalDetailLevel -> GenericPackageDescription -> NExpr +toNixGenericPackageDescription isLocal detailLevel gpd = mkNonRecSet + [ "flags" $= (mkNonRecSet . fmap toNixBinding $ genPackageFlags gpd) + , "package" $= toNixPackageDescription isLocal detailLevel (packageDescription gpd) + , "components" $= components ] + where _packageName :: IsString a => a + _packageName = fromString . show . disp . pkgName . package . packageDescription $ gpd + component :: IsComponent comp => UnqualComponentName -> CondTree ConfVar [Dependency] comp -> Binding NExpr + component unQualName comp + = quoted name $= + mkNonRecSet ( + [ "depends" $= toNix deps | Just deps <- [shakeTree . fmap ( targetBuildDepends . getBuildInfo) $ comp ] ] ++ + [ "libs" $= toNix deps | Just deps <- [shakeTree . fmap ( fmap mkSysDep . extraLibs . getBuildInfo) $ comp ] ] ++ + [ "frameworks" $= toNix deps | Just deps <- [shakeTree . fmap ( fmap mkSysDep . frameworks . getBuildInfo) $ comp ] ] ++ + [ "pkgconfig" $= toNix deps | Just deps <- [shakeTree . fmap ( pkgconfigDepends . getBuildInfo) $ comp ] ] ++ + [ "build-tools" $= toNix deps | Just deps <- [shakeTree . fmap ( toolDeps . getBuildInfo) $ comp ] ] ++ + [ "buildable" $= boolTreeToNix (and <$> b) | Just b <- [shakeTree . fmap ((:[]) . buildable . getBuildInfo) $ comp ] ] ++ + if detailLevel == MinimalDetails + then [] + else + [ "modules" $= toNix mods | Just mods <- [shakeTree . fmap (fmap ModuleName.toFilePath . modules) $ comp ] ] ++ + [ "asmSources" $= toNix src | Just src <- [shakeTree . fmap (asmSources . getBuildInfo) $ comp ] ] ++ + [ "cmmSources" $= toNix src | Just src <- [shakeTree . fmap (cmmSources . getBuildInfo) $ comp ] ] ++ + [ "cSources" $= toNix src | Just src <- [shakeTree . fmap (cSources . getBuildInfo) $ comp ] ] ++ + [ "cxxSources" $= toNix src | Just src <- [shakeTree . fmap (cxxSources . getBuildInfo) $ comp ] ] ++ + [ "jsSources" $= toNix src | Just src <- [shakeTree . fmap (jsSources . getBuildInfo) $ comp ] ] ++ + [ "hsSourceDirs" $= toNix dir | Just dir <- [shakeTree . fmap (hsSourceDirs . getBuildInfo) $ comp ] ] ++ + [ "includeDirs" $= toNix dir | Just dir <- [shakeTree . fmap (includeDirs . getBuildInfo) $ comp] ] ++ + [ "includes" $= toNix dir | Just dir <- [shakeTree . fmap (includes . getBuildInfo) $ comp] ] ++ + [ "mainPath" $= toNix p | Just p <- [shakeTree . fmap (maybeToList . getMainPath) $ comp] ]) + where name = fromString $ unUnqualComponentName unQualName + toolDeps = getToolDependencies (packageDescription gpd) + toBuildToolDep (ExeDependency pkg _ _) = BuildToolDependency pkg + getToolDependencies pkg bi = + map toBuildToolDep (buildToolDepends bi) + <> map (\led -> maybe (guess led) toBuildToolDep $ desugarBuildTool pkg led) (buildTools bi) + guess (LegacyExeDependency n _) = BuildToolDependency (mkPackageName n) + components = mkNonRecSet $ + [ component "library" lib | Just lib <- [condLibrary gpd] ] ++ + (bindTo "sublibs" . mkNonRecSet <$> filter (not . null) [ uncurry component <$> condSubLibraries gpd ]) ++ + (bindTo "foreignlibs" . mkNonRecSet <$> filter (not . null) [ uncurry component <$> condForeignLibs gpd ]) ++ + (bindTo "exes" . mkNonRecSet <$> filter (not . null) [ uncurry component <$> condExecutables gpd ]) ++ + (bindTo "tests" . mkNonRecSet <$> filter (not . null) [ uncurry component <$> condTestSuites gpd ]) ++ + (bindTo "benchmarks" . mkNonRecSet <$> filter (not . null) [ uncurry component <$> condBenchmarks gpd ]) + +-- WARNING: these use functions bound at he top level in the GPD expression, they won't work outside it + +instance ToNixExpr Dependency where + toNix d = selectOr (mkSym hsPkgs) (mkSelector $ quoted pkg) (mkSym buildDepError @@ mkStr pkg) + where + pkg = fromString . show . pretty . depPkgName $ d + +instance ToNixExpr SysDependency where + toNix d = selectOr (mkSym pkgs) (mkSelector $ quoted pkg) (mkSym sysDepError @@ mkStr pkg) + where + pkg = fromString . unSysDependency $ d + +instance ToNixExpr PkgconfigDependency where + toNix (PkgconfigDependency name _versionRange) = selectOr (mkSym pkgconfPkgs) (mkSelector $ quoted pkg) (mkSym pkgConfDepError @@ mkStr pkg) + where + pkg = fromString . unPkgconfigName $ name + +instance ToNixExpr ExeDependency where + toNix (ExeDependency pkgName' _unqualCompName _versionRange) = selectOr (mkSym "exes") (mkSelector $ pkg) (mkSym exeDepError @@ mkStr pkg) + where + pkg = fromString . show . pretty $ pkgName' + +instance ToNixExpr BuildToolDependency where + toNix (BuildToolDependency pkgName') = + -- TODO once https://github.com/haskell-nix/hnix/issues/52 + -- is reolved use something like: + -- [nix| hsPkgs.buildPackages.$((pkgName)) or pkgs.buildPackages.$((pkgName)) ] + selectOr (mkSym hsPkgs) buildPackagesDotName + (selectOr (mkSym pkgs) buildPackagesDotName (mkSym buildToolDepError @@ mkStr pkg)) + where + pkg = fromString . show . pretty $ pkgName' + buildPackagesDotName = mkSelector "buildPackages" <> mkSelector pkg + +instance ToNixExpr LegacyExeDependency where + toNix (LegacyExeDependency name _versionRange) = selectOr (mkSym hsPkgs) (mkSelector $ quoted pkg) (mkSym legacyExeDepError @@ mkStr pkg) + where + pkg = fromString name + +instance {-# OVERLAPPABLE #-} ToNixExpr String where + toNix = mkStr . fromString + +instance {-# OVERLAPS #-} ToNixExpr a => ToNixExpr [a] where + toNix = mkList . fmap toNix + +instance ToNixExpr ConfVar where + toNix (OS os) = mkSym "system" @. (fromString . ("is" ++) . capitalize . show . pretty $ os) + toNix (Arch arch) = mkSym "system" @. (fromString . ("is" ++) . capitalize . show . pretty $ arch) + toNix (Flag flag) = mkSym flags @. (fromString . show . pretty $ flag) + toNix (Impl flavour range) = toNix flavour $&& toNix (projectVersionRange range) + +instance ToNixExpr CompilerFlavor where + toNix flavour = mkSym "compiler" @. (fromString . ("is" ++) . capitalize . show . pretty $ flavour) + +instance ToNixExpr (VersionRangeF VersionRange) where + toNix AnyVersionF = mkBool True + toNix (ThisVersionF ver) = mkSym "compiler" @. "version" @. "eq" @@ mkStr (fromString (show (disp ver))) + toNix (LaterVersionF ver) = mkSym "compiler" @. "version" @. "gt" @@ mkStr (fromString (show (disp ver))) + toNix (OrLaterVersionF ver) = mkSym "compiler" @. "version" @. "ge" @@ mkStr (fromString (show (disp ver))) + toNix (EarlierVersionF ver) = mkSym "compiler" @. "version" @. "lt" @@ mkStr (fromString (show (disp ver))) + toNix (OrEarlierVersionF ver) = mkSym "compiler" @. "version" @. "le" @@ mkStr (fromString (show (disp ver))) + toNix (WildcardVersionF _ver) = mkBool False +-- toNix (MajorBoundVersionF ver) = mkSym "compiler" @. "version" @. "eq" @@ mkStr (fromString (show (disp ver))) + toNix (IntersectVersionRangesF v1 v2) = toNix (projectVersionRange v1) $&& toNix (projectVersionRange v2) + toNix x = error $ "ToNixExpr VersionRange for `" ++ show x ++ "` not implemented!" + +instance ToNixExpr a => ToNixExpr (Condition a) where + toNix (Var a) = toNix a + toNix (Lit b) = mkBool b + toNix (CNot c) = mkNot (toNix c) + toNix (COr l r) = toNix l $|| toNix r + toNix (CAnd l r) = toNix l $&& toNix r + +instance (Foldable t, ToNixExpr (t a), ToNixExpr v, ToNixExpr c) => ToNixExpr (CondBranch v c (t a)) where + toNix (CondBranch c t Nothing) = case toNix t of + (Fix (NList [e])) -> mkSym pkgs @. "lib" @. "optional" @@ toNix c @@ e + e -> mkSym pkgs @. "lib" @. "optionals" @@ toNix c @@ e + toNix (CondBranch _c t (Just f)) | toNix t == toNix f = toNix t + toNix (CondBranch c t (Just f)) = mkIf (toNix c) (toNix t) (toNix f) + +instance (Foldable t, ToNixExpr (t a), ToNixExpr v, ToNixExpr c) => ToNixExpr (CondTree v c (t a)) where + toNix (CondNode d _c []) = toNix d + toNix (CondNode d _c bs) | null d = foldl1 ($++) (fmap toNix bs) + | otherwise = foldl ($++) (toNix d) (fmap toNix bs) + +boolBranchToNix :: (ToNixExpr v, ToNixExpr c) => CondBranch v c Bool -> NExpr +boolBranchToNix (CondBranch _c t Nothing) | boolTreeToNix t == mkBool True = mkBool True +boolBranchToNix (CondBranch c t Nothing) = mkIf (toNix c) (boolTreeToNix t) (mkBool True) +boolBranchToNix (CondBranch _c t (Just f)) | boolTreeToNix t == boolTreeToNix f = boolTreeToNix t +boolBranchToNix (CondBranch c t (Just f)) = mkIf (toNix c) (boolTreeToNix t) (boolTreeToNix f) + +boolTreeToNix :: (ToNixExpr v, ToNixExpr c) => CondTree v c Bool -> NExpr +boolTreeToNix (CondNode False _c _bs) = mkBool False +boolTreeToNix (CondNode True _c bs) = + case filter (/= mkBool True) (fmap boolBranchToNix bs) of + [] -> mkBool True + bs' -> foldl1 ($&&) bs' + +instance ToNixBinding Flag where + toNixBinding (MkFlag name _desc def _manual) = (fromString . show . pretty $ name) $= mkBool def + + diff --git a/lib/Cabal2Nix/Plan.hs b/lib/Cabal2Nix/Plan.hs new file mode 100644 --- /dev/null +++ b/lib/Cabal2Nix/Plan.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +module Cabal2Nix.Plan +where + +import Cabal2Nix.Util ( quoted + , bindPath + ) +import Data.HashMap.Strict ( HashMap ) +import qualified Data.HashMap.Strict as Map +import Data.List.NonEmpty ( NonEmpty (..) ) +import Data.Text ( Text ) +import qualified Data.Text as Text +import Nix.Expr + +type Version = Text +type Revision = Text -- Can be: rNUM, cabal file sha256, or "default" + +data Plan = Plan + { packages :: HashMap Text (Maybe Package) + , compilerVersion :: Text + , compilerPackages :: HashMap Text (Maybe Version) + } + +data Package = Package + { packageVersion :: Version + , packageRevision :: Maybe Revision + , packageFlags :: HashMap Text Bool + } + +plan2nix :: Plan -> NExpr +plan2nix (Plan { packages, compilerVersion, compilerPackages }) = + mkFunction "hackage" + . mkNonRecSet + $ [ "packages" $= (mkNonRecSet $ uncurry bind =<< Map.toList quotedPackages) + , "compiler" $= mkNonRecSet + [ "version" $= mkStr compilerVersion + , "nix-name" $= mkStr ("ghc" <> Text.filter (/= '.') compilerVersion) + , "packages" $= mkNonRecSet (fmap (uncurry bind') $ Map.toList $ mapKeys quoted compilerPackages) + ] + ] + where + quotedPackages = mapKeys quoted packages + bind pkg (Just (Package { packageVersion, packageRevision, packageFlags })) = + let verExpr = mkSym "hackage" @. pkg @. quoted packageVersion + revExpr = verExpr @. "revisions" @. maybe "default" quoted packageRevision + flagBindings = Map.foldrWithKey + (\fname val acc -> bindPath (pkg :| ["flags", fname]) (mkBool val) : acc) + [] + packageFlags + in revBinding pkg revExpr : flagBindings + bind pkg Nothing = [revBinding pkg mkNull] + revBinding pkg revExpr = bindPath (pkg :| ["revision"]) revExpr + bind' pkg ver = pkg $= maybe mkNull mkStr ver + mapKeys f = Map.fromList . fmap (\(k, v) -> (f k, v)) . Map.toList diff --git a/lib/Cabal2Nix/Util.hs b/lib/Cabal2Nix/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Cabal2Nix/Util.hs @@ -0,0 +1,37 @@ +{-# LANGUAGE OverloadedStrings #-} +module Cabal2Nix.Util where + +import System.Directory +import System.FilePath + +import Control.Monad +import Data.String (IsString) + +import Data.ByteString.Char8 (pack, unpack) +import Data.Text (Text) +import Crypto.Hash.SHA256 (hash) +import qualified Data.ByteString.Base16 as Base16 + +import Data.List.NonEmpty (NonEmpty) +import Data.Fix(Fix(..)) +import Nix.Expr + +listDirectories :: FilePath -> IO [FilePath] +listDirectories p = + filter (/= ".git") <$> listDirectory p + >>= filterM (doesDirectoryExist . (p )) + +quoted :: (IsString a, Semigroup a) => a -> a +quoted str = "\"" <> str <> "\"" + +selectOr :: NExpr -> NAttrPath NExpr -> NExpr -> NExpr +selectOr obj path alt = Fix (NSelect obj path (Just $ alt)) + +mkThrow :: NExpr -> NExpr +mkThrow msg = (mkSym "builtins" @. "throw") @@ msg + +sha256 :: String -> String +sha256 = unpack . Base16.encode . hash . pack + +bindPath :: NonEmpty Text -> NExpr -> Binding NExpr +bindPath ks e = NamedVar (fmap StaticKey ks) e nullPos diff --git a/lib/Distribution/Nixpkgs/Fetch.hs b/lib/Distribution/Nixpkgs/Fetch.hs new file mode 100644 --- /dev/null +++ b/lib/Distribution/Nixpkgs/Fetch.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE DeriveGeneric #-} + +module Distribution.Nixpkgs.Fetch + ( Source(..) + , Hash(..) + , DerivationSource(..), fromDerivationSource + , fetch + , fetchWith + ) where + +import Control.Applicative +import Control.DeepSeq +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Maybe +import Data.Aeson +import qualified Data.ByteString.Lazy.Char8 as BS +import GHC.Generics ( Generic ) +import System.Directory +import System.Environment +import System.Exit +import System.IO +import System.Process + +-- | A source is a location from which we can fetch, such as a HTTP URL, a GIT URL, .... +data Source = Source + { sourceUrl :: String -- ^ URL to fetch from. + , sourceRevision :: String -- ^ Revision to use. For protocols where this doesn't make sense (such as HTTP), this + -- should be the empty string. + , sourceHash :: Hash -- ^ The expected hash of the source, if available. + , sourceCabalDir :: String -- ^ Directory where Cabal file is found. + } deriving (Show, Eq, Ord, Generic) + +instance NFData Source + +data Hash = Certain String | Guess String | UnknownHash + deriving (Show, Eq, Ord, Generic) + +instance NFData Hash + +isUnknown :: Hash -> Bool +isUnknown UnknownHash = True +isUnknown _ = False + +hashToList :: Hash -> [String] +hashToList (Certain s) = [s] +hashToList _ = [] + +-- | A source for a derivation. It always needs a hash and also has a protocol attached to it (url, git, svn, ...). +-- A @DerivationSource@ also always has it's revision fully resolved (not relative revisions like @master@, @HEAD@, etc). +data DerivationSource = DerivationSource + { derivKind :: String -- ^ The kind of the source. The name of the build-support fetch derivation should be fetch. + , derivUrl :: String -- ^ URL to fetch from. + , derivRevision :: String -- ^ Revision to use. Leave empty if the fetcher doesn't support revisions. + , derivHash :: String -- ^ The hash of the source. + } + deriving (Show, Eq, Ord, Generic) + +instance NFData DerivationSource + +instance FromJSON DerivationSource where + parseJSON (Object o) = DerivationSource (error "undefined DerivationSource.kind") + <$> o .: "url" + <*> o .: "rev" + <*> o .: "sha256" + parseJSON _ = error "invalid DerivationSource" + +fromDerivationSource :: DerivationSource -> Source +fromDerivationSource DerivationSource{..} = Source derivUrl derivRevision (Certain derivHash) "." + +-- | Fetch a source, trying any of the various nix-prefetch-* scripts. +fetch :: forall a. (String -> MaybeT IO a) -- ^ This function is passed the output path name as an argument. + -- It should return 'Nothing' if the file doesn't match the expected format. + -- This is required, because we cannot always check if a download succeeded otherwise. + -> Source -- ^ The source to fetch from. + -> IO (Maybe (DerivationSource, a)) -- ^ The derivation source and the result of the processing function. Returns Nothing if the download failed. +fetch f = runMaybeT . fetchers where + fetchers :: Source -> MaybeT IO (DerivationSource, a) + fetchers source = msum . (fetchLocal source :) $ map (\fetcher -> fetchWith fetcher source >>= process) + [ (False, "url", []) + , (True, "git", ["--fetch-submodules"]) + , (True, "hg", []) + , (True, "svn", []) + , (True, "bzr", []) + ] + + -- | Remove '/' from the end of the path. Nix doesn't accept paths that + -- end in a slash. + stripSlashSuffix :: String -> String + stripSlashSuffix = reverse . dropWhile (== '/') . reverse + + fetchLocal :: Source -> MaybeT IO (DerivationSource, a) + fetchLocal src = do + let path = stripSlashSuffix $ stripPrefix "file://" $ sourceUrl src + existsFile <- liftIO $ doesFileExist path + existsDir <- liftIO $ doesDirectoryExist path + guard $ existsDir || existsFile + let path' | '/' `elem` path = path + | otherwise = "./" ++ path + process (DerivationSource "" path' "" "", path') <|> localArchive path' + + localArchive :: FilePath -> MaybeT IO (DerivationSource, a) + localArchive path = do + absolutePath <- liftIO $ canonicalizePath path + unpacked <- snd <$> fetchWith (False, "url", ["--unpack"]) (Source ("file://" ++ absolutePath) "" UnknownHash ".") + process (DerivationSource "" absolutePath "" "", unpacked) + + process :: (DerivationSource, FilePath) -> MaybeT IO (DerivationSource, a) + process (derivSource, file) = (,) derivSource <$> f file + +-- | Like 'fetch', but allows to specify which script to use. +fetchWith :: (Bool, String, [String]) -> Source -> MaybeT IO (DerivationSource, FilePath) +fetchWith (supportsRev, kind, addArgs) source = do + unless ((sourceRevision source /= "") || isUnknown (sourceHash source) || not supportsRev) $ + liftIO (hPutStrLn stderr "** need a revision for VCS when the hash is given. skipping.") >> mzero + + MaybeT $ liftIO $ do + envs <- getEnvironment + (Nothing, Just stdoutH, _, processH) <- createProcess (proc script args) + { env = Just $ ("PRINT_PATH", "1") : envs + , std_in = Inherit + , std_err = Inherit + , std_out = CreatePipe + } + + exitCode <- waitForProcess processH + case exitCode of + ExitFailure _ -> return Nothing + ExitSuccess -> do + buf <- BS.hGetContents stdoutH + let (l:ls) = reverse (BS.lines buf) + buf' = BS.unlines (reverse ls) + case length ls of + 0 -> return Nothing + 1 -> return (Just (DerivationSource kind (sourceUrl source) "" (BS.unpack (head ls)) , sourceUrl source)) + _ -> case eitherDecode buf' of + Left err -> error ("invalid JSON: " ++ err ++ " in " ++ show buf') + Right ds -> return (Just (ds { derivKind = kind }, BS.unpack l)) + where + + script :: String + script = "nix-prefetch-" ++ kind + + args :: [String] + args = addArgs ++ sourceUrl source : [ sourceRevision source | supportsRev ] ++ hashToList (sourceHash source) + +stripPrefix :: Eq a => [a] -> [a] -> [a] +stripPrefix prefix as + | prefix' == prefix = stripped + | otherwise = as + where + (prefix', stripped) = splitAt (length prefix) as diff --git a/lts2nix/Main.hs b/lts2nix/Main.hs new file mode 100644 --- /dev/null +++ b/lts2nix/Main.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.Foldable (toList) +import System.Environment (getArgs) + +import Data.Yaml (decodeFileEither) + +import Nix.Pretty (prettyNix) +import Nix.Expr + +import Data.Aeson +import qualified Data.HashMap.Strict as Map +import Lens.Micro +import Lens.Micro.Aeson + +import Cabal2Nix.Plan + +main :: IO () +main = getArgs >>= \case + [file] -> do + print . prettyNix =<< ltsPackages file + _ -> putStrLn "call with /path/to/lts.yaml (Lts2Nix /path/to/lts-X.Y.yaml)" + +ltsPackages :: FilePath -> IO NExpr +ltsPackages lts = do + evalue <- decodeFileEither lts + case evalue of + Left e -> error (show e) + Right value -> pure $ plan2nix $ lts2plan value + +lts2plan :: Value -> Plan +lts2plan lts = Plan { packages , compilerVersion , compilerPackages } + where + packages = mappend compilerPackages' $ fmap Just $ lts ^. key "packages" . _Object <&> \v -> Package + { packageVersion = v ^. key "version" . _String + , packageRevision = v ^? key "cabal-file-info" . key "hashes" . key "SHA256" . _String + , packageFlags = Map.mapMaybe (^? _Bool) $ v ^. key "constraints" . key "flags" . _Object + } + compilerVersion = lts ^. key "system-info" . key "ghc-version" . _String + compilerPackages = + (lts ^. key "system-info" . key "core-packages" . _Object <&> (Just . (^. _String))) + <> Map.fromList + [ (p, Nothing) -- core-executables is just a list of + -- exe names shipped with GHC, which + -- lots of packages depend on + -- (e.g. hsc2hs) + | p <- toList $ lts ^. key "system-info" . key "core-executables" . _Array <&> (^. _String) + ] + compilerPackages' = fmap + (fmap $ \v -> Package + { packageVersion = v + , packageRevision = Nothing + , packageFlags = Map.empty + } + ) + compilerPackages diff --git a/nix-tools.cabal b/nix-tools.cabal new file mode 100644 --- /dev/null +++ b/nix-tools.cabal @@ -0,0 +1,184 @@ +name: nix-tools +version: 0.1.0.0 +synopsis: cabal/stack to nix translation tools +description: A set of tools to aid in trating stack and cabal projects into nix expressions. +license: BSD3 +license-file: LICENSE +author: Moritz Angermann +maintainer: moritz.angermann@gmail.com +-- copyright: +category: Distribution +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +library + ghc-options: -Wall + exposed-modules: Cabal2Nix + , Cabal2Nix.Util + , Cabal2Nix.Plan + , Distribution.Nixpkgs.Fetch + build-depends: base >=4 && <4.13 + , hnix + , aeson + , unordered-containers + , process + , deepseq + , transformers + , data-fix + , Cabal >= 2.4 + , text + , filepath + , directory + , bytestring + , cryptohash-sha256 + , base16-bytestring + , hpack + hs-source-dirs: lib + default-language: Haskell2010 + + +executable cabal-to-nix + ghc-options: -Wall + main-is: Main.hs + build-depends: base >=4 && <4.13 + , transformers + , bytestring + , hpack + , hnix + , text + , nix-tools + , filepath + , directory + , prettyprinter + hs-source-dirs: cabal2nix + default-language: Haskell2010 + +executable hashes-to-nix + ghc-options: -Wall + main-is: Main.hs + build-depends: base >=4 && <4.13 + , hnix + , nix-tools + , data-fix + , aeson + , microlens + , microlens-aeson + , text + , filepath + , directory + hs-source-dirs: hashes2nix + default-language: Haskell2010 + +executable plan-to-nix + ghc-options: -Wall + main-is: Main.hs + other-modules: Plan2Nix + , Plan2Nix.Cache + , Plan2Nix.CLI + , Plan2Nix.Project + , Plan2Nix.Plan + build-depends: base >=4 && <4.13 + , nix-tools + , hnix + , Cabal >= 2.4 + , text + , hpack + , unordered-containers + , vector + , aeson + , microlens + , microlens-aeson + , optparse-applicative + , prettyprinter + , filepath + , directory + , bytestring + , transformers + , extra + hs-source-dirs: plan2nix + default-language: Haskell2010 + +executable hackage-to-nix + ghc-options: -Wall + main-is: Main.hs + build-depends: base >=4 && <4.13 + , nix-tools + , hackage-db + , hnix + , Cabal + , containers + , bytestring + , text + , cryptohash-sha256 + , base16-bytestring + , filepath + , directory + , transformers + hs-source-dirs: hackage2nix + default-language: Haskell2010 + +executable lts-to-nix + ghc-options: -Wall + main-is: Main.hs + build-depends: base >=4 && <4.13 + , nix-tools + , hnix + , yaml + , aeson + , microlens + , microlens-aeson + , text + , filepath + , directory + , unordered-containers + , Cabal + hs-source-dirs: lts2nix + default-language: Haskell2010 + +executable stack-to-nix + ghc-options: -Wall + main-is: Main.hs + other-modules: Stack2nix + , Stack2nix.Cache + , Stack2nix.CLI + , Stack2nix.External.Resolve + , Stack2nix.Project + , Stack2nix.Stack + build-depends: base >=4 && <4.13 + , nix-tools + , transformers + , hnix + , yaml + , aeson + , microlens + , microlens-aeson + , text + , Cabal + , vector + , prettyprinter + , directory + , filepath + , extra + , hpack + , bytestring + , optparse-applicative + , http-client-tls + , http-client + , http-types + , unordered-containers + hs-source-dirs: stack2nix + default-language: Haskell2010 + +executable truncate-index + ghc-options: -Wall + main-is: Main.hs + -- other-modules: + build-depends: base + , optparse-applicative + , zlib + , tar + , bytestring + , time + hs-source-dirs: truncate-index + default-language: Haskell2010 diff --git a/plan2nix/Main.hs b/plan2nix/Main.hs new file mode 100644 --- /dev/null +++ b/plan2nix/Main.hs @@ -0,0 +1,6 @@ +module Main where +import Plan2Nix (doPlan2Nix) +import Plan2Nix.CLI (parsePlan2NixArgs) + +main :: IO () +main = parsePlan2NixArgs >>= doPlan2Nix diff --git a/plan2nix/Plan2Nix.hs b/plan2nix/Plan2Nix.hs new file mode 100644 --- /dev/null +++ b/plan2nix/Plan2Nix.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE LambdaCase, OverloadedStrings, NamedFieldPuns, RecordWildCards #-} + +module Plan2Nix + ( doPlan2Nix + , planexpr + , plan2nix + ) where + +import Data.Aeson +import Data.Char ( isDigit ) +import Data.HashMap.Strict ( HashMap ) +import qualified Data.HashMap.Strict as Map +import Data.Maybe ( mapMaybe + , isJust + , fromMaybe + ) +import Data.List.NonEmpty ( NonEmpty (..) ) +import qualified Data.Text as Text +import Data.Text ( Text ) +import qualified Data.Vector as Vector +import Lens.Micro +import Lens.Micro.Aeson +import Nix.Expr +import Nix.Pretty ( prettyNix ) +import System.Environment ( getArgs ) + +import Data.Text.Prettyprint.Doc (Doc) +import Data.Text.Prettyprint.Doc.Render.Text (hPutDoc) + +import Distribution.Types.PackageId (PackageIdentifier(..)) +import Distribution.Nixpkgs.Fetch (DerivationSource(..), Source(..), Hash(..), fetch) +import Distribution.Simple.Utils (shortRelativePath) + +import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class (liftIO) +import Control.Monad (unless, forM) +import Extra (unlessM) + +import Cabal2Nix hiding (Git) +import qualified Cabal2Nix as C2N +import Cabal2Nix.Util + + +import Plan2Nix.CLI (Args(..)) +import Plan2Nix.Plan (Plan(..), PkgSrc(..), Package(..), Location(..)) + +import Plan2Nix.Cache (appendCache, cacheHits) +import Plan2Nix.Project + +import System.FilePath ((<.>), (), takeDirectory, dropFileName) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory) +import System.IO (IOMode(..), openFile, hClose) +import Data.String (fromString) + + +doPlan2Nix :: Args -> IO () +doPlan2Nix args = do + let pkgsNix = argOutputDir args "pkgs.nix" + defaultNix = argOutputDir args "default.nix" + pkgs <- planexpr args + writeDoc pkgsNix (prettyNix pkgs) + unlessM (doesFileExist defaultNix) $ do + writeFile defaultNix defaultNixContents + +planexpr :: Args -> IO NExpr +planexpr args = + do evalue <- eitherDecodeFileStrict (argPlanJSON args) + case evalue of + Left e -> error (show e) + Right value -> plan2nix args $ value2plan value + +writeDoc :: FilePath -> Doc ann -> IO () +writeDoc file doc = + do handle <- openFile file WriteMode + hPutDoc handle doc + hClose handle + +plan2nix :: Args -> Plan -> IO NExpr +plan2nix args (Plan { packages, extras, compilerVersion, compilerPackages }) = do + -- TODO: this is an aweful hack and expects plan-to-nix to be + -- called from the toplevel project directory. + cwd <- getCurrentDirectory + extrasNix <- fmap (mkNonRecSet . concat) . forM (Map.toList extras) $ \case + (name, Just (Package v r flags (Just (LocalPath folder)))) -> + do cabalFiles <- findCabalFiles folder + forM cabalFiles $ \cabalFile -> + let pkg = cabalFilePkgName cabalFile + nix = ".plan.nix" pkg <.> "nix" + nixFile = argOutputDir args nix + src = Just . C2N.Path $ relPath ".." (shortRelativePath cwd folder) + in do createDirectoryIfMissing True (takeDirectory nixFile) + writeDoc nixFile =<< + prettyNix <$> cabal2nix True (argDetailLevel args) src cabalFile + return $ fromString pkg $= mkPath False nix + (name, Just (Package v r flags (Just (DVCS (Git url rev) subdirs)))) -> + fmap concat . forM subdirs $ \subdir -> + do cacheHits <- liftIO $ cacheHits (argCacheFile args) url rev subdir + case cacheHits of + [] -> do + fetch (\dir -> cabalFromPath url rev subdir $ dir subdir) + (Source url rev UnknownHash subdir) >>= \case + (Just (DerivationSource{..}, genBindings)) -> genBindings derivHash + _ -> return [] + hits -> + forM hits $ \( pkg, nix ) -> do + return $ fromString pkg $= mkPath False nix + _ -> return [] + let flags = concatMap (\case + (name, Just (Package _v _r f _)) -> flags2nix name f + _ -> []) $ Map.toList extras + + return $ mkNonRecSet [ + "pkgs" $= ("hackage" ==> mkNonRecSet ( + [ "packages" $= (mkNonRecSet $ uncurry bind =<< Map.toList quotedPackages) + , "compiler" $= mkNonRecSet + [ "version" $= mkStr compilerVersion + , "nix-name" $= mkStr ("ghc" <> Text.filter (/= '.') compilerVersion) + , "packages" $= mkNonRecSet (fmap (uncurry bind') $ Map.toList $ mapKeys quoted compilerPackages) + ] + ])) + , "extras" $= ("hackage" ==> mkNonRecSet [ "packages" $= extrasNix ]) + , "modules" $= mkList [ + mkParamset [("lib", Nothing)] True ==> mkNonRecSet [ "packages" $= mkNonRecSet flags ] + ] + ] + where + quotedPackages = mapKeys quoted packages + bind pkg (Just (Package { packageVersion, packageRevision, packageFlags })) = + let verExpr = mkSym "hackage" @. pkg @. quoted packageVersion + revExpr = verExpr @. "revisions" @. maybe "default" quoted packageRevision + flagBindings = Map.foldrWithKey + (\fname val acc -> bindPath (pkg :| ["flags", fname]) (mkBool val) : acc) + [] + packageFlags + in revBinding pkg revExpr : flagBindings + bind pkg Nothing = [revBinding pkg mkNull] + revBinding pkg revExpr = bindPath (pkg :| ["revision"]) revExpr + bind' pkg ver = pkg $= maybe mkNull mkStr ver + mapKeys f = Map.fromList . fmap (\(k, v) -> (f k, v)) . Map.toList + + relPath = shortRelativePath (argOutputDir args) (dropFileName (argCabalProject args)) + cabalFromPath + :: String -- URL + -> String -- Revision + -> FilePath -- Subdir + -> FilePath -- Local Directory + -> MaybeT IO (String -> IO [Binding NExpr]) + cabalFromPath url rev subdir path = do + d <- liftIO $ doesDirectoryExist path + unless d $ fail ("not a directory: " ++ path) + cabalFiles <- liftIO $ findCabalFiles path + return $ \sha256 -> + forM cabalFiles $ \cabalFile -> do + let pkg = cabalFilePkgName cabalFile + nix = ".plan.nix" pkg <.> "nix" + nixFile = argOutputDir args nix + subdir' = if subdir == "." then Nothing + else Just subdir + src = Just $ C2N.Git url rev (Just sha256) subdir' + createDirectoryIfMissing True (takeDirectory nixFile) + writeDoc nixFile =<< + prettyNix <$> cabal2nix True (argDetailLevel args) src cabalFile + liftIO $ appendCache (argCacheFile args) url rev subdir sha256 pkg nix + return $ fromString pkg $= mkPath False nix + +-- | Converts the project flags for a package flags into @{ packageName = { flags = { flagA = BOOL; flagB = BOOL; }; }; }@ +flags2nix :: Text -> HashMap Text Bool -> [Binding NExpr] +flags2nix pkgName pkgFlags = + [ quoted pkgName $= mkNonRecSet + -- `mkOverride 900` is used here so that the default values will be replaced (they are 1000). + -- Values without a priority are treated as 100 and will replace these ones. + [ "flags" $= mkNonRecSet [ quoted flag $= ("lib" @. "mkOverride" @@ mkInt 900 @@ mkBool val) + | (flag, val) <- Map.toList pkgFlags + ] + ] + ] + +value2plan :: Value -> Plan +value2plan plan = Plan { packages, extras, compilerVersion, compilerPackages } + where + packages = fmap Just $ filterInstallPlan $ \pkg -> case ( pkg ^. key "type" . _String + , pkg ^. key "style" . _String) of + (_, "global") -> Just $ Package + { packageVersion = pkg ^. key "pkg-version" . _String + , packageRevision = Nothing + , packageFlags = Map.mapMaybe (^? _Bool) $ pkg ^. key "flags" . _Object + , packageSrc = Nothing + } + (_, "inplace") -> Just $ Package + { packageVersion = pkg ^. key "pkg-version" . _String + , packageRevision = Nothing + , packageFlags = Map.mapMaybe (^? _Bool) $ pkg ^. key "flags" . _Object + , packageSrc = Nothing + } + -- Until we figure out how to force Cabal to reconfigure just about any package + -- this here might be needed, so that we get the pre-existing packages as well. + -- Or we would have to plug in our very custom minimal pkg-db as well. + -- + -- The issue is that cabal claims anything in the package db as pre-existing and + -- wants to reuse it if possible. + ("pre-existing",_) -> Just $ Package + { packageVersion = pkg ^. key "pkg-version" . _String + , packageRevision = Nothing + , packageFlags = Map.empty + , packageSrc = Nothing + } + _ -> Nothing + + extras = fmap Just $ filterInstallPlan $ \pkg -> case ( pkg ^. key "type" . _String + , pkg ^. key "style" . _String + , pkg ^. key "pkg-src" . key "type" . _String + , pkg ^. key "pkg-src" . _Object) of + (_, "local", "local", _) -> Just $ Package + { packageVersion = pkg ^. key "pkg-version" . _String + , packageRevision = Nothing + , packageFlags = Map.mapMaybe (^? _Bool) $ pkg ^. key "flags" . _Object + , packageSrc = Just . LocalPath . Text.unpack $ pkg ^. key "pkg-src" . key "path" . _String + } + (_, "local", "source-repo", _) -> Just $ Package + { packageVersion = pkg ^. key "pkg-version" . _String + , packageRevision = Nothing + , packageFlags = Map.mapMaybe (^? _Bool) $ pkg ^. key "flags" . _Object + , packageSrc = Just . flip DVCS [ Text.unpack $ fromMaybe "." $ pkg ^? key "pkg-src" . key "source-repo" . key "subdir" . _String ] $ + Git ( Text.unpack $ pkg ^. key "pkg-src" . key "source-repo" . key "location" . _String ) + ( Text.unpack $ pkg ^. key "pkg-src" . key "source-repo" . key "tag" . _String ) + } + _ -> Nothing + + compilerVersion = Text.dropWhile (not . isDigit) $ plan ^. key "compiler-id" . _String + compilerPackages = fmap Just $ filterInstallPlan $ \pkg -> if isJust (pkg ^? key "style" . _String) + then Nothing + else Just $ pkg ^. key "pkg-version" . _String + + filterInstallPlan :: (Value -> Maybe b) -> HashMap Text b + filterInstallPlan f = + Map.fromList + $ mapMaybe (\pkg -> (,) (pkg ^. key "pkg-name" . _String) <$> f pkg) + $ Vector.toList (plan ^. key "install-plan" . _Array) + + +defaultNixContents = unlines $ + [ "{ pkgs ? import {} }:" + , "" + , "let" + , " haskell = import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz) { inherit pkgs; };" + , "" + , " pkgSet = haskell.mkCabalProjectPkgSet {" + , " plan-pkgs = import ./pkgs.nix;" + , " pkg-def-extras = [];" + , " modules = [];" + , " };" + , "" + , "in" + , " pkgSet.config.hsPkgs" + ] diff --git a/plan2nix/Plan2Nix/CLI.hs b/plan2nix/Plan2Nix/CLI.hs new file mode 100644 --- /dev/null +++ b/plan2nix/Plan2Nix/CLI.hs @@ -0,0 +1,34 @@ +module Plan2Nix.CLI + ( Args(..) + , parsePlan2NixArgs + ) where + +import Options.Applicative hiding (option) +import Data.Semigroup ((<>)) +import Cabal2Nix (CabalDetailLevel(..)) + +-------------------------------------------------------------------------------- +-- CLI Arguments +data Args = Args + { argOutputDir :: FilePath + , argPlanJSON :: FilePath + , argCabalProject :: FilePath + , argCacheFile :: FilePath + , argDetailLevel :: CabalDetailLevel + } deriving Show + +-- Argument Parser +args :: Parser Args +args = Args + <$> strOption ( long "output" <> short 'o' <> metavar "DIR" <> help "Generate output in DIR" ) + <*> strOption ( long "plan-json" <> value "dist-newstyle/cache/plan.json" <> showDefault <> metavar "FILE" <> help "Override plan.json location" ) + <*> strOption ( long "cabal-project" <> value "cabal.project" <> showDefault <> metavar "FILE" <> help "Override path to cabal.project" ) + <*> strOption ( long "cache" <> value ".nix-tools.cache" <> showDefault <> metavar "FILE" <> help "Dependency cache file" ) + <*> flag MinimalDetails FullDetails ( long "full" <> help "Output details needed to determine what files are used" ) + +parsePlan2NixArgs :: IO Args +parsePlan2NixArgs = execParser opts + where opts = info (args <**> helper) + ( fullDesc + <> progDesc "Generate a Nix expression for a Haskell package using Cabal" + <> header "plan-to-nix - a stack to nix converter" ) diff --git a/plan2nix/Plan2Nix/Cache.hs b/plan2nix/Plan2Nix/Cache.hs new file mode 100644 --- /dev/null +++ b/plan2nix/Plan2Nix/Cache.hs @@ -0,0 +1,36 @@ +-- Note: this is identical to Stack2nix.Cache +module Plan2Nix.Cache + ( readCache + , appendCache + , cacheHits + ) where + +import Control.Exception (catch, SomeException(..)) + +readCache :: FilePath + -> IO [( String -- url + , String -- rev + , String -- subdir + , String -- sha256 + , String -- pkgname + , String -- nixexpr-path + )] +readCache f = fmap (toTuple . words) . lines <$> readFile f + where toTuple [ url, rev, subdir, sha256, pkgname, exprPath ] + = ( url, rev, subdir, sha256, pkgname, exprPath ) + +appendCache :: FilePath -> String -> String -> String -> String -> String -> String -> IO () +appendCache f url rev subdir sha256 pkgname exprPath = do + appendFile f $ unwords [ url, rev, subdir, sha256, pkgname, exprPath ] + appendFile f "\n" + +cacheHits :: FilePath -> String -> String -> String -> IO [ (String, String) ] +cacheHits f url rev subdir + = do cache <- catch' (readCache f) (const (pure [])) + return [ ( pkgname, exprPath ) + | ( url', rev', subdir', sha256, pkgname, exprPath ) <- cache + , url == url' + , rev == rev' + , subdir == subdir' ] + where catch' :: IO a -> (SomeException -> IO a) -> IO a + catch' = catch diff --git a/plan2nix/Plan2Nix/Plan.hs b/plan2nix/Plan2Nix/Plan.hs new file mode 100644 --- /dev/null +++ b/plan2nix/Plan2Nix/Plan.hs @@ -0,0 +1,47 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Plan2Nix.Plan + ( Version + , Revision + , URL + , Rev + , Plan(..) + , PkgSrc(..) + , Package(..) + , Location(..) + ) where + + +import Data.Text ( Text ) +import Data.HashMap.Strict ( HashMap ) + +type Version = Text +type Revision = Text -- Can be: rNUM, cabal file sha256, or "default" +-- See stack2nix +type URL = String +type Rev = String + +data Location + = Git URL Rev + | HG URL Rev + deriving (Show) + +data Plan = Plan + { packages :: HashMap Text (Maybe Package) + , extras :: HashMap Text (Maybe Package) + , compilerVersion :: Text + , compilerPackages :: HashMap Text (Maybe Version) + } deriving (Show) + + +data PkgSrc + = LocalPath FilePath -- ^ some local package (potentially overriding a package in the index as well) + | DVCS Location [FilePath] -- ^ One or more packages fetched from git or similar + deriving Show + +data Package = Package + { packageVersion :: Version + , packageRevision :: Maybe Revision + , packageFlags :: HashMap Text Bool + , packageSrc :: Maybe PkgSrc + } deriving (Show) diff --git a/plan2nix/Plan2Nix/Project.hs b/plan2nix/Plan2Nix/Project.hs new file mode 100644 --- /dev/null +++ b/plan2nix/Plan2Nix/Project.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE LambdaCase #-} + +module Plan2Nix.Project + ( findCabalFiles + ) where + +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.ByteString (ByteString) + +import System.FilePath (()) +import System.Directory (listDirectory, doesFileExist) +import Data.List (isSuffixOf) + +import qualified Hpack +import qualified Hpack.Config as Hpack +import qualified Hpack.Render as Hpack + +import Cabal2Nix (CabalFile(..), CabalFileGenerator(..)) + +findCabalFiles :: FilePath -> IO [CabalFile] +findCabalFiles path = doesFileExist (path Hpack.packageConfig) >>= \case + False -> fmap (OnDisk . (path )) . filter (isSuffixOf ".cabal") <$> listDirectory path + True -> do + mbPkg <- Hpack.readPackageConfig Hpack.defaultDecodeOptions {Hpack.decodeOptionsTarget = path Hpack.packageConfig} + case mbPkg of + Left e -> error e + Right r -> + return $ [InMemory (Just Hpack) + (Hpack.decodeResultCabalFile r) + (encodeUtf8 $ Hpack.renderPackage [] (Hpack.decodeResultPackage r))] + + where encodeUtf8 :: String -> ByteString + encodeUtf8 = T.encodeUtf8 . T.pack diff --git a/stack2nix/Main.hs b/stack2nix/Main.hs new file mode 100644 --- /dev/null +++ b/stack2nix/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import Stack2nix (doStack2nix) +import Stack2nix.CLI (parseStack2nixArgs) + +main :: IO () +main = parseStack2nixArgs >>= doStack2nix diff --git a/stack2nix/Stack2nix.hs b/stack2nix/Stack2nix.hs new file mode 100644 --- /dev/null +++ b/stack2nix/Stack2nix.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE LambdaCase, RecordWildCards, OverloadedStrings #-} + +module Stack2nix + ( doStack2nix + , stackexpr + , stack2nix + ) where + +import qualified Data.Text as T +import Data.String (fromString) + +import Control.Monad.Trans.Maybe +import Control.Monad.IO.Class (liftIO) +import Control.Monad (unless, forM) +import Extra (unlessM) + +import System.FilePath ((<.>), (), takeDirectory, dropFileName) +import System.Directory (createDirectoryIfMissing, doesDirectoryExist, doesFileExist, getCurrentDirectory) +import System.IO (IOMode(..), openFile, hClose) +import Data.Yaml (decodeFileEither) + +import Nix.Expr +import Nix.Pretty (prettyNix) +import Data.Text.Prettyprint.Doc (Doc) +import Data.Text.Prettyprint.Doc.Render.Text (hPutDoc) + +import Distribution.Types.PackageId (PackageIdentifier(..)) +import Distribution.Nixpkgs.Fetch (DerivationSource(..), Source(..), Hash(..), fetch) +import Distribution.Simple.Utils (shortRelativePath) +import Distribution.Text (Text(..), simpleParse) + +import Cabal2Nix hiding (Git) +import qualified Cabal2Nix as C2N +import Cabal2Nix.Util + +import Stack2nix.Cache (appendCache, cacheHits) +import Stack2nix.CLI (Args(..)) +import Stack2nix.Project +import Stack2nix.Stack (Stack(..), Dependency(..), Location(..), PackageFlags, GhcOptions) +import Stack2nix.External.Resolve + +import qualified Data.HashMap.Strict as HM + + +doStack2nix :: Args -> IO () +doStack2nix args = do + let pkgsNix = argOutputDir args "pkgs.nix" + defaultNix = argOutputDir args "default.nix" + pkgs <- stackexpr args + writeDoc pkgsNix (prettyNix pkgs) + unlessM (doesFileExist defaultNix) $ do + writeFile defaultNix defaultNixContents + +stackexpr :: Args -> IO NExpr +stackexpr args = + do evalue <- decodeFileEither (argStackYaml args) + case evalue of + Left e -> error (show e) + Right value -> stack2nix args + =<< resolveSnapshot value + +stack2nix :: Args -> Stack -> IO NExpr +stack2nix args stack@(Stack resolver compiler pkgs pkgFlags ghcOpts) = + do let extraDeps = extraDeps2nix pkgs + flags = flags2nix pkgFlags + ghcOptions = ghcOptions2nix ghcOpts + let _f_ = mkSym "f" + _import_ = mkSym "import" + _mkForce_ = mkSym "mkForce" + _isFunction_ = mkSym "isFunction" + _mapAttrs_ = mkSym "mapAttrs" + _config_ = mkSym "config" + packages <- packages2nix args pkgs + return . mkNonRecSet $ + [ "extras" $= ("hackage" ==> mkNonRecSet + ([ "packages" $= mkNonRecSet (extraDeps <> packages) ] + ++ [ "compiler.version" $= fromString (quoted ver) + | (Just c) <- [compiler], let ver = filter (`elem` (".0123456789" :: [Char])) c] + ++ [ "compiler.nix-name" $= fromString (quoted name) + | (Just c) <- [compiler], let name = filter (`elem` ((['a'..'z']++['0'..'9']) :: [Char])) c])) + , "resolver" $= fromString (quoted resolver) + , "modules" $= mkList [ + mkParamset [("lib", Nothing)] True ==> mkNonRecSet [ "packages" $= mkNonRecSet flags ] + , mkNonRecSet [ "packages" $= mkNonRecSet ghcOptions ] ] + ] ++ [ + "compiler" $= fromString (quoted c) | (Just c) <- [compiler] + ] +-- | Transform simple package index expressions +-- The idea is to turn +-- +-- - name-version[@rev:N | @sha256:SHA] +-- +-- into +-- +-- { name.revision = hackage.name.version.revisions.default; } +-- +extraDeps2nix :: [Dependency] -> [Binding NExpr] +extraDeps2nix pkgs = + let extraDeps = [(pkgId, info) | PkgIndex pkgId info <- pkgs] + in [ (quoted (toText pkg)) $= (mkSym "hackage" @. toText pkg @. quoted (toText ver) @. "revisions" @. "default") + | (PackageIdentifier pkg ver, Nothing) <- extraDeps ] + ++ [ (quoted (toText pkg)) $= (mkSym "hackage" @. toText pkg @. quoted (toText ver) @. "revisions" @. quoted (T.pack sha)) + | (PackageIdentifier pkg ver, (Just (Left sha))) <- extraDeps ] + ++ [ (quoted (toText pkg)) $= (mkSym "hackage" @. toText pkg @. quoted (toText ver) @. "revisions" @. toText revNo) + | (PackageIdentifier pkg ver, (Just (Right revNo))) <- extraDeps ] + where parsePackageIdentifier :: String -> Maybe PackageIdentifier + parsePackageIdentifier = simpleParse + toText :: Text a => a -> T.Text + toText = fromString . show . disp + +-- | Converts 'PackageFlags' into @{ packageName = { flags = { flagA = BOOL; flagB = BOOL; }; }; }@ +flags2nix :: PackageFlags -> [Binding NExpr] +flags2nix pkgFlags = + [ quoted pkgName $= mkNonRecSet + -- `mkOverride 900` is used here so that the default values will be replaced (they are 1000). + -- Values without a priority are treated as 100 and will replace these ones. + [ "flags" $= mkNonRecSet [ quoted flag $= ("lib" @. "mkOverride" @@ mkInt 900 @@ mkBool val) + | (flag, val) <- HM.toList flags + ] + ] + | (pkgName, flags) <- HM.toList pkgFlags + ] + +-- | Converts 'GhcOptions' into @{ packageName = { ghcOptions = "..."; }; }@ +ghcOptions2nix :: GhcOptions -> [Binding NExpr] +ghcOptions2nix ghcOptions = + [ quoted pkgName $= mkNonRecSet + [ "package" $= mkNonRecSet [ "ghcOptions" $= mkStr opts ] ] + | (pkgName, opts) <- HM.toList ghcOptions + ] + +writeDoc :: FilePath -> Doc ann -> IO () +writeDoc file doc = + do handle <- openFile file WriteMode + hPutDoc handle doc + hClose handle + + +-- makeRelativeToCurrentDirectory +packages2nix :: Args -> [Dependency] -> IO [Binding NExpr] +packages2nix args pkgs = + do cwd <- getCurrentDirectory + fmap concat . forM pkgs $ \case + (LocalPath folder) -> + do cabalFiles <- findCabalFiles (argHpackUse args) (dropFileName (argStackYaml args) folder) + forM cabalFiles $ \cabalFile -> + let pkg = cabalFilePkgName cabalFile + nix = pkg <.> "nix" + nixFile = argOutputDir args nix + src = Just . C2N.Path $ relPath folder + in do createDirectoryIfMissing True (takeDirectory nixFile) + writeDoc nixFile =<< + prettyNix <$> cabal2nix True (argDetailLevel args) src cabalFile + return $ fromString pkg $= mkPath False nix + (DVCS (Git url rev) subdirs) -> + fmap concat . forM subdirs $ \subdir -> + do cacheHits <- liftIO $ cacheHits (argCacheFile args) url rev subdir + case cacheHits of + [] -> do + fetch (\dir -> cabalFromPath url rev subdir $ dir subdir) + (Source url rev UnknownHash subdir) >>= \case + (Just (DerivationSource{..}, genBindings)) -> genBindings derivHash + _ -> return [] + hits -> + forM hits $ \( pkg, nix ) -> do + return $ fromString pkg $= mkPath False nix + _ -> return [] + where relPath = shortRelativePath (argOutputDir args) (dropFileName (argStackYaml args)) + cabalFromPath + :: String -- URL + -> String -- Revision + -> FilePath -- Subdir + -> FilePath -- Local Directory + -> MaybeT IO (String -> IO [Binding NExpr]) + cabalFromPath url rev subdir path = do + d <- liftIO $ doesDirectoryExist path + unless d $ fail ("not a directory: " ++ path) + cabalFiles <- liftIO $ findCabalFiles (argHpackUse args) path + return $ \sha256 -> + forM cabalFiles $ \cabalFile -> do + let pkg = cabalFilePkgName cabalFile + nix = pkg <.> "nix" + nixFile = argOutputDir args nix + subdir' = if subdir == "." then Nothing + else Just subdir + src = Just $ C2N.Git url rev (Just sha256) subdir' + createDirectoryIfMissing True (takeDirectory nixFile) + writeDoc nixFile =<< + prettyNix <$> cabal2nix True (argDetailLevel args) src cabalFile + liftIO $ appendCache (argCacheFile args) url rev subdir sha256 pkg nix + return $ fromString pkg $= mkPath False nix + +defaultNixContents :: String +defaultNixContents = unlines + [ "{ pkgs ? import {} }:" + , "" + , "let" + , " haskell = import (builtins.fetchTarball https://github.com/input-output-hk/haskell.nix/archive/master.tar.gz) { inherit pkgs; };" + , "" + , " pkgSet = haskell.mkStackPkgSet {" + , " stack-pkgs = import ./pkgs.nix;" + , " pkg-def-extras = [];" + , " modules = [];" + , " };" + , "" + , "in" + , " pkgSet.config.hsPkgs" + ] diff --git a/stack2nix/Stack2nix/CLI.hs b/stack2nix/Stack2nix/CLI.hs new file mode 100644 --- /dev/null +++ b/stack2nix/Stack2nix/CLI.hs @@ -0,0 +1,40 @@ +module Stack2nix.CLI + ( Args(..) + , HpackUse(..) + , parseStack2nixArgs + ) where + +import Options.Applicative hiding (option) +import Data.Semigroup ((<>)) +import Cabal2Nix (CabalDetailLevel(..)) + +data HpackUse + = IgnorePackageYaml + | UsePackageYamlFirst + deriving Show + +-------------------------------------------------------------------------------- +-- CLI Arguments +data Args = Args + { argOutputDir :: FilePath + , argStackYaml :: FilePath + , argHpackUse :: HpackUse + , argCacheFile :: FilePath + , argDetailLevel :: CabalDetailLevel + } deriving Show + +-- Argument Parser +args :: Parser Args +args = Args + <$> strOption ( long "output" <> short 'o' <> metavar "DIR" <> help "Generate output in DIR" ) + <*> strOption ( long "stack-yaml" <> value "stack.yaml" <> showDefault <> metavar "FILE" <> help "Override project stack.yaml" ) + <*> flag UsePackageYamlFirst IgnorePackageYaml (long "ignore-package-yaml" <> help "disable hpack run and use only cabal disregarding package.yaml existence") + <*> strOption ( long "cache" <> value ".stack-to-nix.cache" <> showDefault <> metavar "FILE" <> help "Dependency cache file" ) + <*> flag MinimalDetails FullDetails ( long "full" <> help "Output details needed to determine what files are used" ) + +parseStack2nixArgs :: IO Args +parseStack2nixArgs = execParser opts + where opts = info (args <**> helper) + ( fullDesc + <> progDesc "Generate a Nix expression for a Haskell package using Stack" + <> header "stack-to-nix - a stack to nix converter" ) diff --git a/stack2nix/Stack2nix/Cache.hs b/stack2nix/Stack2nix/Cache.hs new file mode 100644 --- /dev/null +++ b/stack2nix/Stack2nix/Cache.hs @@ -0,0 +1,35 @@ +module Stack2nix.Cache + ( readCache + , appendCache + , cacheHits + ) where + +import Control.Exception (catch, SomeException(..)) + +readCache :: FilePath + -> IO [( String -- url + , String -- rev + , String -- subdir + , String -- sha256 + , String -- pkgname + , String -- nixexpr-path + )] +readCache f = fmap (toTuple . words) . lines <$> readFile f + where toTuple [ url, rev, subdir, sha256, pkgname, exprPath ] + = ( url, rev, subdir, sha256, pkgname, exprPath ) + +appendCache :: FilePath -> String -> String -> String -> String -> String -> String -> IO () +appendCache f url rev subdir sha256 pkgname exprPath = do + appendFile f $ unwords [ url, rev, subdir, sha256, pkgname, exprPath ] + appendFile f "\n" + +cacheHits :: FilePath -> String -> String -> String -> IO [ (String, String) ] +cacheHits f url rev subdir + = do cache <- catch' (readCache f) (const (pure [])) + return [ ( pkgname, exprPath ) + | ( url', rev', subdir', sha256, pkgname, exprPath ) <- cache + , url == url' + , rev == rev' + , subdir == subdir' ] + where catch' :: IO a -> (SomeException -> IO a) -> IO a + catch' = catch diff --git a/stack2nix/Stack2nix/External/Resolve.hs b/stack2nix/Stack2nix/External/Resolve.hs new file mode 100644 --- /dev/null +++ b/stack2nix/Stack2nix/External/Resolve.hs @@ -0,0 +1,48 @@ +module Stack2nix.External.Resolve + ( resolveSnapshot + ) where + +import Control.Monad (unless) +import Data.Aeson +import Data.Yaml hiding (Parser) +import Control.Applicative ((<|>)) +import Data.List (isPrefixOf, isSuffixOf) + +import qualified Data.ByteString.Lazy.Char8 as L8 + +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Network.HTTP.Types.Status (ok200) +import Control.Exception.Base (SomeException(..),PatternMatchFail(..)) + +import Stack2nix.Stack (Stack(..), StackSnapshot(..)) + +-- | A @resolver@ value in a stack.yaml file may point to an URL. As such +-- we need to be able to fetch one. +decodeURLEither :: FromJSON a => String -> IO (Either ParseException a) +decodeURLEither url + | not (("http://" `isPrefixOf` url) || ("https://" `isPrefixOf` url)) + = return . Left . OtherParseException . SomeException . PatternMatchFail $ "No http or https prefix" + | otherwise = do + manager <- newManager tlsManagerSettings + request <- parseRequest url + response <- httpLbs request manager + unless (ok200 == responseStatus response) $ error ("failed to download " ++ url) + return . decodeEither' . L8.toStrict $ responseBody response + + +-- | If a stack.yaml file contains a @resolver@ that points to +-- a file, resolve that file and merge the snapshot into the +-- @Stack@ record. +resolveSnapshot :: Stack -> IO Stack +resolveSnapshot stack@(Stack resolver compiler pkgs flags ghcOptions) + = if ".yaml" `isSuffixOf` resolver + then do evalue <- if ("http://" `isPrefixOf` resolver) || ("https://" `isPrefixOf` resolver) + then decodeURLEither resolver + else decodeFileEither resolver + case evalue of + Left e -> error (show e) + Right (Snapshot resolver' compiler' _name pkgs' flags' ghcOptions') -> + pure $ Stack resolver' (compiler' <|> compiler) (pkgs <> pkgs') (flags <> flags') + (ghcOptions <> ghcOptions') + else pure stack diff --git a/stack2nix/Stack2nix/Project.hs b/stack2nix/Stack2nix/Project.hs new file mode 100644 --- /dev/null +++ b/stack2nix/Stack2nix/Project.hs @@ -0,0 +1,39 @@ +{-# LANGUAGE LambdaCase #-} + +module Stack2nix.Project + ( findCabalFiles + ) where + +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.ByteString (ByteString) + +import System.FilePath (()) +import System.Directory (listDirectory, doesFileExist) +import Data.List (isSuffixOf) + +import qualified Hpack.Config as Hpack +import qualified Hpack.Render as Hpack + +import Cabal2Nix (CabalFile(..), CabalFileGenerator(..)) + +import Stack2nix.CLI (HpackUse(..)) + +findCabalFiles :: HpackUse -> FilePath -> IO [CabalFile] +findCabalFiles IgnorePackageYaml path = findOnlyCabalFiles path +findCabalFiles UsePackageYamlFirst path = doesFileExist (path Hpack.packageConfig) >>= \case + False -> findOnlyCabalFiles path + True -> do + mbPkg <- Hpack.readPackageConfig Hpack.defaultDecodeOptions {Hpack.decodeOptionsTarget = path Hpack.packageConfig} + case mbPkg of + Left e -> error e + Right r -> + return $ [InMemory (Just Hpack) + (Hpack.decodeResultCabalFile r) + (encodeUtf8 $ Hpack.renderPackage [] (Hpack.decodeResultPackage r))] + + where encodeUtf8 :: String -> ByteString + encodeUtf8 = T.encodeUtf8 . T.pack + +findOnlyCabalFiles :: FilePath -> IO [CabalFile] +findOnlyCabalFiles path = fmap (OnDisk . (path )) . filter (isSuffixOf ".cabal") <$> listDirectory path diff --git a/stack2nix/Stack2nix/Stack.hs b/stack2nix/Stack2nix/Stack.hs new file mode 100644 --- /dev/null +++ b/stack2nix/Stack2nix/Stack.hs @@ -0,0 +1,221 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Stack2nix.Stack + ( Resolver + , Name + , Compiler + , Sha256 + , CabalRev + , URL + , Rev + , Stack(..) + , Dependency(..) + , Location(..) + , StackSnapshot(..) + , PackageFlags + , GhcOptions + ) where + +import Data.Char (isDigit) +import Data.List (isSuffixOf) +import qualified Data.Text as T +import Data.Aeson +import Control.Applicative ((<|>)) +import Data.Monoid (mempty) + +import Distribution.Types.PackageName +import Distribution.Types.PackageId +import Distribution.Compat.ReadP hiding (Parser) +import Distribution.Text +import Distribution.Types.Version (nullVersion) + +import qualified Data.HashMap.Strict as HM + +-------------------------------------------------------------------------------- +-- The stack.yaml file +-------------------------------------------------------------------------------- + +-------------------------------------------------------------------------------- +-- packages +-- +-- * (1) Paths +-- - ./site1 +-- - ./site2 +-- * (2) Git Locations +-- - location: +-- git: https://github.com/yesodweb/yesod +-- commit: 7038ae6317cb3fe4853597633ba7a40804ca9a46 +-- extra-dep: true +-- subdirs: +-- - yesod-core +-- - yesod-bin + +-------------------------------------------------------------------------------- +-- extra-deps +-- +-- * (1) Package index (optional sha of cabal files contents; or revision number) +-- - acme-missiles-0.3 +-- - acme-missiles-0.3@sha256:2ba66a092a32593880a87fb00f3213762d7bca65a687d45965778deb8694c5d1 +-- - acme-missiles-0.3@rev:0 +-- +-- * (2) Local File Path (foo-1.2.3 would be parsed as a package index) +-- - vendor/somelib +-- - ./foo-1.2.3 +-- +-- * (3) Git and Mercurial repos (optional subdirs; or github) +-- - git: git@github.com:commercialhaskell/stack.git +-- commit: 6a86ee32e5b869a877151f74064572225e1a0398 +-- - git: git@github.com:snoyberg/http-client.git +-- commit: "a5f4f3" +-- - hg: https://example.com/hg/repo +-- commit: da39a3ee5e6b4b0d3255bfef95601890afd80709 +-- - git: git@github.com:yesodweb/wai +-- commit: 2f8a8e1b771829f4a8a77c0111352ce45a14c30f +-- subdirs: +-- - auto-update +-- - wai +-- - github: snoyberg/http-client +-- commit: a5f4f30f01366738f913968163d856366d7e0342 +-- +-- * (4) Archives (HTTP(S) or local filepath) +-- - https://example.com/foo/bar/baz-0.0.2.tar.gz +-- - archive: http://github.com/yesodweb/wai/archive/2f8a8e1b771829f4a8a77c0111352ce45a14c30f.zip +-- subdirs: +-- - wai +-- - warp +-- - archive: ../acme-missiles-0.3.tar.gz +-- sha256: e563d8b524017a06b32768c4db8eff1f822f3fb22a90320b7e414402647b735b + +-- NOTE: We will only parse a suitable subset of the stack.yaml file. + +-------------------------------------------------------------------------------- +-- Some generic types +type Resolver = String +type Name = String +type Compiler = String +type Sha256 = String +newtype CabalRev = CabalRev Int -- cabal revision 0,1,2,... + deriving (Show) +type URL = String -- Git/Hg/... URL +type Rev = String -- Git revision + +instance Text CabalRev where + disp (CabalRev rev) = "r" <> disp rev + parse = char 'r' *> (CabalRev <$> parse) + +-------------------------------------------------------------------------------- +-- Data Types +-- Dependencies are the merged set of packages and extra-deps. +-- As we do not distinguish them in the same way stack does, we +-- can get away with this. +data Dependency + = PkgIndex PackageIdentifier (Maybe (Either Sha256 CabalRev)) -- ^ overridden package in the stackage index + | LocalPath String -- ^ Some local package (potentially overriding a package in the index as well) + | DVCS Location [FilePath] -- ^ One or more packages fetched from git or similar. + -- TODO: Support archives. + -- | Archive ... + deriving (Show) + +-- flags are { pkg -> { flag -> bool } } +type PackageFlags = HM.HashMap T.Text (HM.HashMap T.Text Bool) + +type GhcOptions = HM.HashMap T.Text T.Text + +data Stack + = Stack Resolver (Maybe Compiler) [Dependency] PackageFlags GhcOptions + deriving (Show) + +-- stack supports custom snapshots +-- https://docs.haskellstack.org/en/stable/custom_snapshot/ +data StackSnapshot + = Snapshot + Resolver -- lts-XX.YY/nightly-... + (Maybe Compiler) -- possible compiler override for the snapshot + Name -- name + [Dependency] -- packages + PackageFlags -- flags + -- [PackageName] -- drop-packages + -- [PackageName -> Bool] -- hidden + GhcOptions -- ghc-options + deriving (Show) + +data Location + = Git URL Rev + | HG URL Rev + deriving (Show) + +-------------------------------------------------------------------------------- +-- Parsers for package indices +sha256Suffix :: ReadP r Sha256 +sha256Suffix = string "@sha256:" *> many1 (satisfy (`elem` (['0'..'9']++['a'..'z']++['A'..'Z']))) + -- Stack supports optional cabal file size after revision's SHA value, + -- we parse it but it doesn't get used + <* optional (char ',' <* many1 (satisfy isDigit)) + +revSuffix :: ReadP r CabalRev +revSuffix = string "@rev:" *> (CabalRev . read <$> many1 (satisfy (`elem` ['0'..'9']))) + +suffix :: ReadP r (Maybe (Either Sha256 CabalRev)) +suffix = option Nothing (Just <$> (Left <$> sha256Suffix) +++ (Right <$> revSuffix)) + +pkgIndex :: ReadP r Dependency +pkgIndex = PkgIndex <$> parse <*> suffix <* eof + +-------------------------------------------------------------------------------- +-- JSON/YAML destructors + +instance FromJSON Location where + parseJSON = withObject "Location" $ \l -> + parseGitHub l <|> parseGit l + where + parseGit l = Git + <$> l .: "git" + <*> l .: "commit" + parseGitHub l = Git + <$> do gitHubUrl <$> l .: "github" + <*> l .: "commit" + gitHubUrl ownerRepo = + "https://github.com/" <> ownerRepo <> ".git" + +instance FromJSON Stack where + parseJSON = withObject "Stack" $ \s -> Stack + <$> s .: "resolver" + <*> s .:? "compiler" .!= Nothing + <*> ((<>) <$> s .:? "packages" .!= [LocalPath "."] + <*> s .:? "extra-deps" .!= []) + <*> s .:? "flags" .!= mempty + <*> s .:? "ghc-options" .!= mempty + +instance FromJSON StackSnapshot where + parseJSON = withObject "Snapshot" $ \s -> Snapshot + <$> s .: "resolver" + <*> s .:? "compiler" .!= Nothing + <*> s .: "name" + <*> s .:? "packages" .!= [] + <*> s .:? "flags" .!= mempty + <*> s .:? "ghc-options" .!= mempty + +instance FromJSON Dependency where + -- Note: we will parse foo-X.Y.Z as a package. + -- if we want it to be a localPath, it needs + -- to be ./foo-X.Y.Z + parseJSON p = parsePkgIndex p <|> parseLocalPath p <|> parseDVCS p + where parsePkgIndex = withText "Package Index" $ \pi -> + case [pi' | (pi',"") <- readP_to_S pkgIndex (T.unpack pi)] of + -- Cabal will happily parse "foo" as a packageIdentifier, + -- we however are only interested in those that have a version + -- as well. Any valid version is larger than @nullVersion@, as + -- such we can use that as a filter. + [pi'@(PkgIndex pkgIdent _)] | pkgVersion pkgIdent > nullVersion -> return $ pi' + _ -> fail $ "invalid package index: " ++ show pi + parseLocalPath = withText "Local Path" $ + return . LocalPath . dropTrailingSlash . T.unpack + parseDVCS = withObject "DVCS" $ \o -> DVCS + <$> (o .: "location" <|> parseJSON p) + <*> o .:? "subdirs" .!= ["."] + + -- drop trailing slashes. Nix doesn't like them much; + -- stack doesn't seem to care. + dropTrailingSlash p | "/" `isSuffixOf` p = take (length p - 1) p + dropTrailingSlash p = p diff --git a/truncate-index/Main.hs b/truncate-index/Main.hs new file mode 100644 --- /dev/null +++ b/truncate-index/Main.hs @@ -0,0 +1,63 @@ +-- I am a sinner! +{-# language RecordWildCards #-} + +module Main (main) where + +import Data.Maybe +import Data.Time.Clock +import Data.Time.Format +import Data.Time.Clock.POSIX +import Codec.Archive.Tar as Tar +import Codec.Archive.Tar.Entry as Tar +import Data.ByteString.Lazy as BS hiding (filter) +import Codec.Compression.GZip as GZip + +import Options.Applicative hiding (option) +import Data.Semigroup ((<>)) + +-- | Parse a hackage index state like "2019-01-01T12:00:00Z" +parseIndexState :: String -> Maybe UTCTime +parseIndexState = parseTimeM True defaultTimeLocale (iso8601DateFormat (Just "%T%Z")) + +-- | Convert the standard 'UTCTime' type into the 'EpochTime' used by the @tar@ +-- library. +toEpochTime :: UTCTime -> EpochTime +toEpochTime = floor . utcTimeToPOSIXSeconds + +-- | Filter Haskell Index +filterHaskellIndex :: FilePath -> String -> FilePath -> IO () +filterHaskellIndex orig indexState out = + BS.writeFile out . nukeHeaderOS . GZip.compress . Tar.write . f . Tar.read . GZip.decompress =<< BS.readFile orig + where f = filter ((<= ts) . Tar.entryTime) . toList + ts = toEpochTime . fromJust . parseIndexState $ indexState + -- gzip headers containt he OS, but we want a stable hash. + -- 0xff is unknown OS. http://www.zlib.org/rfc-gzip.html + nukeHeaderOS :: BS.ByteString -> BS.ByteString + nukeHeaderOS bs = BS.take 9 bs <> BS.singleton 0xff <> BS.drop 10 bs + +-- | Convert @Entries e@ to a list while throwing an error on failure. +toList :: Show e => Entries e -> [Entry] +toList (Next e es) = e:(toList es) +toList Done = [] +toList (Fail e) = error (show e) + +-------------------------------------------------------------------------------- +-- CLI Argument +data Args = Args + { argOutput :: FilePath + , argInput :: FilePath + , argIndexState :: String + } deriving Show + +args :: Parser Args +args = Args + <$> strOption ( long "output" <> short 'o' <> value "00-index.tar.gz" <> showDefault <> metavar "FILE" <> help "The output index" ) + <*> strOption ( long "input" <> short 'i' <> value "01-index.tar.gz" <> showDefault <> metavar "FILE" <> help "The input index" ) + <*> strOption ( long "indexState" <> short 's' <> metavar "INDEX" <> help "Index State ( YYYY-MM-DDTHH:MM:SSZ )" ) + +main :: IO () +main = execParser opts >>= \Args{..} -> filterHaskellIndex argInput argIndexState argOutput + where opts = info (args <**> helper) + ( fullDesc + <> progDesc "Generate a truncated Hackage index" + <> header "truncate-index - a hackage index truncater" )