packages feed

skype4hs (empty) → 0.0.0.0

raw patch · 32 files changed

+3126/−0 lines, 32 filesdep +X11dep +attoparsecdep +basesetup-changed

Dependencies added: X11, attoparsec, base, bytestring, lifted-base, monad-control, mtl, stm, text, time, transformers-base, word8

Files

+ LICENSE view
@@ -0,0 +1,19 @@+Copyright (c) 2013 Shota Nozaki <emonkak@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
+ skype4hs.cabal view
@@ -0,0 +1,88 @@+name:                skype4hs+version:             0.0.0.0+synopsis:            Skype Desktop API binding for Haskell+description:         Skype Desktop API binding for Haskell+homepage:            https://github.com/emonkak/haskell-skype+license:             MIT+license-file:        LICENSE+author:              Shota Nozaki+maintainer:          emonkak@gmail.com+category:            Network+build-type:          Simple+cabal-version:       >=1.10++Flag x11+  Description: Enable x11 communication layer support+  Default:     False++Flag carbon+  Description: Enable carbon communication layer support+  Default:     False++library+  if os(linux) || os(freebsd) || flag(x11)+    exposed-modules:   Network.Skype.API.X11+    build-depends:     X11 >=1.5++  if os(darwin) || flag(carbon)+    frameworks:        Carbon+    exposed-modules:   Network.Skype.API.Carbon+    other-modules:     Network.Skype.API.Carbon.CFBase,+                       Network.Skype.API.Carbon.CFDictionary,+                       Network.Skype.API.Carbon.CFNotificationCenter,+                       Network.Skype.API.Carbon.CFNumber,+                       Network.Skype.API.Carbon.CFString,+                       Network.Skype.API.Carbon.CarbonEventsCore++  exposed-modules:     Network.Skype.API,+                       Network.Skype.Command.Chat,+                       Network.Skype.Command.ChatMember,+                       Network.Skype.Command.ChatMessage,+                       Network.Skype.Command.Misc,+                       Network.Skype.Command.User,+                       Network.Skype.Command.Utils,+                       Network.Skype.Core,+                       Network.Skype.Parser,+                       Network.Skype.Parser.Chat,+                       Network.Skype.Parser.ChatMember,+                       Network.Skype.Parser.ChatMessage,+                       Network.Skype.Parser.Types,+                       Network.Skype.Parser.User,+                       Network.Skype.Protocol,+                       Network.Skype.Protocol.Chat,+                       Network.Skype.Protocol.ChatMember,+                       Network.Skype.Protocol.ChatMessage,+                       Network.Skype.Protocol.Misc,+                       Network.Skype.Protocol.Types,+                       Network.Skype.Protocol.User+  build-depends:       attoparsec >=0.10,+                       base >=4.2 && <5.0,+                       bytestring >=0.10,+                       lifted-base >=0.2,+                       monad-control >=0.3,+                       transformers-base >=0.4,+                       mtl >=2.0,+                       stm >=2.4,+                       text >=0.11,+                       time >=1.3,+                       word8 >=0.0.4+  hs-source-dirs:      src+  default-language:    Haskell2010+  default-extensions:  DeriveDataTypeable,+                       ExistentialQuantification,+                       FlexibleContexts,+                       FlexibleInstances,+                       GeneralizedNewtypeDeriving,+                       ImpredicativeTypes,+                       MultiParamTypeClasses,+                       NoMonomorphismRestriction,+                       OverloadedStrings,+                       RankNTypes,+                       ScopedTypeVariables,+                       TypeFamilies,+                       UndecidableInstances+  ghc-options:         -Wall++Source-Repository head+  type:     git+  location: https://github.com/emonkak/skype4hs
+ src/Network/Skype/API.hs view
@@ -0,0 +1,19 @@+{-# OPTIONS_GHC -cpp #-}++module Network.Skype.API (+  Connection,+  connect+) where++import Network.Skype.Core++#if defined(darwin_HOST_OS)+import qualified Network.Skype.API.Carbon as API+#else+import qualified Network.Skype.API.X11 as API+#endif++type Connection = API.Connection++connect :: ApplicationName -> IO API.Connection+connect = API.connect
+ src/Network/Skype/API/Carbon.hs view
@@ -0,0 +1,167 @@+module Network.Skype.API.Carbon (+  Connection,+  connect+) where++import Control.Applicative+import Control.Concurrent (ThreadId, forkIO)+import Control.Concurrent.STM.TChan (TChan, newBroadcastTChanIO, writeTChan)+import Control.Concurrent.STM.TMVar+import Control.Monad (when)+import Control.Monad.Error (Error, strMsg)+import Control.Monad.Error.Class (MonadError, throwError)+import Control.Monad.Reader (ReaderT, asks)+import Control.Monad.STM (atomically)+import Control.Monad.Trans (MonadIO, liftIO)+import Data.Maybe+import Foreign hiding (addForeignPtrFinalizer)+import Foreign.Concurrent (addForeignPtrFinalizer)+import Network.Skype.API.Carbon.CFBase+import Network.Skype.API.Carbon.CFDictionary+import Network.Skype.API.Carbon.CFNotificationCenter+import Network.Skype.API.Carbon.CFNumber+import Network.Skype.API.Carbon.CFString+import Network.Skype.API.Carbon.CarbonEventsCore+import Network.Skype.Core++type ClientID = Int+type ClientName = CFString++data Connection = Connection+  { skypeClientID :: TMVar ClientID+  , skypeNotificationChan :: TChan Notification+  , skypeNotificationCenter :: NotificationCenter+  , skypeThread :: ThreadId+  }++instance MonadIO m => MonadSkype (ReaderT Connection m) where+  sendCommand command = do+    center <- asks skypeNotificationCenter+    clientID <- asks skypeClientID >>= liftIO . atomically . readTMVar+    liftIO $ sendTo center clientID command++  getNotificationChan = asks skypeNotificationChan++connect :: (Error e, MonadIO m, MonadError e m)+        => ApplicationName+        -> m Connection+connect appName = do+  connection <- liftIO $ newConnection appName+  clientID <- liftIO $ atomically $ readTMVar $ skypeClientID connection++  when (clientID <= 0) $ throwError $ strMsg "Couldn't connect to Skype client."++  liftIO $ addForeignPtrFinalizer+    (getNotificationCenter $ skypeNotificationCenter connection)+    (disconnectFrom (skypeNotificationCenter connection) clientID)++  return connection++newConnection :: ApplicationName -> IO Connection+newConnection appName = do+  clientName <- newCFString appName >>= newForeignPtr p_CFRelease+  clientIDVar <- newEmptyTMVarIO+  notificatonChan <- newBroadcastTChanIO++  center <- getDistributedCenter clientName++  addObserver center "SKSkypeAPINotification" $ notificationCallback clientIDVar notificatonChan+  addObserver center "SKSkypeAttachResponse" $ attachResponseCallback clientIDVar clientName++  threadID <- forkIO $ c_RunCurrentEventLoop eventDurationForever++  attachTo center clientName++  return Connection+    { skypeClientID = clientIDVar+    , skypeNotificationChan = notificatonChan+    , skypeNotificationCenter = center+    , skypeThread = threadID+    }++disconnectFrom :: NotificationCenter -> ClientID -> IO ()+disconnectFrom center clientID =+  withNotificationCenter center $ \center_ptr ->+  withCFNumber clientID $ \clientID_ptr -> do+    userInfo <- newCFDictionary+      [ ("SKYPE_API_CLIENT_ID" :: CFStringRef, castPtr clientID_ptr) ]++    c_CFNotificationCenterPostNotification+      center_ptr+      "SKSkypeAPIDetachRequest"+      nullPtr+      userInfo+      True++    c_CFRelease userInfo++attachTo :: NotificationCenter -> ForeignPtr ClientName -> IO ()+attachTo center clientName =+  withNotificationCenter center $ \center_ptr ->+  withForeignPtr clientName $ \clientName_ptr ->+    c_CFNotificationCenterPostNotification+      center_ptr+      "SKSkypeAPIAttachRequest"+      clientName_ptr+      nullPtr+      True++sendTo :: NotificationCenter -> ClientID -> Command -> IO ()+sendTo center clientID command =+  withNotificationCenter center $ \center_ptr ->+  withCFString command $ \command_ptr ->+  withCFNumber clientID $ \clientID_ptr -> do+    userInfo <- newCFDictionary+      [ ("SKYPE_API_COMMAND" :: CFStringRef, castPtr command_ptr)+      , ("SKYPE_API_CLIENT_ID", castPtr clientID_ptr)+      ]++    c_CFNotificationCenterPostNotification+      center_ptr+      "SKSkypeAPICommand"+      nullPtr+      userInfo+      True++    c_CFRelease userInfo++notificationCallback :: TMVar ClientID+                     -> TChan Notification+                     -> CFNotificationCallback observer object CFString value+notificationCallback clientIDVar notificatonChan _ _ _ _ userInfo = do+  maybeClientID <- atomically $ tryReadTMVar clientIDVar++  case maybeClientID of+    Just clientID -> do+      otherClientID <- getClientID++      when (clientID == otherClientID) $+        getNotification >>= atomically . writeTChan notificatonChan++    Nothing -> return ()+  where+    getClientID = c_CFDictionaryGetValue userInfo "SKYPE_API_CLIENT_ID" >>=+                  fromCFNumber . castPtr++    getNotification = c_CFDictionaryGetValue userInfo "SKYPE_API_NOTIFICATION_STRING" >>=+                      fromCFString . castPtr++attachResponseCallback :: TMVar ClientID+                       -> ForeignPtr ClientName+                       -> CFNotificationCallback observer object CFString value+attachResponseCallback clientIDVar clientName _ _ _ _ userInfo = do+  comparisonResult <- withForeignPtr clientName $ \clientName_ptr -> do+    otherClientName <- getClientName+    c_CFStringCompare clientName_ptr otherClientName compareDefault++  when (comparisonResult == compareEqualTo) $ do+    maybeClientID <- getClientID+    atomically $ putTMVar clientIDVar $ fromMaybe 0 maybeClientID+  where+    getClientName = castPtr <$> c_CFDictionaryGetValue userInfo "SKYPE_API_CLIENT_NAME"++    getClientID = do+      clientID_ptr <- c_CFDictionaryGetValue userInfo "SKYPE_API_ATTACH_RESPONSE"+      if clientID_ptr == nullPtr+        then pure Nothing+        else Just <$> fromCFNumber (castPtr clientID_ptr)
+ src/Network/Skype/API/Carbon/CFBase.hsc view
@@ -0,0 +1,34 @@+module Network.Skype.API.Carbon.CFBase where++#include "CoreFoundation/CFBase.h"++import Foreign hiding (unsafePerformIO)+import Foreign.C.Types+import System.IO.Unsafe++type CFIndex = Int32++data CFAllocator++type CFAllocatorRef = Ptr CFAllocator++defaultAllocator :: CFAllocatorRef+defaultAllocator = unsafePerformIO $ peek p_CFAllocatorDefault++foreign import ccall unsafe "&kCFAllocatorDefault"+  p_CFAllocatorDefault :: Ptr CFAllocatorRef++foreign import ccall unsafe "CFRelease"+  c_CFRelease :: Ptr a -> IO ()++foreign import ccall unsafe "&CFRelease"+  p_CFRelease :: FunPtr (Ptr a -> IO ())++newtype CFComparisonResult = CFComparisonResult CInt+  deriving (Eq, Show)++#{enum CFComparisonResult, CFComparisonResult+     , compareLessThan    = kCFCompareLessThan+     , compareEqualTo     = kCFCompareEqualTo+     , compareGreaterThan = kCFCompareGreaterThan+}
+ src/Network/Skype/API/Carbon/CFDictionary.hsc view
@@ -0,0 +1,48 @@+module Network.Skype.API.Carbon.CFDictionary where++#include "CoreFoundation/CFDictionary.h"++import Foreign+import Network.Skype.API.Carbon.CFBase++data CFDictionary key value++type CFDictionaryRef key value = Ptr (CFDictionary key value)++newtype CFDictionaryKeyCallBacks =+  CFDictionaryKeyCallBacks (Ptr CFDictionaryKeyCallBacks)++newtype CFDictionaryValueCallBacks =+  CFDictionaryValueCallBacks (Ptr CFDictionaryValueCallBacks)++newCFDictionary :: [(Ptr key, Ptr value)] -> IO (CFDictionaryRef key value)+newCFDictionary elements =+  withArrayLen ks $ \len ks_p ->+  withArray    vs $ \vs_p ->+  c_CFDictionaryCreate defaultAllocator+                       ks_p+                       vs_p+                       (fromIntegral len)+                       p_CFTypeDictionaryKeyCallBacks+                       p_CFTypeDictionaryValueCallBacks+  where (ks, vs) = unzip elements++foreign import ccall unsafe "&kCFTypeDictionaryKeyCallBacks"+  p_CFTypeDictionaryKeyCallBacks :: CFDictionaryKeyCallBacks++foreign import ccall unsafe "&kCFTypeDictionaryValueCallBacks"+  p_CFTypeDictionaryValueCallBacks :: CFDictionaryValueCallBacks++foreign import ccall unsafe "CFDictionaryCreate"+  c_CFDictionaryCreate :: CFAllocatorRef+                       -> Ptr (Ptr key)+                       -> Ptr (Ptr value)+                       -> CFIndex+                       -> CFDictionaryKeyCallBacks+                       -> CFDictionaryValueCallBacks+                       -> IO (CFDictionaryRef key value)++foreign import ccall unsafe "CFDictionaryGetValue"+  c_CFDictionaryGetValue :: CFDictionaryRef key value+                         -> Ptr key+                         -> IO (Ptr value)
+ src/Network/Skype/API/Carbon/CFNotificationCenter.hsc view
@@ -0,0 +1,104 @@+module Network.Skype.API.Carbon.CFNotificationCenter where++#include "CoreFoundation/CFNotificationCenter.h"++import Data.IORef+import Foreign hiding (addForeignPtrFinalizer, newForeignPtr)+import Foreign.C.Types+import Foreign.Concurrent+import Network.Skype.API.Carbon.CFDictionary+import Network.Skype.API.Carbon.CFString++data NotificationCenter = forall callback observer. NotificationCenter+  { getNotificationCenter :: ForeignPtr CFNotificationCenter+  , getCallbacks :: IORef [FunPtr callback]+  , getObserver :: ForeignPtr observer+  }++withNotificationCenter :: NotificationCenter -> (CFNotificationCenterRef -> IO a) -> IO a+withNotificationCenter (NotificationCenter center _ _) action =+  withForeignPtr center action++getDistributedCenter :: ForeignPtr a -> IO NotificationCenter+getDistributedCenter observer = do+  callbacks <- newIORef []+  center_ptr <- c_CFNotificationCenterGetDistributedCenter+  center <- newForeignPtr center_ptr $ do+    withForeignPtr observer $ c_CFNotificationCenterRemoveEveryObserver center_ptr+    readIORef callbacks >>= mapM_ freeHaskellFunPtr+  return $ NotificationCenter center callbacks observer++addObserver :: NotificationCenter+            -> CFStringRef+            -> CFNotificationCallback observer object key value+            -> IO ()+addObserver (NotificationCenter center callbacks observer) name callback =+  withForeignPtr center $ \center_ptr ->+  withForeignPtr observer $ \observer_ptr -> do+    callback_ptr <- wrapCFNotificationCallback callback+    c_CFNotificationCenterAddObserver+      center_ptr+      (castPtr observer_ptr)+      callback_ptr+      name+      nullPtr+      suspensionBehaviorDeliverImmediately+    atomicModifyIORef' callbacks (\cs -> (castFunPtr callback_ptr : cs, ()))++data CFNotificationCenter++type CFNotificationCenterRef = Ptr CFNotificationCenter++type CFNotificationCallback observer object key value =+     CFNotificationCenterRef+  -> Ptr observer+  -> CFStringRef  -- name+  -> Ptr object+  -> CFDictionaryRef key value  -- userInfo+  -> IO ()++newtype CFNotificationSuspensionBehavior = CFNotificationSuspensionBehavior CInt+  deriving (Eq, Show)++#{enum CFNotificationSuspensionBehavior, CFNotificationSuspensionBehavior+     , suspensionBehaviorDrop               = CFNotificationSuspensionBehaviorDrop+     , suspensionBehaviorCoalesce           = CFNotificationSuspensionBehaviorCoalesce+     , suspensionBehaviorHold               = CFNotificationSuspensionBehaviorHold+     , suspensionBehaviorDeliverImmediately = CFNotificationSuspensionBehaviorDeliverImmediately+};++foreign import ccall unsafe "CFNotificationCenterGetDistributedCenter"+  c_CFNotificationCenterGetDistributedCenter :: IO CFNotificationCenterRef++foreign import ccall unsafe "CFNotificationCenterAddObserver"+  c_CFNotificationCenterAddObserver :: CFNotificationCenterRef+                                    -> Ptr observer+                                    -> FunPtr (CFNotificationCallback observer object key value)+                                    -> CFStringRef+                                    -> Ptr object+                                    -> CFNotificationSuspensionBehavior+                                    -> IO ()++foreign import ccall unsafe "CFNotificationCenterRemoveObserver"+  c_CFNotificationCenterRemoveObserver :: CFNotificationCenterRef+                                       -> Ptr observer+                                       -> CFStringRef+                                       -> Ptr object+                                       -> IO ()++foreign import ccall unsafe "CFNotificationCenterRemoveEveryObserver"+  c_CFNotificationCenterRemoveEveryObserver :: CFNotificationCenterRef+                                            -> Ptr observer+                                            -> IO ()++foreign import ccall unsafe "CFNotificationCenterPostNotification"+  c_CFNotificationCenterPostNotification :: CFNotificationCenterRef+                                         -> CFStringRef+                                         -> Ptr object+                                         -> CFDictionaryRef key value+                                         -> Bool  -- deliverImmediately+                                         -> IO ()++foreign import ccall "wrapper"+  wrapCFNotificationCallback :: CFNotificationCallback observer object key value+                             -> IO (FunPtr (CFNotificationCallback observer object key value))
+ src/Network/Skype/API/Carbon/CFNumber.hsc view
@@ -0,0 +1,67 @@+module Network.Skype.API.Carbon.CFNumber where++#include "CoreFoundation/CFNumber.h"++import Foreign+import Foreign.C.Types+import Network.Skype.API.Carbon.CFBase++data CFNumber++type CFNumberRef = Ptr CFNumber++class CFNumberFactory a where+  fromCFNumber :: CFNumberRef -> IO a++  newCFNumber :: a -> IO CFNumberRef++instance (Integral a) => CFNumberFactory a where+  fromCFNumber number = alloca $ \(ptr :: Ptr CInt) -> do+    _ <- c_CFNumberGetValue number intType ptr+    fromIntegral `fmap` peek ptr++  newCFNumber value = alloca $ \ptr -> do+    poke ptr (fromIntegral value :: CInt)+    c_CFNumberCreate defaultAllocator intType ptr++withCFNumber :: (CFNumberFactory a) => a -> (CFNumberRef -> IO b) -> IO b+withCFNumber source action = do+  number <- newCFNumber source+  result <- action number+  c_CFRelease number+  return result++newtype CFNumberType = CFNumberType CInt+  deriving (Eq, Show)++#{enum CFNumberType, CFNumberType+     , sInt8Type     = kCFNumberSInt8Type+     , sInt16Type    = kCFNumberSInt16Type+     , sInt32Type    = kCFNumberSInt32Type+     , sInt64Type    = kCFNumberSInt64Type+     , float32Type   = kCFNumberFloat32Type+     , float64Type   = kCFNumberFloat64Type+     , charType      = kCFNumberCharType+     , shortType     = kCFNumberShortType+     , intType       = kCFNumberIntType+     , longType      = kCFNumberLongType+     , longLongType  = kCFNumberLongLongType+     , floatType     = kCFNumberFloatType+     , doubleType    = kCFNumberDoubleType+     , cfIndexType   = kCFNumberCFIndexType+     , nsIntegerType = kCFNumberNSIntegerType+     , cgFloatType   = kCFNumberCGFloatType+     , maxType       = kCFNumberMaxType+}++foreign import ccall unsafe "CFNumberCreate"+  c_CFNumberCreate :: CFAllocatorRef  -- allocator+                   -> CFNumberType  -- theType+                   -> Ptr value  -- valuePtr+                   -> IO CFNumberRef++foreign import ccall unsafe "CFNumberGetValue"+  c_CFNumberGetValue :: CFNumberRef  -- number+                     -> CFNumberType  -- theType+                     -> Ptr value  -- valuePtr+                     -> IO Bool
+ src/Network/Skype/API/Carbon/CFString.hsc view
@@ -0,0 +1,156 @@+module Network.Skype.API.Carbon.CFString where++#include "CoreFoundation/CFString.h"++import Data.String+import Foreign+import Foreign.C.String+import Foreign.C.Types+import Network.Skype.API.Carbon.CFBase+import System.IO.Unsafe++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Unsafe as BS++data CFString++type CFStringRef = Ptr CFString++class CFStringFactory a where+  newCFString :: a -> IO CFStringRef++  fromCFString :: CFStringRef -> IO a++instance CFStringFactory CString where+  newCFString cs = c_CFStringCreateWithCString defaultAllocator+                                               cs+                                               encodingUTF8++  fromCFString source = do+    len <- c_CFStringGetLength source+    let bufferSize = c_CFStringGetMaximumSizeForEncoding len encodingUTF8 + 1+    bufferPtr <- mallocArray $ fromIntegral bufferSize+    _ <- c_CFStringGetCString source bufferPtr bufferSize encodingUTF8+    return bufferPtr++instance CFStringFactory String where+  newCFString str = withCStringLen str $ \(ptr, len) -> do+    c_CFStringCreateWithBytes defaultAllocator+                              (castPtr ptr)+                              (fromIntegral len)+                              encodingUTF8+                              False++  fromCFString source = do+    cs <- fromCFString source+    result <- peekCString cs+    free cs+    return result++instance CFStringFactory BS.ByteString where+  newCFString bs = BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> do+    c_CFStringCreateWithBytes defaultAllocator+                              (castPtr ptr)+                              (fromIntegral len)+                              encodingUTF8+                              False++  fromCFString source = fromCFString source >>= BS.unsafePackCString++instance CFStringFactory BL.ByteString where+  newCFString bs = newCFString $ BL.toStrict bs++  fromCFString source = BL.fromStrict `fmap` fromCFString source++instance IsString CFStringRef where+  fromString = unsafeMakeConstantString++newtype CFStringEncoding = CFStringEncoding CInt+  deriving (Eq, Show)++#{enum CFStringEncoding, CFStringEncoding+     , encodingMacRoman      = kCFStringEncodingMacRoman+     , encodingWindowsLatin1 = kCFStringEncodingWindowsLatin1+     , encodingISOLatin1     = kCFStringEncodingISOLatin1+     , encodingNextStepLatin = kCFStringEncodingNextStepLatin+     , encodingASCII         = kCFStringEncodingASCII+     , encodingUnicode       = kCFStringEncodingUnicode+     , encodingUTF8          = kCFStringEncodingUTF8+     , encodingNonLossyASCII = kCFStringEncodingNonLossyASCII++     , encodingUTF16         = kCFStringEncodingUTF16+     , encodingUTF16BE       = kCFStringEncodingUTF16BE+     , encodingUTF16LE       = kCFStringEncodingUTF16LE++     , encodingUTF32         = kCFStringEncodingUTF32+     , encodingUTF32BE       = kCFStringEncodingUTF32BE+     , encodingUTF32LE       = kCFStringEncodingUTF32LE+}++makeConstantString :: String -> IO CFStringRef+makeConstantString str = withCAString str $ c_CFStringMakeConstantString++unsafeMakeConstantString :: String -> CFStringRef+unsafeMakeConstantString = unsafeDupablePerformIO . makeConstantString++withCFString :: (CFStringFactory a) => a -> (CFStringRef -> IO b) -> IO b+withCFString source action = do+  string <- newCFString source+  result <- action string+  c_CFRelease string+  return result++foreign import ccall unsafe "__CFStringMakeConstantString"+  c_CFStringMakeConstantString :: CString -> IO CFStringRef++foreign import ccall unsafe "CFStringCreateWithBytes"+  c_CFStringCreateWithBytes :: CFAllocatorRef  -- alloc+                            -> Ptr Word8  -- bytes+                            -> CFIndex  -- numBytes+                            -> CFStringEncoding  -- encoding+                            -> Bool  -- isExternalRepresentation+                            -> IO CFStringRef++foreign import ccall unsafe "CFStringCreateWithCString"+  c_CFStringCreateWithCString :: CFAllocatorRef  -- alloc+                              -> CString  -- cStr+                              -> CFStringEncoding  -- encoding+                              -> IO CFStringRef++foreign import ccall unsafe "CFStringGetCString"+  c_CFStringGetCString :: CFStringRef  -- theString+                       -> CString  -- buffer+                       -> CFIndex  -- bufferSize+                       -> CFStringEncoding  -- encoding+                       -> IO Bool++foreign import ccall unsafe "CFStringGetLength"+  c_CFStringGetLength :: CFStringRef -> IO CFIndex++foreign import ccall unsafe "CFStringGetMaximumSizeForEncoding"+  c_CFStringGetMaximumSizeForEncoding :: CFIndex  -- length+                                      -> CFStringEncoding  -- encoding+                                      -> CFIndex++newtype CFStringCompareFlags = CFStringCompareFlags CInt+  deriving (Bits, Eq, Show)++#{enum CFStringCompareFlags, CFStringCompareFlags+     , compareDefault              = 0+     , compareCaseInsensitive      = kCFCompareCaseInsensitive+     , compareBackwards            = kCFCompareBackwards+     , compareAnchored             = kCFCompareAnchored+     , compareNonliteral           = kCFCompareNonliteral+     , compareLocalized            = kCFCompareLocalized+     , compareNumerically          = kCFCompareNumerically+     , compareDiacriticInsensitive = kCFCompareDiacriticInsensitive+     , compareWidthInsensitive     = kCFCompareWidthInsensitive+     , compareForcedOrdering       = kCFCompareForcedOrdering+}++foreign import ccall unsafe "CFStringCompare"+  c_CFStringCompare :: CFStringRef  -- theString1+                    -> CFStringRef  -- theString2+                    -> CFStringCompareFlags  -- compareOptions+                    -> IO CFComparisonResult
+ src/Network/Skype/API/Carbon/CarbonEventsCore.hsc view
@@ -0,0 +1,13 @@+module Network.Skype.API.Carbon.CarbonEventsCore where++#include "Carbon/Carbon.h"++import Foreign.C.Types++type EventTimeout = CDouble++eventDurationForever :: EventTimeout+eventDurationForever = #{const kEventDurationForever}++foreign import ccall "RunCurrentEventLoop"+  c_RunCurrentEventLoop :: EventTimeout -> IO ()
+ src/Network/Skype/API/X11.hsc view
@@ -0,0 +1,246 @@+module Network.Skype.API.X11 (+  Connection,+  DisplayAddress,+  connect,+  connectTo+) where++#include <X11/Xlib.h>++import Control.Concurrent (ThreadId, forkIO)+import Control.Concurrent.STM.TChan (TChan, newBroadcastTChanIO, writeTChan)+import Control.Exception (IOException)+import Control.Exception.Lifted (catch)+import Control.Monad (mplus)+import Control.Monad.Error (Error, strMsg)+import Control.Monad.Error.Class (MonadError, throwError)+import Control.Monad.Reader (ReaderT, asks)+import Control.Monad.STM (atomically)+import Control.Monad.Trans (MonadIO, liftIO)+import Control.Monad.Trans.Control (MonadBaseControl, control)+import Data.Maybe (listToMaybe)+import Data.Monoid (mappend, mempty)+import Foreign hiding (addForeignPtrFinalizer, newForeignPtr)+import Foreign.C.Types+import Foreign.Concurrent+import System.Environment (getEnv)+import Network.Skype.Command.Misc (authenticate)+import Network.Skype.Core++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Lazy.Builder as BS+import qualified Data.ByteString.Unsafe as BS+import qualified Graphics.X11.Xlib as X+import qualified Graphics.X11.Xlib.Extras as X++data Connection = Connection+  { skypeAPI :: SkypeAPI+  , skypeNotificatonChan :: TChan Notification+  , skypeThread :: ThreadId+  }++data SkypeAPI = SkypeAPI+  { skypeDisplay :: ForeignPtr X.Display+  , skypeWindow :: X.Window+  , skypeInstanceWindow :: X.Window+  , skypeMessageBeginAtom :: X.Atom+  , skypeMessageContinueAtom :: X.Atom+  }+  deriving (Show, Eq)++type DisplayAddress = String++instance MonadIO m => MonadSkype (ReaderT Connection m) where+  sendCommand command = asks skypeAPI >>= liftIO . flip sendTo command++  getNotificationChan = asks skypeNotificatonChan++openDisplay :: (MonadBaseControl IO m, MonadIO m, MonadError IOException m)+            => DisplayAddress+            -> m (ForeignPtr X.Display)+openDisplay address = do+  display'@(X.Display display) <- liftIO (X.openDisplay address) `catch` throwError+  liftIO $ newForeignPtr display $ X.closeDisplay display'++getDisplayAddress :: (MonadBaseControl IO m, MonadIO m, MonadError IOException m)+                  => m DisplayAddress+getDisplayAddress = liftIO (getEnv "SKYPEDISPLAY" `mplus` getEnv "DISPLAY")+                    `catch` throwError++createWindow :: (Error e, MonadIO m, MonadError e m)+             => X.Display -> X.Window -> m X.Window+createWindow display root = do+  let screen = X.defaultScreen display+      pixel  = X.blackPixel display screen++  window <- liftIO $ X.createSimpleWindow display root 0 0 1 1 0 pixel pixel++  if window == X.none+     then throwError $ strMsg "Can't create the window"+     else return window++createAtom :: (Error e, MonadIO m, MonadError e m)+           => X.Display -> String -> m X.Atom+createAtom display name = do+  atom <- liftIO $ X.internAtom display name True++  if atom == X.none+    then throwError $ strMsg $ "Can't create the atom: " ++ name+    else return atom++getSkypeInstanceWindow :: (Error e, MonadIO m, MonadError e m)+                       => X.Display -> X.Window -> m X.Window+getSkypeInstanceWindow display root = do+  instanceAtom <- createAtom display "_SKYPE_INSTANCE"++  status <- liftIO $ X.getWindowProperty32 display instanceAtom root++  case status >>= listToMaybe of+    Nothing       -> throwError $ strMsg "Skype instance window is not found"+    Just property -> return $ fromIntegral property .&. 0xffffffff++connect :: (MonadBaseControl IO m, MonadIO m, MonadError IOException m)+        => ApplicationName+        -> m Connection+connect appName = flip connectTo appName =<< getDisplayAddress++connectTo :: (MonadBaseControl IO m, MonadIO m, MonadError IOException m)+          => DisplayAddress+          -> ApplicationName+          -> m Connection+connectTo address appName = do+  api <- createAPI address+  notificationChan <- liftIO newBroadcastTChanIO+  thread <- liftIO $ forkIO $+            runEventLoop api $ atomically . writeTChan notificationChan++  let connection = Connection+                   { skypeAPI = api+                   , skypeNotificatonChan = notificationChan+                   , skypeThread = thread+                   }++  result <- runSkype connection $ authenticate appName++  either (throwError . strMsg . show) (const $ return connection) result++createAPI :: (MonadBaseControl IO m, MonadIO m, MonadError IOException m)+          => String+          -> m SkypeAPI+createAPI address = do+  display <- openDisplay address++  withForeignPtr' display $ \display_ptr -> do+    let display' = X.Display display_ptr+    let root = X.defaultRootWindow display'++    window <- createWindow display' root++    liftIO $ addForeignPtrFinalizer display $+             X.destroyWindow display' window++    instanceWindow <- getSkypeInstanceWindow display' root++    messageBeginAtom <- createAtom display' "SKYPECONTROLAPI_MESSAGE_BEGIN"+    messageContinueAtom <- createAtom display' "SKYPECONTROLAPI_MESSAGE"++    return $ SkypeAPI+      { skypeDisplay             = display+      , skypeWindow              = window+      , skypeInstanceWindow      = instanceWindow+      , skypeMessageBeginAtom    = messageBeginAtom+      , skypeMessageContinueAtom = messageContinueAtom+      }++sendTo :: SkypeAPI -> BS.ByteString -> IO ()+sendTo api message =+  X.allocaXEvent $ \event_ptr ->+  withForeignPtr (skypeDisplay api) $ \display_ptr -> do+    #{poke XClientMessageEvent, type}         event_ptr (#{const ClientMessage} :: CInt)+    #{poke XClientMessageEvent, display}      event_ptr display_ptr+    #{poke XClientMessageEvent, window}       event_ptr $ skypeWindow api+    #{poke XClientMessageEvent, message_type} event_ptr $ skypeMessageBeginAtom api+    #{poke XClientMessageEvent, format}       event_ptr (8 :: CInt)  -- 8 bit values++    let display = X.Display display_ptr++    case splitPerChunk message of+      []       -> return ()+      (bs:[])  -> send display event_ptr bs+      (bs:bss) -> do+        send display event_ptr bs++        #{poke XClientMessageEvent, message_type} event_ptr $ skypeMessageContinueAtom api++        mapM_ (send display event_ptr) bss++  where+    send display event_ptr chunk = do+      let data_ptr = #{ptr XClientMessageEvent, data} event_ptr++      BS.unsafeUseAsCStringLen chunk $ uncurry $ copyArray data_ptr++      X.sendEvent display (skypeInstanceWindow api) False 0 event_ptr+      X.flush display++    splitPerChunk bs+      | BS.length bs == messageChunkSize = bs : BS.singleton 0 : []+      | BS.length bs < messageChunkSize  = BS.snoc bs 0 : []+      | otherwise                        = let (xs, ys) = BS.splitAt messageChunkSize bs+                                           in  xs : splitPerChunk ys++-- | Generalized version of 'withForeignPtr'.+withForeignPtr' :: (MonadBaseControl IO m) => ForeignPtr a -> (Ptr a -> m b) -> m b+withForeignPtr' fp action =+  control $ \runInIO -> withForeignPtr fp $ runInIO . action++ptrIndex :: (Eq a, Storable a) => Ptr a -> a -> Int -> IO (Maybe Int)+ptrIndex ptr value n = go 0 value $ take n $ iterate (flip plusPtr 1) ptr+  where+    go _ _ [] = return Nothing+    go acc x (y:ys) = do+      y' <- peek y+      if y' == x+        then return $ Just acc+        else go (acc + 1) x ys++messageChunkSize :: Int+messageChunkSize = #{const sizeof(((XClientMessageEvent *) 0)->data.b) / sizeof(((XClientMessageEvent *) 0)->data.b[0])}+{-# INLINE messageChunkSize #-}++runEventLoop :: SkypeAPI -> (BL.ByteString -> IO ()) -> IO ()+runEventLoop api action =+  X.allocaXEvent $ \event_ptr ->+  withForeignPtr (skypeDisplay api) $ \display_ptr ->+  loop mempty (X.Display display_ptr) event_ptr+  where+    loop builder display event_ptr = do+      X.nextEvent display event_ptr  -- will blocking++      eventType <- #{peek XClientMessageEvent, type} event_ptr++      if eventType == X.clientMessage+      then do+        messageType <- #{peek XClientMessageEvent, message_type} event_ptr++        if messageType == skypeMessageBeginAtom api ||+           messageType == skypeMessageContinueAtom api+        then do+          let data_ptr = #{ptr XClientMessageEvent, data} event_ptr++          maybeIndex <- ptrIndex data_ptr (0 :: CChar) messageChunkSize++          case maybeIndex of+            Just i -> do+              bs <- BS.packCStringLen (data_ptr, i)+              action $ BS.toLazyByteString $ builder `mappend` BS.byteString bs+              loop mempty display event_ptr++            Nothing -> do+              bs <- BS.packCStringLen (data_ptr, messageChunkSize)+              loop (builder `mappend` BS.byteString bs) display event_ptr+        else+          loop builder display event_ptr+      else+        loop builder display event_ptr
+ src/Network/Skype/Command/Chat.hs view
@@ -0,0 +1,245 @@+module Network.Skype.Command.Chat where++import Control.Monad.Trans+import Control.Monad.Trans.Control+import Data.Monoid ((<>))+import Network.Skype.Command.Utils+import Network.Skype.Core+import Network.Skype.Protocol++import qualified Data.ByteString.Char8 as BC+import qualified Data.Text.Encoding as T++-- | Changes a chat topic.+setTopic :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+         => ChatID+         -> ChatTopic+         -> SkypeT m ()+setTopic chatID chatTopic = executeCommandWithID command $ \response ->+  case response of+    AlterChat AlterChatSetTopic -> return $ Just ()+    _                           -> return Nothing+  where+    command = "ALTER CHAT " <> chatID+                            <> " SETTOPIC "+                            <> T.encodeUtf8 chatTopic++-- | Adds new members to a chat.+addMembers :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+           => ChatID+           -> [UserID]+           -> SkypeT m ()+addMembers _ [] = return ()+addMembers chatID userIDs = executeCommandWithID command $ \response ->+  case response of+    AlterChat AlterChatAddMembers -> return $ Just ()+    _                             -> return Nothing+  where+    command = "ALTER CHAT " <> chatID+                            <> " ADDMEMBERS "+                            <> BC.intercalate ", " userIDs++-- | Joins to a chat.+joinChat :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+         => ChatID+         -> SkypeT m ()+joinChat chatID = executeCommandWithID command $ \response ->+  case response of+    AlterChat AlterChatJoin -> return $ Just ()+    _                       -> return Nothing+  where+    command = "ALTER CHAT " <> chatID <> " JOIN"++-- | Leaves to a chat.+leaveChat :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+          => ChatID+          -> SkypeT m ()+leaveChat chatID = executeCommandWithID command $ \response ->+  case response of+    AlterChat AlterChatLeave -> return $ Just ()+    _                        -> return Nothing+  where+    command = "ALTER CHAT " <> chatID <> " LEAVE"++-- | Sends a message to this chat.+sendMessage :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+            => ChatID+            -> ChatMessageBody+            -> SkypeT m ChatMessageID+sendMessage chatID messageBody = executeCommandWithID command $ \response ->+  case response of+    ChatMessage chatMessageID _ -> return $ Just chatMessageID+    _                           -> return Nothing+  where+    command = "CHATMESSAGE " <> chatID <> " " <> T.encodeUtf8 messageBody++-- | Returns the timestamp of this chat.+getTimestamp :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+             => ChatID+             -> SkypeT m Timestamp+getTimestamp chatID = executeCommandWithID command $ \response ->+  case response of+    Chat _ (ChatTimestamp timestamp) -> return $ Just timestamp+    _                                -> return Nothing+  where+    command = "GET CHAT " <> chatID <> " TIMESTAMP"++-- | Returns the user who added the current user to chat.+getAdder :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+         => ChatID+         -> SkypeT m (Maybe UserID)+getAdder chatID = executeCommandWithID command $ \response ->+  case response of+    Chat _ (ChatAdder adder) -> return $ Just adder+    _                        -> return Nothing+  where+    command = "GET CHAT " <> chatID <> " ADDER"++-- | Returns the chat status.+getStatus :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+          => ChatID+          -> SkypeT m ChatStatus+getStatus chatID = executeCommandWithID command $ \response ->+  case response of+    Chat _ (ChatStatus status) -> return $ Just status+    _                          -> return Nothing+  where+    command = "GET CHAT " <> chatID <> " STATUS"++-- | Returns the name shown in chat window title.+getAllPosters :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+              => ChatID+              -> SkypeT m [UserID]+getAllPosters chatID = executeCommandWithID command $ \response ->+  case response of+    Chat _ (ChatPosters posters) -> return $ Just posters+    _                            -> return Nothing+  where+    command = "GET CHAT " <> chatID <> " POSTERS"++-- | Returns all users who have been there.+getAllMembers :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+              => ChatID+              -> SkypeT m [UserID]+getAllMembers chatID = executeCommandWithID command $ \response ->+  case response of+    Chat _ (ChatMembers members) -> return $ Just members+    _                            -> return Nothing+  where+    command = "GET CHAT " <> chatID <> " MEMBERS"++-- | Returns the chat topic.+getTopic :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+         => ChatID+         -> SkypeT m ChatTopic+getTopic chatID = executeCommandWithID command $ \response ->+  case response of+    Chat _ (ChatTopic topic) -> return $ Just topic+    _                        -> return Nothing+  where+    command = "GET CHAT " <> chatID <> " TOPIC"++-- | Returns the members who have stayed in chat.+getActiveMembers :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                 => ChatID+                 -> SkypeT m [UserID]+getActiveMembers chatID = executeCommandWithID command $ \response ->+  case response of+    Chat _ (ChatActiveMembers members) -> return $ Just members+    _                                  -> return Nothing+  where+    command = "GET CHAT " <> chatID <> " ACTIVEMEMBERS"++-- | Returns the chat window title.+getWindowTitle :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+               => ChatID+               -> SkypeT m ChatWindowTitle+getWindowTitle chatID = executeCommandWithID command $ \response ->+  case response of+    Chat _ (ChatFriendyName name) -> return $ Just name+    _                             -> return Nothing+  where+    command = "GET CHAT " <> chatID <> " FRIENDLYNAME"++-- | Returns all messages in this chat.+getAllMessages :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+               => ChatID+               -> SkypeT m [ChatMessageID]+getAllMessages chatID = executeCommandWithID command $ \response ->+  case response of+    Chat _ (ChatMessages chatMessageIDs) -> return $ Just chatMessageIDs+    _                                    -> return Nothing+  where+    command = "GET CHAT " <> chatID <> " CHATMESSAGES"++-- | Returns recent messages in this chat.+getRecentMessages :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                  => ChatID+                  -> SkypeT m [ChatMessageID]+getRecentMessages chatID = executeCommandWithID command $ \response ->+  case response of+    Chat _ (ChatRecentMessages chatMessageIDs) -> return $ Just chatMessageIDs+    _                                          -> return Nothing+  where+    command = "GET CHAT " <> chatID <> " RECENTCHATMESSAGES"++-- | Indicates if this chat has been bookmarked.+isBookmarked :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+             => ChatID+             -> SkypeT m Bool+isBookmarked chatID = executeCommandWithID command $ \response ->+  case response of+    Chat _ (ChatBookmarked isbookmarked) -> return $ Just isbookmarked+    _                                    -> return Nothing+  where+    command = "GET CHAT " <> chatID <> " BOOKMARKED"++-- | Create a chat.+createChat :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+           => [UserID]+           -> SkypeT m (ChatID, ChatStatus)+createChat userIDs = executeCommandWithID command $ \response ->+  case response of+    Chat chatID (ChatStatus status) -> return $ Just (chatID, status)+    _                               -> return Nothing+  where+    command = "CAHT CREATE " <> BC.intercalate ", " userIDs++-- | Open a chat window.+openChat :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+         => ChatID+         -> SkypeT m ()+openChat chatID = executeCommandWithID command $ \response ->+  case response of+    OpenChat _ -> return $ Just ()+    _          -> return Nothing+  where+    command = "OPEN CHAT " <> chatID++-- | Returns a list of chat IDs.+searchAllChats :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+               => SkypeT m [ChatID]+searchAllChats = searchChats "SEARCH CHATS"++-- | Returns a list of chat IDs that are open in the window.+searchActiveChats :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                  => SkypeT m [ChatID]+searchActiveChats = searchChats "SEARCH ACTIVECHATS"++-- | Returns a list of chat IDs that include unread messages.+searchMissedChats :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                  => SkypeT m [ChatID]+searchMissedChats = searchChats "SEARCH MISSEDCHATS"++-- | Returns a list of recent chat IDs.+searchRecentChats :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                  => SkypeT m [ChatID]+searchRecentChats = searchChats "SEARCH RECENTCHATS"++searchChats :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+            => Command+            -> SkypeT m [ChatID]+searchChats command = executeCommandWithID command $ \response ->+  case response of+    Chats chatIDs          -> return $ Just chatIDs+    _                      -> return Nothing
+ src/Network/Skype/Command/ChatMember.hs view
@@ -0,0 +1,60 @@+module Network.Skype.Command.ChatMember where++import Control.Monad.Trans+import Control.Monad.Trans.Control+import Data.Monoid ((<>))+import Network.Skype.Command.Utils+import Network.Skype.Core+import Network.Skype.Protocol++import qualified Data.ByteString.Char8 as BC++getAllMembers :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+              => ChatID+              -> SkypeT m [ChatMemberID]+getAllMembers chatID = executeCommandWithID command $ \response ->+  case response of+    Chat _ (ChatMemberObjects chatMemberIDs) -> return $ Just chatMemberIDs+    _                                        -> return Nothing+  where+    command = "GET CHAT " <> chatID <> " MEMBEROBJECTS"++getUserID :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+          => ChatMemberID+          -> SkypeT m UserID+getUserID chatMemberID = executeCommandWithID command $ \response ->+  case response of+    ChatMember _ (ChatMemberIdentity userID) -> return $ Just userID+    _                                        -> return Nothing+  where+    command = "GET CHATMEMBER " <> (BC.pack $ show chatMemberID) <> " IDENTITY"++getChatID :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+            => ChatMemberID+            -> SkypeT m ChatID+getChatID chatMemberID = executeCommandWithID command $ \response ->+  case response of+    ChatMember _ (ChatMemberChatName chatID) -> return $ Just chatID+    _                                        -> return Nothing+  where+    command = "GET CHATMEMBER " <> (BC.pack $ show chatMemberID) <> " CHATNAME"++getRole :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+        => ChatMemberID+        -> SkypeT m ChatRole+getRole chatMemberID = executeCommandWithID command $ \response ->+  case response of+    ChatMember _ (ChatMemberRole role) -> return $ Just role+    _                                  -> return Nothing+  where+    command = "GET CHATMEMBER " <> (BC.pack $ show chatMemberID) <> " ROLE"++isActive :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+         => ChatMemberID+         -> SkypeT m Bool+isActive chatMemberID = executeCommandWithID command $ \response ->+  case response of+    ChatMember _ (ChatMemberIsActive active) -> return $ Just active+    _                                        -> return Nothing+  where+    command = "GET CHATMEMBER " <> (BC.pack $ show chatMemberID) <> " IS_ACTIVE"
+ src/Network/Skype/Command/ChatMessage.hs view
@@ -0,0 +1,143 @@+module Network.Skype.Command.ChatMessage where++import Control.Monad.Trans+import Control.Monad.Trans.Control+import Data.Monoid ((<>))+import Network.Skype.Command.Utils+import Network.Skype.Core+import Network.Skype.Protocol++import qualified Data.ByteString.Char8 as BC+import qualified Data.Text.Encoding as T++-- | Returns the time when message was sent.+getTimestamp :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+             => ChatMessageID+             -> SkypeT m Timestamp+getTimestamp chatMessageID = executeCommandWithID command $ \response ->+  case response of+    ChatMessage _ (ChatMessageTimestamp timestamp) -> return $ Just timestamp+    _                                              -> return Nothing+  where+    command = "GET CHATMESSAGE " <> BC.pack (show chatMessageID)+                                 <> " TIMESTAMP"++-- | Returns the skype name of the sender of this message.+getSender :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+          => ChatMessageID+          -> SkypeT m UserID+getSender chatMessageID = executeCommandWithID command $ \response ->+  case response of+    ChatMessage _ (ChatMessageFromHandle userHandle) -> return $ Just userHandle+    _                                                -> return Nothing+  where+    command = "GET CHATMESSAGE " <> BC.pack (show chatMessageID)+                                 <> " FROM_HANDLE"++-- | Returns the displayed name of the sender of this message.+getSenderDisplayName :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                     => ChatMessageID+                     -> SkypeT m UserDisplayName+getSenderDisplayName chatMessageID = executeCommandWithID command $ \response ->+  case response of+    ChatMessage _ (ChatMessageFromDisplayName userHandle) -> return $ Just userHandle+    _                                                     -> return Nothing+  where+    command = "GET CHATMESSAGE " <> BC.pack (show chatMessageID)+                                 <> " FROM_DISPNAME"++-- | Returns the message type.+getType :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+        => ChatMessageID+        -> SkypeT m ChatMessageType+getType chatMessageID = executeCommandWithID command $ \response ->+  case response of+    ChatMessage _ (ChatMessageType messageType) -> return $ Just messageType+    _                                           -> return Nothing+  where+    command = "GET CHATMESSAGE " <> BC.pack (show chatMessageID) <> " TYPE"++-- | Returns the message status.+getStatus :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+          => ChatMessageID+          -> SkypeT m ChatMessageStatus+getStatus chatMessageID = executeCommandWithID command $ \response ->+  case response of+    ChatMessage _ (ChatMessageStatus messageStatus) -> return $ Just messageStatus+    _                                               -> return Nothing+  where+    command = "GET CHATMESSAGE " <> BC.pack (show chatMessageID)+                                 <> " STATUS"++-- | Returns the leave reason.+getLeaveReason :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+               => ChatMessageID+               -> SkypeT m (Maybe ChatMessageLeaveReason)+getLeaveReason chatMessageID = executeCommandWithID command $ \response ->+  case response of+    ChatMessage _ (ChatMessageLeaveReason leaveReason) -> return $ Just leaveReason+    _                                                  -> return Nothing+  where+    command = "GET CHATMESSAGE " <> BC.pack (show chatMessageID)+                                 <> " LEAVEREASON"++-- | Returns the chat which this message belongs.+getChat :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+        => ChatMessageID+        -> SkypeT m ChatID+getChat chatMessageID = executeCommandWithID command $ \response ->+  case response of+    ChatMessage _ (ChatMessageChatName chatID) -> return $ Just chatID+    _                                          -> return Nothing+  where+    command = "GET CHATMESSAGE " <> BC.pack (show chatMessageID)+                                 <> " CHATNAME"++-- | Returns all users that have been added to the chat.+getAllUsers :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+            => ChatMessageID+            -> SkypeT m [UserID]+getAllUsers chatMessageID = executeCommandWithID command $ \response ->+  case response of+    ChatMessage _ (ChatMessageUsers userIDs) -> return $ Just userIDs+    _                                        -> return Nothing+  where+    command = "GET CHATMESSAGE " <> BC.pack (show chatMessageID)+                                 <> " USERS"++-- | Indicates if the chat message is editable.+isEditable :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+           => ChatMessageID+           -> SkypeT m Bool+isEditable chatMessageID = executeCommandWithID command $ \response ->+  case response of+    ChatMessage _ (ChatMessageIsEditable editable) -> return $ Just editable+    _                                              -> return Nothing+  where+    command = "GET CHATMESSAGE " <> BC.pack (show chatMessageID)+                                 <> " IS_EDITABLE"++-- | Returns the content of this chat message.+getBody :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+        => ChatMessageID+        -> SkypeT m ChatMessageBody+getBody chatMessageID = executeCommandWithID command $ \response ->+  case response of+    ChatMessage _ (ChatMessageBody messageBody) -> return $ Just messageBody+    _                                           -> return Nothing+  where+    command = "GET CHATMESSAGE " <> BC.pack (show chatMessageID) <> " BODY"++-- | Sets the content of this chat message.+setBody :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+        => ChatMessageID+        -> ChatMessageBody+        -> SkypeT m ChatMessageBody+setBody chatMessageID content = executeCommandWithID command $ \response ->+  case response of+    ChatMessage _ (ChatMessageBody messageBody) -> return $ Just messageBody+    _                                           -> return Nothing+  where+    command = "SET CHATMESSAGE " <> BC.pack (show chatMessageID)+                                 <> " BODY "+                                 <> T.encodeUtf8 content
+ src/Network/Skype/Command/Misc.hs view
@@ -0,0 +1,29 @@+module Network.Skype.Command.Misc where++import Control.Monad.Error+import Control.Monad.Trans.Control+import Data.Monoid ((<>))+import Network.Skype.Command.Utils+import Network.Skype.Core++import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BC+import qualified Data.ByteString.Lazy as BL++authenticate :: (MonadBaseControl IO m, MonadIO m, MonadSkype m) => BS.ByteString -> SkypeT m ()+authenticate clientName = handleCommand command $ \response ->+  case response of+    "OK"                 -> return $ Just ()+    "CONNSTATUS OFFLINE" -> throwError $ SkypeError 0 command "Skype is offline"+    "ERROR 68"           -> throwError $ SkypeError 0 command "Connection refused"+    _                    -> return Nothing+  where+    command = "NAME " <> clientName++protocol :: (MonadBaseControl IO m, MonadIO m, MonadSkype m) => Int -> SkypeT m ()+protocol version = handleCommand command $ \response ->+  if BL.isPrefixOf "PROTOCOL " response+    then return $ Just ()+    else return Nothing+  where+    command = "PROTOCOL " <> BC.pack (show version)
+ src/Network/Skype/Command/User.hs view
@@ -0,0 +1,391 @@+module Network.Skype.Command.User where++import Control.Monad.Trans+import Control.Monad.Trans.Control+import Data.Monoid ((<>))+import Network.Skype.Command.Utils+import Network.Skype.Core+import Network.Skype.Protocol++import qualified Data.Text.Encoding as T++-- | Gets the full name of the user.+getFullName :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+            => UserID+            -> SkypeT m UserFullName+getFullName userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserFullName fullName) -> return $ Just fullName+    _                              -> return Nothing+  where+    command = "GET USER " <> userID <> " FULLNAME"++-- | Gets the birthdate of the user.+getBirthday :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+            => UserID+            -> SkypeT m (Maybe UserBirthday)+getBirthday userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserBirthday birthday) -> return $ Just birthday+    _                              -> return Nothing+  where+    command = "GET USER " <> userID <> " BIRTHDAY"++-- | Gets the sex of the user.+getSex :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+       => UserID+       -> SkypeT m UserSex+getSex userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserSex sex) -> return $ Just sex+    _                    -> return Nothing+  where+    command = "GET USER " <> userID <> " SEX"++-- | Gets the native language of the user.+getLanguage :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+            => UserID+            -> SkypeT m (Maybe (UserLanguageISOCode, UserLanguage))+getLanguage userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserLanguage language) -> return $ Just language+    _                              -> return Nothing+  where+    command = "GET USER " <> userID <> " LANGUAGE"++-- | Gets the country the user is based.+getCountry :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+           => UserID+           -> SkypeT m (Maybe (UserCountryISOCode, UserCountry))+getCountry userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserCountry country) -> return $ Just country+    _                            -> return Nothing+  where+    command = "GET USER " <> userID <> " COUNTRY"++-- | Gets the province the user is based.+getProvince :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+            => UserID+            -> SkypeT m UserProvince+getProvince userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserProvince province) -> return $ Just province+    _                              -> return Nothing+  where+    command = "GET USER " <> userID <> " PROVINCE"++-- | Gets the city this user is based in.+getCity :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+        => UserID+        -> SkypeT m UserCity+getCity userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserCity city) -> return $ Just city+    _                      -> return Nothing+  where+    command = "GET USER " <> userID <> " CITY"++-- | Gets the home phone number that is in the user profile.+getHomePhone :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+             => UserID+             -> SkypeT m UserPhone+getHomePhone userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserHomePhone phone) -> return $ Just phone+    _                            -> return Nothing+  where+    command = "GET USER " <> userID <> " PHONE_HOME"++-- | Gets the office phone number that is in the user profile.+getOfficePhone :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+             => UserID+             -> SkypeT m UserPhone+getOfficePhone userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserOfficePhone phone) -> return $ Just phone+    _                              -> return Nothing+  where+    command = "GET USER " <> userID <> " PHONE_OFFICE"++-- | Gets the mobile phone number of the user.+getMobilePhone :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                => UserID+                -> SkypeT m UserPhone+getMobilePhone userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserMobilePhone phone) -> return $ Just phone+    _                              -> return Nothing+  where+    command = "GET USER " <> userID <> " PHONE_MOBILE"++-- | Gets the homepage URL of the user.+getHomepage :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+            => UserID+            -> SkypeT m UserHomepage+getHomepage userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserHomepage homepage) -> return $ Just homepage+    _                              -> return Nothing+  where+    command = "GET USER " <> userID <> " HOMEPAGE"++-- | Gets extra information user has provided in his/her profile.+getAbout :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+         => UserID+         -> SkypeT m UserAbout+getAbout userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserAbout about) -> return $ Just about+    _                        -> return Nothing+  where+    command = "GET USER " <> userID <> " ABOUT"++-- | Checks if the user is video-capable.+isVideoCapable :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+               => UserID+               -> SkypeT m Bool+isVideoCapable userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserIsVideoCapable videoCapable) -> return $ Just videoCapable+    _                                        -> return Nothing+  where+    command = "GET USER " <> userID <> " IS_VIDEO_CAPABLE"++-- | Checks if the user is voicemail-capable.+isVoicemailCapable :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                   => UserID+                   -> SkypeT m Bool+isVoicemailCapable userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserIsVoicemailCapable voicemailCapable) -> return $ Just voicemailCapable+    _                                                -> return Nothing+  where+    command = "GET USER " <> userID <> " IS_VOICEMAIL_CAPABLE"++-- | Gets the buddy status of the user.+getBuddyStatus :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+               => UserID+               -> SkypeT m UserBuddyStatus+getBuddyStatus userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserBuddyStatus displayName) -> return $ Just displayName+    _                                    -> return Nothing+  where+    command = "GET USER " <> userID <> " BUDDYSTATUS"++-- | Removes target from contactlist.+removeFromContactList :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                      => UserID+                      -> SkypeT m ()+removeFromContactList userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserBuddyStatus _) -> return $ Just ()+    _                          -> return Nothing+  where+    command = "SET USER " <> userID <> " BUDDYSTATUS 1"++-- | Adds target into contactlist and ask authorization with message.+askAuthorization :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                 => UserID+                 -> UserAuthRequestMessage+                 -> SkypeT m ()+askAuthorization userID message = executeCommandWithID command $ \response ->+  case response of+    User _ (UserBuddyStatus _) -> return $ Just ()+    _                          -> return Nothing+  where+    command = "SET USER " <> userID <> " BUDDYSTATUS 2"+                          <> T.encodeUtf8 message++-- | Checks if the user is authorized in your contactlist.+isAuthorized :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+             => UserID+             -> SkypeT m Bool+isAuthorized userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserIsAuthorized authorized) -> return $ Just authorized+    _                                    -> return Nothing+  where+    command = "GET USER " <> userID <> " ISAUTHORIZED"++-- | Set the user being authorized, or not in your contactlist.+setAuthorized :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+              => UserID+              -> Bool+              -> SkypeT m ()+setAuthorized userID authorized = executeCommandWithID command $ \response ->+  case response of+    User _ (UserIsAuthorized _) -> return $ Just ()+    _                           -> return Nothing+  where+    command = "SET USER " <> userID <> " ISAUTHORIZED "+                          <> if authorized then "TRUE" else "FALSE"++-- | Checks if the user is blocked in your contactlist.+isBlocked :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+          => UserID+          -> SkypeT m Bool+isBlocked userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserIsBlocked blocked) -> return $ Just blocked+    _                              -> return Nothing+  where+    command = "GET USER " <> userID <> " ISBLOCKED"++-- | Sets the user being blocked, or not in your contactlist.+setBlocked :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+           => UserID+           -> Bool+           -> SkypeT m ()+setBlocked userID blocked = executeCommandWithID command $ \response ->+  case response of+    User _ (UserIsBlocked _) -> return $ Just ()+    _                        -> return Nothing+  where+    command = "SET USER " <> userID <> " ISBLOCKED "+                          <> (if blocked then "TRUE" else "FALSE")++-- | Gets the online status of the user.+getOnlineStatus :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                => UserID+                -> SkypeT m UserOnlineStatus+getOnlineStatus userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserOnlineStatus status) -> return $ Just status+    _                                -> return Nothing+  where+    command = "GET USER " <> userID <> " ONLINESTATUS"++-- | Gets last online timestamp of the user.+getLastOnlineTimestamp :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                       => UserID+                       -> SkypeT m Timestamp+getLastOnlineTimestamp userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserLastOnlineTimestamp lastOnlineTime) -> return $ Just lastOnlineTime+    _                                               -> return Nothing+  where+    command = "GET USER " <> userID <> " LASTONLINETIMESTAMP"++-- | Indicates whether the current user can send voicemail to the user.+canLeaveVoicemail :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                  => UserID+                  -> SkypeT m Bool+canLeaveVoicemail userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserCanLeaveVoicemail canLeave) -> return $ Just canLeave+    _                                       -> return Nothing+  where+    command = "GET USER " <> userID <> " CAN_LEAVE_VM"++-- | Gets the speed dial of the user.+getSpeedDial :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+             => UserID+             -> SkypeT m UserSpeedDial+getSpeedDial userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserSpeedDial speedDial) -> return $ Just speedDial+    _                                -> return Nothing+  where+    command = "GET USER " <> userID <> " SPEEDDIAL"++-- | Sets the speed dial of the user.+setSpeedDial :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+             => UserID+             -> UserSpeedDial+             -> SkypeT m ()+setSpeedDial userID speedDial = executeCommandWithID command $ \response ->+  case response of+    User _ (UserSpeedDial _) -> return $ Just ()+    _                        -> return Nothing+  where+    command = "SET USER " <> userID <> " SPEEDDIAL " <> (T.encodeUtf8 speedDial)++-- | Gets the mood message of the user.+getMoodText :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+            => UserID+            -> SkypeT m UserMoodText+getMoodText userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserMoodText moodText) -> return $ Just moodText+    _                              -> return Nothing+  where+    command = "GET USER " <> userID <> " MOOD_TEXT"++-- | Gets the time zone of the user.+getTimezone :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+            => UserID+            -> SkypeT m UserTimezoneOffset+getTimezone userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserTimezone timezone) -> return $ Just timezone+    _                              -> return Nothing+  where+    command = "GET USER " <> userID <> " TIMEZONE"++-- | Indicates whether the user has call forwarding activated or not.+isCallForwardingActive :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                       => UserID+                       -> SkypeT m Bool+isCallForwardingActive userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserIsCallForwardingActive callForwardingActive) -> return $ Just callForwardingActive+    _                                                        -> return Nothing+  where+    command = "GET USER " <> userID <> " IS_CF_ACTIVE"+++-- | Gets the number of authorized contacts in the contact list.+getNumberOfAuthedBuddies :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                         => UserID+                         -> SkypeT m Int+getNumberOfAuthedBuddies userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserNumberOfAuthedBuddies numberOfAuthedBuddies) -> return $ Just numberOfAuthedBuddies+    _                                                        -> return Nothing+  where+    command = "GET USER " <> userID <> " NROF_AUTHED_BUDDIES"++-- | Gets the display name of the user.+getDisplayName :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+               => UserID+               -> SkypeT m UserDisplayName+getDisplayName userID = executeCommandWithID command $ \response ->+  case response of+    User _ (UserDisplayName displayName) -> return $ Just displayName+    _                                    -> return Nothing+  where+    command = "GET USER " <> userID <> " DISPLAYNAME"++-- | Sets the display name of the user.+setDisplayName :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+               => UserID+               -> UserDisplayName+               -> SkypeT m ()+setDisplayName userID displayName = executeCommandWithID command $ \response ->+  case response of+    User _ (UserDisplayName _) -> return $ Just ()+    _                          -> return Nothing+  where+    command = "SET USER " <> userID <> " DISPLAYNAME " <> (T.encodeUtf8 displayName)++-- | Gets the user name for the currently logged in user.+getCurrentUserHandle :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                     => SkypeT m UserID+getCurrentUserHandle = executeCommandWithID command $ \response ->+  case response of+    CurrentUserHandle userID -> return $ Just userID+    _                        -> return Nothing+  where+    command = "GET CURRENTUSERHANDLE"++-- | Returns a list of found usernames.+searchAllFriends :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                 => SkypeT m [UserID]+searchAllFriends = executeCommandWithID command $ \response ->+  case response of+    Users userIDs -> return $ Just userIDs+    _             -> return Nothing+  where+    command = "SEARCH FRIENDS"
+ src/Network/Skype/Command/Utils.hs view
@@ -0,0 +1,76 @@+module Network.Skype.Command.Utils where++import Control.Concurrent.STM.TChan (readTChan)+import Control.Monad.Error (throwError)+import Control.Monad.Reader (asks)+import Control.Monad.STM (atomically)+import Control.Monad.Trans+import Control.Monad.Trans.Control+import Data.Attoparsec.ByteString.Lazy+import Data.Monoid ((<>))+import Data.Unique (newUnique, hashUnique)+import System.Timeout.Lifted (timeout)+import Network.Skype.Core+import Network.Skype.Parser (parseNotification, parseCommandID)+import Network.Skype.Protocol++import qualified Data.ByteString.Char8 as BC+import qualified Data.Text as T++executeCommand :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+               => Command+               -> (NotificationObject -> SkypeT m (Maybe a))+               -> SkypeT m a+executeCommand command handler = handleCommand command $ \notification ->+  case parseNotification notification of+    Right response -> handler response+    Left _         -> return Nothing++executeCommandWithID :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                     => Command+                     -> (NotificationObject -> SkypeT m (Maybe a))+                     -> SkypeT m a+executeCommandWithID command handler = handleCommandWithID command $ \expectID notification ->+  case parseCommandID notification of+    Done t commandID+      | commandID == expectID -> do+        case parseNotification t of+          Left e       -> throwError $ SkypeError 0 command (T.pack e)+          Right object -> guardError object >> handler object+      | otherwise -> return Nothing+    _ -> return Nothing+  where+    guardError (Error code description) = throwError $ SkypeError code command description+    guardError _                        = return ()++handleCommand :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+              => Command+              -> (Notification -> SkypeT m (Maybe a))+              -> SkypeT m a+handleCommand command handler = do+  chan <- dupNotificationChan++  sendCommand command++  time <- asks skypeTimeout+  result <- timeout time $ loop chan++  maybe (throwError $ SkypeError 0 command "Command timeout") return result+  where+    loop chan = do+      response <- liftIO $ atomically $ readTChan chan+      result <- handler response+      case result of+        Just value -> return value+        Nothing    -> loop chan++handleCommandWithID :: (MonadBaseControl IO m, MonadIO m, MonadSkype m)+                    => Command+                    -> (CommandID -> Notification -> SkypeT m (Maybe a))+                    -> SkypeT m a+handleCommandWithID command handler = do+  commandID <- liftIO $ (BC.pack . show . hashUnique) `fmap` newUnique++  let command' = "#" <> commandID <> " " <> command++  handleCommand command' $ handler commandID
+ src/Network/Skype/Core.hs view
@@ -0,0 +1,124 @@+module Network.Skype.Core (+  ApplicationName,+  Command,+  CommandID,+  Notification,+  MonadSkype(..),+  SkypeConfig(..),+  SkypeError(..),+  SkypeT,+  defaultConfig,+  runSkype,+  runSkypeWith,+  dupNotificationChan,+  onNotification+) where++import Control.Applicative (Applicative)+import Control.Concurrent.STM.TChan (TChan, dupTChan, readTChan)+import Control.Monad (liftM)+import Control.Monad.Error (MonadError, Error(..), ErrorT(..))+import Control.Monad.Reader (MonadReader(..), ReaderT(..), runReaderT)+import Control.Monad.STM (atomically)+import Control.Monad.Base (MonadBase)+import Control.Monad.Trans (MonadIO, MonadTrans, lift, liftIO)+import Control.Monad.Trans.Control+import Data.String (fromString)+import Data.Typeable (Typeable)++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T++type ApplicationName = BS.ByteString++type Command = BS.ByteString+type CommandID = BS.ByteString++type Notification = BL.ByteString++-- | Provides the DSL for Skype API.+class (Monad m) => MonadSkype m where+  -- | Sends the command message to the Skype instance.+  sendCommand :: Command -> m ()++  -- | Gets the notification channel of Skype from the event loop.+  getNotificationChan :: m (TChan Notification)++newtype SkypeT m a = SkypeT+  { runSkypeT :: ErrorT SkypeError (ReaderT SkypeConfig m) a+  }+  deriving ( Applicative+           , Functor+           , Monad+           , MonadIO+           , MonadError SkypeError+           , MonadReader SkypeConfig+           , MonadBase base+           )++instance MonadTrans SkypeT where+  lift = SkypeT . lift . lift++instance MonadTransControl SkypeT where+  newtype StT SkypeT a = StSkype { unStSkype :: Either SkypeError a }++  liftWith f = SkypeT . ErrorT . ReaderT $ \r ->+    liftM Right $ f $ \t ->+      liftM StSkype $ runReaderT (runErrorT (runSkypeT t)) r++  restoreT = SkypeT . ErrorT . ReaderT . const . liftM unStSkype++instance MonadBaseControl base m => MonadBaseControl base (SkypeT m) where+  newtype StM (SkypeT m) a = StMSkypeT { unStMSkypeT :: ComposeSt SkypeT m a }++  liftBaseWith = defaultLiftBaseWith StMSkypeT++  restoreM = defaultRestoreM unStMSkypeT++instance MonadSkype m => MonadSkype (SkypeT m) where+  sendCommand = lift . sendCommand++  getNotificationChan = lift getNotificationChan++data SkypeConfig = SkypeConfig+  { skypeTimeout :: Int }++defaultConfig :: SkypeConfig+defaultConfig = SkypeConfig+  { skypeTimeout = 10000 * 1000 }++data SkypeError = SkypeError+  { skypeErrorCode :: Int+  , skypeErrorCommand :: Command+  , skypeErrorDescription :: T.Text+  }+  deriving (Eq, Show, Typeable)++instance Error SkypeError where+  noMsg = SkypeError 0 "" ""+  strMsg = SkypeError 0 "" . fromString++runSkype :: (Monad m, MonadSkype (ReaderT connection m))+         => connection+         -> SkypeT (ReaderT connection m) a+         -> m (Either SkypeError a)+runSkype connection = runSkypeWith connection defaultConfig++runSkypeWith :: (Monad m, MonadSkype (ReaderT connection m))+             => connection+             -> SkypeConfig+             -> SkypeT (ReaderT connection m) a+             -> m (Either SkypeError a)+runSkypeWith connection config skype =+  runReaderT (runReaderT (runErrorT (runSkypeT skype)) config) connection++dupNotificationChan :: (MonadIO m, MonadSkype m) => m (TChan Notification)+dupNotificationChan = getNotificationChan >>= liftIO . atomically . dupTChan++onNotification :: (MonadIO m, MonadSkype m) => (Notification -> m a) -> m ()+onNotification f = dupNotificationChan >>= loop+  where+    loop chan = do+      _ <- liftIO (atomically (readTChan chan)) >>= f+      loop chan
+ src/Network/Skype/Parser.hs view
@@ -0,0 +1,121 @@+module Network.Skype.Parser where++import Control.Applicative+import Data.Attoparsec.ByteString.Char8 (decimal)+import Data.Attoparsec.ByteString.Lazy+import Data.Word8+import Network.Skype.Core+import Network.Skype.Parser.Chat+import Network.Skype.Parser.ChatMember+import Network.Skype.Parser.ChatMessage+import Network.Skype.Parser.Types+import Network.Skype.Parser.User+import Network.Skype.Protocol++import qualified Data.Text.Encoding as T++parseNotification :: Notification -> Either String NotificationObject+parseNotification = eitherResult . parse notification++parseCommandID :: Notification -> Result CommandID+parseCommandID = parse commandID++notification :: Parser NotificationObject+notification = skipWhile isSpace *> choice+  [ alterNotification+  , chatsNotification+  , chatNotification+  , chatMemberNotification+  , chatMessageNotification+  , connectionStatusNotification+  , errorNotification+  , openNotification+  , protocolNotification+  , usersNotification+  , userNotification+  , userStatusNotification+  , currentUserHandleNotification+  ]++commandID :: Parser CommandID+commandID = word8 _numbersign *> takeWhile1 (not . isSpace)++-- | ALTER+alterNotification :: Parser NotificationObject+alterNotification = string "ALTER" *> spaces *> choice+  [ AlterChat <$> (string "CHAT" *> spaces *> alterChatProperties)+  ]++-- | CHAT+chatNotification :: Parser NotificationObject+chatNotification = string "CHAT"+                *> spaces+                *> (Chat <$> (chatID <* spaces) <*> chatProperty)++-- | CHATS+chatsNotification :: Parser NotificationObject+chatsNotification = Chats <$> (string "CHATS" *> spaces *> chatIDs)+  where+    chatIDs = chatID `sepBy` (word8 _comma *> spaces)++-- | CHATMEMEMBER+chatMemberNotification :: Parser NotificationObject+chatMemberNotification = string "CHATMEMEMBER"+                      *> spaces+                      *> (ChatMember <$> (chatMemberID <* spaces) <*> chatMemberProperty)++-- | CHATMESSAGE+chatMessageNotification :: Parser NotificationObject+chatMessageNotification = string "CHATMESSAGE"+                       *> spaces+                       *> (ChatMessage <$> (chatMessageID <* spaces) <*> chatMessageProperty)++-- | CONNSTATUS+connectionStatusNotification :: Parser NotificationObject+connectionStatusNotification = ConnectionStatus <$> (string "CONNSTATUS" *> spaces *> status)+  where+    status = choice+      [ ConnectionStatusOffline    <$ string "OFFLINE"+      , ConnectionStatusConnecting <$ string "CONNECTING"+      , ConnectionStatusPausing    <$ string "PAUSING"+      , ConnectionStatusOnline     <$ string "ONLINE"+      ]++-- | ERROR+errorNotification :: Parser NotificationObject+errorNotification = Error <$> code <*> (description <|> pure "")+  where+    code = string "ERROR" *> spaces *> decimal++    description = spaces *> (T.decodeUtf8 <$> takeByteString)++-- | OPEN+openNotification :: Parser NotificationObject+openNotification = string "OPEN" *> spaces *> choice+  [ chat ]+  where+    chat = OpenChat <$> (string "CHAT" *> spaces *> chatID)++-- | PROTOCOL+protocolNotification :: Parser NotificationObject+protocolNotification = Protocol <$> (string "PROTOCOL" *> spaces *> decimal)++-- | USERS+usersNotification :: Parser NotificationObject+usersNotification = Users <$> (string "USERS" *> spaces *> userIDs)+  where+    userIDs = userID `sepBy` (word8 _comma *> spaces)++-- | USER+userNotification :: Parser NotificationObject+userNotification = User <$> (string "USER" *> spaces *> userID <* spaces)+                        <*> userProperty++-- | USERSTATUS+userStatusNotification :: Parser NotificationObject+userStatusNotification = UserStatus <$> (string "USERSTATUS" *> spaces *> userStatus)++-- | CURRENTUSERHANDLE+currentUserHandleNotification :: Parser NotificationObject+currentUserHandleNotification = CurrentUserHandle <$>+                                (string "CURRENTUSERHANDLE" *> spaces *> userID)
+ src/Network/Skype/Parser/Chat.hs view
@@ -0,0 +1,109 @@+module Network.Skype.Parser.Chat where++import Control.Applicative+import Data.Attoparsec.ByteString.Char8 (decimal)+import Data.Attoparsec.ByteString.Lazy+import Data.Word8+import Network.Skype.Parser.Types+import Network.Skype.Protocol.Chat++chatProperty :: Parser ChatProperty+chatProperty = choice+  [ ChatName              <$> (property "NAME" *> chatID)+  , ChatTimestamp         <$> (property "TIMESTAMP" *> timestamp)+  , ChatAdder             <$> (property "ADDER" *> (Just <$> chatID <|> pure Nothing))+  , ChatStatus            <$> (property "STATUS" *> chatStatus)+  , ChatPosters           <$> (property "POSTERS" *> userIDs)+  , ChatMembers           <$> (property "MEMBERS" *> userIDs)+  , ChatTopic             <$> (property "TOPIC" *> chatTopic)+  , ChatTopicXml          <$> (property "TOPICXML" *> chatTopic)+  , ChatActiveMembers     <$> (property "ACTIVEMEMBERS" *> userIDs)+  , ChatFriendyName       <$> (property "FRIENDLYNAME" *> chatWindowTitle)+  , ChatMessages          <$> (property "CHATMESSAGES" *> chatMessages)+  , ChatRecentMessages    <$> (property "RECENTCHATMESSAGES" *> chatMessages)+  , ChatBookmarked        <$> (property "BOOKMARKED" *> boolean)+  , ChatMemberObjects     <$> (property "MEMBEROBJECTS" *> chatMemberObjects)+  , ChatPasswordHint      <$> (property "PASSWORDHINT" *> chatPasswordHint)+  , ChatGuidelines        <$> (property "GUIDELINES" *> chatGuidelines)+  , ChatOptions           <$> (property "OPTIONS" *> chatOptions)+  , ChatDescription       <$> (property "DESCRIPTION" *> chatDescription)+  , ChatDialogPartner     <$> (property "DIALOG_PARTNER" *> userID)+  , ChatActivityTimestamp <$> (property "ACTIVITY_TIMESTAMP" *> timestamp)+  , ChatType              <$> (property "TYPE" *> chatType)+  , ChatMyStatus          <$> (property "MYSTATUS" *> chatMyStatus)+  , ChatMyRole            <$> (property "MYROLE" *> chatRole)+  , ChatBlob              <$> (property "BLOB" *> chatBlob)+  , ChatApplicants        <$> (property "APPLICANTS" *> userIDs)+  , ChatClosed            <$  (string "CLOSED" *> endOfInput)+  , ChatOpened            <$  (string "OPENED" *> endOfInput)+  ]+  where+    property prop = string prop *> spaces++    userIDs = userID `sepBy` spaces++    chatMessages = chatMessageID `sepBy` (word8 _comma *> spaces)++    chatMemberObjects = chatMemberID `sepBy` (word8 _comma *> spaces)++chatStatus :: Parser ChatStatus+chatStatus = choice+  [ ChatStatusLegacyDialog    <$ string "LEGACY_DIALOG"+  , ChatStatusDialog          <$ string "DIALOG"+  , ChatStatusMultiSubscribed <$ string "MULTI_SUBSCRIBED"+  , ChatStatusUnsubscribed    <$ string "UNSUBSCRIBED"+  ]++chatOptions :: Parser ChatOption+chatOptions = ChatOption <$> decimal++chatType :: Parser ChatType+chatType = choice+  [ ChatTypeLegacyDialog       <$ string "LEGACY_DIALOG"+  , ChatTypeDialog             <$ string "DIALOG"+  , ChatTypeMultiChat          <$ string "MULTICHAT"+  , ChatTypeSharedGroup        <$ string "SHAREDGROUP"+  , ChatTypeLegacyUnsubscribed <$ string "LEGACY_UNSUBSCRIBED"+  ]++chatMyStatus :: Parser ChatMyStatus+chatMyStatus = choice+  [ ChatMyStatusConnecting              <$ string "CONNECTING"+  , ChatMyStatusWaitingRemoteAccept     <$ string "WAITING_REMOTE_ACCEPT"+  , ChatMyStatusAcceptRequired          <$ string "ACCEPT_REQUIRED"+  , ChatMyStatusPasswordRequired        <$ string "PASSWORD_REQUIRED"+  , ChatMyStatusSubscribed              <$ string "SUBSCRIBED"+  , ChatMyStatusUnsubscribed            <$ string "UNSUBSCRIBED"+  , ChatMyStatusDisbanded               <$ string "CHAT_DISBANDED"+  , ChatMyStatusQueuedBecauseChatIsFull <$ string "QUEUED_BECAUSE_CHAT_IS_FULL"+  , ChatMyStatusApplicationDenied       <$ string "APPLICATION_DENIED"+  , ChatMyStatusKicked                  <$ string "KICKED"+  , ChatMyStatusBanned                  <$ string "BANNED"+  , ChatMyStatusRetryConnecting         <$ string "RETRY_CONNECTING"+  ]++chatRole :: Parser ChatRole+chatRole = choice+  [ ChatRoleCreator   <$ string "CREATOR"+  , ChatRoleMaster    <$ string "MASTER"+  , ChatRoleHelper    <$ string "HELPER"+  , ChatRoleUser      <$ string "USER"+  , ChatRoleListener  <$ string "LISTENER"+  , ChatRoleApplicant <$ string "APPLICANT"+  ]++alterChatProperties :: Parser AlterChatProperty+alterChatProperties = choice+  [ AlterChatAcceptAdd           <$  (string "ACCEPTADD")+  , AlterChatAddMembers          <$  (string "ADDMEMBERS")+  , AlterChatBookmarked          <$> (string "BOOKMARKED" *> boolean)+  , AlterChatClearRecentMessages <$  (string "CLEARRECENTMESSAGES")+  , AlterChatDisband             <$  (string "DISBAND")+  , AlterChatEnterPassword       <$  (string "ENTERPASSWORD")+  , AlterChatJoin                <$  (string "JOIN")+  , AlterChatLeave               <$  (string "LEAVE")+  , AlterChatSetAlertString      <$  (string "SETALERTSTRING")+  , AlterChatSetOptions          <$  (string "SETOPTIONS")+  , AlterChatSetPassword         <$  (string "SETPASSWORD")+  , AlterChatSetTopic            <$  (string "SETTOPIC")+  ]
+ src/Network/Skype/Parser/ChatMember.hs view
@@ -0,0 +1,17 @@+module Network.Skype.Parser.ChatMember where++import Control.Applicative+import Data.Attoparsec.ByteString.Lazy+import Network.Skype.Parser.Chat+import Network.Skype.Parser.Types+import Network.Skype.Protocol.ChatMember++chatMemberProperty :: Parser ChatMemberProperty+chatMemberProperty = choice+  [ ChatMemberChatName <$> (property "CHATNAME" *> chatID)+  , ChatMemberIdentity <$> (property "IDENTITY" *> userID)+  , ChatMemberRole     <$> (property "ROLE" *> chatRole)+  , ChatMemberIsActive <$> (property "IS_ACTIVE" *> boolean)+  ]+  where+    property prop = string prop *> spaces
+ src/Network/Skype/Parser/ChatMessage.hs view
@@ -0,0 +1,68 @@+module Network.Skype.Parser.ChatMessage where++import Control.Applicative+import Data.Attoparsec.ByteString.Lazy+import Network.Skype.Parser.Chat+import Network.Skype.Parser.Types+import Network.Skype.Protocol.ChatMessage++chatMessageProperty :: Parser ChatMessageProperty+chatMessageProperty = choice+  [ ChatMessageTimestamp       <$> (property "TIMESTAMP" *> timestamp)+  , ChatMessageFromHandle      <$> (property "FROM_HANDLE" *> userID)+  , ChatMessageFromDisplayName <$> (property "FROM_DISPNAME" *> userDisplayName)+  , ChatMessageType            <$> (property "TYPE" *> chatMessageType)+  , ChatMessageStatus          <$> (property "STATUS" *> chatMessageStatus)+  , ChatMessageLeaveReason     <$> (property "LEAVEREASON" *> (Just <$> chatMessageLeaveReason <|> pure Nothing))+  , ChatMessageChatName        <$> (property "CHATNAME" *> chatID)+  , ChatMessageUsers           <$> (property "USERS" *> userIDs)+  , ChatMessageIsEditable      <$> (property "IS_EDITABLE" *> boolean)+  , ChatMessageEditedBy        <$> (property "EDITED_BY" *> userID)+  , ChatMessageEditedTimestamp <$> (property "EDITED_TIMESTAMP" *> timestamp)+  , ChatMessageOptions         <$> (property "OPTIONS" *> chatOptions)+  , ChatMessageRole            <$> (property "ROLE" *> chatRole)+  , ChatMessageSeen            <$  (string "SEEN" *> endOfInput)+  , ChatMessageBody            <$> (property "BODY" *> chatMessageBody)+  ]+  where+    property prop = string prop *> spaces++    userIDs = userID `sepBy` spaces++chatMessageType :: Parser ChatMessageType+chatMessageType = choice+  [ ChatMessageTypeSetTopic          <$ string "SETTOPIC"+  , ChatMessageTypeSaid              <$ string "SAID"+  , ChatMessageTypeAddedMembers      <$ string "ADDEDMEMBERS"+  , ChatMessageTypeSawMembers        <$ string "SAWMEMBERS"+  , ChatMessageTypeCreatedChatWith   <$ string "CREATEDCHATWITH"+  , ChatMessageTypeLeft              <$ string "LEFT"+  , ChatMessageTypePostedContacts    <$ string "POSTEDCONTACTS"+  , ChatMessageTypeGapInChat         <$ string "GAiN_CHAT"+  , ChatMessageTypeSetRole           <$ string "SETROLE"+  , ChatMessageTypeKicked            <$ string "KICKED"+  , ChatMessageTypeKickBanned        <$ string "KICKBANNED"+  , ChatMessageTypeSetOptions        <$ string "SETOPTIONS"+  , ChatMessageTypeSetPicture        <$ string "SETPICTURE"+  , ChatMessageTypeSetGuideLines     <$ string "SETGUIDELINES"+  , ChatMessageTypeJoinedAsApplicant <$ string "JOINEDASAPPLICANT"+  , ChatMessageTypeEmoted            <$ string "EMOTED"+  , ChatMessageTypeUnkown            <$ string "UNKNOWN"+  ]++chatMessageStatus :: Parser ChatMessageStatus+chatMessageStatus = choice+  [ ChatMessageStatusSending <$ string "SENDING"+  , ChatMessageStatusSent    <$ string "SENT"+  , ChatMessageStatusReceive <$ string "RECEIVE"+  , ChatMessageStatusRead    <$ string "READ"+  ]++chatMessageLeaveReason :: Parser ChatMessageLeaveReason+chatMessageLeaveReason = choice+  [ ChatMessageLeaveReasonUserNotFound          <$ string "USER_NOT_FOUND"+  , ChatMessageLeaveReasonUserIncapable         <$ string "USER_INCAPABLE"+  , ChatMessageLeaveReasonAdderMustBeFriend     <$ string "ADDER_MUST_BE_FRIEND"+  , ChatMessageLeaveReasonAdderMustBeAuthorized <$ string "ADDED_MUST_BE_AUTHORIZED"+  , ChatMessageLeaveReasonUnsubscribe           <$ string "UNSUBSCRIBE"+  ]
+ src/Network/Skype/Parser/Types.hs view
@@ -0,0 +1,121 @@+module Network.Skype.Parser.Types where++import Control.Applicative+import Control.Arrow+import Data.Attoparsec.ByteString.Char8 (decimal)+import Data.Attoparsec.ByteString.Lazy+import Data.Char (chr)+import Data.Time.Calendar (fromGregorian)+import Data.Word8+import Network.Skype.Protocol.Types++import qualified Data.ByteString as BS+import qualified Data.Text as T+import qualified Data.Text.Encoding as T++-- * User++userID :: Parser UserID+userID = takeWhile1 $ uncurry (&&) . ((not . isSpace) &&& (/=) _comma)++userFullName :: Parser UserDisplayName+userFullName = takeText++userDisplayName :: Parser UserDisplayName+userDisplayName = takeText++userBirthday :: Parser (Maybe UserBirthday)+userBirthday = Just <$> (fromGregorian <$> digit 4 <*> digit 2 <*> digit 2)+             <|> Nothing <$ (word8 _0 *> endOfInput)+  where+    digit n = read . map (chr . fromIntegral) <$> count n (satisfy isDigit)++userLanguage :: Parser (Maybe (UserLanguageISOCode, UserLanguage))+userLanguage = Just <$> ((,) <$> (tokens <* spaces) <*> tokens) <|> pure Nothing+  where+    tokens = T.decodeUtf8 <$> takeWhile1 isAlpha++userCountry :: Parser (Maybe (UserCountryISOCode, UserCountry))+userCountry = Just <$> ((,) <$> (tokens <* spaces) <*> tokens) <|> pure Nothing+  where+    tokens = T.decodeUtf8 <$> takeWhile1 isAlpha++userProvince :: Parser UserProvince+userProvince = takeText++userCity :: Parser UserCity+userCity = takeText++userPhone :: Parser UserPhone+userPhone = takeText++userAbout :: Parser UserAbout+userAbout = takeText++userHomepage :: Parser UserHomepage+userHomepage = takeText++userSpeedDial :: Parser UserSpeedDial+userSpeedDial = takeText++userAuthRequestMessage :: Parser UserAuthRequestMessage+userAuthRequestMessage = takeText++userMoodText :: Parser UserMoodText+userMoodText = takeText++userRichMoodText :: Parser UserRichMoodText+userRichMoodText = takeText++userTimezoneOffset :: Parser UserTimezoneOffset+userTimezoneOffset = decimal++-- * Chat++chatID :: Parser ChatID+chatID = takeWhile1 $ uncurry (&&) . ((not . isSpace) &&& (/=) _comma)++chatTopic :: Parser ChatTopic+chatTopic = takeText++chatWindowTitle :: Parser ChatWindowTitle+chatWindowTitle = takeText++chatPasswordHint :: Parser ChatPasswordHint+chatPasswordHint = takeText++chatGuidelines :: Parser ChatGuidelines+chatGuidelines = takeText++chatDescription :: Parser ChatDescription+chatDescription = takeText++chatBlob :: Parser ChatBlob+chatBlob = takeByteString++-- * Chat member++chatMemberID :: Parser ChatMemberID+chatMemberID = decimal++-- * Chat message++chatMessageID :: Parser ChatMessageID+chatMessageID = decimal++chatMessageBody :: Parser ChatMessageBody+chatMessageBody = takeText++-- * Misc.++boolean :: Parser Bool+boolean = (True <$ string "TRUE") <|> (False <$ string "FALSE")++timestamp :: Parser Timestamp+timestamp = decimal++spaces :: Parser BS.ByteString+spaces = takeWhile1 isSpace++takeText :: Parser T.Text+takeText = T.decodeUtf8 <$> takeByteString
+ src/Network/Skype/Parser/User.hs view
@@ -0,0 +1,85 @@+module Network.Skype.Parser.User where++import Control.Applicative+import Data.Attoparsec.ByteString.Char8 (anyChar, decimal)+import Data.Attoparsec.ByteString.Lazy+import Data.Word8+import Network.Skype.Parser.Types+import Network.Skype.Protocol.User++userProperty :: Parser UserProperty+userProperty = choice+  [ UserHandle                 <$> (property "HANDLE" *> userID)+  , UserFullName               <$> (property "FULLNAME" *> userFullName)+  , UserBirthday               <$> (property "BIRTHDAY" *> userBirthday)+  , UserSex                    <$> (property "SEX" *> userSex)+  , UserLanguage               <$> (property "LANGUAGE" *> userLanguage)+  , UserCountry                <$> (property "COUNTRY" *> userCountry)+  , UserProvince               <$> (property "PROVINCE" *> userProvince)+  , UserCity                   <$> (property "CITY" *> userCity)+  , UserHomePhone              <$> (property "PHONE_HOME" *> userPhone)+  , UserOfficePhone            <$> (property "PHONE_OFFICE" *> userPhone)+  , UserMobilePhone            <$> (property "PHONE_MOBILE" *> userPhone)+  , UserHomepage               <$> (property "HOMEPAGE" *> userHomepage)+  , UserAbout                  <$> (property "ABOUT" *> userAbout)+  , UserHasCallEquipment       <$> (property "HASCALLEQUIPMENT" *> boolean)+  , UserIsVideoCapable         <$> (property "IS_VIDEO_CAPABLE" *> boolean)+  , UserIsVoicemailCapable     <$> (property "IS_VOICEMAIL_CAPABLE" *> boolean)+  , UserBuddyStatus            <$> (property "BUDDYSTATUS" *> userBuddyStatus)+  , UserIsAuthorized           <$> (property "ISAUTHORIZED" *> boolean)+  , UserIsBlocked              <$> (property "ISBLOCKED" *> boolean)+  , UserOnlineStatus           <$> (property "ONLINESTATUS" *> userOnlineStatus)+  , UserLastOnlineTimestamp    <$> (property "LASTONLINETIMESTAMP" *> timestamp)+  , UserCanLeaveVoicemail      <$> (property "CAN_LEAVE_VM" *> boolean)+  , UserSpeedDial              <$> (property "SPEEDDIAL" *> userSpeedDial)+  , UserReceiveAuthRequest     <$> (property "RECEIVEDAUTHREQUEST" *> userAuthRequestMessage)+  , UserMoodText               <$> (property "MOOD_TEXT" *> userMoodText)+  , UserRichMoodText           <$> (property "RICH_MOOD_TEXT" *> userRichMoodText)+  , UserTimezone               <$> (property "TIMEZONE" *> userTimezoneOffset)+  , UserIsCallForwardingActive <$> (property "IS_CF_ACTIVE" *> boolean)+  , UserNumberOfAuthedBuddies  <$> (property "NROF_AUTHED_BUDDIES" *> decimal)+  , UserDisplayName            <$> (property "DISPLAYNAME" *> userDisplayName)+  ]+  where+    property prop = string prop *> spaces++userSex :: Parser UserSex+userSex = choice+  [ UserSexUnknown <$ string "UNKNOWN"+  , UserSexMale    <$ string "MALE"+  , UserSexFemale  <$ string "FEMALE"+  ]++userStatus :: Parser UserStatus+userStatus = choice+  [ UserStatusUnknown      <$ string "UNKNOWN"+  , UserStatusOnline       <$ string "ONLINE"+  , UserStatusOffline      <$ string "OFFLINE"+  , UserStatusSkypeMe      <$ string "SKYPEME"+  , UserStatusAway         <$ string "AWAY"+  , UserStatusNotAvailable <$ string "NA"+  , UserStatusDoNotDisturb <$ string "DND"+  , UserStatusInvisible    <$ string "INVISIBLE"+  , UserStatusLoggedOut    <$ string "LOGGEDOUT"+  ]++userBuddyStatus :: Parser UserBuddyStatus+userBuddyStatus = choice+  [ UserBuddyStatusNeverBeen <$ word8 _0+  , UserBuddyStatusDeleted   <$ word8 _1+  , UserBuddyStatusPending   <$ word8 _2+  , UserBuddyStatusAdded     <$ word8 _3+  ]++userOnlineStatus :: Parser UserOnlineStatus+userOnlineStatus = choice+  [ UserOnlineStatusUnknown      <$ string "UNKNOWN"+  , UserOnlineStatusOffline      <$ string "OFFLINE"+  , UserOnlineStatusOnline       <$ string "ONLINE"+  , UserOnlineStatusAway         <$ string "AWAY"+  , UserOnlineStatusNotAvailable <$ string "NA"+  , UserOnlineStatusDoNotDisturb <$ string "DND"+  ]++userAvater :: Parser (Int, FilePath)+userAvater = (,) <$> decimal <*> many anyChar
+ src/Network/Skype/Protocol.hs view
@@ -0,0 +1,32 @@+module Network.Skype.Protocol (+  module Network.Skype.Protocol.Chat,+  module Network.Skype.Protocol.ChatMember,+  module Network.Skype.Protocol.ChatMessage,+  module Network.Skype.Protocol.Misc,+  module Network.Skype.Protocol.Types,+  module Network.Skype.Protocol.User,++  NotificationObject(..)+) where++import Network.Skype.Protocol.Chat+import Network.Skype.Protocol.ChatMember+import Network.Skype.Protocol.ChatMessage+import Network.Skype.Protocol.Misc+import Network.Skype.Protocol.Types+import Network.Skype.Protocol.User++data NotificationObject = AlterChat AlterChatProperty+                        | Chat ChatID ChatProperty+                        | Chats [ChatID]+                        | ChatMember ChatMemberID ChatMemberProperty+                        | ChatMessage ChatMessageID ChatMessageProperty+                        | ConnectionStatus ConnectionStatus+                        | Error ErrorCode ErrorDescription+                        | OpenChat ChatID+                        | Protocol ProtocolVersion+                        | User UserID UserProperty+                        | Users [UserID]+                        | UserStatus UserStatus+                        | CurrentUserHandle UserID+  deriving (Eq, Show)
+ src/Network/Skype/Protocol/Chat.hs view
@@ -0,0 +1,246 @@+module Network.Skype.Protocol.Chat where++import Data.Bits (Bits)+import Data.Typeable (Typeable)+import Network.Skype.Protocol.Types++data AlterChatProperty = AlterChatAcceptAdd+                       | AlterChatAddMembers+                       | AlterChatBookmarked Bool+                       | AlterChatClearRecentMessages+                       | AlterChatDisband+                       | AlterChatEnterPassword+                       | AlterChatJoin+                       | AlterChatLeave+                       | AlterChatSetAlertString+                       | AlterChatSetOptions+                       | AlterChatSetPassword+                       | AlterChatSetTopic+  deriving (Eq, Show, Typeable)++data ChatProperty+  -- | Chat ID+  = ChatName ChatID++  -- | Time when chat was created.+  | ChatTimestamp Timestamp++  -- | User who added the current user to chat.+  | ChatAdder (Maybe UserID)++  -- | Chat status+  | ChatStatus ChatStatus++  -- | Members who have posted messages.+  | ChatPosters [UserID]++  -- | All users who have been there.+  | ChatMembers [UserID]++  -- | Chat topic+  | ChatTopic ChatTopic++  -- | set when a chat topic contains XML formatting elements (topic was changed+  -- with ALTER CHATSETTOPICXML command) This property works in parallel with+  -- TOPIC property - when TOPICXML is set, the value is stripped of XML tags+  -- and updated in TOPIC.+  | ChatTopicXml ChatTopic++  -- | Members who have stayed in chat.+  | ChatActiveMembers [UserID]++  -- | Name shown in chat window title.+  | ChatFriendyName ChatWindowTitle++  -- | All messages IDs in this chat.+  | ChatMessages [ChatMessageID]++  -- | List of missed/recent chatmessage identifiers+  | ChatRecentMessages [ChatMessageID]++  -- | TRUE|FALSE+  | ChatBookmarked Bool++  -- | Contains the list of CHATMEMBER object IDs.+  | ChatMemberObjects [ChatMemberID]++  -- | Contains password hint text for the chat object.+  | ChatPasswordHint ChatPasswordHint++  -- | Contains chat guidelines text.+  | ChatGuidelines ChatGuidelines++  -- | Bitmap of chat options.+  | ChatOptions ChatOption++  -- | Currently used only for hidden synchronization channels for managing+  -- shared groups.+  | ChatDescription ChatDescription++  -- | The handle of the dialog partner for dialog type chats+  -- (chats with two participants).+  | ChatDialogPartner UserID++  -- | The UNIX timestamp of last activity.+  | ChatActivityTimestamp Timestamp++  -- | Chat type+  | ChatType ChatType++  -- | For public chats, this property contains encoded list of chat+  -- join-points. Contents of this field is used in public chat URLs.+  | ChatBlob ChatBlob++  -- | User's current status in chat.+  | ChatMyStatus ChatMyStatus++  -- | User's privilege level in chat.+  | ChatMyRole ChatRole++  -- | This property contains list of skypenames of people who have applied to+  -- join the chat but have not yet been accepted by a public chat+  -- administrator. Users only become applicants when the chat has+  -- JOINERS_BECOME_APPLICANTS option.+  | ChatApplicants [UserID]++  -- | Chat was opened.+  | ChatOpened++  -- | Chat was closed.+  | ChatClosed+  deriving (Eq, Show, Typeable)++data ChatStatus+  -- | Old style IM+  = ChatStatusLegacyDialog++  -- | 1:1 chat+  | ChatStatusDialog++  -- | Participant in chat+  | ChatStatusMultiSubscribed++  -- | Left chat+  | ChatStatusUnsubscribed+  deriving (Eq, Show, Typeable)++newtype ChatOption = ChatOption Int+  deriving (Bits, Eq, Show, Typeable)++-- | When this bit is off, new users cannot join the chat.+chatOptionJoiningEnabled :: ChatOption+chatOptionJoiningEnabled = ChatOption 1++-- | When this bit is on, new users will be able to join the chat but they+-- will be unable to post or receive messages until authorized by one of the+-- chat administrators (CREATOR or MASTER).+chatOptionJoinersBecomeApplicants :: ChatOption+chatOptionJoinersBecomeApplicants = ChatOption 2++-- | When this bit is on, new users will be able to receive message in chat+-- but unable to post until promoted to USER role. Basically a read-only flag+-- for new users.+chatOptionJoinersBecomeListeners :: ChatOption+chatOptionJoinersBecomeListeners = ChatOption 4++-- | When this bit is off, newly joined members can see chat history prior to+-- their joining. Maximum amount of history backlog available is either 400+-- messages or 2 weeks of time, depending on which limit is reached first.+chatOptionHistoryDisclosed :: ChatOption+chatOptionHistoryDisclosed = ChatOption 8++-- | Read-only flag for chat members with USER role.+chatOptionUsersAreListeners :: ChatOption+chatOptionUsersAreListeners = ChatOption 16++-- | when this bit of options is off, USER level chat members can change chat+-- topic and the topic picture.+chatOptionTopicAndPicLockedForUsers :: ChatOption+chatOptionTopicAndPicLockedForUsers = ChatOption 32++data ChatType+  -- | No longer supported.+  = ChatTypeLegacyDialog++  -- | A chat with only two participants.+  | ChatTypeDialog++  -- | A chat with more than two participants.+  | ChatTypeMultiChat++  -- | A chat used for synchronization of shared contact groups.+  | ChatTypeSharedGroup++  -- | No longer supported.+  | ChatTypeLegacyUnsubscribed+  deriving (Eq, Show, Typeable)++data ChatMyStatus+  -- | Status set when the system is trying to connect to the chat.+  = ChatMyStatusConnecting++  -- | Set when a new user joins a public chat. When the chat has+  -- "participants need authorization to read messages" option, the MYSTATUS+  -- property of a new applicant will remain in this status until he gets+  -- accepted or rejected by a chat administrator. Otherwise user's MYSTATUS+  -- will automatically change to either LISTENER or USER, depending on public+  -- chat options.+  | ChatMyStatusWaitingRemoteAccept++  -- | This status is used for shared contact groups functionality.+  | ChatMyStatusAcceptRequired++  -- | Status set when the system is waiting for user to supply the chat+  -- password.+  | ChatMyStatusPasswordRequired++  -- | Set when user joins the chat.+  | ChatMyStatusSubscribed++  -- | Set when user leaves the chat or chat ends.+  | ChatMyStatusUnsubscribed++  -- | Status set when the chat is disbanded.+  | ChatMyStatusDisbanded++  -- | Currently the maximum number of people in the same chat is 100.+  | ChatMyStatusQueuedBecauseChatIsFull++  -- | Set when public chat administrator has rejected user from joining.+  | ChatMyStatusApplicationDenied++  -- | Status set when the user has been kicked from the chat. Note that it is+  -- possible for the user to re-join the chat after being kicked.+  | ChatMyStatusKicked++  -- | Status set when the user has been banned from the chat.+  | ChatMyStatusBanned++  -- | Status set when connect to chat failed and system retries to establish+  -- connection.+  | ChatMyStatusRetryConnecting+  deriving (Eq, Show, Typeable)++data ChatRole+  -- | Member who created the chat. There can be only one creator per chat. Only+  -- creator can promote other members to masters.+  = ChatRoleCreator++  -- | Also known as chat hosts. Masters cannot promote other people to masters.+  | ChatRoleMaster++  -- | A semi-privileged member. Helpers will not be affected by the+  -- USERS_ARE_LISTENERS option. Helpers cannot promote or demote other members.+  | ChatRoleHelper++  -- | Regular members who can post messages into the chat.+  | ChatRoleUser++  -- | A demoted member who can only receive messages but not post anything into+  -- the chat.+  | ChatRoleListener++  -- | A member waiting for acceptance into the chat. Member cannot be demoted+  -- to applicants once they have been accepted.+  | ChatRoleApplicant+  deriving (Eq, Show, Typeable)
+ src/Network/Skype/Protocol/ChatMember.hs view
@@ -0,0 +1,11 @@+module Network.Skype.Protocol.ChatMember where++import Data.Typeable (Typeable)+import Network.Skype.Protocol.Chat+import Network.Skype.Protocol.Types++data ChatMemberProperty = ChatMemberChatName ChatID+                        | ChatMemberIdentity UserID+                        | ChatMemberRole ChatRole+                        | ChatMemberIsActive Bool+  deriving (Eq, Show, Typeable)
+ src/Network/Skype/Protocol/ChatMessage.hs view
@@ -0,0 +1,154 @@+module Network.Skype.Protocol.ChatMessage where++import Data.Typeable (Typeable)+import Network.Skype.Protocol.Chat+import Network.Skype.Protocol.Types++data ChatMessageProperty+  -- | Time when the message was sent (UNIX timestamp).+  = ChatMessageTimestamp Timestamp++  -- | Skypename of the originator of the chatmessage.+  | ChatMessageFromHandle UserID++  -- | Displayed name of the originator of the chatmessage.+  | ChatMessageFromDisplayName UserDisplayName++  -- | Message type+  | ChatMessageType ChatMessageType++  -- | Message status+  | ChatMessageStatus ChatMessageStatus++  -- | Used with LEFT type message+  | ChatMessageLeaveReason (Maybe ChatMessageLeaveReason)++  -- | Chat that includes the message+  | ChatMessageChatName ChatID++  -- | People added to chat+  | ChatMessageUsers [UserID]++  -- | TRUE|FALSE+  | ChatMessageIsEditable Bool++  -- | Identity of the last user who edited the message.+  | ChatMessageEditedBy UserID++  -- | UNIX timestamp of the last edit.+  | ChatMessageEditedTimestamp Timestamp++  -- | Numeric field that contains chat options bitmap in system messages that+  -- get sent out when a change is made to chat options (messages where TYPE is+  -- SETOPTIONS). In normal messages the value of this field is 0.+  | ChatMessageOptions ChatOption++  -- | Used in system messages that get sent when a public chat administrator+  -- has promoted or demoted a chat member. The TYPE property of such messages+  -- is set to SETROLE. In these messages the value of this field is set to the+  -- new assigned role of the promoted or demoted chat member. In normal+  -- messages the value of this property is set to UNKNOWN.+  | ChatMessageRole ChatRole++  -- | Message body+  | ChatMessageBody ChatMessageBody++  -- | The message is seen and will be removed from missed messages list. The+  -- UI sets this automatically if auto-popup is enabled for the user.+  | ChatMessageSeen+  deriving (Eq, Show, Typeable)++data ChatMessageType+  -- | Change of chattopic+  = ChatMessageTypeSetTopic++  -- | IM+  | ChatMessageTypeSaid++  -- | Invited someone to chat.+  | ChatMessageTypeAddedMembers++  -- | Chat participant has seen other members.+  | ChatMessageTypeSawMembers++  -- | Chat to multiple people is created.+  | ChatMessageTypeCreatedChatWith++  -- | Someone left chat.+  -- Can also be a notification if somebody cannot be added to chat.+  | ChatMessageTypeLeft++  -- | System message that is sent or received when one user sends contacts to+  -- another. Added in protocol 7.+  | ChatMessageTypePostedContacts++  -- | messages of this type are generated locally, during synchronization, when+  -- a user enters a chat and it becomes apparent that it is impossible to+  -- update user's chat history completely. Chat history is kept only up to+  -- maximum of 400 messages or 2 weeks. When a user has been offline past that+  -- limit, GAP_IN_CHAT notification is generated. Added in protocol 7.+  | ChatMessageTypeGapInChat++  -- | System messages that are sent when a chat member gets promoted or+  -- demoted.+  | ChatMessageTypeSetRole++  -- | System messages that are sent when a chat member gets kicked+  | ChatMessageTypeKicked++  -- | System messages that are sent when a chat member gets banned.+  | ChatMessageTypeKickBanned++  -- | System messages that are sent when chat options are changed.+  | ChatMessageTypeSetOptions++  -- | System messages that are sent when a chat member has changed the public+  -- chat topic picture. Added in protocol 7.+  | ChatMessageTypeSetPicture++  -- | System messages that are sent when chat guidelines are changed.+  | ChatMessageTypeSetGuideLines++  -- | notification message that gets sent in a public chat with+  -- JOINERS_BECOME_APPLICANTS options, when a new user joins the chat.+  | ChatMessageTypeJoinedAsApplicant++  | ChatMessageTypeEmoted++  -- | Unknown message type, possibly due to connecting to Skype with older+  -- protocol.+  | ChatMessageTypeUnkown+  deriving (Eq, Show, Typeable)++data ChatMessageStatus+  -- | Message is being sent+  = ChatMessageStatusSending++  -- | Message was sent+  | ChatMessageStatusSent++  -- | Message has been received+  | ChatMessageStatusReceive++  -- | Message has been read+  | ChatMessageStatusRead+  deriving (Eq, Show, Typeable)++data ChatMessageLeaveReason+  -- | User was not found+  = ChatMessageLeaveReasonUserNotFound++  -- | User has an older Skype version and cannot join multichat+  | ChatMessageLeaveReasonUserIncapable++  -- | Recipient accepts messages from contacts only and sender is not in+  -- his/her contact list+  | ChatMessageLeaveReasonAdderMustBeFriend++  -- | Recipient accepts messages from authorized users only and sender is not+  -- authorized+  | ChatMessageLeaveReasonAdderMustBeAuthorized++  -- | Participant left chat+  | ChatMessageLeaveReasonUnsubscribe+  deriving (Eq, Show, Typeable)
+ src/Network/Skype/Protocol/Misc.hs view
@@ -0,0 +1,9 @@+module Network.Skype.Protocol.Misc where++import Data.Typeable (Typeable)++data ConnectionStatus = ConnectionStatusOffline+                      | ConnectionStatusConnecting+                      | ConnectionStatusPausing+                      | ConnectionStatusOnline+  deriving (Eq, Show, Typeable)
+ src/Network/Skype/Protocol/Types.hs view
@@ -0,0 +1,56 @@+module Network.Skype.Protocol.Types where++import Data.Time.Calendar (Day)++import qualified Data.ByteString as BS+import qualified Data.Text as T++-- * User++type UserID = BS.ByteString+type UserHandle = T.Text+type UserFullName = T.Text+type UserDisplayName = T.Text+type UserBirthday = Day+type UserLanguage = T.Text+type UserLanguageISOCode = T.Text+type UserCountry = T.Text+type UserCountryISOCode = T.Text+type UserProvince = T.Text+type UserCity = T.Text+type UserPhone = T.Text+type UserAbout = T.Text+type UserHomepage = T.Text+type UserSpeedDial = T.Text+type UserAuthRequestMessage = T.Text+type UserMoodText = T.Text+type UserRichMoodText = T.Text+type UserTimezoneOffset = Int++-- * Chat++type ChatID = BS.ByteString+type ChatTopic = T.Text+type ChatWindowTitle = T.Text+type ChatPasswordHint = T.Text+type ChatGuidelines = T.Text+type ChatDescription = T.Text+type ChatBlob = BS.ByteString++-- * Chat member++type ChatMemberID = Integer++-- * Chat message++type ChatMessageID = Integer+type ChatMessageBody = T.Text++-- * Misc.++type Timestamp = Int++type ErrorCode = Int+type ErrorDescription = T.Text++type ProtocolVersion = Int
+ src/Network/Skype/Protocol/User.hs view
@@ -0,0 +1,66 @@+module Network.Skype.Protocol.User where++import Data.Typeable (Typeable)+import Network.Skype.Protocol.Types++data UserProperty = UserHandle UserID+                  | UserFullName UserFullName+                  | UserBirthday (Maybe UserBirthday)+                  | UserSex UserSex+                  | UserLanguage (Maybe (UserLanguageISOCode, UserLanguage))+                  | UserCountry (Maybe (UserCountryISOCode, UserCountry))+                  | UserProvince UserProvince+                  | UserCity UserCity+                  | UserHomePhone UserPhone+                  | UserOfficePhone UserPhone+                  | UserMobilePhone UserPhone+                  | UserHomepage UserHomepage+                  | UserAbout UserAbout+                  | UserHasCallEquipment Bool+                  | UserIsVideoCapable Bool+                  | UserIsVoicemailCapable Bool+                  | UserBuddyStatus UserBuddyStatus+                  | UserIsAuthorized Bool+                  | UserIsBlocked Bool+                  | UserOnlineStatus UserOnlineStatus+                  | UserLastOnlineTimestamp Timestamp+                  | UserCanLeaveVoicemail Bool+                  | UserSpeedDial UserSpeedDial+                  | UserReceiveAuthRequest UserAuthRequestMessage+                  | UserMoodText UserMoodText+                  | UserRichMoodText UserRichMoodText+                  | UserTimezone UserTimezoneOffset+                  | UserIsCallForwardingActive Bool+                  | UserNumberOfAuthedBuddies Int+                  | UserDisplayName UserDisplayName+  deriving (Eq, Show, Typeable)++data UserSex = UserSexUnknown+             | UserSexMale+             | UserSexFemale+  deriving (Eq, Show, Typeable)++data UserStatus = UserStatusUnknown       -- ^ no status information for current user.+                | UserStatusOnline        -- ^ current user is online.+                | UserStatusOffline       -- ^ current user is offline.+                | UserStatusSkypeMe       -- ^ current user is in "Skype Me" mode (Protocol 2).+                | UserStatusAway          -- ^ current user is away.+                | UserStatusNotAvailable  -- ^ current user is not available.+                | UserStatusDoNotDisturb  -- ^ current user is in "Do not disturb" mode.+                | UserStatusInvisible     -- ^ current user is invisible to others.+                | UserStatusLoggedOut     -- ^ current user is logged out. Clients are detached.+  deriving (Eq, Show, Typeable)++data UserBuddyStatus = UserBuddyStatusNeverBeen+                     | UserBuddyStatusDeleted+                     | UserBuddyStatusPending+                     | UserBuddyStatusAdded+  deriving (Eq, Show, Typeable)++data UserOnlineStatus = UserOnlineStatusUnknown+                      | UserOnlineStatusOffline+                      | UserOnlineStatusOnline+                      | UserOnlineStatusAway+                      | UserOnlineStatusNotAvailable+                      | UserOnlineStatusDoNotDisturb+  deriving (Eq, Show, Typeable)