diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright (c) 2013 Shota Nozaki + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in +all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN +THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/skype4hs.cabal b/skype4hs.cabal new file mode 100644 --- /dev/null +++ b/skype4hs.cabal @@ -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 diff --git a/src/Network/Skype/API.hs b/src/Network/Skype/API.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/API.hs @@ -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 diff --git a/src/Network/Skype/API/Carbon.hs b/src/Network/Skype/API/Carbon.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/API/Carbon.hs @@ -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) diff --git a/src/Network/Skype/API/Carbon/CFBase.hsc b/src/Network/Skype/API/Carbon/CFBase.hsc new file mode 100644 --- /dev/null +++ b/src/Network/Skype/API/Carbon/CFBase.hsc @@ -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 +} diff --git a/src/Network/Skype/API/Carbon/CFDictionary.hsc b/src/Network/Skype/API/Carbon/CFDictionary.hsc new file mode 100644 --- /dev/null +++ b/src/Network/Skype/API/Carbon/CFDictionary.hsc @@ -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) diff --git a/src/Network/Skype/API/Carbon/CFNotificationCenter.hsc b/src/Network/Skype/API/Carbon/CFNotificationCenter.hsc new file mode 100644 --- /dev/null +++ b/src/Network/Skype/API/Carbon/CFNotificationCenter.hsc @@ -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)) diff --git a/src/Network/Skype/API/Carbon/CFNumber.hsc b/src/Network/Skype/API/Carbon/CFNumber.hsc new file mode 100644 --- /dev/null +++ b/src/Network/Skype/API/Carbon/CFNumber.hsc @@ -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 diff --git a/src/Network/Skype/API/Carbon/CFString.hsc b/src/Network/Skype/API/Carbon/CFString.hsc new file mode 100644 --- /dev/null +++ b/src/Network/Skype/API/Carbon/CFString.hsc @@ -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 diff --git a/src/Network/Skype/API/Carbon/CarbonEventsCore.hsc b/src/Network/Skype/API/Carbon/CarbonEventsCore.hsc new file mode 100644 --- /dev/null +++ b/src/Network/Skype/API/Carbon/CarbonEventsCore.hsc @@ -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 () diff --git a/src/Network/Skype/API/X11.hsc b/src/Network/Skype/API/X11.hsc new file mode 100644 --- /dev/null +++ b/src/Network/Skype/API/X11.hsc @@ -0,0 +1,246 @@ +module Network.Skype.API.X11 ( + Connection, + DisplayAddress, + connect, + connectTo +) where + +#include + +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 diff --git a/src/Network/Skype/Command/Chat.hs b/src/Network/Skype/Command/Chat.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Command/Chat.hs @@ -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 diff --git a/src/Network/Skype/Command/ChatMember.hs b/src/Network/Skype/Command/ChatMember.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Command/ChatMember.hs @@ -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" diff --git a/src/Network/Skype/Command/ChatMessage.hs b/src/Network/Skype/Command/ChatMessage.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Command/ChatMessage.hs @@ -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 diff --git a/src/Network/Skype/Command/Misc.hs b/src/Network/Skype/Command/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Command/Misc.hs @@ -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) diff --git a/src/Network/Skype/Command/User.hs b/src/Network/Skype/Command/User.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Command/User.hs @@ -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" diff --git a/src/Network/Skype/Command/Utils.hs b/src/Network/Skype/Command/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Command/Utils.hs @@ -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 diff --git a/src/Network/Skype/Core.hs b/src/Network/Skype/Core.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Core.hs @@ -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 diff --git a/src/Network/Skype/Parser.hs b/src/Network/Skype/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Parser.hs @@ -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) diff --git a/src/Network/Skype/Parser/Chat.hs b/src/Network/Skype/Parser/Chat.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Parser/Chat.hs @@ -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") + ] diff --git a/src/Network/Skype/Parser/ChatMember.hs b/src/Network/Skype/Parser/ChatMember.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Parser/ChatMember.hs @@ -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 diff --git a/src/Network/Skype/Parser/ChatMessage.hs b/src/Network/Skype/Parser/ChatMessage.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Parser/ChatMessage.hs @@ -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" + ] diff --git a/src/Network/Skype/Parser/Types.hs b/src/Network/Skype/Parser/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Parser/Types.hs @@ -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 diff --git a/src/Network/Skype/Parser/User.hs b/src/Network/Skype/Parser/User.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Parser/User.hs @@ -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 diff --git a/src/Network/Skype/Protocol.hs b/src/Network/Skype/Protocol.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Protocol.hs @@ -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) diff --git a/src/Network/Skype/Protocol/Chat.hs b/src/Network/Skype/Protocol/Chat.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Protocol/Chat.hs @@ -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) diff --git a/src/Network/Skype/Protocol/ChatMember.hs b/src/Network/Skype/Protocol/ChatMember.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Protocol/ChatMember.hs @@ -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) diff --git a/src/Network/Skype/Protocol/ChatMessage.hs b/src/Network/Skype/Protocol/ChatMessage.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Protocol/ChatMessage.hs @@ -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) diff --git a/src/Network/Skype/Protocol/Misc.hs b/src/Network/Skype/Protocol/Misc.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Protocol/Misc.hs @@ -0,0 +1,9 @@ +module Network.Skype.Protocol.Misc where + +import Data.Typeable (Typeable) + +data ConnectionStatus = ConnectionStatusOffline + | ConnectionStatusConnecting + | ConnectionStatusPausing + | ConnectionStatusOnline + deriving (Eq, Show, Typeable) diff --git a/src/Network/Skype/Protocol/Types.hs b/src/Network/Skype/Protocol/Types.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Protocol/Types.hs @@ -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 diff --git a/src/Network/Skype/Protocol/User.hs b/src/Network/Skype/Protocol/User.hs new file mode 100644 --- /dev/null +++ b/src/Network/Skype/Protocol/User.hs @@ -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)