{-# LANGUAGE DataKinds #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module NixDaemon where
import Control.Monad (void)
import Control.Monad.IO.Class (liftIO)
import Control.Exception (bracket)
import Control.Concurrent (threadDelay)
import Data.Either (isRight, isLeft)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.HashSet as HS
import qualified Data.Map.Strict as M
import System.Directory
import qualified System.Environment
import System.IO.Temp
import qualified System.Process as P
import System.Posix.User as U
import System.Linux.Namespaces as NS
import Test.Tasty.Hspec (Spec, describe, context)
import qualified Test.Tasty.Hspec as Hspec
import Test.Hspec.Expectations.Lifted
import System.FilePath
import System.Nix.Build
import System.Nix.Hash
import System.Nix.StorePath
import System.Nix.Store.Remote
import System.Nix.Store.Remote.Protocol
import Derivation
createProcessEnv :: FilePath
-> String
-> [String]
-> IO P.ProcessHandle
createProcessEnv fp proc args = do
mPath <- System.Environment.lookupEnv "PATH"
(_, _, _, ph) <- P.createProcess (P.proc proc args) { P.cwd = Just $ fp
, P.env = Just $ mockedEnv mPath fp }
return ph
mockedEnv :: Maybe String -> FilePath -> [(String, FilePath)]
mockedEnv mEnvPath fp = map (\(a, b) -> (a, b)) [
("NIX_STORE_DIR", fp </> "store")
, ("NIX_LOCALSTATE_DIR", fp </> "var")
, ("NIX_LOG_DIR", fp </> "var" </> "log")
, ("NIX_STATE_DIR", fp </> "var" </> "nix")
, ("NIX_CONF_DIR", fp </> "etc")
-- , ("NIX_REMOTE", "daemon")
] ++ (maybe [] (\x -> [("PATH", x)]) mEnvPath)
waitSocket :: FilePath -> Int -> IO ()
waitSocket _ 0 = fail "No socket"
waitSocket fp x = do
ex <- doesFileExist fp
case ex of
True -> return ()
False -> threadDelay 100000 >> waitSocket fp (x - 1)
writeConf :: FilePath -> IO ()
writeConf fp = do
writeFile fp $ unlines [
"build-users-group = "
, "trusted-users = root"
, "allowed-users = *"
, "fsync-metadata = false"
]
{-
- we run in user namespace as root but groups are failed
- => build-users-group has to be empty but we still
- get an error (maybe older nix-daemon)
-
uid=0(root) gid=65534(nobody) groups=65534(nobody)
drwxr-xr-x 3 0 65534 60 Nov 29 05:53 store
accepted connection from pid 22959, user root (trusted)
error: changing ownership of path '/run/user/1000/test-nix-store-06b0d249e5616122/store': Invalid argument
-}
startDaemon :: FilePath -> IO (P.ProcessHandle, MonadStore a -> IO (Either String a, [Logger]))
startDaemon fp = do
writeConf (fp </> "etc" </> "nix.conf")
p <- createProcessEnv fp "nix-daemon" []
waitSocket sockFp 30
return (p, runStoreOpts sockFp (fp </> "store"))
where
sockFp = fp </> "var/nix/daemon-socket/socket"
enterNamespaces :: IO ()
enterNamespaces = do
uid <- getEffectiveUserID
gid <- getEffectiveGroupID
unshare [User, Network, Mount]
-- map our (parent) uid to root
writeUserMappings Nothing [UserMapping 0 uid 1]
-- map our (parent) gid to root group
writeGroupMappings Nothing [GroupMapping 0 gid 1] True
withNixDaemon
:: ((MonadStore a -> IO (Either String a, [Logger])) -> IO a) -> IO a
withNixDaemon action = do
withSystemTempDirectory "test-nix-store" $ \path -> do
mapM_ (createDirectory . snd)
(filter ((/= "NIX_REMOTE") . fst) $ mockedEnv Nothing path)
ini <- createProcessEnv path
"nix-store" ["--init"]
void $ P.waitForProcess ini
writeFile (path </> "dummy") "Hello World"
setCurrentDirectory path
bracket (startDaemon path)
(P.terminateProcess . fst)
(\x -> action . snd $ x)
checks :: (Show a, Show b) => IO (a, b) -> (a -> Bool) -> IO ()
checks action check = action >>= (`Hspec.shouldSatisfy` (check . fst))
it
:: (Show a, Show b, Monad m)
=> String
-> m c
-> (a -> Bool)
-> Hspec.SpecWith (m () -> IO (a, b))
it name action check = Hspec.it name $ \run -> (run (action >> return ())) `checks` check
itRights
:: (Show a, Show b, Show c, Monad m)
=> String
-> m d
-> Hspec.SpecWith (m () -> IO (Either a b, c))
itRights name action = it name action isRight
itLefts
:: (Show a, Show b, Show c, Monad m)
=> String
-> m d
-> Hspec.SpecWith (m () -> IO (Either a b, c))
itLefts name action = it name action isLeft
withPath :: (StorePath -> MonadStore a) -> MonadStore a
withPath action = do
path <- addTextToStore "hnix-store" "test" (HS.fromList []) False
action path
-- | dummy path, adds <tmp>/dummpy with "Hello World" contents
dummy :: MonadStore StorePath
dummy = do
let Right n = makeStorePathName "dummy"
res <- addToStore @'SHA256 n "dummy" False (pure True) False
return res
invalidPath :: StorePath
invalidPath =
let Right n = makeStorePathName "invalid"
in StorePath (hash "invalid") n "no_such_root"
withBuilder :: (StorePath -> MonadStore a) -> MonadStore a
withBuilder action = do
path <- addTextToStore "builder" builderSh (HS.fromList []) False
action path
builderSh :: Text
builderSh = T.concat [ "declare -xp", "export > $out" ]
spec_protocol :: Spec
spec_protocol = Hspec.around withNixDaemon $ do
describe "store" $ do
context "syncWithGC" $ do
itRights "syncs with garbage collector" syncWithGC
context "verifyStore" $ do
itRights "check=False repair=False" $ do
verifyStore False False `shouldReturn` False
itRights "check=True repair=False" $ do
verifyStore True False `shouldReturn` False
--privileged
itRights "check=True repair=True" $ do
verifyStore True True `shouldReturn` False
context "addTextToStore" $ do
itRights "adds text to store" $ withPath $ const return ()
context "isValidPathUncached" $ do
itRights "validates path" $ withPath $ \path -> do
liftIO $ putStrLn $ show path
(isValidPathUncached path) `shouldReturn` True
itLefts "fails on invalid path" $ isValidPathUncached $ invalidPath
context "queryAllValidPaths" $ do
itRights "empty query" $ queryAllValidPaths
itRights "non-empty query" $ withPath $ \path -> queryAllValidPaths `shouldReturn` (HS.fromList [path])
context "queryPathInfoUncached" $ do
itRights "queries path info" $ withPath $ queryPathInfoUncached
context "ensurePath" $ do
itRights "simple ensure" $ withPath $ ensurePath
context "addTempRoot" $ do
itRights "simple addition" $ withPath $ addTempRoot
context "addIndirectRoot" $ do
itRights "simple addition" $ withPath $ addIndirectRoot
context "buildPaths" $ do
itRights "build Normal" $ withPath $ \path -> do
let pathSet = HS.fromList [path]
buildPaths pathSet Normal
itRights "build Check" $ withPath $ \path -> do
let pathSet = HS.fromList [path]
buildPaths pathSet Check
itLefts "build Repair" $ withPath $ \path -> do
let pathSet = HS.fromList [path]
buildPaths pathSet Repair
context "roots" $ do
context "findRoots" $ do
itRights "empty roots" $ (findRoots `shouldReturn` M.empty)
itRights "path added as a temp root" $ withPath $ \_ -> do
roots <- findRoots
roots `shouldSatisfy` ((==1) . M.size)
context "optimiseStore" $ do
itRights "optimises" $ optimiseStore
context "queryMissing" $ do
itRights "queries" $ withPath $ \path -> do
let pathSet = HS.fromList [path]
queryMissing pathSet `shouldReturn` (HS.empty, HS.empty, HS.empty, 0, 0)
context "addToStore" $ do
itRights "adds file to store" $ do
fp <- liftIO $ writeSystemTempFile "addition" "lal"
let Right n = makeStorePathName "tmp-addition"
res <- addToStore @'SHA256 n fp False (pure True) False
liftIO $ print res
context "with dummy" $ do
itRights "adds dummy" dummy
itRights "valid dummy" $ do
path <- dummy
liftIO $ putStrLn $ show path
(isValidPathUncached path) `shouldReturn` True
context "derivation" $ do
itRights "build derivation" $ do
withDerivation $ \path drv -> do
result <- buildDerivation path drv Normal
result `shouldSatisfy` ((==AlreadyValid) . status)