git.iko.soy/obelisk
on 3caa3db help sign in
obelisk/lib/command/src/Obelisk/Command.hs
332 lines 13 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 Control.Monad.Reader (ask)
13import qualified Data.Binary as Binary
14import Data.Bool (bool)
15import qualified Data.ByteString.Base16 as Base16
16import qualified Data.ByteString.Lazy as LBS
17import Data.List
18import Data.Maybe (catMaybes)
19import Data.Monoid
20import qualified Data.Text as T
21import Data.Text.Encoding
22import GHC.StaticPtr
23import Options.Applicative
24import System.Directory
25import System.Environment
26import System.FilePath
27import System.IO (hIsTerminalDevice, stdout)
28import System.Posix.Process (executeFile)
29import System.Process (callCommand)
31import Obelisk.App
32import Obelisk.CLI (Severity (..), cliDemo, failWith, getLogLevel, newLoggingConfig, putLog)
33import Obelisk.Command.Deploy
34import Obelisk.Command.Project
35import Obelisk.Command.Repl
36import Obelisk.Command.Run
37import Obelisk.Command.Thunk
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
49args :: Parser Args
50args = Args <$> noHandoff <*> verbose <*> obCommand
52noHandoff :: Parser Bool
53noHandoff = flag False True $ mconcat
54 [ long "no-handoff"
55 , help "Do not hand off execution to project-specific implementation of this command"
56 , hidden
57 ]
59verbose :: Parser Bool
60verbose = flag False True $ mconcat
61 [ long "verbose"
62 , short 'v'
63 , help "Be more verbose"
64 ]
66argsInfo :: ParserInfo Args
67argsInfo = info (args <**> helper) $ mconcat
68 [ fullDesc
69 , progDesc "Manage Obelisk projects"
70 ]
72initSource :: Parser InitSource
73initSource = foldl1 (<|>)
74 [ pure InitSource_Default
75 , InitSource_Branch <$> strOption (long "branch" <> metavar "BRANCH")
76 , InitSource_Symlink <$> strOption (long "symlink" <> action "directory" <> metavar "PATH")
77 ]
79data ObCommand
80 = ObCommand_Init InitSource
81 | ObCommand_Deploy DeployCommand
82 | ObCommand_Run
83 | ObCommand_Thunk ThunkCommand
84 | ObCommand_Repl FilePath
85 | ObCommand_Watch FilePath
86 | ObCommand_Internal ObInternal
87 deriving Show
89data ObInternal
90 = ObInternal_RunStaticIO StaticKey
91 | ObInternal_CLIDemo
92 deriving Show
94inNixShell' :: MonadObelisk m => StaticPtr (ObeliskT IO ()) -> m ()
95inNixShell' p = withProjectRoot "." $ \root -> do
96 cmd <- liftIO $ unwords <$> mkCmd -- TODO: shell escape instead of unwords
97 projectShell root False "ghc" cmd
98 where
99 mkCmd = do
100 obArgs <- getObArgs
101 progName <- getExecutablePath
102 return $ progName : catMaybes
103 [ Just "--no-handoff"
104 , bool Nothing (Just "--verbose") $ _args_verbose obArgs
105 , Just "internal"
106 , Just "run-static-io"
107 , Just $ encodeStaticKey $ staticKey p
108 ]
110obCommand :: Parser ObCommand
111obCommand = hsubparser
112 (mconcat
113 [ command "init" $ info (ObCommand_Init <$> initSource) $ progDesc "Initialize an Obelisk project"
114 , command "deploy" $ info (ObCommand_Deploy <$> deployCommand) $ progDesc "Prepare a deployment for an Obelisk project"
115 , command "run" $ info (pure ObCommand_Run) $ progDesc "Run current project in development mode"
116 , command "thunk" $ info (ObCommand_Thunk <$> thunkCommand) $ progDesc "Manipulate thunk directories"
117 , command "repl" $ info (ObCommand_Repl <$> strArgument (action "directory")) $ progDesc "Open an interactive interpreter"
118 , command "watch" $ info (ObCommand_Watch <$> strArgument (action "directory"))$ progDesc "Watch directory for changes and update interactive interpreter"
119 ])
120 <|> subparser
121 (mconcat
122 [ internal
123 , command "internal" (info (ObCommand_Internal <$> internalCommand) mempty)
124 ])
126deployCommand :: Parser DeployCommand
127deployCommand = hsubparser $ mconcat
128 [ command "init" $ info deployInitCommand $ progDesc "Initialize a deployment configuration directory"
129 , command "push" $ info (pure DeployCommand_Push) mempty
130 , command "test" $ info (DeployCommand_Test <$> argument (maybeReader readPlatform) (completeWith ["android"])) $ progDesc "Test your obelisk project from a mobile platform. [Only android supported]"
131 , command "update" $ info (pure DeployCommand_Update) $ progDesc "Update the deployment's src thunk to latest"
132 ]
134readPlatform :: String -> Maybe Platform
135readPlatform = \case
136 "android" -> Just Android
137 _ -> Nothing
139deployInitCommand :: Parser DeployCommand
140deployInitCommand = fmap DeployCommand_Init $ DeployInitOpts
141 <$> strArgument (action "directory" <> metavar "DEPLOYDIR" <> help "Path to a directory that it will create")
142 <*> strOption (long "ssh-key" <> action "file" <> metavar "SSHKEY" <> help "Path to an ssh key that it will symlink to")
143 <*> some (strOption (long "hostname" <> metavar "HOSTNAME" <> help "hostname of the deployment target"))
144 <*> strOption (long "upstream" <> value "origin" <> metavar "REMOTE" <> help "git remote to use for the src thunk" <> showDefault)
146data Platform = Android
147 deriving (Show)
149data DeployCommand
150 = DeployCommand_Init DeployInitOpts
151 | DeployCommand_Push
152 | DeployCommand_Test Platform
153 | DeployCommand_Update
154 deriving Show
156data DeployInitOpts = DeployInitOpts
157 { _deployInitOpts_outputDir :: FilePath
158 , _deployInitOpts_sshKey :: FilePath
159 , _deployInitOpts_hostname :: [String]
160 , _deployInitOpts_remote :: String
161 }
162 deriving Show
164internalCommand :: Parser ObInternal
165internalCommand = subparser $ mconcat
166 [ command "run-static-io" $ info (ObInternal_RunStaticIO <$> argument (eitherReader decodeStaticKey) (action "static-key")) mempty
167 , command "clidemo" $ info (pure ObInternal_CLIDemo) mempty
168 ]
170--TODO: Result should provide normalised path and also original user input for error reporting.
171thunkDirectoryParser :: Parser FilePath
172thunkDirectoryParser = fmap (dropTrailingPathSeparator . normalise) . strArgument $ mconcat
173 [ action "directory"
174 , metavar "THUNKDIR"
175 , help "Path to directory containing thunk data"
176 ]
178data ThunkPackOpts = ThunkPackOpts
179 { _thunkPackOpts_directory :: FilePath
180 , _thunkPackOpts_upstream :: String
181 }
182 deriving Show
184data ThunkCommand
185 = ThunkCommand_Update [FilePath]
186 | ThunkCommand_Unpack [FilePath]
187 | ThunkCommand_Pack [ThunkPackOpts]
188 deriving Show
190thunkPackOpts :: Parser ThunkPackOpts
191thunkPackOpts = (ThunkPackOpts <$> thunkDirectoryParser <*>) . strOption $ mconcat
192 [ long "upstream"
193 , value "origin"
194 , metavar "REMOTE"
195 , help "Git remote that packed thunk will point to"
196 , showDefault
197 ]
199thunkCommand :: Parser ThunkCommand
200thunkCommand = hsubparser $ mconcat
201 [ command "update" $ info (ThunkCommand_Update <$> some thunkDirectoryParser) $ progDesc "Update thunk to latest revision available"
202 , command "unpack" $ info (ThunkCommand_Unpack <$> some thunkDirectoryParser) $ progDesc "Unpack thunk into git checkout of revision it points to"
203 , command "pack" $ info (ThunkCommand_Pack <$> some thunkPackOpts) $ progDesc "Pack git checkout into thunk that points at given upstream"
204 ]
206parserPrefs :: ParserPrefs
207parserPrefs = defaultPrefs
208 { prefShowHelpOnEmpty = True
209 }
211-- | Are we on a terminal with active user interaction?
212isInteractiveTerm :: IO Bool
213isInteractiveTerm = do
214 isTerm <- hIsTerminalDevice stdout
215 -- Running in bash/fish/zsh completion
216 inShellCompletion <- liftIO $ isInfixOf "completion" . unwords <$> getArgs
217 return $ isTerm && not inShellCompletion
219mkObeliskConfig :: IO Obelisk
220mkObeliskConfig = do
221 notInteractive <- not <$> isInteractiveTerm
222 logLevel <- toLogLevel <$> getObArgs
223 loggingConfig <- newLoggingConfig logLevel notInteractive
224 return $ Obelisk notInteractive loggingConfig
225 where
226 toLogLevel = bool Notice Debug . _args_verbose
228getObArgs :: IO Args
229getObArgs = getArgs >>= handleParseResult . execParserPure parserPrefs argsInfo
231main :: IO ()
232main = mkObeliskConfig >>= (`runObelisk` ObeliskT main')
234main' :: MonadObelisk m => m ()
235main' = do
236 c <- ask
237 obPath <- liftIO getExecutablePath
238 obArgs <- liftIO getObArgs
239 logLevel <- liftIO $ getLogLevel $ _obelisk_logging c
240 putLog Debug $ T.pack $ unwords
241 [ "Starting Obelisk <" <> obPath <> ">"
242 , "args=" <> show obArgs
243 , "noSpinner=" <> show (_obelisk_noSpinner c)
244 , "logging-level=" <> show logLevel
245 ]
247 --TODO: We'd like to actually use the parser to determine whether to hand off,
248 --but in the case where this implementation of 'ob' doesn't support all
249 --arguments being passed along, this could fail. For now, we don't bother
250 --with optparse-applicative until we've done the handoff.
251 myArgs <- liftIO getArgs
252 let go as = do
253 args' <- liftIO $ handleParseResult (execParserPure parserPrefs argsInfo as)
254 case _args_noHandOffPassed args' of
255 False -> return ()
256 True -> putLog Warning "--no-handoff should only be passed once and as the first argument; ignoring"
257 ob $ _args_command args'
258 handoffAndGo as = findProjectObeliskCommand "." >>= \case
259 Nothing -> go as -- If not in a project, just run ourselves
260 Just impl -> do
261 -- Invoke the real implementation, using --no-handoff to prevent infinite recursion
262 putLog Debug $ "Handing off to " <> T.pack impl
263 liftIO $ executeFile impl False ("--no-handoff" : myArgs) Nothing
264 case myArgs of
265 "--no-handoff" : as -> go as -- If we've been told not to hand off, don't hand off
266 a:as -- Otherwise bash completion would always hand-off even if the user isn't trying to
267 | "--bash-completion" `isPrefixOf` a
268 && "--no-handoff" `elem` as -> go (a:as)
269 | otherwise -> handoffAndGo (a:as)
270 as -> handoffAndGo as
272ob :: MonadObelisk m => ObCommand -> m ()
273ob = \case
274 ObCommand_Init source -> initProject source
275 ObCommand_Deploy dc -> case dc of
276 DeployCommand_Init deployOpts -> withProjectRoot "." $ \root -> do
277 let deployDir = _deployInitOpts_outputDir deployOpts
278 r <- liftIO $ canonicalizePath root
279 rootEqualsTarget <- liftIO $ equalFilePath r <$> canonicalizePath deployDir
280 when rootEqualsTarget $
281 failWith $ "Deploy directory " <> T.pack deployDir <> " should not be the same as project root."
282 thunkPtr <- readThunk root >>= \case
283 Left err -> failWith $ case err of
284 ReadThunkError_AmbiguousFiles ->
285 "Project root " <> T.pack r <> " is not a git repository or valid thunk"
286 ReadThunkError_UnrecognizedFiles ->
287 "Project root " <> T.pack r <> " is not a git repository or valid thunk"
288 _ -> "thunk read: " <> T.pack (show err)
289 Right (ThunkData_Packed ptr) -> return ptr
290 Right (ThunkData_Checkout (Just ptr)) -> return ptr
291 Right (ThunkData_Checkout Nothing) ->
292 getThunkPtr' False root (T.pack $ _deployInitOpts_remote deployOpts)
293 let sshKeyPath = _deployInitOpts_sshKey deployOpts
294 hostname = _deployInitOpts_hostname deployOpts
295 deployInit thunkPtr (root </> "config") deployDir sshKeyPath hostname
296 DeployCommand_Push -> deployPush "."
297 DeployCommand_Test Android -> withProjectRoot "." $ \root -> do
298 let srcDir = root </> "src"
299 exists <- liftIO $ doesDirectoryExist srcDir
300 unless exists $ failWith "ob test should be run inside of a deploy directory"
301 result <- nixBuildAttrWithCache srcDir "android.frontend"
302 liftIO $ callCommand $ result </> "bin" </> "deploy"
303 DeployCommand_Update -> deployUpdate "."
304 ObCommand_Run -> inNixShell' $ static run
305 -- inNixShell ($(mkClosure 'ghcidAction) ())
306 ObCommand_Thunk tc -> case tc of
307 ThunkCommand_Update thunks -> mapM_ updateThunkToLatest thunks
308 ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks
309 ThunkCommand_Pack thunks -> forM_ thunks $ \(ThunkPackOpts dir upstream) -> packThunk dir (T.pack upstream)
310 ObCommand_Repl component -> runRepl component
311 ObCommand_Watch component -> watch component
312 ObCommand_Internal icmd -> case icmd of
313 ObInternal_RunStaticIO k -> liftIO (unsafeLookupStaticPtr @(ObeliskT IO ()) k) >>= \case
314 Nothing -> failWith $ "ObInternal_RunStaticIO: no such StaticKey: " <> T.pack (show k)
315 Just p -> do
316 c <- ask
317 liftIO $ runObelisk c $ deRefStaticPtr p
318 ObInternal_CLIDemo -> cliDemo
320--TODO: Clean up all the magic strings throughout this codebase
322encodeStaticKey :: StaticKey -> String
323encodeStaticKey = T.unpack . decodeUtf8 . Base16.encode . LBS.toStrict . Binary.encode
325-- TODO: Use failWith in place of fail to be consistent.
326decodeStaticKey :: String -> Either String StaticKey
327decodeStaticKey s = case Base16.decode $ encodeUtf8 $ T.pack s of
328 (b, "") -> case Binary.decodeOrFail $ LBS.fromStrict b of
329 Right ("", _, a) -> pure a
330 Right _ -> fail "decodeStaticKey: Binary.decodeOrFail didn't consume all input"
331 Left (_, _, e) -> fail $ "decodeStaticKey: Binary.decodeOrFail failed: " <> show e
332 _ -> fail $ "decodeStaticKey: could not decode hex string: " <> show s