{- |
Basic functions for initiating and working with a connection to an
X11 server.
-}moduleGraphics.XHB.Connection(Connection,connect,connectTo,displayInfo,connectionSetup,mkConnection,newResource,pollForEvent,waitForEvent,pollForError,waitForError,setCrashOnError,SomeError,SomeEvent,getRoot)whereimportData.Word-- MAY import generated type modules (XHB.Gen.*.Types)-- MAY NOT import other generated modulesimportControl.Concurrent.STMimportControl.ConcurrentimportControl.MonadimportSystem.IOimportSystem.ByteOrderimportForeign.C.StringimportData.List(genericLength)importData.MaybeimportData.Monoid(mempty)importqualifiedData.MapasMimportData.ByteString.Lazy(ByteString)importqualifiedData.ByteString.LazyasBSimportData.Binary.GetimportData.Binary.PutimportData.BitsimportGraphics.XHB.Gen.Xproto.TypesimportGraphics.XHB.Gen.ExtensionimportGraphics.XHB.Connection.TypesimportGraphics.XHB.Connection.InternalimportGraphics.XHB.Connection.OpenimportGraphics.XHB.SharedimportGraphics.X11.Xauth-- | Returns the 'Setup' information returned by the server-- during the initiation of the connection.connectionSetup::Connection->SetupconnectionSetup=conf_setup.conn_confnewResource::XidLikea=>Connection->IOanewResourcec=doxidM<-nextXidccasexidMofJustxid->return.fromXid$xidNothing->error"resource ids exhausted"-- request more herenextXid::Connection->IO(MaybeXid)nextXidc=atomically$dolettv=conn_resource_idscxids<-readTVartvcasexidsof[]->returnNothing(x:xs)->dowriteTVartvxsreturn.return$xpollForEvent::Connection->IO(MaybeSomeEvent)pollForEventc=atomically$pollTChan$conn_event_queuecwaitForEvent::Connection->IOSomeEventwaitForEventc=atomically$readTChan$conn_event_queuecpollForError::Connection->IO(MaybeSomeError)pollForErrorc=atomically$pollTChan$conn_error_queuecwaitForError::Connection->IOSomeErrorwaitForErrorc=atomically$readTChan$conn_error_queuecpollTChan::TChana->STM(Maybea)pollTChantc=doempty<-isEmptyTChantcifemptythenreturnNothingelseJust`liftM`readTChantc-- | If you don't feel like writing error handlers, but at least want to know that-- one happened for debugging purposes, call this to have execution come to an-- abrupt end if an error is received.setCrashOnError::Connection->IO()setCrashOnErrorc=doforkIO$dowaitForErrorcerror"Received error from server. Crashing."return()-- Any response from the server is first read into-- this type.dataGenericReply=GenericReply{grep_response_type::ResponseType,grep_error_code::Word8,grep_sequence::Word16,grep_reply_length::Word32-- only useful for replies}dataResponseType=ResponseTypeEventWord8|ResponseTypeError|ResponseTypeReplyinstanceDeserializeGenericReplywheredeserialize=dotype_flag<-deserializeletrType=casetype_flagof0->ResponseTypeError1->ResponseTypeReply_->ResponseTypeEventtype_flagcode<-deserializesequence<-deserializereply_length<-deserializereturn$GenericReplyrTypecodesequencereply_length-- state maintained by the read loopdataReadLoop=ReadLoop{read_error_queue::TChanSomeError-- write only,read_event_queue::TChanSomeEvent-- write only,read_input_queue::Handle-- read only,read_reps::TChanPendedReply-- read only,read_config::ConnectionConfig,read_extensions::TVarExtensionMap}---- Processing for events/errors-- reverse-lookup infrastructure for extensions. Not pretty or-- maybe not even fast. But it is straight-forward.queryExtMap::(QueryExtensionReply->Word8)->ReadLoop->Word8->IO(Maybe(ExtensionId,Word8))queryExtMapfrcode=doext_map<-atomically.readTVar$read_extensionsrreturn$findFromCodeext_mapwherefindFromCodexmap=foldrgoNothing(M.toListxmap)go(ident,extInfo)old|num<=code=caseoldofJust(_oldIndent,oldNum)|oldNum>num->old_->Just(ident,num)|otherwise=oldwherenum=fextInfo-- | Returns the extension id and the base event codeextensionIdFromEventCode::ReadLoop->Word8->IO(Maybe(ExtensionId,Word8))extensionIdFromEventCode=queryExtMapfirst_event_QueryExtensionReply-- | Returns the extension id and the base error codeextensionIdFromErrorCode::ReadLoop->Word8->IO(Maybe(ExtensionId,Word8))extensionIdFromErrorCode=queryExtMapfirst_error_QueryExtensionReplybsToError::ReadLoop->ByteString-- ^Raw data->Word8-- ^Error code->IOSomeErrorbsToError_rchunkcode|code<128=casedeserializeErrorcodeofNothing->return.toError.UnknownError$chunkJustgetAction->return$runGetgetActionchunkbsToErrorrchunkcode=extensionIdFromErrorCodercode>>=\errInfo->caseerrInfoofNothing->return.toError.UnknownError$chunkJust(extId,baseErr)->caseerrorDispatchextId(code-baseErr)ofNothing->return.toError.UnknownError$chunkJustgetAction->return$runGetgetActionchunkbsToEvent::ReadLoop->ByteString-- ^Raw data->Word8-- ^Event code->IOSomeEventbsToEvent_rchunkcode|code<64=casedeserializeEventcodeofNothing->return.toEvent.UnknownEvent$chunkJustgetAction->return$runGetgetActionchunkbsToEventrchunkcode=extensionIdFromEventCodercode>>=\evInfo->caseevInfoofNothing->return.toEvent.UnknownEvent$chunkJust(extId,baseEv)->caseeventDispatchextId(code-baseEv)ofNothing->return.toEvent.UnknownEvent$chunkJustgetAction->return$runGetgetActionchunkdeserializeInReadLooprl=deserializereadBytes::ReadLoop->Int->IOByteStringreadBytesrln=BS.hGet(read_input_queuerl)n-- the read loop slurps bytes off of the handle, and places-- them into the appropriate shared structure.readLoop::ReadLoop->IO()readLooprl=dochunk<-readBytesrl32letgenRep=fliprunGetchunk$deserializecasegrep_response_typegenRepofResponseTypeError->readLoopErrorrlgenRepchunkResponseTypeReply->readLoopReplyrlgenRepchunkResponseTypeEvent_->readLoopEventrlgenRepchunkreadLooprl-- handle a response to a requestreadLoopReply::ReadLoop->GenericReply->ByteString->IO()readLoopReplyrlgenRepchunk=do-- grab the rest of the response bytesletrlength=grep_reply_lengthgenRepextra<-readBytesrl$fromIntegral$4*rlengthletbytes=chunk`BS.append`extra-- place the response into the pending reply TMVar, or discard itatomically$donextPend<-readTChan$read_repsrlif(pended_sequencenextPend)==(grep_sequencegenRep)thenputReceipt(pended_replynextPend)$RightbyteselseunGetTChan(read_repsrl)nextPend-- take the bytes making up the error response, shove it in-- a queue.---- If the error corresponds to one of the pending replies,-- place the error into the pending reply TMVar instead.readLoopErrorrlgenRepchunk=doleterrorCode=grep_error_codegenReperr<-bsToErrorrlchunkerrorCodeatomically$donextPend<-readTChan$read_repsrlif(pended_sequencenextPend)==(grep_sequencegenRep)thenputReceipt(pended_replynextPend)$LefterrelsedounGetTChan(read_repsrl)nextPendwriteTChan(read_error_queuerl)err-- take the bytes making up the event response, shove it in-- a queuereadLoopEventrlgenRepchunk=doev<-bsToEventrlchunkeventCodeatomically$writeTChan(read_event_queuerl)evwhereeventCode=casegrep_response_typegenRepofResponseTypeEventw->w.&.127-- | Connect to the the default display.connect::IO(MaybeConnection)connect=connectTo""-- | Connect to the display specified.-- The string must be of the format used in the-- DISPLAY environment variable.connectTo::String->IO(MaybeConnection)connectTodisplay=do(h,xau,dispName)<-opendisplayhSetBufferinghNoBufferingmkConnectionhxaudispName-- | Returns the information about what we originally tried to-- connect to.displayInfo::Connection->DispNamedisplayInfo=conn_dispInfo-- Handshake with the server-- parse result of handshake-- launch the thread which holds the handle for readingmkConnection::Handle->MaybeXauth->DispName->IO(MaybeConnection)mkConnectionhndauthdispInfo=doerrorQueue<-newTChanIOeventQueue<-newTChanIOreplies<-newTChanIOsequence<-initialSequenceextensions<-newTVarIOmemptywrappedHandle<-newMVarhndconfM<-handshakehndauthifisNothingconfMthenreturnNothingelsedoletJustconf=confMrIds<-newTVarIO$resourceIdsconfletrlData=ReadLooperrorQueueeventQueuehndrepliesconfextensionsreadTid<-forkIO$readLooprlDatareturn$Just$ConnectionerrorQueueeventQueuereadTidwrappedHandlerepliesconfsequencerIdsextensionsdispInforesourceIds::ConnectionConfig->[Xid]resourceIdscc=resourceIdsFromSetup$conf_setupccresourceIdsFromSetup::Setup->[Xid]resourceIdsFromSetups=letbase=resource_id_base_Setupsmask=resource_id_mask_Setupsmax=maskstep=mask.&.(-mask)inmapMkXid$map(.|.base)[0,step..max]-- first 8 bytes of the response from the setup requestdataGenericSetup=GenericSetup{setup_status::SetupStatus,setup_length::Word16}derivingShowinstanceDeserializeGenericSetupwheredeserialize=dostatus<-deserializeskip5length<-deserializereturn$GenericSetupstatuslengthdataSetupStatus=SetupFailed|SetupAuthenticate|SetupSuccessderivingShowinstanceDeserializeSetupStatuswheredeserialize=wordToStatus`liftM`deserializewherewordToStatus::Word8->SetupStatuswordToStatus0=SetupFailedwordToStatus1=SetupSuccesswordToStatus2=SetupAuthenticatewordToStatusn=error$"Unkonwn setup status flag: "++shown-- send the setup request to the server,-- receive the setup responsehandshake::Handle->MaybeXauth->IO(MaybeConnectionConfig)handshakehndauth=do-- send setup requestletrequestChunk=runPut$serialize$setupRequestauthBS.hPuthnd$requestChunk-- grab an 8-byte chunk to get the response type and sizefirstChunk<-BS.hGethnd8letgenSetup=runGetdeserializefirstChunk-- grab the rest of the setup responsesecondChunk<-BS.hGethnd$fromIntegral$(4*)$setup_lengthgenSetupletsetupBytes=firstChunk`BS.append`secondChunk-- handle the response typecasesetup_statusgenSetupofSetupFailed->doletfailed=runGetdeserializesetupBytesfailMessage=mapcastCCharToChar(reason_SetupFailedfailed)hPutStrLnstderrfailMessagereturnNothingSetupAuthenticate->doletauth=runGetdeserializesetupBytesauthMessage=mapcastCCharToChar(reason_SetupAuthenticateauth)hPutStrLnstderrauthMessagereturnNothingSetupSuccess->doletsetup=runGetdeserializesetupBytesreturn.return$ConnectionConfigsetuppadBSn=BS.replicaten0initialSequence::IO(TVarSequenceId)initialSequence=newTVarIO1setupRequest::MaybeXauth->SetupRequestsetupRequestauth=MkSetupRequest(fromIntegral$byteOrderToNumbyteOrder)11-- major version0-- minor versionanamelen-- auth name lengthadatalen-- auth data length-- TODO this manual padding is a horrible hack, it should be-- done by the serialization instance(aname++replicate(requiredPaddinganamelen)0)-- auth name(adata++replicate(requiredPaddingadatalen)0)-- auth datawhere(anamelen,aname,adatalen,adata)=caseauthofNothing->(0,[],0,[])Just(Xauthnd)->(genericLengthn,n,genericLengthd,d)-- | I plan on deprecating this one soon, but until I put together-- some sort of 'utils' package, it will live here.---- Given a connection, this function returns the root window of the-- first screen.---- If your display string specifies a screen other than the first,-- this probably doesnt do what you want.getRoot::Connection->WINDOWgetRoot=root_SCREEN.head.roots_Setup.conf_setup.conn_conf