Add interactive init command (#224) (#227)

* Add interactive init command (#224)

* fixup! Add interactive init command (#224)

* fixup! Add interactive init command (#224)

app/Main.hs

@@ -52,7 +52,9 @@ optionParser = Opts
     command "rollback"
     (info rollbackParser (progDesc "Roll back to Nth previous release")) <>
     command "maintenance"
-    (info maintenanceParser (progDesc "Enable/Disable maintenance mode"))
+    (info maintenanceParser (progDesc "Enable/Disable maintenance mode")) <>
+    command "init"
+    (info initParser (progDesc "Initialize hapistrano file"))
     )
   <*> strOption
   ( long "config"
@@ -92,6 +94,9 @@ rollbackParser = Rollback
   <> showDefault
   <> help "How many deployments back to go?" )
 
+initParser :: Parser Command
+initParser = pure InitConfig
+
 maintenanceParser :: Parser Command
 maintenanceParser =
   Maintenance
@@ -120,27 +125,35 @@ data Message
 
 main :: IO ()
 main = do
-  Opts{..} <- execParser parserInfo
+  opts@Opts{..} <- execParser parserInfo
+  case optsCommand of
+    Deploy cliReleaseFormat cliKeepReleases cliKeepOneFailed ->
+      runHapCmd opts $ \hapConfig@C.Config{..} executionMode ->
+        Hap.deploy
+          hapConfig
+          (fromMaybeReleaseFormat cliReleaseFormat configReleaseFormat)
+          (fromMaybeKeepReleases cliKeepReleases configKeepReleases)
+          (cliKeepOneFailed || configKeepOneFailed)
+          executionMode
+    Rollback n ->
+      runHapCmd opts $ \C.Config{..} _ ->
+        Hap.rollback configTargetSystem configDeployPath n configRestartCommand
+    Maintenance Enable ->
+      runHapCmd opts $ \C.Config{..} _ ->
+        Hap.writeMaintenanceFile configDeployPath configMaintenanceDirectory configMaintenanceFileName
+    Maintenance _ ->
+      runHapCmd opts $ \C.Config{..} _ ->
+        Hap.deleteMaintenanceFile configDeployPath configMaintenanceDirectory configMaintenanceFileName
+    InitConfig -> Hap.initConfig getLine
+
+runHapCmd :: Opts -> (C.Config -> C.ExecutionMode -> Hapistrano ()) -> IO ()
+runHapCmd Opts{..} hapCmd = do
   hapConfig@C.Config{..} <- Yaml.loadYamlSettings [optsConfigFile] [] Yaml.useEnv
   chan <- newTChanIO
   let printFnc dest str = atomically $
         writeTChan chan (PrintMsg dest str)
       hap shell sshOpts executionMode = do
-        r <- Hap.runHapistrano sshOpts shell printFnc $
+        r <- Hap.runHapistrano sshOpts shell printFnc $ hapCmd hapConfig executionMode
-          case optsCommand of
-            Deploy cliReleaseFormat cliKeepReleases cliKeepOneFailed ->
-              Hap.deploy
-                hapConfig
-                (fromMaybeReleaseFormat cliReleaseFormat configReleaseFormat)
-                (fromMaybeKeepReleases cliKeepReleases configKeepReleases)
-                (cliKeepOneFailed || configKeepOneFailed)
-                executionMode
-            Rollback n ->
-              Hap.rollback configTargetSystem configDeployPath n configRestartCommand
-            Maintenance Enable-> do
-              Hap.writeMaintenanceFile configDeployPath configMaintenanceDirectory configMaintenanceFileName
-            Maintenance _ -> do
-              Hap.deleteMaintenanceFile configDeployPath configMaintenanceDirectory configMaintenanceFileName
         atomically (writeTChan chan FinishMsg)
         return r
       printer :: Int -> IO ()
@@ -162,6 +175,7 @@ main = do
                   hap targetShell (Just $ SshOptions targetHost targetPort targetSshArgs)
                     (if leadTarget == currentTarget then C.LeadTarget else C.AllTargets)
             in runHap <$> targets
+
   results <- (runConcurrently . traverse Concurrently)
     ((Right () <$ printer (length haps)) : haps)
   case sequence_ results of

hapistrano.cabal

@@ -54,6 +54,7 @@ library
   build-depends:       aeson              >= 2.0 && < 3.0
                      , ansi-terminal      >= 0.9 && < 0.12
                      , base               >= 4.9 && < 5.0
+                     , directory          >= 1.2.5 && < 1.4
                      , filepath           >= 1.2 && < 1.5
                      , gitrev             >= 1.2 && < 1.4
                      , mtl                >= 2.0 && < 3.0
@@ -61,6 +62,7 @@ library
                      , path               >= 0.5 && < 0.9
                      , path-io            >= 1.2 && < 1.7
                      , process            >= 1.4 && < 1.7
+                     , text               >= 1.2 && < 3
                      , typed-process      >= 0.2 && < 0.3
                      , time               >= 1.5 && < 1.11
                      , transformers       >= 0.4 && < 0.6
@@ -99,6 +101,7 @@ test-suite test
   main-is:             Spec.hs
   other-modules:       System.HapistranoSpec
                      , System.Hapistrano.ConfigSpec
+                     , System.Hapistrano.InitSpec
                      , System.HapistranoPropsSpec
   build-depends:       base               >= 4.9 && < 5.0
                      , aeson

spec/System/Hapistrano/InitSpec.hs

@@ -0,0 +1,17 @@
+module System.Hapistrano.InitSpec (spec) where
+
+import Test.Hspec
+import System.Directory (doesFileExist, getCurrentDirectory, withCurrentDirectory)
+import System.FilePath ((</>))
+import System.Hapistrano (initConfig)
+import System.IO.Temp (withSystemTempDirectory)
+
+spec :: Spec
+spec = do
+  describe "initConfig" $ do
+    it "should create a file when missing" $
+      withSystemTempDirectory "hapistrano-spec-initConfig-missing" $ \tempDir ->
+        withCurrentDirectory tempDir $ do
+          configFilePath <- (</> "hap.yml") <$> getCurrentDirectory
+          initConfig $ return ""
+          doesFileExist configFilePath `shouldReturn` True

src/System/Hapistrano.hs

@@ -9,6 +9,7 @@
 -- A module for creating reliable deploy processes for Haskell applications.
 {-# LANGUAGE CPP                 #-}
 {-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE QuasiQuotes         #-}
 {-# LANGUAGE RecordWildCards     #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TemplateHaskell     #-}
@@ -26,6 +27,7 @@ module System.Hapistrano
   , dropOldReleases
   , playScript
   , playScriptLocally
+  , initConfig
     -- * Path helpers
   , releasePath
   , sharedPath
@@ -42,7 +44,10 @@ import           Control.Monad.Reader       (local)
 import           Data.List                  (dropWhileEnd, genericDrop, sortOn)
 import           Data.Maybe                 (fromMaybe, mapMaybe)
 import           Data.Ord                   (Down (..))
+import qualified Data.Text                  as T
+import qualified Data.Text.IO               as T
 import           Data.Time
+import qualified Data.Yaml                  as Yaml
 import           Numeric.Natural
 import           Path
 import           Path.IO
@@ -55,6 +60,10 @@ import           System.Hapistrano.Config   ( BuildCommand (..)
 import qualified System.Hapistrano.Config   as HC
 import           System.Hapistrano.Core
 import           System.Hapistrano.Types
+import qualified System.Directory           as Directory
+import           System.Exit                (exitFailure)
+import qualified System.FilePath            as FilePath
+import           System.IO                  (stderr)
 import           Text.Read                  (readMaybe)
 
 ----------------------------------------------------------------------------
@@ -262,6 +271,41 @@ playScriptLocally cmds =
         }) $
   forM_ cmds $ flip execWithInheritStdout Nothing
 
+initConfig :: IO String -> IO ()
+initConfig getLine' = do
+  configFilePath <- (FilePath.</> "hap.yml") <$> Directory.getCurrentDirectory
+  alreadyExisting <- Directory.doesFileExist configFilePath
+  when alreadyExisting $ do
+    T.hPutStrLn stderr "'hap.yml' already exists"
+    exitFailure
+  putStrLn "Creating 'hap.yml'"
+  defaults <- defaultInitTemplateConfig
+  let prompt :: Read a => T.Text -> a -> IO a
+      prompt title d = do
+        T.putStrLn $ title <> "?: "
+        x <- getLine'
+        return $
+          if null x
+            then d
+            else read x
+      prompt' :: Read a => T.Text -> (InitTemplateConfig -> T.Text) -> (InitTemplateConfig -> a) -> IO a
+      prompt' title f fd = prompt (title <> " (default: " <> f defaults <> ")") (fd defaults)
+
+  let yesNo :: a -> a -> T.Text -> a
+      yesNo t f x = if x == "y" then t else f
+
+  config <-
+    InitTemplateConfig
+      <$> prompt' "repo" repo repo
+      <*> prompt' "revision" revision revision
+      <*> prompt' "host" host host
+      <*> prompt' "port" (T.pack . show . port) port
+      <*> return (buildScript defaults)
+      <*> fmap (yesNo (restartCommand defaults) Nothing) (prompt' "Include restart command" (const "Y/n") (const "y"))
+
+  Yaml.encodeFile configFilePath config
+  putStrLn $ "Configuration written at " <> configFilePath
+
 ----------------------------------------------------------------------------
 -- Helpers
 

src/System/Hapistrano/Types.hs

@@ -28,6 +28,7 @@ module System.Hapistrano.Types
   , Opts(..)
   , Command(..)
   , MaintenanceOptions(..)
+  , InitTemplateConfig(..)
   -- * Types helpers
   , mkRelease
   , releaseTime
@@ -36,6 +37,7 @@ module System.Hapistrano.Types
   , fromMaybeReleaseFormat
   , fromMaybeKeepReleases
   , toMaybePath
+  , defaultInitTemplateConfig
   ) where
 
 import           Control.Applicative
@@ -44,9 +46,14 @@ import           Control.Monad.Except
 import           Control.Monad.Reader
 import           Data.Aeson
 import           Data.Maybe
+import qualified Data.Text as T
+import qualified Data.Text.Lazy as TL
+import qualified Data.Text.Lazy.Encoding as TL
 import           Data.Time
 import           Numeric.Natural
 import           Path
+import           System.Exit (ExitCode(ExitSuccess))
+import           System.Process.Typed (nullStream, readProcessStdout, setStderr, shell)
 
 -- | Hapistrano monad.
 newtype Hapistrano a =
@@ -192,6 +199,7 @@ data Command
     -- get deleted or not)
   | Rollback Natural -- ^ Rollback to Nth previous release
   | Maintenance MaintenanceOptions
+  | InitConfig -- ^ initialize configuration file
 
 -- | Create a 'Release' indentifier.
 mkRelease :: ReleaseFormat -> UTCTime -> Release
@@ -210,6 +218,48 @@ renderRelease (Release rfmt time) = formatTime defaultTimeLocale fmt time
         ReleaseShort -> releaseFormatShort
         ReleaseLong  -> releaseFormatLong
 
+-- | Initial configurable fields
+data InitTemplateConfig = InitTemplateConfig
+  { repo :: T.Text
+  , revision :: T.Text
+  , host :: T.Text
+  , port :: Word
+  , buildScript :: [T.Text]
+  , restartCommand :: Maybe T.Text
+  }
+
+defaultInitTemplateConfig :: IO InitTemplateConfig
+defaultInitTemplateConfig = do
+  let shellWithDefault d cmd = do
+        (exitCode, stdout) <- readProcessStdout $ setStderr nullStream $ shell cmd
+        return $
+          if exitCode == ExitSuccess
+            then maybe d (T.strip . TL.toStrict) $ listToMaybe $ TL.lines $ TL.decodeUtf8 stdout
+            else d
+  remoteBranch <- shellWithDefault "origin/main" "git rev-parse --abbrev-ref --symbolic-full-name @{u}"
+  let remote = T.takeWhile (/='/') remoteBranch
+  repository <- shellWithDefault "https://github.com/user/repo.git" ("git ls-remote --get-url " <> T.unpack remote)
+  return $
+    InitTemplateConfig
+      { repo = repository
+      , revision = remoteBranch
+      , host = "root@localhost"
+      , port = 22
+      , buildScript = ["echo 'Build steps'"]
+      , restartCommand = Just "echo 'Restart command'"
+      }
+
+instance ToJSON InitTemplateConfig where
+  toJSON x =
+    object
+    [ "repo" .= repo x
+    , "revision" .= revision x
+    , "host" .= host x
+    , "port" .= port x
+    , "buildScript" .= buildScript x
+    , "restartCommand" .= restartCommand x
+    ]
+
 ----------------------------------------------------------------------------
 -- Types helpers