Read methods implemented

Makefile

@@ -64,7 +64,7 @@ rpc-backend-test:
 		-n Gidl.Test
 	make -C tests/gidl-rpc-backend-test create-sandbox
 	make -C tests/gidl-rpc-backend-test
-	make -C tests/gidl-rpc-backend-test test
+	#make -C tests/gidl-rpc-backend-test test
 
 rpc-backend-test-clean:
 	-rm -rf tests/gidl-ivory-backend-test

src/Gidl/Backend/Rpc.hs

@@ -6,10 +6,13 @@ import qualified Paths_gidl as P
 
 import Gidl.Backend.Cabal (cabalFileArtifact,defaultCabalFile,filePathToPackage)
 import Gidl.Backend.Haskell.Interface (interfaceModule,ifModuleName)
-import Gidl.Backend.Haskell.Types (typeModule,isUserDefined,typeModuleName)
+import Gidl.Backend.Haskell.Types
+           (typeModule,isUserDefined,typeModuleName,userTypeModuleName)
 import Gidl.Interface
            (Interface(..),InterfaceEnv(..),MethodName,Method(..),Perm(..))
-import Gidl.Schema (Schema(..),producerSchema,consumerSchema)
+import Gidl.Schema
+           (Schema(..),producerSchema,consumerSchema,Message(..)
+           ,consumerMessages)
 import Gidl.Types (Type,TypeEnv(..))
 
 import Data.Char (isSpace)
@@ -112,7 +115,7 @@ genServer typeEnv ns iface ifaceMod = stack $
   , line
   , line
   , managerDefs
-  , runServer useManager typeEnv iface input output
+  , runServer useManager iface input output
   ]
   where
   (useManager,managerDefs) = managerDef iface input
@@ -172,10 +175,10 @@ queueTypes iface = (input,output)
   output = text "TQueue" <+> text cons
 
 
-runServer :: Bool -> TypeEnv -> Interface -> InputQueue -> OutputQueue -> Doc
-runServer useMgr typeEnv iface input output =
+runServer :: Bool -> Interface -> InputQueue -> OutputQueue -> Doc
+runServer useMgr iface input output =
   runServerSig hasConsumer input output </>
-  runServerDef hasConsumer useMgr typeEnv iface
+  runServerDef hasConsumer useMgr iface
   where
   hasConsumer = not (isEmptySchema (consumerSchema iface))
 
@@ -190,8 +193,8 @@ runServerSig hasConsumer input output =
         [ text "Config", text "IO ()" ]
 
 -- | Generate a definition for the server.
-runServerDef :: Bool -> Bool -> TypeEnv -> Interface -> Doc
-runServerDef hasConsumer useMgr typeEnv iface =
+runServerDef :: Bool -> Bool -> Interface -> Doc
+runServerDef hasConsumer useMgr iface =
   hang 2 (text "rpcServer" <+> body)
   where
   args = spread $
@@ -201,40 +204,52 @@ runServerDef hasConsumer useMgr typeEnv iface =
 
   body =  args <+> char '=' </> nest 2 (doStmts stmts)
 
-  stmts = [ text "state <- mkState"                         | useMgr ]
-       ++ [ defInput                                                 ]
-       ++ [ text "_ <- forkIO (manager state input input')" | useMgr ]
-       ++ [ text "runServer cfg $ Snap.route" </> routesDef          ]
+  stmts = [ text "state <- mkState"                         | useMgr      ]
+       ++ [ defInput                                                      ]
+       ++ [ text "_ <- forkIO (manager state input input')" | useMgr      ]
+       ++ [ text "conn <- newConn output input'"            | hasConsumer ]
+       ++ [ text "runServer cfg $ Snap.route" </> routesDef               ]
 
   defInput
     | useMgr    = text "input' <- newTQueueIO"
     | otherwise = text "let input' = input"
 
-  routesDef = nest 2 (align (routes typeEnv iface (text "state")))
+  routesDef = nest 2 (align (routes iface (text "state")))
 
 
 -- | Define one route for each interface member
-routes :: TypeEnv -> Interface -> Doc -> Doc
-routes types iface state =
-  align $ char '['
-       <> nest 1 (stack (commas (map (mkRoute types pfx state) (allMethods iface))))
-       <> char ']'
+routes :: Interface -> Doc -> Doc
+routes iface state =
+  align (char '[' <> nest 1 (stack (commas handlers)) <> char ']')
   where
   Interface pfx _ _ = iface
