hnix-store/hnix-store-remote/tests/NixDaemon.hs

{-# 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)