marmalade-upload-0.7: main.hs

-- Copyright (c) 2014 Sebastian Wiesner <lunaryorn@gmail.com>

-- Permission is hereby granted, free of charge, to any person obtaining a copy
-- of this software and associated documentation files (the "Software"), to deal
-- in the Software without restriction, including without limitation the rights
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:

-- The above copyright notice and this permission notice shall be included in
-- all copies or substantial portions of the Software.

-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
-- THE SOFTWARE.

module Main where

import qualified System.Keyring as K
import Web.Marmalade

import qualified System.IO as IO

import Control.Exception (SomeException,bracket,handle)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Data.Version (showVersion)
import Options.Applicative (Parser,execParser,
                            info,fullDesc,progDesc,infoOption,
                            helper,argument,long,short,str,metavar,help,
                            (<$>),(<>),(<*>))
import System.Exit (ExitCode(ExitFailure),exitWith)
import System.IO (hPutStrLn,stderr)
import Text.Printf (printf)

import Paths_marmalade_upload (version)

-- Program information

appName :: String
appName = "marmalade-upload"

appVersion :: String
appVersion = showVersion version

appService :: String
appService = "lunaryorn/" ++ appName

appUserAgent :: String
appUserAgent = appService ++ "/" ++ appVersion

-- CLI tools

-- |@'withEcho' echo action@ runs @action@ with input echo set to @echo@.
--
-- If @echo@ is 'False', this module disable echoing of input on the terminal.
-- Otherwise it enables echoing.
--
-- The input echo is reset to its previous state after @action@.
withEcho :: Bool -> IO a -> IO a
withEcho echo action = bracket (IO.hGetEcho IO.stdin)
                       (IO.hSetEcho IO.stdin)
                       (const $ IO.hSetEcho IO.stdin echo >> action)

-- |@'askPassword' prompt@ asks a password on the terminal, with @prompt@.
--
-- Show @prompt@ on the terminal, disable echo and read a password.  Afterwards
-- reset echoing.
askPassword :: String -> IO String
askPassword prompt = do
  putStr prompt
  IO.hFlush IO.stdout
  password <- withEcho False getLine
  putChar '\n'
  return password

-- |@'askMarmaladePassword' username@ asks for the Marmalade password of the
-- given @username@ on the terminal.
askMarmaladePassword :: String -> Marmalade String
askMarmaladePassword username =
  liftIO (askPassword (printf "Marmalade password for %s (never stored): " username))

-- |@'getAuth' username@ gets authentication information for the given
-- @username@.
--
-- Return the authorization information, and a boolean indicating whether
  -- authorization shall be stored.
--
-- If the authorization token of @username@ is stored in the keyring, use it,
-- otherwise fall back to password authentication.
getAuth :: String -> IO (Bool, Auth)
getAuth username = handle ignoreMissingBackend $ do
  result <- K.getPassword (K.Service appService) (K.Username username)
  return $ case result of
    Just (K.Password token) -> (False, TokenAuth (Username username) (Token token))
    Nothing -> (True, BasicAuth (Username username) (askMarmaladePassword username))
  where
    ignoreMissingBackend :: K.KeyringMissingBackendError -> IO (Bool, Auth)
    ignoreMissingBackend _ = do
      hPutStrLn stderr "Warning: No keyring backend found, token will not be saved"
      return (False, BasicAuth (Username username) (askMarmaladePassword username))

-- Arguments handling

exitFailure :: String -> IO ()
exitFailure message = IO.hPutStrLn IO.stderr message >> exitWith (ExitFailure 1)

exitException :: SomeException -> IO ()
exitException = exitFailure.show

data Arguments =  Arguments { argUsername :: String
                            , argPackageFile :: String }

parser :: Parser Arguments
parser =
  versionInfo <*> arguments
  where
    versionInfo = infoOption versionMessage (long "version" <>
                                             short 'V' <>
                                             help "Show version number and exit")
    arguments = Arguments <$>
                argument str (metavar "USERNAME" <> help "Marmalade username") <*>
                argument str (metavar "PACKAGE" <> help "Package file")
    versionMessage = unlines [(appName ++ " " ++ appVersion)
                             ,"Copyright (C) 2014 Sebastian Wiesner."
                             ,"You may redistribute marmalade-upload"
                             ,"under the terms of the MIT/X11 license."]

main :: IO ()
main = do
  args <- execParser (info (helper <*> parser)
                      (fullDesc <> progDesc "Upload a package to Marmalade"))
  (shallSaveToken, auth) <- getAuth (argUsername args)
  handle exitException $ runMarmalade appUserAgent auth $ do
    (Username username, Token token) <- login
    -- Save the token now
    when shallSaveToken $
      liftIO (K.setPassword (K.Service appService) (K.Username username) (K.Password token))
    upload <- uploadPackage (argPackageFile args)
    liftIO (putStrLn (uploadMessage upload))