diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -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 diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 + +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 diff --git a/System/Keyring.hs b/System/Keyring.hs deleted file mode 100644 --- a/System/Keyring.hs +++ /dev/null @@ -1,56 +0,0 @@ --- Copyright (c) 2014 Sebastian Wiesner - --- 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 diff --git a/System/Keyring/Darwin.hsc b/System/Keyring/Darwin.hsc deleted file mode 100644 --- a/System/Keyring/Darwin.hsc +++ /dev/null @@ -1,201 +0,0 @@ --- Copyright (c) 2014 Sebastian Wiesner - --- 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 - -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 diff --git a/System/Keyring/Types.hs b/System/Keyring/Types.hs deleted file mode 100644 --- a/System/Keyring/Types.hs +++ /dev/null @@ -1,36 +0,0 @@ --- Copyright (c) 2014 Sebastian Wiesner - --- 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 diff --git a/System/Keyring/Unix.hs b/System/Keyring/Unix.hs deleted file mode 100644 --- a/System/Keyring/Unix.hs +++ /dev/null @@ -1,53 +0,0 @@ --- Copyright (c) 2014 Sebastian Wiesner - --- 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 diff --git a/System/Keyring/Unix/KDE.hs b/System/Keyring/Unix/KDE.hs deleted file mode 100644 --- a/System/Keyring/Unix/KDE.hs +++ /dev/null @@ -1,186 +0,0 @@ --- Copyright (c) 2014 Sebastian Wiesner - --- 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] diff --git a/main.hs b/main.hs --- a/main.hs +++ b/main.hs @@ -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)) diff --git a/marmalade-upload.cabal b/marmalade-upload.cabal --- a/marmalade-upload.cabal +++ b/marmalade-upload.cabal @@ -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 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