diff --git a/nixfromnpm.cabal b/nixfromnpm.cabal --- a/nixfromnpm.cabal +++ b/nixfromnpm.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: nixfromnpm -version: 0.1.0.4 +version: 0.1.0.5 synopsis: Generate nix expressions from npm packages. -- description: license: MIT @@ -14,11 +14,45 @@ -- extra-source-files: cabal-version: >=1.10 +library + exposed-modules: NixFromNpm + other-modules: NixFromNpm.Common + , NixFromNpm.ConvertToNix + , NixFromNpm.NpmLookup + , NixFromNpm.NpmTypes + , NixFromNpm.NpmVersion + , NixFromNpm.SemVer + , NixFromNpm.Parsers.Common + , NixFromNpm.Parsers.NpmVersion + , NixFromNpm.Parsers.SemVer + build-depends: base >=4.8 && <4.9 + , classy-prelude + , text + , mtl + , bytestring + , unordered-containers + , parsec + , aeson + , data-default + , shelly + , MissingH + , error-list + , text-render + , system-filepath + , filepath + , network-uri + , directory + , simple-nix >=0.1.0.4 + hs-source-dirs: src + default-language: Haskell2010 + + + executable nixfromnpm main-is: Main.hs - -- other-modules: +-- other-modules: NixFromNpm other-extensions: NoImplicitPrelude, OverloadedStrings - build-depends: base >=4.8 && <4.9 + build-depends: base >=4.8 && <4.9 , classy-prelude , text , mtl diff --git a/src/Main.hs b/src/Main.hs --- a/src/Main.hs +++ b/src/Main.hs @@ -1,20 +1,37 @@ {-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE NoImplicitPrelude #-} module Main where import System.Environment (getArgs) -import System.Console.Docopt +import System.Console.Docopt.NoTH import NixFromNpm hiding (getArgs) -patterns :: Docopt -patterns = [docoptFile|USAGE.txt|] +usageString :: String +usageString = "\ + \Usage:\n\ + \ nixfromnpm [-o PATH] [options]\n\ + \Options:\n\ + \ -o, --output PATH Output files to this path\n\ + \ --extend PATHS... Use nix expressions existing at these\n\ + \ paths\n\ + \ --registries REGISTRIES... Use only these registries\n\ + \ --extra-registries REGISTRIES.. Use these in addition to default registry\n\ + \ --no-cache Don't use existing cache\n\ + \ --test Don't write expressions, just fetch\n\ + \ --timeout SECONDS Seconds after which to fail fetching a\n\ + \ package\n\ + \ --node-version VERSION Use this version of node\n" -args ?? arg = getArgOrExitWith patterns args (argument arg) +getFlag args f = isPresent args (longOption f) main :: IO () main = do + patterns <- parseUsageOrExit usageString args <- parseArgsOrExit patterns =<< getArgs - pkgName <- args ?? "packagename" - path <- args ?? "outputpath" - let noCache = isPresent args (longOption "no-cache") - dumpPkgNamed noCache (pack pkgName) (pack path) + let args ?? arg = getArgOrExitWith patterns args (argument arg) + pkgName <- map pack $ args ?? "packagename" + path <- map pack $ args ?? "outputpath" + dumpPkgFromOptions $ (defaultOptions pkgName path) { + nfnoNoCache = args `getFlag` "no-cache" + } diff --git a/src/NixFromNpm.hs b/src/NixFromNpm.hs new file mode 100644 --- /dev/null +++ b/src/NixFromNpm.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} +module NixFromNpm (module NixFromNpm.Common, + module NixFromNpm.SemVer, + module NixFromNpm.Parsers.SemVer, + module NixFromNpm.NpmVersion, + module NixFromNpm.NpmTypes, + module NixFromNpm.Parsers.NpmVersion, + module NixFromNpm.NpmLookup, + module NixFromNpm.ConvertToNix) where + +import NixFromNpm.Common +import NixFromNpm.SemVer +import NixFromNpm.Parsers.SemVer +import NixFromNpm.NpmVersion +import NixFromNpm.NpmTypes +import NixFromNpm.Parsers.NpmVersion +import NixFromNpm.NpmLookup +import NixFromNpm.ConvertToNix diff --git a/src/NixFromNpm/Common.hs b/src/NixFromNpm/Common.hs new file mode 100644 --- /dev/null +++ b/src/NixFromNpm/Common.hs @@ -0,0 +1,161 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE TypeFamilies #-} +module NixFromNpm.Common ( + module ClassyPrelude, + module Control.Applicative, + module Control.Exception, + module Control.Exception.ErrorList, + module Control.Monad, + module Control.Monad.Except, + module Control.Monad.Identity, + module Control.Monad.State.Strict, + module Control.Monad.Reader, + module Control.Monad.Trans, + module Data.Char, + module Data.Default, + module Data.HashMap.Strict, + module Data.Either, + module Data.Maybe, + module Data.List, + module Data.String.Utils, + module GHC.Exts, + module Filesystem.Path.CurrentOS, + module Network.URI, + module GHC.IO.Exception, + module System.Directory, + module Text.Render, + module System.FilePath.Posix, + Name, Record, + tuple, tuple3, fromRight, cerror, cerror', uriToText, uriToString, slash, + putStrsLn, pathToText, putStrs, dropSuffix, maybeIf, grab, withDir, + pathToString, joinBy, mapJoinBy + ) where + +import ClassyPrelude hiding (assert, asList, find, FilePath, bracket, + maximum, maximumBy, try) +import qualified Prelude as P +import Control.Monad (when) +import Control.Monad.Trans (MonadIO(..), lift) +import Control.Monad.Reader (ReaderT(..), MonadReader(..), (<=<), (>=>), ask, + asks) +import Control.Monad.State.Strict (MonadState, StateT, State, get, gets, + modify, put, liftM, liftIO, runState, + runStateT, execState, execStateT, + evalState, evalStateT) +import Control.Monad.Except (ExceptT, MonadError(..), throwError, runExceptT) +import Control.Exception.ErrorList +import Control.Monad.Identity (Identity(..)) +import Control.Applicative hiding (empty, optional) +import Data.Char (isDigit, isAlpha) +import Data.Default +import Data.List (maximum, maximumBy) +import Data.HashMap.Strict (HashMap, (!)) +import qualified Data.HashMap.Strict as H +import Data.Maybe (fromJust, isJust, isNothing) +import Data.Either (isRight, isLeft) +import Data.String.Utils hiding (join) +import qualified Data.Text as T +import Filesystem.Path.CurrentOS (FilePath, fromText, toText, collapse) +import GHC.Exts (IsList) +import GHC.IO.Exception +import Control.Exception (bracket) +import Text.Render hiding (renderParens) +import Network.URI (URI(..), parseURI, parseAbsoluteURI, + parseRelativeReference, relativeTo) +import qualified Network.URI as NU +import System.Directory +import System.FilePath.Posix hiding (FilePath) + +-- | Indicates that the text is some identifier. +type Name = Text + +-- | A record is a lookup table with string keys. +type Record = HashMap Name + +-- | Takes two applicative actions and returns their result as a 2-tuple. +tuple :: Applicative f => f a -> f b -> f (a, b) +tuple action1 action2 = (,) <$> action1 <*> action2 + +-- | Takes three applicative actions and returns their result as a 3-tuple. +tuple3 :: Applicative f => f a -> f b -> f c -> f (a, b, c) +tuple3 action1 action2 action3 = (,,) <$> action1 <*> action2 <*> action3 + +-- | Creates a new hashmap by applying a function to every key in it. +alterKeys :: (Eq k, Hashable k, Eq k', Hashable k') => + (k -> k') -> HashMap k v -> HashMap k' v +alterKeys f mp = do + let pairs = H.toList mp + let newPairs = P.map (\(k, v) -> (f k, v)) pairs + let newMap = H.fromList newPairs + newMap + +cerror :: [String] -> a +cerror = error . concat + +cerror' :: [Text] -> a +cerror' = cerror . map unpack + +fromRight :: Either a b -> b +fromRight (Right x) = x +fromRight (Left err) = error "Expected `Right` value" + +uriToText :: URI -> Text +uriToText = pack . uriToString + +uriToString :: URI -> String +uriToString uri = NU.uriToString id uri "" + +-- | Appends text to URI with a slash. Ex: foo.com `slash` bar == foo.com/bar. +slash :: URI -> Text -> URI +slash uri txt = case parseRelativeReference (unpack txt) of + Nothing -> error ("Invalid appending URI: " <> show txt) + Just uri' -> uri' `relativeTo` uri + +infixl 6 `slash` + +putStrsLn :: MonadIO m => [Text] -> m () +putStrsLn = putStrLn . concat + +putStrs :: MonadIO m => [Text] -> m () +putStrs = putStr . concat + +pathToText :: FilePath -> Text +pathToText pth = case toText pth of + Left p -> p + Right p -> p + +dropSuffix :: String -> String -> String +dropSuffix suffix s | s == suffix = "" +dropSuffix suffix (c:cs) = c : dropSuffix suffix cs +dropSuffix suffix "" = "" + +maybeIf :: Bool -> a -> Maybe a +maybeIf True x = Just x +maybeIf False _ = Nothing + +grab :: (Hashable k, Eq k) => k -> HashMap k v -> v +grab k = fromJust . H.lookup k + +withDir :: String -> IO a -> IO a +withDir d action = do + cur <- getCurrentDirectory + result <- bracket (setCurrentDirectory d) + (\_ -> setCurrentDirectory cur) + (\_ -> action) + return result + +pathToString :: FilePath -> String +pathToString = unpack . pathToText + +joinBy :: Text -> [Text] -> Text +joinBy = T.intercalate + +mapJoinBy :: Text -> (a -> Text) -> [a] -> Text +mapJoinBy sep func = joinBy sep . map func diff --git a/src/NixFromNpm/ConvertToNix.hs b/src/NixFromNpm/ConvertToNix.hs new file mode 100644 --- /dev/null +++ b/src/NixFromNpm/ConvertToNix.hs @@ -0,0 +1,178 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +module NixFromNpm.ConvertToNix where + +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as H +import Data.Text (Text) +import qualified Data.Text as T + +import NixFromNpm.Common +import Nix.Expr +import Nix.Parser +import NixFromNpm.NpmTypes +import NixFromNpm.SemVer +import NixFromNpm.Parsers.SemVer +import NixFromNpm.NpmLookup + + +_startingSrc :: Text +_startingSrc = unlines [ + "{nixpkgs ? import {}}:", + "let", + " allPkgs = nixpkgs // nodePkgs // {inherit (nixpkgs.nodePackages)", + " buildNodePackage;};", + " callPackage = pth: overrides: let", + " f = import pth;", + " in", + " f ((builtins.intersectAttrs (builtins.functionArgs f) allPkgs)", + " // overrides);", + " nodePkgs = byVersion // defaults;", + "in", + "nodePkgs" + ] + +_startingExpr :: NixExpr +_startingExpr = fromRight $ parseNix _startingSrc + +callPackage :: NixExpr -> NixExpr +callPackage e = Apply (Apply (Var "callPackage") e) (Set False []) + +fixName :: Name -> Name +fixName = T.replace "." "-" + +toDepName :: Name -> SemVer -> Name +toDepName name (a, b, c) = concat [fixName name, "_", pack $ + intercalate "-" $ map show [a, b, c]] + +toDotNix :: SemVer -> Text +toDotNix (a,b,c) = pack $ intercalate "." (map show [a,b,c]) <> ".nix" + +distInfoToNix :: DistInfo -> NixExpr +distInfoToNix DistInfo{..} = Apply (Var "fetchurl") $ Set False + [ "url" =$= str diUrl, + "sha1" =$= str diShasum ] + +metaNotEmpty :: PackageMeta -> Bool +metaNotEmpty PackageMeta{..} = isJust pmDescription + +metaToNix :: PackageMeta -> NixExpr +metaToNix PackageMeta{..} = case pmDescription of + Nothing -> Set False [] + Just d -> Set False ["description" =$= str d] + +resolvedPkgToNix :: ResolvedPkg -> NixExpr +resolvedPkgToNix ResolvedPkg{..} = do + let deps = map (Var . uncurry toDepName) $ H.toList rpDependencies + _funcParams = map (uncurry toDepName) (H.toList rpDependencies) + <> ["buildNodePackage", "fetchurl"] + funcParams = toKwargs $ map (\x -> (x, Nothing)) _funcParams + let args = Set False $ catMaybes [ + Just $ "name" =$= str rpName, + Just $ "version" =$= (str $ renderSV rpVersion), + Just $ "src" =$= distInfoToNix rpDistInfo, + maybeIf (length deps > 0) $ "deps" =$= List deps, + maybeIf (metaNotEmpty rpMeta) $ "meta" =$= metaToNix rpMeta + ] + Function funcParams $ Apply (Var "buildNodePackage") args + +mkDefault :: Record (HashMap SemVer a) -> NixExpr +mkDefault rec = do + let mkPath name ver = fromText $ concat ["./", name, "/", toDotNix ver] + mkAssign name ver = Assign [Plain $ toDepName name ver] + (callPackage $ Path $ mkPath name ver) + mkAssigns name vers = map (mkAssign name) vers + mkDefVer name vers = do + Assign [Plain $ fixName name] (Var $ toDepName name $ maximum vers) + -- This bit of map gymnastics will create a list of pairs of names + -- with all of the versions of that name that we have. + versOnly = map (map (map fst)) $ H.toList $ map H.toList rec + byVersion = Set False $ concatMap (uncurry mkAssigns) versOnly + defaults = With (Var "byVersion") $ + Set False $ map (uncurry mkDefVer) versOnly + newAssigns = ["byVersion" =$= byVersion, "defaults" =$= defaults] + Function params (Let assigns e) = _startingExpr + Function params (Let (assigns <> newAssigns) e) + +dumpPkgs :: MonadIO m + => String + -> Record (HashMap SemVer (Either NixExpr ResolvedPkg)) + -> m () +dumpPkgs path rPkgs = liftIO $ do + createDirectoryIfMissing True path + withDir path $ forM_ (H.toList rPkgs) $ \(pkgName, pkgVers) -> do + writeFile "default.nix" $ renderIndented 2 $ mkDefault rPkgs + let subdir = path unpack pkgName + createDirectoryIfMissing False subdir + withDir subdir $ forM_ (H.toList pkgVers) $ \(ver, rpkg) -> do + let nixexpr = case rpkg of + Left e -> e + Right r -> resolvedPkgToNix r + writeFile (unpack $ toDotNix ver) $ renderIndented 2 nixexpr + +parseVersion :: String -> IO (Maybe (SemVer, NixExpr)) +parseVersion pth = do + case parseSemVer . pack $ dropSuffix ".nix" $ takeBaseName pth of + Left _ -> return Nothing -- not a version file + Right version -> parseNix . pack <$> readFile pth >>= \case + Left err -> do + putStrsLn [pack pth, " failed to parse: ", pack $ show err] + return Nothing -- invalid nix, should overwrite + Right expr -> return $ Just (version, expr) + +findExisting :: String -> IO (Record (HashMap SemVer NixExpr)) +findExisting path = do + putStrLn "Searching for existing expressions..." + doesDirectoryExist path >>= \case + False -> return mempty + True -> withDir path $ do + contents <- getDirectoryContents "." + verMaps <- forM contents $ \dir -> do + exprs <- doesDirectoryExist dir >>= \case + True -> withDir dir $ do + contents <- getDirectoryContents "." + let files = filter (endswith ".nix") contents + catMaybes <$> mapM parseVersion files + False -> do + putStrsLn [pack dir, " is not a directory"] + return mempty -- not a directory + case exprs of + [] -> return Nothing + vs -> return $ Just (pack dir, H.fromList exprs) + let total = sum $ map (H.size . snd) $ catMaybes verMaps + putStrsLn ["Found ", render total, " existing expressions"] + return $ H.fromList $ catMaybes verMaps + +-- | Various options we have available for nixfromnpm. As of right now, +-- most of these are unimplemented. +data NixFromNpmOptions = NixFromNpmOptions { + nfnoPkgName :: Name, + nfnoOutputPath :: Text, + nfnoNoCache :: Bool, + nfnoExtendPaths :: [Text], + nfnoTest :: Bool, + nfnoRegistries :: [Text], + nfnoTimeout :: Int +} deriving (Show, Eq) + +defaultOptions :: Name -> Text -> NixFromNpmOptions +defaultOptions pkgName outputPath = NixFromNpmOptions { + nfnoPkgName = pkgName, + nfnoOutputPath = outputPath, + nfnoNoCache = False, + nfnoExtendPaths = [], + nfnoTest = False, + nfnoTimeout = 10, + nfnoRegistries = [] + } + +dumpPkgNamed :: Bool -> Text -> Text -> IO () +dumpPkgNamed noExistCheck name path = do + existing <- if noExistCheck then pure mempty else findExisting $ unpack path + getPkg name existing >>= dumpPkgs (unpack path) + +dumpPkgFromOptions :: NixFromNpmOptions -> IO () +dumpPkgFromOptions NixFromNpmOptions{..} = do + dumpPkgNamed nfnoNoCache nfnoPkgName nfnoOutputPath diff --git a/src/NixFromNpm/NpmLookup.hs b/src/NixFromNpm/NpmLookup.hs new file mode 100644 --- /dev/null +++ b/src/NixFromNpm/NpmLookup.hs @@ -0,0 +1,428 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE ScopedTypeVariables #-} +module NixFromNpm.NpmLookup where + +-------------------------------------------------------------------------- +import qualified Prelude as P +import qualified Data.List as L +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as H +import Data.HashSet (HashSet) +import qualified Data.HashSet as HS + +import qualified Data.ByteString.Lazy.Char8 as BL8 +import Data.Aeson.Parser +import Data.Aeson +import Data.Aeson.Types (Parser, typeMismatch) +import qualified Text.Parsec as Parsec +import Shelly hiding (get) + +import NixFromNpm.Common +import NixFromNpm.NpmTypes +import NixFromNpm.SemVer +import NixFromNpm.Parsers.Common hiding (Parser, Error, lines) +import NixFromNpm.Parsers.SemVer +import NixFromNpm.NpmVersion +import NixFromNpm.Parsers.NpmVersion +import Nix.Expr +-------------------------------------------------------------------------- + +data NpmFetcherState = NpmFetcherState { + registries :: [URI], + githubAuthToken :: Maybe Text, + resolved :: Record (HashMap SemVer (Either NixExpr ResolvedPkg)), + pkgInfos :: Record PackageInfo, + -- For cycle detection. + currentlyResolving :: HashSet (Name, SemVer), + indentLevel :: Int, + knownProblematicPackages :: HashSet Name, + getDevDeps :: Bool +} deriving (Show, Eq) + +type NpmFetcher = ExceptT EList (StateT NpmFetcherState IO) + +indent :: Text -> NpmFetcher Text +indent txt = do + ind <- gets indentLevel + return $ concat [txt, " (depth of ", pack $ show ind, ")"] + +putStrLnI :: Text -> NpmFetcher () +putStrLnI = indent >=> putStrLn + +putStrsLnI :: [Text] -> NpmFetcher () +putStrsLnI = putStrLnI . concat + +putStrI :: Text -> NpmFetcher () +putStrI = indent >=> putStr + +putStrsI :: [Text] -> NpmFetcher () +putStrsI = putStrI . concat + +addResolvedPkg :: Name -> SemVer -> ResolvedPkg -> NpmFetcher () +addResolvedPkg name version _rpkg = do + let rpkg = Right _rpkg + pkgSet <- H.lookupDefault mempty name <$> gets resolved + modify $ \s -> s { + resolved = H.insert name (H.insert version rpkg pkgSet) (resolved s) + } + +_defaultCurlArgs :: [Text] +_defaultCurlArgs = ["-L", "--fail"] + +curl :: [Text] -> NpmFetcher Text +curl args = shell $ print_stdout False $ run "curl" (_defaultCurlArgs <> args) + +-- | Queries NPM for package information. +_getPackageInfo :: Name -> URI -> NpmFetcher PackageInfo +_getPackageInfo pkgName registryUri = do + let uri = uriToText $ registryUri `slash` pkgName + putStrsLn ["Querying ", uriToText registryUri, + " for package ", pkgName, "..."] + jsonStr <- curl [uri] + case eitherDecode $ BL8.fromChunks [T.encodeUtf8 jsonStr] of + Left err -> throwErrorC ["couldn't parse JSON from NPM: ", pack err] + Right info -> return info + +-- | Same as _getPackageInfo, but caches results for speed. +getPackageInfo :: Name -> NpmFetcher PackageInfo +getPackageInfo name = lookup name . pkgInfos <$> get >>= \case + Just info -> return info + Nothing -> inContext ctx $ do + regs <- gets registries + info <- firstSuccess "No repos contained package" $ + map (_getPackageInfo name) regs + storePackageInfo name info + return info + where ctx = pack $ "When querying NPM registry for package " <> show name + +storePackageInfo :: Name -> PackageInfo -> NpmFetcher () +storePackageInfo name info = do + infos <- gets pkgInfos + let existingInfo = H.lookupDefault mempty name infos + newInfo = existingInfo <> info + modify $ \s -> s {pkgInfos = H.insert name newInfo (pkgInfos s)} + + +toSemVerList :: Record a -> NpmFetcher [(SemVer, a)] +toSemVerList rec = do + -- Pairings of parsed semvers (or errors) to values. + let parsePair (k, v) = (parseSemVer k, v) + pairs = map parsePair $ H.toList rec + case filter (\(k, _) -> isRight k) pairs of + [] -> throwError1 "No correctly-formatted versions strings found" + okPairs -> return $ map (\(Right k, v) -> (k, v)) okPairs + +bestMatchFromRecord :: SemVerRange -> Record a -> NpmFetcher a +bestMatchFromRecord range rec = do + pairs <- toSemVerList rec + case filter (matches range . fst) pairs of + [] -> throwError1 "No versions satisfy given range" + matches -> return $ snd $ maximumBy (compare `on` fst) matches + +shell :: Sh Text -> NpmFetcher Text +shell action = do + (code, out, err) <- shelly $ errExit False $ do + out <- action + code <- lastExitCode + err <- lastStderr + return (code, out, err) + case code of + 0 -> return out + n -> do + throwErrorC $ catMaybes [ + Just "Shell command returned an error.", + maybeIf (out /= "") $ "\nstdout:\n" <> out, + Just $ "\nstderr:\n" <> err] + +silentShell :: Sh Text -> NpmFetcher Text +silentShell = shell . silently + +-- | Returns the SHA1 hash of the result of fetching the URI, and the path +-- in which the tarball is stored. +nixPrefetchSha1 :: URI -> NpmFetcher (Text, FilePath) +nixPrefetchSha1 uri = do + hashAndPath <- silentShell $ do + setenv "PRINT_PATH" "1" + run "nix-prefetch-url" ["--type", "sha1", uriToText uri] + if length (lines hashAndPath) /= 2 + then error "Expected two lines from nix-prefetch-url" + else do + let [hashBase32, path] = lines hashAndPath + -- Convert the hash to base16, which is the format NPM uses. + hash <- silentShell $ do + run "nix-hash" ["--type", "sha1", "--to-base16", hashBase32] + return (T.strip hash, fromString $ unpack path) + +extractVersionInfo :: FilePath -> Text -> NpmFetcher VersionInfo +extractVersionInfo tarballPath subpath = do + ind <- gets indentLevel + pkJson <- silentShell $ withTmpDir $ \dir -> do + chdir dir $ do + putStrs ["Extracting ", pathToText tarballPath, " to tempdir"] + putStrsLn [" (depth of ", pack $ show ind, ")"] + run_ "tar" ["-xf", pathToText tarballPath] + curdir <- pathToText <$> pwd + pth <- fmap T.strip $ run "find" [curdir, "-name", "package.json"] + -|- run "head" ["-n", "1"] + when (pth == "") $ error "No package.json found" + map decodeUtf8 $ readBinary $ fromString $ unpack $ pth + case eitherDecode $ BL8.fromChunks [encodeUtf8 pkJson] of + Left err -> error $ "couldn't parse JSON as VersionInfo: " <> err + Right info -> return info + +-- | Fetch a package over HTTP. Return the version of the fetched package, +-- and store the hash. +fetchHttp :: Text -- | Subpath in which to find the package.json. + -> URI -- | The URI to fetch. + -> NpmFetcher SemVer -- | The version of the package at that URI. +fetchHttp subpath uri = do + -- Use nix-fetch to download and hash the tarball. + (hash, tarballPath) <- nixPrefetchSha1 uri + -- Extract the tarball to a temp directory and parse the package.json. + versionInfo <- extractVersionInfo tarballPath subpath + -- Create the DistInfo. + let dist = DistInfo {diUrl = uriToText uri, diShasum = hash} + -- Add the dist information to the version info and resolve it. + resolveVersionInfo $ versionInfo {viDist = Just dist} + +githubCurl :: Text -> NpmFetcher Value +githubCurl uri = do + extraCurlArgs <- gets githubAuthToken >>= \case + Nothing -> return [] + Just token -> return ["-H", "Authorization: token " <> token] + let curlArgs = extraCurlArgs <> [ + -- This accept header tells github to allow redirects. + "-H", "Accept: application/vnd.github.quicksilver-preview+json", + uri + ] + -- putStrsLn $ ["calling curl with args: ", T.intercalate " " curlArgs] + jsonStr <- curl curlArgs + case eitherDecode $ BL8.fromChunks [T.encodeUtf8 jsonStr] of + Left err -> throwErrorC ["couldn't parse JSON from github: ", pack err] + Right info -> return info + +-- | Queries NPM for package information. +getDefaultBranch :: Name -> Name -> NpmFetcher Name +getDefaultBranch owner repo = do + let rpath = "/" <> owner <> "/" <> repo + let uri = concat ["https://api.github.com/repos", rpath] + putStrs ["Querying github for default branch of ", rpath, "..."] + githubCurl uri >>= \case + Object o -> case H.lookup "default_branch" o of + Just (String b) -> putStr " OK. " >> return b + Nothing -> putStrLn "" >> error "No default branch, or not a string" + _ -> error "Expected an object back from github" + +getShaOfBranch :: Name -- | Repo owner + -> Name -- | Repo name + -> Name -- | Name of the branch to get + -> NpmFetcher Text -- | The hash of the default branch +getShaOfBranch owner repo branchName = do + let rpath = "/" <> owner <> "/" <> repo + let uri = concat ["https://api.github.com/repos", rpath, + "/branches/", branchName] + putStrs ["Querying github for sha of ", rpath, "/", branchName, "..."] + githubCurl uri >>= \case + Object o -> case H.lookup "commit" o of + Just (Object o') -> case H.lookup "sha" o' of + Just (String sha) -> return sha + Nothing -> error "No sha in commit info" + Nothing -> error "No commit info" + _ -> error "Didn't get an object back" + +-- | Fetch a package from git. +fetchGithub :: URI -> NpmFetcher SemVer +fetchGithub uri = do + (owner, repo) <- case split "/" $ uriPath uri of + [_, owner, repo] -> return (pack owner, pack $ dropSuffix ".git" repo) + _ -> throwErrorC ["Invalid repo path: ", pack $ uriPath uri] + hash <- case uriFragment uri of + -- if there isn't a ref or a tag, use the default branch. + "" -> do + branch <- getDefaultBranch owner repo + putStrLn $ " Branch is " <> branch + sha <- getShaOfBranch owner repo branch + putStrLn $ " Hash is " <> sha + return sha + -- otherwise, use that as a tag. + '#':frag -> return $ pack frag + frag -> throwErrorC ["Invalid fragment '", pack frag, "'"] + -- Use the hash to pull down a zip. + let uri = concat ["https://github.com/", owner, "/", repo, "/archive/", + hash, ".tar.gz"] + fetchHttp (repo <> "-" <> hash) (fromJust $ parseURI $ unpack uri) + +resolveNpmVersionRange :: Name -> NpmVersionRange -> NpmFetcher SemVer +resolveNpmVersionRange name range = case range of + SemVerRange svr -> resolveDep name svr + NpmUri uri -> case uriScheme uri of + "git:" -> fetchGithub uri + "git+https:" -> fetchGithub uri + "http:" -> fetchHttp "package" uri + "https:" -> fetchHttp "package" uri + scheme -> throwErrorC ["Unknown uri scheme ", pack scheme] + GitId src owner repo rev -> case src of + Github -> do + let frag = case rev of + Nothing -> "" + Just r -> "#" <> r + let uri = concat ["https://github.com/", owner, "/", repo, frag] + fetchGithub $ fromJust $ parseURI $ unpack uri + _ -> throwErrorC ["Can't handle git source ", pack $ show src] + Tag tag -> resolveByTag tag name + vr -> throwErrorC ["Don't know how to resolve dependency '", + pack $ show vr, "'"] + +-- | Uses the set of downloaded packages as a cache to avoid unnecessary +-- duplication. +resolveDep :: Name -> SemVerRange -> NpmFetcher SemVer +resolveDep name range = H.lookup name <$> gets resolved >>= \case + Just versions -> case filter (matches range) (H.keys versions) of + [] -> _resolveDep name range -- No matching versions, need to fetch. + vs -> return $ maximum vs + Nothing -> _resolveDep name range + +startResolving :: Name -> SemVer -> NpmFetcher () +startResolving name ver = do + putStrsLn ["Resolving ", name, " version ", renderSV ver] + modify $ \s -> + s {currentlyResolving = HS.insert (name, ver) $ currentlyResolving s} + +finishResolving :: Name -> SemVer -> NpmFetcher () +finishResolving name ver = do + modify $ \s -> + s {currentlyResolving = HS.delete (name, ver) $ currentlyResolving s} + putStrsLn ["Finished resolving ", name, " ", renderSV ver] + +resolveVersionInfo :: VersionInfo -> NpmFetcher SemVer +resolveVersionInfo versionInfo = do + let name = viName versionInfo + version = viVersion versionInfo + ctx = concat ["When resolving package ", name, ", version ", version] + inContext ctx $ do + version <- case parseSemVer $ viVersion versionInfo of + Left err -> throwErrorC ["Invalid semver in versionInfo object ", + viVersion versionInfo, + " Due to: ", pack $ show err] + Right v -> return v + HS.member (name, version) <$> gets currentlyResolving >>= \case + True -> do putStrsLn ["Warning: cycle detected"] + return version + False -> do + let recurOn deptype deps = map H.fromList $ do + let depList = H.toList $ deps versionInfo + when (length depList > 0) $ + putStrsLn ["Found ", deptype, ": ", pack (show depList)] + res <- map catMaybes $ forM depList $ \(depName, depRange) -> do + HS.member depName <$> gets knownProblematicPackages >>= \case + True -> do + putStrsLn ["WARNING: ", name, " is a broken package"] + return Nothing + False -> do + depVersion <- resolveNpmVersionRange depName depRange + return $ Just (depName, depVersion) + return res + -- We need to recur into the package's dependencies. + -- To prevent the cycles, we store which packages we're currently + -- resolving. + startResolving name version + deps <- recurOn "Dependencies" viDependencies + devDeps <- gets getDevDeps >>= \case + True -> recurOn "Dev dependencies" viDevDependencies + False -> return mempty + finishResolving name version + let dist = case viDist versionInfo of + Nothing -> error "Version information did not include dist" + Just d -> d + -- Store this version's info. + addResolvedPkg name version $ ResolvedPkg { + rpName = name, + rpVersion = version, + rpDistInfo = dist, + rpMeta = viMeta versionInfo, + rpDependencies = deps, + rpDevDependencies = devDeps + } + return version + +-- | Resolves a dependency given a name and version range. +_resolveDep :: Name -> SemVerRange -> NpmFetcher SemVer +_resolveDep name range = do + let ctx = concat ["When resolving dependency ", name, " (", + pack $ show range, ")"] + inContext ctx $ do + pInfo <- getPackageInfo name + versionInfo <- bestMatchFromRecord range $ piVersions pInfo + resolveVersionInfo versionInfo + +resolveByTag :: Name -> Name -> NpmFetcher SemVer +resolveByTag tag pkgName = do + pInfo <- getPackageInfo pkgName + case H.lookup tag $ piTags pInfo of + Nothing -> throwErrorC ["Package ", pkgName, " has no tag '", tag, "'"] + Just version -> case H.lookup version $ piVersions pInfo of + Nothing -> throwErrorC ["Tag '", tag, "' refers to version '", version, + "' but no such version exists for package ", + pack $ show pkgName] + Just versionInfo -> resolveVersionInfo versionInfo + +parseURIs :: [Text] -> [URI] +parseURIs rawUris = map p $! rawUris where + p txt = case parseURI $ unpack txt of + Nothing -> errorC ["Invalid URI: ", txt] + Just uri -> uri + +startState :: Record (HashMap SemVer NixExpr) + -> [Text] + -> Maybe Text + -> NpmFetcherState +startState existing registries token = do + NpmFetcherState { + registries = parseURIs registries, + githubAuthToken = token, + resolved = map (map Left) existing, + pkgInfos = mempty, + currentlyResolving = mempty, + knownProblematicPackages = HS.fromList ["websocket-server"], + indentLevel = 0, + getDevDeps = False + } + +-- | Read NPM registry from env or use default. +getRegistries :: IO [Text] +getRegistries = do + let npmreg = "https://registry.npmjs.org/" + others <- shelly $ silently $ do + get_env "ADDITIONAL_NPM_REGISTRIES" >>= \case + Nothing -> return [] + Just regs -> return $ T.words regs + return (others `snoc` npmreg) + +-- | Read github auth token from env or use none. +getToken :: IO (Maybe Text) +getToken = shelly $ silently $ get_env "GITHUB_TOKEN" + +runIt :: NpmFetcher a -> IO (a, NpmFetcherState) +runIt x = do + state <- startState mempty <$> getRegistries <*> getToken + runItWith state x + +runItWith :: NpmFetcherState -> NpmFetcher a -> IO (a, NpmFetcherState) +runItWith state x = do + runStateT (runExceptT x) state >>= \case + (Left elist, _) -> error $ "\n" <> (unpack $ render elist) + (Right x, state) -> return (x, state) + +getPkg :: Name + -> Record (HashMap SemVer NixExpr) + -> IO (Record (HashMap SemVer (Either NixExpr ResolvedPkg))) +getPkg name existing = do + let range = Gt (0, 0, 0) + state <- startState existing <$> getRegistries <*> getToken + (_, finalState) <- runItWith state (_resolveDep name range) + return (resolved finalState) diff --git a/src/NixFromNpm/NpmTypes.hs b/src/NixFromNpm/NpmTypes.hs new file mode 100644 --- /dev/null +++ b/src/NixFromNpm/NpmTypes.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module NixFromNpm.NpmTypes where + +import Data.Aeson +import Data.Aeson.Types (Parser, typeMismatch) +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as H + +import NixFromNpm.Common +import NixFromNpm.SemVer +import NixFromNpm.NpmVersion +import NixFromNpm.Parsers.NpmVersion +import NixFromNpm.Parsers.SemVer + +data PackageInfo = PackageInfo { + piVersions :: Record VersionInfo, + piTags :: Record Name +} deriving (Show, Eq) + +data PackageMeta = PackageMeta { + pmDescription :: Maybe Text +} deriving (Show, Eq) + +data VersionInfo = VersionInfo { + viDependencies :: Record NpmVersionRange, + viDevDependencies :: Record NpmVersionRange, + viDist :: Maybe DistInfo, -- not present if in a package.json file. + viMain :: Maybe Text, + viName :: Text, + viHasTest :: Bool, + viMeta :: PackageMeta, + viVersion :: Text +} deriving (Show, Eq) + +-- | Distribution info from NPM. Tells us the URL and hash of a tarball. +data DistInfo = DistInfo { + diUrl :: Text, + diShasum :: Text +} deriving (Show, Eq) + +data ResolvedPkg = ResolvedPkg { + rpName :: Name, + rpVersion :: SemVer, + rpDistInfo :: DistInfo, + rpMeta :: PackageMeta, + rpDependencies :: Record SemVer, + rpDevDependencies :: Record SemVer +} deriving (Show, Eq) + +instance Semigroup PackageInfo where + PackageInfo vs ts <> PackageInfo vs' ts' = + PackageInfo (vs <> vs') (ts <> ts') + +instance Monoid PackageInfo where + mempty = PackageInfo mempty mempty + mappend = (<>) + +instance FromJSON VersionInfo where + parseJSON = getObject "version info" >=> \o -> do + dependencies <- getDict "dependencies" o + devDependencies <- getDict "devDependencies" o + dist <- o .:? "dist" + name <- o .: "name" + main <- o .:? "main" + version <- o .: "version" + packageMeta <- fmap PackageMeta $ o .:? "description" + scripts :: Record Value <- getDict "scripts" o + return $ VersionInfo { + viDependencies = dependencies, + viDevDependencies = devDependencies, + viDist = dist, + viMain = main, + viName = name, + viHasTest = H.member "test" scripts, + viMeta = packageMeta, + viVersion = version + } + +instance FromJSON SemVerRange where + parseJSON v = case v of + String s -> case parseSemVerRange s of + Left err -> typeMismatch ("valid semantic version (got " <> show v <> ")") v + Right range -> return range + _ -> typeMismatch "string" v + +instance FromJSON PackageInfo where + parseJSON = getObject "package info" >=> \o -> do + vs <- getDict "versions" o + tags <- getDict "dist-tags" o + return $ PackageInfo vs tags + +instance FromJSON DistInfo where + parseJSON = getObject "dist info" >=> \o -> do + tarball <- o .: "tarball" + shasum <- o .: "shasum" + return $ DistInfo tarball shasum + +-- | Gets a hashmap from an object, or otherwise returns an empty hashmap. +getDict :: (FromJSON a) => Text -> Object -> Parser (HashMap Text a) +getDict key o = mapM parseJSON =<< (o .:? key .!= mempty) + +getObject :: String -> Value -> Parser (HashMap Text Value) +getObject _ (Object o) = return o +getObject msg v = + typeMismatch ("object (got " <> show v <> ", message " <> msg <> ")") v diff --git a/src/NixFromNpm/NpmVersion.hs b/src/NixFromNpm/NpmVersion.hs new file mode 100644 --- /dev/null +++ b/src/NixFromNpm/NpmVersion.hs @@ -0,0 +1,17 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module NixFromNpm.NpmVersion where + +import NixFromNpm.Common +import NixFromNpm.SemVer + +data GitSource = Github | Bitbucket | Gist | GitLab deriving (Show, Eq) + +data NpmVersionRange + = SemVerRange SemVerRange + | Tag Name + | NpmUri URI + | GitId GitSource Name Name (Maybe Name) + | LocalPath FilePath + deriving (Show, Eq) diff --git a/src/NixFromNpm/Parsers/Common.hs b/src/NixFromNpm/Parsers/Common.hs new file mode 100644 --- /dev/null +++ b/src/NixFromNpm/Parsers/Common.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +module NixFromNpm.Parsers.Common ( + module Text.Parsec, + module NixFromNpm.Common, + Parser, + parse, parseFull, spaces, spaces1, sstring, schar, lexeme, pInt + ) where + +import qualified Prelude as P +import Text.Parsec hiding (many, (<|>), spaces, parse, State, uncons) +import qualified Text.Parsec as Parsec + +import NixFromNpm.Common hiding (try) +import NixFromNpm.SemVer + +type Parser = ParsecT String () Identity + +-- | Given a parser and a string, attempts to parse the string. +parse :: Parser a -> Text -> Either ParseError a +parse p = Parsec.parse p "" . unpack + +parseFull :: Parser a -> Text -> Either ParseError a +parseFull p = Parsec.parse (p <* eof) "" . unpack + +-- | Consumes any spaces (not other whitespace). +spaces :: Parser String +spaces = many $ char ' ' + +-- | Consumes at least one space (not other whitespace). +spaces1 :: Parser String +spaces1 = many1 $ char ' ' + +-- | Parses the given string and any trailing spaces. +sstring :: String -> Parser String +sstring = lexeme . string + +-- | Parses the given character and any trailing spaces. +schar :: Char -> Parser Char +schar = lexeme . char + +-- | Parses `p` and any trailing spaces. +lexeme :: Parser a -> Parser a +lexeme p = p <* spaces + +-- | Parses an integer. +pInt :: Parser Int +pInt = lexeme $ P.read <$> many1 digit diff --git a/src/NixFromNpm/Parsers/NpmVersion.hs b/src/NixFromNpm/Parsers/NpmVersion.hs new file mode 100644 --- /dev/null +++ b/src/NixFromNpm/Parsers/NpmVersion.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Tools for parsing NPM version range indicators. +module NixFromNpm.Parsers.NpmVersion where + +import Data.Aeson +import qualified Data.Aeson.Types as DAT + +import NixFromNpm.SemVer +import NixFromNpm.Parsers.Common +import NixFromNpm.Parsers.SemVer +import NixFromNpm.NpmVersion + +pUri :: Parser NpmVersionRange +pUri = try $ fmap NpmUri $ do + parseURI <$> many anyChar >>= \case + Nothing -> unexpected "Not a valid URI" + Just uri -> case uriScheme uri of + "git:" -> return uri + "git+http:" -> return uri + "git+https:" -> return uri + "http:" -> return uri + "https:" -> return uri + scheme -> unexpected ("Unknown URI scheme " <> scheme) + +pGitId :: Parser NpmVersionRange +pGitId = try $ do + let sources = choice $ map (try . sstring) ["github", "gitlab", "gist", + "bitbucket"] + source <- optionMaybe (sources <* char ':') >>= \case + Just "github" -> return Github + Just "gitlab" -> return GitLab + Just "bitbucket" -> return Bitbucket + Just "gist" -> return Gist + Nothing -> return Github + account <- many1 $ noneOf ":/" + char '/' + repo <- many1 $ noneOf "#" + ref <- optionMaybe $ char '#' *> (pack <$> many1 anyChar) + return $ GitId source (pack account) (pack repo) ref + +pLocalPath :: Parser NpmVersionRange +pLocalPath = LocalPath . fromText . pack <$> do + -- The string must start with one of these prefixes. + lookAhead $ choice $ map string ["/", "./", "../", "~/"] + many anyChar + +pEmptyString :: Parser NpmVersionRange +pEmptyString = try $ do + filter (/= ' ') <$> many anyChar >>= \case + [] -> return $ SemVerRange $ Geq (0, 0, 0) + _ -> unexpected "Not an empty string" + +pTag :: Parser NpmVersionRange +pTag = do + filter (/= ' ') <$> many anyChar >>= \case + [] -> unexpected "empty string, not a tag" + tag -> return $ Tag $ pack tag + +pNpmVersionRange :: Parser NpmVersionRange +pNpmVersionRange = choice [pEmptyString, + SemVerRange <$> pSemVerRange, + pUri, + pGitId, + pLocalPath, + pTag] + +parseNpmVersionRange :: Text -> Either ParseError NpmVersionRange +parseNpmVersionRange = parse pNpmVersionRange + +instance FromJSON NpmVersionRange where + parseJSON v = case v of + String s -> case parseNpmVersionRange s of + Left err -> DAT.typeMismatch + ("valid NPM version (got " <> show v <> ")" + <> " Error: " <> show err) v + Right range -> return range + _ -> DAT.typeMismatch "string" v diff --git a/src/NixFromNpm/Parsers/SemVer.hs b/src/NixFromNpm/Parsers/SemVer.hs new file mode 100644 --- /dev/null +++ b/src/NixFromNpm/Parsers/SemVer.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +module NixFromNpm.Parsers.SemVer ( + parseSemVer, parseSemVerRange, pSemVerRange, pSemVer + ) where + +import qualified Prelude as P +import NixFromNpm.Parsers.Common +import NixFromNpm.SemVer + +-- | Parse a string as a version range, or return an error. +parseSemVerRange :: Text -> Either ParseError SemVerRange +parseSemVerRange = parse pSemVerRange + +-- | Parse a string as an explicit version, or return an error. +parseSemVer :: Text -> Either ParseError SemVer +parseSemVer = parse pSemVer + +-- | Parses a semantic version. +pSemVer :: Parser SemVer +pSemVer = wildcardToSemver <$> pWildCard + +pVersionComp :: Parser SemVerRange +pVersionComp = do + comparator <- cmp + ver <- pSemVer + let func = case comparator of {"=" -> Eq; ">" -> Gt; "<" -> Lt; + ">=" -> Geq; "<=" -> Leq; "==" -> Eq} + return $ func ver + +-- | Parses a comparison operator. +cmp :: Parser String +cmp = choice $ fmap (try . sstring) [">=", "<=", ">", "<", "==", "="] + +-- | Parses versions with an explicit range qualifier (gt, lt, etc). +pSemVerRangeSingle :: Parser SemVerRange +pSemVerRangeSingle = choice [ + wildcardToRange <$> pWildCard, + tildeToRange <$> pTildeRange, + caratToRange <$> pCaratRange, + pVersionComp + ] + +-- | Parses semantic version ranges joined with Ands and Ors. +pJoinedSemVerRange :: Parser SemVerRange +pJoinedSemVerRange = do + first <- pSemVerRangeSingle + option first $ do + lookAhead (sstring "||" <|> cmp) >>= \case + "||" -> Or first <$> (sstring "||" *> pJoinedSemVerRange) + _ -> And first <$> pJoinedSemVerRange + +-- | Parses a hyphenated range. +pHyphen :: Parser SemVerRange +pHyphen = hyphenatedRange <$> pWildCard <*> (sstring "-" *> pWildCard) + +-- | Parses a "wildcard" (which is a possibly partial semantic version). +pWildCard :: Parser Wildcard +pWildCard = try $ do + let seps = choice $ map sstring ["x", "X", "*"] + let bound = choice [seps *> pure Nothing, Just <$> pInt] + let stripNothings [Nothing] = [] + stripNothings (Just x:xs) = x : stripNothings xs + takeWhile isJust <$> sepBy1 bound (sstring ".") >>= \case + [] -> return Any + [Just n] -> return $ One n + [Just n, Just m] -> return $ Two n m + [Just n, Just m, Just o] -> return $ Three n m o + w -> unexpected ("Invalid version " ++ show w) + +-- | Parses a tilde range (~1.2.3). +pTildeRange :: Parser Wildcard +pTildeRange = do + sstring "~" + -- For some reason, including the following operators after + -- a tilde is valid, but seems to have no effect. + optional $ choice [try $ sstring ">=", sstring ">", sstring "="] + pWildCard + +-- | Parses a carat range (^1.2.3). +pCaratRange :: Parser Wildcard +pCaratRange = sstring "^" *> pWildCard + +-- | Top-level parser. Parses a semantic version range. +pSemVerRange :: Parser SemVerRange +pSemVerRange = try pHyphen <|> pJoinedSemVerRange diff --git a/src/NixFromNpm/SemVer.hs b/src/NixFromNpm/SemVer.hs new file mode 100644 --- /dev/null +++ b/src/NixFromNpm/SemVer.hs @@ -0,0 +1,117 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +module NixFromNpm.SemVer where + +import qualified Prelude as P +import Data.Text (Text) +import qualified Data.Text as T +import Data.Aeson.Parser +import Data.Aeson +import Data.Aeson.Types (typeMismatch) + +import NixFromNpm.Common + +type SemVer = (Int, Int, Int) + +-- | A partially specified semantic version. Implicitly defines +-- a range of acceptable versions, as seen in @wildcardToRange@. +data Wildcard = Any + | One Int + | Two Int Int + | Three Int Int Int + deriving (Show, Eq) + +data SemVerRange + = Eq SemVer + | Gt SemVer + | Lt SemVer + | Geq SemVer + | Leq SemVer + | And SemVerRange SemVerRange + | Or SemVerRange SemVerRange + deriving (Eq) + +renderSV :: SemVer -> Text +renderSV (x, y, z) = pack (renderSV' (x, y, z)) + +renderSV' :: SemVer -> String +renderSV' (x, y, z) = show x <> "." <> show y <> "." <> show z + +instance Show SemVerRange where + show = \case + Eq sv -> "=" <> renderSV' sv + Gt sv -> ">" <> renderSV' sv + Lt sv -> "<" <> renderSV' sv + Geq sv -> ">=" <> renderSV' sv + Leq sv -> "<=" <> renderSV' sv + And svr1 svr2 -> show svr1 <> " " <> show svr2 + Or svr1 svr2 -> show svr1 <> " || " <> show svr2 + +-- | Returns whether a given semantic version matches a range. +matches :: SemVerRange -> SemVer -> Bool +matches range ver = case range of + Eq sv -> ver == sv + Gt sv -> ver > sv + Lt sv -> ver < sv + Geq sv -> ver >= sv + Leq sv -> ver <= sv + And sv1 sv2 -> matches sv1 ver && matches sv2 ver + Or sv1 sv2 -> matches sv1 ver || matches sv2 ver + +-- | Gets the highest-matching semver in a range. +bestMatch :: SemVerRange -> [SemVer] -> Either String SemVer +bestMatch range vs = case filter (matches range) vs of + [] -> Left "No matching versions" + vs -> Right $ maximum vs + +-- | Fills in zeros in a wildcard. +wildcardToSemver :: Wildcard -> SemVer +wildcardToSemver Any = (0, 0, 0) +wildcardToSemver (One n) = (n, 0, 0) +wildcardToSemver (Two n m) = (n, m, 0) +wildcardToSemver (Three n m o) = (n, m, o) + +-- | Translates a wildcard (partially specified version) to a range. +-- Ex: 2 := >=2.0.0 <3.0.0 +-- Ex: 1.2.x := 1.2 := >=1.2.0 <1.3.0 +wildcardToRange :: Wildcard -> SemVerRange +wildcardToRange = \case + Any -> Geq (0, 0, 0) + One n -> Geq (n, 0, 0) `And` Lt (n+1, 0, 0) + Two n m -> Geq (n, m, 0) `And` Lt (n, m + 1, 0) + Three n m o -> Eq (n, m, o) + +-- | Translates a ~wildcard to a range. +-- Ex: ~1.2.3 := >=1.2.3 <1.(2+1).0 := >=1.2.3 <1.3.0 +tildeToRange :: Wildcard -> SemVerRange +tildeToRange = \case + Any -> tildeToRange (Three 0 0 0) + One n -> tildeToRange (Three n 0 0) + Two n m -> tildeToRange (Three n m 0) + Three n m o -> And (Geq (n, m, o)) (Lt (n, m + 1, 0)) + +-- | Translates a ^wildcard to a range. +-- Ex: ^1.2.x := >=1.2.0 <2.0.0 +caratToRange :: Wildcard -> SemVerRange +caratToRange = \case + One n -> And (Geq (n, 0, 0)) (Lt (n+1, 0, 0)) + Two n m -> And (Geq (n, m, 0)) (Lt (n+1, 0, 0)) + Three 0 0 n -> Eq (0, 0, n) + Three 0 n m -> And (Geq (0, n, m)) (Lt (0, n + 1, 0)) + Three n m o -> And (Geq (n, m, o)) (Lt (n+1, 0, 0)) + +-- | Translates two hyphenated wildcards to an actual range. +-- Ex: 1.2.3 - 2.3.4 := >=1.2.3 <=2.3.4 +-- Ex: 1.2 - 2.3.4 := >=1.2.0 <=2.3.4 +-- Ex: 1.2.3 - 2 := >=1.2.3 <3.0.0 +hyphenatedRange :: Wildcard -> Wildcard -> SemVerRange +hyphenatedRange wc1 wc2 = And sv1 sv2 where + sv1 = case wc1 of Any -> Geq (0, 0, 0) + One n -> Geq (n, 0, 0) + Two n m -> Geq (n, m, 0) + Three n m o -> Geq (n, m, o) + sv2 = case wc2 of Any -> Geq (0, 0, 0) -- Refers to "any version" + One n -> Lt (n+1, 0, 0) + Two n m -> Lt (n, m + 1, 0) + Three n m o -> Leq (n, m, o)