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