Initial rpc backend

Makefile

@@ -54,6 +54,21 @@ tower-backend-test:
 tower-backend-test-clean:
 	-rm -rf tests/gidl-tower-backend-test
 
+rpc-backend-test:
+	cabal copy
+	cabal run gidl -- -b rpc \
+		--debug \
+		-i tests/example.idl \
+		-o tests/gidl-rpc-backend-test \
+		-p gidl-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
+
+rpc-backend-test-clean:
+	-rm -rf tests/gidl-ivory-backend-test
+
 
 clean: ivory-backend-test-clean
 clean: tower-backend-test-clean

gidl.cabal

@@ -13,7 +13,9 @@ data-files: support/ivory/Unpack.hs.template,
             support/ivory/Makefile,
             support/tower/CodeGen.hs.template,
             support/tower/default.conf,
-            support/tower/Makefile
+            support/tower/Makefile,
+            support/rpc/Base.hs.template,
+            support/rpc/Makefile
 
 library
   exposed-modules:     Gidl,
@@ -33,6 +35,7 @@ library
                        Gidl.Backend.Ivory.Schema,
                        Gidl.Backend.Ivory.Test,
                        Gidl.Backend.Ivory.Types,
+                       Gidl.Backend.Rpc,
                        Gidl.Backend.Tower,
                        Gidl.Backend.Tower.Schema,
                        Gidl.Backend.Tower.Interface

src/Gidl.hs

@@ -15,6 +15,7 @@ import Ivory.Artifact
 import Gidl.Parse
 import Gidl.Backend.Haskell
 import Gidl.Backend.Ivory
+import Gidl.Backend.Rpc (rpcBackend)
 import Gidl.Backend.Tower
 
 data OptParser opt = OptParser [String] (opt -> opt)
@@ -40,6 +41,7 @@ data Backend
   = HaskellBackend
   | IvoryBackend
   | TowerBackend
+  | RpcBackend
   deriving (Eq, Show)
 
 data Opts = Opts
@@ -68,6 +70,7 @@ setBackend b = case map toUpper b of
   "HASKELL" -> success (\o -> o { backend = HaskellBackend })
   "IVORY"   -> success (\o -> o { backend = IvoryBackend })
   "TOWER"   -> success (\o -> o { backend = TowerBackend })
+  "RPC"     -> success (\o -> o { backend = RpcBackend })
   _         -> invalid ("\"" ++ b ++ "\" is not a valid backend.\n"
                           ++ "Supported backends: haskell, ivory, tower")
 
@@ -138,6 +141,8 @@ run = do
           ivoryBackend te ie (packagename opts) (namespace opts)
         TowerBackend -> artifactBackend opts $
           towerBackend te ie (packagename opts) (namespace opts)
+        RpcBackend -> artifactBackend opts $
+          rpcBackend te ie (packagename opts) (namespace opts)
 
   where
   artifactBackend :: Opts -> [Artifact] -> IO ()

src/Gidl/Backend/Rpc.hs

