Encode UUIDs as ByteStrings
[ganeti-github.git] / src / Ganeti / THH / Field.hs
1 {-# LANGUAGE TemplateHaskell #-}
2
3 {-| Helpers for creating various kinds of 'Field's.
4
5 They aren't directly needed for the Template Haskell code in Ganeti.THH,
6 so better keep them in a separate module.
7
8 -}
9
10 {-
11
12 Copyright (C) 2014 Google Inc.
13 All rights reserved.
14
15 Redistribution and use in source and binary forms, with or without
16 modification, are permitted provided that the following conditions are
17 met:
18
19 1. Redistributions of source code must retain the above copyright notice,
20 this list of conditions and the following disclaimer.
21
22 2. Redistributions in binary form must reproduce the above copyright
23 notice, this list of conditions and the following disclaimer in the
24 documentation and/or other materials provided with the distribution.
25
26 THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
27 IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
28 TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
29 PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR
30 CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
31 EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
32 PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
33 PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
34 LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
35 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
36 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
37
38 -}
39
40 module Ganeti.THH.Field
41 ( specialNumericalField
42 , timeAsDoubleField
43 , timeStampFields
44 , uuidFields
45 , serialFields
46 , TagSet
47 , tagsFields
48 , fileModeAsIntField
49 , processIdField
50 ) where
51
52 import Control.Monad
53 import qualified Data.ByteString as BS
54 import qualified Data.Set as Set
55 import Language.Haskell.TH
56 import qualified Text.JSON as JSON
57 import System.Posix.Types (FileMode, ProcessID)
58 import System.Time (ClockTime(..))
59
60 import Ganeti.JSON
61 import Ganeti.THH
62
63 -- * Internal functions
64
65 -- | Wrapper around a special parse function, suitable as field-parsing
66 -- function.
67 numericalReadFn :: JSON.JSON a => (String -> JSON.Result a)
68 -> [(String, JSON.JSValue)] -> JSON.JSValue -> JSON.Result a
69 numericalReadFn _ _ v@(JSON.JSRational _ _) = JSON.readJSON v
70 numericalReadFn f _ (JSON.JSString x) = f $ JSON.fromJSString x
71 numericalReadFn _ _ _ = JSON.Error "A numerical field has to be a number or\
72 \ a string."
73
74 -- | Sets the read function to also accept string parsable by the given
75 -- function.
76 specialNumericalField :: Name -> Field -> Field
77 specialNumericalField f field =
78 field { fieldRead = Just (appE (varE 'numericalReadFn) (varE f)) }
79
80 -- | Creates a new mandatory field that reads time as the (floating point)
81 -- number of seconds since the standard UNIX epoch, and represents it in
82 -- Haskell as 'ClockTime'.
83 timeAsDoubleField :: String -> Field
84 timeAsDoubleField fname =
85 (simpleField fname [t| ClockTime |])
86 { fieldRead = Just $ [| \_ -> liftM unTimeAsDoubleJSON . JSON.readJSON |]
87 , fieldShow = Just $ [| \c -> (JSON.showJSON $ TimeAsDoubleJSON c, []) |]
88 }
89
90 -- | A helper function for creating fields whose Haskell representation is
91 -- 'Integral' and which are serialized as numbers.
92 integralField :: Q Type -> String -> Field
93 integralField typq fname =
94 let (~->) = appT . appT arrowT -- constructs an arrow type
95 (~::) = sigE . varE -- (f ~:: t) constructs (f :: t)
96 in (simpleField fname typq)
97 { fieldRead = Just $
98 [| \_ -> liftM $('fromInteger ~:: (conT ''Integer ~-> typq))
99 . JSON.readJSON |]
100 , fieldShow = Just $
101 [| \c -> (JSON.showJSON
102 . $('toInteger ~:: (typq ~-> conT ''Integer))
103 $ c, []) |]
104 }
105
106 -- * External functions and data types
107
108 -- | Timestamp fields description.
109 timeStampFields :: [Field]
110 timeStampFields = map (defaultField [| TOD 0 0 |] . timeAsDoubleField)
111 ["ctime", "mtime"]
112
113
114 -- | Serial number fields description.
115 serialFields :: [Field]
116 serialFields =
117 [ presentInForthcoming . renameField "Serial"
118 $ simpleField "serial_no" [t| Int |] ]
119
120 -- | UUID fields description.
121 uuidFields :: [Field]
122 uuidFields = [ presentInForthcoming $ simpleField "uuid" [t| BS.ByteString |] ]
123
124 -- | Tag set type alias.
125 type TagSet = Set.Set String
126
127 -- | Tag field description.
128 tagsFields :: [Field]
129 tagsFields = [ defaultField [| Set.empty |] $
130 simpleField "tags" [t| TagSet |] ]
131
132 -- ** Fields related to POSIX data types
133
134 -- | Creates a new mandatory field that reads a file mode in the standard
135 -- POSIX file mode representation. The Haskell type of the field is 'FileMode'.
136 fileModeAsIntField :: String -> Field
137 fileModeAsIntField = integralField [t| FileMode |]
138
139 -- | Creates a new mandatory field that contains a POSIX process ID.
140 processIdField :: String -> Field
141 processIdField = integralField [t| ProcessID |]