diff --git a/exe/Main.hs b/exe/Main.hs new file mode 100644 --- /dev/null +++ b/exe/Main.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Monad.Extra (ifM) +import qualified Data.ByteString as BS +import qualified Data.List.NonEmpty as NEL +import Data.Text.Encoding (encodeUtf8) +import Distribution.Types.PackageName (mkPackageName) +import qualified Options.Applicative as Opts +import StackageToHackage.Hackage (printFreeze, printProject, + stackToCabal) +import StackageToHackage.Stackage (localDirs, readStack) +import System.Directory (doesDirectoryExist, + listDirectory) +import System.FilePath (takeBaseName, takeDirectory, + takeExtension, ()) + +main :: IO () +main = do + Options{input} <- Opts.execParser $ + Opts.info (Opts.helper <*> optionsParser) Opts.fullDesc + stack <- readStack =<< BS.readFile input + let dir = (takeDirectory input) + subs = NEL.toList $ (dir ) <$> localDirs stack + cabals <- concat <$> traverse (globExt ".cabal") subs + -- assumes that .cabal files are named correctly, otherwise we need + -- PackageDescription-Parsec.html#v:readGenericPackageDescription + let ignore = (mkPackageName . takeBaseName) <$> cabals + (project, freeze) <- stackToCabal ignore dir stack + BS.writeFile (dir "cabal.project") (encodeUtf8 $ printProject project) + BS.writeFile (dir "cabal.project.freeze") (encodeUtf8 $ printFreeze freeze) + +globExt :: String -> FilePath -> IO [FilePath] +globExt ext path = do + files <- ifM (doesDirectoryExist path) (listDirectory path) (pure []) + pure $ filter ((ext ==) . takeExtension) files + +data Options = Options + { input :: FilePath + } +optionsParser :: Opts.Parser Options +optionsParser = Options + <$> file + where + file = Opts.strArgument + ( Opts.metavar "FILENAME" + <> Opts.help "Input stack.yaml") diff --git a/lib/StackageToHackage/Hackage.hs b/lib/StackageToHackage/Hackage.hs new file mode 100644 --- /dev/null +++ b/lib/StackageToHackage/Hackage.hs @@ -0,0 +1,99 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +-- | A simplistic model of cabal multi-package files and convertors from Stackage. +module StackageToHackage.Hackage + ( stackToCabal + , Project(..), printProject + , Freeze(..), printFreeze + ) where + +import Data.List (sort) +import Data.List.Extra (nubOn) +import Data.List.NonEmpty (NonEmpty) +import qualified Data.List.NonEmpty as NEL +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe, mapMaybe) +import Data.Semigroup (sconcat) +import Data.Text (Text) +import qualified Data.Text as T +import Distribution.Pretty (prettyShow) +import Distribution.Types.PackageId (PackageIdentifier (..)) +import Distribution.Types.PackageName (PackageName, unPackageName) +import StackageToHackage.Stackage +import System.FilePath (addTrailingPathSeparator) + +-- | Converts a stack.yaml (and list of local packages) to cabal.project and +-- cabal.project.freeze. +stackToCabal :: [PackageName] -> FilePath -> Stack -> IO (Project, Freeze) +stackToCabal ignore dir stack = do + resolvers <- unroll dir stack + let resolver = sconcat resolvers + project = genProject stack resolver + freeze = genFreeze resolver ignore + pure (project, freeze) + +-- TODO: something like stackToCabal that puts constraints into .cabal files + +printProject :: Project -> Text +printProject (Project (Ghc ghc) pkgs srcs) = + T.concat [ "-- Generated by stackage-to-hackage\n\n" + , "with-compiler: ", ghc, "\n\n" + , "packages:\n ", packages, "\n\n" + , sources, "\n" + , "allow-older: *\n" + , "allow-newer: *\n" + ] + where + packages = T.intercalate "\n , " (T.pack . addTrailingPathSeparator <$> + NEL.toList pkgs) + sources = T.intercalate "\n" (source =<< srcs) + source Git{repo, commit, subdirs} = + let base = T.concat [ "source-repository-package\n " + , "type: git\n " + , "location: ", repo, "\n " + , "tag: ", commit, "\n"] + in if null subdirs + then [base] + else (\d -> T.concat [base, " subdir: ", d, "\n"]) <$> subdirs + +data Project = Project Ghc (NonEmpty FilePath) [Git] deriving (Show) + +genProject :: Stack -> Resolver -> Project +genProject stack Resolver{compiler, deps} = Project + (fromMaybe (Ghc "ghc") compiler) + (localDirs stack) + (nubOn repo $ mapMaybe pickGit deps) + where + pickGit (Hackage _ ) = Nothing + pickGit (SourceDep g) = Just g + +printFreeze :: Freeze -> Text +printFreeze (Freeze deps (Flags flags)) = + T.concat [ "constraints:\n ", constraints, "\n"] + where + constraints = T.intercalate "\n , " (constrait <$> sort deps) + constrait pkg = + let name = (T.pack . unPackageName . pkgName $ pkg) + ver = (T.pack . prettyShow . pkgVersion $ pkg) + base = T.concat [name, " ==", ver] + in case M.lookup name flags of + Nothing -> base + Just entries -> T.concat [ name, " ", (custom entries) + , "\n , ", base] + custom (M.toList -> lst) = T.intercalate " " $ (renderFlag <$> lst) + renderFlag (name, True) = "+" <> name + renderFlag (name, False) = "-" <> name + +data Freeze = Freeze [PackageIdentifier] Flags deriving (Show) + +genFreeze :: Resolver -> [PackageName] -> Freeze +genFreeze Resolver{deps, flags} ignore = + let pkgs = filter noSelfs $ unPkgId <$> mapMaybe pick deps + uniqpkgs = nubOn pkgName pkgs + in Freeze uniqpkgs flags + where pick (Hackage p) = Just p + pick (SourceDep _) = Nothing + noSelfs (pkgName -> n) = notElem n ignore diff --git a/lib/StackageToHackage/Stackage.hs b/lib/StackageToHackage/Stackage.hs new file mode 100644 --- /dev/null +++ b/lib/StackageToHackage/Stackage.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Duplicates a subset of the Stack ADT. It'd be nice if we could just re-use +-- the actual ADT, but stack isn't available as a library that we can build from +-- Hackage. +module StackageToHackage.Stackage where + +import Control.Applicative (Alternative, empty, (<|>)) +import Control.Monad.Extra (loopM, unlessM) +import qualified Data.ByteString as BS +import Data.ByteString.Lazy (toStrict) +import Data.List.NonEmpty (NonEmpty (..), head, nonEmpty, + reverse, (<|)) +import Data.Map.Strict (Map) +import qualified Data.Map.Strict as M +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Data.Text (Text, isSuffixOf, replace, + takeWhile, unpack) +import Data.YAML (FromYAML, decodeStrict, + parseYAML, withMap, withStr, + (.!=), (.:), (.:?)) +import Distribution.Text (simpleParse) +import Distribution.Types.PackageId (PackageIdentifier (..)) +import Network.HTTP.Client (httpLbs, parseRequest, + responseBody) +import Network.HTTP.Client.TLS (getGlobalManager) +import Prelude hiding (head, reverse, takeWhile) +import System.Directory (XdgDirectory (..), + createDirectoryIfMissing, + doesFileExist, getXdgDirectory) +import System.FilePath (takeDirectory, ()) + +data Stack = Stack + { resolver :: ResolverRef + , compiler :: Maybe Ghc + , packages :: [Package] + , extraDeps :: [Dep] + , flags :: Flags + -- TODO ghcOptions + } deriving (Show) + +localDirs :: Stack -> NonEmpty FilePath +localDirs Stack{packages} = + fromMaybe (pure ".") $ nonEmpty $ mapMaybe locals packages + where + locals (Local p) = Just p + locals (Location _) = Nothing + +newtype Ghc = Ghc Text + deriving (Show) + deriving newtype (FromYAML) + +data Package = Local FilePath + | Location Git + deriving (Show) + +data Git = Git + { repo :: Repo + , commit :: Commit + , subdirs :: [Subdir] + } deriving (Show) +type Repo = Text +type Commit = Text +type Subdir = Text + +data Resolver = Resolver + { resolver :: Maybe ResolverRef + , compiler :: Maybe Ghc + , deps :: [Dep] + , flags :: Flags + } deriving (Show) +instance Semigroup Resolver where + (Resolver r c p f) <> (Resolver r' c' p' f') = + Resolver (r <|> r') (c <|> c') (p <> p') (f <> f') + +-- TODO: remote ResolverRefs +data ResolverRef = Canned Text + | Snapshot Text + deriving (Show) + +-- http://hackage.haskell.org/package/Cabal-2.4.1.0/docs/Distribution-Types-PackageId.html#t:PackageIdentifier +-- http://hackage.haskell.org/package/Cabal-2.4.1.0/docs/Distribution-Parsec-Class.html#v:simpleParsec + +data Dep = Hackage PkgId + | SourceDep Git + deriving (Show) + +newtype Flags = Flags (Map PkgName (Map FlagName Bool)) + deriving (Show) + deriving newtype (FromYAML, Semigroup) + +type PkgName = Text +type FlagName = Text + +-- the format used at https://github.com/commercialhaskell/stackage-snapshots +-- which is similar to the Resolver format. +data NewResolver = NewResolver + { compiler :: Ghc + , packages :: [NewDep] + , flags :: Flags + } deriving (Show) + +data NewDep = NewDep PkgId + deriving (Show) + +-------------------------------------------------------------------------------- +-- Resolvers + +readStack :: BS.ByteString -> IO Stack +readStack text = either fail pure $ decode1Strict text + +type RelativeResolvers = NonEmpty (Maybe FilePath, Resolver) +type Resolvers = NonEmpty Resolver + +-- highest priority resolver first +unroll :: FilePath -> Stack -> IO Resolvers +unroll base stack = do + let stack' = stack2resolver stack + reverse <$> (loopM next (pure (Just base, stack'))) + where + -- lowest priority (deepest) resolver first + next :: RelativeResolvers -> IO (Either RelativeResolvers Resolvers) + next rs = case head rs of + (_, Resolver Nothing _ _ _) -> pure $ Right (snd <$> rs) + (dir, Resolver (Just r) _ _ _) -> (Left . (<| rs)) <$> resolve dir r + +-- if the Resolver is a local snapshot, also include its dir +resolve :: Maybe FilePath -> ResolverRef -> IO (Maybe FilePath, Resolver) +resolve _ (Canned lts) = do + cached <- cache lts + text <- (BS.readFile cached) <|> download + update cached text + either fail (\r -> pure (Nothing, r)) $ new2old <$> (decode1Strict $ text) + where + download = + let path = unpack $ replace "." "/" (replace "-" "/" lts) + raw = concat ["https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/", path, ".yaml"] + in do + manager <- getGlobalManager + url <- parseRequest raw + putStrLn ("Downloading: " <> raw) + resp <- httpLbs url manager + pure $ toStrict $ responseBody resp + + update file content = unlessM (doesFileExist file) (BS.writeFile file content) + +resolve (Just base) (Snapshot path) = do + let file = base (unpack path) + dir = takeDirectory file + text <- BS.readFile file + either fail (\r -> pure (Just dir, r)) $ decode1Strict text + +resolve Nothing _ = fail "Remote snapshots can't use relative paths." + +cache :: Text -> IO FilePath +cache file = do + dir <- getXdgDirectory XdgCache "stackage" + createDirectoryIfMissing True dir + pure $ dir (unpack file) + +stack2resolver :: Stack -> Resolver +stack2resolver Stack{resolver, compiler, packages, extraDeps, flags} = + Resolver (Just resolver) compiler (sourcedeps <> extraDeps) flags + where sourcedeps = mapMaybe pick packages + pick (Local _) = Nothing + pick (Location g) = Just . SourceDep $ g + +new2old :: NewResolver -> Resolver +new2old NewResolver{compiler, packages, flags} = + Resolver Nothing (Just compiler) (new2old' <$> packages) flags + where + new2old' (NewDep pkg) = Hackage pkg + +-------------------------------------------------------------------------------- +-- YAML boilerplate + +-- https://github.com/haskell-hvr/HsYAML/pull/5 +decode1Strict :: FromYAML a => BS.ByteString -> Either String a +decode1Strict text = do + as <- decodeStrict text + maybe (Left "expected unique") Right $ listToMaybe as + +instance FromYAML Stack where + parseYAML = withMap "Stack" $ \m -> Stack + <$> m .: "resolver" + <*> m .:? "compiler" + <*> m .:? "packages" .!= mempty + <*> m .:? "extra-deps" .!= mempty + <*> m .:? "flags" .!= (Flags M.empty) + +instance FromYAML Git where + parseYAML = withMap "Git" $ \m -> Git + <$> m .: "git" + <*> m .: "commit" + <*> m .:? "subdirs" .!= [] + +instance FromYAML ResolverRef where + parseYAML = withStr "ResolverRef" $ \s -> + if isSuffixOf ".yaml" s + then (pure . Snapshot) s + else (pure . Canned) s + +instance FromYAML Package where + parseYAML n = (local n) <|> (location n) + where + local = withStr "Local" $ pure . Local . unpack + location = withMap "Location" $ \m -> + Location <$> m .: "location" + +instance FromYAML Dep where + parseYAML n = hackage <|> source + where + hackage = Hackage <$> parseYAML n + source = SourceDep <$> parseYAML n + +instance FromYAML Resolver where + parseYAML = withMap "Resolver" $ \m -> Resolver + <$> m .:? "resolver" + <*> m .:? "compiler" + <*> m .:? "packages" .!= mempty + <*> m .:? "flags" .!= (Flags M.empty) + +instance FromYAML NewDep where + parseYAML = withMap "NewDep" $ \m -> hackage' =<< m .: "hackage" + where + hackage' n = NewDep <$> parseYAML n + +instance FromYAML NewResolver where + parseYAML = withMap "NewResolver" $ \m -> NewResolver + <$> m .: "compiler" + <*> m .:? "packages" .!= mempty + <*> m .:? "flags" .!= (Flags M.empty) + +newtype PkgId = PkgId { unPkgId :: PackageIdentifier } deriving (Show) +instance FromYAML PkgId where + parseYAML = withStr "PackageIdentifier" $ \s -> + PkgId <$> (hoistMaybe . simpleParse . unpack) (takeWhile ('@' /=) s) + +hoistMaybe :: Alternative m => Maybe a -> m a +hoistMaybe = maybe empty pure diff --git a/src/Main.hs b/src/Main.hs deleted file mode 100644 --- a/src/Main.hs +++ /dev/null @@ -1,133 +0,0 @@ -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -import Control.Monad.Extra (ifM) -import qualified Data.ByteString as BS -import Data.List (sort) -import Data.List.Extra (nubOn) -import Data.List.NonEmpty (NonEmpty, nonEmpty) -import qualified Data.List.NonEmpty as NEL -import qualified Data.Map.Strict as M -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Semigroup.Foldable (fold1) -import Data.Text (Text) -import qualified Data.Text as T -import Data.Text.Encoding (encodeUtf8) -import Distribution.Pretty (prettyShow) -import Distribution.Types.PackageId (PackageIdentifier (..)) -import Distribution.Types.PackageName (PackageName, mkPackageName, - unPackageName) -import OpenSSL (withOpenSSL) -import qualified Options.Applicative as Opts -import Stackage -import System.Directory (doesDirectoryExist, - listDirectory) -import System.FilePath (addTrailingPathSeparator, - takeBaseName, takeDirectory, - takeExtension, ()) - -main :: IO () -main = withOpenSSL $ do - Options{input} <- Opts.execParser $ - Opts.info (Opts.helper <*> optionsParser) Opts.fullDesc - text <- BS.readFile input - stack <- readStack text - let - dir = (takeDirectory input) - resolvers <- unroll dir stack - let - resolver = fold1 resolvers - project = genProject stack resolver - dirs = NEL.toList $ (dir ) <$> localDirs project - cabals <- concat <$> traverse (globExt ".cabal") dirs - let - -- assumes that .cabal files are named correctly, otherwise we need - -- PackageDescription-Parsec.html#v:readGenericPackageDescription - ignore = (mkPackageName . takeBaseName) <$> cabals - freeze = genFreeze resolver ignore - BS.writeFile (dir "cabal.project") (encodeUtf8 $ printProject project) - BS.writeFile (dir "cabal.project.freeze") (encodeUtf8 $ printFreeze freeze) - -globExt :: String -> FilePath -> IO [FilePath] -globExt ext path = do - files <- ifM (doesDirectoryExist path) (listDirectory path) (pure []) - pure $ filter ((ext ==) . takeExtension) files - -printProject :: Project -> Text -printProject (Project (Ghc ghc) pkgs srcs) = - T.concat [ "-- Generated by stackage-to-hackage from stack.yaml\n\n" - , "with-compiler: ", ghc, "\n\n" - , "packages:\n ", packages, "\n\n" - , sources, "\n" - , "allow-older: *\n" - , "allow-newer: *\n" - ] - where - packages = T.intercalate "\n , " (T.pack . addTrailingPathSeparator <$> - NEL.toList pkgs) - sources = T.intercalate "\n" (source =<< srcs) - source Git{repo, commit, subdirs} = - let base = T.concat [ "source-repository-package\n " - , "type: git\n " - , "location: ", repo, "\n " - , "tag: ", commit, "\n"] - in if null subdirs - then [base] - else (\d -> T.concat [base, " subdir: ", d, "\n"]) <$> subdirs - -data Project = Project Ghc (NonEmpty FilePath) [Git] deriving (Show) - -localDirs :: Project -> NonEmpty FilePath -localDirs (Project _ nefp _ ) = nefp - -genProject :: Stack -> Resolver -> Project -genProject Stack{packages} Resolver{compiler, deps} = Project - (fromMaybe (Ghc "ghc") compiler) - (fromMaybe (pure ".") (nonEmpty $ mapMaybe pickLocal packages)) - (nubOn repo $ mapMaybe pickGit deps) - where - pickLocal (Local p) = Just p - pickLocal (Location _) = Nothing - pickGit (Hackage _ ) = Nothing - pickGit (SourceDep g) = Just g - -printFreeze :: Freeze -> Text -printFreeze (Freeze deps (Flags flags)) = - T.concat [ "constraints:\n ", constraints, "\n"] - where - constraints = T.intercalate "\n , " (constrait <$> sort deps) - constrait pkg = - let name = (T.pack . unPackageName . pkgName $ pkg) - ver = (T.pack . prettyShow . pkgVersion $ pkg) - base = T.concat [name, " ==", ver] - in case M.lookup name flags of - Nothing -> base - Just entries -> T.concat [ name, " ", (custom entries) - , "\n , ", base] - custom (M.toList -> lst) = T.intercalate " " $ (renderFlag <$> lst) - renderFlag (name, True) = "+" <> name - renderFlag (name, False) = "-" <> name - -data Freeze = Freeze [PackageIdentifier] Flags deriving (Show) - -genFreeze :: Resolver -> [PackageName] -> Freeze -genFreeze Resolver{deps, flags} ignore = - let pkgs = filter noSelfs $ unPkgId <$> mapMaybe pick deps - uniqpkgs = nubOn pkgName pkgs - in Freeze uniqpkgs flags - where pick (Hackage p) = Just p - pick (SourceDep _) = Nothing - noSelfs (pkgName -> n) = notElem n ignore - -data Options = Options - { input :: FilePath - } -optionsParser :: Opts.Parser Options -optionsParser = Options - <$> file - where - file = Opts.strArgument - ( Opts.metavar "FILENAME" - <> Opts.help "Input stack.yaml") diff --git a/src/Stackage.hs b/src/Stackage.hs deleted file mode 100644 --- a/src/Stackage.hs +++ /dev/null @@ -1,232 +0,0 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE OverloadedStrings #-} - --- Duplicates a subset of the Stack ADT. It'd be nice if we could just re-use --- the actual ADT, but stack isn't available as a library that we can build from --- Hackage. -module Stackage where - -import Control.Applicative ((<|>)) -import Control.Monad.Extra (loopM, unlessM) -import qualified Data.ByteString as BS -import Data.ByteString.Char8 (pack) -import Data.List.NonEmpty (NonEmpty (..), head, reverse, - (<|)) -import Data.Map.Strict (Map, empty) -import Data.Maybe (listToMaybe, mapMaybe) -import Data.Text (Text, concat, isSuffixOf, - replace, takeWhile, unpack) -import Data.YAML (FromYAML, decodeStrict, - parseYAML, withMap, withStr, - (.!=), (.:), (.:?)) -import Distribution.Text (simpleParse) -import Distribution.Types.PackageId (PackageIdentifier (..)) -import qualified Network.Http.Client as Http -import Network.URI (parseURI) -import Options.Applicative.Internal (hoistMaybe) -import Prelude hiding (concat, head, reverse, - takeWhile) -import System.Directory (XdgDirectory (..), - createDirectoryIfMissing, - doesFileExist, getXdgDirectory) -import System.FilePath (takeDirectory, ()) - -data Stack = Stack - { resolver :: ResolverRef - , compiler :: Maybe Ghc - , packages :: [Package] - , extraDeps :: [Dep] - , flags :: Flags - -- TODO ghcOptions - } deriving (Show) - -newtype Ghc = Ghc Text - deriving (Show) - deriving newtype (FromYAML) - -data Package = Local FilePath - | Location Git - deriving (Show) - -data Git = Git - { repo :: Repo - , commit :: Commit - , subdirs :: [Subdir] - } deriving (Show) -type Repo = Text -type Commit = Text -type Subdir = Text - -data Resolver = Resolver - { resolver :: Maybe ResolverRef - , compiler :: Maybe Ghc - , deps :: [Dep] - , flags :: Flags - } deriving (Show) -instance Semigroup Resolver where - (Resolver r c p f) <> (Resolver r' c' p' f') = - Resolver (r <|> r') (c <|> c') (p <> p') (f <> f') - --- TODO: remote ResolverRefs -data ResolverRef = Canned Text - | Snapshot Text - deriving (Show) - --- http://hackage.haskell.org/package/Cabal-2.4.1.0/docs/Distribution-Types-PackageId.html#t:PackageIdentifier --- http://hackage.haskell.org/package/Cabal-2.4.1.0/docs/Distribution-Parsec-Class.html#v:simpleParsec - -data Dep = Hackage PkgId - | SourceDep Git - deriving (Show) - -newtype Flags = Flags (Map PkgName (Map FlagName Bool)) - deriving (Show) - deriving newtype (FromYAML, Semigroup) - -type PkgName = Text -type FlagName = Text - --- the format used at https://github.com/commercialhaskell/stackage-snapshots --- which is similar to the Resolver format. -data NewResolver = NewResolver - { compiler :: Ghc - , packages :: [NewDep] - , flags :: Flags - } deriving (Show) - -data NewDep = NewDep PkgId - deriving (Show) - --------------------------------------------------------------------------------- --- Resolvers - -readStack :: BS.ByteString -> IO Stack -readStack text = either fail pure $ decode1Strict text - -type RelativeResolvers = NonEmpty (Maybe FilePath, Resolver) -type Resolvers = NonEmpty Resolver - --- highest priority resolver first -unroll :: FilePath -> Stack -> IO Resolvers -unroll base stack = do - let stack' = stack2resolver stack - reverse <$> (loopM next (pure (Just base, stack'))) - where - -- lowest priority (deepest) resolver first - next :: RelativeResolvers -> IO (Either RelativeResolvers Resolvers) - next rs = case head rs of - (_, Resolver Nothing _ _ _) -> pure $ Right (snd <$> rs) - (dir, Resolver (Just r) _ _ _) -> (Left . (<| rs)) <$> resolve dir r - --- if the Resolver is a local snapshot, also include its dir -resolve :: Maybe FilePath -> ResolverRef -> IO (Maybe FilePath, Resolver) -resolve _ (Canned lts) = do - cached <- cache lts - text <- (BS.readFile cached) <|> download - update cached text - either fail (\r -> pure (Nothing, r)) $ new2old <$> (decode1Strict $ text) - where - download = - let path = replace "." "/" (replace "-" "/" lts) - raw = concat ["https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/", path, ".yaml"] - in do - url <- maybe (fail "invalid URL") pure (parseURI $ unpack raw) - putStrLn ("Downloading: " <> (show url)) - Http.get (pack $ show url) Http.concatHandler - - update file content = unlessM (doesFileExist file) (BS.writeFile file content) - -resolve (Just base) (Snapshot path) = do - let file = base (unpack path) - dir = takeDirectory file - text <- BS.readFile file - either fail (\r -> pure (Just dir, r)) $ decode1Strict text - -resolve Nothing _ = fail "Remote snapshots can't use relative paths." - -cache :: Text -> IO FilePath -cache file = do - dir <- getXdgDirectory XdgCache "stackage" - createDirectoryIfMissing True dir - pure $ dir (unpack file) - -stack2resolver :: Stack -> Resolver -stack2resolver Stack{resolver, compiler, packages, extraDeps, flags} = - Resolver (Just resolver) compiler (sourcedeps <> extraDeps) flags - where sourcedeps = mapMaybe pick packages - pick (Local _) = Nothing - pick (Location g) = Just . SourceDep $ g - -new2old :: NewResolver -> Resolver -new2old NewResolver{compiler, packages, flags} = - Resolver Nothing (Just compiler) (new2old' <$> packages) flags - where - new2old' (NewDep pkg) = Hackage pkg - --------------------------------------------------------------------------------- --- YAML boilerplate - --- https://github.com/haskell-hvr/HsYAML/pull/5 -decode1Strict :: FromYAML a => BS.ByteString -> Either String a -decode1Strict text = do - as <- decodeStrict text - maybe (Left "expected unique") Right $ listToMaybe as - -instance FromYAML Stack where - parseYAML = withMap "Stack" $ \m -> Stack - <$> m .: "resolver" - <*> m .:? "compiler" - <*> m .:? "packages" .!= mempty - <*> m .:? "extra-deps" .!= mempty - <*> m .:? "flags" .!= (Flags empty) - -instance FromYAML Git where - parseYAML = withMap "Git" $ \m -> Git - <$> m .: "git" - <*> m .: "commit" - <*> m .:? "subdirs" .!= [] - -instance FromYAML ResolverRef where - parseYAML = withStr "ResolverRef" $ \s -> - if isSuffixOf ".yaml" s - then (pure . Snapshot) s - else (pure . Canned) s - -instance FromYAML Package where - parseYAML n = (local n) <|> (location n) - where - local = withStr "Local" $ pure . Local . unpack - location = withMap "Location" $ \m -> - Location <$> m .: "location" - -instance FromYAML Dep where - parseYAML n = hackage <|> source - where - hackage = Hackage <$> parseYAML n - source = SourceDep <$> parseYAML n - -instance FromYAML Resolver where - parseYAML = withMap "Resolver" $ \m -> Resolver - <$> m .:? "resolver" - <*> m .:? "compiler" - <*> m .:? "packages" .!= mempty - <*> m .:? "flags" .!= (Flags empty) - -instance FromYAML NewDep where - parseYAML = withMap "NewDep" $ \m -> hackage' =<< m .: "hackage" - where - hackage' n = NewDep <$> parseYAML n - -instance FromYAML NewResolver where - parseYAML = withMap "NewResolver" $ \m -> NewResolver - <$> m .: "compiler" - <*> m .:? "packages" .!= mempty - <*> m .:? "flags" .!= (Flags empty) - -newtype PkgId = PkgId { unPkgId :: PackageIdentifier } deriving (Show) -instance FromYAML PkgId where - parseYAML = withStr "PackageIdentifier" $ \s -> - PkgId <$> (hoistMaybe . simpleParse . unpack) (takeWhile ('@' /=) s) diff --git a/stackage-to-hackage.cabal b/stackage-to-hackage.cabal --- a/stackage-to-hackage.cabal +++ b/stackage-to-hackage.cabal @@ -1,51 +1,51 @@ cabal-version: 2.2 name: stackage-to-hackage -version: 1.0.2 +version: 1.1.0 synopsis: Convert stack.yaml to cabal.project + cabal.project.freeze license: GPL-3.0-or-later license-file: LICENSE author: Tseen She maintainer: Tseen She copyright: 2018 Tseen She -bug-reports: https://gitlab.com/tseenshe/stackage-to-hackage/merge_requests -tested-with: GHC ^>= 8.4.4 || ^>= 8.6.2 +bug-reports: https://gitlab.com/tseenshe/stack2cabal/merge_requests +tested-with: GHC ^>= 8.4.4 || ^>= 8.6.3 category: Building description: - This is a small tool to create a cabal.project and cabal.project.freeze file - for an existing Haskell application that has its build plan defined for - the stack build tool. - - The following convenience script invokes stackage-to-hackage and hpack - together [stack2cabal](https://gitlab.com/tseenshe/stackage-to-hackage/blob/master/stack2cabal). - -source-repository head - type: git - location: https://gitlab.com/tseenshe/stackage-to-hackage + A small library (and demo app) to convert stack.yaml files to cabal.project / + cabal.project.freeze for an existing Haskell application that has its build plan + defined for the stack build tool. + . + Users will want to use the stack2cabal application, integrating hpack support. -- https://www.haskell.org/cabal/users-guide/cabal-projectindex.html common deps build-depends: , base ^>= 4.11.1.0 || ^>= 4.12.0.0 + , bytestring ^>= 0.10.8.2 + , Cabal ^>= 2.4.1.0 + , containers ^>= 0.6.0.1 + , directory ^>= 1.3.3.1 + , extra ^>= 1.6.13 + , filepath ^>= 1.4.2.1 + , text ^>= 1.2.3.1 ghc-options: -Wall -Werror=missing-home-modules default-language: Haskell2010 +library + import: deps + hs-source-dirs: lib + exposed-modules: StackageToHackage.Hackage + , StackageToHackage.Stackage + build-depends: , HsYAML ^>= 0.1.1.2 + -- http-client, not http-streams, to match hpack + , http-client ^>= 0.5.14 + , http-client-tls ^>= 0.3.5.3 + executable stackage-to-hackage import: deps - hs-source-dirs: src + hs-source-dirs: exe main-is: Main.hs - other-modules: Stackage - build-depends: , Cabal ^>= 2.4.1.0 - , HsYAML ^>= 0.1.1.2 - , HsOpenSSL ^>= 0.11.4.15 - , bytestring ^>= 0.10.8.2 - , http-streams ^>= 0.8.6.1 - , containers ^>= 0.6.0.1 - , directory ^>= 1.3.3.1 - , extra ^>= 1.6.13 - , filepath ^>= 1.4.2.1 + build-depends: stackage-to-hackage , optparse-applicative ^>= 0.14.3.0 - , network-uri ^>= 2.6.1.0 - , semigroupoids ^>= 5.3.1 - , text ^>= 1.2.3.1 ghc-options: -threaded