@@ -0,0 +1,189 @@
+module Gidl.Backend.Rpc (
+    rpcBackend
+  ) where
+
+import qualified Paths_gidl as P
+
+import Gidl.Backend.Cabal
+           (cabalFileArtifact,CabalFile(..),defaultCabalFile,filePathToPackage)
+import Gidl.Backend.Haskell.Interface (interfaceModule,ifModuleName)
+import Gidl.Backend.Haskell.Types (typeModule,isUserDefined,typeModuleName)
+import Gidl.Interface (Interface,InterfaceEnv(..))
+import Gidl.Types (Type,TypeEnv(..))
+
+import Data.Char (isSpace)
+import Data.List (intercalate)
+import Ivory.Artifact
+           (Artifact(..),artifactPath,artifactFileName,artifactPath
+           ,artifactText,artifactCabalFile)
+import Ivory.Artifact.Template (artifactCabalFileTemplate)
+import Text.PrettyPrint.Mainland
+           (Doc,prettyLazyText,text,empty,(<+>),(</>),(<>),char,line,parens
+           ,punctuate,stack,sep,tuple,dot,spread,cat)
+
+
+-- External Interface ----------------------------------------------------------
+
+rpcBackend :: TypeEnv -> InterfaceEnv -> String -> String -> [Artifact]
+rpcBackend typeEnv@(TypeEnv te) ifaceEnv@(InterfaceEnv ie) pkgName nsStr =
+    cabalFileArtifact (defaultCabalFile pkgName modules buildDeps)
+  : artifactCabalFile P.getDataDir "support/rpc/Makefile"
+  : map (artifactPath "src") (rpcBaseModule namespace : sourceMods)
+
+  where
+
+  namespace  = strToNs nsStr
+
+  buildDeps  = [ "cereal", "QuickCheck", "snap-core", "snap-server", "stm"
+               , "bytestring" ]
+
+  modules    = [ filePathToPackage (artifactFileName m) | m <- sourceMods ]
+
+  sourceMods = tmods ++ imods
+
+  tmods      = [ typeModule (namespace ++ ["Types"]) t
+               | (_tn, t) <- te
+               , isUserDefined t
+               ]
+
+  imods      = concat [ [ interfaceModule (namespace ++ ["Interface"]) i
+                        , rpcModule typeEnv namespace i ]
+                      | (_iname, i) <- ie
+                      ]
+
+
+rpcBaseModule :: [String] -> Artifact
+rpcBaseModule ns =
+  artifactPath (foldr (\ p rest -> p ++ "/" ++ rest) "Server" ns) $
+  artifactCabalFileTemplate P.getDataDir "support/rpc/Base.hs.template" env
+  where
+  env = [ ("module_prefix", concatMap (++ ".") ns) ]
+
+
+-- Utilities -------------------------------------------------------------------
+
+strToNs :: String -> [String]
+strToNs str =
+  case break (== '.') (dropWhile isSpace str) of
+
+    (a,'.' : b) | null a    ->          strToNs b
+                | otherwise -> trim a : strToNs b
+
+    (a,_)       | null a    -> []
+                | otherwise -> [trim a]
+
+  where
+  trim = takeWhile (not . isSpace)
+
+
+-- Server Generation -----------------------------------------------------------
+
+rpcModule :: TypeEnv -> [String] -> Interface -> Artifact
+rpcModule typeEnv ns iface =
+  artifactPath (foldr (\ p rest -> p ++ "/" ++ rest) "Server" ns) $
+  artifactText (ifaceMod ++ ".hs") $
+  prettyLazyText 80 $
+  genServer typeEnv ns iface ifaceMod
+  where
+  ifaceMod = ifModuleName iface
+
+
+genServer :: TypeEnv -> [String] -> Interface -> String -> Doc
+genServer typeEnv ns iface ifaceMod =
+  stack [ moduleHeader     ns ifaceMod
+        , importTypes      ns typeEnv
+        , importInterface  ns ifaceMod
+        , line
+        , ppImport False (ppModName (ns ++ ["Server","Base"])) Nothing
+        , line
+        , webServerImports
+        , line
+        , line
+        , runServer typeEnv iface
+        ]
+
+
+moduleHeader :: [String] -> String -> Doc
+moduleHeader ns m =
+  spread [ text "module"
+         , ppHaskellModule (ns ++ ["Server"]) m
+         , tuple [ text "rpcServer", text "Config(..)" ]
+         , text "where"
+         ]
+
+
+-- | Import all of the generated type modules from the type environment.
+importTypes :: [String] -> TypeEnv -> Doc
+importTypes ns (TypeEnv ts) = foldr importType empty ts
+  where
+  prefix = dots (map text (ns ++ ["Types"]))
+
+  importType (_,t) rest =
+    stack [ ppImport False (prefix *. text (typeModuleName t)) Nothing
+          , rest
+          ]
+
+
+importInterface :: [String] -> String -> Doc
+importInterface ns ifaceName =
+  ppImport False (dots (map text (ns ++ ["Interface", ifaceName]))) Nothing
+
+
+webServerImports :: Doc
+webServerImports  =
+  stack [ ppImport False (ppModName ["Snap","Http","Server"]) Nothing
+        , ppImport True  (ppModName ["Data","ByteString"])    Nothing
+        ]
+
+
+runServer :: TypeEnv -> Interface -> Doc
+runServer typeEnv iface = runServerSig </> runServerDef typeEnv iface
+
+
+runServerSig :: Doc
+runServerSig  =
+  text "rpcServer" <+> text "::"
+                   <+> arrow [ chan, chan, text "Config", text "IO ()" ]
+  where
+  chan = text "TChan" <+> text "S.ByteString"
+
+
+-- | Generate a definition for the server.
+runServerDef :: TypeEnv -> Interface -> Doc
+runServerDef typeEnv iface = text "rpcServer" <+> body
+  where
+  body = arg "input"  $ \ input  ->
+         arg "output" $ \ output ->
+         arg "cfg"    $ \ cfg    ->
+           char '=' <+> empty
+
+
+-- Pretty-printing Helpers -----------------------------------------------------
+
+arg :: String -> (Doc -> Doc) -> Doc
+arg name k = let x = text name in x <+> k (text name)
+
+arrow :: [Doc] -> Doc
+arrow ts = spread (punctuate (text "->") ts)
+
+(*.) :: Doc -> Doc -> Doc
+a *. b = a <> dot <> b
+
+dots :: [Doc] -> Doc
+dots  = cat . punctuate dot
+
+ppImport :: Bool -> Doc -> Maybe Doc -> Doc
+ppImport isQual modName mbAs =
+  spread [ text "import"
+         , if isQual then text "qualified" else empty
+         , modName
+         , case mbAs of
+             Just alt -> text "as" <+> alt
+             Nothing  -> empty
+         ]
+
+ppModName :: [String] -> Doc
+ppModName  = dots . map text
+
+ppHaskellModule :: [String] -> String -> Doc
+ppHaskellModule ns n = foldr (\ m rest -> text m <> char '.' <> rest ) (text n) ns

