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/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/System/IO/Magic.hs b/System/IO/Magic.hs new file mode 100644 --- /dev/null +++ b/System/IO/Magic.hs @@ -0,0 +1,45 @@ +-- 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 #-} + +-- |Guess the file type of files. +module System.IO.Magic where + +import Control.Exception (Exception,throwIO) +import Data.Typeable (Typeable) +import System.Exit(ExitCode(..)) +import System.Process (readProcessWithExitCode) + +newtype MagicException = MagicException String + deriving Typeable + +instance Show MagicException where + show (MagicException message) = message + +instance Exception MagicException + +guessMimeType :: FilePath -> IO String +guessMimeType fileName = do + (status, stdout, stderr) <- readProcessWithExitCode "file" args [] + case status of + ExitFailure _ -> throwIO (MagicException (stdout ++ stderr)) + ExitSuccess -> return (head (lines stdout)) + where args = ["--brief", "--mime-type", fileName] diff --git a/System/Keyring.hs b/System/Keyring.hs new file mode 100644 --- /dev/null +++ b/System/Keyring.hs @@ -0,0 +1,56 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/System/Keyring/Darwin.hsc @@ -0,0 +1,201 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/System/Keyring/Types.hs @@ -0,0 +1,36 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/System/Keyring/Unix.hs @@ -0,0 +1,53 @@ +-- 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 new file mode 100644 --- /dev/null +++ b/System/Keyring/Unix/KDE.hs @@ -0,0 +1,186 @@ +-- 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/Web/Marmalade.hs b/Web/Marmalade.hs new file mode 100644 --- /dev/null +++ b/Web/Marmalade.hs @@ -0,0 +1,268 @@ +-- 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 FlexibleContexts #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- |Access to the API of Marmalade +module Web.Marmalade + ( + -- * The Marmalade Monad + Marmalade, runMarmalade,runMarmaladeWithManager + -- * Error handling + , MarmaladeError(..) + -- * Authentication + , Username(..), Token(..), Auth(..), login + -- * Package uploads + , verifyPackage,uploadPackage,Upload(..) + ) + where + +import qualified System.IO.Magic as Magic + +import qualified Data.Aeson as JSON +import qualified Data.ByteString.UTF8 as UTF8 +import qualified Network as N +import qualified Network.HTTP.Client as C + +import Control.Applicative ((<$>)) +import Control.Exception (Exception,throwIO) +import Control.Failure (Failure(..)) +import Control.Monad (liftM,mzero,unless) +import Control.Monad.IO.Class (MonadIO,liftIO) +import Control.Monad.State (StateT,MonadState,evalStateT,get,gets,put) +import Data.Aeson (FromJSON,Value(Object),(.:)) +import Data.ByteString.Lazy (ByteString) +import Data.Typeable (Typeable) +import Network.HTTP.Client (Manager,HttpException,Request,Response) +import Network.HTTP.Client.MultipartFormData +import Network.HTTP.Types.Header (hUserAgent) +import Network.HTTP.Types.Status (Status(statusCode,statusMessage)) +import Text.Printf (printf) + +-- |The Marmalade monad. +-- +-- This monad provides access to the Marmalade API. +newtype Marmalade a = + Marmalade { runM :: StateT MarmaladeState IO a } + deriving (Monad,MonadIO,Functor + ,MonadState MarmaladeState) + +instance Failure HttpException Marmalade where + failure = throwMarmalade + +-- |@'runMarmalade' userAgent auth actions@ runs @actions@. +-- +-- @userAgent@ is sent as @User-Agent@ header to Marmalade, and @auth@ is the +-- authentication information. +-- +-- Marmalade requires a token to access most of its API, however clients can +-- "login" with a username and a password to obtain their token. +runMarmalade :: String -- ^The user agent sent to Marmalade + -> Auth -- ^The authentication information + -> Marmalade a -- ^The actions to run + -> IO a + -- ^The result of the actions, or any error thrown in the course of + -- running the actions. +runMarmalade userAgent auth action = + N.withSocketsDo $ C.withManager C.defaultManagerSettings doIt + where doIt manager = runMarmaladeWithManager userAgent auth manager action + +-- |@'runMarmaladeWithManager userAgent auth manager actions'@ runs @actions@ +-- with the given connection @manager@. +-- +-- Like @'runMarmalade'@, except that it lets you use your own connection +-- manager. +runMarmaladeWithManager :: String -- ^The user agent sent to Marmalade + -> Auth -- ^The authentication information + -> Manager -- ^The connection manager + -> Marmalade a -- ^The actions to run + -> IO a + -- ^The result of the actions, or any error thrown in + -- the course of running the actions. +runMarmaladeWithManager userAgent auth manager action = + evalStateT (runM action) state + where state = MarmaladeState { marmaladeAuth = auth + , marmaladeUserAgent = userAgent + , marmaladeManager = manager} + +-- |The internal state of the @'Marmalade'@ monad. +data MarmaladeState = MarmaladeState + { marmaladeAuth :: Auth + , marmaladeUserAgent :: String + , marmaladeManager :: Manager } + +-- |Errors thrown by Marmalade. +data MarmaladeError = MarmaladeInvalidResponseStatus Status (Maybe String) + -- ^An invalid response from Marmalade, with a status and + -- probably an error message from Marmalade. + | MarmaladeInvalidResponseBody ByteString + -- ^Invalid response body + | MarmaladeBadRequest (Maybe String) + -- ^A bad request error from Marmalade. + -- + -- Marmalade raises this error for failed logins and for + -- uploads of invalid packages (e.g. files without a + -- version header) + | MarmaladeInvalidPackage FilePath String + -- ^An invalid package file, with a corresponding error + -- message. + deriving Typeable + +instance Show MarmaladeError where + show (MarmaladeInvalidResponseStatus status (Just message)) = + printf "Marmalade error: Invalid response status: %s (%s)" msgString message + where msgString = UTF8.toString (statusMessage status) + show (MarmaladeInvalidResponseStatus status Nothing) = + printf "Marmalade error: Invalid response status: %s" msgString + where msgString = UTF8.toString (statusMessage status) + show (MarmaladeInvalidResponseBody s) = + "Marmalade error: Invalid response body: " ++ show s + show (MarmaladeBadRequest (Just message)) = + "Marmalade error: Bad Request: " ++ message + show (MarmaladeBadRequest Nothing) = "Marmalade error: Bad Request" + show (MarmaladeInvalidPackage f m) = + printf "Marmalade error: %s: invalid package: %s" f m + +instance Exception MarmaladeError + +throwMarmalade :: Exception e => e -> Marmalade a +throwMarmalade = liftIO.throwIO + +-- |The name of a user +newtype Username = Username String deriving (Show, Eq) +-- |An authentication token. +newtype Token = Token String deriving (Show, Eq) + +instance FromJSON Token where + parseJSON (Object o) = Token <$> (o .: "token") + parseJSON _ = mzero + +-- |Authentication information for Marmalade. +data Auth = BasicAuth Username (Marmalade String) + -- ^Authentication with a username and an action that returns a + -- password to use + | TokenAuth Username Token + -- ^Authentication with a username and a login token + +-- |@'login'@ logs in to Marmalade to obtain the client's access token. +-- +-- If the monad already uses token authentication this function is a no-op and +-- merely returns the stored token. Otherwise it sends a login request to +-- Marmalade to obtain the token and stores the token in the monad. +login :: Marmalade (Username, Token) +login = do + state <- get + case marmaladeAuth state of + BasicAuth username getPassword -> do + token <- doLogin username getPassword + put state { marmaladeAuth = TokenAuth username token } + return (username, token) + TokenAuth username token -> return (username, token) + where doLogin (Username username) getPassword = do + manager <- gets marmaladeManager + password <- getPassword + request <- liftM (C.urlEncodedBody [("name", UTF8.fromString username) + ,("password", UTF8.fromString password)]) + (makeRequest "/v1/users/login") + response <- liftIO $ C.httpLbs request manager + parseResponse response + +newtype Message = Message { messageContents :: String } + +instance FromJSON Message where + parseJSON (Object o) = Message <$> (o .: "message") + parseJSON _ = mzero + +-- |The result of an upload. +newtype Upload = Upload + { uploadMessage :: String -- ^The message from Marmalade + } + +instance FromJSON Upload where + parseJSON (Object o) = Upload <$> (o .: "message") + parseJSON _ = mzero + +-- |The base URL of Marmalade. +marmaladeURL :: String +marmaladeURL = "http://marmalade-repo.org" + +-- |@'makeRequest' endpoint@ creates a request to @endpoint@. +-- +-- Responses to requests created by this function do not throw 'HTTPException' +-- for non-200 responses. Use @'parseResponse'@ to turn such response into +-- @'MarmaladeError'@s. +makeRequest :: String -> Marmalade Request +makeRequest endpoint = do + initReq <- C.parseUrl (marmaladeURL ++ endpoint) + userAgent <- gets marmaladeUserAgent + return initReq { C.requestHeaders = [(hUserAgent, UTF8.fromString userAgent)] + -- We keep every bad status, because we handle these later + , C.checkStatus = \_ _ _ -> Nothing + } + +-- |@'parseResponse' response@ parses the JSON body of @response@, or throws an +-- error for unexpected responses or invalid JSON bodies. +parseResponse :: FromJSON c => Response ByteString -> Marmalade c +parseResponse response = + case statusCode status of + 200 -> case JSON.decode body of + Just o -> return o + Nothing -> throwMarmalade (MarmaladeInvalidResponseBody body) + 400 -> throwMarmalade (MarmaladeBadRequest message) + _ -> throwMarmalade (MarmaladeInvalidResponseStatus status message) + where body = C.responseBody response + status = C.responseStatus response + message = fmap messageContents (JSON.decode body) + +-- |Permitted package mimetypes. +packageMimeTypes :: [String] +packageMimeTypes = ["application/x-tar", "text/x-lisp"] + +-- |@'verifyPackage' package@ checks whether @package@ is a valid package +-- object. +-- +-- Throw an error if @package@ does not exist, or is not a valid package. +verifyPackage :: String -> Marmalade () +verifyPackage packageFile = do + -- Force early failure if the package doesn't exist + mimeType <- liftIO (Magic.guessMimeType packageFile) + unless (mimeType `elem` packageMimeTypes) + (throwMarmalade (MarmaladeInvalidPackage packageFile + (printf "invalid mimetype %s" mimeType))) + +-- |@'uploadPackage' package@ uploads a @package@ file to Marmalade. +-- +-- Return the result of the upload, or throw an error if @package@ is not a +-- valid package, or if Marmalade refused to accept the upload. +uploadPackage :: FilePath -> Marmalade Upload +uploadPackage packageFile = do + verifyPackage packageFile + (Username username, Token token) <- login + manager <- gets marmaladeManager + request <- makeRequest "/v1/packages" >>= + formDataBody [partBS "name" (UTF8.fromString username) + ,partBS "token" (UTF8.fromString token) + ,partFileSource "package" packageFile] + response <- liftIO (C.httpLbs request manager) + parseResponse response diff --git a/main.hs b/main.hs new file mode 100644 --- /dev/null +++ b/main.hs @@ -0,0 +1,138 @@ +-- 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 #-} + +module Main where + +import qualified System.Keyring as K +import Web.Marmalade + +import qualified System.Environment as Env +import qualified System.IO as IO +import qualified System.Console.CmdArgs as Args + +import Control.Exception (SomeException,bracket,handle) +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Data.Version (showVersion) +import System.Console.CmdArgs (Data,Typeable,(&=),cmdArgs) +import System.Exit (ExitCode(ExitFailure),exitWith) +import Text.Printf (printf) + +import Paths_marmalade_upload (version) + +-- Program information + +appName :: String +appName = "marmalade-upload" + +appVersion :: String +appVersion = showVersion version + +appService :: String +appService = "lunaryorn/" ++ appName + +appUserAgent :: String +appUserAgent = appService ++ "/" ++ appVersion + +-- CLI tools + +-- |@'withEcho' echo action@ runs @action@ with input echo set to @echo@. +-- +-- If @echo@ is 'False', this module disable echoing of input on the terminal. +-- Otherwise it enables echoing. +-- +-- The input echo is reset to its previous state after @action@. +withEcho :: Bool -> IO a -> IO a +withEcho echo action = bracket (IO.hGetEcho IO.stdin) + (IO.hSetEcho IO.stdin) + (const $ IO.hSetEcho IO.stdin echo >> action) + +-- |@'askPassword' prompt@ asks a password on the terminal, with @prompt@. +-- +-- Show @prompt@ on the terminal, disable echo and read a password. Afterwards +-- reset echoing. +askPassword :: String -> IO String +askPassword prompt = do + putStr prompt + IO.hFlush IO.stdout + password <- withEcho False getLine + putChar '\n' + return password + +-- |@'askMarmaladePassword' username@ asks for the Marmalade password of the +-- given @username@ on the terminal. +askMarmaladePassword :: String -> Marmalade String +askMarmaladePassword username = do + liftIO (askPassword (printf "Marmalade password for %s (never stored): " username)) + +-- |@'getAuth' username@ gets authentication information for the given +-- @username@. +-- +-- 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 + 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)) + +-- Arguments handling + +exitFailure :: String -> IO () +exitFailure message = IO.hPutStrLn IO.stderr message >> exitWith (ExitFailure 1) + +exitException :: SomeException -> IO () +exitException = exitFailure.show + +data Arguments = Arguments { argUsername :: String + , argPackageFile :: String} + deriving (Show, Data, Typeable) + +arguments :: IO Arguments +arguments = do + programName <- Env.getProgName + return $ Arguments { argUsername = Args.def &= Args.argPos 0 + &= Args.typ "USERNAME" + , argPackageFile = Args.def &= Args.argPos 1 + &= Args.typ "PACKAGE" } + &= Args.summary (printf "%s %s" programName appVersion) + &= Args.help "Upload a PACKAGE to Marmalade." + &= Args.details ["Copyright (C) 2014 Sebastian Wiesner" + ,"Distributed under the terms of the MIT/X11 license."] + &= Args.program programName + +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 + handle exitException $ runMarmalade appUserAgent auth $ do + ((Username username), (Token token)) <- login + -- Save the token now + when mustSaveToken $ + 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 new file mode 100644 --- /dev/null +++ b/marmalade-upload.cabal @@ -0,0 +1,46 @@ +name: marmalade-upload +version: 0.4 +synopsis: Upload packages to Marmalade +description: Upload Emacs packages to the Marmalade ELPA archive +homepage: https://github.com/lunaryorn/marmalade-upload +license: MIT +license-file: LICENSE +author: Sebastian Wiesner +maintainer: lunaryorn@gmail.com +copyright: (C) 2014 Sebastian Wiesner +bug-reports: https://github.com/lunaryorn/marmalade-upload/issues +category: Development +build-type: Simple +cabal-version: >=1.10 + +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, + mtl >=2 && <3, + transformers >=0 && <1, + failure >=0 && <1, + bytestring >=0 && <1, + utf8-string >=0 && <1, + directory >=1.2 && <2, + process >=1.1 && <2, + cmdargs >=0 && <1, + aeson >=0 && <1, + network >=2 && <3, + http-types >=0 && <1, + http-client >=0 && <1, + http-client-multipart >=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