sandwich-contexts: working on binary introduction

demos/demo-nix-binary/.gitignore

@@ -0,0 +1,2 @@
+.stack-work/
+*~

demos/demo-nix-binary/LICENSE

@@ -0,0 +1,30 @@
+Copyright Tom McLaughlin (c) 2023
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Tom McLaughlin nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

demos/demo-nix-binary/app/Main.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeApplications #-}
+
+module Main where
+
+import Control.Concurrent
+import Control.Monad.IO.Class
+import Sandwich.Contexts.Files
+import Sandwich.Contexts.Nix
+import Test.Sandwich
+import UnliftIO.Process
+
+
+spec :: TopSpec
+spec = describe "Introducing a Nix binary" $
+  introduceNixContext nixpkgsReleaseDefault $ introduceBinaryViaNix @"hello" "hello" $ do
+    it "uses the hello binary" $ do
+      helloPath <- askFile @"hello"
+      readCreateProcess (proc helloPath []) "" >>= (`shouldBe` "Hello, world!\n")
+
+main :: IO ()
+main = runSandwichWithCommandLineArgs defaultOptions spec

demos/demo-nix-binary/demo-nix-binary.cabal

@@ -0,0 +1,34 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.36.0.
+--
+-- see: https://github.com/sol/hpack
+
+name:           demo-nix-binary
+version:        0.1.0.0
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+
+executable demo-nix-binary
+  main-is: Main.hs
+  other-modules:
+      Paths_demo_nix_binary
+  hs-source-dirs:
+      app
+  default-extensions:
+      OverloadedStrings
+      QuasiQuotes
+      NamedFieldPuns
+      RecordWildCards
+      ScopedTypeVariables
+      FlexibleContexts
+      FlexibleInstances
+      LambdaCase
+  ghc-options: -threaded -rtsopts -with-rtsopts=-N
+  build-depends:
+      base
+    , sandwich
+    , sandwich-contexts
+    , unliftio
+  default-language: Haskell2010

demos/demo-nix-binary/package.yaml

@@ -0,0 +1,29 @@
+name:                demo-nix-binary
+version:             0.1.0.0
+license:             BSD3
+
+dependencies:
+- base
+- sandwich
+- sandwich-contexts
+- unliftio
+
+default-extensions:
+- OverloadedStrings
+- QuasiQuotes
+- NamedFieldPuns
+- RecordWildCards
+- ScopedTypeVariables
+- FlexibleContexts
+- FlexibleInstances
+- LambdaCase
+
+ghc-options:
+- -threaded
+- -rtsopts
+- -with-rtsopts=-N
+
+executables:
+  demo-nix-binary:
+    main: Main.hs
+    source-dirs: app

sandwich-contexts/lib/Sandwich/Contexts/FakeSmtpServer.hs

