diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for browsercap + +## 0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, davean + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of davean nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/browscap.cabal b/browscap.cabal new file mode 100644 --- /dev/null +++ b/browscap.cabal @@ -0,0 +1,40 @@ +-- Initial browsercap.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: browscap +version: 0 +synopsis: A reader and interface for the Browser Capabilities Project data files. +description: A reader and interface for the Browser Capabilities Project data files. Currently it uses a linear matcher which is slow. +homepage: https://oss.xkcd.com +license: BSD3 +license-file: LICENSE +author: davean +maintainer: oss@xkcd.com +copyright: davean 2012-2017 +category: Web, Data +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +source-repository head + type: git + location: https://code.xkrd.net/haskell/browscap.git + +library + default-language: Haskell2010 + hs-source-dirs: src + exposed-modules: + Data.BrowsCap + , Data.BrowsCap.Aquire + build-depends: + base >=4.9 && <4.11 + , bytestring >= 0.10 && < 0.11 + , text >= 1.2 && < 1.3 + , unordered-containers >= 0.2 && < 0.3 + , lrucache >= 1.2 && < 1.3 + , deepseq >= 1.4 && < 1.5 + , lens >= 4.15 && < 4.16 + , wreq >= 0.5 && < 0.6 + , mtl >= 2.2 && < 2.3 + , ini >= 0.3 && < 0.4 + diff --git a/src/Data/BrowsCap.hs b/src/Data/BrowsCap.hs new file mode 100644 --- /dev/null +++ b/src/Data/BrowsCap.hs @@ -0,0 +1,317 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE LambdaCase #-} +module Data.BrowsCap ( + BrowsCap(..) + , BrowserEntry(..) + , BrowserType(..), DeviceType(..), PointingMethod(..), BitCount(..) + , loadBrowsCap + , lookupBrowser + ) where + +import Control.DeepSeq +import Control.Monad +import Control.Monad.Except +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import qualified Data.HashSet as Set +import qualified Data.HashMap.Strict as HM +import qualified Data.Cache.LRU.IO as LRU +import qualified Data.Ini as Ini +import Data.Maybe +import Data.Cache.LRU.IO (AtomicLRU) +import Data.List +import GHC.Generics + +data BrowsCap = BrowsCap { + bcEntries :: ![BrowserEntry] + , bcCache :: AtomicLRU BS.ByteString BrowserEntry + } + +data MatchPart = + TPart !T.Text + | One + | Many + deriving (Eq, Ord, Show, Read, Generic, NFData) + +data BrowserType + = Browser + | Application + | BotCrawler + | UseragentAnonymizer + | OfflineBrowser + | MultimediaPlayer + | Library + | FeedReader + | EmailClient + | Tool + | BrowserTypeUnknown + deriving (Read, Show, Eq, Ord, Generic, NFData) + +readBrowserType :: T.Text -> Except String BrowserType +readBrowserType "Browser" = return Browser +readBrowserType "Application" = return Application +readBrowserType "Bot/Crawler" = return BotCrawler +readBrowserType "Useragent Anonymizer" = return UseragentAnonymizer +readBrowserType "Offline Browser" = return OfflineBrowser +readBrowserType "Multimedia Player" = return MultimediaPlayer +readBrowserType "Library" = return Library +readBrowserType "Feed Reader" = return FeedReader +readBrowserType "Email Client" = return EmailClient +readBrowserType "Tool" = return Tool +readBrowserType "unknown" = return BrowserTypeUnknown +readBrowserType bt = throwError $ "Unspecified browser type: "++T.unpack bt + +data DeviceType + = DeviceMobilePhone + | DeviceMobileDevice + | DeviceTablet + | DeviceDesktop + | DeviceTV + | DeviceConsole + | DeviceFonePad + | DeviceEbookReader + | DeviceCarEntertainmentSystem + | DeviceDigitalCamera + | DeviceUnknown + deriving (Read, Show, Eq, Ord, Generic, NFData) + +readDeviceType :: T.Text -> Except String DeviceType +readDeviceType "Mobile Phone" = return DeviceMobilePhone +readDeviceType "Mobile Device" = return DeviceMobileDevice +readDeviceType "Tablet" = return DeviceTablet +readDeviceType "Desktop" = return DeviceDesktop +readDeviceType "TV Device" = return DeviceTV +readDeviceType "Console" = return DeviceConsole +readDeviceType "FonePad" = return DeviceFonePad +readDeviceType "Ebook Reader" = return DeviceEbookReader +readDeviceType "Car Entertainment System" = return DeviceCarEntertainmentSystem +readDeviceType "Digital Camera" = return DeviceDigitalCamera +readDeviceType "unknown" = return DeviceUnknown +readDeviceType d = throwError $ "Unlisted DeviceType: " ++ T.unpack d + +data PointingMethod + = Mouse + | Touchscreen + | Joystick + | Stylus + | Clickwheel + | Trackpad + | Trackball + | PointingDeviceUnknown + deriving (Read, Show, Eq, Ord, Generic, NFData) + +readPointingMethod :: T.Text -> Except String PointingMethod +readPointingMethod "mouse" = return Mouse +readPointingMethod "touchscreen" = return Touchscreen +readPointingMethod "joystick" = return Joystick +readPointingMethod "stylus" = return Stylus +readPointingMethod "clickwheel" = return Clickwheel +readPointingMethod "trackpad" = return Trackpad +readPointingMethod "trackball" = return Trackball +readPointingMethod "unknown" = return PointingDeviceUnknown +readPointingMethod pm = throwError $ "Unlisted pointing method: "++T.unpack pm + +data BitCount + = Bits0 + | Bits8 + | Bits16 + | Bits32 + | Bits64 + deriving (Read, Show, Eq, Ord, Generic, NFData) + +readBitCount :: T.Text -> Except String BitCount +readBitCount "0" = return Bits0 +readBitCount "8" = return Bits8 +readBitCount "16" = return Bits16 +readBitCount "32" = return Bits32 +readBitCount "64" = return Bits64 +readBitCount b = throwError $ "Invalid bit count: " ++ T.unpack b + +data BrowserEntry = + BrowserEntry + { beUserAgent :: !T.Text + , beUserAgentMatcher :: ![MatchPart] + + , beBrowser :: !T.Text + , beBrowserType :: !BrowserType + , beBrowserBits :: !BitCount + , beBrowserMaker :: !T.Text + -- Modus skipped + , beVersion :: !T.Text + , beMajorVer :: !T.Text + , beMinorVer :: !T.Text + , bePlatform :: !T.Text + , bePlatformVersion :: !T.Text + , bePlatformDescription :: !T.Text + , bePlatformBits :: !BitCount + , bePlatformMaker :: !T.Text + , beSyndicationReader :: !Bool + , beCSSVersion :: !T.Text + , beDeviceName :: !T.Text + , beDeviceMaker :: !T.Text + , beDeviceType :: !DeviceType + , beDevicePointingMethod :: !PointingMethod + , beDeviceCodeName :: !T.Text + , beDeviceBrandName :: !T.Text + , beRenderingEngineName :: !T.Text + , beRenderingEngineVer :: !T.Text + , beRenderingEngineDesc :: !T.Text + , beRenderingEngineMaker :: !T.Text + } deriving (Eq, Ord, Show, Read, Generic, NFData) + +-- This would be faster if it returned a list of offsets +-- and took the origional string and dropped the already-matched length. +-- That is because it would improve match simplification. +nextOptions :: [MatchPart] -> T.Text -> [T.Text] +nextOptions ((TPart t0):_) rest = maybeToList $ T.stripPrefix t0 rest +nextOptions (Many:(TPart t0):_) rest = map snd $ T.breakOnAll t0 rest +nextOptions (One:_) rest = maybeToList $ fmap snd $ T.uncons rest +nextOptions [Many] _ = [""] +nextOptions [] rest = if T.null rest then [""] else [] +nextOptions mp _ = error $ "Failed match: " ++ show mp + +isMatch :: T.Text -> [MatchPart] -> Bool +isMatch t mparts = + let finalEnds = foldl (\ends mp -> concatMap (Set.toList . Set.fromList . nextOptions mp) ends) [t] $ tails mparts + in "" `elem` finalEnds + +toMatcher :: T.Text -> [MatchPart] +toMatcher t = + optimize $ map toMatchPart $ T.unpack t + where + toMatchPart '?' = One + toMatchPart '*' = Many + toMatchPart c = TPart (T.pack [c]) + optimize ((TPart t0):(TPart t1):r) = optimize ((TPart (t0 `T.append` t1)):r) + optimize (Many:Many:r) = optimize (Many : r) + optimize (One:Many:r) = optimize (Many : r) + optimize (Many:One:r) = optimize (Many : r) + optimize (x:xs) = x : optimize xs + optimize [] = [] + +lookupBrowser :: BrowsCap -> BS.ByteString -> IO (Maybe BrowserEntry) +lookupBrowser BrowsCap {bcEntries=entries, bcCache=cacheRef} ua = do + cache <- LRU.lookup ua cacheRef + case cache of + Just be -> return $ Just be + Nothing -> do + case bestMatching of + Nothing -> return Nothing + Just be -> do + LRU.insert ua be cacheRef + return $ Just be + where + bestMatching = listToMaybe $ map snd $ sortBy cmpByFst $ map (\be -> (T.length $ beUserAgent be, be)) allMatching + allMatching = mapMaybe match entries + cmpByFst a b = compare (fst b) (fst a) + match :: BrowserEntry -> Maybe BrowserEntry + match be = + if isMatch (TE.decodeUtf8 ua) $ beUserAgentMatcher be + then Just be + else Nothing + +loadBrowsCap :: T.Text -> IO BrowsCap +loadBrowsCap txt = do + case runExcept ((either throwError return $ Ini.parseIni txt) >>= convertShims) of + Left err -> fail err + Right bces -> do + bccR <- LRU.newAtomicLRU (Just 16) + bces `deepseq` return $ + BrowsCap { bcEntries = bces + , bcCache = bccR + } + +convertShims :: Ini.Ini -> Except String [BrowserEntry] +convertShims dPlusVer = + mapM buildBE . HM.keys $ d + where + d = HM.delete "GJK_Browscap_Version" . Ini.unIni $ dPlusVer + mErr :: String -> Maybe a -> Except String a + mErr err Nothing = throwError err + mErr _ (Just a) = return a + sectionValue :: T.Text -> T.Text -> Maybe T.Text + sectionValue s v = + fmap dropQuotes . join . fmap (HM.lookup v) . HM.lookup s $ d + beVal :: T.Text -> T.Text -> Except String T.Text + beVal b v | b == "DefaultProperties" = + mErr ("Could not find "++T.unpack v++" for "++T.unpack b) . sectionValue b $ v + | otherwise = do + -- All non-DefaultProperty entries must have a parent. + p <- mErr ("Could not find Parent for "++T.unpack b) . sectionValue b $ "Parent" + maybe (beVal p v) (return) . sectionValue b $ v + readBool :: T.Text -> Except String Bool + readBool "true" = return True + readBool "false" = return False + readBool o = throwError $ "Bool format invalid: "++T.unpack o + -- If the value is eclosed in quotes, remove them + dropQuotes :: T.Text -> T.Text + dropQuotes = T.dropWhile (=='"') . T.dropWhileEnd (=='"') + buildBE :: T.Text -> Except String BrowserEntry + buildBE a = do + browser <- beVal a "Browser" + bType <- readBrowserType =<< beVal a "Browser_Type" + bBits <- readBitCount =<< beVal a "Browser_Bits" + bMaker <- beVal a "Browser_Maker" + + ver <- beVal a "Version" + verMaj <- beVal a "MajorVer" + verMin <- beVal a "MinorVer" + + plat <- beVal a "Platform" + platVer <- beVal a "Platform_Version" + platDesc <- beVal a "Platform_Description" + platBits <- readBitCount =<< beVal a "Platform_Bits" + platMaker <- beVal a "Platform_Maker" + + synd <- readBool =<< beVal a "isSyndicationReader" + cssVer <- beVal a "CssVersion" + + devName <- beVal a "Device_Name" + devMaker <- beVal a "Device_Maker" + devType <- readDeviceType =<< beVal a "Device_Type" + devPointMeth <- readPointingMethod =<< beVal a "Device_Pointing_Method" + devCodeName <- beVal a "Device_Code_Name" + devBrand <- beVal a "Device_Brand_Name" + + rendName <- beVal a "RenderingEngine_Name" + rendVer <- beVal a "RenderingEngine_Version" + rendDesc <- beVal a "RenderingEngine_Description" + rendMaker <- beVal a "RenderingEngine_Maker" + + return $ BrowserEntry + { beUserAgent = a + , beUserAgentMatcher = toMatcher a + + , beBrowser = browser + , beBrowserType = bType + , beBrowserBits = bBits + , beBrowserMaker = bMaker + + , beVersion = ver + , beMajorVer = verMaj + , beMinorVer = verMin + + , bePlatform = plat + , bePlatformVersion = platVer + , bePlatformDescription = platDesc + , bePlatformBits = platBits + , bePlatformMaker = platMaker + + , beSyndicationReader = synd + , beCSSVersion = cssVer + + , beDeviceName = devName + , beDeviceMaker = devMaker + , beDeviceType = devType + , beDevicePointingMethod = devPointMeth + , beDeviceCodeName = devCodeName + , beDeviceBrandName = devBrand + + , beRenderingEngineName = rendName + , beRenderingEngineVer = rendVer + , beRenderingEngineDesc = rendDesc + , beRenderingEngineMaker = rendMaker + } diff --git a/src/Data/BrowsCap/Aquire.hs b/src/Data/BrowsCap/Aquire.hs new file mode 100644 --- /dev/null +++ b/src/Data/BrowsCap/Aquire.hs @@ -0,0 +1,18 @@ +module Data.BrowsCap.Aquire ( + browsCapFromFile + , browsCapFromWeb + ) where + +import Control.Lens +import Data.BrowsCap +import qualified Data.Text.IO as TIO +import Data.Text.Lazy.Lens +import qualified Network.Wreq as Wreq + +browsCapFromFile :: FilePath -> IO BrowsCap +browsCapFromFile fp = loadBrowsCap =<< TIO.readFile fp + +browsCapFromWeb :: IO BrowsCap +browsCapFromWeb = do + r <- Wreq.get "http://browscap.org/stream?q=Full_PHP_BrowsCapINI" + loadBrowsCap (r ^. Wreq.responseBody.utf8.strict)