git.iko.soy/obelisk
on 6ab28f7 help sign in
obelisk/lib/command/src/Obelisk/Command.hs
420 lines 18 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE StaticPointers #-}
7{-# LANGUAGE TypeApplications #-}
8module Obelisk.Command where
10import Control.Monad
11import Control.Monad.IO.Class (liftIO)
12import qualified Data.Binary as Binary
13import Data.Bool (bool)
14import qualified Data.ByteString.Base16 as Base16
15import qualified Data.ByteString.Lazy as LBS
16import qualified Data.ByteString.UTF8 as BSU
17import Data.List
18import Data.Maybe (catMaybes)
19import qualified Data.Text as T
20import Data.Text.Encoding
21import Data.Text.Encoding.Error (lenientDecode)
22import GHC.StaticPtr
23import Options.Applicative
24import Options.Applicative.Help.Pretty (text, (<$$>))
25import System.Directory
26import System.Environment
27import System.FilePath
28import qualified System.Info
29import System.IO (hIsTerminalDevice, stdout)
30import Text.ShellEscape (bash)
31import System.Posix.Process (executeFile)
33import Obelisk.App
34import Obelisk.CliApp
35import Obelisk.CliApp.Demo (cliDemo)
36import Obelisk.Command.Deploy
37import Obelisk.Command.Project
38import Obelisk.Command.Run
39import Obelisk.Command.Thunk
40import Obelisk.Command.Utils
41import qualified Obelisk.Command.VmBuilder as VmBuilder
44data Args = Args
45 { _args_noHandOffPassed :: Bool
46 -- ^ This flag is actually handled outside of the optparse-applicative parser, but we detect whether
47 -- it has gotten through in order to notify the user that it should only be passed once and as the very
48 -- first argument
49 , _args_verbose :: Bool
50 , _args_command :: ObCommand
51 }
52 deriving Show
54newtype ArgsConfig = ArgsConfig
55 { _argsConfig_enableVmBuilderByDefault :: Bool
56 }
58args :: ArgsConfig -> Parser Args
59args cfg = Args <$> noHandoff <*> verbose <*> obCommand cfg
61noHandoff :: Parser Bool
62noHandoff = flag False True $ mconcat
63 [ long "no-handoff"
64 , help "Do not hand off execution to project-specific implementation of this command"
65 , hidden
66 ]
68verbose :: Parser Bool
69verbose = flag False True $ mconcat
70 [ long "verbose"
71 , short 'v'
72 , help "Be more verbose"
73 ]
75argsInfo :: ArgsConfig -> ParserInfo Args
76argsInfo cfg = info (args cfg <**> helper) $ mconcat
77 [ fullDesc
78 , progDesc "Manage Obelisk projects"
79 ]
81initSource :: Parser InitSource
82initSource = foldl1 (<|>)
83 [ pure InitSource_Default
84 , InitSource_Branch <$> strOption (long "branch" <> metavar "BRANCH")
85 , InitSource_Symlink <$> strOption (long "symlink" <> action "directory" <> metavar "PATH")
86 ]
88initForce :: Parser Bool
89initForce = switch (long "force" <> help "Allow ob init to overwrite files")
91data ObCommand
92 = ObCommand_Init InitSource Bool
93 | ObCommand_Deploy DeployCommand
94 | ObCommand_Run
95 | ObCommand_Thunk ThunkCommand
96 | ObCommand_Repl
97 | ObCommand_Watch
98 | ObCommand_Shell ShellOpts
99 | ObCommand_Doc String [String] -- shell and list of packages
100 | ObCommand_Internal ObInternal
101 deriving Show
103data ObInternal
104 = ObInternal_RunStaticIO StaticKey
105 | ObInternal_CLIDemo
106 deriving Show
108inNixShell' :: MonadObelisk m => StaticPtr (ObeliskT IO ()) -> m ()
109inNixShell' p = withProjectRoot "." $ \root -> do
110 cmd <- liftIO $ fmap (bash . BSU.fromString) <$> mkCmd
111 projectProc root True "ghc" (Just cmd)
112 where
113 mkCmd = do
114 argsCfg <- getArgsConfig
115 myArgs <- getArgs
116 obArgs <- parseCLIArgs argsCfg myArgs
117 progName <- getObeliskExe
118 return $ progName : catMaybes
119 [ Just "--no-handoff"
120 , bool Nothing (Just "--verbose") $ _args_verbose obArgs
121 , Just "internal"
122 , Just "run-static-io"
123 , Just $ encodeStaticKey $ staticKey p
124 ]
126obCommand :: ArgsConfig -> Parser ObCommand
127obCommand cfg = hsubparser
128 (mconcat
129 [ command "init" $ info (ObCommand_Init <$> initSource <*> initForce) $ progDesc "Initialize an Obelisk project"
130 , command "deploy" $ info (ObCommand_Deploy <$> deployCommand cfg) $ progDesc "Prepare a deployment for an Obelisk project"
131 , command "run" $ info (pure ObCommand_Run) $ progDesc "Run current project in development mode"
132 , command "thunk" $ info (ObCommand_Thunk <$> thunkCommand) $ progDesc "Manipulate thunk directories"
133 , command "repl" $ info (pure ObCommand_Repl) $ progDesc "Open an interactive interpreter"
134 , command "watch" $ info (pure ObCommand_Watch) $ progDesc "Watch current project for errors and warnings"
135 , command "shell" $ info (ObCommand_Shell <$> shellOpts) $ progDesc "Enter a shell with project dependencies"
136 , command "doc" $ info (ObCommand_Doc <$> shellFlags <*> packageNames) $
137 progDesc "List paths to haddock documentation for specified packages"
138 <> footerDoc (Just $
139 text "Hint: To open the documentation you can pipe the output of this command like"
140 <$$> text "ob doc reflex reflex-dom-core | xargs -n1 xdg-open")
141 ])
142 <|> subparser
143 (mconcat
144 [ internal
145 , command "internal" (info (ObCommand_Internal <$> internalCommand) mempty)
146 ])
148packageNames :: Parser [String]
149packageNames = some (strArgument (metavar "PACKAGE-NAME..."))
151deployCommand :: ArgsConfig -> Parser DeployCommand
152deployCommand cfg = hsubparser $ mconcat
153 [ command "init" $ info (DeployCommand_Init <$> deployInitOpts) $ progDesc "Initialize a deployment configuration directory"
154 , command "push" $ info (DeployCommand_Push <$> remoteBuilderParser) mempty
155 , command "test" $ info (DeployCommand_Test <$> platformP) $ progDesc "Test your obelisk project from a mobile platform."
156 , command "update" $ info (pure DeployCommand_Update) $ progDesc "Update the deployment's src thunk to latest"
157 ]
158 where
159 platformP = hsubparser $ mconcat
160 [ command "android" $ info (pure (Android, [])) mempty
161 , command "ios" $ info ((,) <$> pure IOS <*> (fmap pure $ strArgument (metavar "TEAMID" <> help "Your Team ID - found in the Apple developer portal"))) mempty
162 ]
164 remoteBuilderParser :: Parser (Maybe RemoteBuilder)
165 remoteBuilderParser =
166 flag (if enabledByDefault then enabled else Nothing) enabled (mconcat
167 [ long $ "enable-" <> flagBase
168 , help $ "Enable " <> flagDesc <> (if enabledByDefault then " (default)" else "")
169 ])
170 <|> flag enabled Nothing (mconcat
171 [ long $ "disable-" <> flagBase
172 , help $ "Disable a " <> flagDesc <> (if not enabledByDefault then " (default)" else "")
173 ])
174 where
175 enabledByDefault = _argsConfig_enableVmBuilderByDefault cfg
176 enabled = Just RemoteBuilder_ObeliskVM
177 flagBase = "vm-builder"
178 flagDesc = "managed Linux virtual machine as a Nix remote builder (requires Docker)"
181deployInitOpts :: Parser DeployInitOpts
182deployInitOpts = DeployInitOpts
183 <$> strArgument (action "directory" <> metavar "DEPLOYDIR" <> help "Path to a directory that it will create")
184 <*> strOption (long "ssh-key" <> action "file" <> metavar "SSHKEY" <> help "Path to an ssh key that it will symlink to")
185 <*> some (strOption (long "hostname" <> metavar "HOSTNAME" <> help "hostname of the deployment target"))
186 <*> strOption (long "route" <> metavar "PUBLICROUTE" <> help "Publicly accessible URL of your app")
187 <*> strOption (long "admin-email" <> metavar "ADMINEMAIL" <> help "Email address where administrative alerts will be sent")
188 <*> flag True False (long "disable-https" <> help "Disable automatic https configuration for the backend")
190type TeamID = String
191data RemoteBuilder = RemoteBuilder_ObeliskVM
192 deriving (Eq, Show)
194data DeployCommand
195 = DeployCommand_Init DeployInitOpts
196 | DeployCommand_Push (Maybe RemoteBuilder)
197 | DeployCommand_Test (PlatformDeployment, [String])
198 | DeployCommand_Update
199 deriving Show
201data DeployInitOpts = DeployInitOpts
202 { _deployInitOpts_outputDir :: FilePath
203 , _deployInitOpts_sshKey :: FilePath
204 , _deployInitOpts_hostname :: [String]
205 , _deployInitOpts_route :: String
206 , _deployInitOpts_adminEmail :: String
207 , _deployInitOpts_enableHttps :: Bool
208 }
209 deriving Show
211internalCommand :: Parser ObInternal
212internalCommand = subparser $ mconcat
213 [ command "run-static-io" $ info (ObInternal_RunStaticIO <$> argument (eitherReader decodeStaticKey) (action "static-key")) mempty
214 , command "clidemo" $ info (pure ObInternal_CLIDemo) mempty
215 ]
217--TODO: Result should provide normalised path and also original user input for error reporting.
218thunkDirectoryParser :: Parser FilePath
219thunkDirectoryParser = fmap (dropTrailingPathSeparator . normalise) . strArgument $ mconcat
220 [ action "directory"
221 , metavar "THUNKDIR"
222 , help "Path to directory containing thunk data"
223 ]
225data ThunkCommand
226 = ThunkCommand_Update [FilePath] (Maybe String)
227 | ThunkCommand_Unpack [FilePath]
228 | ThunkCommand_Pack [FilePath] Bool
229 deriving Show
231forceFlag :: Parser Bool
232forceFlag = 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."
234thunkCommand :: Parser ThunkCommand
235thunkCommand = hsubparser $ mconcat
236 [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser <*> optional (strOption (long "branch" <> metavar "BRANCH"))) $ progDesc "Update thunk to latest revision available"
237 , command "unpack" $ info (ThunkCommand_Unpack <$> some thunkDirectoryParser) $ progDesc "Unpack thunk into git checkout of revision it points to"
238 , command "pack" $ info (ThunkCommand_Pack <$> some thunkDirectoryParser <*> forceFlag) $ progDesc "Pack git checkout into thunk that points at the current branch's upstream"
239 ]
241data ShellOpts
242 = ShellOpts
243 { _shellOpts_shell :: String
244 , _shellOpts_command :: Maybe String
245 }
246 deriving Show
248shellFlags :: Parser String
249shellFlags =
250 flag' "ghc" (long "ghc" <> help "Enter a shell environment having ghc (default)")
251 <|> flag "ghc" "ghcjs" (long "ghcjs" <> help "Enter a shell having ghcjs rather than ghc")
252 <|> strOption (short 'A' <> long "argument" <> metavar "NIXARG" <> help "Use the environment specified by the given nix argument of `shells'")
254shellOpts :: Parser ShellOpts
255shellOpts = ShellOpts
256 <$> shellFlags
257 <*> optional (strArgument (metavar "COMMAND"))
259parserPrefs :: ParserPrefs
260parserPrefs = defaultPrefs
261 { prefShowHelpOnEmpty = True
262 }
264parseCLIArgs :: ArgsConfig -> [String] -> IO Args
265parseCLIArgs cfg as = pure as >>= handleParseResult . execParserPure parserPrefs (argsInfo cfg)
267-- | Create an Obelisk config for the current process.
268mkObeliskConfig :: IO Obelisk
269mkObeliskConfig = do
270 cliArgs <- getArgs
271 -- This function should not use argument parser (full argument parsing happens post handoff)
272 let logLevel = toLogLevel $ "-v" `elem` cliArgs
273 notInteractive <- not <$> isInteractiveTerm
274 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case
275 ObeliskError_ProcessError (ProcessFailure p code) ann ->
276 ( "Process exited with code " <> T.pack (show code) <> "; " <> reconstructCommand p
277 <> maybe "" ("\n" <>) ann
278 , 2
279 )
280 ObeliskError_Unstructured msg -> (msg, 2)
282 return $ Obelisk cliConf
283 where
284 toLogLevel = bool Notice Debug
285 isInteractiveTerm = do
286 isTerm <- hIsTerminalDevice stdout
287 -- Running in bash/fish/zsh completion
288 inShellCompletion <- liftIO $ isInfixOf "completion" . unwords <$> getArgs
290 -- Respect the user’s TERM environment variable. Dumb terminals
291 -- like Eshell cannot handle lots of control sequences that the
292 -- spinner uses.
293 termEnv <- lookupEnv "TERM"
294 let isDumb = termEnv == Just "dumb"
296 return $ isTerm && not inShellCompletion && not isDumb
298-- | For use from development obelisk repls
299--
300-- Example:
301-- > runCommand $ someFuncInMonadObelisk ...
302runCommand :: ObeliskT IO a -> IO a
303runCommand f = flip runObelisk f =<< mkObeliskConfig
305main :: IO ()
306main = runCommand . main' =<< getArgsConfig
308main' :: MonadObelisk m => ArgsConfig -> m ()
309main' argsCfg = do
310 obPath <- liftIO getExecutablePath
311 myArgs <- liftIO getArgs
312 logLevel <- getLogLevel
313 putLog Debug $ T.pack $ unwords
314 [ "Starting Obelisk <" <> obPath <> ">"
315 , "args=" <> show myArgs
316 , "logging-level=" <> show logLevel
317 ]
319 --TODO: We'd like to actually use the parser to determine whether to hand off,
320 --but in the case where this implementation of 'ob' doesn't support all
321 --arguments being passed along, this could fail. For now, we don't bother
322 --with optparse-applicative until we've done the handoff.
323 let go as = do
324 args' <- liftIO $ handleParseResult (execParserPure parserPrefs (argsInfo argsCfg) as)
325 case _args_noHandOffPassed args' of
326 False -> return ()
327 True -> putLog Warning "--no-handoff should only be passed once and as the first argument; ignoring"
328 ob $ _args_command args'
329 handoffAndGo as = findProjectObeliskCommand "." >>= \case
330 Nothing -> go as -- If not in a project, just run ourselves
331 Just impl -> do
332 -- Invoke the real implementation, using --no-handoff to prevent infinite recursion
333 putLog Debug $ "Handing off to " <> T.pack impl
334 liftIO $ executeFile impl False ("--no-handoff" : myArgs) Nothing
335 case myArgs of
336 "--no-handoff" : as -> go as -- If we've been told not to hand off, don't hand off
337 a:as -- Otherwise bash completion would always hand-off even if the user isn't trying to
338 | "--bash-completion" `isPrefixOf` a
339 && "--no-handoff" `elem` as -> go (a:as)
340 | otherwise -> handoffAndGo (a:as)
341 as -> handoffAndGo as
343ob :: MonadObelisk m => ObCommand -> m ()
344ob = \case
345 ObCommand_Init source force -> initProject source force
346 ObCommand_Deploy dc -> case dc of
347 DeployCommand_Init deployOpts -> withProjectRoot "." $ \root -> do
348 let deployDir = _deployInitOpts_outputDir deployOpts
349 r <- liftIO $ canonicalizePath root
350 rootEqualsTarget <- liftIO $ equalFilePath r <$> canonicalizePath deployDir
351 when rootEqualsTarget $
352 failWith $ "Deploy directory " <> T.pack deployDir <> " should not be the same as project root."
353 thunkPtr <- readThunk root >>= \case
354 Left err -> failWith $ case err of
355 ReadThunkError_AmbiguousFiles ->
356 "Project root " <> T.pack r <> " is not a git repository or valid thunk"
357 ReadThunkError_UnrecognizedFiles ->
358 "Project root " <> T.pack r <> " is not a git repository or valid thunk"
359 _ -> "thunk read: " <> T.pack (show err)
360 Right (ThunkData_Packed ptr) -> return ptr
361 Right (ThunkData_Checkout (Just ptr)) -> return ptr
362 Right (ThunkData_Checkout Nothing) ->
363 getThunkPtr False root
364 let sshKeyPath = _deployInitOpts_sshKey deployOpts
365 hostname = _deployInitOpts_hostname deployOpts
366 route = _deployInitOpts_route deployOpts
367 adminEmail = _deployInitOpts_adminEmail deployOpts
368 enableHttps = _deployInitOpts_enableHttps deployOpts
369 deployInit thunkPtr deployDir sshKeyPath hostname route adminEmail enableHttps
370 DeployCommand_Push remoteBuilder -> do
371 deployPath <- liftIO $ canonicalizePath "."
372 deployPush deployPath $ case remoteBuilder of
373 Nothing -> pure []
374 Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg
375 DeployCommand_Update -> deployUpdate "."
376 DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs
377 ObCommand_Run -> inNixShell' $ static run
378 -- inNixShell ($(mkClosure 'ghcidAction) ())
379 ObCommand_Thunk tc -> case tc of
380 ThunkCommand_Update thunks mBranch -> mapM_ ((flip updateThunkToLatest) mBranch) thunks
381 ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks
382 ThunkCommand_Pack thunks force -> forM_ thunks (packThunk force)
383 ObCommand_Repl -> runRepl
384 ObCommand_Watch -> inNixShell' $ static runWatch
385 ObCommand_Shell so -> withProjectRoot "." $ \root ->
386 projectProc root False (_shellOpts_shell so) (pure . bash . BSU.fromString <$> _shellOpts_command so)
387 ObCommand_Doc shell pkgs -> withProjectRoot "." $ \root ->
388 projectShell root False shell (Just $ haddockCommand pkgs)
389 ObCommand_Internal icmd -> case icmd of
390 ObInternal_RunStaticIO k -> liftIO (unsafeLookupStaticPtr @(ObeliskT IO ()) k) >>= \case
391 Nothing -> failWith $ "ObInternal_RunStaticIO: no such StaticKey: " <> T.pack (show k)
392 Just p -> do
393 c <- getObelisk
394 liftIO $ runObelisk c $ deRefStaticPtr p
395 ObInternal_CLIDemo -> cliDemo
397haddockCommand :: [String] -> String
398haddockCommand pkgs = unwords
399 [ "for p in"
400 , unwords [getHaddockPath p ++ "/index.html" | p <- pkgs]
401 , "; do echo $p; done"
402 ]
403 where getHaddockPath p = "$(ghc-pkg field " ++ p ++ " haddock-html --simple-output)"
405--TODO: Clean up all the magic strings throughout this codebase
407getArgsConfig :: IO ArgsConfig
408getArgsConfig = pure $ ArgsConfig { _argsConfig_enableVmBuilderByDefault = System.Info.os == "darwin" }
410encodeStaticKey :: StaticKey -> String
411encodeStaticKey = T.unpack . decodeUtf8With lenientDecode . Base16.encode . LBS.toStrict . Binary.encode
413-- TODO: Use failWith in place of fail to be consistent.
414decodeStaticKey :: String -> Either String StaticKey
415decodeStaticKey s = case Base16.decode $ encodeUtf8 $ T.pack s of
416 (b, "") -> case Binary.decodeOrFail $ LBS.fromStrict b of
417 Right ("", _, a) -> pure a
418 Right _ -> fail "decodeStaticKey: Binary.decodeOrFail didn't consume all input"
419 Left (_, _, e) -> fail $ "decodeStaticKey: Binary.decodeOrFail failed: " <> show e
420 _ -> fail $ "decodeStaticKey: could not decode hex string: " <> show s