module ID3.Parser.General where
import Text.ParserCombinators.Poly.State (Parser, runParser, stGet, stUpdate, onFail, next,
satisfy, adjustErr)
import ID3.Parser.UnSync
import ID3.Type.Header (TagVersion, TagFlags(..))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C
import Data.Word (Word8)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf16LE, decodeUtf16BE, decodeUtf8)
import Data.Char (chr)
import Control.Monad (when)
---,--------------------------------
type Token = Word8
data St = State { id3TagVersion :: TagVersion
, headerFlags :: TagFlags
, tagPos :: Integer
, curSize :: Integer
}
instance Show St where
show st = show (tagPos st, curSize st)
initState :: St
initState = State (4, 0) (TagFlags (False, False, False, False)) 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 TagFlags
flagsGet = stGet >>= return . headerFlags
flagsSet :: TagFlags -> 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 :: TagParser b -> TagParser b
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))
---,--------------------------------
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, Eq 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, Eq 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, Eq 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 = map (chr . fromIntegral) 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 :: Parser St Token Token
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 :: Integer) 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 :: TagParser t -> String -> TagParser t
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