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