git.iko.soy/obelisk
on ae@static-which-prefetch help sign in
obelisk/lib/command/src/Obelisk/Command.hs
455 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.Process (rawSystem)
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 or run a command in such a shell. E.g. ob shell -- ghc-pkg list"
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 -- This funny construction is used to support optparse-applicative's @--@ parsing.
289 -- All arguments after @--@ are left unparsed and instead provided to the last positional parser
290 -- which must therefore be 'many' in order to consume the rest of the input.
291 <*> ((\xs -> if null xs then Nothing else Just $ unwords xs) <$> many (strArgument (metavar "COMMAND")))
293portOpt :: Int -> Parser Int
294portOpt dfault = option auto (long "port" <> short 'p' <> help "Port number for server" <> showDefault <> value dfault <> metavar "INT")
296parserPrefs :: ParserPrefs
297parserPrefs = defaultPrefs
298 { prefShowHelpOnEmpty = True
299 }
301-- | Create an Obelisk config for the current process.
302mkObeliskConfig :: IO Obelisk
303mkObeliskConfig = do
304 cliArgs <- getArgs
305 -- This function should not use argument parser (full argument parsing happens post handoff)
306 -- TODO: See if we can use the argument parser with a subset of the parsers to get logging level out.
307 let logLevel = toLogLevel $ any (`elem` ["-v", "--verbose"]) cliArgs
308 notInteractive <- not <$> isInteractiveTerm
309 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case
310 ObeliskError_ProcessError (ProcessFailure p code) ann ->
311 ( "Process exited with code " <> T.pack (show code) <> "; " <> reconstructCommand p
312 <> maybe "" ("\n" <>) ann
313 , 2
314 )
315 ObeliskError_Unstructured msg -> (msg, 2)
317 return $ Obelisk cliConf
318 where
319 toLogLevel = bool Notice Debug
320 isInteractiveTerm = do
321 isTerm <- hIsTerminalDevice stdout
322 -- Running in bash/fish/zsh completion
323 inShellCompletion <- liftIO $ isInfixOf "completion" . unwords <$> getArgs
325 -- Respect the user’s TERM environment variable. Dumb terminals
326 -- like Eshell cannot handle lots of control sequences that the
327 -- spinner uses.
328 termEnv <- lookupEnv "TERM"
329 let isDumb = termEnv == Just "dumb"
331 return $ isTerm && not inShellCompletion && not isDumb
333-- | For use from development obelisk repls
334--
335-- Example:
336-- > runCommand $ someFuncInMonadObelisk ...
337runCommand :: ObeliskT IO a -> IO a
338runCommand f = flip runObelisk f =<< mkObeliskConfig
340main :: IO ()
341main = runCommand . main' =<< getArgsConfig
343main' :: MonadObelisk m => ArgsConfig -> m ()
344main' argsCfg = do
345 obPath <- liftIO getExecutablePath
346 myArgs <- liftIO getArgs
347 logLevel <- getLogLevel
348 putLog Debug $ T.pack $ unwords
349 [ "Starting Obelisk <" <> obPath <> ">"
350 , "args=" <> show myArgs
351 , "logging-level=" <> show logLevel
352 ]
354 --TODO: We'd like to actually use the parser to determine whether to hand off,
355 --but in the case where this implementation of 'ob' doesn't support all
356 --arguments being passed along, this could fail. For now, we don't bother
357 --with optparse-applicative until we've done the handoff.
358 let go as = do
359 args' <- liftIO $ handleParseResult (execParserPure parserPrefs (argsInfo argsCfg) as)
360 case _args_noHandOffPassed args' of
361 False -> return ()
362 True -> putLog Warning "--no-handoff should only be passed once and as the first argument; ignoring"
363 ob $ _args_command args'
364 handoffAndGo as = findProjectObeliskCommand "." >>= \case
365 Nothing -> go as -- If not in a project, just run ourselves
366 Just impl -> do
367 -- Invoke the real implementation, using --no-handoff to prevent infinite recursion
368 putLog Debug $ "Handing off to " <> T.pack impl
369 _ <- liftIO $ rawSystem impl ("--no-handoff" : myArgs)
370 return ()
371 case myArgs of
372 "--no-handoff" : as -> go as -- If we've been told not to hand off, don't hand off
373 origPath:inPath:outPath:preprocessorName:packagePaths
374 | preprocessorName == preprocessorIdentifier && any (\c -> c == '.' || c == pathSeparator) origPath ->
375 ob $ ObCommand_Internal $ ObInternal_ApplyPackages origPath inPath outPath packagePaths
376 a:as -- Otherwise bash completion would always hand-off even if the user isn't trying to
377 | "--bash-completion" `isPrefixOf` a
378 && "--no-handoff" `elem` as -> go (a:as)
379 | otherwise -> handoffAndGo (a:as)
380 as -> handoffAndGo as
382ob :: MonadObelisk m => ObCommand -> m ()
383ob = \case
384 ObCommand_Init source force -> initProject source force
385 ObCommand_Deploy dc -> case dc of
386 DeployCommand_Init deployOpts -> withProjectRoot "." $ \root -> deployInit deployOpts root
387 DeployCommand_Push remoteBuilder -> do
388 deployPath <- liftIO $ canonicalizePath "."
389 deployPush deployPath $ case remoteBuilder of
390 Nothing -> pure []
391 Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg
392 DeployCommand_Update -> deployUpdate "."
393 DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs
394 ObCommand_Run interpretPathsList -> withInterpretPaths interpretPathsList run
395 ObCommand_Profile basePath rtsFlags -> profile basePath rtsFlags
396 ObCommand_Thunk to -> case _thunkOption_command to of
397 ThunkCommand_Update config -> for_ thunks (updateThunkToLatest config)
398 ThunkCommand_Unpack -> for_ thunks unpackThunk
399 ThunkCommand_Pack config -> for_ thunks (packThunk config)
400 where
401 thunks = _thunkOption_thunks to
402 ObCommand_Repl interpretPathsList -> withInterpretPaths interpretPathsList runRepl
403 ObCommand_Watch interpretPathsList -> withInterpretPaths interpretPathsList runWatch
404 ObCommand_Shell (ShellOpts shellAttr interpretPathsList cmd) -> withInterpretPaths interpretPathsList $ \root interpretPaths ->
405 nixShellForInterpretPaths False shellAttr root interpretPaths cmd -- N.B. We do NOT bash escape here; we want to run the command as-is
406 ObCommand_Doc shellAttr pkgs -> withInterpretPaths [] $ \root interpretPaths ->
407 nixShellForInterpretPaths True shellAttr root interpretPaths $ Just $ haddockCommand pkgs
408 ObCommand_Hoogle shell' port -> withProjectRoot "." $ \root -> do
409 nixShellWithHoogle root True shell' $ Just $ "hoogle server -p" <> show port <> " --local"
410 ObCommand_Internal icmd -> case icmd of
411 ObInternal_ApplyPackages origPath inPath outPath packagePaths -> do
412 liftIO $ Preprocessor.applyPackages origPath inPath outPath packagePaths
413 ObInternal_ExportGhciConfig interpretPathsList useRelativePaths ->
414 liftIO . putStrLn . unlines =<< withInterpretPaths interpretPathsList (exportGhciConfig useRelativePaths)
416-- | A helper for the common case that the command you want to run needs the project root and a resolved
417-- set of interpret paths.
418withInterpretPaths :: MonadObelisk m => [(FilePath, Interpret)] -> (FilePath -> PathTree Interpret -> m a) -> m a
419withInterpretPaths interpretPathsList f = withProjectRoot "." $ \root -> do
420 interpretPaths' <- resolveInterpretPaths $ (root, Interpret_Interpret) : interpretPathsList
421 case interpretPaths' of
422 Nothing -> failWith "No paths provided for finding packages"
423 Just interpretPaths -> f root interpretPaths
425haddockCommand :: [String] -> String
426haddockCommand pkgs = unwords
427 [ "for p in"
428 , unwords [getHaddockPath p ++ "/index.html" | p <- pkgs]
429 , "; do echo $p; done"
430 ]
431 where getHaddockPath p = "$(ghc-pkg field " ++ p ++ " haddock-html --simple-output)"
433--TODO: Clean up all the magic strings throughout this codebase
435getArgsConfig :: IO ArgsConfig
436getArgsConfig = pure $ ArgsConfig { _argsConfig_enableVmBuilderByDefault = System.Info.os == "darwin" }
438-- | Resolves an ordered list of paths for use with @--interpret@/@--no-interpret@ by coalescing
439-- paths into a non-ambiguous set of paths. Ambiguity is resolved by choosing right-most paths
440-- over any preceeding identical paths.
441--
442-- For example: @a/b=ON a/b/c=OFF@ and @a/b/c=OFF a/b=ON@ are the same.
443-- @a/b=ON a/b=OFF@ is reduced to @a/b=OFF@. We prefer right-biased choice to increase
444-- scriptability.
445--
446-- N.B. All the paths in the result will be canonicalized. It's impossible to determine path
447-- overlap otherwise.
448resolveInterpretPaths :: MonadIO m => [(FilePath, a)] -> m (Maybe (PathTree a))
449resolveInterpretPaths ps = do
450 trees <- liftIO $ for ps $ \(p, a) -> pathToTree a <$> canonicalizePath p
451 pure $ foldr1 mergeTrees <$> nonEmpty trees
452 where
453 -- | Merge two 'PathTree's preferring leaves on the right in as much as they overlap with paths on the left.
454 mergeTrees :: PathTree a -> PathTree a -> PathTree a
455 mergeTrees (PathTree_Node ax x) (PathTree_Node ay y) = PathTree_Node (ay <|> ax) $ Map.unionWith mergeTrees x y