{-# LANGUAGE CPP, DeriveDataTypeable, RankNTypes, RecordWildCards, ScopedTypeVariables #-}-----------------------------------------------------------------------------{- |
Module : Data.Acid.Remote
Copyright : PublicDomain
Maintainer : lemmih@gmail.com
Portability : non-portable (uses GHC extensions)
This module provides the ability perform 'update' and 'query' calls
from a remote process.
On the server-side you:
1. open your 'AcidState' normally
2. then use 'acidServer' to share the state
On the client-side you:
1. use 'openRemoteState' to connect to the remote state
2. use the returned 'AcidState' like any other 'AcidState' handle
'openRemoteState' and 'acidServer' communicate over an unencrypted
socket. If you need an encrypted connection, see @acid-state-tls@.
On Unix®-like systems you can use 'UnixSocket' to create a socket file for
local communication between the client and server. Access can be
controlled by setting the permissions of the parent directory
containing the socket file.
It is also possible to perform some simple authentication using
'sharedSecretCheck' and 'sharedSecretPerform'. Keep in mind that
secrets will be sent in plain-text if you do not use
@acid-state-tls@. If you are using a 'UnixSocket' additional
authentication may not be required, so you can use
'skipAuthenticationCheck' and 'skipAuthenticationPerform'.
Working with a remote 'AcidState' is nearly identical to working with
a local 'AcidState' with a few important differences.
The connection to the remote 'AcidState' can be lost. The client will
automatically attempt to reconnect every second. Because 'query'
events do not affect the state, an aborted 'query' will be retried
automatically after the server is reconnected.
If the connection was lost during an 'update' event, the event will
not be retried. Instead 'RemoteConnectionError' will be raised. This
is because it is impossible for the client to know if the aborted
update completed on the server-side or not.
When using a local 'AcidState', an update event in one thread does not
block query events taking place in other threads. With a remote
connection, all queries and requests are channeled over a single
connection. As a result, updates and queries are performed in the
order they are executed and do block each other. In the rare case
where this is an issue, you could create one remote connection per
thread.
When working with local state, a query or update which returns the
whole state is not usually a problem due to memory sharing. The
update/query event basically just needs to return a pointer to the
data already in memory. But, when working remotely, the entire result
will be serialized and sent to the remote client. Hence, it is good
practice to create queries and updates that will only return the
required data.
This module is designed to be extenible. You can easily add your own
authentication methods by creating a suitable pair of functions and
passing them to 'acidServer' and 'openRemoteState'.
It is also possible to create alternative communication layers using
'CommChannel', 'process', and 'processRemoteState'.
-}moduleData.Acid.Remote(-- * Server/ClientacidServer,openRemoteState-- * Authentication,skipAuthenticationCheck,skipAuthenticationPerform,sharedSecretCheck,sharedSecretPerform-- * Exception type,AcidRemoteException(..)-- * Low-Level functions needed to implement additional communication channels,CommChannel(..),process,processRemoteState)whereimportPreludehiding(catch)importControl.Concurrent.STM(atomically)importControl.Concurrent.STM.TMVar(newEmptyTMVar,readTMVar,takeTMVar,tryTakeTMVar,putTMVar)importControl.Concurrent.STM.TQueueimportControl.Exception(AsyncException(ThreadKilled),Exception(fromException),IOException,Handler(..),SomeException,catch,catches,throw)importControl.Exception(throwIO,finally)importControl.Monad(forever,liftM,join,when)importControl.Concurrent(ThreadId,forkIO,threadDelay,killThread,myThreadId)importControl.Concurrent.MVar(MVar,newEmptyMVar,putMVar,takeMVar)importControl.Concurrent.Chan(newChan,readChan,writeChan)importData.Acid.AbstractimportData.Acid.CoreimportData.Acid.CommonimportqualifiedData.ByteStringasStrictimportData.ByteString.Char8(pack)importqualifiedData.ByteString.LazyasLazyimportData.IORef(newIORef,readIORef,writeIORef)importData.SerializeimportData.SafeCopy(SafeCopy,safeGet,safePut)importData.Set(Set,member)importData.Typeable(Typeable)importGHC.IO.Exception(IOErrorType(..))importNetwork(HostName,PortID(..),connectTo,listenOn,withSocketsDo)importNetwork.Socket(Socket,accept,sClose)importNetwork.Socket.ByteString(recv,sendAll)importSystem.Directory(removeFile)importSystem.IO(Handle,hPrint,hFlush,hClose,stderr)importSystem.IO.Error(ioeGetErrorType,isFullError,isDoesNotExistError)debugStrLn::String->IO()debugStrLns=do-- putStrLn s -- uncomment to enable debuggingreturn()-- | 'CommChannel' is a record containing the IO functions we need for communication between the server and client.---- We abstract this out of the core processing function so that we can easily add support for SSL/TLS and Unit testing.dataCommChannel=CommChannel{ccPut::Strict.ByteString->IO(),ccGetSome::Int->IO(Strict.ByteString),ccClose::IO()}dataAcidRemoteException=RemoteConnectionError|AcidStateClosed|SerializeErrorString|AuthenticationErrorStringderiving(Eq,Show,Typeable)instanceExceptionAcidRemoteException-- | create a 'CommChannel' from a 'Handle'. The 'Handle' should be-- some two-way communication channel, such as a socket-- connection. Passing in a 'Handle' to a normal is file is unlikely-- to do anything useful.handleToCommChannel::Handle->CommChannelhandleToCommChannelhandle=CommChannel{ccPut=\bs->Strict.hPuthandlebs>>hFlushhandle,ccGetSome=Strict.hGetSomehandle,ccClose=hClosehandle}{- | create a 'CommChannel' from a 'Socket'. The 'Socket' should be
an accepted socket, not a listen socket.
-}socketToCommChannel::Socket->CommChannelsocketToCommChannelsocket=CommChannel{ccPut=sendAllsocket,ccGetSome=recvsocket,ccClose=sClosesocket}{- | skip server-side authentication checking entirely. -}skipAuthenticationCheck::CommChannel->IOBoolskipAuthenticationCheck_=returnTrue{- | skip client-side authentication entirely. -}skipAuthenticationPerform::CommChannel->IOBoolskipAuthenticationPerform_=returnTrue{- | check that the client knows a shared secret.
The function takes a 'Set' of shared secrets. If a client knows any
of them, it is considered to be trusted.
The shared secret is any 'ByteString' of your choice.
If you give each client a different shared secret then you can
revoke access individually.
see also: 'sharedSecretPerform'
-}sharedSecretCheck::SetStrict.ByteString-- ^ set of shared secrets->(CommChannel->IOBool)sharedSecretChecksecretscc=dobs<-ccGetSomecc1024ifmemberbssecretsthendoccPutcc(pack"OK")returnTrueelsedoccPutcc(pack"FAIL")returnFalse-- | attempt to authenticate with the server using a shared secret.sharedSecretPerform::Strict.ByteString-- ^ shared secret->(CommChannel->IO())sharedSecretPerformpwcc=doccPutccpwr<-ccGetSomecc1024ifr==(pack"OK")thenreturn()elsethrowIO(AuthenticationError"shared secret authentication failed."){- | Accept connections on @port@ and handle requests using the given 'AcidState'.
This call doesn't return.
On Unix®-like systems you can use 'UnixSocket' to communicate
using a socket file. To control access, you can set the permissions of
the parent directory which contains the socket file.
see also: 'openRemoteState' and 'sharedSecretCheck'.
-}acidServer::SafeCopyst=>(CommChannel->IOBool)-- ^ check authentication, see 'sharedSecretPerform'->PortID-- ^ Port to listen on->AcidStatest-- ^ state to serve->IO()acidServercheckAuthportacidState=withSocketsDo$dolistenSocket<-listenOnportletloop=forever$do(socket,_sockAddr)<-acceptlistenSocketletcommChannel=socketToCommChannelsocketforkIO$doauthorized<-checkAuthcommChannelwhenauthorized$processcommChannelacidStateccClosecommChannel-- FIXME: `finally` ?infi=loop`catchSome`logError>>infiinfi`finally`(cleanuplistenSocket)wherelogError::(Showe)=>e->IO()logErrore=hPrintstderreisResourceVanishedError::IOException->BoolisResourceVanishedError=isResourceVanishedType.ioeGetErrorTypeisResourceVanishedType::IOErrorType->BoolisResourceVanishedTypeResourceVanished=TrueisResourceVanishedType_=FalsecatchSome::IO()->(Showe=>e->IO())->IO()catchSomeop_h=op`catches`[Handler$\(e::IOException)->ifisFullErrore||isDoesNotExistErrore||isResourceVanishedErrorethenreturn()-- h (toException e) -- we could log the exception, but there could be thousands of themelsethrowe]cleanupsocket=dosClosesocketcaseportof#if !defined(mingw32_HOST_OS) && !defined(cygwin32_HOST_OS) && !defined(_WIN32)UnixSocketpath->removeFilepath#endif_->return()dataCommand=RunQuery(TaggedLazy.ByteString)|RunUpdate(TaggedLazy.ByteString)|CreateCheckpointinstanceSerializeCommandwhereputcmd=casecmdofRunQueryquery->doputWord80;putqueryRunUpdateupdate->doputWord81;putupdateCreateCheckpoint->putWord82get=dotag<-getWord8casetagof0->liftMRunQueryget1->liftMRunUpdateget2->returnCreateCheckpoint_->error$"Serialize.get for Command, invalid tag: "++showtagdataResponse=ResultLazy.ByteString|Acknowledgement|ConnectionErrorinstanceSerializeResponsewhereputresp=caserespofResultresult->doputWord80;putresultAcknowledgement->putWord81ConnectionError->putWord82get=dotag<-getWord8casetagof0->liftMResultget1->returnAcknowledgement2->returnConnectionError_->error$"Serialize.get for Response, invalid tag: "++showtag{- | Server inner-loop
This function is generally only needed if you are adding a new communication channel.
-}process::SafeCopyst=>CommChannel-- ^ a connected, authenticated communication channel->AcidStatest-- ^ state to share->IO()processCommChannel{..}acidState=dochan<-newChanforkIO$forever$doresponse<-join(readChanchan)ccPut(encoderesponse)workerchan(runGetPartialgetStrict.empty)whereworkerchaninp=caseinpofFailmsg->throwIO(SerializeErrormsg)Partialcont->dobs<-ccGetSome1024workerchan(contbs)Donecmdrest->doprocessCommandchancmd;workerchan(runGetPartialgetrest)processCommandchancmd=casecmdofRunQueryquery->doresult<-queryColdacidStatequerywriteChanchan(return$Resultresult)RunUpdateupdate->doresult<-scheduleColdUpdateacidStateupdatewriteChanchan(liftMResult$takeMVarresult)CreateCheckpoint->docreateCheckpointacidStatewriteChanchan(returnAcknowledgement)dataRemoteStatest=RemoteState(Command->IO(MVarResponse))(IO())deriving(Typeable){- | Connect to an acid-state server which is sharing an 'AcidState'. -}openRemoteState::IsAcidicst=>(CommChannel->IO())-- ^ authentication function, see 'sharedSecretPerform'->HostName-- ^ remote host to connect to (ignored when 'PortID' is 'UnixSocket')->PortID-- ^ remote port to connect to->IO(AcidStatest)openRemoteStateperformAuthorizationhostport=withSocketsDo$doprocessRemoteStatereconnectwhere-- | reconnectreconnect::IOCommChannelreconnect=(dodebugStrLn"Reconnecting."handle<-connectTohostportletcc=handleToCommChannelhandleperformAuthorizationccdebugStrLn"Reconnected."returncc)`catch`((\_->threadDelay1000000>>reconnect)::IOError->IOCommChannel){- | Client inner-loop
This function is generally only needed if you are adding a new communication channel.
-}processRemoteState::IsAcidicst=>IOCommChannel-- ^ (re-)connect function->IO(AcidStatest)processRemoteStatereconnect=docmdQueue<-atomicallynewTQueueccTMV<-atomicallynewEmptyTMVarisClosed<-newIORefFalseletactor::Command->IO(MVarResponse)actorcommand=dodebugStrLn"actor: begin."readIORefisClosed>>=flipwhen(throwIOAcidStateClosed)ref<-newEmptyMVaratomically$writeTQueuecmdQueue(command,ref)debugStrLn"actor: end."returnrefexpireQueuelistenQueue=domCallback<-atomically$tryReadTQueuelistenQueuecasemCallbackofNothing->return()(Justcallback)->docallbackConnectionErrorexpireQueuelistenQueuehandleReconnect::SomeException->IO()handleReconnecte=casefromExceptioneof(JustThreadKilled)->dodebugStrLn"handleReconnect: ThreadKilled. Not attempting to reconnect."return()_->dodebugStrLn$"handleReconnect begin."tmv<-atomically$tryTakeTMVarccTMVcasetmvofNothing->dodebugStrLn$"handleReconnect: error handling already in progress."debugStrLn$"handleReconnect end."return()(Just(oldCC,oldListenQueue,oldListenerTID))->dothisTID<-myThreadIdwhen(thisTID/=oldListenerTID)(killThreadoldListenerTID)ccCloseoldCCexpireQueueoldListenQueuecc<-reconnectlistenQueue<-atomically$newTQueuelistenerTID<-forkIO$listenercclistenQueueatomically$putTMVarccTMV(cc,listenQueue,listenerTID)debugStrLn$"handleReconnect end."return()listener::CommChannel->TQueue(Response->IO())->IO()listenercclistenQueue=getResponseStrict.empty`catch`handleReconnectwheregetResponseleftover=dodebugStrLn$"listener: listening for Response."letgoinp=caseinpofFailmsg->errormsgPartialcont->dodebugStrLn$"listener: ccGetSome"bs<-ccGetSomecc1024go(contbs)Doneresprest->dodebugStrLn$"listener: getting callback"callback<-atomically$readTQueuelistenQueuedebugStrLn$"listener: passing Response to callback"callback(resp::Response)returnrestrest<-go(runGetPartialgetleftover)-- `catch` (\e -> do handleReconnect e-- throwIO e-- )getResponserestactorThread::IO()actorThread=forever$dodebugStrLn"actorThread: waiting for something to do."(cc,cmd)<-atomically$do(cmd,ref)<-readTQueuecmdQueue(cc,listenQueue,_)<-readTMVarccTMVwriteTQueuelistenQueue(putMVarref)return(cc,cmd)debugStrLn"actorThread: sending command."ccPutcc(encodecmd)`catch`handleReconnectdebugStrLn"actorThread: sent."return()shutdown::ThreadId->IO()shutdownactorTID=dodebugStrLn"shutdown: update isClosed IORef to True."writeIORefisClosedTruedebugStrLn"shutdown: killing actor thread."killThreadactorTIDdebugStrLn"shutdown: taking ccTMV."(cc,listenQueue,listenerTID)<-atomically$takeTMVarccTMV-- FIXME: or should this by tryTakeTMVardebugStrLn"shutdown: killing listener thread."killThreadlistenerTIDdebugStrLn"shutdown: expiring listen queue."expireQueuelistenQueuedebugStrLn"shutdown: closing connection."ccCloseccreturn()cc<-reconnectlistenQueue<-atomically$newTQueueactorTID<-forkIO$actorThreadlistenerTID<-forkIO$listenercclistenQueueatomically$putTMVarccTMV(cc,listenQueue,listenerTID)return(toAcidState$RemoteStateactor(shutdownactorTID))remoteQuery::QueryEventevent=>RemoteState(EventStateevent)->event->IO(EventResultevent)remoteQueryacidStateevent=doletencoded=runPutLazy(safePutevent)resp<-remoteQueryColdacidState(methodTagevent,encoded)return(caserunGetLazyFixsafeGetrespofLeftmsg->errormsgRightresult->result)remoteQueryCold::RemoteStatest->TaggedLazy.ByteString->IOLazy.ByteStringremoteQueryColdrs@(RemoteStatefn_shutdown)event=doresp<-takeMVar=<<fn(RunQueryevent)caserespof(Resultresult)->returnresultConnectionError->dodebugStrLn"retrying query event."remoteQueryColdrseventAcknowledgement->error"remoteQueryCold got Acknowledgement. That should never happen."scheduleRemoteUpdate::UpdateEventevent=>RemoteState(EventStateevent)->event->IO(MVar(EventResultevent))scheduleRemoteUpdate(RemoteStatefn_shutdown)event=doletencoded=runPutLazy(safePutevent)parsed<-newEmptyMVarrespRef<-fn(RunUpdate(methodTagevent,encoded))forkIO$doResultresp<-takeMVarrespRefputMVarparsed(caserunGetLazyFixsafeGetrespofLeftmsg->errormsgRightresult->result)returnparsedscheduleRemoteColdUpdate::RemoteStatest->TaggedLazy.ByteString->IO(MVarLazy.ByteString)scheduleRemoteColdUpdate(RemoteStatefn_shutdown)event=doparsed<-newEmptyMVarrespRef<-fn(RunUpdateevent)forkIO$doResultresp<-takeMVarrespRefputMVarparsedrespreturnparsedcloseRemoteState::RemoteStatest->IO()closeRemoteState(RemoteState_fnshutdown)=shutdowncreateRemoteCheckpoint::RemoteStatest->IO()createRemoteCheckpoint(RemoteStatefn_shutdown)=doAcknowledgement<-takeMVar=<<fnCreateCheckpointreturn()toAcidState::IsAcidicst=>RemoteStatest->AcidStatesttoAcidStateremote=AcidState{_scheduleUpdate=scheduleRemoteUpdateremote,scheduleColdUpdate=scheduleRemoteColdUpdateremote,_query=remoteQueryremote,queryCold=remoteQueryColdremote,createCheckpoint=createRemoteCheckpointremote,closeAcidState=closeRemoteStateremote,acidSubState=mkAnyStateremote}