module System.USB.IDDB.LinuxUsbIdRepo
    ( parseDb
    , staticDb
    , fromFile
    , fromWeb
    ) where

import Control.Monad        ( fmap )
import Data.List            ( lines, unlines, isPrefixOf )
import Data.Maybe           ( fromJust )
import Network.Download     ( openURIString )
import Numeric              ( readHex )
import Parsimony
import Parsimony.Char       ( char, hexDigit, spaces, tab )
import System.IO            ( FilePath, readFile )
import System.USB.IDDB.Base
import System.USB.IDDB.Misc ( eitherMaybe, swap, restOfLine )

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 :: String -> Maybe IDDB
parseDb = eitherMaybe . parse dbParser . stripComments
    where
      stripComments :: String -> String
      stripComments = unlines . filter (not . isPrefixOf "#") . lines

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

              return IDDB { dbVendorNameId = vendorNameId
                          , dbVendorIdName = vendorIdName
                          , dbProducts     = productDB
                          , dbClasses      = classDB
                          }
    where
      lexeme :: Parser String a -> Parser String a
      lexeme p = do x <- p
                    spaces
                    return x

      hexId :: Num n => Int -> Parser String n
      hexId d = do ds <- count d hexDigit
                   case readHex ds of
                     [(n, _)]  -> return n
                     _         -> error "impossible"

      vendorSection :: Parser String ( MP.Map VendorName VendorID
                                     , IM.IntMap VendorName
                                     , IM.IntMap ProductDB
                                     )
      vendorSection = do xs <- lexeme $ many vendorParser
                         return ( MP.fromList [(name, vid) | (vid, name, _)   <- xs]
                                , IM.fromList [(vid, name) | (vid, name, _)   <- xs]
                                , IM.fromList [(vid, pdb)  | (vid, _,    pdb) <- xs]
                                )

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

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

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

      classParser :: Parser String (ClassID, (ClassName, SubClassDB))
      classParser = do char 'C'
                       char ' '
                       cid  <- hexId 2
                       count 2 $ char ' '
                       name <- restOfLine
                       subClasses <- many subClassParser
                       return ( cid
                              , (name, IM.fromList subClasses)
                              )

      subClassParser :: Parser String (SubClassID, (SubClassName, ProtocolDB))
      subClassParser = do tab
                          scid <- hexId 2
                          count 2 $ char ' '
                          name <- restOfLine
                          protocols <- many (try protocolParser)
                          return ( scid
                                 , (name, IM.fromList protocols)
                                 )

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

-- |Construct a database from the data available at
-- <http://linux-usb.org/usb.ids>.
fromWeb :: IO (Maybe IDDB)
fromWeb = fmap ( either (const Nothing)
                        parseDb
               ) $ openURIString dbURL

-- |Load a vendor database from file. If the file can not be read for
-- some reason an error will be thrown.
fromFile :: FilePath -> IO (Maybe IDDB)
fromFile = fmap parseDb . readFile

-- |Load a database from a snapshot of the linux-usb.org database which is
--  supplied with the package.
staticDb :: IO IDDB
staticDb = getDataFileName staticDbPath >>= fmap fromJust . fromFile

staticDbPath :: FilePath
staticDbPath = "usb_id_repo_db.txt"

dbURL :: String
dbURL = "http://linux-usb.org/usb.ids"