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