mirror of
https://github.com/haskell-nix/hnix-store.git
synced 2024-11-30 12:53:11 +03:00
c49eb9b6d7
I wonder why type system needs to infer Monad constraint where Applicative would suffice.
278 lines
8.7 KiB
Haskell
278 lines
8.7 KiB
Haskell
{-# 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.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
|
|
}
|
|
pure 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))
|
|
(pure ())
|
|
ex
|
|
|
|
writeConf :: FilePath -> IO ()
|
|
writeConf fp =
|
|
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
|
|
pure (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 =
|
|
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 >> pure ())) `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
|
|
pure 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 = "declare -xpexport > $out"
|
|
|
|
spec_protocol :: Spec
|
|
spec_protocol = Hspec.around withNixDaemon $
|
|
|
|
describe "store" $ do
|
|
|
|
context "syncWithGC" $
|
|
itRights "syncs with garbage collector" syncWithGC
|
|
|
|
context "verifyStore" $ do
|
|
itRights "check=False repair=False" $
|
|
verifyStore False False `shouldReturn` False
|
|
|
|
itRights "check=True repair=False" $
|
|
verifyStore True False `shouldReturn` False
|
|
|
|
--privileged
|
|
itRights "check=True repair=True" $
|
|
verifyStore True True `shouldReturn` False
|
|
|
|
context "addTextToStore" $
|
|
itRights "adds text to store" $ withPath $ const pure ()
|
|
|
|
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" $
|
|
itRights "queries path info" $ withPath $ queryPathInfoUncached
|
|
|
|
context "ensurePath" $
|
|
itRights "simple ensure" $ withPath $ ensurePath
|
|
|
|
context "addTempRoot" $
|
|
itRights "simple addition" $ withPath $ addTempRoot
|
|
|
|
context "addIndirectRoot" $
|
|
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" $ 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" $ itRights "optimises" $ optimiseStore
|
|
|
|
context "queryMissing" $
|
|
itRights "queries" $ withPath $ \path -> do
|
|
let pathSet = HS.fromList [path]
|
|
queryMissing pathSet `shouldReturn` (HS.empty, HS.empty, HS.empty, 0, 0)
|
|
|
|
context "addToStore" $
|
|
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" $
|
|
itRights "build derivation" $
|
|
withDerivation $ \path drv -> do
|
|
result <- buildDerivation path drv Normal
|
|
result `shouldSatisfy` ((== AlreadyValid) . status)
|