support/rpc/Base.hs.template

@@ -0,0 +1,40 @@
+-- vim: ft=haskell
+
+{-# LANGUAGE RecordWildCards #-}
+
+module $module_prefix$Base where
+
+import System.Environment
+import System.Console.GetOpt
+import Snap.Http.Server (simpleHttpServe,defaultConfig)
+import Snap.Util.FileServe (serveDirectory)
+
+data Config = Config { cfgPort :: !Int
+                       -- ^ The port to run on
+
+                     , cfgStaticDir :: Maybe FilePath
+                       -- ^ Content to be served off of the root, relative to
+                       -- the directory that the server was started in
+
+                     } deriving (Show)
+
+-- | A default @Config@ value that will produce a server that runs on port 8080,
+-- and serves no static content.
+defaultConfig :: Config
+defaultConfig  = Config { cfgPort = 8080, cfgStaticDir = Nothing }
+
+
+-- | Spawn a snap server, and run the given RPC action.
+runServer :: Config -> Snap () -> IO ()
+runServer Config { .. } serveRpc = simpleHttpServe snapConfig server
+  where
+  server =
+    do let snapCfg = setPort cfgPort defaultConfig
+       simpleHttpServe snapCfg body
+
+  body =
+    do serveRpc
+
+       case cfgStaticDir of
+         Just path -> route [ ("", serveDirectory path) ]
+         Nothing   -> return ()

support/rpc/Makefile

@@ -0,0 +1,11 @@
+IVORY_REPO ?= ../../../ivory
+
+default:
+	cabal build
+
+create-sandbox:
+	cabal sandbox init
+	cabal install --enable-tests --dependencies-only
+
+test:
+	cabal run -- --src-dir=codegen-out

tests/.gitignore

@@ -1,3 +1,4 @@
 gidl-haskell-backend-test
 gidl-ivory-backend-test
 gidl-tower-backend-test
+gidl-rpc-backend-test