git.iko.soy/obelisk
on 63c7b21 help sign in
obelisk/lib/command/src/Obelisk/Command.hs
380 lines 16 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 <*> 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 PlatformDeployment = Android | IOS TeamID
177 deriving (Show)
179data RemoteBuilder = RemoteBuilder_ObeliskVM
180 deriving (Eq, Show)
182data DeployCommand
183 = DeployCommand_Init DeployInitOpts
184 | DeployCommand_Push (Maybe RemoteBuilder)
185 | DeployCommand_Test PlatformDeployment
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]
217 | ThunkCommand_Set [FilePath] String
218 deriving Show
220thunkCommand :: Parser ThunkCommand
221thunkCommand = hsubparser $ mconcat
222 [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser <*> optional (strOption (long "branch" <> metavar "BRANCH"))) $ progDesc "Update thunk to latest revision available"
223 , command "unpack" $ info (ThunkCommand_Unpack <$> some thunkDirectoryParser) $ progDesc "Unpack thunk into git checkout of revision it points to"
224 , command "pack" $ info (ThunkCommand_Pack <$> some thunkDirectoryParser) $ progDesc "Pack git checkout into thunk that points at the current branch's upstream"
225 , command "set" $ info (ThunkCommand_Set <$> some thunkDirectoryParser <*> strOption (long "branch" <> metavar "BRANCH")) $ progDesc "Set upstream branch of thunk"
226 ]
228parserPrefs :: ParserPrefs
229parserPrefs = defaultPrefs
230 { prefShowHelpOnEmpty = True
231 }
233parseCLIArgs :: ArgsConfig -> [String] -> IO Args
234parseCLIArgs cfg as = pure as >>= handleParseResult . execParserPure parserPrefs (argsInfo cfg)
236-- | Create an Obelisk config for the current process.
237mkObeliskConfig :: IO Obelisk
238mkObeliskConfig = do
239 cliArgs <- getArgs
240 -- This function should not use argument parser (full argument parsing happens post handoff)
241 let logLevel = toLogLevel $ "-v" `elem` cliArgs
242 notInteractive <- not <$> isInteractiveTerm
243 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case
244 ObeliskError_ProcessError (ProcessFailure p code) ann ->
245 ( "Process exited with code " <> T.pack (show code) <> "; " <> reconstructCommand p
246 <> maybe "" ("\n" <>) ann
247 , 2
248 )
249 ObeliskError_Unstructured msg -> (msg, 2)
251 return $ Obelisk cliConf
252 where
253 toLogLevel = bool Notice Debug
254 isInteractiveTerm = do
255 isTerm <- hIsTerminalDevice stdout
256 -- Running in bash/fish/zsh completion
257 inShellCompletion <- liftIO $ isInfixOf "completion" . unwords <$> getArgs
259 -- Respect the user’s TERM environment variable. Dumb terminals
260 -- like Eshell cannot handle lots of control sequences that the
261 -- spinner uses.
262 termEnv <- lookupEnv "TERM"
263 let isDumb = termEnv == Just "dumb"
265 return $ isTerm && not inShellCompletion && not isDumb
267-- | For use from development obelisk repls
268--
269-- Example:
270-- > runCommand $ someFuncInMonadObelisk ...
271runCommand :: ObeliskT IO a -> IO a
272runCommand f = flip runObelisk f =<< mkObeliskConfig
274main :: IO ()
275main = runCommand . main' =<< getArgsConfig
277main' :: MonadObelisk m => ArgsConfig -> m ()
278main' argsCfg = do
279 obPath <- liftIO getExecutablePath
280 myArgs <- liftIO getArgs
281 logLevel <- getLogLevel
282 putLog Debug $ T.pack $ unwords
283 [ "Starting Obelisk <" <> obPath <> ">"
284 , "args=" <> show myArgs
285 , "logging-level=" <> show logLevel
286 ]
288 --TODO: We'd like to actually use the parser to determine whether to hand off,
289 --but in the case where this implementation of 'ob' doesn't support all
290 --arguments being passed along, this could fail. For now, we don't bother
291 --with optparse-applicative until we've done the handoff.
292 let go as = do
293 args' <- liftIO $ handleParseResult (execParserPure parserPrefs (argsInfo argsCfg) as)
294 case _args_noHandOffPassed args' of
295 False -> return ()
296 True -> putLog Warning "--no-handoff should only be passed once and as the first argument; ignoring"
297 ob $ _args_command args'
298 handoffAndGo as = findProjectObeliskCommand "." >>= \case
299 Nothing -> go as -- If not in a project, just run ourselves
300 Just impl -> do
301 -- Invoke the real implementation, using --no-handoff to prevent infinite recursion
302 putLog Debug $ "Handing off to " <> T.pack impl
303 liftIO $ executeFile impl False ("--no-handoff" : myArgs) Nothing
304 case myArgs of
305 "--no-handoff" : as -> go as -- If we've been told not to hand off, don't hand off
306 a:as -- Otherwise bash completion would always hand-off even if the user isn't trying to
307 | "--bash-completion" `isPrefixOf` a
308 && "--no-handoff" `elem` as -> go (a:as)
309 | otherwise -> handoffAndGo (a:as)
310 as -> handoffAndGo as
312ob :: MonadObelisk m => ObCommand -> m ()
313ob = \case
314 ObCommand_Init source force -> initProject source force
315 ObCommand_Deploy dc -> case dc of
316 DeployCommand_Init deployOpts -> withProjectRoot "." $ \root -> do
317 let deployDir = _deployInitOpts_outputDir deployOpts
318 r <- liftIO $ canonicalizePath root
319 rootEqualsTarget <- liftIO $ equalFilePath r <$> canonicalizePath deployDir
320 when rootEqualsTarget $
321 failWith $ "Deploy directory " <> T.pack deployDir <> " should not be the same as project root."
322 thunkPtr <- readThunk root >>= \case
323 Left err -> failWith $ case err of
324 ReadThunkError_AmbiguousFiles ->
325 "Project root " <> T.pack r <> " is not a git repository or valid thunk"
326 ReadThunkError_UnrecognizedFiles ->
327 "Project root " <> T.pack r <> " is not a git repository or valid thunk"
328 _ -> "thunk read: " <> T.pack (show err)
329 Right (ThunkData_Packed ptr) -> return ptr
330 Right (ThunkData_Checkout (Just ptr)) -> return ptr
331 Right (ThunkData_Checkout Nothing) ->
332 getThunkPtr' False root
333 let sshKeyPath = _deployInitOpts_sshKey deployOpts
334 hostname = _deployInitOpts_hostname deployOpts
335 route = _deployInitOpts_route deployOpts
336 adminEmail = _deployInitOpts_adminEmail deployOpts
337 enableHttps = _deployInitOpts_enableHttps deployOpts
338 deployInit thunkPtr (root </> "config") deployDir
339 sshKeyPath hostname route adminEmail enableHttps
340 DeployCommand_Push remoteBuilder -> do
341 deployPath <- liftIO $ canonicalizePath "."
342 deployPush deployPath $ case remoteBuilder of
343 Nothing -> pure []
344 Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg
345 DeployCommand_Update -> deployUpdate "."
346 DeployCommand_Test Android -> deployMobile "android" []
347 DeployCommand_Test (IOS teamID) -> deployMobile "ios" [teamID]
348 ObCommand_Run -> inNixShell' $ static run
349 -- inNixShell ($(mkClosure 'ghcidAction) ())
350 ObCommand_Thunk tc -> case tc of
351 ThunkCommand_Update thunks mBranch -> mapM_ ((flip updateThunkToLatest) mBranch) thunks
352 ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks
353 ThunkCommand_Pack thunks -> forM_ thunks packThunk
354 ThunkCommand_Set thunks branch -> mapM_ (setThunk branch) thunks
355 ObCommand_Repl -> runRepl
356 ObCommand_Watch -> inNixShell' $ static runWatch
357 ObCommand_Internal icmd -> case icmd of
358 ObInternal_RunStaticIO k -> liftIO (unsafeLookupStaticPtr @(ObeliskT IO ()) k) >>= \case
359 Nothing -> failWith $ "ObInternal_RunStaticIO: no such StaticKey: " <> T.pack (show k)
360 Just p -> do
361 c <- getObelisk
362 liftIO $ runObelisk c $ deRefStaticPtr p
363 ObInternal_CLIDemo -> cliDemo
365--TODO: Clean up all the magic strings throughout this codebase
367getArgsConfig :: IO ArgsConfig
368getArgsConfig = pure $ ArgsConfig { _argsConfig_enableVmBuilderByDefault = System.Info.os == "darwin" }
370encodeStaticKey :: StaticKey -> String
371encodeStaticKey = T.unpack . decodeUtf8 . Base16.encode . LBS.toStrict . Binary.encode
373-- TODO: Use failWith in place of fail to be consistent.
374decodeStaticKey :: String -> Either String StaticKey
375decodeStaticKey s = case Base16.decode $ encodeUtf8 $ T.pack s of
376 (b, "") -> case Binary.decodeOrFail $ LBS.fromStrict b of
377 Right ("", _, a) -> pure a
378 Right _ -> fail "decodeStaticKey: Binary.decodeOrFail didn't consume all input"
379 Left (_, _, e) -> fail $ "decodeStaticKey: Binary.decodeOrFail failed: " <> show e
380 _ -> fail $ "decodeStaticKey: could not decode hex string: " <> show s