packages feed

marmalade-upload 0.4 → 0.5

raw patch · 9 files changed

+127/−556 lines, 9 filesdep +keyringdep −udbus

Dependencies added: keyring

Dependencies removed: udbus

Files

+ CHANGES.md view
@@ -0,0 +1,28 @@+0.5 (Apr 2, 2014)+=================++- Use the keyring module from Hackage++0.4 (Apr 1, 2014)+=================++- Replace DBus binding due to licensing issues+- Check for password presence before reading from KWallet++0.3 (Mar 31, 2014)+==================++- Use Security framework to access Keychain by native code, instead of calling+  the `security` tool+- Use DBus API to access KWallet++0.2 (Mar 29, 2014)+==================++- Fix minor issues+- Refactoring++0.1 (Mar 28, 2014)+==================++Initial release
+ README.md view
@@ -0,0 +1,66 @@+marmalade-upload+================++[![hackage][badge-hackage]][hackage] [![license][badge-license]][license]++Haskell tool to upload packages to the Emacs package archive [Marmalade][],+published in the hopes++- that you find it useful,+- and that Marmalade dies rather sooner than later nonetheless.++I'm sorry for the inconvenient language, but if I'm to write a boring tool for a+stupid bug, then at least in a cool language.++And while we're at it, I'd like to say a big thank you to [MELPA][] for building+[stable packages][] now, and bringing Marmalade a big step closer to its+passing.  Well done, folks!++Installation+------------++```console+$ cabal install marmalade-upload+```++Don't forget to add `~/.cabal/bin` to `$PATH`.++Usage+-----++```console+$ marmalade-upload USERNAME PACKAGE+```++Your password will be stored in the keychain of supported systems.  Currently+the keychains of KDE and OS X are supported.++License+-------++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.++[badge-hackage]: https://img.shields.io/hackage/v/marmalade-upload.svg?dummy+[hackage]: https://hackage.haskell.org/package/marmalade-upload+[badge-license]: https://img.shields.io/badge/license-MIT-green.svg?dummy+[license]: https://github.com/lunaryorn/marmalade-upload/blob/master/LICENSE+[Marmalade]: http://marmalade-repo.org+[MELPA]: http://melpa.milkbox.net+[stable packages]: https://github.com/milkypostman/melpa#stable-packages
− System/Keyring.hs 
@@ -1,56 +0,0 @@--- 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.--{-# LANGUAGE CPP #-}---- |Access to the keyring of the user.------ This module provides access to the keyring of the current system.  Currently--- this module supports the following keyrings:------ * Keychain on OS X------ * KWallet on KDE------ The module automatically picks the best appropriate keyring.-module System.Keyring-       (-         -- * Data types-         Service(..),Username(..),Password(..)-         -- * Password storage-       , getPassword,setPassword)-       where--import System.Keyring.Types--#ifdef DARWIN-import qualified System.Keyring.Darwin as Backend-#else-import qualified System.Keyring.Unix as Backend-#endif---- |@'getPassword' service username@ gets the password for the given @username@--- and @service@ from the keyring.-getPassword :: Service -> Username -> IO (Maybe Password)-getPassword = Backend.getPassword---- |@'setPassword' service username password@ adds @password@ to the keyring.-setPassword :: Service -> Username -> Password -> IO ()-setPassword = Backend.setPassword
− System/Keyring/Darwin.hsc 
@@ -1,201 +0,0 @@--- 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.--{-# OPTIONS_HADDOCK hide #-}--{-# LANGUAGE ForeignFunctionInterface #-}-{-# LANGUAGE DeriveDataTypeable #-}---- |Access to the OS X Key chain-module System.Keyring.Darwin (setPassword,getPassword) where--import System.Keyring.Types--import qualified Data.ByteString.UTF8 as UTF8--import Control.Exception (Exception,bracket,throwIO)-import Control.Monad (liftM,when,void)-import Data.ByteString-import Data.Int (Int32, Int64)-import Data.Typeable (Typeable)-import Data.Word (Word32)-import Foreign.C-import Foreign.Ptr-import Foreign.Storable-import Foreign.Marshal.Alloc (alloca,allocaBytes)-import Text.Printf (printf)---- C declarations--#include <Security/Security.h>--type UInt32 = #type UInt32-type CFTypeRef = Ptr ()-type CFStringRef = Ptr ()-type CFStringEncoding = #type CFStringEncoding-type CFIndex = #type CFIndex-type SecKeychainItemRef = Ptr ()-type SecKeychainRef = Ptr ()-type OSStatus = #type OSStatus--#{enum OSStatus, ,-  errSecSuccess = errSecSuccess,-  errSecItemNotFound = errSecItemNotFound,-  errSecAuthFailed = errSecAuthFailed}--kCFStringEncodingUTF8 :: CFStringEncoding-kCFStringEncodingUTF8 = #const kCFStringEncodingUTF8--foreign import ccall unsafe "CoreFoundation/CoreFoundation.h CFRelease"-  c_CFRelease :: CFTypeRef -> IO ()--foreign import ccall unsafe "CoreFoundation/CoreFoundation.h CFStringGetMaximumSizeForEncoding"-  c_CFStringGetMaximumSizeForEncoding :: CFIndex -> CFStringEncoding -> CFIndex--foreign import ccall unsafe "CoreFoundation/CoreFoundation.h CFStringGetLength"-  c_CFStringGetLength :: CFStringRef -> CFIndex--foreign import ccall unsafe "CoreFoundation/CoreFoundation.h CFStringGetCString"-  c_CFStringGetCString :: CFStringRef -> CString -> CFIndex -> CFStringEncoding-                       -> IO Bool--foreign import ccall unsafe "Security/Security.h SecCopyErrorMessageString"-  c_SecCopyErrorMessageString :: OSStatus -> Ptr () -> IO CFStringRef--foreign import ccall unsafe "Security/Security.h SecKeychainItemFreeContent"-  c_SecKeychainItemFreeContent :: Ptr () -> CString -> IO OSStatus--foreign import ccall unsafe "Security/Security.h SecKeychainFindGenericPassword"-  c_SecKeychainFindGenericPassword :: CFTypeRef-                                   -> UInt32 -> CString-                                   -> UInt32 -> CString-                                   -> Ptr UInt32 -> Ptr CString-                                   -> Ptr SecKeychainItemRef-                                   -> IO OSStatus--foreign import ccall unsafe "Security/Security.h SecKeychainAddGenericPassword"-  c_SecKeychainAddGenericPassword :: SecKeychainRef-                                  -> UInt32 -> CString-                                  -> UInt32 -> CString-                                  -> UInt32 -> CString-                                  -> Ptr SecKeychainItemRef-                                  -> IO OSStatus---- C wrappers--data KeychainException = KeychainError (Maybe String) OSStatus-                          deriving Typeable--instance Show KeychainException where-  show (KeychainError Nothing status) =-    printf "Keychain access failed: status %s" status-  show (KeychainError (Just msg) status) =-    printf "Keychain access failed: %s (status %d)" msg status--instance Exception KeychainException--throwKeychainError :: OSStatus -> IO a-throwKeychainError status = do-  messageResult <- secKeychainCopyErrorMessageString status-  let message = (fmap UTF8.toString messageResult)-  throwIO (KeychainError message status)--secKeychainCopyErrorMessageString :: OSStatus -> IO (Maybe ByteString)-secKeychainCopyErrorMessageString status =-  bracket-  (c_SecCopyErrorMessageString status nullPtr)-  (\s -> when (s /= nullPtr) (c_CFRelease s))-  (convertCFString)-  where-    convertCFString s | s == nullPtr = return Nothing-    convertCFString s = do-      let encoding = kCFStringEncodingUTF8-      let bufferSize = c_CFStringGetMaximumSizeForEncoding (c_CFStringGetLength s) encoding-      allocaBytes (fromIntegral bufferSize) (getCString s encoding bufferSize)-    getCString s encoding bufferSize buffer = do-      result <- c_CFStringGetCString s buffer bufferSize encoding-      if result-        then liftM Just (packCString buffer)-        else return Nothing--secKeychainFindGenericPassword :: ByteString -> ByteString -> IO (Maybe ByteString)-secKeychainFindGenericPassword service username = do-  useAsCStringLen service withService-  where-    withService c_service = useAsCStringLen username (withServiceAndUser c_service)-    withServiceAndUser c_service c_user = alloca (withPwLen c_service c_user)-    withPwLen c_service c_user pwlen = alloca (withAll c_service c_user pwlen)-    withAll :: CStringLen -> CStringLen -> Ptr UInt32 -> Ptr CString -> IO (Maybe ByteString)-    withAll (c_service_b, c_service_l) (c_user_b, c_user_l) password_l_buf password_buf =-      do-        result <- c_SecKeychainFindGenericPassword-                   nullPtr      -- Default keychain-                   (fromIntegral c_service_l) c_service_b-                   (fromIntegral c_user_l) c_user_b-                   password_l_buf password_buf-                   nullPtr      -- Ignore the item reference-        (bracket (peek password_buf)-         (\pw -> when (pw /= nullPtr)-                 (void $ c_SecKeychainItemFreeContent nullPtr pw))-         (handleResult result password_l_buf))-    handleResult :: OSStatus -> Ptr UInt32 -> CString -> IO (Maybe ByteString)-    handleResult result password_l_buf password_b = case result of-      _ | result == errSecSuccess -> do-        password_l <- peek password_l_buf-        liftM Just (packCStringLen (password_b, fromIntegral password_l))-      _ | result == errSecItemNotFound ||-          result == errSecAuthFailed -> return Nothing-      _ -> throwKeychainError result--secKeychainAddGenericPassword :: ByteString -> ByteString -> ByteString -> IO ()-secKeychainAddGenericPassword service username password = do-  useAsCStringLen service withService-  where-    withService c_service = useAsCStringLen username (withServiceAndUser c_service)-    withServiceAndUser c_service c_username =-      useAsCStringLen password (withAll c_service c_username)-    withAll (c_service_b, c_service_l) (c_user_b, c_user_l) (c_pw_b, c_pw_l) = do-      result <- c_SecKeychainAddGenericPassword-                nullPtr         -- Default keychain-                (fromIntegral c_service_l) c_service_b-                (fromIntegral c_user_l) c_user_b-                (fromIntegral c_pw_l) c_pw_b-                nullPtr         -- Ignore the item-      if result == errSecSuccess then return () else throwKeychainError result---- Public API---- |@'setPassword' service username password@ stores a @password@ for a given--- @username@ and @service@.-setPassword :: Service -> Username -> Password -> IO ()-setPassword (Service service) (Username username) (Password password) =-  secKeychainAddGenericPassword service_bytes username_bytes password_bytes-  where service_bytes = UTF8.fromString service-        username_bytes = UTF8.fromString username-        password_bytes = UTF8.fromString password---- |@'getPassword' service username@ gets password for a given @username@ and--- @service@.  If the password was not found, return 'Nothing' instead.-getPassword :: Service -> Username -> IO (Maybe Password)-getPassword (Service service) (Username username) = do-  password_bytes <- secKeychainFindGenericPassword service_bytes username_bytes-  return (fmap Password (fmap (UTF8.toString) password_bytes))-  where service_bytes = UTF8.fromString service-        username_bytes = UTF8.fromString username
− System/Keyring/Types.hs 
@@ -1,36 +0,0 @@--- 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.---- |Basic types for keyring access.-module System.Keyring.Types-       (Service(..), Username(..), Password(..))-       where---- |A service which uses the keyring------ The service identifies the application or service for which a secret is--- stored.-newtype Service = Service String---- |A username-newtype Username = Username String---- |A password-newtype Password = Password String
− System/Keyring/Unix.hs 
@@ -1,53 +0,0 @@--- 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.--{-# OPTIONS_HADDOCK hide #-}---- |Access to keyrings of Unix systems.-module System.Keyring.Unix (getPassword,setPassword) where--import qualified System.Keyring.Unix.KDE as KDE--import System.Keyring.Types--import System.Environment (getEnv)---- |The keyring provider to use.-provider :: IO (Service -> Username -> IO (Maybe Password)-               ,Service -> Username -> Password -> IO ())-provider = do-  desktop <- getEnv "XDG_CURRENT_DESKTOP"-  return $ case desktop of-    "KDE" -> (KDE.getPassword, KDE.setPassword)-    _ -> dummy-  where dummy = (\_ _ -> return Nothing, \_ _ _ -> return ())---- |@'getPassword' service username@ gets a password from the current keyring.-getPassword :: Service -> Username -> IO (Maybe Password)-getPassword service username = do-  (get, _) <- provider-  get service username---- |@'setPassword' service username password@ adds @password@ to the current--- keyring.-setPassword :: Service -> Username -> Password -> IO ()-setPassword service username password = do-  (_, set) <- provider-  set service username password
− System/Keyring/Unix/KDE.hs 
@@ -1,186 +0,0 @@--- 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.--{-# LANGUAGE DeriveDataTypeable #-}--{-# OPTIONS_HADDOCK hide #-}---- |Access to the KDE keychain-module System.Keyring.Unix.KDE (getPassword,setPassword) where--import System.Keyring.Types--import Control.Exception (Exception,throwIO,bracket,catch)-import Control.Monad (void,unless)-import Data.Int (Int32)-import Data.Typeable (Typeable)-import Network.DBus (DBusConnection,BusName(..)-                    ,DBusCall(..),ObjectPath(..),Interface(..),Member(..)-                    ,DBusTypeable(..),Type(..),DBusValue(..)-                    ,DBusError(..),ErrorName(..)-                    ,busGetSession,establish,authenticateWithRealUID,call-                    ,returnBody,packedStringToString)-import Text.Printf (printf)--data KWalletError = KWalletDBusError ErrorName (Maybe String)-                  | KWalletOperationError String-                  | KWalletInvalidReturn [Type] [Type]-                  deriving Typeable--instance Show KWalletError where-  show (KWalletDBusError (ErrorName name) Nothing) =-    "KWallet error: DBus error " ++ name-  show (KWalletDBusError (ErrorName name) (Just message)) =-    printf "KWallet error: DBus error %s: %s" name message-  show (KWalletOperationError message) =-    "KWallet error: Operation failed: " ++ message-  show (KWalletInvalidReturn expected actual) =-    printf "KWallet error: invalid return: expected %s, got %s" (show expected) (show actual)--instance Exception KWalletError--throwInvalidReturn :: [Type] -> [DBusValue] -> IO a-throwInvalidReturn expected actual =-  throwIO (KWalletInvalidReturn expected (map toSignature actual))--getKWalletKey :: AppID -> Username -> String-getKWalletKey (AppID appID) (Username username) = username ++ "@" ++ appID--withSessionBus :: (DBusConnection -> IO a) -> IO a-withSessionBus actions = connectSession >>= actions-  where connectSession = establish busGetSession authenticateWithRealUID--newtype AppID = AppID String--instance DBusTypeable AppID where-  toSignature (AppID appID) = toSignature appID-  toDBusValue (AppID appID) = toDBusValue appID-  fromDBusValue value = fmap AppID (fromDBusValue value)--newtype Wallet = Wallet Int32--instance DBusTypeable Wallet where-  toSignature (Wallet appID) = toSignature appID-  toDBusValue (Wallet appID) = toDBusValue appID-  fromDBusValue value = fmap Wallet (fromDBusValue value)--callKWalletD :: DBusConnection -> String -> [DBusValue] -> IO [DBusValue]-callKWalletD connection methodName args = do-  result <- catch (call connection busName message) (throwIO.wrapDBusError)-  return (returnBody result)-  where busName = BusName {unBusName = "org.kde.kwalletd"}-        path = ObjectPath { unObjectPath = "/modules/kwalletd" }-        interface = Interface { unInterface = "org.kde.KWallet" }-        member = Member { unMember = methodName }-        message = DBusCall { callPath = path-                           , callInterface = Just interface-                           , callMember = member-                           , callBody = args}-        wrapDBusError DBusError{errorName=name,errorBody=body} =-          case body of-            [DBusString errMsg] ->-              KWalletDBusError name (Just (packedStringToString errMsg))-            _ -> KWalletDBusError name Nothing--openWallet :: DBusConnection -> String -> AppID -> IO Wallet-openWallet connection walletName appID = do-  reply <- callKWalletD connection "open" [toDBusValue walletName-                                          ,DBusInt64 0-                                          ,toDBusValue appID]-  case reply of-    [DBusInt32 handle] -> return (Wallet handle)-    _ -> throwInvalidReturn [SigInt32] reply--closeWallet :: DBusConnection -> AppID -> Wallet -> IO ()-closeWallet connection appID wallet =-  void (callKWalletD connection "close" [toDBusValue wallet-                                        ,toDBusValue False-                                        ,toDBusValue appID])--withNetworkWallet :: AppID -> (DBusConnection -> Wallet -> IO a) -> IO a-withNetworkWallet appID action = withSessionBus openNetworkWallet-  where-    openNetworkWallet connection = do-      reply <- callKWalletD connection "networkWallet" []-      case reply of-        [DBusString name] -> runAction connection (packedStringToString name)-        _ -> throwInvalidReturn [SigString] reply-    runAction connection name = bracket-      (openWallet connection name appID)-      (closeWallet connection appID)-      (action connection)--getPassword :: Service -> Username -> IO (Maybe Password)-getPassword (Service service) username = withNetworkWallet appID fetchPassword-  where-    appID = AppID service-    key = getKWalletKey appID username-    fetchPassword connection wallet = do-      hasPassword <- hasEntry connection wallet-      if hasPassword then readPassword connection wallet else return Nothing-    hasEntry connection wallet = do-      reply <- callKWalletD connection "hasEntry" [toDBusValue wallet-                                                  ,toDBusValue "Passwords"-                                                  ,toDBusValue key-                                                  ,toDBusValue appID]-      case reply of-        [DBusBoolean b] -> return b-        _ -> throwInvalidReturn [SigBool] reply-    readPassword connection wallet = do-      reply <- callKWalletD connection "readPassword" [toDBusValue wallet-                                                      ,toDBusValue "Passwords"-                                                      ,toDBusValue key-                                                      ,toDBusValue appID]-      case reply of-        [DBusString s] -> return (Just (Password (packedStringToString s)))-        _ -> throwInvalidReturn [SigString] reply--setPassword :: Service -> Username -> Password -> IO ()-setPassword (Service service) username (Password password) =-  withNetworkWallet appID storePassword-  where-    appID = AppID service-    key = getKWalletKey appID username-    storePassword connection wallet = do-      folderExists <- hasFolder connection wallet-      unless folderExists (createFolder connection wallet)-      writePassword connection wallet-    hasFolder connection wallet = do-      reply <- callKWalletD connection "hasFolder" [toDBusValue wallet-                                                   ,toDBusValue "Passwords"-                                                   ,toDBusValue appID]-      case reply of-        [DBusBoolean b] -> return b-        _ -> throwInvalidReturn [SigBool] reply-    createFolder connection wallet = do-      reply <- callKWalletD connection "createFolder" [toDBusValue wallet-                                                      ,toDBusValue "Passwords"-                                                      ,toDBusValue appID]-      case reply of-        [DBusBoolean b] -> do-          unless b (throwIO (KWalletOperationError "Could not create Passwords folder"))-          return ()-        _ -> throwInvalidReturn [SigBool] reply-    writePassword connection wallet =-      void $ callKWalletD connection "writePassword" [toDBusValue wallet-                                                     ,toDBusValue "Passwords"-                                                     ,toDBusValue key-                                                     ,toDBusValue password-                                                     ,toDBusValue appID]
main.hs view
@@ -35,6 +35,7 @@ import Data.Version (showVersion) import System.Console.CmdArgs (Data,Typeable,(&=),cmdArgs) import System.Exit (ExitCode(ExitFailure),exitWith)+import System.IO (hPutStrLn,stderr) import Text.Printf (printf)  import Paths_marmalade_upload (version)@@ -87,14 +88,22 @@ -- |@'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 Auth-getAuth username = do+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) -> (TokenAuth (Username username) (Token token))-    Nothing -> (BasicAuth (Username username) (askMarmaladePassword username))+    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 @@ -124,15 +133,11 @@ main :: IO () main = do   args <- arguments >>= cmdArgs-  auth <- getAuth (argUsername args)-  -- If we got basic authentication, we must save the token after login-  let mustSaveToken = case auth of-        TokenAuth _ _ -> False-        _             -> True+  (shallSaveToken, auth) <- getAuth (argUsername args)   handle exitException $ runMarmalade appUserAgent auth $ do     ((Username username), (Token token)) <- login     -- Save the token now-    when mustSaveToken $+    when shallSaveToken $       liftIO (K.setPassword (K.Service appService) (K.Username username) (K.Password token))     upload <- uploadPackage (argPackageFile args)     liftIO (putStrLn (uploadMessage upload))
marmalade-upload.cabal view
@@ -1,10 +1,14 @@ name:                marmalade-upload-version:             0.4+version:             0.5 synopsis:            Upload packages to Marmalade-description:         Upload Emacs packages to the Marmalade ELPA archive+description:+  Upload Emacs packages to the <http://marmalade-repo.org/ Marmalade> ELPA+  archive. homepage:            https://github.com/lunaryorn/marmalade-upload license:             MIT license-file:        LICENSE+extra-source-files:  README.md,+                     CHANGES.md author:              Sebastian Wiesner maintainer:          lunaryorn@gmail.com copyright:           (C) 2014 Sebastian Wiesner@@ -13,11 +17,19 @@ build-type:          Simple cabal-version:       >=1.10 +source-repository head+  type:              git+  location:          https://github.com/lunaryorn/marmalade-upload.git+  branch:            master++source-repository this+  type:              git+  location:          https://github.com/lunaryorn/marmalade-upload.git+  tag:               0.5+ executable marmalade-upload   main-is:             main.hs   other-modules:       Web.Marmalade-                       System.Keyring-                       System.Keyring.Types                        System.IO.Magic   ghc-options:         -Wall -O2   build-depends:       base >=4.6 && <4.7,@@ -33,14 +45,6 @@                        network >=2 && <3,                        http-types >=0 && <1,                        http-client >=0 && <1,-                       http-client-multipart >=0 && <1+                       http-client-multipart >=0 && <1,+                       keyring >=0 && <1   default-language:    Haskell2010--  if os(darwin)-    cpp-options:       -DDARWIN-    other-modules:     System.Keyring.Darwin-    frameworks:        Security CoreFoundation-  else-    other-modules:     System.Keyring.Unix-                       System.Keyring.Unix.KDE-    build-depends:     udbus >=0 && <1