diff --git a/src/System/Hapistrano.hs b/src/System/Hapistrano.hs index 8fc6ff70..b748a281 100644 --- a/src/System/Hapistrano.hs +++ b/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 diff --git a/src/System/Hapistrano/Types.hs b/src/System/Hapistrano/Types.hs index 6a4cb7a9..a5060d98 100644 --- a/src/System/Hapistrano/Types.hs +++ b/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'"