browscap (empty) → 0
raw patch · 6 files changed
+412/−0 lines, 6 filesdep +basedep +bytestringdep +deepseqsetup-changed
Dependencies added: base, bytestring, deepseq, ini, lens, lrucache, mtl, text, unordered-containers, wreq
Files
- ChangeLog.md +5/−0
- LICENSE +30/−0
- Setup.hs +2/−0
- browscap.cabal +40/−0
- src/Data/BrowsCap.hs +317/−0
- src/Data/BrowsCap/Aquire.hs +18/−0
+ ChangeLog.md view
@@ -0,0 +1,5 @@+# Revision history for browsercap++## 0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ browscap.cabal view
@@ -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+
+ src/Data/BrowsCap.hs view
@@ -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+ }
+ src/Data/BrowsCap/Aquire.hs view
@@ -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)