{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-- |
-- Conversions from Bencoded @ByteString@s to Haskell values.
--
-- == Introduction
--
-- Decoding is done using parsers. There are parsers for the four Bencode types:
--
-- * 'string' decodes Bencode strings as 'B.ByteString's
-- * 'integer' decodes Bencode integers as 'Prelude.Integer's
-- * 'list' decodes Bencode lists as 'V.Vector's
-- * 'dict' decodes Bencode dictionaries as 'M.Map's with 'B.ByteString' keys.
--
-- These can be used to build more complex parsers for arbitrary types.
--
-- @
-- data File = File
--   { hash :: ByteString
--   , size :: Integer
--   , tags :: Vector Text
--   } deriving Show
-- @
--
-- Assuming a @File@ is encoded as a Bencode dictionary with the field names as
-- keys and appropriate value types, a parser for @File@ can be defined as
--
-- @
-- {-# LANGUAGE OverloadedStrings #-}
-- import qualified Data.Bencode.Decode as D
--
-- fileParser :: D.'Parser' File
-- fileParser =
--   File \<\$> D.'field' "hash" D.'string'
--        \<*> D.'field' "size" D.'integer'
--        \<*> D.'field' "tags" (D.'list' D.'text')
-- @
--
-- The parser can then be run on a @ByteString@ with 'decode'.
--
-- >>> D.decode fileParser "d4:hash4:xxxx4:sizei1024e4:tagsl4:work6:backupee"
-- Right (File {hash = "xxxx", size = 1024, tags = ["work","backup"]})
--
-- Of course, invalid Bencode or Bencode that does not satisfy our @File@ parser
-- will fail to decode.
--
-- >>> D.decode fileParser "d4:hash4:xxxx4:tagsl4:work6:backupee"
-- Left "KeyNotFound \"size\""
--
-- For more examples, see the \"Recipes\" section at the end of this page.
--
module Data.Bencode.Decode
  ( -- * Parser
    Parser
  , decode
  , decodeMaybe

    -- * Primary parsers
  , string
  , integer
  , list
  , dict

    -- * More parsers
  , stringEq
  , text
  , textEq
  , int
  , intEq
  , word
  , field
  , value
  , fail

    -- * Recipes
    --
    -- $recipes
  ) where

import Prelude hiding (fail)
import Control.Applicative
import Control.Monad hiding (fail)
import Control.Monad.ST
import Control.Monad.Trans.Reader
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC
import qualified Data.Foldable as F
import qualified Data.Map as M
import qualified Data.Primitive.Array as A
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vector as V
import qualified Data.Vector.Mutable as VM

import Data.Bencode.Type (Value(..))
import Data.Bencode.Util (readKnownNaturalAsInt, readKnownNaturalAsWord)
import qualified Data.Bencode.AST as AST

newtype ParseResult a = ParseResult { forall a. ParseResult a -> Either String a
unParseResult :: Either String a }
  deriving (forall a b. a -> ParseResult b -> ParseResult a
forall a b. (a -> b) -> ParseResult a -> ParseResult b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> ParseResult b -> ParseResult a
$c<$ :: forall a b. a -> ParseResult b -> ParseResult a
fmap :: forall a b. (a -> b) -> ParseResult a -> ParseResult b
$cfmap :: forall a b. (a -> b) -> ParseResult a -> ParseResult b
Functor, Functor ParseResult
forall a. a -> ParseResult a
forall a b. ParseResult a -> ParseResult b -> ParseResult a
forall a b. ParseResult a -> ParseResult b -> ParseResult b
forall a b. ParseResult (a -> b) -> ParseResult a -> ParseResult b
forall a b c.
(a -> b -> c) -> ParseResult a -> ParseResult b -> ParseResult c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. ParseResult a -> ParseResult b -> ParseResult a
$c<* :: forall a b. ParseResult a -> ParseResult b -> ParseResult a
*> :: forall a b. ParseResult a -> ParseResult b -> ParseResult b
$c*> :: forall a b. ParseResult a -> ParseResult b -> ParseResult b
liftA2 :: forall a b c.
(a -> b -> c) -> ParseResult a -> ParseResult b -> ParseResult c
$cliftA2 :: forall a b c.
(a -> b -> c) -> ParseResult a -> ParseResult b -> ParseResult c
<*> :: forall a b. ParseResult (a -> b) -> ParseResult a -> ParseResult b
$c<*> :: forall a b. ParseResult (a -> b) -> ParseResult a -> ParseResult b
pure :: forall a. a -> ParseResult a
$cpure :: forall a. a -> ParseResult a
Applicative, Applicative ParseResult
forall a. a -> ParseResult a
forall a b. ParseResult a -> ParseResult b -> ParseResult b
forall a b. ParseResult a -> (a -> ParseResult b) -> ParseResult b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> ParseResult a
$creturn :: forall a. a -> ParseResult a
>> :: forall a b. ParseResult a -> ParseResult b -> ParseResult b
$c>> :: forall a b. ParseResult a -> ParseResult b -> ParseResult b
>>= :: forall a b. ParseResult a -> (a -> ParseResult b) -> ParseResult b
$c>>= :: forall a b. ParseResult a -> (a -> ParseResult b) -> ParseResult b
Monad)

failResult :: String -> ParseResult a
failResult :: forall a. String -> ParseResult a
failResult = forall a. Either String a -> ParseResult a
ParseResult forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left
{-# INLINE failResult #-}

instance Alternative ParseResult where
  empty :: forall a. ParseResult a
empty = forall a. String -> ParseResult a
failResult String
"Alternative.empty"
  ParseResult a
l <|> :: forall a. ParseResult a -> ParseResult a -> ParseResult a
<|> ParseResult a
r = forall a. Either String a -> ParseResult a
ParseResult forall a b. (a -> b) -> a -> b
$ forall a. ParseResult a -> Either String a
unParseResult ParseResult a
l forall a. Semigroup a => a -> a -> a
<> forall a. ParseResult a -> Either String a
unParseResult ParseResult a
r
  -- Discards left error, not ideal

-- | A parser from a Bencode value to a Haskell value.
newtype Parser a = Parser { forall a. Parser a -> Value -> ParseResult a
runParser :: AST.Value -> ParseResult a }
  deriving (forall a b. a -> Parser b -> Parser a
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Parser b -> Parser a
$c<$ :: forall a b. a -> Parser b -> Parser a
fmap :: forall a b. (a -> b) -> Parser a -> Parser b
$cfmap :: forall a b. (a -> b) -> Parser a -> Parser b
Functor, Functor Parser
forall a. a -> Parser a
forall a b. Parser a -> Parser b -> Parser a
forall a b. Parser a -> Parser b -> Parser b
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. Parser a -> Parser b -> Parser a
$c<* :: forall a b. Parser a -> Parser b -> Parser a
*> :: forall a b. Parser a -> Parser b -> Parser b
$c*> :: forall a b. Parser a -> Parser b -> Parser b
liftA2 :: forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
$cliftA2 :: forall a b c. (a -> b -> c) -> Parser a -> Parser b -> Parser c
<*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
$c<*> :: forall a b. Parser (a -> b) -> Parser a -> Parser b
pure :: forall a. a -> Parser a
$cpure :: forall a. a -> Parser a
Applicative, Applicative Parser
forall a. Parser a
forall a. Parser a -> Parser [a]
forall a. Parser a -> Parser a -> Parser a
forall (f :: * -> *).
Applicative f
-> (forall a. f a)
-> (forall a. f a -> f a -> f a)
-> (forall a. f a -> f [a])
-> (forall a. f a -> f [a])
-> Alternative f
many :: forall a. Parser a -> Parser [a]
$cmany :: forall a. Parser a -> Parser [a]
some :: forall a. Parser a -> Parser [a]
$csome :: forall a. Parser a -> Parser [a]
<|> :: forall a. Parser a -> Parser a -> Parser a
$c<|> :: forall a. Parser a -> Parser a -> Parser a
empty :: forall a. Parser a
$cempty :: forall a. Parser a
Alternative, Applicative Parser
forall a. a -> Parser a
forall a b. Parser a -> Parser b -> Parser b
forall a b. Parser a -> (a -> Parser b) -> Parser b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> Parser a
$creturn :: forall a. a -> Parser a
>> :: forall a b. Parser a -> Parser b -> Parser b
$c>> :: forall a b. Parser a -> Parser b -> Parser b
>>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
$c>>= :: forall a b. Parser a -> (a -> Parser b) -> Parser b
Monad)
    via ReaderT AST.Value ParseResult

lift :: ParseResult a -> Parser a
lift :: forall a. ParseResult a -> Parser a
lift = forall a. (Value -> ParseResult a) -> Parser a
Parser forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const
{-# INLINE lift #-}

failParser :: String -> Parser a
failParser :: forall a. String -> Parser a
failParser = forall a. ParseResult a -> Parser a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> ParseResult a
failResult
{-# INLINE failParser #-}

-- | Decode a value from the given @ByteString@. If decoding fails, returns
-- @Left@ with a failure message.
decode :: Parser a -> B.ByteString -> Either String a
decode :: forall a. Parser a -> ByteString -> Either String a
decode Parser a
p ByteString
s = ByteString -> Either String Value
AST.parseOnly ByteString
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. ParseResult a -> Either String a
unParseResult forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Value -> ParseResult a
runParser Parser a
p

-- | Decode a value from the given @ByteString@. If decoding fails, returns
-- @Nothing@.
decodeMaybe :: Parser a -> B.ByteString -> Maybe a
decodeMaybe :: forall a. Parser a -> ByteString -> Maybe a
decodeMaybe Parser a
p = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> ByteString -> Either String a
decode Parser a
p

errTypeMismatch :: String -> AST.Value -> ParseResult a
errTypeMismatch :: forall a. String -> Value -> ParseResult a
errTypeMismatch String
a Value
b = forall a. String -> ParseResult a
failResult forall a b. (a -> b) -> a -> b
$ String
"TypeMismatch " forall a. [a] -> [a] -> [a]
++ String
a forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String
b'
  where
    b' :: String
b' = case Value
b of
      AST.String ByteString
_  -> String
"String"
      AST.Integer ByteString
_ -> String
"Integer"
      AST.List Array Value
_    -> String
"List"
      AST.Dict Array KeyValue
_    -> String
"Dict"

-- Parsers below are all marked INLINE because they match on the AST
-- constructor and return Eithers. When inlined, GHC is able to optimize the
-- nested case matches using "case merging" and get rid of the intemeditate
-- Eithers using "case-of-case".

stringDirect :: Parser B.ByteString
stringDirect :: Parser ByteString
stringDirect = forall a. (Value -> ParseResult a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \Value
v -> case Value
v of
  AST.String ByteString
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
s
  Value
_ -> forall a. String -> Value -> ParseResult a
errTypeMismatch String
"String" Value
v
{-# INLINE stringDirect #-}

integerDirect :: Parser B.ByteString
integerDirect :: Parser ByteString
integerDirect = forall a. (Value -> ParseResult a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \Value
v -> case Value
v of
  AST.Integer ByteString
s -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
s
  Value
_ -> forall a. String -> Value -> ParseResult a
errTypeMismatch String
"Integer" Value
v
{-# INLINE integerDirect #-}

listDirect :: Parser (A.Array AST.Value)
listDirect :: Parser (Array Value)
listDirect = forall a. (Value -> ParseResult a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \Value
v -> case Value
v of
  AST.List Array Value
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Array Value
a
  Value
_ -> forall a. String -> Value -> ParseResult a
errTypeMismatch String
"List" Value
v
{-# INLINE listDirect #-}

dictDirect :: Parser (A.Array AST.KeyValue)
dictDirect :: Parser (Array KeyValue)
dictDirect = forall a. (Value -> ParseResult a) -> Parser a
Parser forall a b. (a -> b) -> a -> b
$ \Value
v -> case Value
v of
  AST.Dict Array KeyValue
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Array KeyValue
a
  Value
_ -> forall a. String -> Value -> ParseResult a
errTypeMismatch String
"Dict" Value
v
{-# INLINE dictDirect #-}

-- | Decode a Bencode string as a ByteString. Fails on a non-string.
string :: Parser B.ByteString
string :: Parser ByteString
string = Parser ByteString
stringDirect
{-# INLINE string #-}

-- | Decode a Bencode integer as an Integer. Fails on a non-integer.
integer :: Parser Integer
integer :: Parser Integer
integer = ByteString -> Integer
toI forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Parser ByteString
integerDirect
  where
    -- BC.readInteger will be making redundant digit checks since we already
    -- know it to be a valid integer.
    -- But it has an efficient divide-and-conquer algorithm compared to the
    -- simple but O(n^2) foldl' (\acc x -> acc * 10 + x) 0.
    -- We can reimplement the algorithm without the redundant checks if we
    -- really want.
    toI :: ByteString -> Integer
toI ByteString
s = case ByteString -> Maybe (Integer, ByteString)
BC.readInteger ByteString
s of
      Maybe (Integer, ByteString)
Nothing    -> forall a. HasCallStack => String -> a
error String
"Data.Bencode.Decode.integer: should not happen"
      Just (Integer
i,ByteString
_) -> Integer
i
{-# INLINE integer #-}

-- | Decode a Bencode list with the given parser for elements. Fails on a
-- non-list or if any element in the list fails to parse.
list :: Parser a -> Parser (V.Vector a)
list :: forall a. Parser a -> Parser (Vector a)
list Parser a
p = Parser (Array Value)
listDirect forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. ParseResult a -> Parser a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b.
(a -> ParseResult b) -> Array a -> ParseResult (Vector b)
traverseAToV (forall a. Parser a -> Value -> ParseResult a
runParser Parser a
p)
{-# INLINE list #-}

traverseAToV :: (a -> ParseResult b) -> A.Array a -> ParseResult (V.Vector b)
traverseAToV :: forall a b.
(a -> ParseResult b) -> Array a -> ParseResult (Vector b)
traverseAToV a -> ParseResult b
f Array a
a = forall a. (forall s. ST s a) -> a
runST forall a b. (a -> b) -> a -> b
$ do
  let n :: Int
n = forall a. Array a -> Int
A.sizeofArray Array a
a
  MVector (PrimState (ST s)) b
v <- forall (m :: * -> *) a.
PrimMonad m =>
Int -> m (MVector (PrimState m) a)
VM.new Int
n
  let loop :: Int -> ST s (Maybe String)
loop Int
i | Int
i forall a. Eq a => a -> a -> Bool
== Int
n = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
      loop Int
i = case a -> ParseResult b
f (forall a. Array a -> Int -> a
A.indexArray Array a
a Int
i) of
        ParseResult (Left String
e)  -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall a. a -> Maybe a
Just String
e)
        ParseResult (Right b
x) -> forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> Int -> a -> m ()
VM.write MVector (PrimState (ST s)) b
v Int
i b
x forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> ST s (Maybe String)
loop (Int
iforall a. Num a => a -> a -> a
+Int
1)
  Maybe String
res <- Int -> ST s (Maybe String)
loop Int
0
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
PrimMonad m =>
MVector (PrimState m) a -> m (Vector a)
V.unsafeFreeze MVector (PrimState (ST s)) b
v) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> ParseResult a
failResult) Maybe String
res
{-# INLINABLE traverseAToV #-}

-- | Decode a Bencode dict with the given parser for values. Fails on a
-- non-dict or if any value in the dict fails to parse.
dict :: Parser a -> Parser (M.Map B.ByteString a)
dict :: forall a. Parser a -> Parser (Map ByteString a)
dict Parser a
p =
  Parser (Array KeyValue)
dictDirect forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. ParseResult a -> Parser a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall k a. [(k, a)] -> Map k a
M.fromDistinctAscList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse KeyValue -> ParseResult (ByteString, a)
f forall b c a. (b -> c) -> (a -> b) -> a -> c
.  forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList
  where
    f :: KeyValue -> ParseResult (ByteString, a)
f (AST.KeyValue ByteString
k Value
v) = (,) ByteString
k forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Value -> ParseResult a
runParser Parser a
p Value
v
{-# INLINE dict #-}

-- | Succeeds only on a Bencode string that equals the given string.
stringEq :: B.ByteString -> Parser ()
stringEq :: ByteString -> Parser ()
stringEq ByteString
s = Parser ByteString
stringDirect forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ByteString
s' ->
  if ByteString
s forall a. Eq a => a -> a -> Bool
== ByteString
s'
  then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  else forall a. String -> Parser a
failParser forall a b. (a -> b) -> a -> b
$ String
"StringNotEq " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
s forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
s'
{-# INLINE stringEq #-}

-- | Decode a bencode string as UTF-8 text. Fails on a non-string or if the
-- string is not valid UTF-8.
text :: Parser T.Text
text :: Parser Text
text =
  Parser ByteString
stringDirect forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const (forall a. String -> Parser a
failParser String
"UTF8DecodeFailure")) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either UnicodeException Text
T.decodeUtf8'
{-# INLINE text #-}

-- | Succeeds only on a Bencode string that equals the given text.
textEq :: T.Text -> Parser ()
textEq :: Text -> Parser ()
textEq Text
t = Parser Text
text forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
t' ->
  if Text
t forall a. Eq a => a -> a -> Bool
== Text
t'
  then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  else forall a. String -> Parser a
failParser forall a b. (a -> b) -> a -> b
$ String
"TextNotEq " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
t forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Text
t'
{-# INLINE textEq #-}

-- | Decode a Bencode integer as an @Int@. Fails on a non-integer or if the
-- integer is out of bounds for an @Int@.
int :: Parser Int
int :: Parser Int
int = Parser ByteString
integerDirect forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. String -> Parser a
failParser String
"IntOutOfBounds") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe Int
go
  where
    go :: ByteString -> Maybe Int
go ByteString
s = case ByteString -> Maybe (Char, ByteString)
BC.uncons ByteString
s of
      Just (Char
'-', ByteString
s') -> Bool -> ByteString -> Maybe Int
readKnownNaturalAsInt Bool
True ByteString
s'
      Maybe (Char, ByteString)
_              -> Bool -> ByteString -> Maybe Int
readKnownNaturalAsInt Bool
False ByteString
s
{-# INLINE int #-}

-- | Succeeds only on a Bencode integer that equals the given value.
intEq :: Int -> Parser ()
intEq :: Int -> Parser ()
intEq Int
i = Parser Int
int forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Int
i' ->
  if Int
i forall a. Eq a => a -> a -> Bool
== Int
i'
  then forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  else forall a. String -> Parser a
failParser forall a b. (a -> b) -> a -> b
$ String
"IntNotEq " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Int
i'
{-# INLINE intEq #-}

-- | Decode a Bencode integer as a @Word@. Fails on a non-integer or if the
-- integer is out of bounds for a @Word@.
word :: Parser Word
word :: Parser Word
word = Parser ByteString
integerDirect forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. String -> Parser a
failParser String
"WordOutOfBounds") forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe Word
go
  where
    go :: ByteString -> Maybe Word
go ByteString
s = case ByteString -> Maybe (Char, ByteString)
BC.uncons ByteString
s of
      Just (Char
'-',ByteString
_) -> forall a. Maybe a
Nothing
      Maybe (Char, ByteString)
_            -> ByteString -> Maybe Word
readKnownNaturalAsWord ByteString
s
{-# INLINE word #-}

-- | Decode a @Value@. Always succeeds for valid Bencode.
value :: Parser Value
value :: Parser Value
value = ByteString -> Value
String  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString
string
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Integer -> Value
Integer forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Integer
integer
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Vector Value -> Value
List    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser (Vector a)
list Parser Value
value
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Map ByteString Value -> Value
Dict    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Parser a -> Parser (Map ByteString a)
dict Parser Value
value

-- | Always fails with the given message.
fail :: String -> Parser a
fail :: forall a. String -> Parser a
fail = forall a. String -> Parser a
failParser forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String
"Fail: " forall a. [a] -> [a] -> [a]
++ )
{-# INLINE fail #-}

-- | Decode a value with the given parser for the given key. Fails on a
-- non-dict, if the key is absent, or if the value parser fails.
field :: B.ByteString -> Parser a -> Parser a
field :: forall a. ByteString -> Parser a -> Parser a
field ByteString
k Parser a
p =
  Parser (Array KeyValue)
dictDirect forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. String -> Parser a
failParser forall a b. (a -> b) -> a -> b
$ String
"KeyNotFound " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show ByteString
k) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Array KeyValue -> Maybe Value
binarySearch ByteString
k forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=
  forall a. ParseResult a -> Parser a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Parser a -> Value -> ParseResult a
runParser Parser a
p
{-# INLINE field #-}

----------
-- Utils

-- | Binary search. The array must be sorted by key.
binarySearch :: B.ByteString -> A.Array AST.KeyValue -> Maybe AST.Value
binarySearch :: ByteString -> Array KeyValue -> Maybe Value
binarySearch ByteString
k Array KeyValue
a = Int -> Int -> Maybe Value
go Int
0 (forall a. Array a -> Int
A.sizeofArray Array KeyValue
a)
  where
    go :: Int -> Int -> Maybe Value
go Int
l Int
r | Int
l forall a. Eq a => a -> a -> Bool
== Int
r = forall a. Maybe a
Nothing
    go Int
l Int
r = case forall a. Ord a => a -> a -> Ordering
compare ByteString
k ByteString
k' of
      Ordering
LT -> Int -> Int -> Maybe Value
go Int
l Int
m
      Ordering
EQ -> forall a. a -> Maybe a
Just Value
v
      Ordering
GT -> Int -> Int -> Maybe Value
go (Int
mforall a. Num a => a -> a -> a
+Int
1) Int
r
      where
        -- Overflow, careful!
        m :: Int
m = forall a b. (Integral a, Num b) => a -> b
fromIntegral ((forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int
lforall a. Num a => a -> a -> a
+Int
r) :: Word) forall a. Integral a => a -> a -> a
`div` Word
2) :: Int
        AST.KeyValue ByteString
k' Value
v = forall a. Array a -> Int -> a
A.indexArray Array KeyValue
a Int
m
{-# INLINABLE binarySearch #-}

-- $recipes
-- Recipes for some common and uncommon usages.
--
-- The following preface is assumed.
--
-- @
-- {-# LANGUAGE OverloadedStrings #-}
-- import Data.ByteString (ByteString)
-- import Data.Text (Text)
-- import qualified Data.Bencode.Decode as D
-- @
--
-- === Decode an optional field
--
-- @
-- import Control.Applicative ('optional')
--
-- data File = File { name :: Text, size :: Maybe Int } deriving Show
--
-- fileParser :: D.'Parser' File
-- fileParser =
--   File
--     \<$> D.'field' "name" D.'text'
--     \<*> optional (D.'field' "size" D.'int')
-- @
--
-- >>> D.decode fileParser "d4:name9:hello.txt4:sizei16ee"
-- Right (File {name = "hello.txt", size = Just 16})
-- >>> D.decode fileParser "d4:name9:hello.txte"
-- Right (File {name = "hello.txt", size = Nothing})
--
-- === Decode an enum
--
-- @
-- import Control.Applicative ('(<|>)')
--
-- data Color = Red | Green | Blue deriving Show
--
-- colorParser :: D.'Parser' Color
-- colorParser =
--       Red   \<$ D.'stringEq' "red"
--   \<|> Green \<$ D.'stringEq' "green"
--   \<|> Blue  \<$ D.'stringEq' "blue"
--   \<|> D.'fail' "unknown color"
-- @
--
-- >>> D.decode colorParser "5:green"
-- Right Green
-- >>> D.decode colorParser "5:black"
-- Left "Fail: unknown color"
--
-- === Decode differently based on dict contents
--
-- @
-- import Control.Applicative ('(<|>)')
--
-- data Response = Response
--   { id_    :: Int
--   , result :: Either Text ByteString
--   } deriving Show
--
-- responseParser :: D.'Parser' Response
-- responseParser = do
--   id_ <- D.'field' "id" D.'int'
--   success <- D.'field' "status" $
--         False \<$ D.'stringEq' "failure"
--     \<|> True  \<$ D.'stringEq' "success"
--     \<|> D.'fail' "unknown status"
--   Response id_
--     \<$> if success
--         then Right \<$> D.'field' "data" D.'string'
--         else Left  \<$> D.'field' "reason" D.'text'
-- @
--
-- >>> D.decode responseParser "d2:idi42e6:reason12:unauthorized6:status7:failuree"
-- Right (Response {id_ = 42, result = Left "unauthorized"})
-- >>> D.decode responseParser "d4:data4:00002:idi42e6:status7:successe"
-- Right (Response {id_ = 42, result = Right "0000"})
--
-- === Decode nested dicts
--
-- @
-- data File = File { name :: Text, size :: Int } deriving Show
--
-- fileParser :: D.'Parser' File
-- fileParser =
--   File
--     \<$> D.'field' "name" D.'text'
--     \<*> D.'field' "metadata" (D.'field' "info" (D.'field' "size" D.'int'))
-- @
--
-- >>> D.decode fileParser "d8:metadatad4:infod4:sizei32eee4:name9:hello.txte"
-- Right (File {name = "hello.txt", size = 32})
--