Merge branch 'stable-2.16' into stable-2.17
[ganeti-github.git] / src / Ganeti / THH / PyRPC.hs
1 {-# LANGUAGE TemplateHaskell #-}
2 {-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
3
4 {-| Combines the construction of RPC server components and their Python stubs.
5
6 -}
7
8 {-
9
10 Copyright (C) 2013 Google Inc.
11 All rights reserved.
12
13 Redistribution and use in source and binary forms, with or without
14 modification, are permitted provided that the following conditions are
15 met:
16
17 1. Redistributions of source code must retain the above copyright notice,
18 this list of conditions and the following disclaimer.
19
20 2. Redistributions in binary form must reproduce the above copyright
21 notice, this list of conditions and the following disclaimer in the
22 documentation and/or other materials provided with the distribution.
23
24 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
25 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
26 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
27 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
28 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
29 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
30 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
31 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
32 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
33 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
34 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
35
36 -}
37
38 module Ganeti.THH.PyRPC
39 ( genPyUDSRpcStub
40 , genPyUDSRpcStubStr
41 ) where
42
43 import Prelude ()
44 import Ganeti.Prelude
45
46 import Control.Monad (liftM, zipWithM)
47 import Data.Char (toLower, toUpper)
48 import Data.Maybe (fromMaybe)
49 import Language.Haskell.TH
50 import Language.Haskell.TH.Syntax (liftString)
51 import Text.PrettyPrint
52
53 import Ganeti.THH.Types
54
55 -- | The indentation step in generated Python files.
56 pythonIndentStep :: Int
57 pythonIndentStep = 2
58
59 -- | A helper function that nests a block of generated output by the default
60 -- step (see 'pythonIndentStep').
61 nest' :: Doc -> Doc
62 nest' = nest pythonIndentStep
63
64 -- | The name of an abstract function to which all method in a Python stub
65 -- are forwarded to.
66 genericInvokeName :: String
67 genericInvokeName = "_GenericInvoke"
68
69 -- | The name of a function that returns the socket path for reaching the
70 -- appropriate RPC client.
71 socketPathName :: String
72 socketPathName = "_GetSocketPath"
73
74 -- | Create a Python expression that applies a given function to a list of
75 -- given expressions
76 apply :: String -> [Doc] -> Doc
77 apply name as = text name <> parens (hcat $ punctuate (text ", ") as)
78
79 -- | An empty line block.
80 emptyLine :: Doc
81 emptyLine = text "" -- apparently using 'empty' doesn't work
82
83 lowerFirst :: String -> String
84 lowerFirst (x:xs) = toLower x : xs
85 lowerFirst [] = []
86
87 upperFirst :: String -> String
88 upperFirst (x:xs) = toUpper x : xs
89 upperFirst [] = []
90
91 -- | Creates a method declaration given a function name and a list of
92 -- Haskell types corresponding to its arguments.
93 toFunc :: String -> [Type] -> Q Doc
94 toFunc fname as = do
95 args <- zipWithM varName [1..] as
96 let args' = text "self" : args
97 callName = lowerFirst fname
98 return $ (text "def" <+> apply fname args') <> colon $+$
99 nest' (text "return" <+>
100 text "self." <>
101 apply genericInvokeName (text (show callName) : args)
102 )
103 where
104 -- | Create a name for a method argument, given its index position
105 -- and Haskell type.
106 varName :: Int -> Type -> Q Doc
107 varName _ (VarT n) = lowerFirstNameQ n
108 varName _ (ConT n) = lowerFirstNameQ n
109 varName idx (AppT ListT t) = listOf idx t
110 varName idx (AppT (ConT n) t)
111 | n == ''[] = listOf idx t
112 | otherwise = kind1Of idx n t
113 varName idx (AppT (AppT (TupleT 2) t) t')
114 = pairOf idx t t'
115 varName idx (AppT (AppT (ConT n) t) t')
116 | n == ''(,) = pairOf idx t t'
117 varName idx t = do
118 report False $ "Don't know how to make a Python variable name from "
119 ++ show t ++ "; using a numbered one."
120 return $ text ('_' : show idx)
121
122 -- | Create a name for a method argument, knowing that its a list of
123 -- a given type.
124 listOf :: Int -> Type -> Q Doc
125 listOf idx t = (<> text "List") <$> varName idx t
126
127 -- | Create a name for a method argument, knowing that its wrapped in
128 -- a type of kind @* -> *@.
129 kind1Of :: Int -> Name -> Type -> Q Doc
130 kind1Of idx name t = (<> text (nameBase name)) <$> varName idx t
131
132 -- | Create a name for a method argument, knowing that its a pair of
133 -- the given types.
134 pairOf :: Int -> Type -> Type -> Q Doc
135 pairOf idx t t' = do
136 tn <- varName idx t
137 tn' <- varName idx t'
138 return $ tn <> text "_" <> tn' <> text "_Pair"
139
140 lowerFirstNameQ :: Name -> Q Doc
141 lowerFirstNameQ = return . text . lowerFirst . nameBase
142
143 -- | Creates a method declaration by inspecting (reifying) Haskell's function
144 -- name.
145 nameToFunc :: Name -> Q Doc
146 nameToFunc name = do
147 (as, _) <- funArgs `liftM` typeOfFun name
148 -- If the function has just one argument, try if it isn't a tuple;
149 -- if not, use the arguments as they are.
150 let as' = fromMaybe as $ case as of
151 [t] -> tupleArgs t -- TODO CHECK!
152 _ -> Nothing
153 toFunc (upperFirst $ nameBase name) as'
154
155 -- | Generates a Python class stub, given a class name, the list of Haskell
156 -- functions to expose as methods, and a optionally a piece of code to
157 -- include.
158 namesToClass
159 :: String -- ^ the class name
160 -> Doc -- ^ Python code to include in the class
161 -> [Name] -- ^ the list of functions to include
162 -> Q Doc
163 namesToClass cname pycode fns = do
164 fnsCode <- mapM (liftM ($+$ emptyLine) . nameToFunc) fns
165 return $ vcat [ text "class" <+> apply cname [text "object"] <> colon
166 , nest' (
167 pycode $+$ vcat fnsCode
168 )
169 ]
170
171 -- | Takes a list of function names and creates a RPC handler that delegates
172 -- calls to them, as well as writes out the corresponding Python stub.
173 --
174 -- See 'mkRpcM' for the requirements on the passed functions and the returned
175 -- expression.
176 genPyUDSRpcStub
177 :: String -- ^ the name of the class to be generated
178 -> String -- ^ the name of the constant from @constants.py@ holding
179 -- the path to a UDS socket
180 -> [Name] -- ^ names of functions to include
181 -> Q Doc
182 genPyUDSRpcStub className constName = liftM (header $+$) .
183 namesToClass className stubCode
184 where
185 header = text "# This file is automatically generated, do not edit!" $+$
186 text "# pylint: skip-file"
187 stubCode =
188 abstrMethod genericInvokeName [ text "method", text "*args"] $+$
189 method socketPathName [] (
190 text "from ganeti import pathutils" $+$
191 text "return" <+> text "pathutils." <> text constName)
192 method name args body =
193 text "def" <+> apply name (text "self" : args) <> colon $+$
194 nest' body $+$
195 emptyLine
196 abstrMethod name args = method name args $
197 text "raise" <+> apply "NotImplementedError" []
198
199 -- The same as 'genPyUDSRpcStub', but returns the result as a @String@
200 -- expression.
201 genPyUDSRpcStubStr
202 :: String -- ^ the name of the class to be generated
203 -> String -- ^ the constant in @pathutils.py@ holding the socket path
204 -> [Name] -- ^ functions to include
205 -> Q Exp
206 genPyUDSRpcStubStr className constName names =
207 liftString . render =<< genPyUDSRpcStub className constName names