@@ -8,11 +8,13 @@ module Obelisk.Command.Run where
88
99import Control.Arrow ((&&&))
1010import Control.Exception (Exception, bracket)
11+import qualified Control.Lens as Lens
1112import Control.Monad (filterM, unless)
1213import Control.Monad.Except (runExceptT, throwError)
1314import Control.Monad.IO.Class (liftIO)
1415import Control.Monad.Reader (MonadIO)
1516import Data.Coerce (coerce)
17+import Data.Default (def)
1618import Data.Either
1719import Data.Foldable (for_, toList)
1820import qualified Data.List.NonEmpty as NE
@@ -43,15 +45,14 @@ import Language.Haskell.Extension
4345import Network.Socket hiding (Debug)
4446import System.Directory
4547import System.Environment (getExecutablePath)
46−import System.Exit (ExitCode (ExitSuccess, ExitFailure))
4748import System.FilePath
4849import qualified System.Info
49−import System.IO (hPutStr, hFlush, hClose)
50−import System.IO.Temp (withSystemTempDirectory, withSystemTempFile)
50+import System.IO.Temp (withSystemTempDirectory)
5151import System.Process (waitForProcess)
5252
5353import Obelisk.App (MonadObelisk)
5454import Obelisk.CliApp (Severity (..) , failWith, putLog, proc, readCreateProcessWithExitCode, setCwd, setDelegateCtlc, createProcess_)
55+import Obelisk.Command.Nix
5556import Obelisk.Command.Project (withProjectRoot, nixShellWithPkgs, findProjectAssets)
5657import Obelisk.Command.Utils (findExePath, ghcidExePath)
5758
@@ -90,34 +91,39 @@ profile mProfileBaseName = withProjectRoot "." $ \root -> do
9091 putLog Debug $ "Assets impurely loaded from: " <> assets
9192 putLog Debug "Using profiled build of project."
9293 time <- liftIO $ formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" <$> getCurrentTime
93− let exeSource =
94− unlines $
95− [ "module Main where"
96− , "import Control.Exception"
97− , "import Reflex.Profiled"
98− , "import System.Environment" ]
99− <> obRunImports <>
100− [ "main :: IO ()"
101− , "main = getArgs >>= \\args -> (Obelisk.Run.run (read (args !! 0)) (Obelisk.Run.runServeAsset (args !! 1)) Backend.backend Frontend.frontend) `finally` writeProfilingData \"" <> profileBaseName <> ".rprof\"" ]
102− -- Sane flags to enable by default, enable time profiling +
94+ profileBaseName <- case mProfileBaseName of
95+ Just baseName -> pure baseName
96+ Nothing -> do
97+ let profileDirectory = root </> "profile"
98+ liftIO $ createDirectoryIfMissing False profileDirectory
99+ pure $ profileDirectory </> time
100+ let -- Sane flags to enable by default, enable time profiling +
103101 -- closure heap profiling.
104102 rtsFlags = [ "+RTS", "-p", "-po" <> profileBaseName, "-hc", "-RTS" ]
105− profileDirectory = root </> "profile"
106− profileBaseName = fromMaybe (profileDirectory </> time) mProfileBaseName
107− liftIO $ createDirectoryIfMissing False profileDirectory
108− withSystemTempFile "ob-run-profiled.hs" $ \hsFname hsHandle -> withSystemTempFile "ob-run" $ \exeFname exeHandle -> do
109− liftIO $ hPutStr hsHandle exeSource
110− liftIO $ hFlush hsHandle
111− (_, _, _, ph1) <- createProcess_ "nixGhcWithProfiling" $ setCwd (Just root) $ proc "nix-shell" [ "-p", "((import ./. {}).profiled.ghc.ghcWithPackages (p: [ p.backend p.frontend]))", "--run", unwords [ "ghc", "-x", "hs", "-prof", "-fno-prof-auto", hsFname, "-o", exeFname ] ]
112− code <- liftIO $ waitForProcess ph1
113− case code of
114− ExitSuccess -> do
115− liftIO $ hClose exeHandle
116− (_, _, _, ph2) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc exeFname ([show freePort, T.unpack assets] <> rtsFlags)
117− _ <- liftIO $ waitForProcess ph2
118− pure ()
119− ExitFailure _ -> do
120− pure ()
103+ nixBuildExpr = unlines $
104+ [ "(with (import ./. {});"
105+ , "let"
106+ , " exeSource = obelisk.nixpkgs.writeText \"ob-run\" ''"
107+ , "module Main where"
108+ , "import Control.Exception"
109+ , "import Reflex.Profiled"
110+ , "import System.Environment" ]
111+ <> obRunImports <>
112+ [ "main :: IO ()"
113+ , "main = getArgs >>= \\args -> (Obelisk.Run.run (read (args !! 0)) (Obelisk.Run.runServeAsset (args !! 1)) Backend.backend Frontend.frontend) `finally` writeProfilingData \"" <> profileBaseName <> ".rprof\""
114+ , " '';"
115+ , "in obelisk.nixpkgs.runCommand \"ob-run\" {"
116+ , " buildInputs = [ (profiled.ghc.ghcWithPackages (p: [ p.backend p.frontend])) ];"
117+ , "} \"ghc -x hs -prof -fno-prof-auto ${exeSource} -o $out\")" ]
118+ exePath <- nixCmd $ NixCmd_Build $ def
119+ Lens.& nixBuildConfig_outLink Lens..~ OutLink_None
120+ Lens.& nixCmdConfig_target Lens..~ Target
121+ { _target_path = Nothing
122+ , _target_attr = Nothing
123+ , _target_expr = Just nixBuildExpr }
124+ (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc exePath ([show freePort, T.unpack assets] <> rtsFlags)
125+ _ <- liftIO $ waitForProcess ph
126+ pure ()
121127
122128run
123129 :: MonadObelisk m