sexpr (empty) → 0.1

raw patch · 6 files changed

+299/−0 lines, 6 filesdep +basedep +base64-stringdep +prettysetup-changed

Dependencies added: base, base64-string, pretty

Files

Codec/Sexpr.hs +50/−0
Codec/Sexpr/Parser.hs +140/−0
Codec/Sexpr/Printer.hs +65/−0
LICENSE +22/−0
Setup.lhs +3/−0
sexpr.cabal +19/−0

+ Codec/Sexpr.hs view

@@ -0,0 +1,50 @@+module Sexpr (Sexpr,+              atom,+              hintedAtom,+              list,+              isAtom,+              isList,+              hint,+              defaultHint,+              unAtom,+              unList,+              isTokenChar,isInitialTokenChar,isQuoteableChar+              ) where++import Data.Char++data Sexpr = Atom String+           | HintedAtom String String+           | List [Sexpr] ++instance Eq Sexpr where+    (List a) == (List b) = and $ zipWith (==) a b+    a == b = unAtom a == unAtom b && hint a == hint b++defaultHint = "text/plain; charset=iso-8859-1"++atom s = Atom s+list xs = List xs+hintedAtom h s | h == defaultHint = Atom s+hintedAtom h s = HintedAtom h s++isList (List _) = True+isList _ = False++isAtom (List _) = False+isAtom _ = True++hint (Atom s) = Just defaultHint+hint (HintedAtom h s) = Just h+hint _ = Nothing++unAtom (Atom s) = s+unAtom (HintedAtom h s) = s++unList (List xs) = xs++isInitialTokenChar x = isAlpha x || x `elem` "-./_:*+="++isTokenChar x = isAlphaNum x || x `elem` "-./_:*+="++isQuoteableChar x = isTokenChar x || isSpace x

+ Codec/Sexpr/Parser.hs view

