-- Copyright (C) 2017 Red Hat, Inc.
--
-- This library is free software; you can redistribute it and/or
-- modify it under the terms of the GNU Lesser General Public
-- License as published by the Free Software Foundation; either
-- version 2.1 of the License, or (at your option) any later version.
--
-- This library is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
-- Lesser General Public License for more details.
--
-- You should have received a copy of the GNU Lesser General Public
-- License along with this library; if not, see .
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module BDCS.Build.NPM(rebuildNPM)
where
import Control.Monad(forM_, void, when)
import Control.Monad.Except(MonadError, throwError)
import Control.Monad.IO.Class(MonadIO, liftIO)
import Control.Monad.Trans.Resource(MonadBaseControl, MonadResource)
import Data.Bifunctor(bimap)
import Data.Bits((.|.))
import Data.Conduit(sourceToList)
import Data.List(scanl')
import qualified Data.Text as T
import Data.Time.Clock(UTCTime, getCurrentTime)
import Data.Time.Clock.POSIX(utcTimeToPOSIXSeconds)
import Database.Esqueleto
import System.FilePath((>), joinPath, makeRelative, splitDirectories)
import System.Posix.Files(directoryMode, symbolicLinkMode)
import BDCS.Builds(insertBuild, insertBuildKeyValue)
import BDCS.DB
import BDCS.Files(associateFilesWithBuild, sourceIdToFiles)
import BDCS.KeyType
import BDCS.Label.FileLabels(apply)
import BDCS.NPM.SemVer(SemVer, SemVerRangeSet, parseSemVer, parseSemVerRangeSet, satisfies, toText)
{-# ANN rebuildNPM ("HLint: ignore Use ." :: String) #-}
rebuildNPM :: (MonadBaseControl IO m, MonadIO m, MonadError String m, MonadResource m) => Key Sources -> SqlPersistT m [Key Builds]
rebuildNPM sourceId = do
-- get the name and version for this source
(name, version) <- getNameVer
-- figure out what sources satisfy the dependencies for this package
-- Each list element represents one of the dependencies, within those each
-- element is a source ID that satisfies the dependencies. sequence the whole thing
-- to get all of the possible combinations that satisfy all dependencies.
dependencies <- sequence <$> getDeps
-- get the list of files for this source
sourceFiles <- sourceToList $ sourceIdToFiles sourceId
-- For each dependency list, create a new build
mapM (relink sourceFiles (name, version)) dependencies
where
copyFile :: Files -> FilePath -> Files
copyFile f@Files{..} newPath = let
basePath = makeRelative "/package" $ T.unpack filesPath
in
f {filesPath = T.pack $ newPath > basePath}
getDeps :: (MonadIO m, MonadError String m) => SqlPersistT m [[(T.Text, SemVer)]]
getDeps = do
-- fetch the list of dependencies
-- the dependencies for a given source are stored as key/vals, k="dependency", v=package name, e=version expression
kvs <- select $ from $ \(kv `InnerJoin` skv) -> do
on $ kv ^. KeyValId ==. skv ^. SourceKeyValuesKey_val_id
where_ $ skv ^. SourceKeyValuesSource_id ==. val sourceId &&.
kv ^. KeyValKey_value ==. val (TextKey "dependency")
return (kv ^. KeyValVal_value, kv ^. KeyValExt_value)
depnames <- mapM (unpackName . fst) kvs
depvers <- mapM (unpackVersion . snd) kvs
mapM getOneDep $ zip depnames depvers
where
unpackName name = maybe (throwError "Invalid dependency name") return $ unValue name
unpackVersion ver = do
unmaybe <- maybe (throwError "Invalid dependency version") return $ unValue ver
either (throwError . show) return $ parseSemVerRangeSet unmaybe
getOneDep :: (MonadIO m, MonadError String m) => (T.Text, SemVerRangeSet) -> SqlPersistT m [(T.Text, SemVer)]
getOneDep (name, range) = do
-- Get all npm Sources records that match the name
sources <- select $ from $ \(p `InnerJoin` s `InnerJoin` skv `InnerJoin` kv) -> do
on $ kv ^. KeyValId ==. skv ^. SourceKeyValuesKey_val_id
on $ s ^. SourcesId ==. skv ^. SourceKeyValuesSource_id
on $ p ^. ProjectsId ==. s ^. SourcesProject_id
where_ $ kv ^. KeyValKey_value ==. val (TextKey "npm") &&.
p ^. ProjectsName ==. val name
return $ s ^. SourcesVersion
-- if nothing is found, that's an error
when (null sources) $ throwError $ "Unable to satisfy dependency for " ++ show name ++ " " ++ show range
-- Parse the versions into SemVers
versions <- mapM unpackVersion sources
let filteredVersions = filter (`satisfies` range) versions
return $ zip (repeat name) filteredVersions
where
unpackVersion ver = either (throwError . show) return $ parseSemVer $ unValue ver
getNameVer :: (MonadIO m, MonadError String m) => SqlPersistT m (T.Text, T.Text)
getNameVer = do
nv <- select $ from $ \(sources `InnerJoin` projects) -> do
on $ sources ^. SourcesProject_id ==. projects ^. ProjectsId
where_ $ sources ^. SourcesId ==. val sourceId
limit 1
return (projects ^. ProjectsName, sources ^. SourcesVersion)
case nv of
hd:_ -> return $ bimap unValue unValue hd
_ -> throwError $ "No such source id " ++ show sourceId
relink :: (MonadBaseControl IO m, MonadIO m) => [Files] -> (T.Text, T.Text) -> [(T.Text, SemVer)] -> SqlPersistT m (Key Builds)
relink sourceFiles (name, ver) depList = do
buildTime <- liftIO getCurrentTime
-- Create a directory for this module in /usr/lib/node_modules
-- NB: In order to allow multiple versions of an npm module to be included in the same export,
-- the /usr/lib/node_modules name is @ instead of just ,
-- and none of the bin or man symlinks are installed to /usr/bin and /usr/share/man. It's up to the
-- export to determine which modules need to be accessible system-wide and to create the bin and man
-- symlinks and the /usr/lib/node_modules/ directory.
let module_dir = "/" > "usr" > "lib" > "node_modules" > T.unpack (T.concat [name, "@", ver])
-- Create the /usr/lib/node_modules/ directory, and a node_modules directory under that
moduleDirsIds <- mkdirs buildTime $ module_dir > "node_modules"
-- Copy everything from the Source into the module directory
let packageFiles = map (`copyFile` module_dir) sourceFiles
packageFilesIds <- mapM (\file -> (file,) <$> insert file) packageFiles
-- For each of the dependencies, create a symlink from the /usr/lib/node_modules/@ directory
-- to this module's node_modules directory.
deplinkFilesIds <- mapM (createDepLink module_dir buildTime) depList
-- Apply the file-based labels
let buildFilesIds = moduleDirsIds ++ packageFilesIds ++ deplinkFilesIds
void $ apply buildFilesIds
-- Create a build and add the files to it
createBuild $ map snd buildFilesIds
where
createDepLink :: MonadIO m => FilePath -> UTCTime -> (T.Text, SemVer) -> SqlPersistT m (Files, Key Files)
createDepLink module_dir buildTime (depname, depver) = let
verstr = toText depver
source = T.pack $ joinPath ["/", "usr", "lib", "node_modules", T.unpack (T.concat [depname, "@", verstr])]
dest = T.pack $ joinPath [module_dir, "node_modules", T.unpack depname]
link = Files dest "root" "root" (floor $ utcTimeToPOSIXSeconds buildTime) Nothing (fromIntegral $ symbolicLinkMode .|. 0o0644) 0 (Just source)
in
(link,) <$> insert link
mkdirs :: MonadIO m => UTCTime -> FilePath -> SqlPersistT m [(Files, Key Files)]
mkdirs buildTime path = mapM mkdir $ scanl' (>) "/" $ splitDirectories path
where
mkdir :: MonadIO m => FilePath -> SqlPersistT m (Files, Key Files)
mkdir subPath = let
newdir = Files (T.pack subPath) "root" "root" (floor $ utcTimeToPOSIXSeconds buildTime) Nothing (fromIntegral $ directoryMode .|. 0o0755) 0 Nothing
in
(newdir,) <$> insert newdir
createBuild :: MonadIO m => [Key Files] -> SqlPersistT m (Key Builds)
createBuild fids = do
buildTime <- liftIO getCurrentTime
-- There is no equivalent to epoch or release in npm, so use 0 and ""
let epoch = 0
let release = ""
-- FIXME there are some npm packages that are arch-specific but for now ignore those
let arch = "noarch"
-- FIXME changelog?
let changelog = ""
-- FIXME ??
let build_config_ref = "BUILD_CONFIG_REF"
let build_env_ref = "BUILD_ENV_REF"
buildId <- insertBuild $ Builds sourceId epoch release arch buildTime changelog build_config_ref build_env_ref
void $ associateFilesWithBuild fids buildId
-- Record the exact-version dependencies used for this build
forM_ depList $ \(n, v) -> insertBuildKeyValue (TextKey "dependency") n (Just $ toText v) buildId
return buildId