-- Copyright (c) 2014 Sebastian Wiesner <swiesner@lunaryorn.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.
{-# LANGUAGE OverloadedStrings #-}
module Main (main) where
import Control.Exception (SomeException,IOException,bracket,handle)
import Control.Monad (liftM,when,mzero)
import Control.Monad.IO.Class (liftIO)
import Data.Aeson (FromJSON(parseJSON),ToJSON(toJSON),
Value(Object),(.:),object,(.=),
decodeStrict',encode)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.Default (Default(def))
import Data.Maybe (fromMaybe)
import Data.Monoid ((<>),mempty)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import qualified Data.Text.Lazy.IO as L
import Data.Version (showVersion)
import Options.Applicative (Parser,execParser,
info,fullDesc,progDesc,
infoOption,option,
helper,argument,long,short,str,auto,
metavar,help,value,showDefault,
(<$>),(<*>))
import Paths_marmalade_upload (version)
import System.Directory (getHomeDirectory)
import System.Exit (ExitCode(ExitFailure),exitWith)
import System.FilePath ((</>))
import qualified System.IO as IO
import qualified System.Keyring as K
import Text.Printf (printf)
import Web.Marmalade
-- Program information
appName :: Text
appName = "marmalade-upload"
appVersion :: Text
appVersion = T.pack (showVersion version)
appService :: Text
appService = T.concat ["lunaryorn/", appName]
appUserAgent :: Text
appUserAgent = T.concat [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 :: Text -> IO Text
askPassword prompt = do
T.putStr prompt
IO.hFlush IO.stdout
password <- withEcho False T.getLine
putChar '\n'
return password
askMarmaladeUsername :: IO Text
askMarmaladeUsername = do
T.putStr "Marmalade username: "
IO.hFlush IO.stdout
T.getLine
-- |@'askMarmaladePassword' username@ asks for the Marmalade password of the
-- given @username@ on the terminal.
askMarmaladePassword :: Text -> Marmalade Text
askMarmaladePassword username = liftIO (askPassword prompt)
where prompt = T.concat [ "Marmalade password for "
, username
, " (never stored): " ]
-- |@'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 :: Text -> IO (Bool, Auth)
getAuth username = handle ignoreMissingBackend $ do
result <- K.getPassword (K.Service (T.unpack appService))
(K.Username (T.unpack username))
return $ case result of
Just (K.Password token) -> (False, TokenAuth (Username (username))
(Token (T.pack token)))
Nothing -> (True, BasicAuth (Username username)
(askMarmaladePassword username))
where
ignoreMissingBackend :: K.KeyringMissingBackendError -> IO (Bool, Auth)
ignoreMissingBackend _ = do
IO.hPutStrLn IO.stderr
"Warning: No keyring backend found, token will not be saved"
return (False, BasicAuth (Username username)
(askMarmaladePassword username))
-- |@'setAuth' username token@ stores the authentication token for the given
-- @username@.
--
-- Stores @token@ for @username@ in the system keyring if possible.
storeAuth :: Text -> Text -> IO ()
storeAuth username token = K.setPassword (K.Service (T.unpack appService))
(K.Username (T.unpack username))
(K.Password (T.unpack token))
-- Configuration handling
data Configuration = Configuration { configUsername :: Maybe Text }
deriving (Read,Show,Eq)
instance Default Configuration where
def = Configuration Nothing
instance FromJSON Configuration where
parseJSON (Object o) = Configuration <$> o .: "username"
parseJSON _ = mzero
instance ToJSON Configuration where
toJSON config = object [ "username" .= configUsername config ]
loadConfig :: IO Configuration
loadConfig = do
fileName <- configFile
handle returnDefault $ IO.withBinaryFile fileName IO.ReadMode $ \source ->
liftM (fromMaybe def.decodeStrict') (BS.hGetContents source)
where returnDefault :: IOException -> IO Configuration
returnDefault _ = return def
saveConfig :: Configuration -> IO ()
saveConfig config = do
fileName <- configFile
IO.withBinaryFile fileName IO.WriteMode (`LBS.hPut` encode config)
configFile :: IO FilePath
configFile = do
home <- getHomeDirectory
return (home </> ".emacs.d" </> "marmalade-upload.json")
-- 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 :: Text
, argPackageFile :: FilePath }
parser :: Configuration -> Parser Arguments
parser config =
versionInfo <*> arguments
where
versionInfo = infoOption versionMessage (long "version" <>
short 'V' <>
help "Show version number and exit")
defUsername = fromMaybe "" (configUsername config)
arguments = Arguments <$>
option auto (long "username" <>
short 'u' <>
value defUsername <>
if defUsername == "" then mempty else showDefault <>
help "Marmalade username" <>
metavar "USERNAME") <*>
argument str (metavar "PACKAGE" <> help "Package file")
versionMessage = unlines [(T.unpack appName) ++ " " ++ (T.unpack appVersion)
,"Copyright (C) 2014 Sebastian Wiesner."
,"You may redistribute marmalade-upload"
,"under the terms of the MIT/X11 license."]
main :: IO ()
main = do
config <- loadConfig
args <- execParser (info (helper <*> parser config)
(fullDesc <> progDesc "Upload a package to Marmalade"))
(shallSaveToken, auth) <- getUsername args >>= getAuth
handle exitException $ runMarmalade appUserAgent auth $ do
(Username username, Token token) <- login
let newConfig = Configuration (Just username)
liftIO $ when (config /= newConfig) $ do
saveConfig newConfig
configFile >>= printf "Saved username to %s\n"
-- Save the token now
when shallSaveToken $
liftIO (storeAuth username token)
upload <- uploadPackage (argPackageFile args)
liftIO (L.putStrLn (uploadMessage upload))
where getUsername args | T.null (argUsername args) = askMarmaladeUsername
getUsername args = return (argUsername args)