Test megaparsec

hapistrano.cabal

@@ -58,6 +58,7 @@ library
                      , filepath           >= 1.2 && < 1.5
                      , gitrev             >= 1.2 && < 1.4
                      , mtl                >= 2.0 && < 3.0
+                     , megaparsec
                      , stm                >= 2.0 && < 2.6
                      , path               >= 0.5 && < 1.0
                      , path-io            >= 1.2 && < 1.9

src/System/Hapistrano.hs

@@ -44,8 +44,6 @@ 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
@@ -61,8 +59,11 @@ import           System.Hapistrano.Config   (BuildCommand (..), CopyThing (..),
                                              deployStateFilename)
 import           System.Hapistrano.Core
 import           System.Hapistrano.Types
-import           System.IO                  (stderr)
+import           System.IO                  (stderr, hPutStrLn)
 import           Text.Read                  (readMaybe)
+import Text.Megaparsec (Parsec, many)
+import Data.Void (Void)
+import qualified Text.Megaparsec as M
 
 ----------------------------------------------------------------------------
 
@@ -276,36 +277,58 @@ initConfig getLine' = do
   configFilePath <- (FilePath.</> "hap.yml") <$> Directory.getCurrentDirectory
   alreadyExisting <- Directory.doesFileExist configFilePath
   when alreadyExisting $ do
-    T.hPutStrLn stderr "'hap.yml' already exists"
+    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"))
+  config <- generateUserConfig defaultInitTemplateConfig
 
   Yaml.encodeFile configFilePath config
   putStrLn $ "Configuration written at " <> configFilePath
 
+  where
+
+    promptString :: String -> String -> IO String
+    promptString parameterName def  = do
+      userInput <- prompt' (parameterName <> " (default: " <> show def <> ")")
+      let parsed = M.parseMaybe stringParser userInput
+      pure $ fromMaybe def parsed
+
+    prompt' :: String -> IO String
+    prompt' title = do
+        hPutStrLn stderr title
+        getLine'
+
+
+    generateUserConfig :: IO InitTemplateConfig -> IO InitTemplateConfig
+    generateUserConfig initCfg = do
+      InitTemplateConfig{..} <- initCfg
+      InitTemplateConfig
+        <$> promptString "repo" repo
+        <*> promptString "revision" revision
+        <*> promptString "host" host
+        <*> pure port
+        <*> pure buildScript 
+        <*> pure restartCommand
+
+type MParser = Parsec Void String
+
+
+stringParser :: MParser String
+stringParser = many (M.satisfy (not . barOrNewline))
+
+barOrNewline :: Char -> Bool
+barOrNewline c = c == '|' || c == '\n'
+
+
+-- numberParser :: MParser Word
+-- numberParser = read <$>
+--   integerParser
+--   where
+--     integerParser :: MParser String
+--     integerParser = M.try (some M.digitChar)
+
 ----------------------------------------------------------------------------
 -- Helpers
 

src/System/Hapistrano/Types.hs

@@ -220,35 +220,36 @@ renderRelease (Release rfmt time) = formatTime defaultTimeLocale fmt time
 
 -- | Initial configurable fields
 data InitTemplateConfig = InitTemplateConfig
-  { repo :: T.Text
-  , revision :: T.Text
-  , host :: T.Text
+  { repo :: String
+  , revision :: String
+  , host :: String
   , port :: Word
-  , buildScript :: [T.Text]
-  , restartCommand :: Maybe T.Text
+  , buildScript :: [String]
+  , restartCommand :: Maybe String
   }
 
 -- | Default initial template for creating hapistrano file.
 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
+      { repo = T.unpack repository
+      , revision = T.unpack remoteBranch
       , host = "root@localhost"
       , port = 22
       , buildScript = ["echo 'Build steps'"]
       , restartCommand = Just "echo 'Restart command'"
       }
+  where
+    shellWithDefault def cmd = do
+      (exitCode, stdout) <- readProcessStdout $ setStderr nullStream $ shell cmd
+      return $ case exitCode of
+        ExitSuccess ->
+          maybe def (T.strip . TL.toStrict) $ listToMaybe $ TL.lines $ TL.decodeUtf8 stdout
+        _ -> def
 
 instance ToJSON InitTemplateConfig where
   toJSON x =