module ID3.Parser.General where
import Text.ParserCombinators.Poly.State (Parser, runParser, stGet, stUpdate, onFail, next,
satisfy, adjustErr, exactly)
import ID3.Parser.UnSync
import ID3.Type.Header (TagVersion, unsynch)
import ID3.Type.Flags (Flags(..))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C
import Data.Word (Word8)
import Bits
import Data.Accessor
import qualified Data.Text as Text
import Data.Text.Encoding (decodeASCII, decodeUtf16LE, decodeUtf16BE, decodeUtf8)
import Data.ByteString.Lazy.UTF8 (toString)
import Codec.Binary.UTF8.String as Codec
import Control.Monad (when)
---,--------------------------------
type Token = Word8
data St = State { id3TagVersion :: TagVersion
, headerFlags :: Flags
, tagPos :: Integer
, curSize :: Integer
}
instance Show St where
show st = show (tagPos st, curSize st)
initState = State (4, 0) (Flags []) 0 10
type CharEncoding = Integer
type TagParser = Parser St Token
run :: TagParser a -> [Word8] -> (Either String a, [Token])
run p cont = (result, rest) where (result, _, rest) = runParser p initState cont
---,--------------------------------
tagVersionGet :: TagParser TagVersion
tagVersionGet = stGet >>= return . id3TagVersion
tagVersionSet :: TagVersion -> TagParser ()
tagVersionSet v = stUpdate (\st -> st {id3TagVersion = v})
---,--------------------------------
flagsGet :: TagParser Flags
flagsGet = stGet >>= return . headerFlags
flagsSet :: Flags -> TagParser ()
flagsSet fs = stUpdate (\st -> st {headerFlags = fs})
---,--------------------------------
posGet :: TagParser Integer
posGet = stGet >>= return . tagPos
posUpdate :: (Integer -> Integer) -> TagParser ()
posUpdate f = stUpdate ( \st -> st {tagPos = f (tagPos st)} )
posSet :: Integer -> TagParser ()
posSet p = posUpdate (\_ -> p)
posDec :: TagParser ()
posDec = posUpdate (\p -> p1)
posInc :: TagParser ()
posInc = posUpdate (\p -> p+1)
---,--------------------------------
sizeGet :: TagParser Integer
sizeGet = stGet >>= return . curSize
sizeUpdate :: (Integer -> Integer) -> TagParser ()
sizeUpdate f = stUpdate ( \st -> st {curSize = f (curSize st)} )
sizeSet :: Integer -> TagParser ()
sizeSet s = sizeUpdate (\_ -> s)
sizeDec :: TagParser ()
sizeDec = sizeUpdate (\x -> x1)
sizeInc :: TagParser ()
sizeInc = sizeUpdate (\x -> x+1)
---,--------------------------------
ifSize :: TagParser [a] -> TagParser [a]
ifSize p = do
s <- sizeGet
if s > 0
then p
else return []
withSize p = do
x <- p
sizeDec
posInc
return x
---,--------------------------------
many' :: TagParser a -> TagParser [a]
many' p = many1' p `onFail` return []
many1' :: TagParser a -> TagParser [a]
many1' p = ifSize $ do
x <- p
xs <- many' p
return (x:xs)
---,--------------------------------
manyTill' :: TagParser a -> TagParser z -> TagParser [a]
manyTill' p end = manyTill1' p end `onFail` return []
manyTill1' :: TagParser a -> TagParser z -> TagParser [a]
manyTill1' p end = ifSize $ (end >> return []) `onFail`
(ifSize $ do
x <- p
xs <- manyTill' p end
return (x:xs))
skipTill p end = end `onFail` do {p; skipTill p end}
---,--------------------------------
sepBy' :: TagParser a -> TagParser sep -> TagParser [a]
sepBy' p sep = sepBy1' p sep `onFail` return []
sepBy1' :: TagParser a -> TagParser sep -> TagParser [a]
sepBy1' p sep= ifSize $ do
x <- p
xs <- many' (sep >> p)
return (x:xs)
---,--------------------------------
count :: (Num n) => n -> TagParser a -> TagParser [a]
count 0 _ = return []
count n p = do
x <- p
xs <- count (n1) p
return (x:xs)
count' :: (Num n) => n -> TagParser a -> TagParser [a]
count' 0 _ = return []
count' n p = ifSize $ do
x <- p
xs <- count' (n1) p
return (x:xs)
---,--------------------------------
countSepBy' :: (Num n) => n -> TagParser a -> TagParser sep -> TagParser [a]
countSepBy' 0 _ _ = return []
countSepBy' n p sep = ifSize $ do
x <- p
xs <- count' (n1) (sep >> p)
return (x:xs)
encPack :: CharEncoding -> [Token] -> String
encPack 0x00 s = Text.unpack $ decodeASCII $ BS.pack s
encPack 0x01 (0xFF:0xFE:s) = Text.unpack $ decodeUtf16LE $ BS.pack s
encPack 0x01 (0xFE:0xFF:s) = Text.unpack $ decodeUtf16BE $ BS.pack s
encPack 0x02 s = Text.unpack $ decodeUtf16BE $ BS.pack s
encPack _ s = Text.unpack $ decodeUtf8 $ BS.pack s
parseUntilWord8Null :: TagParser [Token]
parseUntilWord8Null = nonNull `manyTill'` (word8 0x00)
parseUntilWord16Null :: TagParser [Token]
parseUntilWord16Null = do
s <- sizeGet
when (s == 1) $ fail "Non-even number of bytes for UTF-16 string"
if s > 1
then do
byte1 <- anyWord8
byte2 <- anyWord8
if byte1 == 0x00 && byte2 == 0x00
then return []
else do
rest <- parseUntilWord16Null
return $ [byte1, byte2] ++ rest
else return []
nonNull = withSize $ satisfy (/=0x00) `adjustErr` (++"\nWTF: nonNull")
parseEncoding :: TagParser CharEncoding
parseEncoding = anyWord8 >>= (return . toInteger)
parseString :: CharEncoding -> TagParser String
parseString enc = do
v <- case enc of
0x01 -> parseUntilWord16Null
0x02 -> parseUntilWord16Null
_ -> parseUntilWord8Null
return $ encPack enc v
parseNumber :: TagParser Integer
parseNumber = parseUntilWord8Null >>= return . sum . (zipWith (*) (iterate (*10) 1)) .
reverse . map toInteger
parseLanguage :: TagParser String
parseLanguage = do
lang <- count' 3 anyWord8
return $ encPack 0x03 lang
---,--------------------------------
parsers :: [TagParser a] -> TagParser [a]
parsers [] = return []
parsers (p:ps) = do
x <- p
xs <- parsers ps
return (x:xs)
---,--------------------------------
word8 :: Token -> TagParser Token
word8 w = (withSize $ satisfy (==w)) `err` (" \nWTF: word8 "++(show w))
word8s :: [Token] -> TagParser [Token]
word8s ws = parsers $ map word8 ws
byteString :: BS.ByteString -> TagParser BS.ByteString
byteString bs = (word8s $ BS.unpack bs) >> return bs
string :: String -> TagParser BS.ByteString
string = byteString . C.pack
upper :: TagParser Token
upper = satisfy (\x -> (0x41<=x)&&(x<=0x5a)) `err` ("\nWTF: upper")
digit :: TagParser Token
digit = satisfy (\x -> (0x30<=x)&&(x<=0x39)) `err` ("\nWTF: digit")
---,--------------------------------
anyWord8 :: TagParser Token
anyWord8 = withSize next `err` "anyWord8"
err p s = do
pos <- posGet
p `adjustErr` (++"\n"++"at "++(show pos)++": "++s)
---,--------------------------------
type Size = Integer
parseSize :: Integer -> Bool -> TagParser Size
parseSize n unsynchDecode = do
s <- count n next
posUpdate (+n)
let size = if unsynchDecode then unSynchronise s else wordsToInteger s
sizeSet size
return size
parseFlags_ :: [Int] -> TagParser [Bool]
parseFlags_ nums = do
flag <- anyWord8
sizeInc
return $ map (\i -> testBit flag (i1)) nums