root / src / Ganeti / THH / PyRPC.hs @ c8751a72
History | View | Annotate | Download (6.3 kB)
1 | f952ed9f | Petr Pudlak | {-# LANGUAGE TemplateHaskell #-} |
---|---|---|---|
2 | 857a05fe | Petr Pudlak | {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} |
3 | f952ed9f | Petr Pudlak | |
4 | f952ed9f | Petr Pudlak | {-| Combines the construction of RPC server components and their Python stubs. |
5 | f952ed9f | Petr Pudlak | |
6 | f952ed9f | Petr Pudlak | -} |
7 | f952ed9f | Petr Pudlak | |
8 | f952ed9f | Petr Pudlak | {- |
9 | f952ed9f | Petr Pudlak | |
10 | f952ed9f | Petr Pudlak | Copyright (C) 2013 Google Inc. |
11 | f952ed9f | Petr Pudlak | |
12 | f952ed9f | Petr Pudlak | This program is free software; you can redistribute it and/or modify |
13 | f952ed9f | Petr Pudlak | it under the terms of the GNU General Public License as published by |
14 | f952ed9f | Petr Pudlak | the Free Software Foundation; either version 2 of the License, or |
15 | f952ed9f | Petr Pudlak | (at your option) any later version. |
16 | f952ed9f | Petr Pudlak | |
17 | f952ed9f | Petr Pudlak | This program is distributed in the hope that it will be useful, but |
18 | f952ed9f | Petr Pudlak | WITHOUT ANY WARRANTY; without even the implied warranty of |
19 | f952ed9f | Petr Pudlak | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
20 | f952ed9f | Petr Pudlak | General Public License for more details. |
21 | f952ed9f | Petr Pudlak | |
22 | f952ed9f | Petr Pudlak | You should have received a copy of the GNU General Public License |
23 | f952ed9f | Petr Pudlak | along with this program; if not, write to the Free Software |
24 | f952ed9f | Petr Pudlak | Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
25 | f952ed9f | Petr Pudlak | 02110-1301, USA. |
26 | f952ed9f | Petr Pudlak | |
27 | f952ed9f | Petr Pudlak | -} |
28 | f952ed9f | Petr Pudlak | |
29 | f952ed9f | Petr Pudlak | module Ganeti.THH.PyRPC |
30 | f952ed9f | Petr Pudlak | ( genPyUDSRpcStub |
31 | f952ed9f | Petr Pudlak | , genPyUDSRpcStubStr |
32 | f952ed9f | Petr Pudlak | ) where |
33 | f952ed9f | Petr Pudlak | |
34 | f952ed9f | Petr Pudlak | import Control.Monad |
35 | f952ed9f | Petr Pudlak | import Data.Char (toLower, toUpper) |
36 | f952ed9f | Petr Pudlak | import Data.Functor |
37 | f952ed9f | Petr Pudlak | import Data.Maybe (fromMaybe) |
38 | f952ed9f | Petr Pudlak | import Language.Haskell.TH |
39 | f952ed9f | Petr Pudlak | import Language.Haskell.TH.Syntax (liftString) |
40 | f952ed9f | Petr Pudlak | import Text.PrettyPrint |
41 | f952ed9f | Petr Pudlak | |
42 | f952ed9f | Petr Pudlak | import Ganeti.THH.Types |
43 | f952ed9f | Petr Pudlak | |
44 | f952ed9f | Petr Pudlak | -- | The indentation step in generated Python files. |
45 | f952ed9f | Petr Pudlak | pythonIndentStep :: Int |
46 | f952ed9f | Petr Pudlak | pythonIndentStep = 2 |
47 | f952ed9f | Petr Pudlak | |
48 | f952ed9f | Petr Pudlak | -- | A helper function that nests a block of generated output by the default |
49 | f952ed9f | Petr Pudlak | -- step (see 'pythonIndentStep'). |
50 | f952ed9f | Petr Pudlak | nest' :: Doc -> Doc |
51 | f952ed9f | Petr Pudlak | nest' = nest pythonIndentStep |
52 | f952ed9f | Petr Pudlak | |
53 | f952ed9f | Petr Pudlak | -- | The name of an abstract function to which all method in a Python stub |
54 | f952ed9f | Petr Pudlak | -- are forwarded to. |
55 | f952ed9f | Petr Pudlak | genericInvokeName :: String |
56 | f952ed9f | Petr Pudlak | genericInvokeName = "_GenericInvoke" |
57 | f952ed9f | Petr Pudlak | |
58 | f952ed9f | Petr Pudlak | -- | The name of a function that returns the socket path for reaching the |
59 | f952ed9f | Petr Pudlak | -- appropriate RPC client. |
60 | f952ed9f | Petr Pudlak | socketPathName :: String |
61 | f952ed9f | Petr Pudlak | socketPathName = "_GetSocketPath" |
62 | f952ed9f | Petr Pudlak | |
63 | f952ed9f | Petr Pudlak | -- | Create a Python expression that applies a given function to a list of |
64 | f952ed9f | Petr Pudlak | -- given expressions |
65 | f952ed9f | Petr Pudlak | apply :: String -> [Doc] -> Doc |
66 | f952ed9f | Petr Pudlak | apply name as = text name <> parens (hcat $ punctuate (text ", ") as) |
67 | f952ed9f | Petr Pudlak | |
68 | f952ed9f | Petr Pudlak | -- | An empty line block. |
69 | f952ed9f | Petr Pudlak | emptyLine :: Doc |
70 | f952ed9f | Petr Pudlak | emptyLine = text "" -- apparently using 'empty' doesn't work |
71 | f952ed9f | Petr Pudlak | |
72 | f952ed9f | Petr Pudlak | lowerFirst :: String -> String |
73 | f952ed9f | Petr Pudlak | lowerFirst (x:xs) = toLower x : xs |
74 | f952ed9f | Petr Pudlak | lowerFirst [] = [] |
75 | f952ed9f | Petr Pudlak | |
76 | f952ed9f | Petr Pudlak | upperFirst :: String -> String |
77 | f952ed9f | Petr Pudlak | upperFirst (x:xs) = toUpper x : xs |
78 | f952ed9f | Petr Pudlak | upperFirst [] = [] |
79 | f952ed9f | Petr Pudlak | |
80 | f952ed9f | Petr Pudlak | -- | Creates a method declaration given a function name and a list of |
81 | f952ed9f | Petr Pudlak | -- Haskell types corresponding to its arguments. |
82 | f952ed9f | Petr Pudlak | toFunc :: String -> [Type] -> Q Doc |
83 | f952ed9f | Petr Pudlak | toFunc fname as = do |
84 | f952ed9f | Petr Pudlak | args <- zipWithM varName [1..] as |
85 | f952ed9f | Petr Pudlak | let args' = text "self" : args |
86 | f952ed9f | Petr Pudlak | callName = lowerFirst fname |
87 | f952ed9f | Petr Pudlak | return $ (text "def" <+> apply fname args') <> colon $+$ |
88 | f952ed9f | Petr Pudlak | nest' (text "return" <+> |
89 | f952ed9f | Petr Pudlak | text "self." <> |
90 | f952ed9f | Petr Pudlak | apply genericInvokeName (text (show callName) : args) |
91 | f952ed9f | Petr Pudlak | ) |
92 | f952ed9f | Petr Pudlak | where |
93 | f952ed9f | Petr Pudlak | -- | Create a name for a method argument, given its index position |
94 | f952ed9f | Petr Pudlak | -- and Haskell type. |
95 | f952ed9f | Petr Pudlak | varName :: Int -> Type -> Q Doc |
96 | f952ed9f | Petr Pudlak | varName _ (VarT n) = lowerFirstNameQ n |
97 | f952ed9f | Petr Pudlak | varName _ (ConT n) = lowerFirstNameQ n |
98 | f952ed9f | Petr Pudlak | varName idx (AppT ListT t) = listOf idx t |
99 | f952ed9f | Petr Pudlak | varName idx (AppT (ConT n) t) |
100 | f952ed9f | Petr Pudlak | | n == ''[] = listOf idx t |
101 | f952ed9f | Petr Pudlak | varName idx t = do |
102 | f952ed9f | Petr Pudlak | report False $ "Don't know how to make a Python variable name from " |
103 | f952ed9f | Petr Pudlak | ++ show t ++ "; using a numbered one." |
104 | f952ed9f | Petr Pudlak | return $ text ('_' : show idx) |
105 | f952ed9f | Petr Pudlak | |
106 | f952ed9f | Petr Pudlak | -- | Create a name for a method argument, knowing that its a list of |
107 | f952ed9f | Petr Pudlak | -- a given type. |
108 | f952ed9f | Petr Pudlak | listOf :: Int -> Type -> Q Doc |
109 | f952ed9f | Petr Pudlak | listOf idx t = (<> text "List") <$> varName idx t |
110 | f952ed9f | Petr Pudlak | |
111 | f952ed9f | Petr Pudlak | lowerFirstNameQ :: Name -> Q Doc |
112 | f952ed9f | Petr Pudlak | lowerFirstNameQ = return . text . lowerFirst . nameBase |
113 | f952ed9f | Petr Pudlak | |
114 | f952ed9f | Petr Pudlak | -- | Creates a method declaration by inspecting (reifying) Haskell's function |
115 | f952ed9f | Petr Pudlak | -- name. |
116 | f952ed9f | Petr Pudlak | nameToFunc :: Name -> Q Doc |
117 | f952ed9f | Petr Pudlak | nameToFunc name = do |
118 | f952ed9f | Petr Pudlak | (as, _) <- funArgs `liftM` typeOfFun name |
119 | f952ed9f | Petr Pudlak | -- If the function has just one argument, try if it isn't a tuple; |
120 | f952ed9f | Petr Pudlak | -- if not, use the arguments as they are. |
121 | f952ed9f | Petr Pudlak | let as' = fromMaybe as $ case as of |
122 | f952ed9f | Petr Pudlak | [t] -> tupleArgs t -- TODO CHECK! |
123 | f952ed9f | Petr Pudlak | _ -> Nothing |
124 | f952ed9f | Petr Pudlak | toFunc (upperFirst $ nameBase name) as' |
125 | f952ed9f | Petr Pudlak | |
126 | f952ed9f | Petr Pudlak | -- | Generates a Python class stub, given a class name, the list of Haskell |
127 | f952ed9f | Petr Pudlak | -- functions to expose as methods, and a optionally a piece of code to |
128 | f952ed9f | Petr Pudlak | -- include. |
129 | f952ed9f | Petr Pudlak | namesToClass |
130 | f952ed9f | Petr Pudlak | :: String -- ^ the class name |
131 | f952ed9f | Petr Pudlak | -> Doc -- ^ Python code to include in the class |
132 | f952ed9f | Petr Pudlak | -> [Name] -- ^ the list of functions to include |
133 | f952ed9f | Petr Pudlak | -> Q Doc |
134 | f952ed9f | Petr Pudlak | namesToClass cname pycode fns = do |
135 | f952ed9f | Petr Pudlak | fnsCode <- mapM (liftM ($+$ emptyLine) . nameToFunc) fns |
136 | f952ed9f | Petr Pudlak | return $ vcat [ text "class" <+> apply cname [text "object"] <> colon |
137 | f952ed9f | Petr Pudlak | , nest' ( |
138 | f952ed9f | Petr Pudlak | pycode $+$ vcat fnsCode |
139 | f952ed9f | Petr Pudlak | ) |
140 | f952ed9f | Petr Pudlak | ] |
141 | f952ed9f | Petr Pudlak | |
142 | f952ed9f | Petr Pudlak | -- | Takes a list of function names and creates a RPC handler that delegates |
143 | f952ed9f | Petr Pudlak | -- calls to them, as well as writes out the corresponding Python stub. |
144 | f952ed9f | Petr Pudlak | -- |
145 | f952ed9f | Petr Pudlak | -- See 'mkRpcM' for the requirements on the passed functions and the returned |
146 | f952ed9f | Petr Pudlak | -- expression. |
147 | f952ed9f | Petr Pudlak | genPyUDSRpcStub |
148 | f952ed9f | Petr Pudlak | :: String -- ^ the name of the class to be generated |
149 | f952ed9f | Petr Pudlak | -> String -- ^ the name of the constant from @constants.py@ holding |
150 | f952ed9f | Petr Pudlak | -- the path to a UDS socket |
151 | f952ed9f | Petr Pudlak | -> [Name] -- ^ names of functions to include |
152 | f952ed9f | Petr Pudlak | -> Q Doc |
153 | f952ed9f | Petr Pudlak | genPyUDSRpcStub className constName = liftM (header $+$) . |
154 | f952ed9f | Petr Pudlak | namesToClass className stubCode |
155 | f952ed9f | Petr Pudlak | where |
156 | f952ed9f | Petr Pudlak | header = text "# This file is automatically generated, do not edit!" $+$ |
157 | f952ed9f | Petr Pudlak | text "# pylint: disable-all" |
158 | f952ed9f | Petr Pudlak | stubCode = |
159 | f952ed9f | Petr Pudlak | abstrMethod genericInvokeName [ text "method", text "*args"] $+$ |
160 | f952ed9f | Petr Pudlak | method socketPathName [] ( |
161 | f952ed9f | Petr Pudlak | text "from ganeti import pathutils" $+$ |
162 | f952ed9f | Petr Pudlak | text "return" <+> text "pathutils." <> text constName) |
163 | f952ed9f | Petr Pudlak | method name args body = |
164 | f952ed9f | Petr Pudlak | text "def" <+> apply name (text "self" : args) <> colon $+$ |
165 | f952ed9f | Petr Pudlak | nest' body $+$ |
166 | f952ed9f | Petr Pudlak | emptyLine |
167 | f952ed9f | Petr Pudlak | abstrMethod name args = method name args $ |
168 | f952ed9f | Petr Pudlak | text "raise" <+> apply "NotImplementedError" [] |
169 | f952ed9f | Petr Pudlak | |
170 | f952ed9f | Petr Pudlak | -- The same as 'genPyUDSRpcStub', but returns the result as a @String@ |
171 | f952ed9f | Petr Pudlak | -- expression. |
172 | f952ed9f | Petr Pudlak | genPyUDSRpcStubStr |
173 | f952ed9f | Petr Pudlak | :: String -- ^ the name of the class to be generated |
174 | f952ed9f | Petr Pudlak | -> String -- ^ the constant in @pathutils.py@ holding the socket path |
175 | f952ed9f | Petr Pudlak | -> [Name] -- ^ functions to include |
176 | f952ed9f | Petr Pudlak | -> Q Exp |
177 | f952ed9f | Petr Pudlak | genPyUDSRpcStubStr className constName names = |
178 | f952ed9f | Petr Pudlak | liftString . render =<< genPyUDSRpcStub className constName names |