{-# 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)
rebuildNPM :: (MonadBaseControl IO m, MonadIO m, MonadError String m, MonadResource m) => Key Sources -> SqlPersistT m [Key Builds]
rebuildNPM sourceId = do
(name, version) <- getNameVer
dependencies <- sequence <$> getDeps
sourceFiles <- sourceToList $ sourceIdToFiles sourceId
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
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
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
when (null sources) $ throwError $ "Unable to satisfy dependency for " ++ show name ++ " " ++ show range
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
let module_dir = "/" </> "usr" </> "lib" </> "node_modules" </> T.unpack (T.concat [name, "@", ver])
moduleDirsIds <- mkdirs buildTime $ module_dir </> "node_modules"
let packageFiles = map (`copyFile` module_dir) sourceFiles
packageFilesIds <- mapM (\file -> (file,) <$> insert file) packageFiles
deplinkFilesIds <- mapM (createDepLink module_dir buildTime) depList
let buildFilesIds = moduleDirsIds ++ packageFilesIds ++ deplinkFilesIds
void $ apply buildFilesIds
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
let epoch = 0
let release = ""
let arch = "noarch"
let changelog = ""
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
forM_ depList $ \(n, v) -> insertBuildKeyValue (TextKey "dependency") n (Just $ toText v) buildId
return buildId