module System.USB.IDDB.LinuxUsbIdRepo
( parseDb
, staticDb
, fromFile
, fromWeb
) where
import Control.Monad (liftM)
import Data.Encoding ( decodeStrictByteString
, encodeStrictByteString
)
import Data.Maybe (fromJust)
import Data.String.UTF8 (UTF8, fromRep)
import Network.Download (openURI)
import Numeric (readHex)
import Parsimony
import Parsimony.Char (char, hexDigit, spaces, tab)
import System.IO (FilePath)
import System.USB.IDDB.Base
import System.USB.IDDB.Misc (BSParser, eitherMaybe, restOfLine)
import qualified Codec.Binary.UTF8.String as UTF8 (encode)
import qualified Data.Bimap as BM (Bimap, fromList)
import qualified Data.ByteString as BS (ByteString, pack, readFile)
import qualified Data.Encoding.ISO88591 as Enc (ISO88591(..))
import qualified Data.Encoding.UTF8 as Enc (UTF8(..))
import qualified Data.Map as MP (Map, fromList)
parseDb :: UTF8 BS.ByteString -> Maybe IDDB
parseDb = eitherMaybe . parse dbParser
dbParser :: BSParser IDDB
dbParser = do spaces
comments
(vendorDB, productDB) <- lexeme vendorSection
comments
classDB <- classSection
return IDDB { dbVendors = vendorDB
, dbProducts = productDB
, dbClasses = classDB
}
where
utf8BS :: String -> BS.ByteString
utf8BS = BS.pack . UTF8.encode
lexeme :: BSParser a -> BSParser a
lexeme p = do x <- p
spaces
return x
comment :: BSParser String
comment = char '#' >> restOfLine
comments :: BSParser [String]
comments = many $ lexeme comment
hexId :: Num n => Int -> BSParser n
hexId d = do ds <- count d hexDigit
case readHex ds of
[(n, _)] -> return n
_ -> error "impossible"
vendorSection :: BSParser (VendorDB, MP.Map VendorID ProductDB)
vendorSection = do xs <- lexeme $ many vendorParser
return ( BM.fromList [(vid, name) | (vid, name, _) <- xs]
, MP.fromList [(vid, pdb) | (vid, _, pdb) <- xs]
)
vendorParser :: BSParser (VendorID, VendorName, BM.Bimap ProductID ProductName)
vendorParser = do vid <- hexId 4
count 2 $ char ' '
name <- restOfLine
products <- many productParser
return ( vid
, utf8BS name
, BM.fromList products
)
productParser :: BSParser (ProductID, ProductName)
productParser = do tab
pid <- hexId 4
count 2 $ char ' '
name <- restOfLine
return (pid, utf8BS name)
classSection :: BSParser ClassDB
classSection = do xs <- lexeme $ many classParser
return $ MP.fromList xs
classParser :: BSParser (ClassID, (ClassName, SubClassDB))
classParser = do char 'C'
char ' '
cid <- hexId 2
count 2 $ char ' '
name <- restOfLine
subClasses <- many subClassParser
return ( cid
, (utf8BS name, MP.fromList subClasses)
)
subClassParser :: BSParser (SubClassID, (SubClassName, ProtocolDB))
subClassParser = do tab
scid <- hexId 2
count 2 $ char ' '
name <- restOfLine
protocols <- many (try protocolParser)
return ( scid
, (utf8BS name, MP.fromList protocols)
)
protocolParser :: BSParser (ProtocolID, ProtocolName)
protocolParser = do count 2 tab
protId <- hexId 2
count 2 $ char ' '
name <- restOfLine
return (protId, utf8BS name)
fromWeb :: IO (Maybe IDDB)
fromWeb = liftM ( either (const Nothing)
(parseDb . fromRep . iso88591_to_utf8)
) $ openURI dbURL
fromFile :: FilePath -> IO (Maybe IDDB)
fromFile = liftM (parseDb . fromRep . iso88591_to_utf8) . BS.readFile
iso88591_to_utf8 :: BS.ByteString -> BS.ByteString
iso88591_to_utf8 = encodeStrictByteString Enc.UTF8
. decodeStrictByteString Enc.ISO88591
staticDb :: IO IDDB
staticDb = getDataFileName staticDbPath >>= liftM fromJust . fromFile
staticDbPath :: FilePath
staticDbPath = "usb_id_repo_db.txt"
dbURL :: String
dbURL = "http://linux-usb.org/usb.ids"