-- 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)