haskell-rpc backend: builds reasonable code for new sequenced attrs

src/Gidl/Backend/Haskell/Interface.hs

@@ -41,10 +41,12 @@ interfaceModule useAeson modulepath i =
                      $ map text (typepath modulepath ++ ["Types", mname])
     where typepath = reverse . drop 1 . reverse
 
-  typeimports = map (importDecl tm)
+  typeimports = map (\a -> importDecl tm a </> qualifiedImportDecl tm a)
               $ nub
               $ map importType
+              $ (++ [sequence_num_t])
               $ interfaceTypes i
+
   extraimports = [ text "import Data.Serialize"
                  , text "import Data.Typeable"
                  , text "import Data.Data"
@@ -57,7 +59,7 @@ schemaDoc :: Bool -> String -> Schema -> Doc
 schemaDoc _ interfaceName (Schema schemaName [])     =
     text "-- Cannot define" <+> text schemaName  <+> text "schema for"
         <+> text interfaceName <+> text "interface: schema is empty"
-schemaDoc useAeson interfaceName (Schema schemaName schema) = stack $
+schemaDoc useAeson interfaceName s@(Schema schemaName schema) = stack $
     [ text "-- Define" <+> text schemaName  <+> text "schema for"
         <+> text interfaceName <+> text "interface"
     , text "data" <+> text typeName
@@ -108,7 +110,8 @@ schemaDoc useAeson interfaceName (Schema schemaName schema) = stack $
     , empty
     ] ++
     [ toJSONInstance   typeName | useAeson ] ++
-    [ fromJSONInstance typeName | useAeson ]
+    [ fromJSONInstance typeName | useAeson ] ++
+    [ seqnumGetter typeName s ]
   where
   constructorName n = userTypeModuleName n ++ schemaName
   deriv = text "deriving (Eq, Show, Data, Typeable, Generic)"
@@ -127,4 +130,31 @@ ifModuleName (Interface iname _ _) = aux iname
   u_to_camel (a:as) = a : u_to_camel as
   u_to_camel [] = []
 
+seqnumGetter :: String -> Schema -> Doc
+seqnumGetter _        (Schema _ []) = empty
+seqnumGetter typeName (Schema schemaName ms) = stack
+  [ text "seqNumGetter" <> text typeName
+                        <+> colon <> colon <+> text typeName
+                        <+> text "->" <+> text "SequenceNum"
+  , stack [ text "seqNumGetter" <> text typeName 
+            <+> parens (text (constructorName mname) <+> text "_a")
+            <+> equals <+> aux mtype
+          | (_,Message mname mtype) <- ms
+          ]
+  ]
+  where
+  constructorName n = userTypeModuleName n ++ schemaName
+  aux mtype
+    | isSeqNum mtype = text "_a"
+    | isSeqNumbered mtype = text (userTypeModuleName (structTypeName mtype))
+                            <> dot <> text "seqnum" <+> text "_a"
+    | otherwise = text "error \"impossible: should not be asking for"
+                <+> text "sequence number of non-attribute\""
+
+  isSeqNum a = a == sequence_num_t
+  -- XXX the following is ugly and i know it:
+  isSeqNumbered (StructType _ [("seqnum",_),("val",_)]) = True
+  isSeqNumbered _ = False
+  structTypeName (StructType a _) = a
+  structTypeName _ = error "impossible"
 

src/Gidl/Backend/Haskell/Types.hs

@@ -286,6 +286,14 @@ importDecl mkpath (UserType t) =
   text "import" <+> mkpath (userTypeModuleName t)
 importDecl _ NoImport = empty
 
+qualifiedImportDecl :: (String -> Doc) -> ImportType -> Doc
+qualifiedImportDecl _ (LibraryType p) =
+  text "import" <+> text p
+qualifiedImportDecl mkpath (UserType t) =
+  text "import qualified" <+> mkpath (userTypeModuleName t) <+> text "as"
+   <+> text (userTypeModuleName t)
+qualifiedImportDecl _ NoImport = empty
+
 
 encloseStack :: Doc -> Doc -> Doc -> [Doc] -> Doc
 encloseStack l r p ds = case ds of

src/Gidl/Backend/Rpc.hs

@@ -8,14 +8,14 @@ import Gidl.Backend.Cabal (cabalFileArtifact,defaultCabalFile,filePathToPackage)
 import Gidl.Backend.Haskell.Interface (interfaceModule,ifModuleName)
 import Gidl.Backend.Haskell.Types
            (typeModule,isUserDefined,typeModuleName,userTypeModuleName
-           ,importType,importDecl)
+           ,importType,importDecl, qualifiedImportDecl)
 import Gidl.Interface
            (Interface(..),MethodName,Method(..),Perm(..)
            ,interfaceMethods)
 import Gidl.Schema
            (Schema(..),producerSchema,consumerSchema,Message(..)
            ,consumerMessages,interfaceTypes)
