{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module NixFreezeTree (main) where
import BuilderDirs (BuilderDirs (..))
import Config (Config (..))
import qualified Config as C
import Control.Exception (catch)
import Control.Monad (when)
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Reader (ReaderT (..), asks, local)
import Data.Bool (bool)
import Data.Functor (void)
import Data.Functor.Identity (Identity (..))
import Data.List (isSuffixOf)
import Data.Text (Text)
import qualified Data.Text.IO as T
import Nix.Pretty (prettyNix)
import NixBuilder (mkBuildExpr)
import Options.Applicative (execParser)
import Path (Abs, Dir, Path, PathException, (</>))
import qualified Path as P
import Prettyprinter (defaultLayoutOptions, layoutPretty)
import Prettyprinter.Render.Text (renderStrict)
import qualified System.Directory as D
import System.Directory.Tree
( AnchoredDirTree (..),
DirTree (..),
FileName,
)
import qualified System.Directory.Tree as DT
import System.Exit (exitFailure)
import System.IO (hPutStrLn, stderr)
buildExprTree :: Path Abs Dir -> IO (DirTree Text)
buildExprTree p = flip runReaderT (BuilderDirs p [P.reldir|.|]) $ do
(_ :/ inDirTree) <- asks _root >>= liftIO . DT.build . P.toFilePath
case inDirTree of
Dir _ fs -> go (".", fs) -- Use "." to avoid the root in output paths
_ -> fail "Should never happen"
where
-- Walk the directory tree, building the @default.nix@ files, and
-- keeping an absolute path to where we are in the ReaderT
-- context.
go :: (FileName, [DirTree a]) -> ReaderT BuilderDirs IO (DirTree Text)
go (dirName, dirFiles) = do
relDirName <- P.parseRelDir dirName
local (\b -> b {_subdir = _subdir b </> relDirName}) $ do
files <- traverse P.parseRelFile [f | File f _ <- dirFiles]
dirs <- traverse P.parseRelDir [d | Dir d _ <- dirFiles]
defaultNix <- renderNix <$> mkBuildExpr files dirs
subdirs <- traverse go [(d, fs) | Dir d fs <- dirFiles]
pure . Dir dirName $ File "default.nix" defaultNix : subdirs
renderNix = renderStrict . layoutPretty defaultLayoutOptions . prettyNix
data DirConstraint = MustNameDirectory | MustNameDirectoryIfExists
toAbsDir :: DirConstraint -> FilePath -> IO (Path Abs Dir)
toAbsDir constraint d = liftIO $ do
absD <-
(D.canonicalizePath d >>= P.parseAbsDir)
`catch` \(_ :: PathException) -> dieD "does not name a directory"
isDir <- D.doesDirectoryExist d
if isDir
then pure absD
else case constraint of
MustNameDirectory -> dieD "does not name a directory"
MustNameDirectoryIfExists ->
D.doesPathExist d
>>= bool (pure absD) (dieD "names something other than a directory")
where
dieD m = die $ show d <> " " <> m
writeNixTree :: Config Identity -> IO ()
writeNixTree cfg = do
outRoot <- toAbsDir MustNameDirectoryIfExists $ get _outputRoot
inDir <- toAbsDir MustNameDirectory $ get _inDir
let outRootPath = P.toFilePath outRoot
outPathTree@(_ :/ outFiles) <- liftIO $ DT.build outRootPath
when (defaultNixExists outFiles) $
if get _force
then do
vPutStrLn "a default.nix exists somewhere in the output tree, cleaning"
void . liftIO $ flip DT.writeDirectoryWith outPathTree $ \fp _ ->
when ("default.nix" `isSuffixOf` fp) $ do
vPutStrLn $ "deleting " <> fp
D.removePathForcibly fp
else die "a default.nix exists somewhere in the output tree, cannot proceed"
outTree <- buildExprTree inDir
void $ flip DT.writeDirectoryWith (outRootPath :/ outTree) $ \fp t -> do
vPutStrLn . ("writing " <>) =<< D.canonicalizePath fp
T.writeFile fp t
where
get f = runIdentity $ f cfg
defaultNixExists (File n _) = n == "default.nix"
defaultNixExists (Dir _ cs) = any defaultNixExists cs
defaultNixExists Failed {} = False
vPutStrLn msg = when (get _verbose) $ putStrLn msg
main :: IO ()
main =
execParser C.configParserInfo
>>= maybe (fail "Should be impossible") writeNixTree . C.checkConfig
die :: (MonadIO m) => String -> m a
die msg = liftIO $ hPutStrLn stderr ("FATAL: " <> msg) *> exitFailure