+  Schema suffix _   = consumerSchema iface
 
+  handlers = map (mkRoute pfx suffix state) (allMethods iface)
 
-mkRoute :: TypeEnv -> String -> Doc -> (MethodName,Method) -> Doc
-mkRoute types iface state (name,method) =
-  parens (url <> comma </> guardMethods (handlersFor method))
+
+mkRoute :: String -> String -> Doc -> (MethodName,Method) -> Doc
+mkRoute ifacePfx consSuffix state method@(name,mty) =
+  parens (url <> comma </> guardMethods (handlersFor mty))
   where
-  url = dquotes (text iface <> char '/' <> text name)
+  url = dquotes (text ifacePfx <> char '/' <> text name)
 
   guardMethods [h] = h
   guardMethods hs  = nest 2 $ text "msum"
                           </> brackets (stack (commas hs))
 
-  handlersFor (StreamMethod _  _ ) = [ readStream state name ]
-  handlersFor (AttrMethod perm ty) = [ m types ty | m <- permMethods perm ]
+  handlersFor StreamMethod {} =
+      [ readStream state name ]
+
+  handlersFor (AttrMethod Read _) =
+      [ readAttr  consSuffix m | m <- consumerMessages method ]
+
+  handlersFor (AttrMethod Write _) =
+      [ writeAttr consSuffix m | m <- consumerMessages method ]
+
+  handlersFor (AttrMethod ReadWrite ty) =
+      [ readAttr  consSuffix m | m <- consumerMessages (name,AttrMethod Read  ty) ] ++
+      [ writeAttr consSuffix m | m <- consumerMessages (name,AttrMethod Write ty) ]
 
 
 readStream :: Doc -> MethodName -> Doc
@@ -246,20 +261,20 @@ readStream state name = nest 2 $ text "Snap.method Snap.GET $"
   where
   svar = parens (fieldName name <+> state)
 
+constrName :: String -> Message -> String
+constrName suffix (Message n _) = userTypeModuleName n ++ suffix
 
-permMethods :: Perm -> [ TypeEnv -> Type -> Doc ]
-permMethods Read      = [ readMethod              ]
-permMethods Write     = [ writeMethod             ]
-permMethods ReadWrite = [ readMethod, writeMethod ]
-
-
-readMethod :: TypeEnv -> Type -> Doc
-readMethod types _ = doStmts
-  [ text "Snap.writeBS \"read\""
+readAttr :: String -> Message -> Doc
+readAttr suffix msg = text "Snap.method Snap.GET $" <+> doStmts
+  [ text "resp <- liftIO $ sendRequest conn $" <+>
+                   text (constrName suffix msg) <+> text "()"
+  , text "Snap.writeLBS (encode resp)"
   ]
 
-writeMethod :: TypeEnv -> Type -> Doc
-writeMethod types _ = text "Snap.writeBS \"write\""
+writeAttr :: String -> Message -> Doc
+writeAttr _ _ = text "Snap.method Snap.POST $" <+> doStmts
+  [ text "Snap.writeBS \"write\""
+  ]
 
 
 -- The stream manager ----------------------------------------------------------
@@ -272,6 +287,8 @@ managerDef iface input
   | otherwise    = (True,stack defs </> empty)
   where
 
+  hasConsumer = not (isEmptySchema (consumerSchema iface))
+
   streams = [ (name,ty) | (name,StreamMethod _ ty) <- allMethods iface ]
 
   (stateType,stateDecl) = stateDef streams
@@ -286,7 +303,8 @@ managerDef iface input
          ]
 
   stmts = [ text "msg <- atomically (readTQueue input)"
-          , nest 2 (text "case msg of" </> stack (map mkCase streams ++ [defCase])) ]
+          , nest 2 (text "case msg of" </>
+                   stack (map mkCase streams ++ [defCase | hasConsumer ])) ]
 
   -- name the producer constructor for a stream element
   Schema prodSuffix _ = producerSchema iface

src/Gidl/Schema.hs

@@ -16,27 +16,30 @@ data Schema = Schema String [(MsgId, Message)]
 producerSchema :: Interface -> Schema
 producerSchema ir = Schema "Producer" [(mkMsgId m, m) | m <- messages ]
   where