-import Gidl.Types (Type)
+import Gidl.Types (Type(..))
 
 import Data.Char (isSpace)
 import Data.List (nub)
@@ -42,7 +42,7 @@ rpcBackend iis pkgName nsStr =
   namespace  = strToNs nsStr
 
   buildDeps  = [ "cereal", "QuickCheck", "snap-core", "snap-server", "stm"
-               , "aeson", "transformers" ]
+               , "aeson", "transformers", "containers" ]
 
   modules    = [ filePathToPackage (artifactFileName m) | m <- sourceMods ]
 
@@ -108,13 +108,15 @@ genServer :: [String] -> Interface -> String -> Doc
 genServer ns iface ifaceMod = stack $
   [ text "{-# LANGUAGE RecordWildCards #-}" | useManager ] ++
   [ text "{-# LANGUAGE OverloadedStrings #-}"
+  , text "{-# OPTIONS_GHC -fno-warn-unused-imports #-}"
   , moduleHeader     ns ifaceMod
   , line
   , importTypes      ns iface
   , importInterface  ns ifaceMod
   , line
   , text "import" <+> (ppModName (ns ++ ["Rpc","Base"]))
-  , line
+  ] ++
+  [ line
   , webServerImports hasConsumer
   , line
   , line
@@ -145,10 +147,12 @@ importTypes ns iface = stack
                      $ map (streamImport . importType) streams
                     ++ map (typeImport   . importType) types
   where
-  (streams,types) = partitionTypes iface
+  (streams,itypes) = partitionTypes iface
+
+  types = itypes ++ interfaceTypes iface
 
   streamImport ty = importDecl addNs ty
-  typeImport   ty = importDecl addNs ty <+> text "()"
+  typeImport   ty = qualifiedImportDecl addNs ty
 
   prefix  = dots (map text (ns ++ ["Types"]))
   addNs m = prefix <> char '.' <> text m
@@ -230,7 +234,8 @@ runServerDef hasConsumer useMgr iface =
        ++ [ spread $ [ text "_ <- forkIO (manager state input" ]
                   ++ [ text "input'" | hasConsumer ]
                   ++ [ text ")" ]                           | useMgr      ]
-       ++ [ text "conn <- newConn output" <+> input'        | hasConsumer ]
+       ++ [ text "conn <- newConn output" <+> input'
+                  <+> seqNumGetter                          | hasConsumer ]
        ++ [ text "runServer cfg $ Snap.route" </> routesDef               ]
 
   (input',defInput)
@@ -239,6 +244,9 @@ runServerDef hasConsumer useMgr iface =
 
   routesDef = nest 2 (align (routes iface (text "state")))
 
+  seqNumGetter = parens (text "SequenceNum.unSequenceNum ."
+      <+> text "seqNumGetter" <> text (ifModuleName iface) <> text prodName)
+  Schema prodName _ = producerSchema iface
 
 -- | Define one route for each interface member
 routes :: Interface -> Doc -> Doc
@@ -289,8 +297,10 @@ constrName suffix (Message n _) = userTypeModuleName n ++ suffix
 
 readAttr :: String -> Message -> Doc
 readAttr suffix msg = text "Snap.method Snap.GET $" <+> doStmts
-  [ text "resp <- liftIO $ sendRequest conn $" <+>
-                   text (constrName suffix msg) <+> text "()"
+  [ text "resp <- liftIO $ sendRequest conn $"
+                   <+> text (constrName suffix msg)
+                   <+> dot <+> text "SequenceNum.SequenceNum"
+
   , text "Snap.writeLBS (encode resp)"
   ]
 
@@ -298,12 +308,19 @@ writeAttr :: String -> Message -> Doc
 writeAttr suffix msg = text "Snap.method Snap.POST $" <+> doStmts
   [ text "bytes <- Snap.readRequestBody 32768"
   , text "case decode bytes of" </>
-      text "Just req -> liftIO $ sendRequest_ conn $" <+>
-                            text con <+> text "req" </>
+      text "Just req -> liftIO $" <+> doStmts
+        [ text "_ <- sendRequest conn $ \\ snum ->"
+                    <+> text con
+                    <+> parens (text (userTypeModuleName sname)
+                                <> dot <> text (userTypeModuleName sname)
+                                <+> text "(SequenceNum.SequenceNum snum)" <+> text "req")
+        , text "return ()"
+        ] </>
       text "Nothing  -> Snap.modifyResponse $ Snap.setResponseCode 400"
   ]
   where
   con = constrName suffix msg
+  (Message _ (StructType sname _)) = msg
 
 
 -- The stream manager ----------------------------------------------------------

support/rpc/Base.hs.template

@@ -5,17 +5,20 @@
 
 module $module_path$.Base where
 
+import           Data.Word (Word32)
+import           Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
 import           Control.Concurrent (forkIO)
 import           Control.Concurrent.STM
                      (atomically,STM,retry,TVar,newTVar,writeTVar,readTVar
-                     ,TQueue,readTQueue,writeTQueue,newTQueueIO,tryReadTQueue
-                     ,TMVar,newEmptyTMVarIO,takeTMVar,putTMVar)
+                     ,TQueue,readTQueue,writeTQueue
+                     ,TMVar,newEmptyTMVarIO,takeTMVar,putTMVar,newTVarIO
+                     ,modifyTVar)
 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
 
@@ -77,19 +80,26 @@ readTSampleVar (TSampleVar tv) =
 -- Response Handling -----------------------------------------------------------
 
 data Conn req resp = Conn { connRequests :: TQueue req
-                          , connWaiting  :: TQueue (TMVar resp)
+                          , connWaiting  :: TVar (Map Word32 (TMVar resp))
+                          , connSeqNum   :: TVar Word32
                           }
 
 
 -- | 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
+newConn :: TQueue req -> TQueue resp -> (resp -> Word32) -> IO (Conn req resp)
+newConn connRequests connResps toSeqNum =
+  do connWaiting <- newTVarIO Map.empty
+     connSeqNum  <- newTVarIO 0
 
      _ <- forkIO (forever
         (do resp <- atomically (readTQueue connResps)
-            mb   <- atomically (tryReadTQueue connWaiting)
+            let snum = toSeqNum resp
+            mb   <- atomically (do
+                     m <- readTVar connWaiting
+                     let (mb, m') = Map.updateLookupWithKey (\\_ _ -> Nothing) snum m
+                     writeTVar connWaiting m'
+                     return mb)
             case mb of
               Just var -> atomically (putTMVar var resp)
               Nothing  -> return ()))
@@ -97,18 +107,14 @@ newConn connRequests connResps =
      return Conn { .. }
 
 
-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 resp -> (Word32 -> req) -> IO resp
 sendRequest Conn { .. } req =
   do var <- newEmptyTMVarIO
 
-     atomically (do writeTQueue connWaiting var
-                    writeTQueue connRequests req)
+     atomically (do snum <- readTVar connSeqNum
+                    writeTVar connSeqNum (snum + 1)
+                    modifyTVar connWaiting (Map.insert snum var)
+                    writeTQueue connRequests (req snum))
 
      atomically (takeTMVar var)