diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMainWithHooks defaultUserHooks diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,5 @@ +#!/usr/bin/env runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMainWithHooks defaultUserHooks diff --git a/bencode.cabal b/bencode.cabal --- a/bencode.cabal +++ b/bencode.cabal @@ -1,19 +1,19 @@ Name: bencode -Version: 0.3 +Version: 0.4 Maintainer: Lemmih (lemmih@gmail.com) Author: Lemmih (lemmih@gmail.com), Jesper Louis Andersen -Copyright: 2005-2007, Lemmih +Copyright: 2005-2009, Lemmih License-File: LICENSE License: BSD3 -Build-Depends: base, parsec, bytestring, containers, binary +Build-Depends: base<5, parsec, bytestring, containers, binary Build-Type: Simple Category: Text Synopsis: Parser and printer for bencoded data. -Tested-with: GHC ==6.8.1 +Tested-with: GHC ==6.8.1, GHC ==6.10.2 Extensions: PatternGuards Exposed-Modules: Data.BEncode Data.BEncode.Lexer Data.BEncode.Parser -GHC-Options: -Wall -Werror +GHC-Options: -Wall Hs-Source-Dirs: src diff --git a/src/Data/BEncode.hs b/src/Data/BEncode.hs --- a/src/Data/BEncode.hs +++ b/src/Data/BEncode.hs @@ -44,10 +44,10 @@ import qualified Data.Map as Map import Data.Map (Map) +import Data.List (sort) import Text.ParserCombinators.Parsec import qualified Data.ByteString.Lazy.Char8 as L import qualified Data.ByteString.Char8 as BS -import Data.ByteString (ByteString) import Data.Binary import Data.BEncode.Lexer ( Token (..), lexer ) @@ -59,7 +59,7 @@ data type here -} data BEncode = BInt Int - | BString ByteString + | BString L.ByteString | BList [BEncode] | BDict (Map String BEncode) deriving (Eq, Ord, Show) @@ -88,7 +88,7 @@ where fn (TNumber i) = Just i fn _ = Nothing -tstring :: BParser ByteString +tstring :: BParser L.ByteString tstring = token' fn where fn (TString str) = Just str fn _ = Nothing @@ -110,11 +110,14 @@ bList = withToken TList $ fmap BList (many bParse) bDict :: BParser BEncode -bDict = withToken TDict $ fmap (BDict . Map.fromAscList) (many1 bAssocList) - where bAssocList +bDict = withToken TDict $ fmap (BDict . Map.fromAscList) (checkList =<< many1 bAssocList) + where checkList lst = if (lst /= sort lst) + then fail "dictionary not sorted" + else return lst + bAssocList = do str <- tstring value <- bParse - return (BS.unpack str,value) + return (L.unpack str,value) bParse :: BParser BEncode bParse = bDict <|> bList <|> bString <|> bInt @@ -140,7 +143,7 @@ bShow' b = case b of BInt i -> sc 'i' . shows i . sc 'e' - BString s -> sString (BS.unpack s) (BS.length s) + BString s -> sString (L.unpack s) (L.length s) BList bl -> sc 'l' . sList bl . sc 'e' BDict bd -> sc 'd' . sDict bd . sc 'e' @@ -151,10 +154,10 @@ endTag = BS.pack "e" listTag = BS.pack "l" dictTag = BS.pack "d" - sString s r = BS.pack (show (BS.length s)) : colonTag : s : r + sString s r = BS.pack (show (L.length s)) : colonTag : L.toChunks s ++ r bPack' (BInt i) r = intTag : BS.pack (show i) : endTag : r bPack' (BString s) r = sString s r bPack' (BList bl) r = listTag : foldr bPack' (endTag : r) bl - bPack' (BDict bd) r = dictTag : foldr (\(k,v) -> sString (BS.pack k) . bPack' v) (endTag : r) (Map.toAscList bd) + bPack' (BDict bd) r = dictTag : foldr (\(k,v) -> sString (L.pack k) . bPack' v) (endTag : r) (Map.toAscList bd) --check be = bShow be "" == L.unpack (bPack be) diff --git a/src/Data/BEncode/Lexer.hs b/src/Data/BEncode/Lexer.hs --- a/src/Data/BEncode/Lexer.hs +++ b/src/Data/BEncode/Lexer.hs @@ -3,14 +3,12 @@ import Data.Char import qualified Data.ByteString.Lazy.Char8 as L -import qualified Data.ByteString.Char8 as BS -import Data.ByteString (ByteString) data Token = TDict | TList | TInt - | TString ByteString + | TString L.ByteString | TNumber Int | TEnd deriving (Show,Eq) @@ -34,7 +32,7 @@ then [TNumber number] else case L.head rest' of ':' -> let (str, rest'') = L.splitAt (fromIntegral number) (L.tail rest') - in TString (BS.concat $ L.toChunks str) : lexer rest'' + in TString str : lexer rest'' _ -> TNumber number : lexer rest' | otherwise -> error "Lexer error." where ch = L.head fs diff --git a/src/Data/BEncode/Parser.hs b/src/Data/BEncode/Parser.hs --- a/src/Data/BEncode/Parser.hs +++ b/src/Data/BEncode/Parser.hs @@ -44,12 +44,19 @@ import Data.BEncode import qualified Data.Map as Map -import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy.Char8 as L import Control.Monad data BParser a = BParser (BEncode -> Reply a) +instance MonadPlus BParser where + mzero = BParser $ \_ -> Error "mzero" + mplus (BParser a) (BParser b) = BParser $ \st -> case a st of + Error _err -> b st + ok -> ok + + runB :: BParser a -> BEncode -> Reply a runB (BParser b) = b @@ -64,11 +71,12 @@ return val = BParser $ Ok val fail str = BParser $ \_ -> Error str +instance Functor BParser where + fmap fn p = do a <- p + return (fn a) + (<|>) :: BParser a -> BParser a -> BParser a -(BParser b1) <|> (BParser b2) - = BParser $ \b -> case b1 b of - Ok a b' -> Ok a b' - _ -> b2 b +a <|> b = a `mplus` b runParser :: BParser a -> BEncode -> Either String a runParser parser b = case runB parser b of @@ -101,10 +109,10 @@ bstring :: BParser BEncode -> BParser String bstring p = do b <- p case b of - BString str -> return (BS.unpack str) + BString str -> return (L.unpack str) _ -> fail $ "Expected BString, found: " ++ show b -bbytestring :: BParser BEncode -> BParser BS.ByteString +bbytestring :: BParser BEncode -> BParser L.ByteString bbytestring p = do b <- p case b of BString str -> return str