tnet-0.0.1: TNET.hs
{-# LANGUAGE OverloadedStrings, FlexibleInstances, TypeSynonymInstances,
OverlappingInstances #-}
-- | 'TNET' is a library that implements the TNET serialization protocol
-- to be used for PGI
-- (<http://code.google.com/p/polyweb/source/browse/doc/PGI.txt>)
-- applications. The TNET protocol
-- (<http://tnetstrings.org>) is designed to be simple to implement in
-- any language, please look at the README for the changes to the
-- original tnetstrings spec.
module TNET
(
-- * TNET Parser
tnetParser
-- * Classes
, TNET(..)
-- * Types
, TValue
-- * TNET serialization functions
, decode
, encode
-- * Helpers for defining TNET datatypes
, dict
, (.=)
, (.:)
) where
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.UTF8 as U
import Data.Attoparsec as P
import Data.Attoparsec.Char8 (char8, endOfLine)
import qualified Data.Attoparsec.Char8 as P8
import Control.Applicative
import Data.Word (Word8)
import Data.Char
import Control.Arrow (second)
-- | A 'TValue' represents a raw TNET object. TNET values
-- are one of the following types:
--
-- * a string of bytes
--
-- * a UTF-8 encoded string
--
-- * an integer
--
-- * a floating point number
--
-- * a boolean
--
-- * null
--
-- * a dictionary type
--
-- * a list of TValues
data TValue = TBytes ByteString
| TString String
| TInteger Integer
| TFloat Double
| TBool Bool
| TNull
| TDict [(String, TValue)]
| TList [TValue]
deriving (Eq, Show)
-- | Used to create a TNET dictionary from
-- TNET values. Meant to be used with the
-- '.=' operator as in the following example:
--
-- > myDict = dict [ "a" .= 5
-- > , "is_dict" .= True
-- > ]
dict :: [(String, TValue)] -> TValue
dict = TDict
(.=) :: (TNET a) => String -> a -> (String, TValue)
key .= val = (key, toTNET val)
-- | Helper function to extract TNET values from
-- a TNET dictionary. Meant to be used as in the
-- following example:
--
-- > data Person = Person {
-- > name :: String
-- > , age :: Integer
-- > }
-- > personFromDict :: TValue -> Maybe Person
-- > personFromDict tdict = do
-- > name <- tdict .: "name"
-- > age <- tdict .: "age"
-- > return $ Person name age
(.:) :: TNET a => TValue -> String -> Maybe a
(TDict xs) .: key = let lkup = lookup key xs in
case lkup of
Nothing -> fromTNET TNull
Just v -> fromTNET v
_ .: _ = Nothing
-- | The 'TNET' typeclass represents types that
-- can be encoded and decoded in the TNET format.
-- An example instance:
--
-- > data Person = Person {
-- > name :: String
-- > , age :: Integer
-- > }
-- > instance TNET Person where
-- > toTNET (Person n a) = dict [ "name" .= n
-- > , "age" .= a
-- > ]
-- > fromTNET tval = do
-- > n <- tval .: "name"
-- > a <- tval .: "age"
-- > return $ Person n a
class TNET a where
toTNET :: a -> TValue
fromTNET :: TValue -> Maybe a
instance TNET () where
toTNET = const TNull
fromTNET TNull = Just ()
fromTNET _ = Nothing
instance TNET TValue where
toTNET = id
fromTNET = Just
instance TNET Integer where
toTNET = TInteger
fromTNET (TInteger n) = Just n
fromTNET _ = Nothing
instance TNET Double where
toTNET = TFloat
fromTNET (TFloat n) = Just n
fromTNET _ = Nothing
instance TNET Bool where
toTNET = TBool
fromTNET (TBool b) = Just b
fromTNET _ = Nothing
instance TNET a => TNET [(String, a)] where
toTNET = TDict . map (second toTNET)
fromTNET (TDict d) = mapM (f . second fromTNET) d
where f (s, Just x) = Just (s, x)
f _ = Nothing
fromTNET _ = Nothing
instance TNET String where
toTNET = TString
fromTNET (TString s) = Just s
fromTNET _ = Nothing
instance TNET Char where
toTNET = TString . (:[])
fromTNET (TString [c]) = Just c
fromTNET _ = Nothing
instance TNET ByteString where
toTNET = TBytes
fromTNET (TBytes b) = Just b
fromTNET _ = Nothing
instance TNET a => TNET (Maybe a) where
toTNET = maybe TNull toTNET
fromTNET TNull = Just Nothing
fromTNET x = case fromTNET x of
Just val -> Just $ Just val
Nothing -> Nothing
instance TNET a => TNET [a] where
toTNET = TList . map toTNET
fromTNET (TList xs) = mapM fromTNET xs
fromTNET _ = Nothing
dataFromTValue :: TValue -> ByteString
dataFromTValue (TBytes bs) = bs
dataFromTValue (TString s) = U.fromString s
dataFromTValue (TBool True) = "true"
dataFromTValue (TBool False) = "false"
dataFromTValue TNull = ""
dataFromTValue (TInteger n) = (B8.pack . show) n
dataFromTValue (TFloat n) = (B8.pack . show) n
dataFromTValue (TList l) = B8.concat $ map dumpTNET l
dataFromTValue (TDict m) = B8.concat $ map dumpPair m
typeFromTValue :: TValue -> ByteString
typeFromTValue (TBytes _) = ","
typeFromTValue (TString _) = "$"
typeFromTValue (TBool _) = "!"
typeFromTValue TNull = "~"
typeFromTValue (TInteger _) = "#"
typeFromTValue (TFloat _) = "^"
typeFromTValue (TList _) = "]"
typeFromTValue (TDict _) = "}"
dumpPair :: (String, TValue) -> ByteString
dumpPair (key, value) =
dumpTNET (TString key) `B8.append` dumpTNET value
dumpTNET :: TValue -> ByteString
dumpTNET tval = let t_data = dataFromTValue tval
t_size = B8.pack . show $ B8.length t_data
t_type = typeFromTValue tval
in B8.concat [t_size, ":", t_data, t_type]
-- | Encode a Haskell value into the TNET format.
-- Some examples:
--
-- >>> encode 5
-- "1:5#"
--
-- >>> encode "Hello"
-- "5:Hello$"
--
-- >>> encode (-12.3)
-- "5:-12.3^"
--
-- >>> encode ()
-- "0:~"
encode :: TNET a => a -> ByteString
encode = dumpTNET . toTNET
-- | Decode a TNET format bytestring into a Haskell
-- value. An explicit type annotation may be needed
-- if the type of the decoded value can not be
-- determined:
--
-- >>> decode "0:~" :: Maybe ()
-- Just ()
--
-- >>> decode "0:~" :: Maybe (Maybe String)
-- Just Nothing
--
-- >>> decode "1:5#" :: Maybe Integer
-- Just 5
--
-- > let x = decode "4:true!" in
-- > case x of
-- > Just True -> putStrLn "got true!"
-- > Just False -> putStrLn "got false!"
-- > Nothing -> putStrLn "error decoding"
decode :: TNET a => ByteString -> Maybe a
decode s = case parse tnetParser s of
Done _ v -> fromTNET v
_ -> Nothing
tnetParser :: Parser TValue
tnetParser = do
size <- P8.decimal <* char8 ':'
t_data <- P.take size
t_type <- P8.satisfy $ P8.inClass ",$#^!~}]?"
case t_type of
',' -> return $ TBytes t_data
'$' -> return $ TString $ U.toString t_data
'~' -> if size == 0 then return TNull
else empty
'!' -> case parseOnly p_bool t_data of
Left err -> fail "failed to parse bool"
Right b -> return b
'?' -> case parseOnly p_smallbool t_data of
Left err -> fail "failed to parse bool"
Right b -> return b
'#' -> case parseOnly (P8.signed P8.decimal) t_data of
Left err -> fail "failed to parse integer"
Right n -> return $ TInteger n
'^' -> case parseOnly (P8.signed P8.double) t_data of
Left err -> fail "failed to parse float"
Right n -> return $ TFloat n
'}' -> case parseOnly (many p_pair) t_data of
Left err -> fail "failed to parse dict"
Right m -> return $ TDict m
']' -> case parseOnly (many tnetParser) t_data of
Left err -> fail "failed to parse list"
Right m -> return $ TList m
_ -> empty
p_bool :: Parser TValue
p_bool = (return (TBool True) <* P8.string "true")
<|> return (TBool False)
p_smallbool :: Parser TValue
p_smallbool = (return (TBool True) <* P8.string "t")
<|> return (TBool False)
p_pair :: Parser (String, TValue)
p_pair = do
key <- tnetParser
value <- tnetParser
case key of
TString s -> return (s, value)
TBytes s -> return (U.toString s, value)
_ -> fail "key must be string"