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