packages feed

nixfromnpm 0.1.0.4 → 0.1.0.5

raw patch · 12 files changed

+1305/−11 lines, 12 files

Files

nixfromnpm.cabal view
@@ -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
src/Main.hs view
@@ -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 <packagename> [-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"+      }
+ src/NixFromNpm.hs view
@@ -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
+ src/NixFromNpm/Common.hs view
@@ -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
+ src/NixFromNpm/ConvertToNix.hs view
@@ -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 <nixpkgs> {}}:",+  "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
+ src/NixFromNpm/NpmLookup.hs view
@@ -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)
+ src/NixFromNpm/NpmTypes.hs view
@@ -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
+ src/NixFromNpm/NpmVersion.hs view
@@ -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)
+ src/NixFromNpm/Parsers/Common.hs view
@@ -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
+ src/NixFromNpm/Parsers/NpmVersion.hs view
@@ -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
+ src/NixFromNpm/Parsers/SemVer.hs view
@@ -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
+ src/NixFromNpm/SemVer.hs view
@@ -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)