module ID3.Type.Frame where
import Data.Accessor
import Data.Accessor.Basic (compose)
import ID3.Type.Flags
import ID3.Type.Unparse
import ID3.Type.FrameInfo
import Numeric
import Data.Char
import Data.Word
data ID3Frame = ID3Frame
{ frHeader_ :: FrameHeader
, frInfo_ :: FrameInfo
} deriving Eq
emptyID3Frame :: ID3Frame
emptyID3Frame = ID3Frame emptyFrameHeader (Unknown [])
initID3Frame :: [ID3Frame -> ID3Frame] -> ID3Frame
initID3Frame = flip compose emptyID3Frame
frHeader :: Accessor ID3Frame FrameHeader
frHeader = accessor frHeader_ (\x fr -> fr {frHeader_ = x})
frInfo :: Accessor ID3Frame FrameInfo
frInfo = accessor frInfo_ (\x fr -> fr {frInfo_ = x})
instance HasSize ID3Frame where
size = accessor (toInteger . length . unparse . getVal frInfo) (setVal $ frHeader .> frSize)
textContent :: Accessor ID3Frame String
textContent = frInfo .> infoTextContent
instance Show ID3Frame where
show fr = (show $ fr^.frHeader) ++"\n"++
(show $ fr^.frInfo )++"\n"
instance Parsed ID3Frame where
unparse fr = (unparse $ fr^.frHeader) ++
(unparse $ fr^.frInfo )
type FrameName = String
data FrameHeader = FrameHeader
{ frID_ :: FrameID
, frSize_ :: FrameSize
, frFlags_ :: FrameFlags
} deriving Eq
emptyFrameHeader :: FrameHeader
emptyFrameHeader = FrameHeader "" 0 emptyFrameFlags
initFrameHeader :: [FrameHeader -> FrameHeader] -> FrameHeader
initFrameHeader = flip compose emptyFrameHeader
frID :: Accessor FrameHeader FrameID
frID = accessor frID_ (\x h -> h {frID_ = x})
frSize :: Accessor FrameHeader FrameSize
frSize = accessor frSize_ (\x h -> h {frSize_ = x})
frFlags :: Accessor FrameHeader FrameFlags
frFlags = accessor frFlags_ (\x h -> h {frFlags_ = x})
instance Show FrameHeader where
show (FrameHeader i s fs) = "\tFrame ID:\t"++i++"\n"++
"\tFrame size:\t"++(show s)++
(show fs)
instance Parsed FrameHeader where
unparse fh = (unparse $ Str $ fh^.frID ) ++
(unparse $ fh^.frSize ) ++
(unparse $ fh^.frFlags )
type FrameID = String
type FrameSize = Integer
data FrameFlags = FrameFlags
{ statusFlags_ :: StatusFlags
, formatFlags_ :: FormatFlags
} deriving Eq
emptyFrameFlags :: FrameFlags
emptyFrameFlags = FrameFlags (StatusFlags 4 (False, False, False))
(FormatFlags 4 (False, False, False, False, False))
initFrameFlags :: [FrameFlags -> FrameFlags] -> FrameFlags
initFrameFlags = flip compose emptyFrameFlags
statusFlags :: Accessor FrameFlags StatusFlags
statusFlags = accessor statusFlags_ (\x fs -> fs {statusFlags_ = x})
formatFlags :: Accessor FrameFlags FormatFlags
formatFlags = accessor formatFlags_ (\x fs -> fs {formatFlags_ = x})
instance Show FrameFlags where
show fs = if not ((anyStatusFlagsOn $ fs^.statusFlags) || (anyFormatFlagsOn $ fs^.formatFlags))
then "" else
"\tFlags " ++ (showBinary $ unparse $ fs^.statusFlags) ++
" " ++ (showBinary $ unparse $ fs^.formatFlags) ++ ":\n"++
(showStatusFlags $ fs^.statusFlags) ++ "\n" ++
(showFormatFlags $ fs^.formatFlags)
instance Parsed FrameFlags where
unparse fs = (unparse $ fs^.statusFlags) ++ (unparse $ fs^.formatFlags)
data StatusFlags = StatusFlags Word8 (Bool, Bool, Bool) deriving Eq
frameDiscardFlag :: StatusFlags -> Bool
frameDiscardFlag (StatusFlags _ (a, _, _)) = a
fileDiscardFlag :: StatusFlags -> Bool
fileDiscardFlag (StatusFlags _ (_, b, _)) = b
readOnlyFlag :: StatusFlags -> Bool
readOnlyFlag (StatusFlags _ (_, _, c)) = c
anyStatusFlagsOn :: StatusFlags -> Bool
anyStatusFlagsOn (StatusFlags _ (a, b, c)) = a || b || c
showBinary :: [Word8] -> String
showBinary [n] =
pad $ showIntAtBase 2 intToDigit n ""
where
pad s = replicate (8 length s) '0' ++ s
showBinary _ = error "internal error: flags unparsed incorrectly"
showStatusFlags :: StatusFlags -> String
showStatusFlags stat = if not (anyStatusFlagsOn stat) then "" else "\t\tStatus Flags:\n" ++ finfo
where finfo = (if frameDiscardFlag stat then "\t\t\t- Frame should be discarded when tag is altered\n" else "") ++
(if fileDiscardFlag stat then "\t\t\t- Frame should be discarded when file contents are altered\n" else "") ++
(if readOnlyFlag stat then "\t\t\t- Frame is read only!\n" else "")
instance Parsed StatusFlags where
unparse (StatusFlags v (a, b, c)) =
case v of
3 -> [flagsToWord8 (a, b, c, False, False, False, False, False)]
4 -> [flagsToWord8 (False, a, b, c, False, False, False, False)]
_ -> [0]
data FormatFlags = FormatFlags Word8 (Bool, Bool, Bool, Bool, Bool) deriving Eq
groupPartFlag :: FormatFlags -> Bool
groupPartFlag (FormatFlags _ (h, _, _, _, _)) = h
compressedFlag :: FormatFlags -> Bool
compressedFlag (FormatFlags _ (_, k, _, _, _)) = k
encryptedFlag :: FormatFlags -> Bool
encryptedFlag (FormatFlags _ (_, _, m, _, _)) = m
unsychronisedFlag :: FormatFlags -> Bool
unsychronisedFlag (FormatFlags _ (_, _, _, n, _)) = n
dataLengthIdFlag :: FormatFlags -> Bool
dataLengthIdFlag (FormatFlags _ (_, _, _, _, p)) = p
anyFormatFlagsOn :: FormatFlags -> Bool
anyFormatFlagsOn (FormatFlags _ (h, k, m, n, p)) = h || k || m || n || p
showFormatFlags :: FormatFlags -> String
showFormatFlags fs = if not (anyFormatFlagsOn fs) then "" else finfo
where finfo = "\t\tFormat Flags:\n" ++ (concat $ map (\i -> "\t\t\t- " ++ i ++ "\n") items)
items = [] ++
(if groupPartFlag fs then ["frame is a part of group"] else []) ++
(if compressedFlag fs then ["frame is compressed"] else []) ++
(if encryptedFlag fs then ["frame is encrypted"] else []) ++
(if unsychronisedFlag fs then ["frame is unsynchronised"] else []) ++
(if dataLengthIdFlag fs then ["frame has data length indicator"] else [])
instance Parsed FormatFlags where
unparse (FormatFlags v (h, k, m, n, p)) =
case v of
3 -> [flagsToWord8 (k, m, h, False, False, False, False, False)]
4 -> [flagsToWord8 (False, h, False, False, k, m, n, p)]
_ -> [0]
initFrame :: FrameID -> ID3Frame
initFrame frid = updateSize $ initID3Frame [ frHeader.>frID ^= frid, frInfo ^= inf ]
where inf = case frid of
"UFID" -> UFID "" []
"TXXX" -> TXXX 03 "" ""
"TCMP" -> TCMP False
('T':_)-> Text 03 ""
"WXXX" -> WXXX 03 "" ""
('W':_)-> URL ""
"MCDI" -> MCDI []
"USLT" -> USLT 03 "eng" "" ""
"COMM" -> COMM 03 "eng" "" ""
"APIC" -> APIC 03 "" 00 "" []
"PCNT" -> PCNT 00
"POPM" -> POPM "" 00 00
"USER" -> USER 03 "eng" ""
"PRIV" -> PRIV "" []
_ -> Unknown []