module Network.BERT.Server
( DispatchResult(..)
, serve
) where
import Control.Concurrent (forkIO)
import Control.Monad.Trans (liftIO)
import Network.BERT.Transport (Transport, withTransport, servet, recvt, sendt)
import Data.ByteString.Lazy.Char8 as C
import Data.BERT (Term(..))
import Text.Printf (printf)
data DispatchResult
= Success Term
| NoSuchModule
| NoSuchFunction
| Undesignated String
deriving (Eq, Show, Ord)
serve :: Transport
-> (String -> String -> [Term] -> IO DispatchResult)
-> IO ()
serve transport dispatch =
servet transport $ \t ->
(forkIO $ withTransport t $ handleCall dispatch) >> return ()
handleCall dispatch = recvt >>= handle
where
handle (TupleTerm [AtomTerm "info", AtomTerm "stream", _]) =
sendErr "server" 0 "BERTError" "streams are unsupported" []
handle (TupleTerm [AtomTerm "info", AtomTerm "cache", _]) =
recvt >>= handle
handle (TupleTerm [
AtomTerm "call", AtomTerm mod,
AtomTerm fun, ListTerm args]) = do
res <- liftIO $ dispatch mod fun args
case res of
Success term ->
sendt $ TupleTerm [AtomTerm "reply", term]
NoSuchModule ->
sendErr "server" 1 "BERTError"
(printf "no such module \"%s\"" mod :: String) []
NoSuchFunction ->
sendErr "server" 2 "BERTError"
(printf "no such function \"%s\"" fun :: String) []
Undesignated detail ->
sendErr "server" 0 "HandlerError" detail []
sendErr etype ecode eclass detail backtrace =
sendt $ TupleTerm [
AtomTerm "error",
TupleTerm [
AtomTerm etype, IntTerm ecode, BinaryTerm . C.pack $ eclass,
ListTerm $ Prelude.map (BinaryTerm . C.pack) backtrace]]