Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Newer
Older
100644 337 lines (305 sloc) 11.336 kb
8005cbd @mariusae Client side (synchronous) RPC support.
authored
1 {-# LANGUAGE OverlappingInstances, TypeSynonymInstances #-}
e9eefaa @mariusae Haskell implementation of BERT.
authored
2 -- |
3 -- Module : Data.BERT.Term
4 -- Copyright : (c) marius a. eriksen 2009
5 --
6 -- License : BSD3
7 -- Maintainer : marius@monkey.org
8 -- Stability : experimental
9 -- Portability : GHC
10 --
8005cbd @mariusae Client side (synchronous) RPC support.
authored
11 -- Define BERT termsm their binary encoding & decoding and a typeclass
12 -- for converting Haskell values to BERT terms and back.
13 --
14 -- We define a number of convenient instances for 'BERT'. Users will
15 -- probably want to define their own instances for composite types.
e9eefaa @mariusae Haskell implementation of BERT.
authored
16 module Data.BERT.Term
17 ( Term(..)
8005cbd @mariusae Client side (synchronous) RPC support.
authored
18 , BERT(..)
e9eefaa @mariusae Haskell implementation of BERT.
authored
19 ) where
20
8005cbd @mariusae Client side (synchronous) RPC support.
authored
21 import Control.Monad.Error
22 import Control.Monad (forM_, replicateM, liftM2, liftM3, liftM4)
e9eefaa @mariusae Haskell implementation of BERT.
authored
23 import Control.Applicative ((<$>))
24 import Data.Bits (shiftR, (.&.))
8ca25f5 @mariusae Support for time & regex composite types.
authored
25 import Data.Char (chr, isAsciiLower, isAscii)
e9eefaa @mariusae Haskell implementation of BERT.
authored
26 import Data.Binary (Binary(..), Word8)
8005cbd @mariusae Client side (synchronous) RPC support.
authored
27 import Data.Binary.Put (
28 Put, putWord8, putWord16be,
29 putWord32be, putLazyByteString)
30 import Data.Binary.Get (
31 Get, getWord8, getWord16be, getWord32be,
32 getLazyByteString)
8ca25f5 @mariusae Support for time & regex composite types.
authored
33 import Data.List (intercalate)
34 import Data.Time (UTCTime(..), diffUTCTime, addUTCTime, Day(..))
e9eefaa @mariusae Haskell implementation of BERT.
authored
35 import Data.ByteString.Lazy (ByteString)
36 import qualified Data.ByteString.Lazy as B
37 import qualified Data.ByteString.Lazy.Char8 as C
38 import Data.Map (Map)
39 import qualified Data.Map as Map
40 import Text.Printf (printf)
41
8ca25f5 @mariusae Support for time & regex composite types.
authored
42 -- The 0th-hour as per the BERT spec.
43 zeroHour = UTCTime (read "1970-01-01") 0
44
45 decomposeTime :: UTCTime -> (Int, Int, Int)
46 decomposeTime t = (mS, s, uS)
47 where
48 d = diffUTCTime t zeroHour
49 (mS, s) = (floor d) `divMod` 1000000
50 uS = floor $ 1000000 * (snd $ properFraction d)
51
52 composeTime :: (Int, Int, Int) -> UTCTime
53 composeTime (mS, s, uS) = addUTCTime seconds zeroHour
54 where
55 mS' = fromIntegral mS
56 s' = fromIntegral s
57 uS' = fromIntegral uS
58 seconds = ((mS' * 1000000) + s' + (uS' / 1000000))
59
60 fromAtom (AtomTerm a) = a
61
8005cbd @mariusae Client side (synchronous) RPC support.
authored
62 -- | A single BERT term.
e9eefaa @mariusae Haskell implementation of BERT.
authored
63 data Term
64 -- Simple (erlang) terms:
65 = IntTerm Int
66 | FloatTerm Float
67 | AtomTerm String
68 | TupleTerm [Term]
69 | BytelistTerm ByteString
70 | ListTerm [Term]
71 | BinaryTerm ByteString
72 | BigintTerm Integer
73 | BigbigintTerm Integer
8ca25f5 @mariusae Support for time & regex composite types.
authored
74 -- Composite (BERT specific) terms:
e9eefaa @mariusae Haskell implementation of BERT.
authored
75 | NilTerm
76 | BoolTerm Bool
77 | DictionaryTerm [(Term, Term)]
8ca25f5 @mariusae Support for time & regex composite types.
authored
78 | TimeTerm UTCTime
79 | RegexTerm String [String]
80 deriving (Eq, Ord)
e9eefaa @mariusae Haskell implementation of BERT.
authored
81
dfb6ce5 @mariusae refactor & simplify handling of composite terms
authored
82 -- Another design would be to split the Term type into
83 -- SimpleTerm|CompositeTerm, and then do everything in one go, but
84 -- that complicates syntax and semantics for end users. Let's do this
85 -- one ugly thing instead, eh?
830f934 @mariusae Some style cleanup.
authored
86 ct b rest = TupleTerm $ [AtomTerm "bert", AtomTerm b] ++ rest
87 compose NilTerm = ListTerm []
88 compose (BoolTerm True) = ct "true" []
89 compose (BoolTerm False) = ct "false" []
90 compose (DictionaryTerm kvs) =
91 ct "dict" [ListTerm $ map (\(k, v) -> TupleTerm [k, v]) kvs]
92 compose (TimeTerm t) =
93 ct "time" [IntTerm mS, IntTerm s, IntTerm uS]
dfb6ce5 @mariusae refactor & simplify handling of composite terms
authored
94 where
95 (mS, s, uS) = decomposeTime t
830f934 @mariusae Some style cleanup.
authored
96 compose (RegexTerm s os) =
97 ct "regex" [BytelistTerm (C.pack s),
98 TupleTerm [ListTerm $ map AtomTerm os]]
c00cbc2 @mariusae More stylistic changes.
authored
99 compose _ = error "invalid composite term"
dfb6ce5 @mariusae refactor & simplify handling of composite terms
authored
100
8ca25f5 @mariusae Support for time & regex composite types.
authored
101 instance Show Term where
102 -- Provide an erlang-compatible 'show' for terms. The results of
103 -- this should be parseable as erlang source.
104 show = showTerm
105
106 showTerm (IntTerm x) = show x
107 showTerm (FloatTerm x) = printf "%15.15e" x
108 showTerm (AtomTerm "") = ""
109 showTerm (AtomTerm a@(x:xs))
110 | isAsciiLower x = a
111 | otherwise = "'" ++ a ++ "'"
112 showTerm (TupleTerm ts) =
113 "{" ++ intercalate ", " (map showTerm ts) ++ "}"
114 showTerm (BytelistTerm bs) = show $ C.unpack bs
115 showTerm (ListTerm ts) =
116 "[" ++ intercalate ", " (map showTerm ts) ++ "]"
117 showTerm (BinaryTerm b)
118 | all (isAscii . chr . fromIntegral) (B.unpack b) =
119 wrap $ "\"" ++ C.unpack b ++ "\""
120 | otherwise =
121 wrap $ intercalate ", " $ map show $ B.unpack b
122 where
123 wrap x = "<<" ++ x ++ ">>"
124 showTerm (BigintTerm x) = show x
125 showTerm (BigbigintTerm x) = show x
dfb6ce5 @mariusae refactor & simplify handling of composite terms
authored
126 -- All other terms are composite:
830f934 @mariusae Some style cleanup.
authored
127 showTerm t = showTerm . compose $ t
738b076 @mariusae BERT-RPC implementation (both client & server), and a meaningful
authored
128
8005cbd @mariusae Client side (synchronous) RPC support.
authored
129 class BERT a where
130 -- | Introduce a 'Term' from a Haskell value.
131 showBERT :: a -> Term
132 -- | Attempt to read a haskell value from a 'Term'.
133 readBERT :: Term -> (Either String a)
134
135 -- Herein are some instances for common Haskell data types. To do
136 -- anything more complicated, you should make your own instance.
137
138 instance BERT Term where
139 showBERT = id
140 readBERT = return . id
141
142 instance BERT Int where
143 showBERT = IntTerm
144 readBERT (IntTerm value) = return value
145 readBERT _ = fail "Invalid integer type"
146
147 instance BERT Bool where
148 showBERT = BoolTerm
149 readBERT (BoolTerm x) = return x
150 readBERT _ = fail "Invalid bool type"
151
152 instance BERT Integer where
153 showBERT = BigbigintTerm
154 readBERT (BigintTerm x) = return x
155 readBERT (BigbigintTerm x) = return x
156 readBERT _ = fail "Invalid integer type"
157
158 instance BERT Float where
159 showBERT = FloatTerm
160 readBERT (FloatTerm value) = return value
161 readBERT _ = fail "Invalid floating point type"
162
163 instance BERT String where
164 showBERT = BytelistTerm . C.pack
165 readBERT (BytelistTerm x) = return $ C.unpack x
166 readBERT (BinaryTerm x) = return $ C.unpack x
167 readBERT (AtomTerm x) = return x
168 readBERT (ListTerm xs) = mapM readBERT xs >>= return . map chr
169 readBERT _ = fail "Invalid string type"
170
171 instance BERT ByteString where
172 showBERT = BytelistTerm
173 readBERT (BytelistTerm value) = return value
174 readBERT _ = fail "Invalid bytestring type"
175
176 instance (BERT a) => BERT [a] where
177 showBERT xs = ListTerm $ map showBERT xs
178 readBERT (ListTerm xs) = mapM readBERT xs
179 readBERT _ = fail "Invalid list type"
180
181 instance (BERT a, BERT b) => BERT (a, b) where
182 showBERT (a, b) = TupleTerm [showBERT a, showBERT b]
183 readBERT (TupleTerm [a, b]) = liftM2 (,) (readBERT a) (readBERT b)
184 readBERT _ = fail "Invalid tuple(2) type"
185
186 instance (BERT a, BERT b, BERT c) => BERT (a, b, c) where
187 showBERT (a, b, c) = TupleTerm [showBERT a, showBERT b, showBERT c]
188 readBERT (TupleTerm [a, b, c]) =
189 liftM3 (,,) (readBERT a) (readBERT b) (readBERT c)
190 readBERT _ = fail "Invalid tuple(3) type"
191
192 instance (BERT a, BERT b, BERT c, BERT d) => BERT (a, b, c, d) where
193 showBERT (a, b, c, d) =
194 TupleTerm [showBERT a, showBERT b, showBERT c, showBERT d]
195 readBERT (TupleTerm [a, b, c, d]) =
196 liftM4 (,,,) (readBERT a) (readBERT b) (readBERT c) (readBERT d)
197 readBERT _ = fail "Invalid tuple(4) type"
198
199 instance (Ord k, BERT k, BERT v) => BERT (Map k v) where
200 showBERT m = DictionaryTerm
201 $ map (\(k, v) -> (showBERT k, showBERT v)) (Map.toList m)
202 readBERT (DictionaryTerm kvs) =
203 mapM (\(k, v) -> liftM2 (,) (readBERT k) (readBERT v)) kvs >>=
204 return . Map.fromList
205 readBERT _ = fail "Invalid map type"
206
e9eefaa @mariusae Haskell implementation of BERT.
authored
207 -- Binary encoding & decoding.
208 instance Binary Term where
209 put term = putWord8 131 >> putTerm term
c00cbc2 @mariusae More stylistic changes.
authored
210 get = getWord8 >>= \magic ->
211 case magic of
e9eefaa @mariusae Haskell implementation of BERT.
authored
212 131 -> getTerm
c00cbc2 @mariusae More stylistic changes.
authored
213 _ -> fail "bad magic"
e9eefaa @mariusae Haskell implementation of BERT.
authored
214
215 -- | Binary encoding of a single term (without header)
216 putTerm (IntTerm value) = tag 98 >> put32i value
217 putTerm (FloatTerm value) =
218 tag 99 >> (putL . C.pack . pad $ printf "%15.15e" value)
219 where
220 pad s = s ++ replicate (31 - (length s)) '\0'
221 putTerm (AtomTerm value)
222 | len < 256 = tag 100 >> put16i len >> (putL $ C.pack value)
223 | otherwise = fail "BERT atom too long (>= 256)"
224 where
225 len = length value
226 putTerm (TupleTerm value)
227 | len < 256 = tag 104 >> put8i len >> forM_ value putTerm
228 | otherwise = tag 105 >> put32i len >> forM_ value putTerm
229 where
230 len = length value
231 putTerm (BytelistTerm value)
232 | len < 65536 = tag 107 >> put16i len >> putL value
233 | otherwise = do -- too big: encode as a list.
234 tag 108
235 put32i len
236 forM_ (B.unpack value) $ \v -> do
237 tag 97
238 putWord8 v
239 where
240 len = B.length value
241 putTerm (ListTerm value)
242 | len == 0 = putNil -- this is mentioend in the BERT spec.
243 | otherwise= do
244 tag 108
245 put32i $ length value
246 forM_ value putTerm
247 putNil
248 where
249 len = length value
250 putNil = putWord8 106
251 putTerm (BinaryTerm value) = tag 109 >> (put32i $ B.length value) >> putL value
252 putTerm (BigintTerm value) = tag 110 >> putBigint put8i value
253 putTerm (BigbigintTerm value) = tag 111 >> putBigint put32i value
dfb6ce5 @mariusae refactor & simplify handling of composite terms
authored
254 -- All other terms are composite:
830f934 @mariusae Some style cleanup.
authored
255 putTerm t = putTerm . compose $ t
8ca25f5 @mariusae Support for time & regex composite types.
authored
256
e9eefaa @mariusae Haskell implementation of BERT.
authored
257 -- | Binary decoding of a single term (without header)
258 getTerm = do
259 tag <- get8i
260 case tag of
261 97 -> IntTerm <$> get8i
262 98 -> IntTerm <$> get32i
263 99 -> getL 31 >>= return . FloatTerm . read . C.unpack
264 100 -> get16i >>= getL >>= return . AtomTerm . C.unpack
265 104 -> get8i >>= getN >>= tupleTerm
266 105 -> get32i >>= getN >>= tupleTerm
267 106 -> return $ ListTerm []
268 107 -> get16i >>= getL >>= return . BytelistTerm
269 108 -> get32i >>= getN >>= return . ListTerm
270 109 -> get32i >>= getL >>= return . BinaryTerm
271 110 -> getBigint get8i >>= return . BigintTerm . fromIntegral
272 111 -> getBigint get32i >>= return . BigintTerm . fromIntegral
273 where
274 getN n = replicateM n getTerm
dfb6ce5 @mariusae refactor & simplify handling of composite terms
authored
275 -- First try & decode composite terms.
e9eefaa @mariusae Haskell implementation of BERT.
authored
276 tupleTerm [AtomTerm "bert", AtomTerm "true"] = return $ BoolTerm True
277 tupleTerm [AtomTerm "bert", AtomTerm "false"] = return $ BoolTerm False
278 tupleTerm [AtomTerm "bert", AtomTerm "dict", ListTerm kvs] =
279 mapM toTuple kvs >>= return . DictionaryTerm
280 where
281 toTuple (TupleTerm [k, v]) = return $ (k, v)
282 toTuple _ = fail "invalid dictionary"
8ca25f5 @mariusae Support for time & regex composite types.
authored
283 tupleTerm [AtomTerm "bert", AtomTerm "time",
284 IntTerm mS, IntTerm s, IntTerm uS] =
285 return $ TimeTerm $ composeTime (mS, s, uS)
286 tupleTerm [AtomTerm "bert", AtomTerm "regex",
287 BytelistTerm s, ListTerm os] =
288 options os >>= return . RegexTerm (C.unpack s)
289 where
290 -- TODO: type-check the options values as well
291 options [] = return []
292 options ((AtomTerm o):os) = options os >>= return . (o:)
293 options _ = fail "regex options must be atoms"
dfb6ce5 @mariusae refactor & simplify handling of composite terms
authored
294 -- All other tuples are just .. tuples
e9eefaa @mariusae Haskell implementation of BERT.
authored
295 tupleTerm xs = return $ TupleTerm xs
296
297 putBigint putter value = do
298 putter len -- TODO: verify size?
299 if value < 0
300 then put8i 1
301 else put8i 0
302 putL $ B.pack $ map (fromIntegral . digit) [0..len-1]
303 where
304 value' = abs value
305 len = ceiling $ logBase 256 (fromIntegral $ value' + 1)
306 digit pos = (value' `shiftR` (8 * pos)) .&. 0xFF
307
308 getBigint getter = do
309 len <- fromIntegral <$> getter
310 sign <- get8i
311 bytes <- getL len
312 multiplier <-
313 case sign of
314 0 -> return 1
315 1 -> return (-1)
316 _ -> fail "Invalid sign byte"
317 return $ (*) multiplier
318 $ foldl (\s (n, d) -> s + d*(256^n)) 0
319 $ zip [0..len-1] (map fromIntegral $ B.unpack bytes)
320
321 put8i :: (Integral a) => a -> Put
322 put8i = putWord8 . fromIntegral
323 put16i :: (Integral a) => a -> Put
324 put16i = putWord16be . fromIntegral
325 put32i :: (Integral a) => a -> Put
326 put32i = putWord32be . fromIntegral
327 putL = putLazyByteString
328
329 get8i = fromIntegral <$> getWord8
330 get16i = fromIntegral <$> getWord16be
331 get32i = fromIntegral <$> getWord32be
332 getL :: (Integral a) => a -> Get ByteString
333 getL = getLazyByteString . fromIntegral
334
335 tag :: Word8 -> Put
336 tag which = putWord8 which
Something went wrong with that request. Please try again.