wip

src/System/Hapistrano.hs

@@ -280,16 +280,18 @@ initConfig getLine' = do
     exitFailure
   putStrLn "Creating 'hap.yml'"
   defaults <- defaultInitTemplateConfig
-  let prompt :: Read a => T.Text -> a -> IO a
+  let prompt :: forall a. 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)
+          case (null x, readMaybe x :: Maybe a) of
+            (True, _) -> d
+            (_, Just y) -> y
+            (_, Nothing) ->
+              error $ "'" <> x <> "'" <> " was not expected for '" <> T.unpack title <> "'"
+      prompt' :: Read a => T.Text -> (InitTemplateConfig -> Foo) -> (InitTemplateConfig -> a) -> IO a
+      prompt' title f fd = prompt (title <> " (default: " <> unFoo (f defaults) <> ")") (fd defaults)
 
   let yesNo :: a -> a -> T.Text -> a
       yesNo t f x = if x == "y" then t else f
@@ -299,9 +301,9 @@ initConfig getLine' = do
       <$> prompt' "repo" repo repo
       <*> prompt' "revision" revision revision
       <*> prompt' "host" host host
-      <*> prompt' "port" (T.pack . show . port) port
+      <*> prompt' "port" (Foo . T.pack . show . port) port
       <*> return (buildScript defaults)
-      <*> fmap (yesNo (restartCommand defaults) Nothing) (prompt' "Include restart command" (const "Y/n") (const "y"))
+      <*> fmap (yesNo (restartCommand defaults) Nothing) (prompt' "Include restart command" (const (Foo "Y/n")) (const "y"))
 
   Yaml.encodeFile configFilePath config
   putStrLn $ "Configuration written at " <> configFilePath

src/System/Hapistrano/Types.hs

@@ -10,6 +10,7 @@
 {-# LANGUAGE DerivingVia       #-}
 {-# LANGUAGE LambdaCase        #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 
 module System.Hapistrano.Types
   ( Hapistrano(..)
@@ -30,6 +31,7 @@ module System.Hapistrano.Types
   , MaintenanceOptions(..)
   , InitTemplateConfig(..)
   -- * Types helpers
+  , Foo(..)
   , mkRelease
   , releaseTime
   , renderRelease
@@ -218,11 +220,25 @@ renderRelease (Release rfmt time) = formatTime defaultTimeLocale fmt time
         ReleaseShort -> releaseFormatShort
         ReleaseLong  -> releaseFormatLong
 
+newtype Foo = Foo { unFoo :: T.Text}
+  deriving (Show, ToJSON)
+
+instance Read Foo where
+  readsPrec _ input = f <$> lex input
+    where
+      f (s, s2) = (Foo $ T.pack s, s2)
+
+-- readFoo :: ReadS Foo
+-- readFoo = flip readPrec_to_S 0 $ parens $ do
+--   str <- lex
+--   let txt = T.pack str
+--   return (Foo txt)
+
 -- | Initial configurable fields
 data InitTemplateConfig = InitTemplateConfig
-  { repo :: T.Text
-  , revision :: T.Text
-  , host :: T.Text
+  { repo :: Foo
+  , revision :: Foo
+  , host :: Foo
   , port :: Word
   , buildScript :: [T.Text]
   , restartCommand :: Maybe T.Text
@@ -242,9 +258,9 @@ defaultInitTemplateConfig = do
   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"
+      { repo = Foo repository
+      , revision = Foo remoteBranch
+      , host = Foo "root@localhost"
       , port = 22
       , buildScript = ["echo 'Build steps'"]
       , restartCommand = Just "echo 'Restart command'"