Skip to content

Commit

Permalink
Replaced ByteStrings with Strings (3x faster parsing), Added Binary i…
Browse files Browse the repository at this point in the history 
…nstance for IDDB

Ignore-this: 73db464310212ab1d718f18da5f04ff9

darcs-hash:20090911150212-b004c-d2e3406e6fa212cb1d87a27c8f7fb12c901dfb83.gz
  • Loading branch information
@roelvandijk
roelvandijk committed Sep 11, 2009
1 parent 99cc0b0 commit 570db27
Show file tree
Hide file tree
Showing 6 changed files with 141 additions and 118 deletions.
79 changes: 52 additions & 27 deletions System/USB/IDDB/Base.hs
View file
Expand Up @@ -3,7 +3,7 @@
module System.USB.IDDB.Base
( IDDB(..)

, VendorID, VendorName, VendorDB
, VendorID, VendorName
, ProductID, ProductName, ProductDB
, ClassID, ClassName, ClassDB
, SubClassID, SubClassName, SubClassDB
Expand All @@ -23,10 +23,10 @@ module System.USB.IDDB.Base
)
where

import Data.ByteString (ByteString)
import Data.Binary (Binary(..), Get)

import qualified Data.Bimap as BM
import qualified Data.Map as MP
import qualified Data.IntMap as IM
import qualified Data.Map as MP

#ifdef BUILD_WITH_CABAL
import Paths_usb_id_database (getDataFileName)
Expand All @@ -40,7 +40,7 @@ getDataFileName = return
-------------------------------------------------------------------------------

type ID = Int
type Name = ByteString
type Name = String

type VendorID = ID
type ProductID = ID
Expand All @@ -54,52 +54,77 @@ type ClassName = Name
type SubClassName = Name
type ProtocolName = Name

type VendorDB = BM.Bimap VendorID VendorName
type ProductDB = BM.Bimap ProductID ProductName
type ClassDB = MP.Map ClassID (ClassName, SubClassDB)
type SubClassDB = MP.Map SubClassID (SubClassName, ProtocolDB)
type ProtocolDB = MP.Map ProtocolID ProtocolName
type ProductDB = ( MP.Map ProductName ProductID
, IM.IntMap ProductName
)
type ClassDB = IM.IntMap (ClassName, SubClassDB)
type SubClassDB = IM.IntMap (SubClassName, ProtocolDB)
type ProtocolDB = IM.IntMap ProtocolName

