@@ -1,6 +1,9 @@
11{-# LANGUAGE FlexibleContexts #-}
22{-# LANGUAGE LambdaCase #-}
33{-# LANGUAGE OverloadedStrings #-}
4+{-# LANGUAGE ScopedTypeVariables #-}
5+{-# LANGUAGE TupleSections #-}
6+
47module Obelisk.Command.Project
58 ( InitSource (..)
69 , findProjectObeliskCommand
@@ -11,17 +14,24 @@ module Obelisk.Command.Project
1114 , nixShellRunProc
1215 , nixShellWithHoogle
1316 , nixShellWithoutPkgs
17+ , mkObNixShellProc
1418 , obeliskDirName
1519 , toImplDir
1620 , toObeliskDir
1721 , withProjectRoot
1822 , bashEscape
23+ , getHaskellManifestProjectPath
24+ , AssetSource(..)
25+ , describeImpureAssetSource
26+ , watchStaticFilesDerivation
1927 ) where
2028
2129import Control.Concurrent.MVar (MVar, newMVar, withMVarMasked)
22−import Control.Lens ((.~), (?~), (<&>))
30+import Control.Lens ((.~), (?~), (<&>), (^.), _2, _3)
2331import Control.Monad
32+import Control.Monad.Except
2433import Control.Monad.IO.Class (liftIO)
34+import Control.Monad.Log
2535import Control.Monad.State
2636import qualified Data.Aeson as Json
2737import qualified Data.ByteString.UTF8 as BSU
@@ -30,28 +40,36 @@ import qualified Data.ByteString.Lazy as BSL
3040import Data.Default (def)
3141import Data.Function ((&), on)
3242import Data.Map (Map)
43+import Data.Maybe (isJust)
3344import Data.Text (Text)
3445import qualified Data.Text as T
3546import Data.Text.Encoding (decodeUtf8, encodeUtf8)
3647import Data.Traversable (for)
48+import Reflex
49+import Reflex.FSNotify
50+import Reflex.Host.Headless
3751import System.Directory
3852import System.Environment (lookupEnv)
53+import System.Exit (ExitCode(..))
3954import System.FilePath
55+import System.FSNotify (defaultConfig, eventPath, WatchConfig(..))
56+import qualified System.Info as SysInfo
4057import System.IO.Temp
4158import System.IO.Unsafe (unsafePerformIO)
4259import System.PosixCompat.Files
4360import System.PosixCompat.Types
4461import System.PosixCompat.User
62+import qualified System.Process as Proc
4563import Text.ShellEscape (bash, bytes)
4664
4765import GitHub.Data.GitData (Branch)
4866import GitHub.Data.Name (Name)
4967
50−import Obelisk.App (MonadObelisk)
68+import Obelisk.App (MonadObelisk, runObelisk, getObelisk)
5169import Obelisk.CliApp
5270import Obelisk.Command.Nix
5371import Obelisk.Command.Thunk
54−import Obelisk.Command.Utils (nixBuildExePath, nixExePath, toNixPath, cp, nixShellPath)
72+import Obelisk.Command.Utils (nixBuildExePath, nixExePath, toNixPath, cp, nixShellPath, lnPath)
5573
5674--TODO: Make this module resilient to random exceptions
5775
@@ -300,7 +318,7 @@ bashEscape = BSU.toString . bytes . bash . BSU.fromString
300318nixShellRunProc :: NixShellConfig -> ProcessSpec
301319nixShellRunProc cfg = setDelegateCtlc True $ proc nixShellPath $ runNixShellConfig cfg
302320
303−nixShellWithoutPkgs
321+mkObNixShellProc
304322 :: MonadObelisk m
305323 => FilePath -- ^ Path to project root
306324 -> Bool -- ^ Should this be a pure shell?
@@ -308,12 +326,12 @@ nixShellWithoutPkgs
308326 -> Map Text FilePath -- ^ Package names mapped to their paths
309327 -> String -- ^ Shell attribute to use (e.g. @"ghc"@, @"ghcjs"@, etc.)
310328 -> Maybe String -- ^ If 'Just' run the given command; otherwise just open the interactive shell
311− -> m ()
312−nixShellWithoutPkgs root isPure chdirToRoot packageNamesAndPaths shellAttr command = do
329+ -> m ProcessSpec
330+mkObNixShellProc root isPure chdirToRoot packageNamesAndPaths shellAttr command = do
313331 packageNamesAndAbsPaths <- liftIO $ for packageNamesAndPaths makeAbsolute
314332 defShellConfig <- nixShellRunConfig root isPure command
315333 let setCwd_ = if chdirToRoot then setCwd (Just root) else id
316− runProcess_ $ setCwd_ $ nixShellRunProc $ defShellConfig
334+ pure $ setCwd_ $ nixShellRunProc $ defShellConfig
317335 & nixShellConfig_common . nixCmdConfig_target . target_expr ?~
318336 "{root, pkgs, shell}: ((import root {}).passthru.__unstable__.self.extend (_: _: {\
319337 \shellPackages = builtins.fromJSON pkgs;\
@@ -324,6 +342,18 @@ nixShellWithoutPkgs root isPure chdirToRoot packageNamesAndPaths shellAttr comma
324342 , strArg "shell" shellAttr
325343 ]
326344
345+nixShellWithoutPkgs
346+ :: MonadObelisk m
347+ => FilePath -- ^ Path to project root
348+ -> Bool -- ^ Should this be a pure shell?
349+ -> Bool -- ^ Should we chdir to the package root in the shell?
350+ -> Map Text FilePath -- ^ Package names mapped to their paths
351+ -> String -- ^ Shell attribute to use (e.g. @"ghc"@, @"ghcjs"@, etc.)
352+ -> Maybe String -- ^ If 'Just' run the given command; otherwise just open the interactive shell
353+ -> m ()
354+nixShellWithoutPkgs root isPure chdirToRoot packageNamesAndPaths shellAttr command = do
355+ runProcess_ =<< mkObNixShellProc root isPure chdirToRoot packageNamesAndPaths shellAttr command
356+
327357nixShellWithHoogle :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()
328358nixShellWithHoogle root isPure shell' command = do
329359 defShellConfig <- nixShellRunConfig root isPure command
@@ -334,7 +364,21 @@ nixShellWithHoogle root isPure shell' command = do
334364 \})).project.shells.${shell}"
335365 & nixShellConfig_common . nixCmdConfig_args .~ [ strArg "shell" shell' ]
336366
337−findProjectAssets :: MonadObelisk m => FilePath -> m Text
367+-- | Describes the provenance of static assets (i.e., are they the result of a derivation
368+-- that was built, or just a folder full of files.
369+data AssetSource = AssetSource_Derivation
370+ | AssetSource_Files
371+ deriving (Eq)
372+
373+-- | Some log messages to make it easier to tell where static files are coming from
374+describeImpureAssetSource :: AssetSource -> Text -> Text
375+describeImpureAssetSource src path = case src of
376+ AssetSource_Files -> "Assets impurely loaded from: " <> path
377+ AssetSource_Derivation -> "Assets derivation built and impurely loaded from: " <> path
378+
379+-- | Determine where the static files of a project are and whether they're plain files or a derivation.
380+-- If they are a derivation, that derivation will be built.
381+findProjectAssets :: MonadObelisk m => FilePath -> m (AssetSource, Text)
338382findProjectAssets root = do
339383 isDerivation <- readProcessAndLogStderr Debug $ setCwd (Just root) $
340384 proc nixExePath
@@ -346,10 +390,95 @@ findProjectAssets root = do
346390 ]
347391 -- Check whether the impure static files are a derivation (and so must be built)
348392 if isDerivation == "1"
349− then fmap T.strip $ readProcessAndLogStderr Debug $ setCwd (Just root) $ -- Strip whitespace here because nix-build has no --raw option
350− proc nixBuildExePath
351− [ "--no-out-link"
393+ then do
394+ _ <- buildStaticFilesDerivationAndSymlink
395+ (readProcessAndLogStderr Debug)
396+ root
397+ pure (AssetSource_Derivation, T.pack $ root </> "static.out")
398+ else fmap (AssetSource_Files,) $ do
399+ path <- readProcessAndLogStderr Debug $ setCwd (Just root) $
400+ proc nixExePath ["eval", "-f", ".", "passthru.staticFilesImpure", "--raw"]
401+ _ <- readProcessAndLogStderr Debug $ setCwd (Just root) $
402+ proc lnPath ["-sfT", T.unpack path, "./static.out"]
403+ pure path
404+
405+-- | Get the nix store path to the generated static asset manifest module (e.g., "obelisk-generated-static")
406+getHaskellManifestProjectPath :: MonadObelisk m => FilePath -> m Text
407+getHaskellManifestProjectPath root = fmap T.strip $ readProcessAndLogStderr Debug $ setCwd (Just root) $
408+ proc nixBuildExePath
409+ [ "--no-out-link"
410+ , "-E"
411+ , "(let a = import ./. {}; in a.passthru.processedStatic.haskellManifest)"
412+ ]
413+
414+-- | Watch the project directory for file changes and check whether those file changes
415+-- cause changes in the static files nix derivation. If so, rebuild it.
416+watchStaticFilesDerivation
417+ :: (MonadIO m, MonadObelisk m)
418+ => FilePath
419+ -> m ()
420+watchStaticFilesDerivation root = do
421+ ob <- getObelisk
422+ drv0 <- showDerivation
423+ liftIO $ runHeadlessApp $ do
424+ pb <- getPostBuild
425+ checkForChanges <- batchOccurrences 0.25 =<< watchDirectoryTree
426+ -- On macOS, use the polling backend due to https://github.com/luite/hfsevents/issues/13
427+ (defaultConfig { confUsePolling = SysInfo.os == "darwin", confPollInterval = 250000 })
428+ (root <$ pb)
429+ ((/="static.out") . takeFileName . eventPath)
430+ drv <- performEvent $ ffor checkForChanges $ \_ ->
431+ liftIO $ runObelisk ob showDerivation
432+ drvs <- foldDyn (\new (_, old, _) -> (old, new, old /= new)) (drv0, drv0, False) drv
433+ void $ throttleBatchWithLag
434+ (\e -> performEvent $ ffor e $ \_ -> liftIO $ runObelisk ob $ do
435+ putLog Notice "Static assets being built..."
436+ buildStaticCatchErrors >>= \case
437+ Nothing -> pure ()
438+ Just _ -> putLog Notice "Static assets built and symlinked to static.out"
439+ )
440+ ((() <$) . ffilter (\x -> isJust (x ^._2) && x ^._3) $ updated drvs)
441+ pure never
442+ where
443+ handleBuildFailure
444+ :: MonadObelisk m
445+ => (ExitCode, String, String)
446+ -> m (Maybe Text)
447+ handleBuildFailure (ex, out, err) = case ex of
448+ ExitSuccess -> pure $ Just $ T.pack out
449+ _ -> do
450+ putLog Error $
451+ ("Static assets build failed: " <>) $
452+ T.unlines $ reverse $ take 10 $ reverse $ T.lines $ T.pack err
453+ pure Nothing
454+ showDerivation :: MonadObelisk m => m (Maybe Text)
455+ showDerivation =
456+ handleBuildFailure <=< readCreateProcessWithExitCode $
457+ setCwd (Just root) $ ProcessSpec
458+ { _processSpec_createProcess = Proc.proc nixExePath
459+ [ "show-derivation"
460+ , "-f", "."
461+ , "passthru.staticFilesImpure"
462+ ]
463+ , _processSpec_overrideEnv = Nothing
464+ }
465+ buildStaticCatchErrors :: MonadObelisk m => m (Maybe Text)
466+ buildStaticCatchErrors = handleBuildFailure =<<
467+ buildStaticFilesDerivationAndSymlink
468+ readCreateProcessWithExitCode
469+ root
470+
471+buildStaticFilesDerivationAndSymlink
472+ :: MonadObelisk m
473+ => (ProcessSpec -> m a)
474+ -> FilePath
475+ -> m a
476+buildStaticFilesDerivationAndSymlink f root = f $
477+ setCwd (Just root) $ ProcessSpec
478+ { _processSpec_createProcess = Proc.proc
479+ nixBuildExePath
480+ [ "-o", "static.out"
352481 , "-E", "(import ./. {}).passthru.staticFilesImpure"
353482 ]
354− else readProcessAndLogStderr Debug $ setCwd (Just root) $
355− proc nixExePath ["eval", "-f", ".", "passthru.staticFilesImpure", "--raw"]
483+ , _processSpec_overrideEnv = Nothing
484+ }