git.iko.soy/obelisk
on examples help sign in
obelisk/lib/command/src/Obelisk/Command.hs
418 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.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 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 Obelisk.Command.Utils
39import qualified Obelisk.Command.VmBuilder as VmBuilder
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 deriving Show
106inNixShell' :: MonadObelisk m => StaticPtr (ObeliskT IO ()) -> m ()
107inNixShell' p = withProjectRoot "." $ \root -> do
108 cmd <- liftIO $ unwords <$> mkCmd -- TODO: shell escape instead of unwords
109 projectShell root True "ghc" (Just cmd)
110 where
111 mkCmd = do
112 argsCfg <- getArgsConfig
113 myArgs <- getArgs
114 obArgs <- parseCLIArgs argsCfg myArgs
115 progName <- getObeliskExe
116 return $ progName : catMaybes
117 [ Just "--no-handoff"
118 , bool Nothing (Just "--verbose") $ _args_verbose obArgs
119 , Just "internal"
120 , Just "run-static-io"
121 , Just $ encodeStaticKey $ staticKey p
122 ]
124obCommand :: ArgsConfig -> Parser ObCommand
125obCommand cfg = hsubparser
126 (mconcat
127 [ command "init" $ info (ObCommand_Init <$> initSource <*> initForce) $ progDesc "Initialize an Obelisk project"
128 , command "deploy" $ info (ObCommand_Deploy <$> deployCommand cfg) $ progDesc "Prepare a deployment for an Obelisk project"
129 , command "run" $ info (pure ObCommand_Run) $ progDesc "Run current project in development mode"
130 , command "thunk" $ info (ObCommand_Thunk <$> thunkCommand) $ progDesc "Manipulate thunk directories"
131 , command "repl" $ info (pure ObCommand_Repl) $ progDesc "Open an interactive interpreter"
132 , command "watch" $ info (pure ObCommand_Watch) $ progDesc "Watch current project for errors and warnings"
133 , command "shell" $ info (ObCommand_Shell <$> shellOpts) $ progDesc "Enter a shell with project dependencies"
134 , command "doc" $ info (ObCommand_Doc <$> shellFlags <*> packageNames) $
135 progDesc "List paths to haddock documentation for specified packages"
136 <> footerDoc (Just $
137 text "Hint: To open the documentation you can pipe the output of this command like"
138 <$$> text "ob doc reflex reflex-dom-core | xargs -n1 xdg-open")
139 ])
140 <|> subparser
141 (mconcat
142 [ internal
143 , command "internal" (info (ObCommand_Internal <$> internalCommand) mempty)
144 ])
146packageNames :: Parser [String]
147packageNames = some (strArgument (metavar "PACKAGE-NAME..."))
149deployCommand :: ArgsConfig -> Parser DeployCommand
150deployCommand cfg = hsubparser $ mconcat
151 [ command "init" $ info (DeployCommand_Init <$> deployInitOpts) $ progDesc "Initialize a deployment configuration directory"
152 , command "push" $ info (DeployCommand_Push <$> remoteBuilderParser) mempty
153 , command "test" $ info (DeployCommand_Test <$> platformP) $ progDesc "Test your obelisk project from a mobile platform."
154 , command "update" $ info (pure DeployCommand_Update) $ progDesc "Update the deployment's src thunk to latest"
155 ]
156 where
157 platformP = hsubparser $ mconcat
158 [ command "android" $ info (pure (Android, [])) mempty
159 , command "ios" $ info ((,) <$> pure IOS <*> (fmap pure $ strArgument (metavar "TEAMID" <> help "Your Team ID - found in the Apple developer portal"))) mempty
160 ]
162 remoteBuilderParser :: Parser (Maybe RemoteBuilder)
163 remoteBuilderParser =
164 flag (if enabledByDefault then enabled else Nothing) enabled (mconcat
165 [ long $ "enable-" <> flagBase
166 , help $ "Enable " <> flagDesc <> (if enabledByDefault then " (default)" else "")
167 ])
168 <|> flag enabled Nothing (mconcat
169 [ long $ "disable-" <> flagBase
170 , help $ "Disable a " <> flagDesc <> (if not enabledByDefault then " (default)" else "")
171 ])
172 where
173 enabledByDefault = _argsConfig_enableVmBuilderByDefault cfg
174 enabled = Just RemoteBuilder_ObeliskVM
175 flagBase = "vm-builder"
176 flagDesc = "managed Linux virtual machine as a Nix remote builder (requires Docker)"
179deployInitOpts :: Parser DeployInitOpts
180deployInitOpts = DeployInitOpts
181 <$> strArgument (action "directory" <> metavar "DEPLOYDIR" <> help "Path to a directory that it will create")
182 <*> strOption (long "ssh-key" <> action "file" <> metavar "SSHKEY" <> help "Path to an ssh key that it will symlink to")
183 <*> some (strOption (long "hostname" <> metavar "HOSTNAME" <> help "hostname of the deployment target"))
184 <*> strOption (long "route" <> metavar "PUBLICROUTE" <> help "Publicly accessible URL of your app")
185 <*> strOption (long "admin-email" <> metavar "ADMINEMAIL" <> help "Email address where administrative alerts will be sent")
186 <*> flag True False (long "disable-https" <> help "Disable automatic https configuration for the backend")
188type TeamID = String
189data RemoteBuilder = RemoteBuilder_ObeliskVM
190 deriving (Eq, Show)
192data DeployCommand
193 = DeployCommand_Init DeployInitOpts
194 | DeployCommand_Push (Maybe RemoteBuilder)
195 | DeployCommand_Test (PlatformDeployment, [String])
196 | DeployCommand_Update
197 deriving Show
199data DeployInitOpts = DeployInitOpts
200 { _deployInitOpts_outputDir :: FilePath
201 , _deployInitOpts_sshKey :: FilePath
202 , _deployInitOpts_hostname :: [String]
203 , _deployInitOpts_route :: String
204 , _deployInitOpts_adminEmail :: String
205 , _deployInitOpts_enableHttps :: Bool
206 }
207 deriving Show
209internalCommand :: Parser ObInternal
210internalCommand = subparser $ mconcat
211 [ command "run-static-io" $ info (ObInternal_RunStaticIO <$> argument (eitherReader decodeStaticKey) (action "static-key")) mempty
212 , command "clidemo" $ info (pure ObInternal_CLIDemo) mempty
213 ]
215--TODO: Result should provide normalised path and also original user input for error reporting.
216thunkDirectoryParser :: Parser FilePath
217thunkDirectoryParser = fmap (dropTrailingPathSeparator . normalise) . strArgument $ mconcat
218 [ action "directory"
219 , metavar "THUNKDIR"
220 , help "Path to directory containing thunk data"
221 ]
223data ThunkCommand
224 = ThunkCommand_Update [FilePath] (Maybe String)
225 | ThunkCommand_Unpack [FilePath]
226 | ThunkCommand_Pack [FilePath] Bool
227 deriving Show
229forceFlag :: Parser Bool
230forceFlag = 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."
232thunkCommand :: Parser ThunkCommand
233thunkCommand = hsubparser $ mconcat
234 [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser <*> optional (strOption (long "branch" <> metavar "BRANCH"))) $ 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 <*> forceFlag) $ 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 as = pure as >>= 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 let logLevel = toLogLevel $ "-v" `elem` cliArgs
271 notInteractive <- not <$> isInteractiveTerm
272 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case
273 ObeliskError_ProcessError (ProcessFailure p code) ann ->
274 ( "Process exited with code " <> T.pack (show code) <> "; " <> reconstructCommand p
275 <> maybe "" ("\n" <>) ann
276 , 2
277 )
278 ObeliskError_Unstructured msg -> (msg, 2)
280 return $ Obelisk cliConf
281 where
282 toLogLevel = bool Notice Debug
283 isInteractiveTerm = do
284 isTerm <- hIsTerminalDevice stdout
285 -- Running in bash/fish/zsh completion
286 inShellCompletion <- liftIO $ isInfixOf "completion" . unwords <$> getArgs
288 -- Respect the user’s TERM environment variable. Dumb terminals
289 -- like Eshell cannot handle lots of control sequences that the
290 -- spinner uses.
291 termEnv <- lookupEnv "TERM"
292 let isDumb = termEnv == Just "dumb"
294 return $ isTerm && not inShellCompletion && not isDumb
296-- | For use from development obelisk repls
297--
298-- Example:
299-- > runCommand $ someFuncInMonadObelisk ...
300runCommand :: ObeliskT IO a -> IO a
301runCommand f = flip runObelisk f =<< mkObeliskConfig
303main :: IO ()
304main = runCommand . main' =<< getArgsConfig
306main' :: MonadObelisk m => ArgsConfig -> m ()
307main' argsCfg = do
308 obPath <- liftIO getExecutablePath
309 myArgs <- liftIO getArgs
310 logLevel <- getLogLevel
311 putLog Debug $ T.pack $ unwords
312 [ "Starting Obelisk <" <> obPath <> ">"
313 , "args=" <> show myArgs
314 , "logging-level=" <> show logLevel
315 ]
317 --TODO: We'd like to actually use the parser to determine whether to hand off,
318 --but in the case where this implementation of 'ob' doesn't support all
319 --arguments being passed along, this could fail. For now, we don't bother
320 --with optparse-applicative until we've done the handoff.
321 let go as = do
322 args' <- liftIO $ handleParseResult (execParserPure parserPrefs (argsInfo argsCfg) as)
323 case _args_noHandOffPassed args' of
324 False -> return ()
325 True -> putLog Warning "--no-handoff should only be passed once and as the first argument; ignoring"
326 ob $ _args_command args'
327 handoffAndGo as = findProjectObeliskCommand "." >>= \case
328 Nothing -> go as -- If not in a project, just run ourselves
329 Just impl -> do
330 -- Invoke the real implementation, using --no-handoff to prevent infinite recursion
331 putLog Debug $ "Handing off to " <> T.pack impl
332 liftIO $ executeFile impl False ("--no-handoff" : myArgs) Nothing
333 case myArgs of
334 "--no-handoff" : as -> go as -- If we've been told not to hand off, don't hand off
335 a:as -- Otherwise bash completion would always hand-off even if the user isn't trying to
336 | "--bash-completion" `isPrefixOf` a
337 && "--no-handoff" `elem` as -> go (a:as)
338 | otherwise -> handoffAndGo (a:as)
339 as -> handoffAndGo as
341ob :: MonadObelisk m => ObCommand -> m ()
342ob = \case
343 ObCommand_Init source force -> initProject source force
344 ObCommand_Deploy dc -> case dc of
345 DeployCommand_Init deployOpts -> withProjectRoot "." $ \root -> do
346 let deployDir = _deployInitOpts_outputDir deployOpts
347 r <- liftIO $ canonicalizePath root
348 rootEqualsTarget <- liftIO $ equalFilePath r <$> canonicalizePath deployDir
349 when rootEqualsTarget $
350 failWith $ "Deploy directory " <> T.pack deployDir <> " should not be the same as project root."
351 thunkPtr <- readThunk root >>= \case
352 Left err -> failWith $ case err of
353 ReadThunkError_AmbiguousFiles ->
354 "Project root " <> T.pack r <> " is not a git repository or valid thunk"
355 ReadThunkError_UnrecognizedFiles ->
356 "Project root " <> T.pack r <> " is not a git repository or valid thunk"
357 _ -> "thunk read: " <> T.pack (show err)
358 Right (ThunkData_Packed ptr) -> return ptr
359 Right (ThunkData_Checkout (Just ptr)) -> return ptr
360 Right (ThunkData_Checkout Nothing) ->
361 getThunkPtr False root
362 let sshKeyPath = _deployInitOpts_sshKey deployOpts
363 hostname = _deployInitOpts_hostname deployOpts
364 route = _deployInitOpts_route deployOpts
365 adminEmail = _deployInitOpts_adminEmail deployOpts
366 enableHttps = _deployInitOpts_enableHttps deployOpts
367 deployInit thunkPtr deployDir sshKeyPath hostname route adminEmail enableHttps
368 DeployCommand_Push remoteBuilder -> do
369 deployPath <- liftIO $ canonicalizePath "."
370 deployPush deployPath $ case remoteBuilder of
371 Nothing -> pure []
372 Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg
373 DeployCommand_Update -> deployUpdate "."
374 DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs
375 ObCommand_Run -> inNixShell' $ static run
376 -- inNixShell ($(mkClosure 'ghcidAction) ())
377 ObCommand_Thunk tc -> case tc of
378 ThunkCommand_Update thunks mBranch -> mapM_ ((flip updateThunkToLatest) mBranch) thunks
379 ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks
380 ThunkCommand_Pack thunks force -> forM_ thunks (packThunk force)
381 ObCommand_Repl -> runRepl
382 ObCommand_Watch -> inNixShell' $ static runWatch
383 ObCommand_Shell so -> withProjectRoot "." $ \root ->
384 projectShell root False (_shellOpts_shell so) (_shellOpts_command so)
385 ObCommand_Doc shell pkgs -> withProjectRoot "." $ \root ->
386 projectShell root False shell (Just $ haddockCommand pkgs)
387 ObCommand_Internal icmd -> case icmd of
388 ObInternal_RunStaticIO k -> liftIO (unsafeLookupStaticPtr @(ObeliskT IO ()) k) >>= \case
389 Nothing -> failWith $ "ObInternal_RunStaticIO: no such StaticKey: " <> T.pack (show k)
390 Just p -> do
391 c <- getObelisk
392 liftIO $ runObelisk c $ deRefStaticPtr p
393 ObInternal_CLIDemo -> cliDemo
395haddockCommand :: [String] -> String
396haddockCommand pkgs = unwords
397 [ "for p in"
398 , unwords [getHaddockPath p ++ "/index.html" | p <- pkgs]
399 , "; do echo $p; done"
400 ]
401 where getHaddockPath p = "$(ghc-pkg field " ++ p ++ " haddock-html --simple-output)"
403--TODO: Clean up all the magic strings throughout this codebase
405getArgsConfig :: IO ArgsConfig
406getArgsConfig = pure $ ArgsConfig { _argsConfig_enableVmBuilderByDefault = System.Info.os == "darwin" }
408encodeStaticKey :: StaticKey -> String
409encodeStaticKey = T.unpack . decodeUtf8With lenientDecode . Base16.encode . LBS.toStrict . Binary.encode
411-- TODO: Use failWith in place of fail to be consistent.
412decodeStaticKey :: String -> Either String StaticKey
413decodeStaticKey s = case Base16.decode $ encodeUtf8 $ T.pack s of
414 (b, "") -> case Binary.decodeOrFail $ LBS.fromStrict b of
415 Right ("", _, a) -> pure a
416 Right _ -> fail "decodeStaticKey: Binary.decodeOrFail didn't consume all input"
417 Left (_, _, e) -> fail $ "decodeStaticKey: Binary.decodeOrFail failed: " <> show e
418 _ -> fail $ "decodeStaticKey: could not decode hex string: " <> show s