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

{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications    #-}

module NixDaemon where

import           Prelude
import           Control.Monad
import           Control.Monad.IO.Class      (liftIO, MonadIO)
import           Control.Exception           (bracket)
import           Control.Concurrent          (threadDelay)
import           Data.Either                 (isRight, isLeft, fromRight)
import           Data.Binary.Put
import qualified Data.ByteString             as BS
import qualified Data.ByteString.Base64.Lazy as B64
import qualified Data.ByteString.Lazy        as BSL
import           Data.Monoid                 ((<>))
import           Data.Maybe                  (fromJust)
import           Data.Proxy
import           Data.Time
import qualified Data.Text                   as T
import qualified Data.Text.Lazy.Builder
import qualified Data.HashSet                as HS
import qualified Data.Map.Strict             as M
import qualified Data.Set                    as S
import qualified Data.Vector                 as V
import           System.Directory
import qualified System.Environment
import           System.IO.Temp
import qualified System.IO                   as IO (hGetContents, hPutStr, openFile)
import qualified System.Process              as P
import           System.Posix.User           as U
import           System.Linux.Namespaces     as NS
import           Test.Tasty                  as T
import           Test.Tasty.Hspec            (Spec, HasCallStack, describe, context)
import qualified Test.Tasty.Hspec            as Hspec
import           Test.Hspec.Expectations.Lifted
import qualified Test.Tasty.HUnit            as HU
import           Test.Tasty.QuickCheck
import           Text.Read                   (readMaybe)

import           System.FilePath

import           System.Nix.Build
import           System.Nix.Hash
import           System.Nix.StorePath
import           System.Nix.ReadonlyStore
import           System.Nix.Nar
import qualified System.Nix.StorePathMetadata as VP
import           System.Nix.Store.Remote
import           System.Nix.Store.Remote.Logger
import           System.Nix.Store.Remote.Types
import           System.Nix.Store.Remote.Protocol
import           System.Nix.Store.Remote.Util

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 fp 0 = fail "No socket"
waitSocket fp x = do
  ex <- doesFileExist fp
  case ex of
    True -> return ()
    False -> threadDelay 100000 >> waitSocket fp (x - 1)

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 = 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 action = do
  withSystemTempDirectory "test-nix-store" $ \path -> do

    mapM_ (createDirectory . snd)
      (filter ((/= "NIX_REMOTE") . fst) $ mockedEnv Nothing path)

    ini <- createProcessEnv path
      "nix-store" ["--init"]
    P.waitForProcess ini

    writeFile (path </> "dummy") "Hello World"

    setCurrentDirectory path

    bracket (startDaemon path)
            (P.terminateProcess . fst)
            (\x -> action . snd $ x)

checks action check = action >>= (`Hspec.shouldSatisfy` (check . fst))
it name action check = Hspec.it name $ \run -> (run (action >> return ())) `checks` check
itRights name action = it name action isRight
itLefts name action = it name action isLeft

withPath action = do
  path <- addTextToStore "hnix-store" "test" (HS.fromList []) False
  action path

-- | dummy path, adds <tmp>/dummpy with "Hello World" contents
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 action = do
  path <- addTextToStore "builder" builderSh (HS.fromList []) False
  action path

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 $ \path -> 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)