@@ -0,0 +1,140 @@+module Parser (readSexpr,+               sexpr,+               canonicalSexpr) where++import Sexpr++import Data.Char+import Text.ParserCombinators.ReadP+import qualified Codec.Binary.Base64.String as B64++{-+From Rivest's documentation:++<sexpr>    	:: <string> | <list>+<string>   	:: <display>? <simple-string> ;+<simple-string>	:: <raw> | <token> | <base-64> | <hexadecimal> | +		           <quoted-string> ;+<display>  	:: "[" <simple-string> "]" ;+<raw>      	:: <decimal> ":" <bytes> ;+<decimal>  	:: <decimal-digit>+ ;+		-- decimal numbers should have no unnecessary leading zeros+<bytes> 	-- any string of bytes, of the indicated length+<token>    	:: <tokenchar>+ ;+<base-64>  	:: <decimal>? "|" ( <base-64-char> | <whitespace> )* "|" ;+<hexadecimal>   :: "#" ( <hex-digit> | <white-space> )* "#" ;+<quoted-string> :: <decimal>? <quoted-string-body>  +<quoted-string-body> :: "\"" <bytes> "\""+<list>     	:: "(" ( <sexp> | <whitespace> )* ")" ;+<whitespace> 	:: <whitespace-char>* ;+<token-char>  	:: <alpha> | <decimal-digit> | <simple-punc> ;+<alpha>       	:: <upper-case> | <lower-case> | <digit> ;+<lower-case>  	:: "a" | ... | "z" ;+<upper-case>  	:: "A" | ... | "Z" ;+<decimal-digit> :: "0" | ... | "9" ;+<hex-digit>     :: <decimal-digit> | "A" | ... | "F" | "a" | ... | "f" ;+<simple-punc> 	:: "-" | "." | "/" | "_" | ":" | "*" | "+" | "=" ;+<whitespace-char> :: " " | "\t" | "\r" | "\n" ;+<base-64-char> 	:: <alpha> | <decimal-digit> | "+" | "/" | "=" ;+<null>        	:: "" ;+-}++instance Read Sexpr where+    readsPrec n = readP_to_S sexpr++readSexpr s = fst . head $ readP_to_S sexpr s++sexpr = do+  skipSpaces+  s <- canonicalSexpr+  skipSpaces+  return s++canonicalSexpr :: ReadP Sexpr+canonicalSexpr = do+  s <- atomR <++ listR <++ basicTransport+  optional $ char '\NUL'+  return s++basicTransport :: ReadP Sexpr+basicTransport = do+  b64Octets <- between (char '{') (char '}') $ many1 b64char+  let parses = readP_to_S sexpr $ B64.decode b64Octets+  choice $ map (return.fst) $ filter ((=="") . snd) parses++b64char = satisfy (\x -> isAlphaNum x || x `elem` "+/=")+b64char' = skipSpaces >> b64char++hexchar = satisfy isHexDigit+hexchar' = skipSpaces >> hexchar++listR :: ReadP Sexpr+listR = do+  l <- between (char '(') (char ')') $ many sexpr+  return $ list l++atomR :: ReadP Sexpr+atomR = unhinted +++ hinted+  where +    unhinted = simpleString >>= (return . atom)+    hinted = do+      hint <- between (char '[' >> skipSpaces) +                      (skipSpaces >> char ']') +                      simpleString+      value <- simpleString+      return $ hintedAtom hint value+      +simpleString :: ReadP String+simpleString = raw +++ token +++ b64Atom +++ hexAtom +++ quotedString++quotedString = withLength +++ withoutLength+  where+    withLength = do+      l <- decimal+      c <- between (char '"') (char '"') (many get)+      let s = read ('"':c ++ "\"")+      if (l == length s)+       then return s+       else fail "length error"              +    withoutLength = do+                 c <- between (char '"') (char '"') (many get)+                 return $ read ('"':c ++ "\"")++hexAtom = do+  s <- withLength +++ withoutLength+  return $ hexDecode s+    where+      withLength = do+            l <- decimal+            between (char '#') (char '#') (count (2*l) hexchar')+      withoutLength = between (char '#') (char '#') (many1 hexchar')++hexDecode [] = ""+hexDecode (h:o:cs) = chr (16*digitToInt h + digitToInt o) : (hexDecode cs)++b64Atom = do+  s <- withLength +++ withoutLength+  return $ B64.decode s+  where+    withLength = do+      l <- decimal+      between (char '|') (char '|') (count (b64length l) b64char')+    withoutLength = +      between (char '|') (char '|') (many1 b64char')+    b64length l = 4 * (ceiling (fromIntegral l / 3))++token = do+  c <- satisfy isInitialTokenChar+  cs <- munch isTokenChar+  return (c:cs)++raw :: ReadP String+raw = do+  length <- decimal+  char ':'+  count length get++decimal :: ReadP Int+decimal = do+  s <- munch1 isNumber+  return $ read s

+ Codec/Sexpr/Printer.hs view

@@ -0,0 +1,65 @@+module Printer (canonical, canonicalString,+                basic, basicString,+                advanced, advancedString+               ) where++import Sexpr++import Data.Char+import Data.Maybe+import Text.PrettyPrint+import qualified Codec.Binary.Base64.String as B64++instance Show Sexpr where+    show s = advancedString s++raw s = shows (length s) . showString ":" . showString s++canonicalString s = canonical s ""++canonical :: Sexpr -> ShowS+canonical s | isAtom s && hint s == Just defaultHint = raw $ unAtom s+canonical s | isAtom s = showString "[" +                             . raw (fromJust $ hint s)+                             . showString "]"+                             . raw (unAtom s)+canonical s | isList s = showString "("+                 . showString (foldr (.) id (map canonical $ unList s) $ "")+                 . showString ")"++basicString s = render $ basic s++basic :: Sexpr -> Doc+basic s = braces . hcat $ map char . B64.encode $ canonical s ""+-- FIXME should basic add and encode a NUL terminator?+-- FIXMIE We parse it out in canonical---should canonical encodings end with a NUL? ++advancedString s = render $ advanced s+++format s | canToken s = text s+         | canQuote s = quote s+         | canHex s = hex s+         | otherwise = base64 s++canToken (x:xs) = isInitialTokenChar x && all isTokenChar xs++canQuote s = all isQuoteableChar s+             || fromIntegral (length (show s)) <= 1.1 * fromIntegral (length s)++canHex s = length s `elem` [1,2,3,4,8,16,20]++hex s = text (show $ length s) <> (char '#') <> hcat (map (text . hexEncode) s) <> (char '#')++hexEncode x = (intToDigit h) : (intToDigit o) : []+    where +      (h,o) = quotRem (ord x) 16++quote s = text $ show s++base64 s = (char '|') <> hcat (map char $ B64.encode s) <> (char '|')++advanced s | isAtom s && hint s == Just defaultHint = format $ unAtom s+advanced s | isAtom s = brackets (format $ fromJust $ hint s) +                        <> (format $ unAtom s) +advanced s | isList s = parens $ sep (map advanced $ unList s)

+ LICENSE view

@@ -0,0 +1,22 @@+Copyright (c) 2009 Brian Sniffen <bts@evenmere.org>++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.

+ Setup.lhs view

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain

+ sexpr.cabal view

@@ -0,0 +1,19 @@+Name:                sexpr+Version:             0.1+Cabal-Version:	     >= 1.2+Synopsis:            S-expression printer and parser +Description:         Parser and printer for S-expressions, including Ron +		     Rivest's Canonical S-expressions.  These are used in +		     SDSI and SPKI, and are generally useful for +		     cryptographic operations over structured data.+Category:            Codec+License:             BSD3+License-file:        LICENSE+Author:              Brian Sniffen+Maintainer:          bts@evenmere.org+Build-type: 	     Simple++Library+    Build-Depends: base, base64-string, pretty+    Exposed-modules: Codec.Sexpr, Codec.Sexpr.Parser, Codec.Sexpr.Printer+