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