module Data.BEncode
(
BEncode(..),
bRead,
bShow,
bPack
)
where
import qualified Data.Map as Map
import Data.Map (Map)
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 )
type BParser a = GenParser Token () a
data BEncode = BInt Int
| BString ByteString
| BList [BEncode]
| BDict (Map String BEncode)
deriving (Eq, Ord, Show)
instance Binary BEncode where
put e = put (BS.concat $ L.toChunks $ bPack e)
get = do s <- get
case bRead (L.fromChunks [s]) of
Just e -> return e
Nothing -> fail "Failed to parse BEncoded data"
updatePos :: (SourcePos -> Token -> [Token] -> SourcePos)
updatePos pos _ _ = pos
bToken :: Token -> BParser ()
bToken t = tokenPrim show updatePos fn
where fn t' | t' == t = Just ()
fn _ = Nothing
token' :: (Token -> Maybe a) -> BParser a
token' = tokenPrim show updatePos
tnumber :: BParser Int
tnumber = token' fn
where fn (TNumber i) = Just i
fn _ = Nothing
tstring :: BParser ByteString
tstring = token' fn
where fn (TString str) = Just str
fn _ = Nothing
withToken :: Token -> BParser a -> BParser a
withToken tok
= between (bToken tok) (bToken TEnd)
bInt :: BParser BEncode
bInt = withToken TInt $ fmap BInt tnumber
bString :: BParser BEncode
bString = fmap BString tstring
bList :: BParser BEncode
bList = withToken TList $ fmap BList (many bParse)
bDict :: BParser BEncode
bDict = withToken TDict $ fmap (BDict . Map.fromAscList) (many1 bAssocList)
where bAssocList
= do str <- tstring
value <- bParse
return (BS.unpack str,value)
bParse :: BParser BEncode
bParse = bDict <|> bList <|> bString <|> bInt
bRead :: L.ByteString -> Maybe BEncode
bRead str = case parse bParse "" (lexer str) of
Left _err -> Nothing
Right b -> Just b
bShow :: BEncode -> ShowS
bShow be = bShow' be
where
sc = showChar
ss = showString
sKV (k,v) = sString k (length k) . bShow' v
sDict dict = foldr (.) id (map sKV (Map.toAscList dict))
sList list = foldr (.) id (map bShow' list)
sString str len = shows len . sc ':' . ss str
bShow' b =
case b of
BInt i -> sc 'i' . shows i . sc 'e'
BString s -> sString (BS.unpack s) (BS.length s)
BList bl -> sc 'l' . sList bl . sc 'e'
BDict bd -> sc 'd' . sDict bd . sc 'e'
bPack :: BEncode -> L.ByteString
bPack be = L.fromChunks (bPack' be [])
where intTag = BS.pack "i"
colonTag = BS.pack ":"
endTag = BS.pack "e"
listTag = BS.pack "l"
dictTag = BS.pack "d"
sString s r = BS.pack (show (BS.length s)) : colonTag : 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)