git.iko.soy/obelisk
on ba85ebf help sign in
obelisk/lib/command/src/Obelisk/Command/Run.hs
393 lines 17 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TupleSections #-}
7{-# LANGUAGE QuasiQuotes #-}
8module Obelisk.Command.Run where
10import Control.Arrow ((&&&))
11import Control.Exception (Exception, bracket)
12import Control.Lens (ifor, (.~), (&))
13import Control.Monad (filterM, unless)
14import Control.Monad.Except (runExceptT, throwError)
15import Control.Monad.IO.Class (liftIO)
16import Control.Monad.Reader (MonadIO)
17import Data.Coerce (coerce)
18import Data.Default (def)
19import Data.Either
20import Data.Foldable (for_, toList)
21import qualified Data.List.NonEmpty as NE
22import Data.Map (Map)
23import qualified Data.Map as Map
24import Data.Maybe
25import qualified Data.Set as Set
26import Data.String.Here (hereLit)
27import Data.Text (Text)
28import qualified Data.Text as T
29import Data.Traversable (for)
30import Debug.Trace (trace)
31import Distribution.Compiler (CompilerFlavor(..))
32import Distribution.PackageDescription.Parsec (parseGenericPackageDescription)
33import Distribution.Parsec.ParseResult (runParseResult)
34import qualified Distribution.System as Dist
35import Distribution.Types.BuildInfo
36import Distribution.Types.CondTree
37import Distribution.Types.GenericPackageDescription
38import Distribution.Types.Library
39import Distribution.Utils.Generic
40import qualified Distribution.Parsec.Common as Dist
41import qualified Hpack.Config as Hpack
42import qualified Hpack.Render as Hpack
43import qualified Hpack.Yaml as Hpack
44import Language.Haskell.Extension
45import Network.Socket hiding (Debug)
46import System.Directory
47import System.Environment (getExecutablePath)
48import System.FilePath
49import qualified System.Info
50import System.IO.Temp (withSystemTempDirectory)
51import System.Process (waitForProcess)
53import Obelisk.App (MonadObelisk)
54import Obelisk.CliApp (Severity (..) , failWith, putLog, proc, readCreateProcessWithExitCode, setCwd, setDelegateCtlc, createProcess_)
55import Obelisk.Command.Nix
56import Obelisk.Command.Project (withProjectRoot, nixShellWithPkgs, findProjectAssets)
57import Obelisk.Command.Utils (findExePath, ghcidExePath)
59data CabalPackageInfo = CabalPackageInfo
60 { _cabalPackageInfo_packageFile :: FilePath
61 , _cabalPackageInfo_packageName :: T.Text
62 , _cabalPackageInfo_packageRoot :: FilePath
63 , _cabalPackageInfo_buildable :: Bool
64 , _cabalPackageInfo_sourceDirs :: NE.NonEmpty FilePath
65 -- ^ List of hs src dirs of the library component
66 , _cabalPackageInfo_defaultExtensions :: [Extension]
67 -- ^ List of globally enable extensions of the library component
68 , _cabalPackageInfo_defaultLanguage :: Maybe Language
69 -- ^ List of globally set languages of the library component
70 , _cabalPackageInfo_compilerOptions :: [(CompilerFlavor, [String])]
71 -- ^ List of compiler-specific options (e.g., the "ghc-options" field of the cabal file)
72 }
74-- | Used to signal to obelisk that it's being invoked as a preprocessor
75preprocessorIdentifier :: String
76preprocessorIdentifier = "__preprocessor-apply-packages"
78profile
79 :: MonadObelisk m
80 => FilePath
81 -> m ()
82profile profileBaseName = withProjectRoot "." $ \root -> do
83 putLog Debug "Using profiled build of project."
84 liftIO $ createDirectoryIfMissing False $ takeDirectory profileBaseName
85 let -- Sane flags to enable by default, enable time profiling +
86 -- closure heap profiling.
87 rtsFlags = [ "+RTS", "-p", "-po" <> profileBaseName, "-hc", "-RTS" ]
88 nixBuildExpr = [hereLit|
89with (import ./. {});
90let
91 exeSource = obelisk.nixpkgs.writeText "ob-run" ''
92module Main where
94import Control.Exception
95import Reflex.Profiled
96import System.Environment
98import qualified Obelisk.Run
99import qualified Frontend
100import qualified Backend
102main :: IO ()
103main = do
104 args <- getArgs
105 let port = read $ args !! 0
106 assets = args !! 1
107 profileFile = (args !! 2) <> ".rprof"
108 Obelisk.Run.run port (Obelisk.Run.runServeAsset assets) Backend.backend Frontend.frontend `finally` writeProfilingData profileFile
109 '';
110in obelisk.nixpkgs.runCommand "ob-run" {
111 buildInputs = [ (profiled.ghc.ghcWithPackages (p: [ p.backend p.frontend])) ];
112} "ghc -x hs -prof -fno-prof-auto ${exeSource} -o $out"
113|]
114 exePath <- nixCmd $ NixCmd_Build $ def
115 & nixBuildConfig_outLink .~ OutLink_None
116 & nixCmdConfig_target .~ Target
117 { _target_path = Nothing
118 , _target_attr = Nothing
119 , _target_expr = Just nixBuildExpr }
120 assets <- findProjectAssets root
121 putLog Debug $ "Assets impurely loaded from: " <> assets
122 freePort <- getFreePort
123 (_, _, _, ph) <- createProcess_ "runProfExe" $ setCwd (Just root) $ setDelegateCtlc True $ proc exePath ([show freePort, T.unpack assets, profileBaseName] <> rtsFlags)
124 _ <- liftIO $ waitForProcess ph
125 pure ()
127run
128 :: MonadObelisk m
129 => m ()
130run = withProjectRoot "." $ \root -> do
131 pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
132 withGhciScript pkgs root $ \dotGhciPath -> do
133 freePort <- getFreePort
134 assets <- findProjectAssets root
135 putLog Debug $ "Assets impurely loaded from: " <> assets
136 runGhcid root True dotGhciPath pkgs $ Just $ unwords
137 [ "Obelisk.Run.run"
138 , show freePort
139 , "(Obelisk.Run.runServeAsset " ++ show assets ++ ")"
140 , "Backend.backend"
141 , "Frontend.frontend"
142 ]
144runRepl :: MonadObelisk m => m ()
145runRepl = withProjectRoot "." $ \root -> do
146 pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
147 withGhciScript pkgs "." $ \dotGhciPath ->
148 runGhciRepl root pkgs dotGhciPath
150runWatch :: MonadObelisk m => m ()
151runWatch = withProjectRoot "." $ \root -> do
152 pkgs <- fmap toList . parsePackagesOrFail =<< getLocalPkgs root
153 withGhciScript pkgs root $ \dotGhciPath ->
154 runGhcid root True dotGhciPath pkgs Nothing
156-- | Relative paths to local packages of an obelisk project.
157--
158-- These are a combination of the obelisk predefined local packages,
159-- and any packages that the user has set with the @packages@ argument
160-- to the Nix @project@ function.
161getLocalPkgs :: MonadObelisk m => FilePath -> m [FilePath]
162getLocalPkgs root = do
163 obeliskPaths <- runFind ["-L", root, "-name", ".obelisk", "-type", "d"]
165 -- We do not want to find packages that are embedded inside other obelisk projects, unless that
166 -- obelisk project is our own.
167 let exclusions = filter (/= root) $ map takeDirectory obeliskPaths
168 fmap (map (makeRelative ".")) $ runFind $
169 ["-L", root, "(", "-name", "*.cabal", "-o", "-name", Hpack.packageConfig, ")", "-a", "-type", "f"]
170 <> concat [["-not", "-path", p </> "*"] | p <- exclusions]
171 where
172 runFind args = do
173 (_exitCode, out, err) <- readCreateProcessWithExitCode $ proc findExePath args
174 putLog Debug $ T.strip $ T.pack err
175 pure $ map T.unpack $ T.lines $ T.strip $ T.pack out
177data GuessPackageFileError = GuessPackageFileError_Ambiguous [FilePath] | GuessPackageFileError_NotFound
178 deriving (Eq, Ord, Show)
179instance Exception GuessPackageFileError
181newtype HPackFilePath = HPackFilePath { unHPackFilePath :: FilePath } deriving (Eq, Ord, Show)
182newtype CabalFilePath = CabalFilePath { unCabalFilePath :: FilePath } deriving (Eq, Ord, Show)
184-- | Given a directory, try to guess what the appropriate @.cabal@ or @package.yaml@ file is for the package.
185guessCabalPackageFile
186 :: (MonadIO m)
187 => FilePath -- ^ Directory or path to search for cabal package
188 -> m (Either GuessPackageFileError (Either CabalFilePath HPackFilePath))
189guessCabalPackageFile pkg = do
190 liftIO (doesDirectoryExist pkg) >>= \case
191 False -> case cabalOrHpackFile pkg of
192 (Just hpack@(Right _)) -> pure $ Right hpack
193 (Just cabal@(Left (CabalFilePath cabalFilePath))) -> do
194 -- If the cabal file has a sibling hpack file, we use that instead
195 -- since running hpack often generates a sibling cabal file
196 let possibleHpackSibling = takeDirectory cabalFilePath </> Hpack.packageConfig
197 hasHpackSibling <- liftIO $ doesFileExist possibleHpackSibling
198 pure $ Right $ if hasHpackSibling then Right (HPackFilePath possibleHpackSibling) else cabal
199 Nothing -> pure $ Left GuessPackageFileError_NotFound
200 True -> do
201 candidates <- liftIO $
202 filterM (doesFileExist . either unCabalFilePath unHPackFilePath)
203 =<< mapMaybe (cabalOrHpackFile . (pkg </>)) <$> listDirectory pkg
204 pure $ case partitionEithers candidates of
205 ([hpack], _) -> Right $ Left hpack
206 ([], [cabal]) -> Right $ Right cabal
207 ([], []) -> Left GuessPackageFileError_NotFound
208 (hpacks, cabals) -> Left $ GuessPackageFileError_Ambiguous $ coerce hpacks <> coerce cabals
210cabalOrHpackFile :: FilePath -> Maybe (Either CabalFilePath HPackFilePath)
211cabalOrHpackFile = \case
212 x | takeExtension x == ".cabal" -> Just (Left $ CabalFilePath x)
213 | takeFileName x == Hpack.packageConfig -> Just (Right $ HPackFilePath x)
214 | otherwise -> Nothing
216-- | Parses the cabal package in a given directory.
217-- This automatically figures out which .cabal file or package.yaml (hpack) file to use in the given directory.
218parseCabalPackage
219 :: MonadObelisk m
220 => FilePath -- ^ Package directory
221 -> m (Maybe CabalPackageInfo)
222parseCabalPackage dir = parseCabalPackage' dir >>= \case
223 Left err -> Nothing <$ putLog Error err
224 Right (warnings, pkgInfo) -> do
225 for_ warnings $ putLog Warning . T.pack . show
226 pure $ Just pkgInfo
228-- | Like 'parseCabalPackage' but returns errors and warnings directly so as to avoid 'MonadObelisk'.
229parseCabalPackage'
230 :: (MonadIO m)
231 => FilePath -- ^ Package directory
232 -> m (Either T.Text ([Dist.PWarning], CabalPackageInfo))
233parseCabalPackage' pkg = runExceptT $ do
234 (cabalContents, packageFile, packageName) <- guessCabalPackageFile pkg >>= \case
235 Left GuessPackageFileError_NotFound -> throwError $ "No .cabal or package.yaml file found in " <> T.pack pkg
236 Left (GuessPackageFileError_Ambiguous _) -> throwError $ "Unable to determine which .cabal file to use in " <> T.pack pkg
237 Right (Left (CabalFilePath file)) -> (, file, takeBaseName file) <$> liftIO (readUTF8File file)
238 Right (Right (HPackFilePath file)) -> do
239 let
240 decodeOptions = Hpack.DecodeOptions (Hpack.ProgramName "ob") file Nothing Hpack.decodeYaml
241 liftIO (Hpack.readPackageConfig decodeOptions) >>= \case
242 Left err -> throwError $ T.pack $ "Failed to parse " <> file <> ": " <> err
243 Right (Hpack.DecodeResult hpackPackage _ _ _) -> pure (Hpack.renderPackage [] hpackPackage, file, Hpack.packageName hpackPackage)
245 let
246 (warnings, result) = runParseResult $ parseGenericPackageDescription $ toUTF8BS cabalContents
247 osConfVar = case System.Info.os of
248 "linux" -> Just Dist.Linux
249 "darwin" -> Just Dist.OSX
250 _ -> trace "Unrecgonized System.Info.os" Nothing
251 archConfVar = Just Dist.X86_64 -- TODO: Actually infer this
252 evalConfVar v = Right $ case v of
253 OS osVar -> Just osVar == osConfVar
254 Arch archVar -> Just archVar == archConfVar
255 Impl GHC _ -> True -- TODO: Actually check version range
256 _ -> False
257 case condLibrary <$> result of
258 Right (Just condLib) -> do
259 let (_, lib) = simplifyCondTree evalConfVar condLib
260 pure $ (warnings,) $ CabalPackageInfo
261 { _cabalPackageInfo_packageName = T.pack packageName
262 , _cabalPackageInfo_packageFile = packageFile
263 , _cabalPackageInfo_packageRoot = takeDirectory packageFile
264 , _cabalPackageInfo_buildable = buildable $ libBuildInfo lib
265 , _cabalPackageInfo_sourceDirs =
266 fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib
267 , _cabalPackageInfo_defaultExtensions =
268 defaultExtensions $ libBuildInfo lib
269 , _cabalPackageInfo_defaultLanguage =
270 defaultLanguage $ libBuildInfo lib
271 , _cabalPackageInfo_compilerOptions = options $ libBuildInfo lib
272 }
273 Right Nothing -> throwError "Haskell package has no library component"
274 Left (_, errors) ->
275 throwError $ T.pack $ "Failed to parse " <> packageFile <> ":\n" <> unlines (map show errors)
277parsePackagesOrFail :: MonadObelisk m => [FilePath] -> m (NE.NonEmpty CabalPackageInfo)
278parsePackagesOrFail dirs = do
279 (pkgDirErrs, packageInfos') <- fmap partitionEithers $ for dirs $ \dir -> do
280 flip fmap (parseCabalPackage dir) $ \case
281 Just packageInfo
282 | _cabalPackageInfo_buildable packageInfo -> Right packageInfo
283 _ -> Left dir
285 let packagesByName = Map.fromListWith (<>) [(_cabalPackageInfo_packageName p, p NE.:| []) | p <- packageInfos']
286 unambiguous <- ifor packagesByName $ \packageName ps -> case ps of
287 p NE.:| [] -> pure p -- No ambiguity here
288 p NE.:| _ -> do
289 putLog Warning $ T.pack $
290 "Packages named '" <> T.unpack packageName <> "' appear in " <> show (length ps) <> " different locations: "
291 <> intercalate ", " (map _cabalPackageInfo_packageFile $ toList ps)
292 <> "; Picking " <> _cabalPackageInfo_packageFile p
293 pure p
295 packageInfos <- case NE.nonEmpty $ toList unambiguous of
296 Nothing -> failWith $ T.pack $ "No valid, buildable packages found in " <> intercalate ", " dirs
297 Just xs -> pure xs
299 unless (null pkgDirErrs) $
300 putLog Warning $ T.pack $ "Failed to find buildable packages in " <> intercalate ", " pkgDirErrs
302 pure packageInfos
304packageInfoToNamePathMap :: [CabalPackageInfo] -> Map Text FilePath
305packageInfoToNamePathMap = Map.fromList . map (_cabalPackageInfo_packageName &&& _cabalPackageInfo_packageRoot)
307-- | Create ghci configuration to load the given packages
308withGhciScript
309 :: MonadObelisk m
310 => [CabalPackageInfo] -- ^ List of packages to load into ghci
311 -> FilePath -- ^ All paths written to the .ghci file will be relative to this path
312 -> (FilePath -> m ()) -- ^ Action to run with the path to generated temporary .ghci
313 -> m ()
314withGhciScript packageInfos pathBase f = do
315 selfExe <- liftIO getExecutablePath
316 let
317 packageNames = Set.fromList $ map _cabalPackageInfo_packageName packageInfos
318 modulesToLoad = mconcat
319 [ [ "Obelisk.Run" | "obelisk-run" `Set.member` packageNames ]
320 , [ "Backend" | "backend" `Set.member` packageNames ]
321 , [ "Frontend" | "frontend" `Set.member` packageNames ]
322 ]
323 dotGhci = unlines $
324 -- TODO: Shell escape
325 [ ":set -F -pgmF " <> selfExe <> " -optF " <> preprocessorIdentifier <> " " <> unwords (map (("-optF " <>) . makeRelative pathBase . _cabalPackageInfo_packageFile) packageInfos)
326 , ":set -i" <> intercalate ":" (packageInfos >>= rootedSourceDirs)
327 , if null modulesToLoad then "" else ":load " <> unwords modulesToLoad
328 , "import qualified Obelisk.Run"
329 , "import qualified Frontend"
330 , "import qualified Backend" ]
331 withSystemTempDirectory "ob-ghci" $ \fp -> do
332 let dotGhciPath = fp </> ".ghci"
333 liftIO $ writeFile dotGhciPath dotGhci
334 f dotGhciPath
336 where
337 rootedSourceDirs pkg = NE.toList $
338 makeRelative pathBase . (_cabalPackageInfo_packageRoot pkg </>) <$> _cabalPackageInfo_sourceDirs pkg
340-- | Run ghci repl
341runGhciRepl
342 :: MonadObelisk m
343 => FilePath -- ^ Path to project root
344 -> [CabalPackageInfo]
345 -> FilePath -- ^ Path to .ghci
346 -> m ()
347runGhciRepl root packages dotGhci =
348 -- NOTE: We do *not* want to use $(staticWhich "ghci") here because we need the
349 -- ghc that is provided by the shell in the user's project.
350 nixShellWithPkgs root True False (packageInfoToNamePathMap packages) $ Just $ "ghci " <> makeBaseGhciOptions dotGhci -- TODO: Shell escape
352-- | Run ghcid
353runGhcid
354 :: MonadObelisk m
355 => FilePath -- ^ Path to project root
356 -> Bool -- ^ Should we chdir to root when running this process?
357 -> FilePath -- ^ Path to .ghci
358 -> [CabalPackageInfo]
359 -> Maybe String -- ^ Optional command to run at every reload
360 -> m ()
361runGhcid root chdirToRoot dotGhci packages mcmd =
362 nixShellWithPkgs root True chdirToRoot (packageInfoToNamePathMap packages) (Just $ unwords $ ghcidExePath : opts) -- TODO: Shell escape
363 where
364 opts =
365 [ "-W"
366 , "--command='ghci -ignore-dot-ghci " <> makeBaseGhciOptions dotGhci <> "' "
367 , "--outputfile=ghcid-output.txt"
368 ] <> map (\x -> "--reload='" <> x <> "'") reloadFiles
369 <> map (\x -> "--restart='" <> x <> "'") restartFiles
370 <> testCmd
371 testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'") -- TODO: Shell escape
373 adjustRoot x = if chdirToRoot then makeRelative root x else x
374 reloadFiles = map adjustRoot [root </> "config"]
375 restartFiles = map (adjustRoot . _cabalPackageInfo_packageFile) packages
377makeBaseGhciOptions :: FilePath -> String
378makeBaseGhciOptions dotGhci =
379 unwords
380 [ "-no-user-package-db"
381 , "-package-env -"
382 , "-ghci-script " <> dotGhci
383 ]
385getFreePort :: MonadIO m => m PortNumber
386getFreePort = liftIO $ withSocketsDo $ do
387 addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")
388 bracket (open addr) close socketPort
389 where
390 open addr = do
391 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
392 bind sock (addrAddress addr)
393 return sock