module Gidl.Backend.Rpc ( rpcBackend ) where 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,userTypeModuleName ,importType,importDecl, qualifiedImportDecl) import Gidl.Interface (Interface(..),MethodName,Method(..),Perm(..) ,interfaceMethods) import Gidl.Schema (Schema(..),producerSchema,consumerSchema,Message(..) ,consumerMessages,interfaceTypes,getResponseMessage) import Gidl.Types (Type(..)) import Data.Char (isSpace) import Data.List (nub) 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,tuple,dot,spread,cat,hang,nest,align,comma ,braces,brackets,dquotes) -- External Interface ---------------------------------------------------------- rpcBackend :: [Interface] -> String -> String -> [Artifact] rpcBackend iis pkgName nsStr = cabalFileArtifact (defaultCabalFile pkgName modules buildDeps) : artifactCabalFile P.getDataDir "support/rpc/Makefile" : map (artifactPath "src") sourceMods where namespace = strToNs nsStr buildDeps = [ "cereal", "QuickCheck", "snap-core", "snap-server", "stm" , "aeson", "transformers", "containers" ] modules = [ filePathToPackage (artifactFileName m) | m <- sourceMods ] sourceMods = tmods ++ imods ++ [rpcBaseModule namespace] types = nub [ t | i <- iis, t <- interfaceTypes i] tmods = [ typeModule True (namespace ++ ["Types"]) t | t <- types , isUserDefined t ] imods = concat [ [ interfaceModule True (namespace ++ ["Interface"]) i , rpcModule namespace i ] | i <- iis ] rpcBaseModule :: [String] -> Artifact rpcBaseModule ns = artifactPath (foldr (\ p rest -> p ++ "/" ++ rest) "Rpc" ns) $ artifactCabalFileTemplate P.getDataDir "support/rpc/Base.hs.template" env where env = [ ("module_path", foldr (\p rest -> p ++ "." ++ rest) "Rpc" 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) allMethods :: Interface -> [(MethodName,Method)] allMethods (Interface _ ps ms) = concatMap allMethods ps ++ ms isEmptySchema :: Schema -> Bool isEmptySchema (Schema _ ms) = null ms -- Server Generation ----------------------------------------------------------- rpcModule :: [String] -> Interface -> Artifact rpcModule ns iface = artifactPath (foldr (\ p rest -> p ++ "/" ++ rest) "Rpc" ns) $ artifactText (ifaceMod ++ ".hs") $ prettyLazyText 1000 $ genServer ns iface ifaceMod where ifaceMod = ifModuleName iface 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 , webServerImports hasConsumer , line , line , managerDefs , runServer hasConsumer useManager iface input output ] where hasConsumer = not (isEmptySchema (consumerSchema iface)) (useManager,managerDefs) = managerDef hasConsumer iface input (input,output) = queueTypes iface moduleHeader :: [String] -> String -> Doc moduleHeader ns m = spread [ text "module" , dots (map text (ns ++ ["Rpc", m])) , tuple [ text "rpcServer", text "Config(..)" ] , text "where" ] -- | Import the type modules required by the interface. Import hiding -- everything, as we just need the ToJSON/FromJSON instances. importTypes :: [String] -> Interface -> Doc importTypes ns iface = stack $ map (streamImport . importType) streams ++ map (typeImport . importType) types where (streams,itypes) = partitionTypes iface types = itypes ++ interfaceTypes iface streamImport ty = importDecl addNs ty typeImport ty = qualifiedImportDecl addNs ty prefix = dots (map text (ns ++ ["Types"])) addNs m = prefix <> char '.' <> text m -- | Separate the types that are used from a stream method, from those used -- in attribute methods. partitionTypes :: Interface -> ([Type],[Type]) partitionTypes iface = go [] [] (interfaceMethods iface) where go s a [] = (nub s, nub a) go s a ((_,StreamMethod _ ty):rest) = go (ty:s) a rest go s a ((_,AttrMethod _ ty):rest) = go s (ty:a) rest importInterface :: [String] -> String -> Doc importInterface ns ifaceName = text "import" <+> (dots (map text (ns ++ ["Interface", ifaceName]))) webServerImports :: Bool -> Doc webServerImports hasConsumer = stack $ [ text "import Control.Monad (msum)" | hasConsumer ] ++ [ text "import Data.Aeson (decode)" | hasConsumer ] ++ [ text "import qualified Snap.Core as Snap" , text "import Control.Concurrent (forkIO)" , text "import Control.Concurrent.STM" , text "import Control.Monad (forever)" , text "import Control.Monad.IO.Class (liftIO)" , text "import Data.Aeson (encode,Value(Null))" ] type InputQueue = Doc type OutputQueue = Doc queueTypes :: Interface -> (InputQueue,OutputQueue) queueTypes iface = (input,output) where Schema prodName _ = producerSchema iface Schema consName _ = consumerSchema iface prod = ifModuleName iface ++ prodName cons = ifModuleName iface ++ consName input = text "TQueue" <+> text prod output = text "TQueue" <+> text cons runServer :: Bool -> Bool -> Interface -> InputQueue -> OutputQueue -> Doc runServer hasConsumer useMgr iface input output = runServerSig hasConsumer input output runServerDef hasConsumer useMgr iface runServerSig :: Bool -> InputQueue -> OutputQueue -> Doc runServerSig hasConsumer input output = text "rpcServer ::" <+> hang 2 (arrow tys) where tys = [ input ] ++ [ output | hasConsumer ] ++ [ text "Config", text "IO ()" ] -- | Generate a definition for the server. runServerDef :: Bool -> Bool -> Interface -> Doc runServerDef hasConsumer useMgr iface = hang 2 (text "rpcServer" <+> body) where args = spread $ [ text "input" ] ++ [ text "output" | hasConsumer ] ++ [ text "cfg" ] body = args <+> char '=' nest 2 (doStmts stmts) stmts = [ text "state <- mkState" | useMgr ] ++ [ defInput ] ++ [ spread $ [ text "_ <- forkIO (manager state input" ] ++ [ text "input'" | hasConsumer ] ++ [ text ")" ] | useMgr ] ++ [ text "conn <- newConn output" <+> input' <+> seqNumGetter | hasConsumer ] ++ [ text "runServer cfg $ Snap.route" routesDef ] (input',defInput) | hasConsumer && useMgr = (text "input'", text "input' <- newTQueueIO") | otherwise = (text "input", empty) 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 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 :: String -> String -> Doc -> (MethodName,Method) -> Doc mkRoute ifacePfx consSuffix state method@(name,mty) = parens (url <> comma guardMethods (handlersFor mty)) where 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 Read _) = [ readAttr method consSuffix m | m <- consumerMessages method ] handlersFor (AttrMethod Write _) = [ writeAttr consSuffix m | m <- consumerMessages method ] handlersFor (AttrMethod ReadWrite ty) = [ readAttr method consSuffix m | m <- consumerMessages (name,AttrMethod Read ty) ] ++ [ writeAttr consSuffix m | m <- consumerMessages (name,AttrMethod Write ty) ] readStream :: Doc -> MethodName -> Doc readStream state name = nest 2 $ text "Snap.method Snap.GET $" doStmts [ text "x <- liftIO (atomically (readTSampleVar" <+> svar <> text "))" , text "let e = case x of Just v -> encode v; Nothing -> encode Null" , text "Snap.writeLBS e" ] where svar = parens (fieldName name <+> state) constrName :: String -> Message -> String constrName suffix (Message n _) = userTypeModuleName n ++ suffix readAttr :: (MethodName,Method) -> String -> Message -> Doc readAttr (attrname, (AttrMethod _ t)) suffix msg = text "Snap.method Snap.GET $" <+> doStmts [ parens (text responseConstructor <+> parens (responseSNumed <> dot <> responseSNumed <+> text "_ resp")) <+> text "<- liftIO $ sendRequest conn $" <+> text (constrName suffix msg) <+> dot <+> text "SequenceNum.SequenceNum" , text "Snap.modifyResponse $ Snap.setContentType \"application/json\"" , text "Snap.writeLBS (encode resp)" ] where resp@(Message _ (StructType resp_tyname _)) = getResponseMessage attrname t responseConstructor = constrName "Producer" resp responseSNumed = text $ userTypeModuleName resp_tyname readAttr _ _ _ = error "impossible readAttr" 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 $" <+> 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 ---------------------------------------------------------- -- | Define everything associated with the manager, but only if there are stream -- values to manage. managerDef :: Bool -> Interface -> InputQueue -> (Bool,Doc) managerDef hasConsumer iface input | null streams = (False,empty) | otherwise = (True,stack defs empty) where streams = [ (name,ty) | (name,StreamMethod _ ty) <- allMethods iface ] (stateType,stateDecl) = stateDef streams defs = [ stateDecl , empty , mkStateDef streams , empty , text "manager ::" <+> arrow ([ stateType, input ] ++ [ input | hasConsumer ] ++ [ text "IO ()" ]) , nest 2 $ spread $ [ text "manager state input" ] ++ [ text "filtered" | hasConsumer ] ++ [ text "= forever $" doStmts stmts ] ] stmts = [ text "msg <- atomically (readTQueue input)" , nest 2 (text "case msg of" stack (map mkCase streams ++ [ defCase | hasConsumer ])) ] -- name the producer constructor for a stream element Schema prodSuffix _ = producerSchema iface prodName ty = text (typeModuleName ty ++ prodSuffix) -- update the state for this stream element mkCase (n,ty) = prodName ty <+> text "x -> atomically (writeTSampleVar" <+> parens (fieldName n <+> text "state") <+> text "x)" defCase = text "notStream -> atomically (writeTQueue filtered notStream)" -- | Generate the data type used to hold the streaming values, or nothing if -- there aren't any present in the interface. stateDef :: [(MethodName,Type)] -> (Doc,Doc) stateDef streams = (text "State",def) where def = nest 2 (text "data State = State" <+> braces fields) fields = align (stack (punctuate comma (map mkField streams))) mkField (name,ty) = fieldName name <+> text "::" <+> text "TSampleVar" <+> text (typeModuleName ty) mkStateDef :: [(MethodName,Type)] -> Doc mkStateDef streams = stack [ text "mkState :: IO State" , nest 2 (text "mkState =" nest 3 (doStmts stmts)) ] where stmts = [ fieldName n <+> text "<- newTSampleVarIO" | (n,_) <- streams ] ++ [ text "return State { .. }" ] -- | Given the name of a stream in the interface, produce the selector for the -- state data type. fieldName :: MethodName -> Doc fieldName name = text "stream_" <> text name -- Pretty-printing Helpers ----------------------------------------------------- arrow :: [Doc] -> Doc arrow ts = spread (punctuate (text "->") ts) commas :: [Doc] -> [Doc] commas = punctuate comma dots :: [Doc] -> Doc dots = cat . punctuate dot ppModName :: [String] -> Doc ppModName = dots . map text doStmts :: [Doc] -> Doc doStmts [d] = nest 2 d doStmts ds = text "do" <+> align (stack (map (nest 2) ds))