packages feed

marmalade-upload (empty) → 0.4

raw patch · 11 files changed

+1049/−0 lines, 11 filesdep +aesondep +basedep +bytestringsetup-changed

Dependencies added: aeson, base, bytestring, cmdargs, directory, failure, http-client, http-client-multipart, http-types, mtl, network, process, transformers, udbus, utf8-string

Files

+ 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ System/IO/Magic.hs view
@@ -0,0 +1,45 @@+-- 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 #-}++-- |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]
+ System/Keyring.hs view
@@ -0,0 +1,56 @@+-- Copyright (c) 2014 Sebastian Wiesner <lunaryorn@gmail.com>++-- Permission is hereby granted, free of charge, to any person obtaining a copy+-- of this software and associated documentation files (the "Software"), to deal+-- in the Software without restriction, including without limitation the rights+-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+-- copies of the Software, and to permit persons to whom the Software is+-- furnished to do so, subject to the following conditions:++-- The above copyright notice and this permission notice shall be included in+-- all copies or substantial portions of the Software.++-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+-- THE SOFTWARE.++{-# LANGUAGE CPP #-}++-- |Access to the keyring of the user.+--+-- This module provides access to the keyring of the current system.  Currently+-- this module supports the following keyrings:+--+-- * Keychain on OS X+--+-- * KWallet on KDE+--+-- The module automatically picks the best appropriate keyring.+module System.Keyring+       (+         -- * Data types+         Service(..),Username(..),Password(..)+         -- * Password storage+       , getPassword,setPassword)+       where++import System.Keyring.Types++#ifdef DARWIN+import qualified System.Keyring.Darwin as Backend+#else+import qualified System.Keyring.Unix as Backend+#endif++-- |@'getPassword' service username@ gets the password for the given @username@+-- and @service@ from the keyring.+getPassword :: Service -> Username -> IO (Maybe Password)+getPassword = Backend.getPassword++-- |@'setPassword' service username password@ adds @password@ to the keyring.+setPassword :: Service -> Username -> Password -> IO ()+setPassword = Backend.setPassword
+ System/Keyring/Darwin.hsc view
@@ -0,0 +1,201 @@+-- Copyright (c) 2014 Sebastian Wiesner <lunaryorn@gmail.com>++-- Permission is hereby granted, free of charge, to any person obtaining a copy+-- of this software and associated documentation files (the "Software"), to deal+-- in the Software without restriction, including without limitation the rights+-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+-- copies of the Software, and to permit persons to whom the Software is+-- furnished to do so, subject to the following conditions:++-- The above copyright notice and this permission notice shall be included in+-- all copies or substantial portions of the Software.++-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+-- THE SOFTWARE.++{-# OPTIONS_HADDOCK hide #-}++{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE DeriveDataTypeable #-}++-- |Access to the OS X Key chain+module System.Keyring.Darwin (setPassword,getPassword) where++import System.Keyring.Types++import qualified Data.ByteString.UTF8 as UTF8++import Control.Exception (Exception,bracket,throwIO)+import Control.Monad (liftM,when,void)+import Data.ByteString+import Data.Int (Int32, Int64)+import Data.Typeable (Typeable)+import Data.Word (Word32)+import Foreign.C+import Foreign.Ptr+import Foreign.Storable+import Foreign.Marshal.Alloc (alloca,allocaBytes)+import Text.Printf (printf)++-- C declarations++#include <Security/Security.h>++type UInt32 = #type UInt32+type CFTypeRef = Ptr ()+type CFStringRef = Ptr ()+type CFStringEncoding = #type CFStringEncoding+type CFIndex = #type CFIndex+type SecKeychainItemRef = Ptr ()+type SecKeychainRef = Ptr ()+type OSStatus = #type OSStatus++#{enum OSStatus, ,+  errSecSuccess = errSecSuccess,+  errSecItemNotFound = errSecItemNotFound,+  errSecAuthFailed = errSecAuthFailed}++kCFStringEncodingUTF8 :: CFStringEncoding+kCFStringEncodingUTF8 = #const kCFStringEncodingUTF8++foreign import ccall unsafe "CoreFoundation/CoreFoundation.h CFRelease"+  c_CFRelease :: CFTypeRef -> IO ()++foreign import ccall unsafe "CoreFoundation/CoreFoundation.h CFStringGetMaximumSizeForEncoding"+  c_CFStringGetMaximumSizeForEncoding :: CFIndex -> CFStringEncoding -> CFIndex++foreign import ccall unsafe "CoreFoundation/CoreFoundation.h CFStringGetLength"+  c_CFStringGetLength :: CFStringRef -> CFIndex++foreign import ccall unsafe "CoreFoundation/CoreFoundation.h CFStringGetCString"+  c_CFStringGetCString :: CFStringRef -> CString -> CFIndex -> CFStringEncoding+                       -> IO Bool++foreign import ccall unsafe "Security/Security.h SecCopyErrorMessageString"+  c_SecCopyErrorMessageString :: OSStatus -> Ptr () -> IO CFStringRef++foreign import ccall unsafe "Security/Security.h SecKeychainItemFreeContent"+  c_SecKeychainItemFreeContent :: Ptr () -> CString -> IO OSStatus++foreign import ccall unsafe "Security/Security.h SecKeychainFindGenericPassword"+  c_SecKeychainFindGenericPassword :: CFTypeRef+                                   -> UInt32 -> CString+                                   -> UInt32 -> CString+                                   -> Ptr UInt32 -> Ptr CString+                                   -> Ptr SecKeychainItemRef+                                   -> IO OSStatus++foreign import ccall unsafe "Security/Security.h SecKeychainAddGenericPassword"+  c_SecKeychainAddGenericPassword :: SecKeychainRef+                                  -> UInt32 -> CString+                                  -> UInt32 -> CString+                                  -> UInt32 -> CString+                                  -> Ptr SecKeychainItemRef+                                  -> IO OSStatus++-- C wrappers++data KeychainException = KeychainError (Maybe String) OSStatus+                          deriving Typeable++instance Show KeychainException where+  show (KeychainError Nothing status) =+    printf "Keychain access failed: status %s" status+  show (KeychainError (Just msg) status) =+    printf "Keychain access failed: %s (status %d)" msg status++instance Exception KeychainException++throwKeychainError :: OSStatus -> IO a+throwKeychainError status = do+  messageResult <- secKeychainCopyErrorMessageString status+  let message = (fmap UTF8.toString messageResult)+  throwIO (KeychainError message status)++secKeychainCopyErrorMessageString :: OSStatus -> IO (Maybe ByteString)+secKeychainCopyErrorMessageString status =+  bracket+  (c_SecCopyErrorMessageString status nullPtr)+  (\s -> when (s /= nullPtr) (c_CFRelease s))+  (convertCFString)+  where+    convertCFString s | s == nullPtr = return Nothing+    convertCFString s = do+      let encoding = kCFStringEncodingUTF8+      let bufferSize = c_CFStringGetMaximumSizeForEncoding (c_CFStringGetLength s) encoding+      allocaBytes (fromIntegral bufferSize) (getCString s encoding bufferSize)+    getCString s encoding bufferSize buffer = do+      result <- c_CFStringGetCString s buffer bufferSize encoding+      if result+        then liftM Just (packCString buffer)+        else return Nothing++secKeychainFindGenericPassword :: ByteString -> ByteString -> IO (Maybe ByteString)+secKeychainFindGenericPassword service username = do+  useAsCStringLen service withService+  where+    withService c_service = useAsCStringLen username (withServiceAndUser c_service)+    withServiceAndUser c_service c_user = alloca (withPwLen c_service c_user)+    withPwLen c_service c_user pwlen = alloca (withAll c_service c_user pwlen)+    withAll :: CStringLen -> CStringLen -> Ptr UInt32 -> Ptr CString -> IO (Maybe ByteString)+    withAll (c_service_b, c_service_l) (c_user_b, c_user_l) password_l_buf password_buf =+      do+        result <- c_SecKeychainFindGenericPassword+                   nullPtr      -- Default keychain+                   (fromIntegral c_service_l) c_service_b+                   (fromIntegral c_user_l) c_user_b+                   password_l_buf password_buf+                   nullPtr      -- Ignore the item reference+        (bracket (peek password_buf)+         (\pw -> when (pw /= nullPtr)+                 (void $ c_SecKeychainItemFreeContent nullPtr pw))+         (handleResult result password_l_buf))+    handleResult :: OSStatus -> Ptr UInt32 -> CString -> IO (Maybe ByteString)+    handleResult result password_l_buf password_b = case result of+      _ | result == errSecSuccess -> do+        password_l <- peek password_l_buf+        liftM Just (packCStringLen (password_b, fromIntegral password_l))+      _ | result == errSecItemNotFound ||+          result == errSecAuthFailed -> return Nothing+      _ -> throwKeychainError result++secKeychainAddGenericPassword :: ByteString -> ByteString -> ByteString -> IO ()+secKeychainAddGenericPassword service username password = do+  useAsCStringLen service withService+  where+    withService c_service = useAsCStringLen username (withServiceAndUser c_service)+    withServiceAndUser c_service c_username =+      useAsCStringLen password (withAll c_service c_username)+    withAll (c_service_b, c_service_l) (c_user_b, c_user_l) (c_pw_b, c_pw_l) = do+      result <- c_SecKeychainAddGenericPassword+                nullPtr         -- Default keychain+                (fromIntegral c_service_l) c_service_b+                (fromIntegral c_user_l) c_user_b+                (fromIntegral c_pw_l) c_pw_b+                nullPtr         -- Ignore the item+      if result == errSecSuccess then return () else throwKeychainError result++-- Public API++-- |@'setPassword' service username password@ stores a @password@ for a given+-- @username@ and @service@.+setPassword :: Service -> Username -> Password -> IO ()+setPassword (Service service) (Username username) (Password password) =+  secKeychainAddGenericPassword service_bytes username_bytes password_bytes+  where service_bytes = UTF8.fromString service+        username_bytes = UTF8.fromString username+        password_bytes = UTF8.fromString password++-- |@'getPassword' service username@ gets password for a given @username@ and+-- @service@.  If the password was not found, return 'Nothing' instead.+getPassword :: Service -> Username -> IO (Maybe Password)+getPassword (Service service) (Username username) = do+  password_bytes <- secKeychainFindGenericPassword service_bytes username_bytes+  return (fmap Password (fmap (UTF8.toString) password_bytes))+  where service_bytes = UTF8.fromString service+        username_bytes = UTF8.fromString username
+ System/Keyring/Types.hs view
@@ -0,0 +1,36 @@+-- Copyright (c) 2014 Sebastian Wiesner <lunaryorn@gmail.com>++-- Permission is hereby granted, free of charge, to any person obtaining a copy+-- of this software and associated documentation files (the "Software"), to deal+-- in the Software without restriction, including without limitation the rights+-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+-- copies of the Software, and to permit persons to whom the Software is+-- furnished to do so, subject to the following conditions:++-- The above copyright notice and this permission notice shall be included in+-- all copies or substantial portions of the Software.++-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+-- THE SOFTWARE.++-- |Basic types for keyring access.+module System.Keyring.Types+       (Service(..), Username(..), Password(..))+       where++-- |A service which uses the keyring+--+-- The service identifies the application or service for which a secret is+-- stored.+newtype Service = Service String++-- |A username+newtype Username = Username String++-- |A password+newtype Password = Password String
+ System/Keyring/Unix.hs view
@@ -0,0 +1,53 @@+-- Copyright (c) 2014 Sebastian Wiesner <lunaryorn@gmail.com>++-- Permission is hereby granted, free of charge, to any person obtaining a copy+-- of this software and associated documentation files (the "Software"), to deal+-- in the Software without restriction, including without limitation the rights+-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+-- copies of the Software, and to permit persons to whom the Software is+-- furnished to do so, subject to the following conditions:++-- The above copyright notice and this permission notice shall be included in+-- all copies or substantial portions of the Software.++-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+-- THE SOFTWARE.++{-# OPTIONS_HADDOCK hide #-}++-- |Access to keyrings of Unix systems.+module System.Keyring.Unix (getPassword,setPassword) where++import qualified System.Keyring.Unix.KDE as KDE++import System.Keyring.Types++import System.Environment (getEnv)++-- |The keyring provider to use.+provider :: IO (Service -> Username -> IO (Maybe Password)+               ,Service -> Username -> Password -> IO ())+provider = do+  desktop <- getEnv "XDG_CURRENT_DESKTOP"+  return $ case desktop of+    "KDE" -> (KDE.getPassword, KDE.setPassword)+    _ -> dummy+  where dummy = (\_ _ -> return Nothing, \_ _ _ -> return ())++-- |@'getPassword' service username@ gets a password from the current keyring.+getPassword :: Service -> Username -> IO (Maybe Password)+getPassword service username = do+  (get, _) <- provider+  get service username++-- |@'setPassword' service username password@ adds @password@ to the current+-- keyring.+setPassword :: Service -> Username -> Password -> IO ()+setPassword service username password = do+  (_, set) <- provider+  set service username password
+ System/Keyring/Unix/KDE.hs view
@@ -0,0 +1,186 @@+-- Copyright (c) 2014 Sebastian Wiesner <lunaryorn@gmail.com>++-- Permission is hereby granted, free of charge, to any person obtaining a copy+-- of this software and associated documentation files (the "Software"), to deal+-- in the Software without restriction, including without limitation the rights+-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+-- copies of the Software, and to permit persons to whom the Software is+-- furnished to do so, subject to the following conditions:++-- The above copyright notice and this permission notice shall be included in+-- all copies or substantial portions of the Software.++-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+-- THE SOFTWARE.++{-# LANGUAGE DeriveDataTypeable #-}++{-# OPTIONS_HADDOCK hide #-}++-- |Access to the KDE keychain+module System.Keyring.Unix.KDE (getPassword,setPassword) where++import System.Keyring.Types++import Control.Exception (Exception,throwIO,bracket,catch)+import Control.Monad (void,unless)+import Data.Int (Int32)+import Data.Typeable (Typeable)+import Network.DBus (DBusConnection,BusName(..)+                    ,DBusCall(..),ObjectPath(..),Interface(..),Member(..)+                    ,DBusTypeable(..),Type(..),DBusValue(..)+                    ,DBusError(..),ErrorName(..)+                    ,busGetSession,establish,authenticateWithRealUID,call+                    ,returnBody,packedStringToString)+import Text.Printf (printf)++data KWalletError = KWalletDBusError ErrorName (Maybe String)+                  | KWalletOperationError String+                  | KWalletInvalidReturn [Type] [Type]+                  deriving Typeable++instance Show KWalletError where+  show (KWalletDBusError (ErrorName name) Nothing) =+    "KWallet error: DBus error " ++ name+  show (KWalletDBusError (ErrorName name) (Just message)) =+    printf "KWallet error: DBus error %s: %s" name message+  show (KWalletOperationError message) =+    "KWallet error: Operation failed: " ++ message+  show (KWalletInvalidReturn expected actual) =+    printf "KWallet error: invalid return: expected %s, got %s" (show expected) (show actual)++instance Exception KWalletError++throwInvalidReturn :: [Type] -> [DBusValue] -> IO a+throwInvalidReturn expected actual =+  throwIO (KWalletInvalidReturn expected (map toSignature actual))++getKWalletKey :: AppID -> Username -> String+getKWalletKey (AppID appID) (Username username) = username ++ "@" ++ appID++withSessionBus :: (DBusConnection -> IO a) -> IO a+withSessionBus actions = connectSession >>= actions+  where connectSession = establish busGetSession authenticateWithRealUID++newtype AppID = AppID String++instance DBusTypeable AppID where+  toSignature (AppID appID) = toSignature appID+  toDBusValue (AppID appID) = toDBusValue appID+  fromDBusValue value = fmap AppID (fromDBusValue value)++newtype Wallet = Wallet Int32++instance DBusTypeable Wallet where+  toSignature (Wallet appID) = toSignature appID+  toDBusValue (Wallet appID) = toDBusValue appID+  fromDBusValue value = fmap Wallet (fromDBusValue value)++callKWalletD :: DBusConnection -> String -> [DBusValue] -> IO [DBusValue]+callKWalletD connection methodName args = do+  result <- catch (call connection busName message) (throwIO.wrapDBusError)+  return (returnBody result)+  where busName = BusName {unBusName = "org.kde.kwalletd"}+        path = ObjectPath { unObjectPath = "/modules/kwalletd" }+        interface = Interface { unInterface = "org.kde.KWallet" }+        member = Member { unMember = methodName }+        message = DBusCall { callPath = path+                           , callInterface = Just interface+                           , callMember = member+                           , callBody = args}+        wrapDBusError DBusError{errorName=name,errorBody=body} =+          case body of+            [DBusString errMsg] ->+              KWalletDBusError name (Just (packedStringToString errMsg))+            _ -> KWalletDBusError name Nothing++openWallet :: DBusConnection -> String -> AppID -> IO Wallet+openWallet connection walletName appID = do+  reply <- callKWalletD connection "open" [toDBusValue walletName+                                          ,DBusInt64 0+                                          ,toDBusValue appID]+  case reply of+    [DBusInt32 handle] -> return (Wallet handle)+    _ -> throwInvalidReturn [SigInt32] reply++closeWallet :: DBusConnection -> AppID -> Wallet -> IO ()+closeWallet connection appID wallet =+  void (callKWalletD connection "close" [toDBusValue wallet+                                        ,toDBusValue False+                                        ,toDBusValue appID])++withNetworkWallet :: AppID -> (DBusConnection -> Wallet -> IO a) -> IO a+withNetworkWallet appID action = withSessionBus openNetworkWallet+  where+    openNetworkWallet connection = do+      reply <- callKWalletD connection "networkWallet" []+      case reply of+        [DBusString name] -> runAction connection (packedStringToString name)+        _ -> throwInvalidReturn [SigString] reply+    runAction connection name = bracket+      (openWallet connection name appID)+      (closeWallet connection appID)+      (action connection)++getPassword :: Service -> Username -> IO (Maybe Password)+getPassword (Service service) username = withNetworkWallet appID fetchPassword+  where+    appID = AppID service+    key = getKWalletKey appID username+    fetchPassword connection wallet = do+      hasPassword <- hasEntry connection wallet+      if hasPassword then readPassword connection wallet else return Nothing+    hasEntry connection wallet = do+      reply <- callKWalletD connection "hasEntry" [toDBusValue wallet+                                                  ,toDBusValue "Passwords"+                                                  ,toDBusValue key+                                                  ,toDBusValue appID]+      case reply of+        [DBusBoolean b] -> return b+        _ -> throwInvalidReturn [SigBool] reply+    readPassword connection wallet = do+      reply <- callKWalletD connection "readPassword" [toDBusValue wallet+                                                      ,toDBusValue "Passwords"+                                                      ,toDBusValue key+                                                      ,toDBusValue appID]+      case reply of+        [DBusString s] -> return (Just (Password (packedStringToString s)))+        _ -> throwInvalidReturn [SigString] reply++setPassword :: Service -> Username -> Password -> IO ()+setPassword (Service service) username (Password password) =+  withNetworkWallet appID storePassword+  where+    appID = AppID service+    key = getKWalletKey appID username+    storePassword connection wallet = do+      folderExists <- hasFolder connection wallet+      unless folderExists (createFolder connection wallet)+      writePassword connection wallet+    hasFolder connection wallet = do+      reply <- callKWalletD connection "hasFolder" [toDBusValue wallet+                                                   ,toDBusValue "Passwords"+                                                   ,toDBusValue appID]+      case reply of+        [DBusBoolean b] -> return b+        _ -> throwInvalidReturn [SigBool] reply+    createFolder connection wallet = do+      reply <- callKWalletD connection "createFolder" [toDBusValue wallet+                                                      ,toDBusValue "Passwords"+                                                      ,toDBusValue appID]+      case reply of+        [DBusBoolean b] -> do+          unless b (throwIO (KWalletOperationError "Could not create Passwords folder"))+          return ()+        _ -> throwInvalidReturn [SigBool] reply+    writePassword connection wallet =+      void $ callKWalletD connection "writePassword" [toDBusValue wallet+                                                     ,toDBusValue "Passwords"+                                                     ,toDBusValue key+                                                     ,toDBusValue password+                                                     ,toDBusValue appID]
+ Web/Marmalade.hs view
@@ -0,0 +1,268 @@+-- 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 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
+ main.hs view
@@ -0,0 +1,138 @@+-- 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 #-}++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))
+ marmalade-upload.cabal view
@@ -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