-- |A database of USB identifiers. Contains both vendor identifiers
-- and product identifiers.
data IDDB = IDDB { dbVendors :: VendorDB
, dbProducts :: MP.Map VendorID ProductDB
, dbClasses :: ClassDB
data IDDB = IDDB { dbVendorNameId :: MP.Map VendorName VendorID
, dbVendorIdName :: IM.IntMap VendorName
, dbProducts :: IM.IntMap ProductDB
, dbClasses :: ClassDB
}

-- |An empty database./
-- |An empty database.
emptyDb :: IDDB
emptyDb = IDDB { dbVendors = BM.empty
, dbProducts = MP.empty
, dbClasses = MP.empty
emptyDb = IDDB { dbVendorNameId = MP.empty
, dbVendorIdName = IM.empty
, dbProducts = IM.empty
, dbClasses = IM.empty
}

-------------------------------------------------------------------------------
-- Binary serialisation
-------------------------------------------------------------------------------

instance Binary IDDB where
put db = put ( dbVendorNameId db
, dbVendorIdName db
, dbProducts db
, dbClasses db
)

get = do (a, b, c, d) <- get :: Get ( MP.Map VendorName VendorID
, IM.IntMap VendorName
, IM.IntMap ProductDB
, ClassDB
)
return $ IDDB { dbVendorNameId = a
, dbVendorIdName = b
, dbProducts = c
, dbClasses = d
}

-------------------------------------------------------------------------------
-- Query database
-------------------------------------------------------------------------------

vendorName :: IDDB -> VendorID -> Maybe VendorName
vendorName db vid = BM.lookup vid $ dbVendors db
vendorName db vid = IM.lookup vid $ dbVendorIdName db

vendorId :: IDDB -> VendorName -> Maybe VendorID
vendorId db name = BM.lookupR name $ dbVendors db
vendorId db name = MP.lookup name $ dbVendorNameId db

productName :: IDDB -> VendorID -> ProductID -> Maybe ProductName
productName db vid pid = BM.lookup pid =<< MP.lookup vid (dbProducts db)
productName db vid pid = IM.lookup pid . snd =<< IM.lookup vid (dbProducts db)

productId :: IDDB -> VendorID -> ProductName -> Maybe ProductID
productId db vid name = BM.lookupR name =<< MP.lookup vid (dbProducts db)
productId db vid name = MP.lookup name . fst =<< IM.lookup vid (dbProducts db)

className :: IDDB -> ClassID -> Maybe ClassName
className db cid = fmap fst $ MP.lookup cid $ dbClasses db
className db cid = fmap fst $ IM.lookup cid $ dbClasses db

subClassName :: IDDB -> ClassID -> SubClassID -> Maybe SubClassName
subClassName db cid scid = fmap fst $ MP.lookup scid . snd
=<< MP.lookup cid (dbClasses db)
subClassName db cid scid = fmap fst $ IM.lookup scid . snd
=<< IM.lookup cid (dbClasses db)

protocolName :: IDDB -> ClassID -> SubClassID -> ProtocolID -> Maybe ProtocolName
protocolName db cid scid protId = MP.lookup protId . snd
=<< MP.lookup scid . snd
=<< MP.lookup cid (dbClasses db)
protocolName db cid scid protId = IM.lookup protId . snd
=<< IM.lookup scid . snd
=<< IM.lookup cid (dbClasses db)


90 changes: 41 additions & 49 deletions System/USB/IDDB/LinuxUsbIdRepo.hs
View file
Expand Up @@ -6,132 +6,124 @@ module System.USB.IDDB.LinuxUsbIdRepo
) 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 Network.Download (openURIString)
import Numeric (readHex)
import Parsimony
import Parsimony.Char (char, hexDigit, spaces, tab)
import System.IO (FilePath)
import System.IO (FilePath, readFile)
import System.USB.IDDB.Base
import System.USB.IDDB.Misc (BSParser, eitherMaybe, restOfLine)
import System.USB.IDDB.Misc (eitherMaybe, swap, 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)
import qualified Data.IntMap as IM (IntMap, fromList)
import qualified Data.Map as MP (Map, fromList)


-- |Construct a database from a string in the format used by
-- <http://linux-usb.org>.
parseDb :: UTF8 BS.ByteString -> Maybe IDDB
parseDb :: String -> Maybe IDDB
parseDb = eitherMaybe . parse dbParser

dbParser :: BSParser IDDB
dbParser :: Parser String IDDB
dbParser = do spaces
comments
(vendorDB, productDB) <- lexeme vendorSection
(vendorNameId, vendorIdName, productDB) <- lexeme vendorSection
comments
classDB <- classSection

return IDDB { dbVendors = vendorDB
, dbProducts = productDB
, dbClasses = classDB
return IDDB { dbVendorNameId = vendorNameId
, dbVendorIdName = vendorIdName
, dbProducts = productDB
, dbClasses = classDB
}
where
utf8BS :: String -> BS.ByteString
utf8BS = BS.pack . UTF8.encode

lexeme :: BSParser a -> BSParser a
lexeme :: Parser String a -> Parser String a
lexeme p = do x <- p
spaces
return x

comment :: BSParser String
comment :: Parser String String
comment = char '#' >> restOfLine

comments :: BSParser [String]
comments :: Parser String [String]
comments = many $ lexeme comment

hexId :: Num n => Int -> BSParser n
hexId :: Num n => Int -> Parser String 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 :: Parser String ( MP.Map VendorName VendorID
, IM.IntMap VendorName
, IM.IntMap ProductDB
)
vendorSection = do xs <- lexeme $ many vendorParser
return ( BM.fromList [(vid, name) | (vid, name, _) <- xs]
, MP.fromList [(vid, pdb) | (vid, _, pdb) <- xs]
return ( MP.fromList [(name, vid) | (vid, name, _) <- xs]
, IM.fromList [(vid, name) | (vid, name, _) <- xs]
, IM.fromList [(vid, pdb) | (vid, _, pdb) <- xs]
)

vendorParser :: BSParser (VendorID, VendorName, BM.Bimap ProductID ProductName)
vendorParser :: Parser String (VendorID, VendorName, ProductDB)
vendorParser = do vid <- hexId 4
count 2 $ char ' '
name <- restOfLine
products <- many productParser
return ( vid
, utf8BS name
, BM.fromList products
, name
, ( MP.fromList $ map swap products
, IM.fromList products
)
)

productParser :: BSParser (ProductID, ProductName)
productParser :: Parser String (ProductID, ProductName)
productParser = do tab
pid <- hexId 4
count 2 $ char ' '
name <- restOfLine
return (pid, utf8BS name)
return (pid, name)

classSection :: BSParser ClassDB
classSection :: Parser String ClassDB
classSection = do xs <- lexeme $ many classParser
return $ MP.fromList xs
return $ IM.fromList xs

classParser :: BSParser (ClassID, (ClassName, SubClassDB))
classParser :: Parser String (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)
, (name, IM.fromList subClasses)
)

subClassParser :: BSParser (SubClassID, (SubClassName, ProtocolDB))
subClassParser :: Parser String (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)
, (name, IM.fromList protocols)
)

protocolParser :: BSParser (ProtocolID, ProtocolName)
protocolParser :: Parser String (ProtocolID, ProtocolName)
protocolParser = do count 2 tab
protId <- hexId 2
count 2 $ char ' '
name <- restOfLine
return (protId, utf8BS name)
return (protId, name)

-- |Construct a database from the data available at
-- <http://linux-usb.org/usb.ids>.
fromWeb :: IO (Maybe IDDB)
fromWeb = liftM ( either (const Nothing)
(parseDb . fromRep . iso88591_to_utf8)
) $ openURI dbURL
parseDb
) $ openURIString 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
fromFile = liftM parseDb . readFile

staticDb :: IO IDDB
staticDb = getDataFileName staticDbPath >>= liftM fromJust . fromFile
Expand Down
15 changes: 7 additions & 8 deletions System/USB/IDDB/Misc.hs
View file
@@ -1,20 +1,19 @@
module System.USB.IDDB.Misc
( BSParser
, eitherMaybe
( eitherMaybe
, swap
, restOfLine
) where

import Data.ByteString (ByteString)
import Data.String.UTF8 (UTF8)
import Parsimony (Parser, manyTill)
import Parsimony.Char (anyChar, newline)


type BSParser = Parser (UTF8 ByteString)


eitherMaybe :: Either e a -> Maybe a
eitherMaybe = either (const Nothing) Just

restOfLine :: BSParser String
swap :: (a, b) -> (b, a)
swap = uncurry $ flip (,)

restOfLine :: Parser String String
restOfLine = manyTill anyChar newline

0 comments on commit 570db27

Please sign in to comment.