-  messages = concatMap mkMessages (interfaceMethods ir)
-  mkMessages (streamname, (StreamMethod _ tr)) =
-    [ Message streamname tr ]
-  mkMessages (_ , (AttrMethod Write _)) = []
-  mkMessages (attrname, (AttrMethod  _ tr)) =
-    [ Message (attrname ++ "_val") tr ]
+  messages = concatMap producerMessages (interfaceMethods ir)
+
+producerMessages :: (MethodName,Method) -> [Message]
+producerMessages (streamname, (StreamMethod _ tr)) =
+  [ Message streamname tr ]
+producerMessages (_ , (AttrMethod Write _)) = []
+producerMessages (attrname, (AttrMethod  _ tr)) =
+  [ Message (attrname ++ "_val") tr ]
 
 consumerSchema :: Interface -> Schema
 consumerSchema ir = Schema "Consumer" [(mkMsgId m, m) | m <- messages ]
   where
-  messages = concatMap mkMessages (interfaceMethods ir)
-
-  mkMessages (_, (StreamMethod _ _)) = [] -- XXX eventaully add set rate?
-  mkMessages (attrname, (AttrMethod Write tr)) =
-    [ Message (attrname ++ "_set") tr ]
-  mkMessages (attrname, (AttrMethod Read _)) =
-    [ Message (attrname ++ "_get")  (PrimType VoidType) ]
-  mkMessages (attrname, (AttrMethod ReadWrite tr)) =
-    [ Message (attrname ++ "_set") tr
-    , Message (attrname ++ "_get") (PrimType VoidType)
-    ]
+  messages = concatMap consumerMessages (interfaceMethods ir)
+
+consumerMessages :: (MethodName,Method) -> [Message]
+consumerMessages (_, (StreamMethod _ _)) = [] -- XXX eventaully add set rate?
+consumerMessages (attrname, (AttrMethod Write tr)) =
+  [ Message (attrname ++ "_set") tr ]
+consumerMessages (attrname, (AttrMethod Read _)) =
+  [ Message (attrname ++ "_get")  (PrimType VoidType) ]
+consumerMessages (attrname, (AttrMethod ReadWrite tr)) =
+  [ Message (attrname ++ "_set") tr
+  , Message (attrname ++ "_get") (PrimType VoidType)
+  ]
 
 
 mkMsgId :: Message -> MsgId

support/rpc/Base.hs.template

@@ -5,12 +5,17 @@
 
 module $module_path$.Base where
 
+import           Control.Concurrent (forkIO)
 import           Control.Concurrent.STM
-                     (atomically,STM,retry,TVar,newTVar,writeTVar,readTVar)
+                     (atomically,STM,retry,TVar,newTVar,writeTVar,readTVar
+                     ,TQueue,readTQueue,writeTQueue,newTQueueIO,tryReadTQueue
+                     ,TMVar,newEmptyTMVarIO,takeTMVar,putTMVar)
+import           Control.Monad (forever)
 import           Snap.Core (Snap,route)
 import qualified Snap.Http.Server as HTTP
 import           Snap.Util.FileServe (serveDirectory)
 
+
 data Config = Config { cfgPort :: !Int
                        -- ^ The port to run on
 
@@ -67,3 +72,43 @@ readTSampleVar (TSampleVar tv) =
      case mb of
        Just a  -> return a
        Nothing -> retry
+
+
+-- Response Handling -----------------------------------------------------------
+
+data Conn req resp = Conn { connRequests :: TQueue req
+                          , connWaiting  :: TQueue (TMVar resp)
+                          }
+
+
+-- | Fork a handler thread that will apply handlers to incoming messages.  If
+-- the handler queue is empty when a response arrives, the response is dropped.
+newConn :: TQueue req -> TQueue resp -> IO (Conn req resp)
+newConn connRequests connResps =
+  do connWaiting <- newTQueueIO
+
+     _ <- forkIO (forever
+        (do resp <- atomically (readTQueue connResps)
+            mb   <- atomically (tryReadTQueue connWaiting)
+            case mb of
+              Just var -> atomically (putTMVar var resp)
+              Nothing  -> return ()))
+
+     return Conn { .. }
+
+
+-- | Send a request that doesn't expect a response.
+sendRequest_ :: Conn req resp -> req -> IO ()
+sendRequest_ Conn { .. } req =
+  atomically (writeTQueue connRequests req)
+
+
+-- | Send a request, and block until a response is received.
+sendRequest :: Conn req resp -> req -> IO resp
+sendRequest Conn { .. } req =
+  do var <- newEmptyTMVarIO
+
+     atomically (do writeTQueue connWaiting var
+                    writeTQueue connRequests req)
+
+     atomically (takeTMVar var)