packages feed

keyring (empty) → 0.1.0.0

raw patch · 11 files changed

+958/−0 lines, 11 filesdep +basedep +bytestringdep +keyringsetup-changed

Dependencies added: base, bytestring, keyring, udbus, utf8-string

Files

+ CHANGES.md view
@@ -0,0 +1,5 @@+0.1.0.0 (Apr 1, 2014)+=====================++- Initial release+- Add support for KDE KWallet and OS X Keychain
+ Example.hs view
@@ -0,0 +1,74 @@+-- 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.++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
+ LICENSE view
@@ -0,0 +1,18 @@+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.
+ README.md view
@@ -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 <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/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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ keyring.cabal view
@@ -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
+ src/System/Keyring.hs view
@@ -0,0 +1,74 @@+-- 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+         -- * 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
+ src/System/Keyring/Darwin.hsc view
@@ -0,0 +1,233 @@+-- 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 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 <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 ()++-- |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 <https://developer.apple.com/library/mac/documentation/security/Reference/keychainservices/Reference/reference.html#//apple_ref/doc/uid/TP30000898-CH5g-CJBEABHG Keychain Services Result Codes>+  -- 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
+ src/System/Keyring/Types.hs view
@@ -0,0 +1,75 @@+-- 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 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
+ src/System/Keyring/Unix.hs view
@@ -0,0 +1,73 @@+-- 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.++-- |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
+ src/System/Keyring/Unix/KDE.hs view
@@ -0,0 +1,224 @@+-- 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 #-}++-- |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]