diff --git a/package.yaml b/package.yaml index 0315d21..4281d6b 100644 --- a/package.yaml +++ b/package.yaml @@ -70,20 +70,27 @@ library: dependencies: - aeson - aeson-pretty + - async - async-pool - base >= 4.7 && < 5 - bower-json - bytestring + - conduit + - conduit-extra - containers - dhall - filelock - filepath - generic-lens - github + - Glob - http-api-data - http-client + - http-client-tls - http-conduit + - language-javascript - megaparsec + - network-uri - path-pieces - persistent - persistent-sqlite @@ -95,6 +102,7 @@ library: - semver-range - spago - stm + - tar-conduit - temporary - text < 1.3 - time diff --git a/src/Language/JavaScript/Dependencies.hs b/src/Language/JavaScript/Dependencies.hs new file mode 100644 index 0000000..ef0f794 --- /dev/null +++ b/src/Language/JavaScript/Dependencies.hs @@ -0,0 +1,384 @@ +module Language.JavaScript.Dependencies + ( JSAST + , Dependencies + , jsAstDependencies + ) where + +import PacchettiBotti.Prelude + +import qualified Data.Char as Char +import qualified Data.List as List +import qualified Data.Set as Set +import qualified Data.Text as Text +import qualified Network.URI as URI +import qualified Turtle + +import Data.Set (Set) +import Language.JavaScript.Parser.AST + +type ModuleId = String +type Dependencies = Set Text + +-- | Returns a set of optionaly scoped npm packages names for a module identifier. +dependency :: ModuleId -> Dependencies +dependency moduleId +-- Paths, relative and absolute, are valid module identifiers. + | not . Turtle.absolute $ Turtle.decodeString moduleId + , not $ "." `List.isPrefixOf` moduleId +-- Packages names can be followed by a subpath. + = foldMap Set.singleton $ case Text.split (== '/') $ Text.pack moduleId of + scope : name : _ + | "@" `Text.isPrefixOf` scope + -> Just $ scope <> "/" <> name + name : _ -> Just name + _ -> Nothing + | otherwise + = mempty + +-- | A predicate for the [`require`](https://nodejs.org/api/modules.html#modules_require_id) CommonJS function. +isCommonJsRequire :: JSExpression -> Bool +isCommonJsRequire = \case + JSMemberDot (JSIdentifier _ "module") _ (JSIdentifier _ "require") -> True + JSCallExpressionDot (JSIdentifier _ "module") _ (JSIdentifier _ "require") -> True + JSIdentifier _ "require" -> True + _ -> False + +-- | Collects all third party dependencies of a JavaScript AST. +jsAstDependencies :: JSAST -> Dependencies +jsAstDependencies = \case + JSAstProgram statements _ -> + foldMap jsStatementDependencies statements + JSAstModule items _ -> + foldMap jsModuleItemDependencies items + JSAstStatement statement _ -> + jsStatementDependencies statement + JSAstExpression expression _ -> + jsExpressionDependencies expression + JSAstLiteral expression _ -> + jsExpressionDependencies expression + +jsModuleItemDependencies :: JSModuleItem -> Dependencies +jsModuleItemDependencies = \case + JSModuleImportDeclaration _ declaration + | JSImportDeclaration _ (JSFromClause _ _ moduleId) _ <- declaration + , not $ URI.isURI moduleId + -> dependency $ unescape moduleId + | JSImportDeclarationBare _ moduleId _ <- declaration + , not $ URI.isURI moduleId + -> dependency $ unescape moduleId + | otherwise -> mempty + JSModuleExportDeclaration {} -> mempty + JSModuleStatementListItem statement -> + jsStatementDependencies statement + +jsStatementDependencies :: JSStatement -> Dependencies +jsStatementDependencies = \case + JSStatementBlock _ statements _ _ -> + foldMap jsStatementDependencies statements + JSBreak {} -> mempty + JSLet _ declarations _ -> + foldMapJSCommaList jsExpressionDependencies declarations + JSClass _ _ super _ methods _ _ -> + jsClassHeritageDependencies super + <> foldMap jsClassElementDependencies methods + JSConstant _ declarations _ -> + foldMapJSCommaList jsExpressionDependencies declarations + JSContinue {} -> mempty + JSDoWhile _ body _ _ condition _ _ -> + jsStatementDependencies body + <> jsExpressionDependencies condition + JSFor _ _ declarations _ condition _ update _ body -> + jsForStatementDependencies declarations condition update body + JSForIn _ _ declaration _ expression _ body -> + jsForInStatementDependencies declaration expression body + JSForVar _ _ _ declarations _ condition _ update _ body -> + jsForStatementDependencies declarations condition update body + JSForVarIn _ _ _ declaration _ expression _ body -> + jsForInStatementDependencies declaration expression body + JSForLet _ _ _ declarations _ condition _ update _ body -> + jsForStatementDependencies declarations condition update body + JSForLetIn _ _ _ declaration _ expression _ body -> + jsForInStatementDependencies declaration expression body + JSForLetOf _ _ _ declaration _ expression _ body -> + jsForOfStatementDependencies declaration expression body + JSForConst _ _ _ declarations _ condition _ update _ body -> + jsForStatementDependencies declarations condition update body + JSForConstIn _ _ _ declaration _ expression _ body -> + jsForInStatementDependencies declaration expression body + JSForConstOf _ _ _ declaration _ expression _ body -> + jsForOfStatementDependencies declaration expression body + JSForOf _ _ declaration _ expression _ body -> + jsForOfStatementDependencies declaration expression body + JSForVarOf _ _ _ declaration _ expression _ body -> + jsForOfStatementDependencies declaration expression body + JSFunction _ _ _ parameters _ body _ -> + foldMapJSCommaList jsExpressionDependencies parameters + <> jsBlockDependencies body + JSGenerator _ _ _ _ parameters _ body _ -> + foldMapJSCommaList jsExpressionDependencies parameters + <> jsBlockDependencies body + JSIf _ _ condition _ body -> + jsExpressionDependencies condition + <> jsStatementDependencies body + JSIfElse _ _ condition _ consequent _ alternative -> + jsExpressionDependencies condition + <> jsStatementDependencies consequent + <> jsStatementDependencies alternative + JSLabelled _ _ statement -> + jsStatementDependencies statement + JSEmptyStatement {} -> mempty + JSExpressionStatement expression _ -> + jsExpressionDependencies expression + JSAssignStatement assignee _ assigned _ -> + jsExpressionDependencies assignee + <> jsExpressionDependencies assigned + JSMethodCall function _ arguments _ _ + | isCommonJsRequire function + , JSLOne (JSStringLiteral _ moduleId) <- arguments + -> dependency $ unescape moduleId + | otherwise + -> jsExpressionDependencies function + <> foldMapJSCommaList jsExpressionDependencies arguments + JSReturn _ optionalExpression _ -> + foldMap jsExpressionDependencies optionalExpression + JSSwitch _ _ scrutinee _ _ cases _ _ -> + jsExpressionDependencies scrutinee + <> foldMap jsSwitchPartsDependencies cases + where + jsSwitchPartsDependencies = \case + JSCase _ pattern _ body -> + jsExpressionDependencies pattern + <> foldMap jsStatementDependencies body + JSDefault _ _ body -> + foldMap jsStatementDependencies body + JSThrow _ exception _ -> + jsExpressionDependencies exception + JSTry _ block jsTryCatches jstTryFinally -> + jsBlockDependencies block + <> foldMap jsTryCatchDependencies jsTryCatches + <> jsTryFinallyDependencies jstTryFinally + where + jsTryCatchDependencies = \case + JSCatch _ _ exception _ handler -> + jsExpressionDependencies exception + <> jsBlockDependencies handler + JSCatchIf {} -> mempty -- non standard + jsTryFinallyDependencies = \case + JSFinally _ handler -> jsBlockDependencies handler + JSNoFinally -> mempty + JSVariable _ declarations _ -> + foldMapJSCommaList jsExpressionDependencies declarations + JSWhile _ _ condition _ body -> + jsExpressionDependencies condition + <> jsStatementDependencies body + JSWith _ _ scope _ body _ -> + jsExpressionDependencies scope + <> jsStatementDependencies body + +foldMapJSCommaList :: Monoid m => (a -> m) -> JSCommaList a -> m +foldMapJSCommaList f = \case + JSLCons xs _ x -> + foldMapJSCommaList f xs <> f x + JSLOne value -> f value + JSLNil -> mempty + +foldMapJSCommaTrailingList :: Monoid m => (a -> m) -> JSCommaTrailingList a -> m +foldMapJSCommaTrailingList f = \case + JSCTLComma xs _ -> foldMapJSCommaList f xs + JSCTLNone xs -> foldMapJSCommaList f xs + +jsForStatementDependencies + :: JSCommaList JSExpression + -> JSCommaList JSExpression + -> JSCommaList JSExpression + -> JSStatement + -> Dependencies +jsForStatementDependencies declarations condition update body = + foldMapJSCommaList jsExpressionDependencies declarations + <> foldMapJSCommaList jsExpressionDependencies condition + <> foldMapJSCommaList jsExpressionDependencies update + <> jsStatementDependencies body + +jsForInStatementDependencies :: JSExpression -> JSExpression -> JSStatement -> Dependencies +jsForInStatementDependencies declaration expression body = + jsExpressionDependencies declaration + <> jsExpressionDependencies expression + <> jsStatementDependencies body + +jsForOfStatementDependencies :: JSExpression -> JSExpression -> JSStatement -> Dependencies +jsForOfStatementDependencies declaration expression body = + jsExpressionDependencies declaration + <> jsExpressionDependencies expression + <> jsStatementDependencies body + +jsBlockDependencies :: JSBlock -> Dependencies +jsBlockDependencies (JSBlock _ statements _) = + foldMap jsStatementDependencies statements + +jsExpressionDependencies :: JSExpression -> Dependencies +jsExpressionDependencies = \case + JSIdentifier {} -> mempty + JSDecimal {} -> mempty + JSLiteral {} -> mempty + JSHexInteger {} -> mempty + JSOctal {} -> mempty + JSStringLiteral {} -> mempty + JSRegEx {} -> mempty + JSArrayLiteral _ array _ -> flip foldMap array $ \case + JSArrayElement expression -> + jsExpressionDependencies expression + JSArrayComma _ -> mempty + JSAssignExpression assignee _ assigned -> + jsExpressionDependencies assignee + <> jsExpressionDependencies assigned + JSCallExpression function _ arguments _ + | isCommonJsRequire function + , JSLOne (JSStringLiteral _ moduleId) <- arguments + -> dependency $ unescape moduleId + | otherwise + -> jsExpressionDependencies function + <> foldMapJSCommaList jsExpressionDependencies arguments + JSCallExpressionDot receiver _ property -> + jsExpressionDependencies receiver + <> jsExpressionDependencies property + JSCallExpressionSquare receiver _ property _ -> + jsExpressionDependencies receiver + <> jsExpressionDependencies property + JSClassExpression _ _ super _ methods _ -> + jsClassHeritageDependencies super + <> foldMap jsClassElementDependencies methods + JSCommaExpression lhs _ rhs -> + jsExpressionDependencies lhs + <> jsExpressionDependencies rhs + JSExpressionBinary lhs _ rhs -> + jsExpressionDependencies lhs + <> jsExpressionDependencies rhs + JSExpressionParen _ expression _ -> + jsExpressionDependencies expression + JSExpressionPostfix expression _ -> + jsExpressionDependencies expression + JSExpressionTernary condition _ consequent _ alternative -> + jsExpressionDependencies condition + <> jsExpressionDependencies consequent + <> jsExpressionDependencies alternative + JSArrowExpression parameters _ body -> + jsArrowParameterListDependencies parameters + <> jsStatementDependencies body + where + jsArrowParameterListDependencies = \case + JSUnparenthesizedArrowParameter {} -> mempty + JSParenthesizedArrowParameterList _ parameters' _ -> + foldMapJSCommaList jsExpressionDependencies parameters' + JSFunctionExpression _ _ _ parameters _ body -> + foldMapJSCommaList jsExpressionDependencies parameters + <> jsBlockDependencies body + JSGeneratorExpression _ _ _ _ parameters _ body -> + foldMapJSCommaList jsExpressionDependencies parameters + <> jsBlockDependencies body + JSMemberDot receiver _ property -> + jsExpressionDependencies receiver + <> jsExpressionDependencies property + JSMemberExpression function _ arguments _ + | isCommonJsRequire function + , JSLOne (JSStringLiteral _ moduleId) <- arguments + -> dependency $ unescape moduleId + | otherwise + -> jsExpressionDependencies function + <> foldMapJSCommaList jsExpressionDependencies arguments + JSMemberNew _ constructor _ arguments _ -> + jsExpressionDependencies constructor + <> foldMapJSCommaList jsExpressionDependencies arguments + JSMemberSquare receiver _ property _ -> + jsExpressionDependencies receiver + <> jsExpressionDependencies property + JSNewExpression _ constructor -> + jsExpressionDependencies constructor + JSObjectLiteral _ properties _ -> + foldMapJSCommaTrailingList jsObjectPropertyDependencies properties + where + jsObjectPropertyDependencies = \case + JSPropertyNameandValue name _ value -> + jsPropertyNameDependencies name + <> foldMap jsExpressionDependencies value + JSPropertyIdentRef {} -> mempty + JSObjectMethod method -> + jsMethodDefinitionDependencies method + JSSpreadExpression _ expression -> + jsExpressionDependencies expression + JSTemplateLiteral optionalTag _ _ parts -> + foldMap jsExpressionDependencies optionalTag + <> foldMap jsTemplatePartDependencies parts + where + jsTemplatePartDependencies (JSTemplatePart expression _ _ ) = + jsExpressionDependencies expression + JSUnaryExpression _ expression -> + jsExpressionDependencies expression + JSVarInitExpression _ (JSVarInit _ initializer) -> + jsExpressionDependencies initializer + JSVarInitExpression _ JSVarInitNone -> mempty + JSYieldExpression _ optionalExpression -> + foldMap jsExpressionDependencies optionalExpression + JSYieldFromExpression _ _ expression -> + jsExpressionDependencies expression + +jsClassHeritageDependencies :: JSClassHeritage -> Dependencies +jsClassHeritageDependencies = \case + JSExtends _ super -> jsExpressionDependencies super + JSExtendsNone -> mempty + +jsClassElementDependencies :: JSClassElement -> Dependencies +jsClassElementDependencies = \case + JSClassInstanceMethod method -> + jsMethodDefinitionDependencies method + JSClassStaticMethod _ method -> + jsMethodDefinitionDependencies method + JSClassSemi _ -> mempty + +jsMethodDefinitionDependencies :: JSMethodDefinition -> Dependencies +jsMethodDefinitionDependencies = \case + JSMethodDefinition name _ parameters _ body -> + jsPropertyNameDependencies name + <> foldMapJSCommaList jsExpressionDependencies parameters + <> jsBlockDependencies body + JSGeneratorMethodDefinition _ name _ parameters _ body -> + jsPropertyNameDependencies name + <> foldMapJSCommaList jsExpressionDependencies parameters + <> jsBlockDependencies body + JSPropertyAccessor _ name _ parameters _ body -> + jsPropertyNameDependencies name + <> foldMapJSCommaList jsExpressionDependencies parameters + <> jsBlockDependencies body + +jsPropertyNameDependencies :: JSPropertyName -> Dependencies +jsPropertyNameDependencies = \case + JSPropertyIdent {} -> mempty + JSPropertyString {} -> mempty + JSPropertyNumber {} -> mempty + JSPropertyComputed _ expression _ -> + jsExpressionDependencies expression + +unescape :: String -> String +unescape str = go $ List.drop 1 str + where + go ('\\' : 'b' : xs) = '\b' : go xs + go ('\\' : 'f' : xs) = '\f' : go xs + go ('\\' : 'n' : xs) = '\n' : go xs + go ('\\' : 'r' : xs) = '\r' : go xs + go ('\\' : 't' : xs) = '\t' : go xs + go ('\\' : 'v' : xs) = '\v' : go xs + go ('\\' : '0' : xs) = '\0' : go xs + go ('\\' : 'x' : a : b : xs) = Char.chr (a' + b') : go xs + where + a' = 16 * Char.digitToInt a + b' = Char.digitToInt b + go ('\\' : 'u' : a : b : c : d : xs) = Char.chr (a' + b' + c' + d') : go xs + where + a' = 16 * 16 * 16 * Char.digitToInt a + b' = 16 * 16 * Char.digitToInt b + c' = 16 * Char.digitToInt c + d' = Char.digitToInt d + go ('\\' : x : xs) = x : go xs + go "\"" = "" + go "'" = "" + go (x : xs) = x : go xs + go "" = "" diff --git a/src/PacchettiBotti/Env.hs b/src/PacchettiBotti/Env.hs index 82ab4b4..52cffb6 100644 --- a/src/PacchettiBotti/Env.hs +++ b/src/PacchettiBotti/Env.hs @@ -22,6 +22,7 @@ type HasEnv env = , HasType GitHub.Auth env , HasType DB.Handle env , HasType Bus env + , HasResourceMap env ) data Env = Env @@ -31,11 +32,15 @@ data Env = Env , envDB :: !DB.Handle -- | Main message bus. It is write-only so you should use `spawnThread` to read from it , envBus :: !Bus + , envResourceMap :: ResourceMap } deriving (Generic) instance HasLogFunc Env where logFuncL = lens envLogFunc (\x y -> x { envLogFunc = y }) +instance HasResourceMap Env where + resourceMapL = lens envResourceMap (\x y -> x { envResourceMap = y }) + data Message = HourlyUpdate | DailyUpdate diff --git a/src/PacchettiBotti/Registry/Bower.hs b/src/PacchettiBotti/Registry/Bower.hs index f9fd158..7b5a6fa 100644 --- a/src/PacchettiBotti/Registry/Bower.hs +++ b/src/PacchettiBotti/Registry/Bower.hs @@ -3,20 +3,33 @@ module PacchettiBotti.Registry.Bower where import PacchettiBotti.Prelude +import qualified Control.Concurrent.Async as Async import qualified Data.Aeson as Json +import qualified Data.Conduit.Combinators as Conduit +import qualified Data.Conduit.Tar as Tar +import qualified Data.Conduit.Zlib as Compression (ungzip) import qualified Data.List as List import qualified Data.Map.Strict as Map import qualified Data.Set as Set import qualified Data.Text as Text -import qualified Network.HTTP.Simple as Http +import qualified Language.JavaScript.Parser as JavaScript +import qualified Network.HTTP.Client as Http +import qualified Network.HTTP.Client.TLS as Http (getGlobalManager) +import qualified Network.HTTP.Conduit as Http import qualified RIO.Time as Time import qualified Spago.Dhall as Dhall +import qualified System.FilePath.Glob as Glob import qualified Text.Megaparsec as Parse import qualified Turtle import qualified UnliftIO.Directory as Directory import qualified Web.Bower.PackageMeta as Bower -import Web.Bower.PackageMeta (PackageMeta (..)) +import Control.Monad.IO.Class (liftIO) +import Data.Aeson (FromJSON(..), (.!=), (.:!)) +import Data.Conduit (runConduit, (.|)) +import Language.JavaScript.Dependencies (jsAstDependencies) +import System.IO.Error (isDoesNotExistError) +import Web.Bower.PackageMeta (PackageMeta (..)) import qualified PacchettiBotti.DB as DB import qualified PacchettiBotti.GitHub as GitHub @@ -26,6 +39,23 @@ import qualified PacchettiBotti.Static as Static type Expr = Dhall.DhallExpr Dhall.Import +type NativeDependencies = Map Text Text + +newtype NpmDependencies = NpmDependencies { npmDependencies :: NativeDependencies } +newtype NpmDevDependencies = NpmDevDependencies { npmDevDependencies :: NativeDependencies } + +data NpmPackageJson = + NpmPackageJson + { npmPackageJsonDependencies :: NativeDependencies + , npmPackageJsonDevDependencies :: NativeDependencies + } + +instance FromJSON NpmPackageJson where + parseJSON = Json.withObject "npm package.json" $ \package -> + NpmPackageJson + <$> package .:! "dependencies" .!= mempty + <*> package .:! "devDependencies" .!= mempty + registryRepo :: GitHub.Address registryRepo = GitHub.Address "purescript" "registry" @@ -79,25 +109,30 @@ writeMissingBowerManifests path = do let (DB.Address owner repo) = releaseAddress let (Tag tag) = releaseTag unless (Set.member (releaseAddress, releaseTag) toSkip) $ do - let url = "https://raw.githubusercontent.com/" + let releaseTarballUrl = "https://github.com/" <> GitHub.untagName owner <> "/" <> GitHub.untagName repo <> "/" - <> tag <> "/bower.json" - -- FIXME: download the package.json too? - -- See https://github.com/purescript/registry/issues/20 + <> "archive/" + <> tag <> ".tar.gz" let packageInfo = displayShow releaseAddress <> "@" <> display tag let versionPath = packageDir <> "/" <> tag <> ".dhall" - result <- try $ do + result <- try . withSystemTempDirectory (Text.unpack $ GitHub.untagName repo <> "-" <> tag) $ \tmp -> do -- TODO: try to fetch the spago.dhall first and see if it conforms -- to the registry schema. Not right now, there's no package doing it - logInfo $ "Fetching Bower info for " <> packageInfo - req <- Http.parseRequest $ Text.unpack url - packageMeta <- Http.getResponseBody <$> Http.httpJSON req - logDebug "Checking self-contained dependencies" + logInfo $ "Fetching release tarball for " <> packageInfo + req <- Http.parseRequest $ Text.unpack releaseTarballUrl + res <- Http.responseBody <$> (Http.http req =<< liftIO Http.getGlobalManager) + runConduit $ res .| Compression.ungzip .| Tar.untar (Tar.restoreFileInto tmp) .| Conduit.mapM_ liftIO + packageMeta <- either error pure <=< liftIO $ Json.eitherDecodeFileStrict' "bower.json" + logDebug "Checking self-contained Bower dependencies" unlessM (selfContainedDependencies packageMeta) $ - error "Dependencies not self-contained on purescript packages!" + error "Bower dependencies not self-contained on PureScript packages!" + logInfo $ "Parsing foreign modules for JavaScript dependencies" + npmPackageJson <- either error pure <=< liftIO $ Json.eitherDecodeFileStrict "package.json" `catch` \e -> + if isDoesNotExistError e then pure (Right $ NpmPackageJson mempty mempty) else throwIO e + (npmDependencies, npmDevDependencies) <- nativeDependencies tmp npmPackageJson logInfo $ "Writing package definition for " <> packageInfo - writeTextFile versionPath (toDhallSource packageMeta tag) + writeTextFile versionPath (toDhallSource packageMeta npmDependencies npmDevDependencies tag) Dhall.format versionPath case result of @@ -135,8 +170,72 @@ bowerPackages bowerPackagesMap = fromRight mempty $ Json.eitherDecodeStrict Static.bowerPackagesJson -toDhallSource :: PackageMeta -> Text -> Text -toDhallSource PackageMeta{..} version = Text.unlines +nativeDependencies :: MonadIO m => String -> NpmPackageJson -> m (NpmDependencies, NpmDevDependencies) +nativeDependencies root NpmPackageJson{..} = liftIO $ do + (usedDependencies, usedDevDependencies) <- Async.concurrently + (globUsedDependencies "src/**/*.js") + (globUsedDependencies "test/**/*.js") + let (unsavedNpmDependencies, npmDependencies) = partitionUsedDependencies npmPackageJsonDependencies usedDependencies + (unsavedNpmDevDependencies, npmDevDependencies) = partitionUsedDependencies npmPackageJsonDevDependencies usedDevDependencies + unless (null unsavedNpmDependencies && null (Set.difference unsavedNpmDevDependencies usedDependencies)) $ do + error "Npm dependencies not saved in package.json!" + pure $ (NpmDependencies{..}, NpmDevDependencies{..}) + where + globUsedDependencies pattern = do + sources <- Glob.globDir1 (Glob.compile pattern) root + dependencies <- mconcat <$> Async.mapConcurrently (fmap jsAstDependencies . JavaScript.parseFileUtf8) sources + pure $ Set.difference dependencies builtinNodeJsModules + partitionUsedDependencies dependencies = foldMap $ \k -> + case Map.lookup k dependencies of + Nothing -> (Set.singleton k, mempty) + Just v -> (mempty, Map.singleton k v) + builtinNodeJsModules = + [ "assert" + , "async_hooks" + , "buffer" + , "child_process" + , "cluster" + , "console" + , "constants" + , "crypto" + , "dgram" + , "dns" + , "domain" + , "events" + , "fs" + , "http" + , "http2" + , "https" + , "inspector" + , "module" + , "net" + , "os" + , "path" + , "perf_hooks" + , "process" + , "punycode" + , "querystring" + , "readline" + , "repl" + , "stream" + , "string_decoder" + , "sys" + , "timers" + , "tls" + , "trace_events" + , "tty" + , "url" + , "util" + , "v8" + , "vm" + , "wasi" + , "worker_threads" + , "zlib" + ] + + +toDhallSource :: PackageMeta -> NpmDependencies -> NpmDevDependencies -> Text -> Text +toDhallSource PackageMeta{..} NpmDependencies{..} NpmDevDependencies{..} version = Text.unlines [ "let Registry = ../../v1/Registry.dhall" , "in Registry.Package::{" , ", name = " <> (tshow . stripPurescriptPrefix . Bower.runPackageName) bowerName @@ -150,21 +249,35 @@ toDhallSource PackageMeta{..} version = Text.unlines Nothing -> "Git { url = " <> tshow repositoryUrl <> ", version = " <> version <> " })" Just (owner, repo) -> "GitHub { owner = " <> tshow owner <> ", repo = " <> tshow repo <> ", version = " <> tshow version <> " })" - , ", targets = toMap { " - , if List.null bowerDependencies - then ", src = Registry.Target::{ sources = [ \"src/**/*.purs\" ], dependencies = [] : Registry.Dependencies }" - else ", src = Registry.Target::{ sources = [ \"src/**/*.purs\" ], dependencies = toMap { " <> Text.intercalate ", " (mkDep <$> bowerDependencies) <> " }}" - , if List.null bowerDevDependencies - then "" - else ", test = Registry.Target::{ sources = [ \"src/**/*.purs\", \"test/**/*.purs\" ], dependencies = toMap { " <> Text.intercalate ", " (mkDep <$> bowerDevDependencies) <> " }}" - , " }" - , " }" + , ", targets = toMap {" + , ", src = Registry.Target::{" + , " sources = [ \"src/**/*.purs\" ] " + , ", dependencies = " <> mkDependenciesMap (mkBowerDep <$> bowerDependencies) + , ", nativeDependencies = " <> mkDependenciesMap (mkDep <$> Map.toList npmDependencies) + , "}" + , if List.null bowerDevDependencies && Map.null npmDevDependencies then "" else Text.unlines + [ ", test = Registry.Target::{" + , " sources = [ \"src/**/*.purs\", \"test/**/*.purs\" ] " + , ", dependencies = " <> mkDependenciesMap (mkBowerDep <$> bowerDependencies <> bowerDevDependencies) + , ", nativeDependencies = " <> mkDependenciesMap (mkDep <$> Map.toList (npmDependencies <> npmDevDependencies)) + , "}" + , "}" + ] ] where + mkBowerDep (packageName, versionRange) = + mkDep + ( stripPurescriptPrefix $ Bower.runPackageName packageName + , Bower.runVersionRange versionRange + ) mkDep (packageName, versionRange) - = "`" <> stripPurescriptPrefix (Bower.runPackageName packageName) + = "`" <> packageName <> "` = " - <> tshow (Bower.runVersionRange versionRange) + <> tshow versionRange + mkDependenciesMap dependencies = + if List.null dependencies + then "[] : Registry.Dependencies" + else "toMap { " <> Text.intercalate ", " dependencies <> " }" parseRepo :: Text -> Maybe (Text, Text) @@ -191,4 +304,4 @@ stripPurescriptPrefix name = fromMaybe name $ Text.stripPrefix "purescript-" nam mkReleaseIndex :: [DB.Release] -> Text mkReleaseIndex releases = "{ " <> foldMap mkReleaseLine releases <> " }" where - mkReleaseLine DB.Release{ releaseTag = Tag tag } = "\n, `" <> tag <> "` = ./" <> tag <> ".dhall" \ No newline at end of file + mkReleaseLine DB.Release{ releaseTag = Tag tag } = "\n, `" <> tag <> "` = ./" <> tag <> ".dhall" diff --git a/src/PacchettiBotti/RunEnv.hs b/src/PacchettiBotti/RunEnv.hs index 7d65d97..eba46d8 100644 --- a/src/PacchettiBotti/RunEnv.hs +++ b/src/PacchettiBotti/RunEnv.hs @@ -20,7 +20,7 @@ withEnv action = withBinaryFile "pacchettibotti.log" AppendMode $ \configHandle withLogFunc logStderr $ \logFuncConsole -> withLogFunc logFile $ \logFuncFile -> let envLogFunc = logFuncConsole <> logFuncFile - in runRIO envLogFunc $ do + in runRIO envLogFunc $ withResourceMap $ \envResourceMap -> do -- We always want to run in UTF8 anyways liftIO $ GHC.IO.Encoding.setLocaleEncoding GHC.IO.Encoding.utf8 -- Stop `git` from asking for input, not gonna happen @@ -44,4 +44,4 @@ withEnv action = withBinaryFile "pacchettibotti.log" AppendMode $ \configHandle let envLogContext = LogContext "/" let env = Env{..} - runRIO env action \ No newline at end of file + runRIO env action diff --git a/stack.yaml b/stack.yaml index 7b948b1..406ea8c 100644 --- a/stack.yaml +++ b/stack.yaml @@ -43,6 +43,7 @@ extra-deps: - unliftio-0.2.12@sha256:b089fbc2ff2628a963c2c4b12143f2020874e3e5144ffd6c62b25639a0ca1483 - hspec-megaparsec-2.0.1@sha256:7f26ab334eaa653054766110cf259c31314d1c2ec170270e56101e344ce65ef9,2163 - with-utf8-1.0.0.0@sha256:686e47588986d8080451b4e617118b579487dd4e085bba7bb36fac4198c90ae6,2480 +- language-javascript-0.7.0.0 allow-newer: true nix: packages: [zlib]