llsd (empty) → 0.1.0.1
raw patch · 16 files changed
+3313/−0 lines, 16 filesdep +HUnitdep +QuickCheckdep +basesetup-changed
Dependencies added: HUnit, QuickCheck, base, binary, bytestring, cereal, containers, dataenc, ghc-prim, hexpat, mtl, network, old-locale, parsec, pretty, random, template-haskell, text, time, utf8-string, uuid
Files
- LICENSE +17/−0
- Main.hs +119/−0
- Network/Format/LLSD.hs +50/−0
- Network/Format/LLSD/Binary.hs +178/−0
- Network/Format/LLSD/Conversion.hs +232/−0
- Network/Format/LLSD/IEEE754.hs +27/−0
- Network/Format/LLSD/Internal.hs +376/−0
- Network/Format/LLSD/LLIDL.hs +367/−0
- Network/Format/LLSD/Pretty.hs +80/−0
- Network/Format/LLSD/Test.hs +452/−0
- Network/Format/LLSD/TestIDL.hs +816/−0
- Network/Format/LLSD/XML.hs +171/−0
- Setup.lhs +6/−0
- TestData.hs +133/−0
- TestMain.hs +211/−0
- llsd.cabal +78/−0
+ LICENSE view
@@ -0,0 +1,17 @@+Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN+THE SOFTWARE.
+ Main.hs view
@@ -0,0 +1,119 @@+-- |+-- Module : Main - LLSD Utility+-- Copyright : (c) Linden Lab 2009+-- License : MIT+-- Maintainer : bos@lindenlab.com+-- Stability : provisional+-- Portability : portable++module Main where++import Control.Monad+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.UTF8 as U+import Data.List (foldl')+import Data.Maybe+import Network.Format.LLSD+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO+import Text.PrettyPrint.HughesPJ (render)+++data Mode = Mode {+ modeHelp :: Bool,+ modeInput :: Maybe (B.ByteString -> Either String LLSD),+ modeOutput :: Maybe (LLSD -> L.ByteString)+ }++defaultMode :: Mode+defaultMode = Mode {+ modeHelp = False,+ modeInput = Nothing,+ modeOutput = Nothing+ }++++options :: [OptDescr (Mode -> Mode)]+options = [+ Option ['b'] ["in-binary"] (NoArg setInBinary) "read binary encoded LLSD",+ Option ['e'] ["in-example"] (NoArg setInExample) "use example LLSD as input",+ Option ['x'] ["in-xml"] (NoArg setInXML) "read XML encoded LLSD",++ Option ['B'] ["out-binary"] (NoArg setOutBinary) "write XML encoded ouptut",+ Option ['P'] ["out-pretty"] (NoArg setOutPretty) "write pretty print output",+ Option ['S'] ["out-show"] (NoArg setOutShow) "write show output",+ Option ['V'] ["out-valid"] (NoArg setOutValid) "write only if LLSD is valid",+ Option ['X'] ["out-xml"] (NoArg setOutXML) "write XML encoded ouptut",++ Option ['?'] ["help"] (NoArg setHelp) "print help summary"+ ]+ where setInput f mode = mode { modeInput = Just f }+ setOutput f mode = mode { modeOutput = Just f }+ setHelp mode = mode { modeHelp = True }++ setInExample = setInput $ const $ Right (llsd `with` "name" .= "Amy")+ setInXML = setInput parseXML+ setInBinary = setInput parseBinary++ setOutPretty = setOutput $ U.fromString . render . prettyLLSD+ setOutShow = setOutput $ U.fromString . show+ setOutValid = setOutput $ const $ U.fromString "valid LLSD"+ setOutXML = setOutput formatXML+ setOutBinary = setOutput formatBinary++usage :: [String] -> Handle -> IO ()+usage errs h =+ do+ progName <- getProgName+ forM_ errs (hPutStr h)+ hPutStr h $ usageInfo (header progName) options+ where header progName = "Usage: " ++ progName ++ " [options] [files]"++usageFailure :: [String] -> IO a+usageFailure errs = usage errs stderr >> exitFailure++parseOptions :: IO (Mode, [String])+parseOptions =+ do+ argv <- getArgs+ case getOpt Permute options argv of+ (opts, args, []) -> return (foldl' (flip ($)) defaultMode opts, args)+ ( _, _, errs) -> usageFailure errs+++++process :: Mode -> B.ByteString -> IO ()+process mode input =+ case (modeInput mode, modeOutput mode) of+ (Just inF, Just outF) ->+ case inF input of+ Left err -> hPutStrLn stderr err+ Right v -> L.putStr $ outF v+ (inM, outM) ->+ usageFailure (errIfMissing "No input mode selected\n" inM+ ++ errIfMissing "No output mode selected\n" outM)+ where errIfMissing msg f = maybe [msg] (const []) f+++processHandle :: Mode -> Handle -> IO ()+processHandle mode h = B.hGetContents h >>= process mode++processFile :: Mode -> String -> IO ()+processFile mode path = B.readFile path >>= process mode++main :: IO ()+main = do+ (mode, files) <- parseOptions+ when (modeHelp mode) $ do+ usage [] stdout+ exitSuccess+ if null files+ then processHandle mode stdin+ else forM_ files $ processFile mode++
+ Network/Format/LLSD.hs view
@@ -0,0 +1,50 @@+-- |+-- Module : Network.Format.LLSD+-- Copyright : (c) Linden Lab 2009+-- License : MIT+-- Maintainer : bos@lindenlab.com+-- Stability : provisional+-- Portability : portable+--+-- An implementation of the LLSD data system.+--+-- LLSD is defined in draft-hamrick-vwrap-type-system-00. It is a structured +-- data system used for interchange. See the draft for more details:+-- <http://tools.ietf.org/html/draft-hamrick-vwrap-type-system-00>++module Network.Format.LLSD (+ -- * Types+ LLSD,+ -- * Classes+ SData(..),+ SPath(..),+ -- * Functions+ -- ** Constants+ undef,+ -- ** Information+ size,+ -- ** Structure Accessors+ set, setAtIndex, setAtKey,+ get, getAtIndex, getAtKey,+ has, hasIndex, hasKey,+ -- ** Path Based Accessor DSL+ llsd,+ (./),+ (.=),+ with,+ at,+ -- ** Conversion+ toMap,+ toList,+ prettyLLSD,+ parseXML,+ formatXML,+ parseBinary,+ formatBinary,+ )+ where++import Network.Format.LLSD.Binary+import Network.Format.LLSD.Internal+import Network.Format.LLSD.Pretty+import Network.Format.LLSD.XML
+ Network/Format/LLSD/Binary.hs view
@@ -0,0 +1,178 @@+-- |+-- Module : Network.Format.LLSD.Binary+-- Copyright : (c) Linden Lab 2009+-- License : MIT+-- Maintainer : bos@lindenlab.com+-- Stability : provisional+-- Portability : portable++module Network.Format.LLSD.Binary (+ formatBinary,+ parseBinary+ )+ where++import Control.Monad (liftM, replicateM, when)+import qualified Data.Binary as Binary+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as U+import qualified Data.ByteString.Lazy as L+import Data.Char (chr, ord)+import qualified Data.Map as Map+import Data.UUID (UUID)+import Data.Serialize+import Data.Serialize.Get+import Data.Serialize.Put+import Data.Time+import Data.Time.Clock.POSIX+import Data.Word (Word64)+import Network.Format.LLSD.IEEE754+import Network.Format.LLSD.Internal+import Network.URI (URI, uriToString)+++parseBinary :: B.ByteString -> Either String LLSD+parseBinary = decode++formatBinary :: LLSD -> L.ByteString+formatBinary = toLazyByteString . encode++instance Serialize LLSD where+ get = getLLSD+ put = putLLSD+++getLLSD :: Get LLSD+getLLSD = do+ c <- getChar8+ case c of+ '!' -> return undef+ '1' -> return $ toLLSD True+ '0' -> return $ toLLSD False+ 'i' -> getInt32be >>= return . toLLSD+ 'r' -> getWord64be >>= return . toLLSD . decodeIEEEDouble+ 's' -> getString >>= return . toLLSD+ 'u' -> getUUID >>= return . toLLSD+ 'd' -> getWord64be >>= return . toLLSD . decodeDate+ 'l' -> getString >>= return . toLLSD+ . (fromLLSD . toLLSD :: String -> URI)+ 'b' -> getInt32be >>= getLazyByteString . fromIntegral+ >>= return . toLLSD+ '[' -> getLLSDArray+ '{' -> getLLSDMap+ _ -> fail $ "unrecognized binary tag: " ++ show c++getLLSDArray :: Get LLSD+getLLSDArray = do+ n <- getInt32be+ vs <- replicateM n getLLSD+ validateChar8 ']' "missing closing bracket on array"+ return $ toLLSD vs++getLLSDMap :: Get LLSD+getLLSDMap = do+ n <- getInt32be+ vs <- replicateM n getLLSDEntry+ validateChar8 '}' "missing closing bracket on map"+ return $ toLLSD $ Map.fromAscList vs++getLLSDEntry :: Get (String, LLSD)+getLLSDEntry = do+ validateChar8 'k' "missing key in map"+ k <- getString+ v <- getLLSD+ return (k, v)++validateChar8 :: Char -> String -> Get ()+validateChar8 c msg = do+ a <- getChar8+ when (a /= c) $ fail msg+++++putLLSD :: Putter LLSD+putLLSD (LUndef) = putChar8 '!'+putLLSD (LBool True) = putChar8 '1'+putLLSD (LBool False) = putChar8 '0'+putLLSD (LInt v) = putChar8 'i' >> putInt32be v+putLLSD (LReal v) = putChar8 'r' >> putWord64be (encodeIEEEDouble v)+putLLSD (LString v) = putChar8 's' >> putString v+putLLSD (LUUID v) = putChar8 'u' >> putUUID v+putLLSD (LDate v) = putChar8 'd' >> putWord64be (encodeDate v)+putLLSD (LURI v) = putChar8 'l' >> putString (uriToString id v "")+putLLSD (LBinary v) = putChar8 'b' >> putInt32be (fromIntegral $ L.length v)+ >> putLazyByteString v+putLLSD (LArray m) = putChar8 '[' >> putLLSDArray m >> putChar8 ']'+putLLSD (LMap m) = putChar8 '{' >> putLLSDMap m >> putChar8 '}'+++putLLSDArray :: Putter (Map.Map Int LLSD)+putLLSDArray m = putInt32be (length vs) >> mapM_ putLLSD vs+ where vs = expandLLSDArray m++putLLSDMap :: Putter (Map.Map String LLSD)+putLLSDMap m = putInt32be (length vs) >> mapM_ putLLSDEntry vs+ where vs = Map.assocs m++putLLSDEntry :: Putter (String, LLSD)+putLLSDEntry (k, v) = putChar8 'k' >> putString k >> putLLSD v++++--+-- Utilities to make working with Serial easier+--++getChar8 :: Get Char+getChar8 = liftM (chr . fromIntegral) getWord8+putChar8 :: Putter Char+putChar8 = putWord8 . fromIntegral . ord++getInt32be :: Get Int+getInt32be = liftM fromIntegral getWord32be+putInt32be :: Putter Int+putInt32be = putWord32be . fromIntegral++getString :: Get String+getString = getInt32be >>= getByteString >>= return . U.toString+putString :: Putter String+putString s = putInt32be (B.length u) >> putByteString u+ where u = U.fromString s++-- These are a hack until Data.UUID supports either extracting the bytes+-- or being an instance of Serialize+getUUID :: Get UUID+getUUID = getLazyByteString 16 >>= \bs -> return (Binary.decode bs :: UUID)+putUUID :: Putter UUID+putUUID = putLazyByteString . Binary.encode+++--+-- Conversion Utilities+--++toByteString :: L.ByteString -> B.ByteString+toByteString = B.concat . L.toChunks++toLazyByteString :: B.ByteString -> L.ByteString+toLazyByteString = L.fromChunks . (:[])++decodeDate :: Word64 -> UTCTime+decodeDate = posixSecondsToUTCTime . realToFrac . decodeIEEEDouble++encodeDate :: UTCTime -> Word64+encodeDate = encodeIEEEDouble . realToFrac . utcTimeToPOSIXSeconds++++{-+ Notes on cereal++ needed utility functions getInt32be, getChar8, etc....+ needed utility functions for IEEE floats / doubles+ getBytes but not putBytes+ needing to include Serial, Serial.Get, Serial.Put seems excessive+ built in instances seem generally unhelpful++-}
+ Network/Format/LLSD/Conversion.hs view
@@ -0,0 +1,232 @@+{-# LANGUAGE TypeSynonymInstances #-}++-- |+-- Module : Network.Format.LLSD.Conversions+-- Copyright : (c) Linden Lab 2009, 2010+-- License : MIT+-- Maintainer : bos@lindenlab.com+-- Stability : provisional+-- Portability : portable+--+-- Conversion operations for the simple types+--+-- This module implements the conversion rules for LLSD. The conversion rules+-- define how a received LLSD value of type a should be converted to be used+-- as a value of type b. These conversions are designed to ensure fidelity of+-- intended values as LLSD moves through systems and languages that may have+-- less rich type systems, and/or "common" automatic value conversion rules.+--+-- Conversion in LLSD is always defined to return a value. However, for use+-- by LLIDL, knowledge of the fidelity of the conversion is needed++module Network.Format.LLSD.Conversion (+ Fidelity(..), (~&~), (~|~),+ Conversion,+ ConvertTo,+ ConvertFrom(..),+ convert,+ )+ where++import Data.Maybe (fromJust, listToMaybe)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import System.Locale (defaultTimeLocale)++import qualified Data.ByteString.Lazy as Byte+import qualified Data.Time as Time+import qualified Data.UUID as UUID+import qualified Network.URI as URI+++-- | How accurately a conversion was performed+data Fidelity = Incompatible -- the value was a type that couldn't convert+ | Unconvertable -- convertable type, but conversion failed+ | Approximate -- converted, but information was lost+ | Mixed -- value has both additional and defaulted data+ | Additional -- value had additional data (for maps and arrays)+ | Defaulted -- the default value due to undef or ""+ | Converted -- the value was converted+ | Native -- value was natively the correct type+ | Matched -- the value has the correct shape + deriving (Eq, Ord, Show)+{- Notes:++ Mixed, Additional, and Matched are used by LLIDL for maps and arrays. No+ conversions return these values.+ + This whole scheme is somewhat overblown. There are really only three+ levels of Fidelity LLIDL cares about:+ + Fidelity Match Valid Invalid+ Incompatible - - x+ Unconvertable - - x+ Approximate - - x+ Defaulted - x -+ Converted x x -+ Native x x -+ + Integrity Match Valid Invalid+ Incompatible - - x+ Mixed - x -+ Additional - x -+ Defaulted - x -+ Matched x x -+-}++(~&~) :: Fidelity -> Fidelity -> Fidelity+Incompatible ~&~ _ = Incompatible -- important short circuit case+Defaulted ~&~ Additional = Mixed+Additional ~&~ Defaulted = Mixed+a ~&~ b = min a b+infixr 3 ~&~++(~|~) :: Fidelity -> Fidelity -> Fidelity+Matched ~|~ _ = Matched -- important short circuit case+a ~|~ b = max a b+infixr 2 ~|~++++-- | The result of a conversion+type Conversion a = (a, Fidelity)+++class ConvertTo a where+ defaultValue :: a+ + convertFromUndef :: () -> Conversion a+ convertFromBool :: Bool -> Conversion a+ convertFromInt :: Int -> Conversion a+ convertFromReal :: Double -> Conversion a+ convertFromString :: String -> Conversion a+ convertFromUUID :: UUID.UUID -> Conversion a+ convertFromDate :: Time.UTCTime -> Conversion a+ convertFromURI :: URI.URI -> Conversion a+ convertFromBinary :: Byte.ByteString -> Conversion a+ + -- default implementations+ convertFromUndef = const $ defaultWith Defaulted+ convertFromBool = const $ defaultWith Incompatible+ convertFromInt = const $ defaultWith Incompatible+ convertFromReal = const $ defaultWith Incompatible+ convertFromString = const $ defaultWith Incompatible+ convertFromUUID = const $ defaultWith Incompatible+ convertFromDate = const $ defaultWith Incompatible+ convertFromURI = const $ defaultWith Incompatible+ convertFromBinary = const $ defaultWith Incompatible++++native :: a -> Conversion a+native a = (a, Native)++convertAsJust :: a -> Conversion a+convertAsJust a = (a, Converted)++defaultWith :: (ConvertTo a) => Fidelity -> Conversion a+defaultWith f = (defaultValue, f)++convertString :: (ConvertTo a) =>+ (String -> Maybe a) -> String -> Conversion a+convertString f s =+ if null s+ then defaultWith Defaulted+ else maybe (defaultWith Unconvertable) convertAsJust $ f s+++ +instance ConvertTo Bool where+ defaultValue = False+ convertFromBool = native+ convertFromInt = boolConv 0 1 (/= 0)+ convertFromReal = boolConv 0.0 1.0 (\v -> v < 0.0 || 0.0 < v)+ -- written this way to handle NaNs+ convertFromString = boolConv "" "true" (/= "")++boolConv :: (Eq a) => a -> a -> (a -> Bool) -> a -> Conversion Bool+boolConv vFalse vTrue f v = (f v, if canonical then Converted else Approximate)+ where canonical = v == vFalse || v == vTrue+++instance ConvertTo Int where+ defaultValue = 0+ convertFromBool v = convertAsJust $ if v then 1 else 0+ convertFromInt = native+ convertFromReal = intFromDouble+ convertFromString = intFromDoubleConv . convertFromString++intFromDouble :: Double -> Conversion Int+intFromDouble d = (i, f)+ where i = round d+ f = if fromIntegral i == d then Converted else Approximate+ +intFromDoubleConv :: Conversion Double -> Conversion Int+intFromDoubleConv (d, Converted) = intFromDouble d+intFromDoubleConv (_, f) = (defaultValue, f)+++instance ConvertTo Double where+ defaultValue = 0.0+ convertFromBool v = convertAsJust $ if v then 1.0 else 0.0+ convertFromInt = convertAsJust . realToFrac+ convertFromReal = native+ convertFromString = convertString readDouble++instance ConvertTo String where+ defaultValue = ""+ convertFromBool v = convertAsJust $ if v then "true" else ""+ convertFromInt = convertAsJust . show+ convertFromReal = convertAsJust . show+ convertFromString = native+ convertFromUUID = convertAsJust . UUID.toString+ convertFromDate =+ convertAsJust . Time.formatTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ"+ convertFromURI v = convertAsJust $ URI.uriToString id v ""+ +instance ConvertTo UUID.UUID where+ defaultValue =+ fromJust $ UUID.fromString "00000000-0000-0000-0000-000000000000"+ -- FIXME: replace when UUID exports the nilUUID+ convertFromString = convertString UUID.fromString+ convertFromUUID = native++instance ConvertTo Time.UTCTime where+ defaultValue = posixSecondsToUTCTime 0+ convertFromString =+ convertString $ Time.parseTime defaultTimeLocale "%Y-%m-%dT%H:%M:%S%QZ"+ convertFromDate = native++instance ConvertTo URI.URI where+ defaultValue = URI.nullURI+ convertFromString = convertString URI.parseURIReference+ convertFromURI = native++instance ConvertTo Byte.ByteString where+ defaultValue = Byte.empty+ convertFromBinary = native++++class ConvertFrom a where+ conversion :: (ConvertTo b) => a -> Conversion b++instance ConvertFrom () where conversion = convertFromUndef+instance ConvertFrom Bool where conversion = convertFromBool+instance ConvertFrom Int where conversion = convertFromInt+instance ConvertFrom Double where conversion = convertFromReal+instance ConvertFrom String where conversion = convertFromString+instance ConvertFrom UUID.UUID where conversion = convertFromUUID+instance ConvertFrom Time.UTCTime where conversion = convertFromDate+instance ConvertFrom URI.URI where conversion = convertFromURI+instance ConvertFrom Byte.ByteString where conversion = convertFromBinary++++convert :: (ConvertFrom a, ConvertTo b) => a -> b+convert = fst . conversion++++readDouble :: String -> Maybe Double+readDouble = listToMaybe . map fst . filter ((=="") . snd) . reads+
+ Network/Format/LLSD/IEEE754.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE MagicHash #-}++-- |+-- Module : Network.Format.LLSD.IEEE754+-- Copyright : (c) Linden Lab 2009+-- License : MIT+-- Maintainer : bos@lindenlab.com+-- Stability : provisional+-- Portability : GHC specific++module Network.Format.LLSD.IEEE754 (+ encodeIEEEDouble, -- :: Double -> Word64+ decodeIEEEDouble, -- :: Word64 -> Double+ )+ where++import GHC.Prim+import GHC.Types+import GHC.Word++encodeIEEEDouble :: Double -> Word64+encodeIEEEDouble (D# x) = W64# (unsafeCoerce# x)+{-# NOINLINE encodeIEEEDouble #-}++decodeIEEEDouble :: Word64 -> Double+decodeIEEEDouble (W64# x) = D# (unsafeCoerce# x)+{-# NOINLINE decodeIEEEDouble #-}
+ Network/Format/LLSD/Internal.hs view
@@ -0,0 +1,376 @@+{-# LANGUAGE FlexibleInstances, OverlappingInstances, TypeSynonymInstances #-}++-- |+-- Module : Network.Format.LLSD.Internal+-- Copyright : (c) Linden Lab 2009+-- License : MIT+-- Maintainer : bos@lindenlab.com+-- Stability : provisional+-- Portability : portable+--+-- Internal Implementation+-- Other modules inside LLSD include this in order to get at the details+-- and utility functions. The only exposed module, Data.LLSD, re-exports+-- ony the public bits from here.++module Network.Format.LLSD.Internal where++{-+ Missing operations++ has :: String -> LLSD -> Bool++ delete :: String -> LLSD -> LLSD+ append :: (SData a) -> a -> LLSD -> LLSD++ pretty :: LLSD -> PP.Doc+-}++import qualified Data.ByteString.Lazy as Byte+import Data.List (foldl')+import Data.Maybe (fromMaybe, isJust)+import qualified Data.Map as M+import qualified Data.Time as Time+import qualified Data.UUID as UUID+import Network.Format.LLSD.Conversion+import qualified Network.URI as URI+++{- |+ An LLSD value. May represent a single value of any of the LLSD types:+ Undefined, Boolean, Integer, Real, String, UUID, Data, URI or Binary; or may+ be an Array or Map of LLSD values.+-}+data LLSD = LUndef+ | LBool Bool+ | LInt Int+ | LReal Double+ | LString String+ | LUUID UUID.UUID+ | LDate Time.UTCTime+ | LURI URI.URI+ | LBinary Byte.ByteString+ | LArray (M.Map Int LLSD)+ | LMap (M.Map String LLSD)++++-- | An undefined LLSD value. Useful for a starting point for building up values+-- using the 'with' construct:+--+-- > llsd `with` "name" .= "Amy"+-- > `with` "skill" .= 42+llsd :: LLSD+llsd = LUndef++-- | The LLSD with the value of type Undefined.+undef :: LLSD+undef = LUndef++-- | The number of values in a map or array, else 0.+size :: LLSD -> Int+size (LArray m) = M.size m+size (LMap m) = M.size m+size _ = 0+++expandLLSDArray :: M.Map Int LLSD -> [LLSD]+expandLLSDArray m = map (vOrUndef . lookupIn m) [0..maxIndex]+ where vOrUndef v = fromMaybe undef v+ lookupIn = flip M.lookup+ maxIndex = if M.null m then (-1) else fst . M.findMax $ m+++conversionFromLLSD :: (ConvertTo a) => LLSD -> Conversion a+conversionFromLLSD (LUndef) = conversion ()+conversionFromLLSD (LBool v) = conversion v+conversionFromLLSD (LInt v) = conversion v+conversionFromLLSD (LReal v) = conversion v+conversionFromLLSD (LString v) = conversion v+conversionFromLLSD (LUUID v) = conversion v+conversionFromLLSD (LDate v) = conversion v+conversionFromLLSD (LURI v) = conversion v+conversionFromLLSD (LBinary v) = conversion v+conversionFromLLSD _ = conversion ()++convertFromLLSD :: (ConvertTo a) => LLSD -> a+convertFromLLSD = fst. conversionFromLLSD+++{- |+ Types that can be converted to and from LLSD.++ LLSD was designed to be very resilient and flexible in light of difference+ between end points. In particular, it has well defined, though liberal+ type conversion, designed to allow data to map directly into the data+ system of an implementation.++ Instances of SData can be converted to and from LLSD values. The LLSD types+ are handled by these provided instances of SData:++ * LLSD Boolean <-> 'Bool'++ * LLSD Integer <-> 'Int'++ * LLSD Real <-> 'Double'++ * LLSD String <-> 'String'++ * LLSD UUID <-> 'UUID' (from 'Data.UUID')++ * LLSD Date <-> 'UTCTime' (from 'Data.Time')++ * LLSD URI <-> 'URI' (from 'Network.URI')++ * LLSD Binary <-> 'ByteString' (from 'Data.ByteString.Lazy')++ Other Haskell types can be extended to support conversion to and from LLSD+ by being made instances of SData:++ @+data Address = Address String String String Int+ deriving (Eq, Show)++instance SData Address where+ toLLSD (Address street city state zipcode) =+ llsd `with` "street" .= street+ `with` "city" .= city+ `with` "state" .= state+ `with` "zip" .= zipcode+ fromLLSD v =+ Address (v `at` "street")+ (v `at` "city")+ (v `at` "state")+ (v `at` "zip")+ @++ For a given @'SData a'@ type, @[a]@ and @'Map' 'String' a@ are also+ instances of SData, allow easy conversion to and from such structures.++ Finally, @'LLSD'@ itself is an instance of @'SData'@, which is convienent+ for extracting lists or maps of heterogenous values from an LLSD.+-}+class SData a where+ -- | Convert the value to an LLSD value.+ toLLSD :: a -> LLSD+ -- | Convert an LLSD value to a value of the given type.+ -- The instances for the base types perform conversion+ -- as per the LLSD spec, if the underlying LLSD type doesn't match.+ fromLLSD :: LLSD -> a++instance SData LLSD where+ toLLSD = id+ fromLLSD = id++{-+instance SData () where+ toLLSD () = LUndef+ fromLLSD _ = ()+ -- Dang, this won't compile!+-}++instance (SData a) => SData (Maybe a) where+ toLLSD Nothing = LUndef+ toLLSD (Just v) = toLLSD v+ fromLLSD LUndef = Nothing+ fromLLSD l = Just $ fromLLSD l+ -- FIXME: Not clear if this is correct behavior+ -- should it be Nothing unless it is of the right type?+ -- should this even be defined?+++instance SData Bool where+ toLLSD b = LBool b+ fromLLSD = convertFromLLSD++instance SData Int where+ toLLSD v = LInt v+ fromLLSD = convertFromLLSD++instance SData Double where+ -- FIXME: generalize to all Fractionals some how+ toLLSD v = LReal v+ fromLLSD = convertFromLLSD++instance SData String where+ -- FIXME: requires OverlappingInstances which seems scary+ toLLSD v = LString v+ fromLLSD = convertFromLLSD++instance SData UUID.UUID where+ toLLSD v = LUUID v+ fromLLSD = convertFromLLSD++instance SData Time.UTCTime where+ toLLSD v = LDate v+ fromLLSD = convertFromLLSD++instance SData URI.URI where+ toLLSD v = LURI v+ fromLLSD = convertFromLLSD++instance SData Byte.ByteString where+ toLLSD v = LBinary v+ fromLLSD = convertFromLLSD++instance (SData a) => SData [a] where+ toLLSD as = LArray $ M.fromDistinctAscList $ zip [0..] $ map toLLSD as+ fromLLSD (LArray m) = map fromLLSD $ expandLLSDArray m+ fromLLSD _ = []++instance (SData a) => SData (M.Map String a) where+ toLLSD m = LMap (M.map toLLSD m)+ fromLLSD (LMap m) = M.map fromLLSD m+ fromLLSD _ = M.empty++instance (SData a) => SData [(String, a)] where+ toLLSD = toLLSD . M.fromList+ fromLLSD = M.toList . fromLLSD++++-- seems like it would be okay to export LLSDSegment, it's constructors,+-- and LLSDPath... if cleaned up++data LLSDSegment = PIndex Int | PKey String+ deriving Show++type LLSDPath = [LLSDSegment]++class SPath a where+ toPath :: a -> LLSDPath++instance SPath LLSDPath where+ toPath = id++instance SPath Int where+ toPath i = [ PIndex i ]++instance SPath String where+ toPath k = [ PKey k ]++class SSegment a where+ toSegment :: a -> LLSDSegment++instance SSegment LLSDSegment where+ toSegment = id++instance SSegment Int where+ toSegment i = PIndex i++instance SSegment String where+ toSegment k = PKey k+++{-- Native LLSD access interface++ All these functions take or return SData values. These values have+ toLLSD applied when combined into an LLSD, and fromLLSD applied when+ returned. Since LLSD is an instance of SData, then can be used with+ other LLSD values, any of the base types that LLSD supports, or your+ own extensions (via instancing SData).++ The set family of functions all return a copy of an LLSD with a+ given within the LLSD updated. These operations will+ force values within the LLSD to become arrays or maps as needed.+--}++innerArray :: LLSD -> M.Map Int LLSD+innerArray (LArray m) = m+innerArray _ = M.empty++innerMap :: LLSD -> M.Map String LLSD+innerMap (LMap m) = m+innerMap _ = M.empty++setAtIndex :: (SData a) => Int -> a -> LLSD -> LLSD+-- ^ Return an updated LLSD array, with the index set to the given value+setAtIndex i v d = LArray $ M.insert i (toLLSD v) (innerArray d)+++setAtKey :: (SData a) => String -> a -> LLSD -> LLSD+-- ^ Return an updated LLSD map, with the key set to the given value+setAtKey k v d = LMap $ M.insert k (toLLSD v) (innerMap d)+++setSegment :: (SData a) => LLSDSegment -> a -> LLSD -> LLSD+setSegment (PIndex i) = setAtIndex i+setSegment (PKey k) = setAtKey k++setPath :: (SData a) => LLSDPath -> a -> LLSD -> LLSD+setPath (p:ps) v d = setSegment p (setPath ps v (getSegment p d)) d+setPath [] v _ = toLLSD v++set :: (SPath a, SData b) => a -> b -> LLSD -> LLSD+-- ^ Return a copy of the LLSD, with the value at the given path+set p v = setPath (toPath p) (toLLSD v)+++-- | Return a the value at an LLSD array+getAtIndex :: (SData a) => Int -> LLSD -> a+getAtIndex i d = fromLLSD $ fromMaybe undef $ M.lookup i (innerArray d)++-- | Return a value in an LLSD map+getAtKey :: (SData a) => String -> LLSD -> a+getAtKey k d = fromLLSD $ fromMaybe undef $ M.lookup k (innerMap d)++getSegment :: (SData a) => LLSDSegment -> LLSD -> a+getSegment (PIndex i) = getAtIndex i+getSegment (PKey i) = getAtKey i++getPath :: (SData a) => LLSDPath -> LLSD -> a+getPath p d = fromLLSD $ foldl' (flip getSegment) d p++-- | Retun a value in an LLSD at a given path+get :: (SPath a, SData b) => a -> LLSD -> b+get p = getPath (toPath p)++-- | Test if an LLSD is an array, and has an entry at the index+-- Note: The entry could be undef+hasIndex :: Int -> LLSD -> Bool+hasIndex i d = M.member i (innerArray d)++-- | Test if an LLSD is a map, and has a entry for the key+hasKey :: String -> LLSD -> Bool+hasKey k d = M.member k (innerMap d)++-- | Test if an LLSD has a value (even undef) at a given path.+-- Note: A value may be 'fetched' from the path even if this function+-- returns False, though the value will be the default for the type.+has :: (SPath a) => a -> LLSD -> Bool+has p d = isJust $ foldl' hasSegment (Just d) (toPath p)+ where hasSegment Nothing _ = Nothing+ hasSegment (Just e) (PIndex i) = M.lookup i (innerArray e)+ hasSegment (Just e) (PKey k) = M.lookup k (innerMap e)++++(./) :: (SSegment a, SPath b) => a -> b -> LLSDPath+-- ^ Combine a segment and a path into a path+a ./ b = toSegment a : toPath b+infixr 4 ./++at :: (SPath a, SData b) => LLSD -> a -> b+-- ^ Return a value in an LLSD at a path+d `at` ps = get ps d+infixl 2 `at`++with :: (SPath a, SData b) => LLSD -> (a, b) -> LLSD+-- ^ Return a copy of the LLSD with the given path updated to a new value+d `with` (ps, v) = set ps v d+infixl 2 `with`++(.=) :: (SPath a, SData b) => a -> b -> (a, b)+-- ^ Suppy the value to set at a path, for use with with+ps .= v = (ps, v)+infix 3 .=+++toMap :: (SData a) => LLSD -> M.Map String a+-- ^ Convert to a Data.Map+toMap = fromLLSD -- M.map fromLLSD . innerMap++toList :: (SData a) => LLSD -> [a]+-- ^ Convert to a list+toList = map fromLLSD . expandLLSDArray . innerArray+
+ Network/Format/LLSD/LLIDL.hs view
@@ -0,0 +1,367 @@+{-# LANGUAGE DeriveDataTypeable #-}++-- |+-- Module : Network.Format.LLSD.LLIDL+-- Copyright : (c) Linden Lab 2009+-- License : MIT+-- Maintainer : bos@lindenlab.com+-- Stability : provisional+-- Portability : portable++module Network.Format.LLSD.LLIDL (+ LLIDL(..),+ match, valid, hasAdditional, hasDefaulted, incompatible,++ Suite(),+ request, response,+ + Definition(..), -- for quasi quoter+ fromDefinitions,+ + parseValue,+ parseSuite,+ + llidlSuite,+ llidlValue,+ )+ where++import Control.Monad+import Data.Data+import Data.List+import qualified Data.Map as M+import qualified Data.Set as S+import Network.Format.LLSD.Conversion+import Network.Format.LLSD.Internal+import Text.ParserCombinators.Parsec+import Text.ParserCombinators.Parsec.Pos++import qualified Data.ByteString.Lazy as Byte+import qualified Data.Time as Time+import qualified Data.UUID as UUID+import qualified Network.URI as URI++import qualified Language.Haskell.TH as TH+import Language.Haskell.TH.Quote+++data LLIDL = UndefLLIDL+ | BoolLLIDL | IntLLIDL | RealLLIDL | StringLLIDL+ | DateLLIDL | UriLLIDL | UuidLLIDL | BinaryLLIDL+ | SelectNameLLIDL String | SelectBoolLLIDL Bool | SelectIntLLIDL Int+ | ArrayLLIDL Bool [LLIDL]+ | MapLLIDL [(String, LLIDL)]+ | DictLLIDL LLIDL+ | VariantLLIDL String+ | UndefinedLLIDL+ | BoundLLIDL VarContext LLIDL+ deriving (Typeable, Data)++++baseResolve :: LLIDL -> LLSD -> Fidelity+baseResolve i = resolve i M.empty++match :: LLIDL -> LLSD -> Bool+match i v = baseResolve i v >= Converted++valid :: LLIDL -> LLSD -> Bool+valid i v = baseResolve i v >= Mixed++hasAdditional :: LLIDL -> LLSD -> Bool+hasAdditional i v = let r = baseResolve i v in r == Additional || r == Mixed++hasDefaulted :: LLIDL -> LLSD -> Bool+hasDefaulted i v = let r = baseResolve i v in r == Defaulted || r == Mixed++incompatible :: LLIDL -> LLSD -> Bool+incompatible i v = baseResolve i v < Mixed+++type VarContext = M.Map String [LLIDL]++bindContext :: VarContext -> LLIDL -> LLIDL+bindContext = BoundLLIDL++++type ReqRsp = (LLIDL, LLIDL)+data Definition = Resource String LLIDL LLIDL | Variant String LLIDL+ deriving (Typeable, Data)++data Suite = S {+ resources :: M.Map String ReqRsp,+ variants :: VarContext+ }++fromDefinitions :: [Definition] -> Suite+fromDefinitions = foldl' merge (S M.empty M.empty)+ where merge (S rs vs) (Resource k req rsp) = S (M.insert k (req, rsp) rs) vs+ merge (S rs vs) (Variant k var) = S rs (M.insertWith (++) k [var] vs)+ +resource :: String -> Suite -> ReqRsp+resource r st = M.findWithDefault undefinedResource r (resources st)+ where undefinedResource = (UndefinedLLIDL, UndefinedLLIDL)++request :: String -> Suite -> LLIDL+request r st = bindContext (variants st) (fst $ resource r st)++response :: String -> Suite -> LLIDL+response r st = bindContext (variants st) (snd $ resource r st)+++type Resolver = VarContext -> LLSD -> Fidelity++resolve :: LLIDL -> Resolver++resolve UndefLLIDL = resolveTo Matched+resolve BoolLLIDL = resolveType (undefined :: Bool)+resolve IntLLIDL = resolveType (undefined :: Int)+resolve RealLLIDL = resolveType (undefined :: Double)+resolve StringLLIDL = resolveType (undefined :: String)+resolve DateLLIDL = resolveType (undefined :: Time.UTCTime)+resolve UriLLIDL = resolveType (undefined :: URI.URI)+resolve UuidLLIDL = resolveType (undefined :: UUID.UUID)+resolve BinaryLLIDL = resolveType (undefined :: Byte.ByteString)++resolve (SelectNameLLIDL v) = resolveSelect v+resolve (SelectBoolLLIDL v) = resolveSelect v+resolve (SelectIntLLIDL v) = resolveSelect v++resolve (ArrayLLIDL repeating is) = resolveArray repeating is+resolve (MapLLIDL assocs) = resolveMap assocs+resolve (DictLLIDL i) = resolveDict i+resolve (VariantLLIDL v) = resolveVariant v++resolve UndefinedLLIDL = resolveTo Incompatible++resolve (BoundLLIDL c i) = \_ l -> resolve i c l+++resolveTo :: Fidelity -> Resolver+resolveTo f _ _ = f++resolveType :: (ConvertTo a) => a -> Resolver+resolveType t _ l = snd $ convertAs t+ where convertAs :: (ConvertTo a) => a -> Conversion a+ convertAs _ = conversionFromLLSD l+ +resolveSelect :: (Eq a, ConvertTo a) => a -> Resolver+resolveSelect v _ l = select (conversionFromLLSD l)+ where select c = if v == fst c then snd c else Incompatible++resolveArray :: Bool -> [LLIDL] -> Resolver+resolveArray repeating is = arrayMatch+ where arrayMatch _ (LUndef) = Defaulted+ arrayMatch c v@(LArray _) = resolveAll c is0 $ toList v+ arrayMatch _ _ = Incompatible++ is0 = if repeating then [] else is++ resolveAll c (j:js) (l:ls) = resolve j c l ~&~ resolveAll c js ls+ resolveAll c (j:js) [] = resolve j c undef ~&~ resolveAll c js []+ resolveAll c [] ls@(_:_) = if repeating+ then resolveAll c is ls+ else Additional+ resolveAll _ [] [] = Matched++resolveMap :: [(String, LLIDL)] -> Resolver+resolveMap assocs = mapMatch+ where mapMatch _ (LUndef) = Defaulted+ mapMatch c (LMap m) = resolveAll ~&~ hasAll+ where resolveAll = foldr (\a r -> resolveOne a ~&~ r) Matched assocs+ resolveOne (k, l) = maybe Defaulted (resolve l c) $ M.lookup k m+ hasAll = if M.keysSet m `S.isSubsetOf` idlkeys+ then Matched+ else Additional+ mapMatch _ _ = Incompatible+ idlkeys = S.fromList $ map fst assocs++resolveDict :: LLIDL -> Resolver+resolveDict i = dictMatch+ where dictMatch _ (LUndef) = Defaulted+ dictMatch c (LMap m) = M.fold (\l r -> resolve i c l ~&~ r) Matched m+ dictMatch _ _ = Incompatible++resolveVariant :: String -> Resolver+resolveVariant v = varMatch+ where varMatch c l = foldl' pRes Incompatible vars+ where pRes r i = resolve i c l ~|~ r+ vars = M.findWithDefault [] v c+ +++showAnyError :: Either ParseError a -> Either String a+showAnyError = either (Left . show) (Right)++parseValue :: String -> Either String LLIDL+parseValue = showAnyError . parse (between s eof value) ""++parseSuite :: String -> Either String Suite+parseSuite = showAnyError . parse (between s eof suite) ""++++value :: Parser LLIDL+value = simpleType <|> arrayType <|> mapType <|> selector <|> variant++simpleType :: Parser LLIDL+simpleType = typeSymbol "undef" UndefLLIDL+ <|> typeSymbol "string" StringLLIDL+ <|> typeSymbol "bool" BoolLLIDL+ <|> typeSymbol "int" IntLLIDL+ <|> typeSymbol "real" RealLLIDL+ <|> typeSymbol "date" DateLLIDL+ <|> typeSymbol "uri" UriLLIDL+ <|> typeSymbol "uuid" UuidLLIDL+ <|> typeSymbol "binary" BinaryLLIDL+ where typeSymbol t i = symbol t >> return i+++arrayType :: Parser LLIDL+arrayType =+ try (do { cymbol '['; is <- valueList; cymbol ']'; return $ ArrayLLIDL False is })+ <|> (do { cymbol '['; is <- valueList; symbol "..."; cymbol ']'; return $ ArrayLLIDL True is })++valueList :: Parser [LLIDL]+valueList = sepEndBy1 value (cymbol ',')+++mapType :: Parser LLIDL+mapType = try (simpleMapType) <|> try (dictMapType)++simpleMapType :: Parser LLIDL+simpleMapType = do+ cymbol '{'; is <- memberList; cymbol '}'+ let keys = map fst is+ dupes = keys \\ nub keys+ if null dupes+ then return $ MapLLIDL is+ else fail $ "duplicate map keys: " ++ intercalate ", " dupes++memberList :: Parser [(String, LLIDL)]+memberList = sepEndBy1 member (cymbol ',')++member :: Parser (String, LLIDL)+member = do { n <- name; cymbol ':'; v <- value; return (n, v) }++dictMapType :: Parser LLIDL+dictMapType = do+ cymbol '{'; cymbol '$'; cymbol ':'; i <- value; cymbol '}'+ return $ DictLLIDL i+++selector :: Parser LLIDL+selector =+ try (lexeme $ between (char '"') (char '"') name' >>= return . SelectNameLLIDL)+ <|> (symbol "true" >> return (SelectBoolLLIDL True))+ <|> (symbol "false" >> return (SelectBoolLLIDL False))+ <|> ((lexeme $ integer) >>= return . SelectIntLLIDL)+++++variant :: Parser LLIDL+variant = char '&' >> name >>= return . VariantLLIDL+++suite :: Parser Suite+suite = definitions >>= return . fromDefinitions++definitions :: Parser [Definition]+definitions = many ( variantDef <|> resourceDef )++variantDef :: Parser Definition+variantDef = return Variant `ap` between (char '&') (cymbol '=') name `ap` value++resourceDef :: Parser Definition+resourceDef = do+ res <- resName+ (req, resp) <- (postRes <|> getRes <|> getPutRes)+ return $ Resource res req resp+ ++resName :: Parser String+resName = symbol "%%" >> name++postRes :: Parser (LLIDL, LLIDL)+postRes = do+ req <- symbol "->" >> value+ resp <- symbol "<-" >> value+ return (req, resp)+ +getRes :: Parser (LLIDL, LLIDL)+getRes = do+ body <- symbol "<<" >> value+ return (UndefinedLLIDL, body)++getPutRes :: Parser (LLIDL, LLIDL)+getPutRes = do+ body <- (symbol "<>" <|> symbol "<x>") >> value+ return (body, body)++++-- These follow the pattern in Parsec.Token, but we redo it here because the+-- specifics of whitepsace in LLIDL don't match the assumptions in Parsec.Token.++symbol :: String -> Parser ()+symbol t = try (lexeme $ string t >> return ())++cymbol :: Char -> Parser ()+cymbol c = lexeme $ char c >> return ()++name :: Parser String+name = lexeme name'++lexeme :: Parser a -> Parser a+lexeme p = do { r <- p; s; return r }+++-- Non-lexmeme parsers++s :: Parser ()+s = skipMany (tab <|> newline <|> space <|> comment)+ -- unfortunate name, but that is what it is called in the Internet Draft++comment :: Parser Char+comment = char ';' >> (skipMany $ noneOf "\n") >> newline >> return ';'+ --FIXME: newline in spec is \n, \r, or \r\n+ --FIXME: returning Char is ugly just to make s easier++name' :: Parser String+name' = do { c <- nameStart; cs <- many nameContinue; return (c:cs) }+ where nameStart = idStart <|> char '_'+ nameContinue = idContinue <|> char '_' <|> char '/'+ idStart = oneOf ['A'..'Z'] <|> oneOf ['a'..'z']+ idContinue = idStart <|> oneOf ['0'..'9']++integer :: Parser Int+integer = many1 digit >>= return . read+++--+-- QuasiQuote Support+--++llidlSuite, llidlValue :: QuasiQuoter+llidlSuite = QuasiQuoter (qqToSuite $ qq definitions) failPat+llidlValue = QuasiQuoter (qq value) failPat++qq :: (Data t) => (Parser t) -> String -> TH.Q TH.Exp+qq pThing input = do+ loc <- TH.location+ let pos = newPos (TH.loc_filename loc)+ (fst (TH.loc_start loc))+ (snd (TH.loc_start loc))+ case parse (setPosition pos >> between s eof pThing) "" input of+ Left err -> fail $ show err+ Right e -> dataToExpQ (const Nothing) e++qqToSuite :: (String -> TH.Q TH.Exp) -> (String -> TH.Q TH.Exp)+qqToSuite f = \input -> do+ eDefs <- f input+ return $ TH.AppE (TH.VarE (TH.mkName "fromDefinitions")) eDefs++failPat :: String -> TH.Q TH.Pat+failPat _ = fail "can't pattern match llidl"
+ Network/Format/LLSD/Pretty.hs view
@@ -0,0 +1,80 @@+-- |+-- Module : Network.Format.LLSD.Pretty+-- Copyright : (c) Linden Lab 2009+-- License : MIT+-- Maintainer : bos@lindenlab.com+-- Stability : provisional+-- Portability : portable+--+-- Pretty printing of LLSD data++module Network.Format.LLSD.Pretty (+ prettyLLSD,+ showsPrecLLSD,+ )+ where++import qualified Data.UUID as UUID+import Network.Format.LLSD.Internal+import qualified Network.URI as URI+import Text.PrettyPrint.HughesPJ++import qualified Data.Map as M+++instance Show LLSD where+ --show = render . prettyLLSD+ showsPrec = showsPrecLLSD++++-- | Layout an LLSD as a PrettyPrint 'Doc' value+prettyLLSD :: LLSD -> Doc+prettyLLSD v = text "LLSD" <+> prettyValue v++prettyValue :: LLSD -> Doc+prettyValue LUndef = text "undef"+prettyValue (LBool True) = text "true"+prettyValue (LBool False) = text "false"+prettyValue (LInt v) = int v+prettyValue (LReal v) = double v+prettyValue (LString v) = doubleQuotes . text $ v+prettyValue (LUUID v) = text $ UUID.toString v+prettyValue v@(LDate _) = text $ fromLLSD v+prettyValue (LURI v) = text $ URI.uriToString id v ""+prettyValue (LBinary _) = text "<binary>" -- FIXME: do something pretty+prettyValue (LArray vs) =+ brackets $ cat $ punctuate (text ", ")+ (map (nest 4 . prettyValue) (expandLLSDArray vs))+prettyValue (LMap vmap) =+ braces $ cat $ punctuate (text ", ")+ (map (nest 4 . prettyAssoc) (M.assocs vmap))+ where+ prettyAssoc (k,v) = text k <> colon <+> prettyValue v++++showsPrecLLSD :: Int -> LLSD -> ShowS+showsPrecLLSD d v = showParen (d > appPrec) $ showString "LLSD " . showPrecValue v+ where appPrec = 10++showPrecValue :: LLSD -> ShowS+showPrecValue LUndef = showString "undef"+showPrecValue (LBool True) = showString "True"+showPrecValue (LBool False) = showString "False"+showPrecValue (LInt v) = shows v -- this won't read back in, needs ::Int+showPrecValue (LReal v) = shows v -- this won't read back in, needs ::Double+showPrecValue (LString v) = showString v+showPrecValue (LUUID v) = shows v+showPrecValue (LDate v) = shows v+showPrecValue (LURI v) = shows v+showPrecValue (LBinary v) = shows v+showPrecValue (LArray vs) = buildShowList "[" ", " "]" $ showPrecArray (expandLLSDArray vs)+ where showPrecArray = map showPrecValue+showPrecValue (LMap vmap) = buildShowList "{" ", " "}" $ showPrecMap (M.assocs vmap)+ where showPrecMap = map (\(k, v) -> showString k . showString ": " . showPrecValue v)++buildShowList :: String -> String -> String -> [ShowS] -> ShowS+buildShowList pre mid post ss = showString pre . interpose ss . showString post+ where interpose [] = showChar ' '+ interpose ss' = foldr1 (\a b -> a . showString mid . b) ss'
+ Network/Format/LLSD/Test.hs view
@@ -0,0 +1,452 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-binds #-}++-- |+-- Module : Network.Format.LLSD.Test+-- Copyright : (c) Linden Lab 2009+-- License : MIT+-- Maintainer : bos@lindenlab.com+-- Stability : provisional+-- Portability : portable++module Network.Format.LLSD.Test (+ runTests,+ runChecks+ )+ where++import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as C+import qualified Data.ByteString.Lazy.UTF8 as U+import Data.Char (ord)+import Data.List (foldl')+import qualified Data.Map as Map+import Data.Maybe (fromJust)+import Data.Time+import qualified Data.UUID as UUID+import Network.Format.LLSD+import qualified Network.URI as URI+import System.IO (stderr)+import Test.HUnit+import Test.QuickCheck+++{-+ unit tests to write+ path access+ updating+ SData extension++ llsd+ size++ get 34 l+ get "foo" l++ set 34 thing l+ set "foo" thing l++ getPath ("abc" ./ "def") l+ setPath ("abc" ./ "def") v l+ -- test paths with strings and with numbers++ test parsing of with, at, ./ and .=++-}+++instance Arbitrary Char where+ arbitrary = choose ('\32', '\xcfff') -- FIXME: expand to all Unicode chars+ coarbitrary c = variant (ord c `rem` 4)+ -- boilerplate for using Char with Test.QuickCheck++--+-- Identity Conversion Tests+--++prop_toFromIdentity :: (Eq a, SData a) => a -> Bool+prop_toFromIdentity a = fromLLSD (toLLSD a) == a++prop_BoolToFromIdentity :: Bool -> Bool+prop_BoolToFromIdentity = prop_toFromIdentity++prop_IntToFromIdentity :: Int -> Bool+prop_IntToFromIdentity = prop_toFromIdentity++prop_DoubleToFromIdentity :: Double -> Bool+prop_DoubleToFromIdentity = prop_toFromIdentity++prop_StringToFromIdentity :: String -> Bool+prop_StringToFromIdentity = prop_toFromIdentity++nullUUID = fromJust $ UUID.fromString "00000000-0000-0000-0000-000000000000"+someUUID = fromJust $ UUID.fromString "14409e2f-5588-4c12-b719-ff33f614e3b7"++nullDate = UTCTime (fromGregorian 1970 01 01) (secondsToDiffTime 0)+someDate = UTCTime (fromGregorian 2003 06 23) (secondsToDiffTime $ 4*3600)++nullURI = URI.nullURI+someURI = fromJust $ URI.parseURI+ "http://slurl.com/secondlife/Ambleside/57/104/26"++nullBytes = L.empty+someBytes = L.pack [222, 173, 190, 239]++test_identity = "scalar type identities" ~: TestList [+ prop_toFromIdentity True ~? "true identity",+ prop_toFromIdentity False ~? "false identity",+ prop_toFromIdentity(42::Int) ~? "42 identity",+ prop_toFromIdentity(0::Int) ~? "zero identity",+ prop_toFromIdentity(-12345::Int) ~? "neg identity",+ prop_toFromIdentity(2000000000::Int) ~? "big identity",+ prop_toFromIdentity(3.14159265359::Double) ~? "pi identity",+ prop_toFromIdentity(6.7e256::Double) ~? "big float identity",+ prop_toFromIdentity "now is the time" ~? "string identity",+ prop_toFromIdentity nullUUID ~? "null uuid identity",+ prop_toFromIdentity someUUID ~? "some uuid identity",+ prop_toFromIdentity nullDate ~? "null date identity",+ prop_toFromIdentity someDate ~? "some date identity",+ prop_toFromIdentity nullURI ~? "null URI identity",+ prop_toFromIdentity someURI ~? "some URI identity",+ prop_toFromIdentity nullBytes ~? "null byte array",+ prop_toFromIdentity someBytes ~? "some byte array"+ ]++props_identity = [+ label "prop_BoolToFromIdentity" prop_BoolToFromIdentity,+ label "prop_IntToFromIdentity" prop_IntToFromIdentity,+ label "prop_DoubleToFromIdentity" prop_DoubleToFromIdentity,+ label "prop_StringToFromIdentity" prop_StringToFromIdentity+ ]++-- FIXME: test identity conversion of Maybe abs+-- FIXME: test identity conversion of lists+-- FIXME: test identity conversion of maps++++--+-- Conversion Tests+--++test_conversion :: (SData a, Show a) => a -> Bool -> Int -> Double -> String -> Test+test_conversion av eb ei ed es =+ show av ~: TestList $ map TestCase [+ fromLLSD al @?= eb,+ fromLLSD al @?= ei,+ not (fromLLSD al < ed || fromLLSD al > ed) @? "double compare",+ -- written this way to handle NaNs correctly+ fromLLSD al @?= es+ ]+ where al = toLLSD av++test_IntConversion :: Int -> Bool -> Int -> Double -> String -> Test+test_IntConversion = test_conversion++test_DoubleConversion :: Double -> Bool -> Int -> Double -> String -> Test+test_DoubleConversion = test_conversion++test_toFromString :: (SData a, Show a, Eq a) => a -> String -> Test+test_toFromString av es =+ show av ~: TestList $ map TestCase [+ fromLLSD (toLLSD av) @?= es,+ fromLLSD (toLLSD es) @?= av+ ]++test_conversions = "conversions" ~: TestList [+ test_conversion llsd False 0 0.0 "",+ test_conversion False False 0 0.0 "",+ test_conversion True True 1 1.0 "true",+ test_IntConversion 0 False 0 0.0 "0",+ test_IntConversion 1 True 1 1.0 "1",+ test_IntConversion (-33) True (-33) (-33.0) "-33",+ test_DoubleConversion 0.0 False 0 0.0 "0.0",+ -- differs from C, which gives just "0" for string conversion+ test_DoubleConversion 0.5 True 0 0.5 "0.5",+ test_DoubleConversion 0.9 True 1 0.9 "0.9",+ -- differs from C, which seems to use trunc for int conversion+ test_DoubleConversion (-3.9)+ True (-4) (-3.9) "-3.9",+ -- differs from C, which seems to use trunc for int conversion+ test_DoubleConversion (sqrt(-1))+ False 0 (sqrt(-1)) "NaN",+ -- differs from C, which gives "nan" for string conversion+ test_conversion "" False 0 0.0 "",+ test_conversion "0" True 0 0.0 "0",+ test_conversion "10" True 10 10.0 "10",+ test_conversion "-2.345" True (-2) (-2.345) "-2.345",+ test_conversion "apple" True 0 0.0 "apple",+ test_conversion "33bob" True 0 0.0 "33bob",+ test_conversion " " True 0 0.0 " ",+ test_conversion "\n" True 0 0.0 "\n",+ test_toFromString nullUUID "00000000-0000-0000-0000-000000000000",+ test_toFromString someUUID "14409e2f-5588-4c12-b719-ff33f614e3b7",+ test_toFromString nullDate "1970-01-01T00:00:00Z",+ test_toFromString someDate "2003-06-23T04:00:00Z",+ test_toFromString nullURI "",+ test_toFromString someURI+ "http://slurl.com/secondlife/Ambleside/57/104/26"+ ]+++compile_fromLLSD :: LLSD -> Bool+compile_fromLLSD v = b && (i /= 0) && (d /= 0.0) && (s /= "")+ where b :: Bool+ b = fromLLSD v+ i :: Int+ i = fromLLSD v+ d :: Double+ d = fromLLSD v+ s :: String+ s = fromLLSD v++compile_toLLSD :: Bool -> Int -> Double -> String -> LLSD+compile_toLLSD b i d s = toLLSD [vb, vi, vd, vs]+ where vb, vi, vd, vs :: LLSD+ vb = toLLSD b+ vi = toLLSD i+ vd = toLLSD d+ vs = toLLSD s+++prop_arrayHasIndex :: [Int] -> Bool+prop_arrayHasIndex is = all sameAsElem $ range is+ where ls = foldl' (\l i -> l `with` i .= "bob") undef is+ sameAsElem i = (hasIndex i ls) == (elem i is)+ range [] = [-1..1]+ range is' = [minimum is' - 1 .. maximum is' + 1]++prop_mapHasKey :: [String] -> Bool+prop_mapHasKey ks = all sameAsElem $ range ks+ where ls = foldl' (\l k -> l `with` k .= "bob") undef ks+ sameAsElem k = (hasKey k ls) == (elem k ks)+ range [] = ["a", "z"]+ range ks' = ks ++ map (++"x") ks' ++ map ("x"++) ks'+{-+prop_mapHasMaps :: [String] -> Bool+prop_mapHasMaps ks = all sameAsPrefix $ paths ks+ where ls = foldl' (\l k -> l `with` k .= "yo") undef ks+ sameAsPrefix p = (hasPath p ls) == (isPrefixOf p ks)+-}++props_has = [+ label "prop_arrayHas" prop_arrayHasIndex,+ label "prop_mapHas" prop_mapHasKey+ ]++--+-- XML Format Tests+--++test_xmlFormat :: (SData a, Show a) => a -> String -> Test+test_xmlFormat v xml = xml ~=? (U.toString . formatXML . toLLSD $ v)++test_xmlFormats = "XML formats" ~: TestList [+ test_xmlFormat undef "<llsd><undef/></llsd>",+ test_xmlFormat True "<llsd><boolean>true</boolean></llsd>",+ test_xmlFormat False "<llsd><boolean>false</boolean></llsd>",+ test_xmlFormat (3463::Int) "<llsd><integer>3463</integer></llsd>",+ test_xmlFormat "" "<llsd><string/></llsd>",+ test_xmlFormat "foobar" "<llsd><string>foobar</string></llsd>",+ test_xmlFormat (1.0::Double) "<llsd><real>1.0</real></llsd>",++ test_xmlFormat nullUUID+ "<llsd><uuid>00000000-0000-0000-0000-000000000000</uuid></llsd>",+ test_xmlFormat someUUID+ "<llsd><uuid>14409e2f-5588-4c12-b719-ff33f614e3b7</uuid></llsd>",+ test_xmlFormat nullDate+ "<llsd><date>1970-01-01T00:00:00Z</date></llsd>",+ test_xmlFormat someDate+ "<llsd><date>2003-06-23T04:00:00Z</date></llsd>",+ test_xmlFormat nullURI+ "<llsd><uri/></llsd>",+ test_xmlFormat someURI+ "<llsd><uri>http://slurl.com/secondlife/Ambleside/57/104/26</uri></llsd>",+ test_xmlFormat nullBytes+ "<llsd><binary encoding=\"base64\"/></llsd>",+ test_xmlFormat someBytes+ "<llsd><binary encoding=\"base64\">3q2+7w==</binary></llsd>",++ test_xmlFormat ([]::[Int]) "<llsd><array/></llsd>",+ test_xmlFormat [undef] "<llsd><array><undef/></array></llsd>",+ test_xmlFormat [undef, toLLSD (1::Int)]+ "<llsd><array><undef/><integer>1</integer></array></llsd>",+ test_xmlFormat (Map.empty :: Map.Map String Int)+ "<llsd><map/></llsd>",+ test_xmlFormat (Map.fromAscList [("foo", "bar")])+ "<llsd><map><key>foo</key><string>bar</string></map></llsd>",+ test_xmlFormat (Map.fromAscList [("foo", toLLSD "bar"), ("baz", undef)])+ "<llsd><map><key>foo</key><string>bar</string><key>baz</key><undef/></map></llsd>"+ ]++++--+-- Binary Format Tests+--++test_binaryFormat :: (SData a, Show a) => a -> String -> Test+test_binaryFormat v binstr = binstr ~=? (C.unpack . formatBinary . toLLSD $ v)++test_binaryFormats = "Binary formats" ~: TestList [+ test_binaryFormat undef "!",+ test_binaryFormat True "1",+ test_binaryFormat False "0",+ test_binaryFormat (3463::Int) "i\x00\x00\x0d\x87",+ test_binaryFormat "" "s\x00\x00\x00\x00",+ test_binaryFormat "foobar" "s\x00\x00\x00\x06\&foobar",++ test_binaryFormat nullUUID+ "u\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00",+ test_binaryFormat someUUID+ "u\x14\x40\x9e\x2f\x55\x88\x4c\x12\xb7\x19\xff\x33\xf6\x14\xe3\xb7",+ test_binaryFormat nullURI+ "l\x00\x00\x00\x00",+ test_binaryFormat someURI+ "l\x00\x00\x00\x2fhttp://slurl.com/secondlife/Ambleside/57/104/26",++ test_binaryFormat (1.0::Double) "r\x3f\xf0\x00\x00\x00\x00\x00\x00",+ test_binaryFormat (3.14159::Double) "r\x40\x09\x21\xF9\xF0\x1B\x86\x6E",++ test_binaryFormat nullDate "d\x00\x00\x00\x00\x00\x00\x00\x00",+ test_binaryFormat someDate "d\x41\xCF\x7B\x3D\xA0\x00\x00\x00",++ test_binaryFormat nullBytes+ "b\x00\x00\x00\x00",+ test_binaryFormat someBytes+ "b\x00\x00\x00\x04\222\173\190\239",++ test_binaryFormat ([]::[Int]) "[\0\0\0\0]",+ test_binaryFormat [undef] "[\0\0\0\1!]",+ test_binaryFormat [undef, toLLSD (1::Int)]+ "[\0\0\0\2!i\0\0\0\1]",+ test_binaryFormat (Map.empty :: Map.Map String Int)+ "{\0\0\0\0}",+ test_binaryFormat (Map.fromAscList [("foo", "bar")])+ "{\0\0\0\1k\0\0\0\3foos\0\0\0\3bar}",+ test_binaryFormat (Map.fromAscList [("foo", toLLSD "bar"), ("baz", undef)])+ "{\0\0\0\2k\0\0\0\3foos\0\0\0\3bark\0\0\0\3baz!}"+ ]+++--+-- Round Trip Tests+--++prop_roundtrip :: (SData a, Eq a) => (LLSD -> Either String LLSD) -> a -> Bool+prop_roundtrip rt v =+ case rt lv of+ (Left _) -> False+ (Right lw) -> v == fromLLSD lw+ where lv = toLLSD v+ -- FIXME: should be testing the structural equality of the LLSDs++prop_mapRoundtrip :: (SData a, Eq a) => (LLSD -> Either String LLSD) -> [(String, a)] -> Bool+prop_mapRoundtrip rt v = prop_roundtrip rt (Map.fromAscList v)++test_roundtrip s rt = s ++ " Roundtrips" ~: TestList [+ --prop_roundtrip rt undef ~? "undef",+ prop_roundtrip rt True ~? "true",+ prop_roundtrip rt False ~? "false",+ prop_roundtrip rt (1::Int) ~? "one",+ prop_roundtrip rt (0::Int) ~? "zero",+ prop_roundtrip rt (-1::Int) ~? "negative one",+ prop_roundtrip rt (1234.5::Double) ~? "float",+ prop_roundtrip rt (0.0::Double) ~? "float zero",+ prop_roundtrip rt (-1234.5::Double) ~? "negative float",+ prop_roundtrip rt "" ~? "empty string",+ prop_roundtrip rt "some string" ~? "some string",+ prop_roundtrip rt nullUUID ~? "null UUID",+ prop_roundtrip rt someUUID ~? "some UUID",+ prop_roundtrip rt nullDate ~? "null date",+ prop_roundtrip rt someDate ~? "some date",+ prop_roundtrip rt nullURI ~? "null URI",+ prop_roundtrip rt someURI ~? "some URI",+ prop_roundtrip rt nullBytes ~? "null byte array",+ prop_roundtrip rt someBytes ~? "some byte array"+ ]++props_roundtrip s rt = [+ label (s ++ "prop_BoolToFromIdentity") (prop_roundtrip rt :: Bool -> Bool),+ label (s ++ "prop_IntToFromIdentity") (prop_roundtrip rt :: Int -> Bool),+ label (s ++ "prop_DoubleToFromIdentity") (prop_roundtrip rt :: Double -> Bool),+ label (s ++ "prop_StringToFromIdentity") (prop_roundtrip rt :: String -> Bool),+ label (s ++ "prop_ArrayToFromIdentity") (prop_roundtrip rt :: [String] -> Bool),+ label (s ++ "prop_MapToFromIdentity") (prop_mapRoundtrip rt :: [(String, Int)] -> Bool)+ ]++test_xmlRoundtrip = test_roundtrip "XML" (parseXML . toByteString . formatXML)+props_xmlRoundtrip = props_roundtrip "XML" (parseXML . toByteString . formatXML)+test_binaryRoundtrip = test_roundtrip "Binary" (parseBinary . toByteString . formatBinary)+props_binaryRoundtrip = props_roundtrip "Binary" (parseBinary . toByteString . formatBinary)++toByteString :: L.ByteString -> B.ByteString+toByteString = B.concat . L.toChunks+++addExample :: LLSD -> LLSD+addExample origLLSD =+ origLLSD `with` "p1" ./ "name" .= "Bob"+ `with` "p1" ./ "age" .= (45::Int)+ `with` "p2" ./ "name" .= "Amy"+ `with` "p2" ./ "age" .= (36::Int)++fetchAge :: String -> LLSD -> Int+fetchAge ident d = d `at` ident ./ "age"++fetchName :: String -> LLSD -> String+fetchName ident d = d `at` ident ./ "name"++setSize :: String -> String -> LLSD -> LLSD+setSize ident s d = d `with` ident ./ "size" .= s++data Address = Address String String String Int+ deriving (Eq, Show)++instance SData Address where+ toLLSD (Address street city state zipcode) =+ llsd `with` "street" .= street+ `with` "city" .= city+ `with` "state" .= state+ `with` "zip" .= zipcode+ fromLLSD v =+ Address (v `at` "street")+ (v `at` "city")+ (v `at` "state")+ (v `at` "zip")++setAddress :: String -> Address -> LLSD -> LLSD+setAddress ident add d = d `with` ident ./ "address" .= add++data Part = Part { name:: String, weight:: Double, location:: (Int, Int) }+instance SData Part where+ toLLSD p =+ llsd `with` "name" .= name p+ `with` "weight" .= weight p+ `with` "location" .= [fst $ location p, snd $ location p]+ fromLLSD v =+ Part { name = v `at` "name",+ weight = v `at` "weight",+ location = (v `at` "location" ./ (0::Int),+ v `at` "location" ./ (1::Int)) }+{-+oneAndTwo :: LLSD -> (Int, Int)+oneAndTwo v = (v `at` "foo" ./ 0, v `at` "foo" ./ 1)+-}++++runTests = runTestText (putTextToHandle stderr False) (TestList [+ test_identity,+ test_conversions,+ test_xmlFormats,+ test_xmlRoundtrip,+ test_binaryFormats,+ test_binaryRoundtrip+ ])+runChecks = mapM_ quickCheck $ concat [+ props_identity,+ props_has,+ props_xmlRoundtrip,+ props_binaryRoundtrip+ ]
+ Network/Format/LLSD/TestIDL.hs view
@@ -0,0 +1,816 @@+{-# LANGUAGE QuasiQuotes #-}+{-# OPTIONS_GHC -fno-warn-missing-signatures -fno-warn-unused-binds #-}++-- |+-- Module : Network.Format.LLSD.TestIDL+-- Copyright : (c) Linden Lab 2009+-- License : MIT+-- Maintainer : bos@lindenlab.com+-- Stability : provisional+-- Portability : portable++module Network.Format.LLSD.TestIDL (+ runTests,+ runChecks+ )+ where++import qualified Data.ByteString.Lazy as L+import qualified Data.Map as M+import Data.Maybe+import Data.Time+import qualified Data.UUID as UUID+import Network.Format.LLSD+import Network.Format.LLSD.LLIDL+import qualified Network.URI as URI+import Test.HUnit+import Test.QuickCheck+import System.IO (stderr)+++nullUUID, someUUID :: UUID.UUID+nullUUID = fromJust $ UUID.fromString "00000000-0000-0000-0000-000000000000"+someUUID = fromJust $ UUID.fromString "14409e2f-5588-4c12-b719-ff33f614e3b7"++nullDate, someDate :: UTCTime+nullDate = UTCTime (fromGregorian 1970 01 01) (secondsToDiffTime 0)+someDate = UTCTime (fromGregorian 2003 06 23) (secondsToDiffTime $ 4*3600)++nullURI, someURI :: URI.URI+nullURI = URI.nullURI+someURI = fromJust $ URI.parseURI+ "http://slurl.com/secondlife/Ambleside/57/104/26"++nullBinary, someBinary :: L.ByteString+nullBinary = L.empty+someBinary = L.pack [222, 173, 190, 239]++ls :: String -> LLSD; ls = toLLSD+li :: Int -> LLSD; li = toLLSD+ld :: Double -> LLSD; ld = toLLSD+lu :: String -> LLSD; lu = toLLSD . (fromLLSD :: LLSD -> URI.URI) . toLLSD++notMatch :: LLIDL -> LLSD -> Bool+notMatch i l = not $ match i l :: Bool++++testIDLCases :: String -> [LLIDL -> Test] -> Test+testIDLCases itext its = itext ~:+ case parseValue itext of+ (Left err) -> TestCase $ assertFailure ("parse error: " ++ err)+ (Right i) -> TestList $ map ($i) its++should :: (SData a, Show a) => (LLIDL -> LLSD -> Bool) -> a -> LLIDL -> Test+should f a i = show a ~: assertBool "" (f i (toLLSD a))+++++test_simple :: Test+test_simple = "simple" ~: TestList [+ -- This class aggregates all the parse and match tests for simple types++ testIDLCases "undef" [+ should match undef,+ should match True,+ should match False,+ should match (0 :: Int),+ should match (1 :: Int),+ should match (3 :: Int),+ should match (0.0 :: Double),+ should match (1.0 :: Double),+ should match (3.14 :: Double),+ should match "",+ should match "True",+ should match "False",+ should match someDate,+ should match someUUID,+ should match someURI,+ should match someBinary+ ],++ testIDLCases "bool" [+ should hasDefaulted undef,+ should match True,+ should match False,+ should match (0 :: Int),+ should match (1 :: Int),+ should incompatible (3 :: Int),+ should match (0.0 :: Double),+ should match (1.0 :: Double),+ should incompatible (3.14 :: Double),+ should match "",+ should match "true",+ should incompatible "false",+ should incompatible someDate,+ should incompatible someUUID,+ should incompatible someURI,+ should incompatible someBinary+ ],++ testIDLCases "int" [+ should hasDefaulted undef,+ should match True,+ should match False,+ should match (0 :: Int),+ should match (1 :: Int),+ should match (0.0 :: Double),+ should match (10.0 :: Double),+ should incompatible (3.14 :: Double),+ should incompatible (6.02e23 :: Double),+ should hasDefaulted "",+ should match "0",+ should match "1",+ should match "0.0",+ should match "10.0",+ should incompatible "3.14",+ should incompatible "6.02e23",+ should incompatible "blob",+ should incompatible someDate,+ should incompatible someUUID,+ should incompatible someURI,+ should incompatible someBinary+ ],++ testIDLCases "real" [+ should hasDefaulted undef,+ should match True,+ should match False,+ should match (0 :: Int),+ should match (1 :: Int),+ should match (0.0 :: Double),+ should match (10.0 :: Double),+ should match (3.14 :: Double),+ should match (6.02e23 :: Double),+ should hasDefaulted "",+ should match "0",+ should match "1",+ should match "0.0",+ should match "10.0",+ should match "3.14",+ should match "6.02e23",+ should incompatible "blob",+ should incompatible someDate,+ should incompatible someUUID,+ should incompatible someURI,+ should incompatible someBinary+ ],++ testIDLCases "string" [+ should hasDefaulted undef,+ should match True,+ should match False,+ should match (3 :: Int),+ should match (3.14 :: Double),+ should match "",+ should match "bob",+ should match someDate,+ should match someUUID,+ should match someURI,+ should incompatible someBinary+ ],++ testIDLCases "date" [+ should hasDefaulted undef,+ should incompatible True,+ should incompatible (3 :: Int),+ should incompatible (3.14 :: Double),+ should hasDefaulted "",+ should match "2009-02-06T22:17:38Z",+ should match "2009-02-06T22:17:38.0025Z",+ should incompatible "bob",+ should match someDate,+ should incompatible someUUID,+ should incompatible someURI,+ should incompatible someBinary+ ],++ testIDLCases "uuid" [+ should hasDefaulted undef,+ should incompatible True,+ should incompatible (3 :: Int),+ should incompatible (3.14 :: Double),+ should hasDefaulted "",+ should match "6cb93268-5148-423f-8618-eaa0884f5b6c",+ should incompatible "bob",+ should incompatible someDate,+ should match someUUID,+ should incompatible someURI,+ should incompatible someBinary+ ],++ testIDLCases "uri" [+ should hasDefaulted undef,+ should incompatible True,+ should incompatible (3 :: Int),+ should incompatible (3.14 :: Double),+ should hasDefaulted "",+ should match "http://example.com/",+ should incompatible someDate,+ should incompatible someUUID,+ should match someURI,+ should incompatible someBinary+ ],++ testIDLCases "binary" [+ should hasDefaulted undef,+ should incompatible True,+ should incompatible (3 :: Int),+ should incompatible (3.14 :: Double),+ should incompatible "bob",+ should incompatible someDate,+ should incompatible someUUID,+ should incompatible someURI,+ should match someBinary+ ]+ ]++prop_IntMatchesDoubleIfIntegral :: Int -> Bool+prop_IntMatchesDoubleIfIntegral v = either (const False) (\i -> match i l) p+ where p = parseValue "int"+ l = toLLSD (fromIntegral v :: Double)++props_simple = [+ label "prop_IntMatchesDoubleIfIntegral" prop_IntMatchesDoubleIfIntegral+ ]++test_selector :: Test+test_selector = "selector" ~: TestList [+ -- This class aggregates all the test cases for atomic type selectors.++ testIDLCases "true" [+ should incompatible undef,+ should match True,+ should incompatible False,+ should incompatible (0 :: Int),+ should match (1 :: Int),+ should incompatible (3 :: Int),+ should incompatible (0.0 :: Double),+ should match (1.0 :: Double),+ should incompatible (3.14 :: Double),+ should incompatible "",+ should match "true",+ should incompatible "false",+ should incompatible someDate,+ should incompatible someUUID,+ should incompatible someURI,+ should incompatible someBinary+ ],++ testIDLCases "false" [+ should hasDefaulted undef,+ should incompatible True,+ should match False,+ should match (0 :: Int),+ should incompatible (1 :: Int),+ should incompatible (3 :: Int),+ should match (0.0 :: Double),+ should incompatible (1.0 :: Double),+ should incompatible (3.14 :: Double),+ should match "",+ should incompatible "true",+ should incompatible "false",+ should incompatible someDate,+ should incompatible someUUID,+ should incompatible someURI,+ should incompatible someBinary+ ],++ testIDLCases "1983" [+ should incompatible undef,+ should incompatible True,+ should incompatible False,+ should incompatible (0 :: Int),+ should incompatible (3 :: Int),+ should match (1983 :: Int),+ should incompatible (0.0 :: Double),+ should match (1983.0 :: Double),+ should incompatible (1983.2 :: Double),+ should incompatible "",+ should match "1983",+ should incompatible someDate,+ should incompatible someUUID,+ should incompatible someURI,+ should incompatible someBinary+ ],++ testIDLCases "0" [+ should hasDefaulted undef,+ should incompatible True,+ should match False,+ should match (0 :: Int),+ should incompatible (3 :: Int),+ should match (0.0 :: Double),+ should incompatible (16.0 :: Double),+ should hasDefaulted "",+ should match "0",+ should incompatible someDate,+ should incompatible someUUID,+ should incompatible someURI,+ should incompatible someBinary+ ],++ testIDLCases "\"secondLife\"" [+ should incompatible undef,+ should incompatible True,+ should incompatible False,+ should incompatible (0 :: Int),+ should incompatible (3 :: Int),+ should incompatible (0.0 :: Double),+ should incompatible (16.0 :: Double),+ should incompatible "",+ should match "secondLife",+ should incompatible "1983",+ should incompatible someDate,+ should incompatible someUUID,+ should incompatible someURI,+ should incompatible someBinary+ ]+{-+ testIDLCases "\"\"" [+ -- currently the draft doesn"t support this test+ should match undef,+ should incompatible True,+ should incompatible False,+ should incompatible (0 :: Int),+ should incompatible (3 :: Int),+ should incompatible (0.0 :: Double),+ should incompatible (16.0 :: Double),+ should match "",+ should incompatible "bob",+ should incompatible someDate,+ should incompatible someUUID,+ should incompatible someURI,+ should incompatible someBinary+ ]+-}+ ]++++test_array :: Test+test_array = "array" ~: TestList [++ testIDLCases "[real, real, real]" [+ -- simple types+ should incompatible (123 :: Int),+ should incompatible (3.1415 :: Double),+ should incompatible someUUID,++ should notMatch ([] :: [Double]),++ -- 1 element array+ should notMatch [ld 1.23],++ -- 2 elements array+ should notMatch [ld 1.23, ld 789.0],++ -- 4 elements array ( > 3)+ should notMatch [ld 1.23, ld 2.3, ld 4.56, ld 5.67],++ -- 3 elements with incorrect value type+ should incompatible [ld 1.23, ld 3.3, ls "string"],++ -- 3 elements with correct value type+ should match [ld 1.23, ld 3.3, ld 2.3434]+ ],++ testIDLCases "[int, string]" [+ -- simple types+ should incompatible (123 :: Int),+ should incompatible (3.1415 :: Double),+ should incompatible "string",+ should incompatible someUUID,++ -- empty array+ should notMatch ([] :: [LLSD]),++ should notMatch [li 123],+ should incompatible [ls "str1"],+ should notMatch [li 123, ls "str1", ls "str2"],+ should incompatible [ls "str1", li 123, li 345],++ should match [li 123, ls "str1"],+ should match [li 123, ld 1.2323],+ should match [li 123, li 456],+ should incompatible [ld 9.999, ls "str1"]+ ],+++ testIDLCases "[uri,...]" [+ -- simple types+ should incompatible (123 :: Int),+ should incompatible (3.1415 :: Double),+ should incompatible "string",+ should incompatible someUUID,++ -- empty array+ should match ([] :: [LLSD]),++ -- 1 element array+ should match [lu "www.foo.com"],++ -- 2 elements array+ should match [lu "www.foo.com", lu "www.bar.com"],++ -- 3 elements array+ should match [lu "www.foo.com", lu "www.bar.com",+ lu "www.topcoder.com/tc/review?project_id=30012"],++ -- 1 element+ should incompatible [li 123],++ -- 2 elements+ should incompatible [lu "www.google.com", li 123]+ ],++ testIDLCases "[string, int,...]" [++ -- simple types+ should incompatible (123 :: Int),+ should incompatible (3.1415 :: Double),+ should incompatible "string",+ should incompatible someUUID,++ -- empty array+ should match ([] :: [LLSD]),++ should notMatch [ls "str"],+ should notMatch [li 12345],+ should notMatch [ls "str", li 123, ls "str2"],+ should incompatible [ls "foo", ls "bar"],++ should match [ls "foo", li 123],+ should match [ls "foo", li 123, ls "bar", li 345]+ ],++ testIDLCases "[int, int]" [++ should match [li 123, li 123],+ should notMatch [li 123, li 345, li 678],+ should hasAdditional [li 123, li 345, li 678],++ should valid [li 123, li 123],+ should valid [li 123, li 345, li 678]+ ]+ ]++test_map :: Test+test_map = "map" ~: TestList [++ let a0 = toLLSD ([] :: [String])+ m0 = toLLSD (M.empty :: M.Map String LLSD)+ m1 = llsd `with` "name" .= "ant"+ m2 = m1 `with` "phone" .= (429873232 :: Int)+ m3 = m2 `with` "cam" .= True+ in testIDLCases "{ name : string, phone: int }" [++ should incompatible (123 :: Int),+ should incompatible (3.1415 :: Double),+ should incompatible "string",+ should incompatible someUUID,++ should incompatible a0,+ should hasDefaulted m0,+ should hasDefaulted m1,+ should hasDefaulted $ llsd `with` "phone" .= (42312334 :: Int),+ should incompatible $ llsd `with` "phone" .= "error",+ should match m2,++ -- three entries map+ should notMatch $ m2 `with` "address" .= "xx",+ should hasAdditional m3+ ],+++ let a0 = toLLSD ([] :: [String])+ m0 = toLLSD (M.empty :: M.Map String LLSD)+ m1 = llsd `with` "id1" .= (1234 :: Int)+ m2 = m1 `with` "id2" .= (100 :: Int)+ m4 = m2 `with` "id3" .= (101 :: Int) `with` "id4" .= (102 :: Int)+ in testIDLCases "{ $: int }" [++ should incompatible (123 :: Int),+ should incompatible (3.1415 :: Double),+ should incompatible "string",+ should incompatible someUUID,++ should incompatible a0,++ -- empty map+ should match m0,++ -- one entry map+ should incompatible $ llsd `with` "name" .= "ant",+ should match $ m1,+ should incompatible $ llsd `with` "phone" .= "error",++ -- two entires map+ should match $ m2,+ should incompatible $ m1 `with` "phone" .= "error",+ should hasDefaulted $ llsd `with` "id1" .= undef `with` "id2" .= (100 :: Int),++ -- many entires map+ should match $ m4+ ],+++ let m1 = llsd `with` "name" .= "bob"+ m2 = m1 `with` "address" .= "NYC"+ in testIDLCases "{name : string}" [+ should match m1,+ should notMatch m2,+ should hasAdditional m2+ ],++ let m1 = llsd `with` "name" .= "bob"+ m2 = m1 `with` "address" .= "NYC"+ m3 = m2 `with` "phone" .= (123 :: Int)+ in testIDLCases "{name : string, phone : int}" [+ should valid m1,+ should valid m2,+ should valid m3+ ]+ ]+++shouldParseValue :: String -> Test+shouldParseValue itext = itext ~: assertBool ("should've parsed: " ++ e) p+ where parse = parseValue itext+ e = either id (const "") parse+ p = either (const False) (const True) parse++shouldNotParseValue :: String -> Test+shouldNotParseValue itext = itext ~: assertBool "shouldn't've parsed" np+ where parse = parseValue itext+ np = either (const True) (const False) parse+++test_parseValue :: Test+test_parseValue = "parse value" ~: TestList [+ shouldParseValue "undef",+ shouldParseValue "bool",+ shouldParseValue "int",+ shouldParseValue "real",+ shouldParseValue "string",+ shouldParseValue "uuid",+ shouldParseValue "date",+ shouldParseValue "uri",+ shouldParseValue "binary",+ + shouldNotParseValue "blob",+ shouldNotParseValue "Bool",+ shouldNotParseValue "BOOL",+ shouldNotParseValue "--",+ shouldNotParseValue "*",+ shouldNotParseValue "_",++ shouldParseValue "true",+ shouldParseValue "false",+ shouldParseValue "0",+ shouldParseValue "1",+ shouldParseValue "42",+ shouldParseValue "1000000",+ shouldParseValue "\"red\"",+ shouldParseValue "\"blue\"",+ shouldParseValue "\"a/b/c_d\"",+ + shouldNotParseValue "3.14159",+ shouldNotParseValue "-10",+ shouldNotParseValue "2x2",+ shouldNotParseValue "0x3f",+ shouldNotParseValue "\"\"",+ shouldNotParseValue "\"a-b\"",+ shouldNotParseValue "\"3\"",+ shouldNotParseValue "\"~boo~\"",+ shouldNotParseValue "\"feh",+{- + for w in ["[ real]", "[\treal]", "[ real]", "[\t\treal]"]:+ self.good_parse_value(w)+ for nl in ["\n", "\r\n", "\r", "\n\n"]:+ w = ("[%s\tint,%s\tbool, ;comment and stuff!!%s\tstring%s]"+ % (nl, nl, nl, nl,+ self.good_parse_value(w)+-}++ shouldNotParseValue "",+ shouldNotParseValue " ",+ shouldParseValue " int",+ shouldParseValue "int ",+ -- NOTE: Differs from Python implementation.+ -- The Haskell implementation allows leading and trailing whitespace++ shouldParseValue "[int,bool]",+ shouldParseValue "[ int,bool]",+ shouldParseValue "[int ,bool]",+ shouldParseValue "[int, bool]",+ shouldParseValue "[int,bool ]",+ + shouldParseValue "[int,...]",+ shouldParseValue "[ int,...]",+ shouldParseValue "[int ,...]",+ shouldParseValue "[int, ...]",+ shouldParseValue "[int,... ]",+ + shouldParseValue "[string, int, bool, real...]",+ shouldParseValue "[int, date, uuid]",+ shouldParseValue "{name1 : string, name2 : real, name3 : date, name4 : uuid}",+ shouldParseValue "{$ : int}",++ shouldNotParseValue "foo",+ shouldNotParseValue "bar",+ shouldNotParseValue "[]",+ shouldNotParseValue "{}",+ shouldNotParseValue "[int, real, date",+ shouldNotParseValue "{name : string, phone : int",+ shouldNotParseValue "{name:string, name:int}",+ shouldNotParseValue "{name:string,phone:}",+ shouldNotParseValue "{name:string, :int}",+ shouldNotParseValue "{name:string phone,int}",+ shouldNotParseValue "[int, real, invalid]",+ shouldNotParseValue "{name: string, id:invalid}",+ shouldNotParseValue "[...]",+ shouldNotParseValue "{alphone-omega:real}",+ shouldNotParseValue "{$}",+ shouldNotParseValue "{$:}"+ ]++++++testSuiteCases :: String -> [Suite -> Test] -> Test+testSuiteCases itext its = (take 20 itext ++ "...") ~:+ case parseSuite itext of+ (Left err) -> TestCase $ assertFailure ("parse error: " ++ err)+ (Right i) -> TestList $ map ($i) its++suiteShould :: (SData a, Show a) =>+ (LLIDL -> LLSD -> Bool) ->+ (String -> Suite -> LLIDL) -> String ->+ a -> Suite -> Test+suiteShould f r t a s =+ (t ++ ": " ++ show a) ~: assertBool "" (f (r t s) (toLLSD a))++test_parseSuite :: Test+test_parseSuite = "parse suite" ~: TestList [+ testSuiteCases "\+ \;test suite\n\+ \%% agent/name\n\+ \-> { agent_id: uuid }\n\+ \<- { first: string, last: string }\n\+ \\n\+ \%% region/hub\n\+ \-> { region_id: uuid }\n\+ \<- { loc: [ real, real, real ] }\n\+ \\n\+ \%% event_record\n\+ \-> { log: string, priority: int }\n\+ \<- undef\n\+ \\n\+ \%% motd\n\+ \-> undef\n\+ \<- { message: string }\n"+ [+ suiteShould match request "agent/name" + $ llsd `with` "agent_id" .= someUUID,+ suiteShould match response "agent/name"+ $ llsd `with` "first" .= "Amy"+ `with` "last" .= "Ant",++ suiteShould match request "region/hub" + $ llsd `with` "region_id" .= (UUID.toString someUUID),+ suiteShould match response "region/hub"+ $ llsd `with` "loc" .= ([128,128,24]::[Int]),++ suiteShould valid request "event_record" + $ llsd `with` "log" .= "Beep-Bepp-Beep",+ suiteShould match response "event_record" (12345::Int),++ suiteShould match request "motd" "please",+ suiteShould valid response "motd"+ $ llsd `with` "message" .= "To infinity, and beyond!"+ `with` "author" .= ["Buzz", "Lightyear"]+ ],+ + let p = ([ 128.0, 128.0, 26.0 ] :: [Double])+ in testSuiteCases "\+ \;variant suite\n\+ \%% object/info\n\+ \-> undef\n\+ \<- { name: string, pos: [ real, real, real ], geom: &geometry }\n\+ \\n\+ \&geometry = { type: \"sphere\", radius: real }\n\+ \&geometry = { type: \"cube\", side: real }\n\+ \&geometry = { type: \"prisim\", faces: int, twist: real }\n"+ [+ suiteShould match response "object/info"+ $ llsd `with` "name" .= "ball"+ `with` "pos" .= p+ `with` "geom" ./ "type" .= "sphere"+ `with` "geom" ./ "radius" .= (2.2::Double),++ suiteShould match response "object/info"+ $ llsd `with` "name" .= "box"+ `with` "pos" .= p+ `with` "geom" ./ "type" .= "cube"+ `with` "geom" ./ "side" .= (2.2::Double),+ + suiteShould match response "object/info"+ $ llsd `with` "name" .= "lith"+ `with` "pos" .= p+ `with` "geom" ./ "type" .= "prisim"+ `with` "geom" ./ "faces" .= (3::Int)+ `with` "geom" ./ "twist" .= (2.2::Double),+ + suiteShould incompatible response "object/info"+ $ llsd `with` "name" .= "blob"+ `with` "pos" .= p+ `with` "geom" ./ "type" .= "mesh"+ `with` "geom" ./ "verticies" .= ([1,2,3,4]::[Int]) + ],+ + let iv = 42::Int+ sv = "Amy"+ idl = [$llidlSuite|+ %% api/get+ << int+ + %% api/getput+ <> int+ + %% api/getputdel+ <x> int+ |]+ in "api/get..." ~: TestList $ map ($idl)+ [+ suiteShould incompatible request "api/get" iv,+ suiteShould incompatible request "api/get" sv,+ suiteShould match response "api/get" iv,+ suiteShould incompatible response "api/get" sv,++ suiteShould match request "api/getput" iv,+ suiteShould incompatible request "api/getput" sv,+ suiteShould match response "api/getput" iv,+ suiteShould incompatible response "api/getput" sv,++ suiteShould match request "api/getputdel" iv,+ suiteShould incompatible request "api/getputdel" sv,+ suiteShould match response "api/getputdel" iv,+ suiteShould incompatible response "api/getputdel" sv+ ]+ ]+++quotedValue :: LLIDL+quotedValue = [$llidlValue|{ name : string, phone: int }|]+ +quotedSuite :: Suite+quotedSuite = [$llidlSuite|+;test suite+%% agent/name+-> { agent_id: uuid }+<- { first: string, last: string }++%% region/hub+-> { region_id: uuid }+<- { loc: [ real, real, real ] }++%% event_record+-> { log: string, priority: int }+<- undef++%% motd+-> undef+<- { message: string }+ |]+ +test_quote :: Test+test_quote = "quote" ~: TestList [+ should incompatible "string" quotedValue,+ should match (llsd `with` "name" .= "ant"+ `with` "phone" .= (429873232 :: Int)) quotedValue,+ suiteShould match response "agent/name"+ (llsd `with` "first" .= "Amy" `with` "last" .= "Ant")+ quotedSuite,+ suiteShould valid request "event_record" + (llsd `with` "log" .= "Beep-Bepp-Beep")+ quotedSuite+ ]+ + + +runTests = runTestText (putTextToHandle stderr False) (TestList [+ test_simple,+ test_selector,+ test_array,+ test_map,+ test_parseValue,+ test_parseSuite,+ test_quote+ ])++runChecks = mapM_ quickCheck $ concat [+ props_simple+ ]
+ Network/Format/LLSD/XML.hs view
@@ -0,0 +1,171 @@+-- |+-- Module : Network.Format.LLSD.XML+-- Copyright : (c) Linden Lab 2009+-- License : MIT+-- Maintainer : bos@lindenlab.com+-- Stability : provisional+-- Portability : portable++module Network.Format.LLSD.XML (+ parseXML,+ formatXML,+ )+ where++import Codec.Binary.Base64 as Base64+import Control.Monad.Error+import Data.Char (isSpace)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.List (foldl')+import qualified Data.Map as Map+-- import qualified Data.Text as T+import Data.Time (UTCTime)+import Data.UUID (UUID)+import Network.Format.LLSD.Internal+import Network.URI (URI)+import qualified Text.XML.Expat.Tree as XML+import qualified Text.XML.Expat.Format as XML++type XText = B.ByteString+toXText :: String -> XText+toXText = XML.gxFromString++fromXText :: XText -> String+fromXText = XML.gxToString+++type Node = XML.Node String XText+++parseXML :: B.ByteString -> Either String LLSD+parseXML s = do+ case XML.parseTree' Nothing s of+ Right (XML.Element "llsd" _ cs) -> convertLLSD cs+ Right (_) -> fail "root element not llsd"+ Left err -> (fail . show) err+++convertLLSD :: [Node] -> Either String LLSD+convertLLSD ns+ | exactlyOne filtns = convertValue (head filtns)+ | otherwise = fail "not just one element under llsd"+ where filtns = dropWhitespaceText ns+ exactlyOne [_] = True+ exactlyOne _ = False++convertValue :: Node -> Either String LLSD+convertValue (XML.Element name _ ns) =+ case name of+ "undef" -> convertUndef ns+ "boolean" -> textOnly ns >>= convertBool+ "integer" -> textOnly ns >>= convertInt+ "real" -> textOnly ns >>= convertReal+ "string" -> textOnly ns >>= convertString+ "uuid" -> textOnly ns >>= convertUUID+ "date" -> textOnly ns >>= convertDate+ "uri" -> textOnly ns >>= convertURI+ "binary" -> textOnly ns >>= convertBinary+ "map" -> convertMap ns+ "array" -> convertArray ns+ _ -> fail ("unknown value element: " ++ name)+convertValue (XML.Text text) = fail ("Unexpected text: " ++ fromXText text)++convertUndef :: [Node] -> Either String LLSD+convertUndef ns = case dropWhitespaceText ns of+ [] -> return undef+ _ -> fail "undef element isn't empty"+convertBool, convertInt, convertReal, convertString, convertUUID,+ convertDate, convertURI, convertBinary :: String -> Either String LLSD+convertBool t = fmap toLLSD $ textBoolean t+convertInt t = return $ toLLSD (fromLLSD (toLLSD t) :: Int)+convertReal t = return $ toLLSD (fromLLSD (toLLSD t) :: Double)+convertString t = return $ toLLSD t+convertUUID t = return $ toLLSD (fromLLSD (toLLSD t) :: UUID)+convertDate t = return $ toLLSD (fromLLSD (toLLSD t) :: UTCTime)+convertURI t = return $ toLLSD (fromLLSD (toLLSD t) :: URI)+convertBinary t =+ maybe (fail "invalid base64") (return . toLLSD . L.pack) $ Base64.decode t+ -- FIXME: should check that the encoding attribute is "base64"++convertArray :: [Node] -> Either String LLSD+convertArray = fmap toLLSD . mapM convertValue . dropWhitespaceText++convertMap :: [Node] -> Either String LLSD+convertMap ns = (toLLSD . Map.fromAscList) `fmap`+ (mapM convertAssoc =<< pairUp (dropWhitespaceText ns))+ where pairUp (a:b:rest) = do { ps <- pairUp rest; return $ (a,b) : ps }+ pairUp (_:[]) = fail "extra element in map"+ pairUp _ = return []++convertAssoc :: (Node, Node) -> Either String (String, LLSD)+convertAssoc (nk, nv) = (,) `fmap` convertKey nk `ap` convertValue nv++convertKey :: Node -> Either String String+convertKey (XML.Element "key" _ ns) = textOnly ns+convertKey (XML.Element name _ _) = fail ("expected key, found element: " ++ name)+convertKey (XML.Text text) = fail ("expected key, found text: " ++ fromXText text)+++dropWhitespaceText :: [Node] -> [Node]+dropWhitespaceText ns = filter isNotWhitespace ns+ where isNotWhitespace (XML.Element _ _ _) = True+ isNotWhitespace (XML.Text t) = not $ all isSpace $ fromXText t++textOnly :: [Node] -> Either String String+textOnly ns = (foldl' (\a b -> a ++ fromXText b) "") `fmap` textOnly' ns+ where textOnly' :: [Node] -> Either String [B.ByteString]+ textOnly' [] = return []+ textOnly' ((XML.Text t):ns') = textOnly' ns' >>= return . (t:)+ textOnly' ((XML.Element name _ _):_) =+ fail ("expected only text, found element: " ++ name)+++++++formatXML :: LLSD -> L.ByteString+formatXML v = XML.formatNode $ XML.Element "llsd" [] [asNode v]+ -- FIXME: ? using XML.formatTree outputs an XML header++asNode :: LLSD -> Node+asNode LUndef = XML.Element "undef" [] []+asNode (LBool b) = XML.Element "boolean" [] [XML.Text $ booleanText b]+asNode v@(LInt _) = XML.Element "integer" [] (textOf v)+asNode v@(LReal _) = XML.Element "real" [] (textOf v)+asNode v@(LString _) = XML.Element "string" [] (textOf v)+asNode v@(LUUID _) = XML.Element "uuid" [] (textOf v)+asNode v@(LDate _) = XML.Element "date" [] (textOf v)+asNode v@(LURI _) = XML.Element "uri" [] (textOf v)+asNode (LBinary b) = XML.Element "binary" [("encoding", toXText "base64")] $+ base64Text b+asNode (LArray vs) = XML.Element "array" [] $+ map asNode $ expandLLSDArray vs+asNode (LMap vs) = XML.Element "map" [] $+ concatMap asAssocNodes $ Map.assocs vs+ where asAssocNodes (k, v) = [XML.Element "key" [] [XML.Text $ toXText k], asNode v]++booleanText :: Bool -> B.ByteString+booleanText True = toXText "true"+booleanText False = toXText "false"+textBoolean :: String -> Either String Bool+textBoolean "true" = return True+textBoolean "false" = return False+textBoolean t = fail $ "invalid value for boolean: " ++ t+ -- FIXME: The spec implies that the value for the boolean node should be+ -- the string conversion, but that would make False be the empty string.+ -- The C++ implementation generates the word "false". Who's right?++textOf :: LLSD -> [Node]+textOf v = case t of+ "" -> [];+ _ -> [XML.Text $ toXText t]+ where t = fromLLSD v :: String++base64Text :: L.ByteString -> [Node]+base64Text b = if L.null b+ then []+ else [XML.Text $ toXText $ Base64.encode $ L.unpack b]++
+ Setup.lhs view
@@ -0,0 +1,6 @@+#!/usr/bin/runhaskell +> module Main where+> import Distribution.Simple+> main :: IO ()+> main = defaultMain+
+ TestData.hs view
@@ -0,0 +1,133 @@+{-# LANGUAGE TypeSynonymInstances #-}++-- |+-- Module : TestData - Part of the Test LLSD Utility+-- Copyright : (c) Linden Lab 2009+-- License : MIT+-- Maintainer : bos@lindenlab.com+-- Stability : provisional+-- Portability : portable++module TestData where+++import Network.Format.LLSD+import Control.Monad+import Data.Maybe+import qualified Data.Map as M+import Data.Time (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Data.UUID (UUID)+import Network.URI (URI, nullURI, parseURIReference)+import Test.QuickCheck+import System.Random+++data LogItem =+ LogIn { liAgent:: UUID, liTime:: UTCTime, liFirstTime:: Bool, liReferer:: URI }+ | LogOut { liAgent:: UUID, liTime:: UTCTime, liAttachments:: Attachments }+ | LogMisc { liAgent:: UUID, liTime:: UTCTime, liThis:: Int, liThat:: Double }+ | LogError+ deriving (Eq, Show)++instance SData LogItem where+ toLLSD (LogIn a t ft r) = llsd `with` "event" .= "login"+ `with` "agent" .= a+ `with` "time" .= t+ `with` "firsttime" .= ft+ `with` "referer" .= r+ toLLSD (LogOut a t ats) = llsd `with` "event" .= "logout"+ `with` "agent" .= a+ `with` "time" .= t+ `with` "attachments" .= ats+ toLLSD (LogMisc a t x y) = llsd `with` "event" .= "misc"+ `with` "agent" .= a+ `with` "time" .= t+ `with` "this" .= x+ `with` "that" .= y+ toLLSD LogError = undef++ fromLLSD l = case l `at` "event" of+ "login" -> LogIn (l `at` "agent") (l `at` "time")+ (l `at` "firsttime") (l `at` "referer")+ "logout" -> LogOut (l `at` "agent") (l `at` "time")+ (l `at` "attachments")+ "misc" -> LogMisc (l `at` "agent") (l `at` "time")+ (l `at` "this") (l `at` "that")+ _ -> LogError++type Attachments = [(String, UUID)]++instance SData Attachments where+ toLLSD = toLLSD . map entryToLLSD+ where entryToLLSD (s, u) = llsd `with` "point" .= s+ `with` "inv" .= u+ fromLLSD = map entryFromLLSD . fromLLSD+ where entryFromLLSD l = (l `at` "point", l `at` "inv")++++data LogStats = LogStats {+ lsCountIn, lsCountOut, lsCountMisc, lsCountError:: !Int,+ lsAttachmentsHistogram:: !(M.Map Int Int)+ }+ deriving (Eq, Show)++zeroStats :: LogStats+zeroStats = LogStats 0 0 0 0 M.empty++note :: LogItem -> LogStats -> LogStats+note (LogIn _ _ _ _) s = s { lsCountIn = lsCountIn s + 1 }+note (LogOut _ _ ats) s =+ s { lsCountOut = lsCountOut s + 1,+ lsAttachmentsHistogram =+ M.insertWith' (+) (length ats) 1 (lsAttachmentsHistogram s) }+ -- must use the strict version of insertWith++note (LogMisc _ _ _ _) s = s { lsCountMisc = lsCountMisc s + 1 }+note LogError s = s { lsCountError = lsCountError s + 1 }++++makeLogItems :: Int -> IO [LogItem]+makeLogItems n = getStdRandom makeEm+ where makeEm g0 = let (g1, g2) = split g0 in+ (generate n g1 (arbitraryItems n), g2)+++arbitraryItems :: Int -> Gen [LogItem]+arbitraryItems n = replicateM n arbitraryItem++arbitraryItem, arbitraryIn, arbitraryOut, arbitraryMisc :: Gen LogItem+arbitraryItem = oneof [ arbitraryIn, arbitraryOut, arbitraryMisc ]++arbitraryIn =+ liftM4 LogIn arbitraryUUID arbitraryTime arbitrary arbitraryURI+arbitraryOut =+ liftM3 LogOut arbitraryUUID arbitraryTime arbitraryAttachements+arbitraryMisc =+ liftM4 LogMisc arbitraryUUID arbitraryTime arbitrary arbitrary++arbitraryUUID :: Gen UUID+arbitraryUUID = (fst . random) `fmap` rand++arbitraryTime :: Gen UTCTime+arbitraryTime = (posixSecondsToUTCTime . realToFrac) `fmap` choose (0, century)+ where century :: Integer+ century = 50*365*24*60*60++arbitraryURI :: Gen URI+arbitraryURI = return $ fromMaybe nullURI+ $ parseURIReference "http://example.com/"++arbitraryAttachements :: Gen Attachments+arbitraryAttachements = choose (0,22) >>= \n -> replicateM n arbAttach+ where arbAttach = do+ p <- elements points+ u <- arbitraryUUID+ return (p, u)+ points = [ "head", "neck", "spine", "pelvis" ]+ ++ [ side ++ "-" ++ part |+ side <- [ "left", "right" ],+ part <- [ "shoulder", "arm", "hand", "leg", "foot" ]]+
+ TestMain.hs view
@@ -0,0 +1,211 @@+-- |+-- Module : Main - Test LLSD Utility+-- Copyright : (c) Linden Lab 2009+-- License : MIT+-- Maintainer : bos@lindenlab.com+-- Stability : provisional+-- Portability : portable++module Main where++import Control.Monad+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import Data.List (foldl')+import Data.Serialize+import Data.Word+import Network.Format.LLSD+import qualified Network.Format.LLSD.Test as Test+import qualified Network.Format.LLSD.TestIDL as TestIDL+import System.Console.GetOpt+import System.Environment+import System.Exit+import System.IO+import TestData++data Operation = Test | Help | Generate | Read++data Mode = Mode {+ modeOperation :: Operation,+ modeCount :: Int,+ modeGroup :: Int,+ modeReportEvery :: Int,+ modeQuiet :: Bool,+ modeParse :: B.ByteString -> Either String LLSD,+ modeFormat :: LLSD -> L.ByteString,+ modeDataFile :: Maybe String+ }++defaultMode :: Mode+defaultMode = Mode {+ modeOperation = Help,+ modeCount = 0,+ modeGroup = 1,+ modeReportEvery = 1000,+ modeQuiet = False,+ modeParse = parseXML,+ modeFormat = formatXML,+ modeDataFile = Nothing+ }++setOperation :: Operation -> Mode -> Mode+setOperation op mode = mode { modeOperation = op }++setTest, setHelp, setRead :: Mode -> Mode+setGenerate :: String -> Mode -> Mode+setTest = setOperation Test+setHelp = setOperation Help+setGenerate n = setOperation Generate . setCount n+setRead = setOperation Read++setCount, setGroup, setReportEvery, setDataFile :: String -> Mode -> Mode+setCount n mode = mode { modeCount = read n }+setGroup n mode = mode { modeGroup = read n }+setReportEvery n mode = mode { modeReportEvery = read n }+ -- FIXME: should do something better than read, which can error+setDataFile f mode = mode { modeDataFile = Just f }++setXML, setBinary, setQuiet :: Mode -> Mode+setXML mode = mode { modeParse = parseXML, modeFormat = formatXML }+setBinary mode = mode { modeParse = parseBinary, modeFormat = formatBinary }+setQuiet mode = mode { modeQuiet = True }++options :: [OptDescr (Mode -> Mode)]+options = [+ Option ['t'] ["test", "tests"] (NoArg setTest)+ "run unit tests and checks",++ Option ['g'] ["gen", "generate"] (ReqArg setGenerate "N")+ "generate N packets of LLSD output",+ Option ['c'] ["count"] (ReqArg setGroup "M")+ "generate M records per packet",++ Option ['r'] ["read"] (NoArg setRead)+ "read packets of LLSD",+ Option ['e'] ["every"] (ReqArg setReportEvery "N")+ "report stats every N packets",++ Option ['b'] ["binary"] (NoArg setBinary)+ "binary encoded LLSD",+ Option ['x'] ["xml", "XML"] (NoArg setXML)+ "XML encoded LLSD",++ Option ['d'] ["data"] (ReqArg setDataFile "F")+ "read/write data file F",+ Option ['q'] ["quiet"] (NoArg setQuiet)+ "supress message output",++ Option ['?'] ["help"] (NoArg setHelp)+ "print help summary"+ ]++usage :: [String] -> Handle -> IO ()+usage errs h = do+ progName <- getProgName+ forM_ errs (hPutStr h)+ hPutStr h $ usageInfo (header progName) options+ where header progName = "Usage: " ++ progName ++ " [options]"++usageFailure :: [String] -> IO a+usageFailure errs = usage errs stderr >> exitFailure++parseOptions :: IO (Mode, [String])+parseOptions = do+ argv <- getArgs+ case getOpt Permute options argv of+ (opts, args, []) -> return (foldl' (flip ($)) defaultMode opts, args)+ ( _, _, errs) -> usageFailure errs++runtimeFailure :: [String] -> IO a+runtimeFailure msgs = do+ forM_ msgs (\m -> hPutStrLn stderr m)+ exitFailure++++++hEncode :: (Serialize a) => Handle -> a -> IO ()+hEncode h = B.hPut h . encode++hDecode :: (Serialize a) => Handle -> String -> Int -> IO a+hDecode h msg n = do+ buf <- B.hGet h n+ case decode buf of+ Left err -> runtimeFailure [msg, err]+ Right a -> return a++hPutInt32 :: (Integral a) => Handle -> a -> IO ()+hPutInt32 h i = hEncode h (fromIntegral i :: Word32)+hGetInt32 :: Handle -> String -> IO Int+hGetInt32 h msg = (hDecode h msg 4 :: IO Word32) >>= return . fromIntegral+++report :: (Show a) => Mode -> Handle -> a -> IO ()+report mode h a =+ when (not $ modeQuiet mode) $ hPutStrLn h (show a)++reportCount :: Mode -> Int -> IO ()+reportCount mode i =+ when (i `mod` (modeReportEvery mode) == 0) $ report mode stderr i++generateData :: Mode -> Handle -> IO ()+generateData mode h = do+ let count = modeCount mode+ group = modeGroup mode+ formatter = modeFormat mode+ hSetBinaryMode h True+ -- write format indicator+ hPutInt32 h count+ forM_ [1..count] $ \i -> do+ items <- makeLogItems group+ let bs = (formatter $ toLLSD items)+ hPutInt32 h $ L.length bs+ L.hPut h bs+ reportCount mode i++readData :: Mode -> Handle -> IO ()+readData mode h = do+ hSetBinaryMode h True+ -- read format indicator+ count <- hGetInt32 h "packet count"+ foldM readPacket zeroStats [1..count] >>= report mode stdout+ where readPacket :: LogStats -> Int -> IO LogStats+ readPacket s0 i = s0 `seq` do -- this force of s0 is important+ bs <- hGetInt32 h "length" >>= B.hGet h+ reportCount mode i+ case (modeParse mode $ bs) of+ Right l -> return $ foldl' (flip note) s0 (fromLLSD l :: [LogItem])+ Left err -> runtimeFailure ["packet decode error", err]+++runAllTests :: IO()+runAllTests = do+ Test.runTests+ Test.runChecks+ TestIDL.runTests+ TestIDL.runChecks+ ++withDataHandle :: IOMode -> Handle -> Mode -> (Handle -> IO a) -> IO a+withDataHandle iomode defHandle mode act =+ maybe (act defHandle) (\f -> withFile f iomode act) $ modeDataFile mode++withInputHandle :: Mode -> (Handle -> IO a) -> IO a+withInputHandle = withDataHandle ReadMode stdin++withOutputHandle :: Mode -> (Handle -> IO a) -> IO a+withOutputHandle = withDataHandle WriteMode stdout+ ++main :: IO ()+main = do+ (mode, _files) <- parseOptions+ case modeOperation mode of+ Help -> usage [] stdout+ Test -> runAllTests+ Generate -> withOutputHandle mode $ generateData mode+ Read -> withInputHandle mode $ readData mode+++
+ llsd.cabal view
@@ -0,0 +1,78 @@+Name: llsd+Version: 0.1.0.1+Copyright: 2009-2010 Linden Lab+Author: Mark Lentczner+Maintainer: zero@lindenlab.com+License: MIT+License-File: LICENSE++Category: Networking+Synopsis: An implementation of the LLSD data system+Description: .+Stability: provisional+Homepage:+Package-URL:+Bug-Reports: mailto:zero@lindenlab.com++Build-type: Simple+Cabal-version: >= 1.6++Flag test+ Description: Build unit tests.+ Default: False+++++Library+ Exposed-Modules:+ Network.Format.LLSD+ Network.Format.LLSD.Internal+ Network.Format.LLSD.LLIDL+ Other-Modules:+ Network.Format.LLSD.Binary+ Network.Format.LLSD.Conversion+ Network.Format.LLSD.IEEE754+ Network.Format.LLSD.Pretty+ Network.Format.LLSD.XML+ Build-Depends:+ base == 4.*,+ binary >= 0.5,+ bytestring == 0.9.*,+ cereal >= 0.2,+ containers >= 0.2,+ dataenc == 0.13.*,+ ghc-prim >= 0.1,+ hexpat >= 0.10,+ mtl == 1.1.*,+ network == 2.2.*,+ old-locale == 1.0.*,+ parsec == 2.1.*,+ pretty == 1.0.*,+ random == 1.0.*,+ template-haskell >= 2.3,+ text >= 0.5 && < 0.8,+ time == 1.1.*,+ utf8-string == 0.3.*,+ uuid >= 1.1 && < 1.3+ Ghc-Options: -Wall+ Ghc-Prof-Options: -auto-all -caf-all+ +Executable llsdutil+ Main-Is: Main.hs+ Ghc-Options: -Wall+ Ghc-Prof-Options: -auto-all -caf-all+ +Executable testllsd+ Main-Is: TestMain.hs+ Other-Modules: TestData Network.Format.LLSD.Test Network.Format.LLSD.TestIDL+ Ghc-Options: -Wall+ Ghc-Prof-Options: -auto-all -caf-all+ If flag(test)+ Buildable: True+ Build-Depends:+ HUnit == 1.2.*,+ QuickCheck == 1.2.*+ Else+ Buildable: False+