git.iko.soy/obelisk
on jam@export-create-process help sign in
obelisk/lib/command/src/Obelisk/Command.hs
451 lines 21 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TupleSections #-}
7module Obelisk.Command where
9import Control.Monad.IO.Class (MonadIO, liftIO)
10import Data.Bool (bool)
11import Data.Foldable (for_)
12import Data.List (isInfixOf, isPrefixOf)
13import Data.List.NonEmpty (NonEmpty, nonEmpty)
14import qualified Data.List.NonEmpty as NonEmpty
15import qualified Data.Map as Map
16import qualified Data.Text as T
17import Data.Traversable (for)
18import Options.Applicative
19import Options.Applicative.Help.Pretty (text, (<$$>))
20import System.Directory
21import System.Environment
22import System.FilePath
23import qualified System.Info
24import System.IO (hIsTerminalDevice, stdout)
25import System.Posix.Process (executeFile)
27import Obelisk.App
28import Obelisk.CliApp
29import Obelisk.Command.Deploy
30import Obelisk.Command.Project
31import Obelisk.Command.Run
32import Obelisk.Command.Thunk
33import qualified Obelisk.Command.VmBuilder as VmBuilder
34import qualified Obelisk.Command.Preprocessor as Preprocessor
37data Args = Args
38 { _args_noHandOffPassed :: Bool
39 -- ^ This flag is actually handled outside of the optparse-applicative parser, but we detect whether
40 -- it has gotten through in order to notify the user that it should only be passed once and as the very
41 -- first argument
42 , _args_verbose :: Bool
43 , _args_command :: ObCommand
44 }
45 deriving Show
47newtype ArgsConfig = ArgsConfig
48 { _argsConfig_enableVmBuilderByDefault :: Bool
49 }
51args :: ArgsConfig -> Parser Args
52args cfg = Args <$> noHandoff <*> verbose <*> obCommand cfg
54noHandoff :: Parser Bool
55noHandoff = flag False True $ mconcat
56 [ long "no-handoff"
57 , help "Do not hand off execution to project-specific implementation of this command"
58 , hidden
59 ]
61verbose :: Parser Bool
62verbose = flag False True $ mconcat
63 [ long "verbose"
64 , short 'v'
65 , help "Be more verbose"
66 ]
68argsInfo :: ArgsConfig -> ParserInfo Args
69argsInfo cfg = info (args cfg <**> helper) $ mconcat
70 [ fullDesc
71 , progDesc "Manage Obelisk projects"
72 ]
74initSource :: Parser InitSource
75initSource = foldl1 (<|>)
76 [ pure InitSource_Default
77 , InitSource_Branch <$> strOption (long "branch" <> metavar "BRANCH" <> help "Initialize the project using the given BRANCH of Obelisk's official repository")
78 , InitSource_Symlink <$> strOption (long "symlink" <> action "directory" <> metavar "PATH" <> help "(Use with caution) Initialize the project using the copy of Obelisk found at the given PATH")
79 ]
81initForce :: Parser Bool
82initForce = switch (long "force" <> help "Allow ob init to overwrite files")
84data ObCommand
85 = ObCommand_Init InitSource Bool
86 | ObCommand_Deploy DeployCommand
87 | ObCommand_Run [(FilePath, Interpret)]
88 | ObCommand_Profile String [String]
89 | ObCommand_Thunk ThunkOption
90 | ObCommand_Repl [(FilePath, Interpret)]
91 | ObCommand_Watch [(FilePath, Interpret)]
92 | ObCommand_Shell ShellOpts
93 | ObCommand_Doc String [String] -- shell and list of packages
94 | ObCommand_Hoogle String Int -- shell and port
95 | ObCommand_Internal ObInternal
96 deriving Show
98data ObInternal
99 -- the preprocessor argument syntax is also handled outside
100 -- optparse-applicative, but it shouldn't ever conflict with another syntax
101 = ObInternal_ApplyPackages String String String [String]
102 | ObInternal_ExportGhciConfig
103 [(FilePath, Interpret)]
104 Bool -- ^ Use relative paths
105 deriving Show
107obCommand :: ArgsConfig -> Parser ObCommand
108obCommand cfg = hsubparser
109 (mconcat
110 [ command "init" $ info (ObCommand_Init <$> initSource <*> initForce) $ progDesc "Initialize an Obelisk project"
111 , command "deploy" $ info (ObCommand_Deploy <$> deployCommand cfg) $ progDesc "Prepare a deployment for an Obelisk project"
112 , command "run" $ info (ObCommand_Run <$> interpretOpts) $ progDesc "Run current project in development mode"
113 , command "profile" $ info (uncurry ObCommand_Profile <$> profileCommand) $ progDesc "Run current project with profiling enabled"
114 , command "thunk" $ info (ObCommand_Thunk <$> thunkOption) $ progDesc "Manipulate thunk directories"
115 , command "repl" $ info (ObCommand_Repl <$> interpretOpts) $ progDesc "Open an interactive interpreter"
116 , command "watch" $ info (ObCommand_Watch <$> interpretOpts) $ progDesc "Watch current project for errors and warnings"
117 , command "shell" $ info (ObCommand_Shell <$> shellOpts) $ progDesc "Enter a shell with project dependencies"
118 , command "doc" $ info (ObCommand_Doc <$> shellFlags <*> packageNames) $
119 progDesc "List paths to haddock documentation for specified packages"
120 <> footerDoc (Just $
121 text "Hint: To open the documentation you can pipe the output of this command like"
122 <$$> text "ob doc reflex reflex-dom-core | xargs -n1 xdg-open")
123 , command "hoogle" $ info (ObCommand_Hoogle <$> shellFlags <*> portOpt 8080) $ progDesc "Run a hoogle server locally for your project's dependency tree"
124 , command "internal" $ info (ObCommand_Internal <$> internalCommand) $ progDesc "Internal Obelisk commands with unstable APIs"
125 ])
127internalCommand :: Parser ObInternal
128internalCommand = hsubparser $ mconcat
129 [ command "export-ghci-configuration" $ info (ObInternal_ExportGhciConfig <$> interpretOpts <*> useRelativePathsFlag)
130 $ progDesc "Export the GHCi configuration used by ob run, etc.; useful for IDE integration"
131 ]
132 where
133 useRelativePathsFlag = switch (long "use-relative-paths" <> help "Use relative paths")
135packageNames :: Parser [String]
136packageNames = some (strArgument (metavar "PACKAGE-NAME..."))
138deployCommand :: ArgsConfig -> Parser DeployCommand
139deployCommand cfg = hsubparser $ mconcat
140 [ command "init" $ info (DeployCommand_Init <$> deployInitOpts) $ progDesc "Initialize a deployment configuration directory"
141 , command "push" $ info (DeployCommand_Push <$> remoteBuilderParser) mempty
142 , command "test" $ info (DeployCommand_Test <$> platformP) $ progDesc "Test your obelisk project from a mobile platform."
143 , command "update" $ info (pure DeployCommand_Update) $ progDesc "Update the deployment's src thunk to latest"
144 ]
145 where
146 platformP = hsubparser $ mconcat
147 [ command "android" $ info (pure (Android, [])) mempty
148 , command "ios" $ info ((,) <$> pure IOS <*> fmap pure (strArgument (metavar "TEAMID" <> help "Your Team ID - found in the Apple developer portal"))) mempty
149 ]
151 remoteBuilderParser :: Parser (Maybe RemoteBuilder)
152 remoteBuilderParser =
153 flag (if enabledByDefault then enabled else Nothing) enabled (mconcat
154 [ long $ "enable-" <> flagBase
155 , help $ "Enable " <> flagDesc <> (if enabledByDefault then " (default)" else "")
156 ])
157 <|> flag enabled Nothing (mconcat
158 [ long $ "disable-" <> flagBase
159 , help $ "Disable a " <> flagDesc <> (if not enabledByDefault then " (default)" else "")
160 ])
161 where
162 enabledByDefault = _argsConfig_enableVmBuilderByDefault cfg
163 enabled = Just RemoteBuilder_ObeliskVM
164 flagBase = "vm-builder"
165 flagDesc = "managed Linux virtual machine as a Nix remote builder (requires Docker)"
168deployInitOpts :: Parser DeployInitOpts
169deployInitOpts = DeployInitOpts
170 <$> strArgument (action "directory" <> metavar "DEPLOYDIR" <> help "Path to a directory where the deployment repository will be initialized")
171 <*> strOption (long "ssh-key" <> action "file" <> metavar "SSHKEY" <> help "Path to an SSH key that will be *copied* to the deployment repository")
172 <*> some (strOption (long "hostname" <> metavar "HOSTNAME" <> help "hostname of the deployment target"))
173 <*> strOption (long "route" <> metavar "PUBLICROUTE" <> help "Publicly accessible URL of your app")
174 <*> strOption (long "admin-email" <> metavar "ADMINEMAIL" <> help "Email address where administrative alerts will be sent")
175 <*> flag True False (long "disable-https" <> help "Disable automatic https configuration for the backend")
177type TeamID = String
178data RemoteBuilder = RemoteBuilder_ObeliskVM
179 deriving (Eq, Show)
181data DeployCommand
182 = DeployCommand_Init DeployInitOpts
183 | DeployCommand_Push (Maybe RemoteBuilder)
184 | DeployCommand_Test (PlatformDeployment, [String])
185 | DeployCommand_Update
186 deriving Show
188profileCommand :: Parser (String, [String])
189profileCommand = (,)
190 <$> strOption
191 ( long "output"
192 <> short 'o'
193 <> help "Base output to use for profiling output. Suffixes are added to this based on the profiling type. Defaults to a timestamped path in the profile/ directory in the project's root."
194 <> metavar "PATH"
195 <> value "profile/%Y-%m-%dT%H:%M:%S"
196 <> showDefault
197 )
198 <*> (words <$> strOption
199 ( long "rts-flags"
200 <> help "RTS Flags to pass to the executable."
201 <> value "-p -hc"
202 <> metavar "FLAGS"
203 <> showDefault
204 ))
206thunkConfig :: Parser ThunkConfig
207thunkConfig = ThunkConfig
208 <$>
209 ( flag' (Just True) (long "private" <> help "Mark thunks as pointing to a private repository")
210 <|> flag' (Just False) (long "public" <> help "Mark thunks as pointing to a public repository")
211 <|> pure Nothing
212 )
214thunkUpdateConfig :: Parser ThunkUpdateConfig
215thunkUpdateConfig = ThunkUpdateConfig
216 <$> optional (strOption (long "branch" <> metavar "BRANCH" <> help "Use the given branch when looking for the latest revision"))
217 <*> thunkConfig
219thunkPackConfig :: Parser ThunkPackConfig
220thunkPackConfig = ThunkPackConfig
221 <$> switch (long "force" <> short 'f' <> help "Force packing thunks even if there are branches not pushed upstream, uncommitted changes, stashes. This will cause changes that have not been pushed upstream to be lost; use with care.")
222 <*> thunkConfig
224data ThunkOption = ThunkOption
225 { _thunkOption_thunks :: NonEmpty FilePath
226 , _thunkOption_command :: ThunkCommand
227 } deriving Show
229data ThunkCommand
230 = ThunkCommand_Update ThunkUpdateConfig
231 | ThunkCommand_Unpack
232 | ThunkCommand_Pack ThunkPackConfig
233 deriving Show
235thunkOption :: Parser ThunkOption
236thunkOption = hsubparser $ mconcat
237 [ command "update" $ info (thunkOptionWith $ ThunkCommand_Update <$> thunkUpdateConfig) $ progDesc "Update packed thunk to latest revision available on the tracked branch"
238 , command "unpack" $ info (thunkOptionWith $ pure ThunkCommand_Unpack) $ progDesc "Unpack thunk into git checkout of revision it points to"
239 , command "pack" $ info (thunkOptionWith $ ThunkCommand_Pack <$> thunkPackConfig) $ progDesc "Pack git checkout or unpacked thunk into thunk that points at the current branch's upstream"
240 ]
241 where
242 thunkOptionWith f = ThunkOption
243 <$> ((NonEmpty.:|)
244 <$> thunkDirArg (metavar "THUNKDIRS..." <> help "Paths to directories containing thunk data")
245 <*> many (thunkDirArg mempty)
246 )
247 <*> f
248 thunkDirArg opts = fmap (dropTrailingPathSeparator . normalise) $ strArgument $ action "directory" <> opts
250data ShellOpts
251 = ShellOpts
252 { _shellOpts_shell :: String
253 , _shellOpts_interpretPaths :: [(FilePath, Interpret)]
254 , _shellOpts_command :: Maybe String
255 }
256 deriving Show
258shellFlags :: Parser String
259shellFlags =
260 flag' "ghc" (long "ghc" <> help "Enter a shell environment having ghc (default)")
261 <|> flag "ghc" "ghcjs" (long "ghcjs" <> help "Enter a shell having ghcjs rather than ghc")
262 <|> strOption (short 'A' <> long "argument" <> metavar "NIXARG" <> help "Use the environment specified by the given nix argument of `shells'")
264interpretOpts :: Parser [(FilePath, Interpret)]
265interpretOpts = many
266 ( (, Interpret_Interpret) <$>
267 strOption (common <> long "interpret" <> help
268 "Don't pre-build packages found in DIR when constructing the package database. The default behavior is \
269 \'--interpret <project-root>', which will load everything which is unpacked into GHCi. \
270 \ Use --interpret and --no-interpret multiple times to add or remove multiple trees \
271 \ from the environment. Settings for right-most directories will \
272 \ override settings for any identical directories given earlier."
273 )
274 <|> (, Interpret_NoInterpret) <$>
275 strOption (common <> long "no-interpret" <> help
276 "Make packages found in DIR available in the package database (but only when they are used dependencies). \
277 \ This will build the packages in DIR before loading GHCi. \
278 \See help for --interpret for how the two options are related."
279 )
280 )
281 where
282 common = action "directory" <> metavar "DIR"
284shellOpts :: Parser ShellOpts
285shellOpts = ShellOpts
286 <$> shellFlags
287 <*> interpretOpts
288 <*> optional (strArgument (metavar "COMMAND"))
290portOpt :: Int -> Parser Int
291portOpt dfault = option auto (long "port" <> short 'p' <> help "Port number for server" <> showDefault <> value dfault <> metavar "INT")
293parserPrefs :: ParserPrefs
294parserPrefs = defaultPrefs
295 { prefShowHelpOnEmpty = True
296 }
298-- | Create an Obelisk config for the current process.
299mkObeliskConfig :: IO Obelisk
300mkObeliskConfig = do
301 cliArgs <- getArgs
302 -- This function should not use argument parser (full argument parsing happens post handoff)
303 -- TODO: See if we can use the argument parser with a subset of the parsers to get logging level out.
304 let logLevel = toLogLevel $ any (`elem` ["-v", "--verbose"]) cliArgs
305 notInteractive <- not <$> isInteractiveTerm
306 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case
307 ObeliskError_ProcessError (ProcessFailure p code) ann ->
308 ( "Process exited with code " <> T.pack (show code) <> "; " <> reconstructCommand p
309 <> maybe "" ("\n" <>) ann
310 , 2
311 )
312 ObeliskError_Unstructured msg -> (msg, 2)
314 return $ Obelisk cliConf
315 where
316 toLogLevel = bool Notice Debug
317 isInteractiveTerm = do
318 isTerm <- hIsTerminalDevice stdout
319 -- Running in bash/fish/zsh completion
320 inShellCompletion <- liftIO $ isInfixOf "completion" . unwords <$> getArgs
322 -- Respect the user’s TERM environment variable. Dumb terminals
323 -- like Eshell cannot handle lots of control sequences that the
324 -- spinner uses.
325 termEnv <- lookupEnv "TERM"
326 let isDumb = termEnv == Just "dumb"
328 return $ isTerm && not inShellCompletion && not isDumb
330-- | For use from development obelisk repls
331--
332-- Example:
333-- > runCommand $ someFuncInMonadObelisk ...
334runCommand :: ObeliskT IO a -> IO a
335runCommand f = flip runObelisk f =<< mkObeliskConfig
337main :: IO ()
338main = runCommand . main' =<< getArgsConfig
340main' :: MonadObelisk m => ArgsConfig -> m ()
341main' argsCfg = do
342 obPath <- liftIO getExecutablePath
343 myArgs <- liftIO getArgs
344 logLevel <- getLogLevel
345 putLog Debug $ T.pack $ unwords
346 [ "Starting Obelisk <" <> obPath <> ">"
347 , "args=" <> show myArgs
348 , "logging-level=" <> show logLevel
349 ]
351 --TODO: We'd like to actually use the parser to determine whether to hand off,
352 --but in the case where this implementation of 'ob' doesn't support all
353 --arguments being passed along, this could fail. For now, we don't bother
354 --with optparse-applicative until we've done the handoff.
355 let go as = do
356 args' <- liftIO $ handleParseResult (execParserPure parserPrefs (argsInfo argsCfg) as)
357 case _args_noHandOffPassed args' of
358 False -> return ()
359 True -> putLog Warning "--no-handoff should only be passed once and as the first argument; ignoring"
360 ob $ _args_command args'
361 handoffAndGo as = findProjectObeliskCommand "." >>= \case
362 Nothing -> go as -- If not in a project, just run ourselves
363 Just impl -> do
364 -- Invoke the real implementation, using --no-handoff to prevent infinite recursion
365 putLog Debug $ "Handing off to " <> T.pack impl
366 liftIO $ executeFile impl False ("--no-handoff" : myArgs) Nothing
367 case myArgs of
368 "--no-handoff" : as -> go as -- If we've been told not to hand off, don't hand off
369 origPath:inPath:outPath:preprocessorName:packagePaths
370 | preprocessorName == preprocessorIdentifier && any (\c -> c == '.' || c == pathSeparator) origPath ->
371 ob $ ObCommand_Internal $ ObInternal_ApplyPackages origPath inPath outPath packagePaths
372 a:as -- Otherwise bash completion would always hand-off even if the user isn't trying to
373 | "--bash-completion" `isPrefixOf` a
374 && "--no-handoff" `elem` as -> go (a:as)
375 | otherwise -> handoffAndGo (a:as)
376 as -> handoffAndGo as
378ob :: MonadObelisk m => ObCommand -> m ()
379ob = \case
380 ObCommand_Init source force -> initProject source force
381 ObCommand_Deploy dc -> case dc of
382 DeployCommand_Init deployOpts -> withProjectRoot "." $ \root -> deployInit deployOpts root
383 DeployCommand_Push remoteBuilder -> do
384 deployPath <- liftIO $ canonicalizePath "."
385 deployPush deployPath $ case remoteBuilder of
386 Nothing -> pure []
387 Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg
388 DeployCommand_Update -> deployUpdate "."
389 DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs
390 ObCommand_Run interpretPathsList -> withInterpretPaths interpretPathsList run
391 ObCommand_Profile basePath rtsFlags -> profile basePath rtsFlags
392 ObCommand_Thunk to -> case _thunkOption_command to of
393 ThunkCommand_Update config -> for_ thunks (updateThunkToLatest config)
394 ThunkCommand_Unpack -> for_ thunks unpackThunk
395 ThunkCommand_Pack config -> for_ thunks (packThunk config)
396 where
397 thunks = _thunkOption_thunks to
398 ObCommand_Repl interpretPathsList -> withInterpretPaths interpretPathsList runRepl
399 ObCommand_Watch interpretPathsList -> withInterpretPaths interpretPathsList runWatch
400 ObCommand_Shell (ShellOpts shellAttr interpretPathsList cmd) -> withInterpretPaths interpretPathsList $ \root interpretPaths ->
401 nixShellForInterpretPaths False shellAttr root interpretPaths cmd
402 ObCommand_Doc shellAttr pkgs -> withInterpretPaths [] $ \root interpretPaths ->
403 nixShellForInterpretPaths True shellAttr root interpretPaths $ Just $ haddockCommand pkgs
404 ObCommand_Hoogle shell' port -> withProjectRoot "." $ \root -> do
405 nixShellWithHoogle root True shell' $ Just $ "hoogle server -p " <> show port <> " --local"
406 ObCommand_Internal icmd -> case icmd of
407 ObInternal_ApplyPackages origPath inPath outPath packagePaths -> do
408 liftIO $ Preprocessor.applyPackages origPath inPath outPath packagePaths
409 ObInternal_ExportGhciConfig interpretPathsList useRelativePaths ->
410 liftIO . putStrLn . unlines =<< withInterpretPaths interpretPathsList (exportGhciConfig useRelativePaths)
412-- | A helper for the common case that the command you want to run needs the project root and a resolved
413-- set of interpret paths.
414withInterpretPaths :: MonadObelisk m => [(FilePath, Interpret)] -> (FilePath -> PathTree Interpret -> m a) -> m a
415withInterpretPaths interpretPathsList f = withProjectRoot "." $ \root -> do
416 interpretPaths' <- resolveInterpretPaths $ (root, Interpret_Interpret) : interpretPathsList
417 case interpretPaths' of
418 Nothing -> failWith "No paths provided for finding packages"
419 Just interpretPaths -> f root interpretPaths
421haddockCommand :: [String] -> String
422haddockCommand pkgs = unwords
423 [ "for p in"
424 , unwords [getHaddockPath p ++ "/index.html" | p <- pkgs]
425 , "; do echo $p; done"
426 ]
427 where getHaddockPath p = "$(ghc-pkg field " ++ p ++ " haddock-html --simple-output)"
429--TODO: Clean up all the magic strings throughout this codebase
431getArgsConfig :: IO ArgsConfig
432getArgsConfig = pure $ ArgsConfig { _argsConfig_enableVmBuilderByDefault = System.Info.os == "darwin" }
434-- | Resolves an ordered list of paths for use with @--interpret@/@--no-interpret@ by coalescing
435-- paths into a non-ambiguous set of paths. Ambiguity is resolved by choosing right-most paths
436-- over any preceeding identical paths.
437--
438-- For example: @a/b=ON a/b/c=OFF@ and @a/b/c=OFF a/b=ON@ are the same.
439-- @a/b=ON a/b=OFF@ is reduced to @a/b=OFF@. We prefer right-biased choice to increase
440-- scriptability.
441--
442-- N.B. All the paths in the result will be canonicalized. It's impossible to determine path
443-- overlap otherwise.
444resolveInterpretPaths :: MonadIO m => [(FilePath, a)] -> m (Maybe (PathTree a))
445resolveInterpretPaths ps = do
446 trees <- liftIO $ for ps $ \(p, a) -> pathToTree a <$> canonicalizePath p
447 pure $ foldr1 mergeTrees <$> nonEmpty trees
448 where
449 -- | Merge two 'PathTree's preferring leaves on the right in as much as they overlap with paths on the left.
450 mergeTrees :: PathTree a -> PathTree a -> PathTree a
451 mergeTrees (PathTree_Node ax x) (PathTree_Node ay y) = PathTree_Node (ay <|> ax) $ Map.unionWith mergeTrees x y