diff --git a/CHANGES.md b/CHANGES.md new file mode 100644 --- /dev/null +++ b/CHANGES.md @@ -0,0 +1,5 @@ +0.1.0.0 (Apr 1, 2014) +===================== + +- Initial release +- Add support for KDE KWallet and OS X Keychain diff --git a/Example.hs b/Example.hs new file mode 100644 --- /dev/null +++ b/Example.hs @@ -0,0 +1,74 @@ +-- 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. + +module Main where + +import System.Keyring (Service(..),Username(..),Password(..) + ,getPassword,setPassword + ,KeyringError) + +import Control.Exception (catch) +import Control.Monad (liftM) +import Data.Version (showVersion) +import System.Exit (exitFailure) +import System.IO (hPutStrLn, hPutStr, hFlush, stderr, stdout) +import Text.Printf (printf) + +import Paths_keyring (version) + +ask :: String -> IO String +ask prompt = do + hPutStr stdout prompt + hFlush stdout + getLine + +service :: Service +service = Service "haskell-keyring-example" + +handleKeyringError :: KeyringError -> IO () +handleKeyringError exc = + hPutStrLn stderr (show exc) >> exitFailure + +roundTrip :: Username -> IO () +roundTrip username = do + password <- ask "A password (VISIBLE): " + setPassword service username (Password password) + result <- getPassword service username + case result of + (Just (Password storedPassword)) -> do + let matching = if password == storedPassword then "ok" else "MISMATCH" + printf "Password in keyring: %s (%s)\n" storedPassword matching + Nothing -> hPutStrLn stderr "Error: Password NOT saved!" >> exitFailure + +tryGetPassword :: IO () +tryGetPassword = do + username <- liftM Username (ask "A username: ") + password <- getPassword service username + case password of + (Just (Password pw)) -> putStr "Your Password: " >> putStrLn pw + Nothing -> putStrLn "No password in keyring" >> roundTrip username + +showVersionInfo :: IO () +showVersionInfo = printf "Keyring %s\n" (showVersion version) + +main :: IO () +main = do + showVersionInfo + catch tryGetPassword handleKeyringError diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,18 @@ +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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,99 @@ +haskell-keyring +=============== + +[![hackage][badge-hackage]][hackage] [![license][badge-license]]][license] + +Haskell library to access the system's keyring to securely store passwords. + +Supported keyring backends: + +- Keychain on OS X +- KWallet on KDE + +The library automatically chooses the appropriate backend for the current +system and environment. + +Installation +------------ + +From [Hackage][]: + +```console +$ cabal install keyring +``` + +Usage +----- + +See [Example.hs][example] for a complete example. + +### Getting passwords + +```haskell +import System.Keyring + +main = do + password <- getPassword (Service "my-application") + (Username "Joe") + case password of + (Just (Password pw)) -> + putStrLn ("Your password is " ++ pw) + Nothing -> + putStrLn "No password found" +``` + +### Setting passwords + +```haskell +import System.Keyring + +main = setPassword (Service "my-application") + (Username "Joe") + (Password "my-secret-password") +``` + +Support +------- + +- [Issue tracker][issues] + +Contribute +---------- + +- [Issue tracker][issues] +- [Github][] + +Credits +------- + +- [Contributors](https://github.com/lunaryorn/haskell-keyring/graphs/contributors) + +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/keyring.svg?dummy +[hackage]: https://hackage.haskell.org/package/keyring +[badge-license]: https://img.shields.io/badge/license-MIT-green.svg?dummy +[license]: https://github.com/lunaryorn/haskell-keyring/blob/master/LICENSE +[example]: https://github.com/lunaryorn/haskell-keyring/blob/master/Example.hs +[issues]: https://github.com/lunaryorn/haskell-keyring/issues +[Github]: https://github.com/lunaryorn/haskell-keyring diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/keyring.cabal b/keyring.cabal new file mode 100644 --- /dev/null +++ b/keyring.cabal @@ -0,0 +1,81 @@ +name: keyring +version: 0.1.0.0 +synopsis: Keyring access +description: + keyring provides access to the system's keyring to securely store passwords. + . + Currently this library supports the following keyring implementations: + . + * Keychain on OS X + . + * KWallet on KDE + . + The "System.Keyring" module provides the high-level functions 'getPassword' + and 'setPassword' to easily get and set passwords in the keyring of the + current user. The appropriate backend is chosen automatically. + +homepage: https://github.com/lunaryorn/haskell-keyring +bug-reports: https://github.com/lunaryorn/haskell-keyring/issues +license: MIT +license-file: LICENSE +extra-source-files: README.md, + CHANGES.md +author: Sebastian Wiesner +maintainer: lunaryorn@gmail.com +copyright: (C) 2014 Sebastian Wiesner +category: System +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/lunaryorn/haskell-keyring.git + branch: master + +source-repository this + type: git + location: https://github.com/lunaryorn/haskell-keyring.git + tag: 0.1.0.0 + +flag AllBackends + description: Try to build as many backends as possible + manual: True + default: False + +flag Example + description: Build an example executable + manual: True + default: False + +library + hs-source-dirs: src/ + ghc-options: -Wall -O2 + exposed-modules: System.Keyring + other-modules: System.Keyring.Types + build-depends: base >=4.6 && <4.7 + default-language: Haskell2010 + + if os(darwin) + cpp-options: -DDARWIN + exposed-modules: System.Keyring.Darwin + build-tools: hsc2hs + build-depends: utf8-string >=0.3 && <0.4, + bytestring >=0.10 && <0.11 + frameworks: Security CoreFoundation + + if !os(darwin) || flag(AllBackends) + exposed-modules: System.Keyring.Unix + System.Keyring.Unix.KDE + build-depends: udbus >=0.2 && <0.3 + +executable keyring-example + main-is: Example.hs + default-language: Haskell2010 + ghc-options: -Wall -O2 + build-depends: base, + keyring + + if flag(Example) + buildable: True + else + buildable: False diff --git a/src/System/Keyring.hs b/src/System/Keyring.hs new file mode 100644 --- /dev/null +++ b/src/System/Keyring.hs @@ -0,0 +1,74 @@ +-- 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 + -- * Exceptions + , KeyringError(..) + , KeyringMissingBackendError(..) + ) 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. +-- +-- @service@ identifies the application which gets the password. +-- +-- This function throws 'KeyringMissingBackendError' is no keyring +-- implementation exists for the current system and environment, and +-- 'KeyringError' if access to the keyring failed. +getPassword :: Service -> Username -> IO (Maybe Password) +getPassword = Backend.getPassword + +-- |@'setPassword' service username password@ adds @password@ to the keyring. +-- +-- @service@ identifies the application which sets the password. +-- +-- This function throws 'KeyringMissingBackendError' is no keyring +-- implementation exists for the current system and environment, and +-- 'KeyringError' if access to the keyring failed. +setPassword :: Service -> Username -> Password -> IO () +setPassword = Backend.setPassword diff --git a/src/System/Keyring/Darwin.hsc b/src/System/Keyring/Darwin.hsc new file mode 100644 --- /dev/null +++ b/src/System/Keyring/Darwin.hsc @@ -0,0 +1,233 @@ +-- 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 ForeignFunctionInterface #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- |Access to the OS X Keychain. +-- +-- This module is only available on OS X. See "System.Keyring.Unix" for keyring +-- support on other Unix systems. +module System.Keyring.Darwin + ( + -- * Keychain access + setPassword + , getPassword + -- * Error handling + , KeychainError(..) + , OSStatus + ) 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,cast) +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 () + +-- |An internal OS X status code. +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 KeychainError = + -- |@'KeychainError' message status@ denotes an error which occurred when + -- accessing Keychain. + -- + -- @message@ is the human-readable error message reported by the system, and + -- @status@ is the internal status code. + -- + -- See + -- for a list of all status codes. + -- + -- Note that this error is /not/ thrown for the status codes + -- @errSecItemNotFound@ and @errSecAuthFailed@. For these status codes, + -- 'getPassword' simply returns 'Nothing'. + KeychainError (Maybe String) OSStatus deriving Typeable + +instance Show KeychainError 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 KeychainError where + toException = toException . KeyringError + fromException x = do + KeyringError e <- fromException x + cast e + +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 + +-- |@'setPassword' service username password@ adds @password@ for @username@ +-- to the user's keychain. +-- +-- @username@ is the name of the user whose password to set. @service@ +-- identifies the application which sets the password. +-- +-- This function throws 'KeychainError' if access to the Keychain failed. +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. +-- +-- This function throws 'KeychainError' if access to the Keychain failed. +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/src/System/Keyring/Types.hs b/src/System/Keyring/Types.hs new file mode 100644 --- /dev/null +++ b/src/System/Keyring/Types.hs @@ -0,0 +1,75 @@ +-- 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 ExistentialQuantification #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- |Basic types for keyring access. +module System.Keyring.Types + ( + -- * Data types + Service(..) + , Username(..) + , Password(..) + -- * Exceptions + , KeyringError(..) + , KeyringMissingBackendError(..) + ) + where + +import Control.Exception (Exception(..)) +import Data.Typeable (Typeable,cast) + +-- |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 + +-- |Base type for all exceptions of this library. +data KeyringError = forall e . Exception e => KeyringError e + deriving Typeable + +instance Show KeyringError where + show (KeyringError e) = show e + +instance Exception KeyringError + +data KeyringMissingBackendError = + -- |@'KeyringMissingBackendError'@ indicates that no keyring backend is + -- available for the current system and environment. + -- + -- See "System.Keyring" for a list of supported keyring backends. + KeyringMissingBackendError deriving (Typeable) + +instance Show KeyringMissingBackendError where + show KeyringMissingBackendError = "Keyring error: no backend available" + +instance Exception KeyringMissingBackendError where + toException = toException . KeyringError + fromException x = do + KeyringError e <- fromException x + cast e diff --git a/src/System/Keyring/Unix.hs b/src/System/Keyring/Unix.hs new file mode 100644 --- /dev/null +++ b/src/System/Keyring/Unix.hs @@ -0,0 +1,73 @@ +-- 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. + +-- |Access to keyrings of Unix systems. +-- +-- Currently this module only supports KWallet, via "System.Keyring.Unix.KDE". +-- +-- This module and any of its submodules are not available on OS X. See +-- "System.Keyring.Darwin" for keyring support on OS X. +module System.Keyring.Unix (getPassword,setPassword) where + +import qualified System.Keyring.Unix.KDE as KDE + +import System.Keyring.Types + +import Control.Exception (throwIO) +import System.Environment (getEnv) + +-- |The keyring provider to use. +-- +-- Throws 'KeyringMissingBackendError' if no keyring backend is available on the +-- current system. +provider :: IO (Service -> Username -> IO (Maybe Password) + ,Service -> Username -> Password -> IO ()) +provider = do + desktop <- getEnv "XDG_CURRENT_DESKTOP" + case desktop of + "KDE" -> return (KDE.getPassword, KDE.setPassword) + _ -> throwIO KeyringMissingBackendError + +-- |@'getPassword' service username@ gets a password from the current keyring. +-- +-- @username@ is the name of the user whose password to get. @service@ +-- identifies the application which fetches the password. +-- +-- This function throws 'KeyringMissingBackendError' is no keyring +-- implementation exists for the current system and environment, and +-- 'KeyringError' if access to the keyring failed. +getPassword :: Service -> Username -> IO (Maybe Password) +getPassword service username = do + (get, _) <- provider + get service username + +-- |@'setPassword' service username password@ adds @password@ for @username@ +-- to the current keyring. +-- +-- @username@ is the name of the user whose password to set. @service@ +-- identifies the application which sets the password. +-- +-- This function throws 'KeyringMissingBackendError' is no keyring +-- implementation exists for the current system and environment, and +-- 'KeyringError' if access to the keyring failed. +setPassword :: Service -> Username -> Password -> IO () +setPassword service username password = do + (_, set) <- provider + set service username password diff --git a/src/System/Keyring/Unix/KDE.hs b/src/System/Keyring/Unix/KDE.hs new file mode 100644 --- /dev/null +++ b/src/System/Keyring/Unix/KDE.hs @@ -0,0 +1,224 @@ +-- 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 #-} + +-- |Access to KWallet. +module System.Keyring.Unix.KDE + ( + -- * KWallet access + getPassword,setPassword + -- * Errors + , KWalletError(..)) 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,cast) +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) + -- ^@'KWalletDBusError' name message@ denotes an error + -- received over DBus. + -- + -- @name@ is the proper name of the error, and @message@ is + -- a human-readable error message. + | KWalletOperationError String + -- ^@'KWalletOperationError' message@ denotes a failed + -- KWallet operation. + -- + -- @message@ is a human-readable error message with details + -- on the error. + | KWalletInvalidReturn [Type] [Type] + -- ^@'KWalletInvalidReturn' expected actual@ denotes an + -- unexpected return value from a DBus method call. + -- + -- @expected@ is the expected type signature, and @actual@ + -- is the signature which was actually received from the + -- remote DBus object. + 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 where + toException = toException . KeyringError + fromException x = do + KeyringError e <- fromException x + cast e + +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@ gets a password from the user's network +-- wallet. +-- +-- @username@ is the name of the user whose password to get. @service@ +-- identifies the application which fetches the password. +-- +-- This function throws 'KWalletError' if access to KWallet failed. +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@ adds @password@ for @username@ to +-- the user's network wallet. +-- +-- @username@ is the name of the user whose password to set. @service@ +-- identifies the application which sets the password. +-- +-- This function throws 'KWalletError' if access to KWallet failed. +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]