NixDaemon.hs

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

module NixDaemon where

import           Data.Bool                         ( bool )
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 =
  [ ("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
  bool
    (threadDelay 100000 >> waitSocket fp (x - 1))
    (return ())
    ex

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)