git.iko.soy/obelisk
on ba85ebf help sign in
obelisk/lib/command/src/Obelisk/Command.hs
419 lines 19 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 Data.Time.Clock
20import Data.Time.Format (formatTime, defaultTimeLocale)
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.Command.Deploy
34import Obelisk.Command.Project
35import Obelisk.Command.Run
36import Obelisk.Command.Thunk
37import qualified Obelisk.Command.VmBuilder as VmBuilder
38import qualified Obelisk.Command.Preprocessor as Preprocessor
41data Args = Args
42 { _args_noHandOffPassed :: Bool
43 -- ^ This flag is actually handled outside of the optparse-applicative parser, but we detect whether
44 -- it has gotten through in order to notify the user that it should only be passed once and as the very
45 -- first argument
46 , _args_verbose :: Bool
47 , _args_command :: ObCommand
48 }
49 deriving Show
51newtype ArgsConfig = ArgsConfig
52 { _argsConfig_enableVmBuilderByDefault :: Bool
53 }
55args :: ArgsConfig -> Parser Args
56args cfg = Args <$> noHandoff <*> verbose <*> obCommand cfg
58noHandoff :: Parser Bool
59noHandoff = flag False True $ mconcat
60 [ long "no-handoff"
61 , help "Do not hand off execution to project-specific implementation of this command"
62 , hidden
63 ]
65verbose :: Parser Bool
66verbose = flag False True $ mconcat
67 [ long "verbose"
68 , short 'v'
69 , help "Be more verbose"
70 ]
72argsInfo :: ArgsConfig -> ParserInfo Args
73argsInfo cfg = info (args cfg <**> helper) $ mconcat
74 [ fullDesc
75 , progDesc "Manage Obelisk projects"
76 ]
78initSource :: Parser InitSource
79initSource = foldl1 (<|>)
80 [ pure InitSource_Default
81 , InitSource_Branch <$> strOption (long "branch" <> metavar "BRANCH")
82 , InitSource_Symlink <$> strOption (long "symlink" <> action "directory" <> metavar "PATH")
83 ]
85initForce :: Parser Bool
86initForce = switch (long "force" <> help "Allow ob init to overwrite files")
88data ObCommand
89 = ObCommand_Init InitSource Bool
90 | ObCommand_Deploy DeployCommand
91 | ObCommand_Run
92 | ObCommand_Profile (Maybe FilePath)
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_Hoogle String Int -- shell and port
99 | ObCommand_Internal ObInternal
100 deriving Show
102data ObInternal
103 -- the preprocessor argument syntax is also handled outside
104 -- optparse-applicative, but it shouldn't ever conflict with another syntax
105 = ObInternal_ApplyPackages String String String [String]
106 deriving Show
108obCommand :: ArgsConfig -> Parser ObCommand
109obCommand cfg = hsubparser
110 (mconcat
111 [ command "init" $ info (ObCommand_Init <$> initSource <*> initForce) $ progDesc "Initialize an Obelisk project"
112 , command "deploy" $ info (ObCommand_Deploy <$> deployCommand cfg) $ progDesc "Prepare a deployment for an Obelisk project"
113 , command "run" $ info (pure ObCommand_Run) $ progDesc "Run current project in development mode"
114 , command "profile" $ info (ObCommand_Profile <$> optional (strOption (long "output" <> short 'o' <> help "Base output to use for profiling output. Suffixes are added to this based on the profiling type. Defaults to a timestamped path in the profile/ directory in the project's root." <> metavar "PATH"))) $ progDesc "Run current project with profiling enabled"
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 , command "hoogle" $ info (ObCommand_Hoogle <$> shellFlags <*> portOpt 8080) $ progDesc "Run a hoogle server locally for your project's dependency tree"
125 ])
127packageNames :: Parser [String]
128packageNames = some (strArgument (metavar "PACKAGE-NAME..."))
130deployCommand :: ArgsConfig -> Parser DeployCommand
131deployCommand cfg = hsubparser $ mconcat
132 [ command "init" $ info (DeployCommand_Init <$> deployInitOpts) $ progDesc "Initialize a deployment configuration directory"
133 , command "push" $ info (DeployCommand_Push <$> remoteBuilderParser) mempty
134 , command "test" $ info (DeployCommand_Test <$> platformP) $ progDesc "Test your obelisk project from a mobile platform."
135 , command "update" $ info (pure DeployCommand_Update) $ progDesc "Update the deployment's src thunk to latest"
136 ]
137 where
138 platformP = hsubparser $ mconcat
139 [ command "android" $ info (pure (Android, [])) mempty
140 , command "ios" $ info ((,) <$> pure IOS <*> (fmap pure $ strArgument (metavar "TEAMID" <> help "Your Team ID - found in the Apple developer portal"))) mempty
141 ]
143 remoteBuilderParser :: Parser (Maybe RemoteBuilder)
144 remoteBuilderParser =
145 flag (if enabledByDefault then enabled else Nothing) enabled (mconcat
146 [ long $ "enable-" <> flagBase
147 , help $ "Enable " <> flagDesc <> (if enabledByDefault then " (default)" else "")
148 ])
149 <|> flag enabled Nothing (mconcat
150 [ long $ "disable-" <> flagBase
151 , help $ "Disable a " <> flagDesc <> (if not enabledByDefault then " (default)" else "")
152 ])
153 where
154 enabledByDefault = _argsConfig_enableVmBuilderByDefault cfg
155 enabled = Just RemoteBuilder_ObeliskVM
156 flagBase = "vm-builder"
157 flagDesc = "managed Linux virtual machine as a Nix remote builder (requires Docker)"
160deployInitOpts :: Parser DeployInitOpts
161deployInitOpts = DeployInitOpts
162 <$> strArgument (action "directory" <> metavar "DEPLOYDIR" <> help "Path to a directory that it will create")
163 <*> strOption (long "ssh-key" <> action "file" <> metavar "SSHKEY" <> help "Path to an ssh key that it will symlink to")
164 <*> some (strOption (long "hostname" <> metavar "HOSTNAME" <> help "hostname of the deployment target"))
165 <*> strOption (long "route" <> metavar "PUBLICROUTE" <> help "Publicly accessible URL of your app")
166 <*> strOption (long "admin-email" <> metavar "ADMINEMAIL" <> help "Email address where administrative alerts will be sent")
167 <*> flag True False (long "disable-https" <> help "Disable automatic https configuration for the backend")
169type TeamID = String
170data RemoteBuilder = RemoteBuilder_ObeliskVM
171 deriving (Eq, Show)
173data DeployCommand
174 = DeployCommand_Init DeployInitOpts
175 | DeployCommand_Push (Maybe RemoteBuilder)
176 | DeployCommand_Test (PlatformDeployment, [String])
177 | DeployCommand_Update
178 deriving Show
180data DeployInitOpts = DeployInitOpts
181 { _deployInitOpts_outputDir :: FilePath
182 , _deployInitOpts_sshKey :: FilePath
183 , _deployInitOpts_hostname :: [String]
184 , _deployInitOpts_route :: String
185 , _deployInitOpts_adminEmail :: String
186 , _deployInitOpts_enableHttps :: Bool
187 }
188 deriving Show
190--TODO: Result should provide normalised path and also original user input for error reporting.
191thunkDirectoryParser :: Parser FilePath
192thunkDirectoryParser = fmap (dropTrailingPathSeparator . normalise) . strArgument $ mconcat
193 [ action "directory"
194 , metavar "THUNKDIR"
195 , help "Path to directory containing thunk data"
196 ]
198thunkConfig :: Parser ThunkConfig
199thunkConfig = ThunkConfig
200 <$>
201 ( flag' (Just True) (long "private" <> help "Mark thunks as pointing to a private repository")
202 <|> flag' (Just False) (long "public" <> help "Mark thunks as pointing to a public repository")
203 <|> pure Nothing
204 )
206thunkUpdateConfig :: Parser ThunkUpdateConfig
207thunkUpdateConfig = ThunkUpdateConfig
208 <$> optional (strOption (long "branch" <> metavar "BRANCH" <> help "Use the given branch when looking for the latest revision"))
209 <*> thunkConfig
211thunkPackConfig :: Parser ThunkPackConfig
212thunkPackConfig = ThunkPackConfig
213 <$> 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.")
214 <*> thunkConfig
216data ThunkCommand
217 = ThunkCommand_Update [FilePath] ThunkUpdateConfig
218 | ThunkCommand_Unpack [FilePath]
219 | ThunkCommand_Pack [FilePath] ThunkPackConfig
220 deriving Show
222thunkCommand :: Parser ThunkCommand
223thunkCommand = hsubparser $ mconcat
224 [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser <*> thunkUpdateConfig) $ progDesc "Update thunk to latest revision available"
225 , command "unpack" $ info (ThunkCommand_Unpack <$> some thunkDirectoryParser) $ progDesc "Unpack thunk into git checkout of revision it points to"
226 , command "pack" $ info (ThunkCommand_Pack <$> some thunkDirectoryParser <*> thunkPackConfig) $ progDesc "Pack git checkout into thunk that points at the current branch's upstream"
227 ]
229data ShellOpts
230 = ShellOpts
231 { _shellOpts_shell :: String
232 , _shellOpts_command :: Maybe String
233 }
234 deriving Show
236shellFlags :: Parser String
237shellFlags =
238 flag' "ghc" (long "ghc" <> help "Enter a shell environment having ghc (default)")
239 <|> flag "ghc" "ghcjs" (long "ghcjs" <> help "Enter a shell having ghcjs rather than ghc")
240 <|> strOption (short 'A' <> long "argument" <> metavar "NIXARG" <> help "Use the environment specified by the given nix argument of `shells'")
242shellOpts :: Parser ShellOpts
243shellOpts = ShellOpts
244 <$> shellFlags
245 <*> optional (strArgument (metavar "COMMAND"))
247portOpt :: Int -> Parser Int
248portOpt dfault = option auto (long "port" <> short 'p' <> help "Port number for server" <> showDefault <> value dfault <> metavar "INT")
250parserPrefs :: ParserPrefs
251parserPrefs = defaultPrefs
252 { prefShowHelpOnEmpty = True
253 }
255parseCLIArgs :: ArgsConfig -> [String] -> IO Args
256parseCLIArgs cfg = handleParseResult . execParserPure parserPrefs (argsInfo cfg)
258-- | Create an Obelisk config for the current process.
259mkObeliskConfig :: IO Obelisk
260mkObeliskConfig = do
261 cliArgs <- getArgs
262 -- This function should not use argument parser (full argument parsing happens post handoff)
263 -- TODO: See if we can use the argument parser with a subset of the parsers to get logging level out.
264 let logLevel = toLogLevel $ any (`elem` ["-v", "--verbose"]) cliArgs
265 notInteractive <- not <$> isInteractiveTerm
266 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case
267 ObeliskError_ProcessError (ProcessFailure p code) ann ->
268 ( "Process exited with code " <> T.pack (show code) <> "; " <> reconstructCommand p
269 <> maybe "" ("\n" <>) ann
270 , 2
271 )
272 ObeliskError_Unstructured msg -> (msg, 2)
274 return $ Obelisk cliConf
275 where
276 toLogLevel = bool Notice Debug
277 isInteractiveTerm = do
278 isTerm <- hIsTerminalDevice stdout
279 -- Running in bash/fish/zsh completion
280 inShellCompletion <- liftIO $ isInfixOf "completion" . unwords <$> getArgs
282 -- Respect the user’s TERM environment variable. Dumb terminals
283 -- like Eshell cannot handle lots of control sequences that the
284 -- spinner uses.
285 termEnv <- lookupEnv "TERM"
286 let isDumb = termEnv == Just "dumb"
288 return $ isTerm && not inShellCompletion && not isDumb
290-- | For use from development obelisk repls
291--
292-- Example:
293-- > runCommand $ someFuncInMonadObelisk ...
294runCommand :: ObeliskT IO a -> IO a
295runCommand f = flip runObelisk f =<< mkObeliskConfig
297main :: IO ()
298main = runCommand . main' =<< getArgsConfig
300main' :: MonadObelisk m => ArgsConfig -> m ()
301main' argsCfg = do
302 obPath <- liftIO getExecutablePath
303 myArgs <- liftIO getArgs
304 logLevel <- getLogLevel
305 putLog Debug $ T.pack $ unwords
306 [ "Starting Obelisk <" <> obPath <> ">"
307 , "args=" <> show myArgs
308 , "logging-level=" <> show logLevel
309 ]
311 --TODO: We'd like to actually use the parser to determine whether to hand off,
312 --but in the case where this implementation of 'ob' doesn't support all
313 --arguments being passed along, this could fail. For now, we don't bother
314 --with optparse-applicative until we've done the handoff.
315 let go as = do
316 args' <- liftIO $ handleParseResult (execParserPure parserPrefs (argsInfo argsCfg) as)
317 case _args_noHandOffPassed args' of
318 False -> return ()
319 True -> putLog Warning "--no-handoff should only be passed once and as the first argument; ignoring"
320 ob $ _args_command args'
321 handoffAndGo as = findProjectObeliskCommand "." >>= \case
322 Nothing -> go as -- If not in a project, just run ourselves
323 Just impl -> do
324 -- Invoke the real implementation, using --no-handoff to prevent infinite recursion
325 putLog Debug $ "Handing off to " <> T.pack impl
326 liftIO $ executeFile impl False ("--no-handoff" : myArgs) Nothing
327 case myArgs of
328 "--no-handoff" : as -> go as -- If we've been told not to hand off, don't hand off
329 origPath:inPath:outPath:preprocessorName:packagePaths
330 | preprocessorName == preprocessorIdentifier && any (\c -> c == '.' || c == pathSeparator) origPath ->
331 ob $ ObCommand_Internal $ ObInternal_ApplyPackages origPath inPath outPath packagePaths
332 a:as -- Otherwise bash completion would always hand-off even if the user isn't trying to
333 | "--bash-completion" `isPrefixOf` a
334 && "--no-handoff" `elem` as -> go (a:as)
335 | otherwise -> handoffAndGo (a:as)
336 as -> handoffAndGo as
338ob :: MonadObelisk m => ObCommand -> m ()
339ob = \case
340 ObCommand_Init source force -> initProject source force
341 ObCommand_Deploy dc -> case dc of
342 DeployCommand_Init deployOpts -> withProjectRoot "." $ \root -> do
343 let deployDir = _deployInitOpts_outputDir deployOpts
344 r <- liftIO $ canonicalizePath root
345 rootEqualsTarget <- liftIO $ equalFilePath r <$> canonicalizePath deployDir
346 when rootEqualsTarget $
347 failWith $ "Deploy directory " <> T.pack deployDir <> " should not be the same as project root."
348 thunkPtr <- readThunk root >>= \case
349 Left err -> failWith $ case err of
350 ReadThunkError_AmbiguousFiles ->
351 "Project root " <> T.pack r <> " is not a git repository or valid thunk"
352 ReadThunkError_UnrecognizedFiles ->
353 "Project root " <> T.pack r <> " is not a git repository or valid thunk"
354 _ -> "thunk read: " <> T.pack (show err)
355 Right (ThunkData_Packed ptr) -> return ptr
356 Right (ThunkData_Checkout (Just ptr)) -> return ptr
357 Right (ThunkData_Checkout Nothing) ->
358 getThunkPtr False root Nothing
359 let sshKeyPath = _deployInitOpts_sshKey deployOpts
360 hostname = _deployInitOpts_hostname deployOpts
361 route = _deployInitOpts_route deployOpts
362 adminEmail = _deployInitOpts_adminEmail deployOpts
363 enableHttps = _deployInitOpts_enableHttps deployOpts
364 deployInit thunkPtr deployDir sshKeyPath hostname route adminEmail enableHttps
365 DeployCommand_Push remoteBuilder -> do
366 deployPath <- liftIO $ canonicalizePath "."
367 deployPush deployPath $ case remoteBuilder of
368 Nothing -> pure []
369 Just RemoteBuilder_ObeliskVM -> (:[]) <$> VmBuilder.getNixBuildersArg
370 DeployCommand_Update -> deployUpdate "."
371 DeployCommand_Test (platform, extraArgs) -> deployMobile platform extraArgs
372 ObCommand_Run -> run
373 ObCommand_Profile mBasePath -> do
374 basePath <- case mBasePath of
375 Just path -> pure path
376 Nothing -> do
377 time <- liftIO $ getCurrentTime
378 pure $ "profile" </> formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S" time
379 profile basePath
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_Hoogle shell' port -> withProjectRoot "." $ \root -> do
391 nixShellWithHoogle root True shell' $ Just $ "hoogle server -p " <> show port <> " --local"
392 ObCommand_Internal icmd -> case icmd of
393 ObInternal_ApplyPackages origPath inPath outPath packagePaths -> do
394 liftIO $ Preprocessor.applyPackages origPath inPath outPath packagePaths
396haddockCommand :: [String] -> String
397haddockCommand pkgs = unwords
398 [ "for p in"
399 , unwords [getHaddockPath p ++ "/index.html" | p <- pkgs]
400 , "; do echo $p; done"
401 ]
402 where getHaddockPath p = "$(ghc-pkg field " ++ p ++ " haddock-html --simple-output)"
404--TODO: Clean up all the magic strings throughout this codebase
406getArgsConfig :: IO ArgsConfig
407getArgsConfig = pure $ ArgsConfig { _argsConfig_enableVmBuilderByDefault = System.Info.os == "darwin" }
409encodeStaticKey :: StaticKey -> String
410encodeStaticKey = T.unpack . decodeUtf8With lenientDecode . Base16.encode . LBS.toStrict . Binary.encode
412-- TODO: Use failWith in place of fail to be consistent.
413decodeStaticKey :: String -> Either String StaticKey
414decodeStaticKey s = case Base16.decode $ encodeUtf8 $ T.pack s of
415 (b, "") -> case Binary.decodeOrFail $ LBS.fromStrict b of
416 Right ("", _, a) -> pure a
417 Right _ -> fail "decodeStaticKey: Binary.decodeOrFail didn't consume all input"
418 Left (_, _, e) -> fail $ "decodeStaticKey: Binary.decodeOrFail failed: " <> show e
419 _ -> fail $ "decodeStaticKey: could not decode hex string: " <> show s