@@ -1,10 +1,11 @@
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeOperators #-}
 
 module Sandwich.Contexts.FakeSmtpServer (
-  introduceFakeSmtpServer
+  introduceFakeSmtpServer'
   , withFakeSMTPServer
   , fakeSmtpServer
   , FakeSmtpServer(..)
@@ -27,6 +28,7 @@ import Data.String.Interpolate
 import Network.HTTP.Client
 import Network.Socket (PortNumber)
 import Relude
+import Sandwich.Contexts.Files
 import Sandwich.Contexts.Util.Aeson
 import Sandwich.Contexts.Waits
 import System.FilePath
@@ -63,17 +65,26 @@ fakeSmtpServer = Label
 
 -- * Functions
 
-introduceFakeSmtpServer :: (
-  HasBaseContext context, MonadMask m, MonadUnliftIO m
+introduceFakeSmtpServerNix :: (
+  HasBaseContext context
+  , MonadMask m, MonadUnliftIO m
   ) => Bool -> Bool -> SpecFree (LabelValue "fakeSmtpServer" FakeSmtpServer :> context) m () -> SpecFree context m ()
-introduceFakeSmtpServer auth allowInsecureLogin = introduceWith "fake SMTP server" fakeSmtpServer (withFakeSMTPServer auth allowInsecureLogin)
+introduceFakeSmtpServerNix auth allowInsecureLogin =
+  undefined
+
+introduceFakeSmtpServer' :: (
+  HasBaseContext context, HasFile context "fake-smtp-server"
+  , MonadMask m, MonadUnliftIO m
+  ) => Bool -> Bool -> SpecFree (LabelValue "fakeSmtpServer" FakeSmtpServer :> context) m () -> SpecFree context m ()
+introduceFakeSmtpServer' auth allowInsecureLogin = introduceWith "fake SMTP server" fakeSmtpServer (withFakeSMTPServer auth allowInsecureLogin)
 
 authUsername, authPassword :: Text
 authUsername = "user"
 authPassword = "pass"
 
 withFakeSMTPServer :: (
-  HasBaseContext context, MonadReader context m, MonadLoggerIO m, MonadThrow m, MonadUnliftIO m
+  HasBaseContext context, MonadReader context m, HasFile context "fake-smtp-server"
+  , MonadLoggerIO m, MonadThrow m, MonadUnliftIO m
   ) => Bool -> Bool -> (FakeSmtpServer -> m [Result]) -> m ()
 withFakeSMTPServer auth allowInsecureLogin action = do
   folder <- getCurrentFolder >>= \case
@@ -83,10 +94,12 @@ withFakeSMTPServer auth allowInsecureLogin action = do
   let httpPortFile = folder </> "http-port-file"
   let smtpPortFile = folder </> "smtp-port-file"
 
+  fakeSmtpServerPath <- askFile @"fake-smtp-server"
+
   bracket (do
               let authFlag = if auth then ["--auth",  [i|#{authUsername}:#{authPassword}|]] else []
               let insecureLoginFlag = if allowInsecureLogin then "--allow-insecure-login" else ""
-              createProcessWithLogging ((proc "fake-smtp-server" ([insecureLoginFlag
+              createProcessWithLogging ((proc fakeSmtpServerPath ([insecureLoginFlag
                                                                   , "--smtp-port", "0"
                                                                   , "--smtp-port-file", smtpPortFile
                                                                   , "--http-port", "0"

sandwich-contexts/lib/Sandwich/Contexts/FakeSmtpServer/Derivation.hs

@@ -0,0 +1,46 @@
+
+module Sandwich.Contexts.FakeSmtpServer.Derivation where
+
+import Data.String.Interpolate
+import Relude
+
+
+expr :: Text
+expr = [iii|
+{ callPackage
+, fetchFromGitHub
+, node2nix
+, nodejs
+, stdenv
+}:
+
+let
+
+  nixified = stdenv.mkDerivation {
+    pname = "fake-smtp-server";
+    version = "0.8.1";
+
+    src = fetchFromGitHub {
+      owner = "codedownio";
+      repo = "fake-smtp-server";
+      rev = "102b72c1ec852d88309b290b6b68ff5b4f50a431";
+      sha256 = "sha256-uTcYGs5OOQ/uKfKYdmgnGYvBPfTALDoZsytqJEDTwHA=";
+    };
+
+    dontConfigure = true;
+
+    buildInputs = [node2nix];
+
+    buildPhase = ''
+      node2nix -- --nodejs-14 --lock package-lock.json
+    '';
+
+    installPhase = ''
+      cp -r ./. $out
+    '';
+  };
+
+in
+
+(callPackage nixified { inherit nodejs; }).package
+|]

sandwich-contexts/lib/Sandwich/Contexts/Files.hs

@@ -0,0 +1,123 @@
+{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Sandwich.Contexts.Files (
+  introduceBinaryViaEnvironment
+  , introduceBinaryViaNix
+  , introduceBinaryViaNixProxy'
+  , introduceBinaryViaNixProxy''
+
+  , askFile
+  , askFileProxy
+
+  , EnvironmentFile(..)
+  , HasFile
+  ) where
+
+import Control.Monad.IO.Unlift
+import Control.Monad.Logger
+import Data.String.Interpolate
+import GHC.TypeLits
+import Relude
+import Sandwich.Contexts.Nix
+import System.FilePath
+import Test.Sandwich
+import UnliftIO.Directory
+
+
+-- | A file path to make available to tests.
+-- For example, this can be an external binary like "minikube" if a given test context wants
+-- to use it to start a Minikube cluster.
+-- But you can use this for any kind of file you want to inject into tests.
+data EnvironmentFile a = EnvironmentFile { unEnvironmentFile :: FilePath }
+
+-- | Has-* class for asserting a given file is available.
+type HasFile context a = HasLabel context (AppendSymbol "file-" a) (EnvironmentFile a)
+
+mkLabel :: Label (AppendSymbol "file-" a) (EnvironmentFile a)
+mkLabel = Label
+
+askFile :: forall a context m. (MonadReader context m, HasFile context a) => m FilePath
+askFile = askFileProxy (Proxy @a)
+
+askFileProxy :: forall a context m. (MonadReader context m, HasFile context a) => Proxy a -> m FilePath
+askFileProxy _ = unEnvironmentFile <$> getContext (mkLabel @a)
+
+-- | Introduce a given 'EnvironmentFile' from the PATH present when tests are run.
+-- Useful when you want to set up your own environment with binaries etc. to use in tests.
+-- Throws an exception if the desired file is not available.
+introduceBinaryViaEnvironment :: forall a context m. (
+  MonadUnliftIO m, KnownSymbol a
+  ) => Proxy a -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m () -> SpecFree context m ()
+introduceBinaryViaEnvironment proxy = introduce [i|#{symbolVal proxy} (binary from PATH)|] (mkLabel @a) alloc cleanup
+  where
+    alloc = do
+      liftIO (findExecutable (symbolVal proxy)) >>= \case
+        Nothing -> expectationFailure [i|Couldn't find binary '#{symbolVal proxy}' on PATH|]
+        Just path -> return $ EnvironmentFile path
+
+    cleanup _ = return ()
+
+type NixPackageName = Text
+
+-- | Introduce a given 'EnvironmentFile' from the PATH present when tests are run.
+-- Useful when you want to set up your own environment with binaries etc. to use in tests.
+-- Throws an exception if the desired file is not available.
+introduceBinaryViaNix :: forall a context m. (
+  HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a
+  ) =>
+    -- | Nix package name within the configured Nixpkgs version
+    NixPackageName
+    -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
+    -> SpecFree context m ()
+introduceBinaryViaNix = introduceBinaryViaNixProxy (Proxy @a)
+
+-- | Introduce a given 'EnvironmentFile' from the PATH present when tests are run.
+-- Useful when you want to set up your own environment with binaries etc. to use in tests.
+-- Throws an exception if the desired file is not available.
+introduceBinaryViaNixProxy :: forall a context m. (
+  HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a
+  ) => Proxy a
+    -- | Nix package name within the configured Nixpkgs version
+    -> NixPackageName
+    -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
+    -> SpecFree context m ()
+introduceBinaryViaNixProxy proxy packageName = introduce [i|#{symbolVal proxy} (binary via Nix)|] (mkLabel @a) alloc (const $ return ())
+  where
+    alloc = buildNixEnvironment [packageName] >>= tryFindBinary (symbolVal proxy)
+
+-- | Same as 'introduceBinaryViaNix', but using an arbitrary derivation.
+introduceBinaryViaNixProxy' :: forall a context m. (
+  HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a
+  ) =>
+    -- | Nix derivation as a string.
+    Text
+    -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
+    -> SpecFree context m ()
+introduceBinaryViaNixProxy' = introduceBinaryViaNixProxy'' (Proxy @a)
+
+introduceBinaryViaNixProxy'' :: forall a context m. (
+  HasBaseContext context, HasNixContext context, MonadUnliftIO m, KnownSymbol a
+  ) => Proxy a
+    -- | Nix derivation as a string.
+    -> Text
+    -> SpecFree (LabelValue (AppendSymbol "file-" a) (EnvironmentFile a) :> context) m ()
+    -> SpecFree context m ()
+introduceBinaryViaNixProxy'' proxy derivation = introduce [i|#{symbolVal proxy} (binary via Nix)|] (mkLabel @a) alloc (const $ return ())
+  where
+    alloc = buildNixExpression derivation >>= tryFindBinary (symbolVal proxy)
+
+tryFindBinary :: (MonadLoggerIO m) => String -> FilePath -> m (EnvironmentFile a)
+tryFindBinary binaryName env = do
+  findExecutablesInDirectories [env </> "bin"] binaryName >>= \case
+    (x:_) -> do
+      info [i|Found binary: #{x}|]
+      return $ EnvironmentFile x
+    _ -> expectationFailure [i|Couldn't find binary '#{binaryName}' in #{env </> "bin"}|]

sandwich-contexts/lib/Sandwich/Contexts/Nix.hs

@@ -12,6 +12,7 @@ module Sandwich.Contexts.Nix (
   -- * Nix environments
   , introduceNixEnvironment
   , buildNixEnvironment
+  , buildNixExpression
   , nixEnvironment
   , HasNixEnvironment
 
@@ -26,6 +27,7 @@ import Control.Monad.Catch (MonadThrow)
 import Control.Monad.IO.Unlift
 import Control.Monad.Logger
 import Data.Aeson as A
+import qualified Data.Map as M
 import Data.String.Interpolate
 import qualified Data.Text as T
 import qualified Data.Vector as V
@@ -34,7 +36,9 @@ import Sandwich.Contexts.Util.Aeson
 import System.FilePath
 import System.IO.Temp
 import Test.Sandwich
+import UnliftIO.Async
 import UnliftIO.Directory
+import UnliftIO.MVar (modifyMVar)
 import UnliftIO.Process
 
 -- * Types
@@ -44,8 +48,9 @@ nixContext = Label
 
 data NixContext = NixContext {
   nixContextNixBinary :: FilePath
-  , nixContextNixpkgsDerivations :: NixpkgsDerivation
-  } deriving (Show, Eq)
+  , nixContextNixpkgsDerivation :: NixpkgsDerivation
+  , nixContextBuildCache :: MVar (Map Text (Async FilePath))
+  }
 
 type HasNixContext context = HasLabel context "nixContext" NixContext
 
@@ -86,7 +91,8 @@ introduceNixContext nixpkgsDerivation = introduce "Introduce Nix context" nixCon
       Nothing -> expectationFailure [i|Couldn't find "nix" binary when introducing Nix context. A Nix binary and store must already be available in the environment.|]
       Just p -> do
         -- TODO: make sure the Nixpkgs derivation works
-        pure (NixContext p nixpkgsDerivation)
+        buildCache <- newMVar mempty
+        pure (NixContext p nixpkgsDerivation buildCache)
 
 introduceNixEnvironment :: (
   MonadReader context m, HasBaseContext context, HasNixContext context
@@ -102,25 +108,45 @@ buildNixEnvironment :: (
   , MonadUnliftIO m, MonadLogger m, MonadFail m
   ) => [Text] -> m FilePath
 buildNixEnvironment packageNames = do
-  Just dir <- getCurrentFolder
-  gcrootDir <- liftIO $ createTempDirectory dir "nix-environment"
-
   NixContext {..} <- getContext nixContext
-  output <- readCreateProcessWithLogging (
-    proc "nix" ["build"
-               , "--impure"
-               , "--expr", renderNixEnvironment nixContextNixpkgsDerivations packageNames
-               , "-o", gcrootDir </> "gcroot"
-               , "--json"
-               ]
-    ) ""
+  buildNixExpression $ renderNixEnvironment nixContextNixpkgsDerivation packageNames
 
-  case A.eitherDecodeStrict (encodeUtf8 output) of
-    Right (A.Array (V.toList -> ((A.Object (aesonLookup "outputs" -> Just (A.Object (aesonLookup "out" -> Just (A.String p))))):_))) -> pure (toString p)
-    x -> expectationFailure [i|Couldn't parse Nix build JSON output: #{x} (output was #{output})|]
+-- | Build a Nix environment containing the given list of packages, using the current 'NixContext'.
+-- These packages are mashed together using the Nix "symlinkJoin" function. Their binaries will generally
+-- be found in "<environment path>/bin".
+buildNixExpression :: (
+  MonadReader context m, HasBaseContext context, HasNixContext context
+  , MonadUnliftIO m, MonadLogger m, MonadFail m
+  ) => Text -> m FilePath
+buildNixExpression expr = do
+  NixContext {..} <- getContext nixContext
 
+  buildAsync <- modifyMVar nixContextBuildCache $ \m ->
+    case M.lookup expr m of
+      Just x -> return (m, x)
+      Nothing -> do
+        asy <- async $ do
+          Just dir <- getCurrentFolder
+          gcrootDir <- liftIO $ createTempDirectory dir "nix-expression"
 
-renderNixEnvironment :: NixpkgsDerivation -> [Text] -> String
+          output <- readCreateProcessWithLogging (
+            proc "nix" ["build"
+                       , "--impure"
+                       , "--expr", toString expr
+                       , "-o", gcrootDir </> "gcroot"
+                       , "--json"
+                       ]
+            ) ""
+
+          case A.eitherDecodeStrict (encodeUtf8 output) of
+            Right (A.Array (V.toList -> ((A.Object (aesonLookup "outputs" -> Just (A.Object (aesonLookup "out" -> Just (A.String p))))):_))) -> pure (toString p)
+            x -> expectationFailure [i|Couldn't parse Nix build JSON output: #{x} (output was #{output})|]
+
+        return (M.insert expr asy m, asy)
+
+  wait buildAsync
+
+renderNixEnvironment :: NixpkgsDerivation -> [Text] -> Text
 renderNixEnvironment (NixpkgsDerivationFetchFromGitHub {..}) packageNames = [i|
 \# Use the ambient <nixpkgs> channel to bootstrap
 with {

sandwich-contexts/package.yaml

@@ -33,9 +33,10 @@ ghc-options:
 library:
   source-dirs: lib
   exposed-modules:
-  - Sandwich.Contexts.FakeSmtpServer
   - Sandwich.Contexts.Container.MinioS3Server
   - Sandwich.Contexts.Container.PostgreSQL
+  - Sandwich.Contexts.FakeSmtpServer
+  - Sandwich.Contexts.Files
   - Sandwich.Contexts.Nix
   - Sandwich.Contexts.Nix.PostgreSQL
   - Sandwich.Contexts.Waits

sandwich-contexts/sandwich-contexts.cabal

@@ -15,13 +15,15 @@ build-type:     Simple
 
 library
   exposed-modules:
-      Sandwich.Contexts.FakeSmtpServer
       Sandwich.Contexts.Container.MinioS3Server
       Sandwich.Contexts.Container.PostgreSQL
+      Sandwich.Contexts.FakeSmtpServer
+      Sandwich.Contexts.Files
       Sandwich.Contexts.Nix
       Sandwich.Contexts.Nix.PostgreSQL
       Sandwich.Contexts.Waits
   other-modules:
+      Sandwich.Contexts.FakeSmtpServer.Derivation
       Sandwich.Contexts.Nix.CaddyProxy
       Sandwich.Contexts.Nix.MinIO
       Sandwich.Contexts.Util.Aeson

stack.yaml

@@ -34,6 +34,7 @@ packages:
 - ./demos/demo-golden
 - ./demos/demo-hedgehog
 - ./demos/demo-landing
+- ./demos/demo-nix-binary
 - ./demos/demo-paralleln
 - ./demos/demo-processes
 - ./demos/demo-quickcheck