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