ua-parser 0.4 → 0.5
raw patch · 5 files changed
+344/−332 lines, 5 filesdep +file-embed
Dependencies added: file-embed
Files
- regexes.yaml +125/−47
- src/Web/UAParser.hs +202/−19
- src/Web/UAParser/Core.hs +0/−243
- test/src/TestSuite.hs +11/−14
- ua-parser.cabal +6/−9
regexes.yaml view
@@ -60,10 +60,13 @@ - regex: '(Opera Tablet).*Version/(\d+)\.(\d+)(?:\.(\d+))?' - regex: '(Opera)/.+Opera Mobi.+Version/(\d+)\.(\d+)' family_replacement: 'Opera Mobile'+ - regex: '(Opera)/(\d+)\.(\d+).+Opera Mobi'+ family_replacement: 'Opera Mobile'+ - regex: 'Opera Mobi.+(Opera)/(\d+)\.(\d+)'+ family_replacement: 'Opera Mobile' - regex: 'Opera Mobi' family_replacement: 'Opera Mobile'- - regex: '(Opera Mini)/(\d+)\.(\d+)'- - regex: '(Opera Mini)/att/(\d+)\.(\d+)'+ - regex: '(Opera Mini)(?:/att)?/(\d+)\.(\d+)' - regex: '(Opera)/9.80.*Version/(\d+)\.(\d+)(?:\.(\d+))?' # Opera 14 for Android uses a WebKit render engine.@@ -82,7 +85,7 @@ # http://luakit.org/projects/luakit/ - regex: '(luakit)' family_replacement: 'LuaKit'- + # Snowshoe - regex: '(Snowshoe)/(\d+)\.(\d+).(\d+)' @@ -157,15 +160,11 @@ family_replacement: 'Baidu Explorer' # QQ Browsers- - regex: '(MQQBrowser)/(\d+)\.(\d+)\.(\d+)'- family_replacement: 'QQ Browser Mobile'- - regex: '(MQQBrowser)/(\d+)\.(\d+)'- family_replacement: 'QQ Browser Mobile'- - regex: '(QQBrowser)/(\d+)\.(\d+)\.(\d+)\.(\d+)'- family_replacement: 'QQ Browser'- - regex: 'MQQBrowser'+ - regex: '(MQQBrowser/Mini)(?:(\d+)(?:\.(\d+)(?:\.(\d+))?)?)?'+ family_replacement: 'QQ Browser Mini'+ - regex: '(MQQBrowser)(?:/(\d+)(?:\.(\d+)(?:\.(\d+))?)?)?' family_replacement: 'QQ Browser Mobile'- - regex: 'QQBrowser'+ - regex: '(QQBrowser)(?:/(\d+)(?:\.(\d+)\.(\d+)(?:\.(\d+))?)?)?' family_replacement: 'QQ Browser' # Pingdom@@ -238,8 +237,12 @@ # Chrome/Chromium/major_version.minor_version.beta_version - regex: '(Chromium|Chrome)/(\d+)\.(\d+)\.(\d+)' + # Dolphin Browser + # @ref: http://www.dolphin.com+ - regex: '\b(Dolphin)(?: |HDCN/|/INT\-)(\d+)\.(\d+)\.?(\d+)?'+ # Browser/major_version.minor_version- - regex: '(bingbot|Bolt|Jasmine|IceCat|Skyfire|Midori|Maxthon|Lynx|Arora|IBrowse|Dillo|Camino|Shiira|Fennec|Phoenix|Chrome|Flock|Netscape|Lunascape|Epiphany|WebPilot|Opera Mini|Opera|NetFront|Netfront|Konqueror|Googlebot|SeaMonkey|Kazehakase|Vienna|Iceape|Iceweasel|IceWeasel|Iron|K-Meleon|Sleipnir|Galeon|GranParadiso|iCab|NetNewsWire|Space Bison|Stainless|Orca|Dolfin|BOLT|Minimo|Tizen Browser|Polaris|Abrowser|Planetweb|ICE Browser)/(\d+)\.(\d+)'+ - regex: '(bingbot|Bolt|Jasmine|IceCat|Skyfire|Midori|Maxthon|Lynx|Arora|IBrowse|Dillo|Camino|Shiira|Fennec|Phoenix|Chrome|Flock|Netscape|Lunascape|Epiphany|WebPilot|Opera Mini|Opera|NetFront|Netfront|Konqueror|Googlebot|SeaMonkey|Kazehakase|Vienna|Iceape|Iceweasel|IceWeasel|Iron|K-Meleon|Sleipnir|Galeon|GranParadiso|iCab|NetNewsWire|Space Bison|Stainless|Orca|Dolfin|BOLT|Minimo|Tizen Browser|Polaris|Abrowser|Planetweb|ICE Browser|mDolphin)/(\d+)\.(\d+)\.?(\d+)?' # Chrome/Chromium/major_version.minor_version - regex: '(Chromium|Chrome)/(\d+)\.(\d+)'@@ -248,10 +251,10 @@ - regex: '(iRider|Crazy Browser|SkipStone|iCab|Lunascape|Sleipnir|Maemo Browser) (\d+)\.(\d+)\.(\d+)' # Browser major_version.minor_version (space instead of slash) - regex: '(iCab|Lunascape|Opera|Android|Jasmine|Polaris) (\d+)\.(\d+)\.?(\d+)?'- + # Kindle WebKit - regex: '(Kindle)/(\d+)\.(\d+)'- + # weird android UAs - regex: '(Android) Donut' v1_replacement: '1'@@ -321,6 +324,10 @@ - regex: '(BonEcho)/(\d+)\.(\d+)\.(\d+)' family_replacement: 'Bon Echo' + # @note: iOS / OSX Applications+ - regex: '(CFNetwork)(?:/(\d+)\.(\d+)\.?(\d+)?)?'+ family_replacement: 'CFNetwork'+ - regex: '(iPod).+Version/(\d+)\.(\d+)\.(\d+)' family_replacement: 'Mobile Safari' - regex: '(iPod).*Version/(\d+)\.(\d+)'@@ -518,8 +525,7 @@ # Android # can actually detect rooted android os. do we care? ##########- - regex: '(Android) (\d+)\.(\d+)(?:[.\-]([a-z0-9]+))?'- - regex: '(Android)\-(\d+)\.(\d+)(?:[.\-]([a-z0-9]+))?'+ - regex: '(Android)[ \-/](\d+)\.(\d+)(?:[.\-]([a-z0-9]+))?' - regex: '(Android) Donut' os_v1_replacement: '1'@@ -540,6 +546,17 @@ - regex: '(Android) Honeycomb' os_v1_replacement: '3' + # UCWEB+ - regex: '^UCWEB.*; (Adr) (\d+)\.(\d+)(?:[.\-]([a-z0-9]+))?;'+ os_replacement: 'Android'+ - regex: '^UCWEB.*; (iPad OS|iPh OS) (\d+)_(\d+)(?:_(\d+))?;'+ os_replacement: 'iOS'+ - regex: '^UCWEB.*; (wds) (\d+)\.(\d+)(?:\.(\d+))?;'+ os_replacement: 'Windows Phone'+ # JUC+ - regex: '^(JUC).*; ?U; ?(?:Android)?(\d+)\.(\d+)(?:[\.\-]([a-z0-9]+))?'+ os_replacement: 'Android'+ ########## # Kindle Android ##########@@ -555,14 +572,19 @@ # (very) roughly ordered in terms of frequency of occurence of regex (win xp currently most frequent, etc) ########## - - regex: '(Windows (?:NT 5\.2|NT 5\.1))'- os_replacement: 'Windows XP'-- # ie mobile des ktop mode+ # ie mobile desktop mode # spoofs nt 6.1. must come before windows 7 - regex: '(XBLWP7)' os_replacement: 'Windows Phone' + # @note: These need to come before Windows NT 6.1+ - regex: '(Windows Phone) (?:OS[ /])?(\d+)\.(\d+)'+ - regex: '(Windows ?Mobile)'+ os_replacement: 'Windows Mobile'++ - regex: '(Windows (?:NT 5\.2|NT 5\.1))'+ os_replacement: 'Windows XP'+ - regex: '(Windows NT 6\.1)' os_replacement: 'Windows 7' @@ -570,7 +592,7 @@ os_replacement: 'Windows Vista' - regex: '(Win 9x 4\.90)'- os_replacement: 'Windows Me'+ os_replacement: 'Windows ME' - regex: '(Windows 98|Windows XP|Windows ME|Windows 95|Windows CE|Windows 7|Windows NT 4\.0|Windows Vista|Windows 2000|Windows 3.1)' @@ -587,17 +609,21 @@ - regex: '(Windows NT 5\.0)' os_replacement: 'Windows 2000' - - regex: '(Windows Phone) (\d+)\.(\d+)'- - regex: '(Windows Phone) OS (\d+)\.(\d+)'- - regex: '(Windows ?Mobile)'- os_replacement: 'Windows Mobile'- - regex: '(WinNT4.0)' os_replacement: 'Windows NT 4.0' - - regex: '(Win98)'- os_replacement: 'Windows 98'+ - regex: '(Windows ?CE)'+ os_replacement: 'Windows CE' + - regex: 'Win ?(95|98|3.1|NT|ME|2000)'+ os_replacement: 'Windows $1'++ - regex: 'Win16'+ os_replacement: 'Windows 3.1'++ - regex: 'Win32'+ os_replacement: 'Windows 95'+ ########## # Tizen OS from Samsung # spoofs Android so pushing it above@@ -606,10 +632,36 @@ ########## # Mac OS- # http://en.wikipedia.org/wiki/Mac_OS_X#Versions+ # @ref: http://en.wikipedia.org/wiki/Mac_OS_X#Versions+ # @ref: http://www.puredarwin.org/curious/versions ########## - regex: '(Mac OS X) (\d+)[_.](\d+)(?:[_.](\d+))?'- + # Leopard+ - regex: ' (Dar)(win)/(9).(\d+).*\((?:i386|x86_64|Power Macintosh)\)'+ os_replacement: 'Mac OS X'+ os_v1_replacement: '10'+ os_v2_replacement: '5'+ # Snow Leopard+ - regex: ' (Dar)(win)/(10).(\d+).*\((?:i386|x86_64)\)'+ os_replacement: 'Mac OS X'+ os_v1_replacement: '10'+ os_v2_replacement: '6'+ # Lion+ - regex: ' (Dar)(win)/(11).(\d+).*\((?:i386|x86_64)\)'+ os_replacement: 'Mac OS X'+ os_v1_replacement: '10'+ os_v2_replacement: '7'+ # Mountain Lion+ - regex: ' (Dar)(win)/(12).(\d+).*\((?:i386|x86_64)\)'+ os_replacement: 'Mac OS X'+ os_v1_replacement: '10'+ os_v2_replacement: '8'+ # Mavericks+ - regex: ' (Dar)(win)/(13).(\d+).*\((?:i386|x86_64)\)'+ os_replacement: 'Mac OS X'+ os_v1_replacement: '10'+ os_v2_replacement: '9'+ # IE on Mac doesn't specify version number - regex: 'Mac_PowerPC' os_replacement: 'Mac OS'@@ -623,7 +675,7 @@ # iOS # http://en.wikipedia.org/wiki/IOS_version_history ##########- - regex: '(CPU OS|iPhone OS|CPU iPhone) (\d+)[_\.](\d+)(?:[_\.](\d+))?'+ - regex: '(CPU OS|iPhone OS|CPU iPhone) +(\d+)[_\.](\d+)(?:[_\.](\d+))?' os_replacement: 'iOS' # remaining cases are mostly only opera uas, so catch opera as to not catch iphone spoofs@@ -638,6 +690,29 @@ os_replacement: 'ATV OS X' ##########+ # CFNetwork iOS Apps+ # @ref: https://en.wikipedia.org/wiki/Darwin_(operating_system)#Release_history+ ##########+ - regex: 'CFNetwork/.* Darwin/(9)\.\d+'+ os_replacement: 'iOS'+ os_v1_replacement: '1'+ - regex: 'CFNetwork/.* Darwin/(10)\.\d+'+ os_replacement: 'iOS'+ os_v1_replacement: '4'+ - regex: 'CFNetwork/.* Darwin/(11)\.\d+'+ os_replacement: 'iOS'+ os_v1_replacement: '5'+ - regex: 'CFNetwork/.* Darwin/(13)\.\d+'+ os_replacement: 'iOS'+ os_v1_replacement: '6'+ - regex: 'CFNetwork/.* Darwin/(14)\.\d+'+ os_replacement: 'iOS'+ os_v1_replacement: '7'+ # iOS Apps+ - regex: '\b(iOS[ /]|iPhone(?:/| v|[ _]OS[/,]|; | OS : |\d,\d/|\d,\d; )|iPad/)(\d{1,2})[_\.](\d{1,2})(?:[_\.](\d+))?'+ os_replacement: 'iOS'++ ########## # Chrome OS # if version 0.0.0, probably this stuff: # http://code.google.com/p/chromium-os/issues/detail?id=11573@@ -673,6 +748,8 @@ os_replacement: 'Symbian OS' - regex: 'Series40;' os_replacement: 'Nokia Series 40'+ - regex: 'Series30Plus;'+ os_replacement: 'Nokia Series 30 Plus' ########## # BlackBerry devices@@ -710,12 +787,10 @@ ########## # Google TV ##########- - regex: '(GoogleTV) (\d+)\.(\d+)\.(\d+)'- # Old style- - regex: '(GoogleTV)/[\da-z]+'+ - regex: '(GoogleTV)(?: (\d+)\.(\d+)(?:\.(\d+))?|/[\da-z]+)' - regex: '(WebTV)/(\d+).(\d+)'- + ########## # Misc mobile ##########@@ -727,20 +802,20 @@ # Generic patterns # since the majority of os cases are very specific, these go last ##########- # first.second.third.fourth bits- - regex: '(Fedora|Red Hat|PCLinuxOS)/(\d+)\.(\d+)\.(\d+)\.(\d+)'+ - regex: '(Fedora|Red Hat|PCLinuxOS|Puppy|Ubuntu|Kindle|Bada|Lubuntu|BackTrack|Slackware|(?:Free|Open|Net|\b)BSD)[/ ](\d+)\.(\d+)(?:\.(\d+)(?:\.(\d+))?)?' - # first.second.third bits- - regex: '(Red Hat|Puppy|PCLinuxOS)/(\d+)\.(\d+)\.(\d+)'+ # Gentoo Linux + Kernel Version+ - regex: '(Linux)[ /](\d+)\.(\d+)(?:\.(\d+))?.*gentoo'+ os_replacement: 'Gentoo' - # first.second bits- - regex: '(Ubuntu|Kindle|Bada|Lubuntu|BackTrack|Red Hat|Slackware)/(\d+)\.(\d+)'+ # Opera Mini Bada+ - regex: '\((Bada);' # just os- - regex: '(Windows|OpenBSD|FreeBSD|NetBSD|Android|WeTab)'- - regex: '(Ubuntu|Kubuntu|Arch Linux|CentOS|Slackware|Gentoo|openSUSE|SUSE|Red Hat|Fedora|PCLinuxOS|Gentoo|Mageia)'- - regex: '(Linux)/(\d+)\.(\d+)'- - regex: '(Linux|BSD)'+ - regex: '(Windows|Android|WeTab|Maemo)'+ - regex: '(Ubuntu|Kubuntu|Arch Linux|CentOS|Slackware|Gentoo|openSUSE|SUSE|Red Hat|Fedora|PCLinuxOS|Gentoo|Mageia|(?:Free|Open|Net|\b)BSD)'+ # Linux + Kernel Version+ - regex: '(Linux)(?:[ /](\d+)\.(\d+)(?:\.(\d+))?)?' - regex: 'SunOS' os_replacement: 'Solaris' @@ -911,7 +986,10 @@ - regex: 'Googlebot-Mobile/(\d+).(\d+)' device_replacement: 'Spider'- ++ - regex: 'Googlebot/\d+.\d+'+ device_replacement: 'Spider'+ ########## # complete but probably catches spoofs # iSTUFF@@ -1130,6 +1208,6 @@ ########## # Spiders (this is hack...) ##########- - regex: '(bingbot|bot|borg|google(^tv)|yahoo|slurp|msnbot|msrbot|openbot|archiver|netresearch|lycos|scooter|altavista|teoma|gigabot|baiduspider|blitzbot|oegp|charlotte|furlbot|http%20client|polybot|htdig|ichiro|mogimogi|larbin|pompos|scrubby|searchsight|seekbot|semanticdiscovery|silk|snappy|speedy|spider|voila|vortex|voyager|zao|zeal|fast\-webcrawler|converacrawler|dataparksearch|findlinks|crawler)'+ - regex: '(bingbot|bot|borg|google(^tv)|yahoo|slurp|msnbot|msrbot|openbot|archiver|netresearch|lycos|scooter|altavista|teoma|gigabot|baiduspider|blitzbot|oegp|charlotte|furlbot|http%20client|polybot|htdig|ichiro|mogimogi|larbin|pompos|scrubby|searchsight|seekbot|semanticdiscovery|silk|snappy|speedy|spider|voila|vortex|voyager|zao|zeal|fast\-webcrawler|converacrawler|dataparksearch|findlinks|crawler|Netvibes|Sogou Pic Spider|ICC\-Crawler|Innovazion Crawler)' device_replacement: 'Spider'
src/Web/UAParser.hs view
@@ -1,38 +1,221 @@+{-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-} module Web.UAParser- (- -- * Readying parser- UAConfig- , loadUAParser- -- * Parsing browser (user agent)- , parseUA+ ( -- * Parsing browser (user agent)+ parseUA , UAResult (..) , uarVersion- -- * Parsing OS++ -- * Parsing OS , parseOS , OSResult (..) , osrVersion ) where +-------------------------------------------------------------------------------+import Control.Applicative+import Control.Monad+import Data.Aeson+import Data.ByteString.Char8 (ByteString)+import Data.Default+import Data.FileEmbed+import Data.Generics+import Data.Maybe+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Yaml+import Text.Regex.PCRE.Light+------------------------------------------------------------------------------- ++test :: [ByteString]+test =+ ["SonyEricssonK750i/R1L Browser/SEMC-Browser/4.2 Profile/MIDP-2.0 Configuration/CLDC-1.1"+ , "Mozilla/5.0 (Windows; U; Windows NT 5.2; en-GB; rv:1.8.1.18) Gecko/20081029 Firefox/2.0.0.18"+ , "Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10_5_5; en-us) AppleWebKit/525.26.2 (KHTML, like Gecko) Version/3.2 Safari/525.26.12'"+ , "Mozilla/4.0 (compatible; MSIE 6.0; Windows XP 5.1) Lobo/0.98.4"+ , "Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; )'"+ , "Opera/9.80 (Windows NT 5.1; U; cs) Presto/2.2.15 Version/10.00'"+ , "boxee (alpha/Darwin 8.7.1 i386 - 0.9.11.5591)'"+ , "Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 5.1; Trident/4.0; CSM-NEWUSER; GTB6; byond_4.0; .NET CLR 2.0.50727; .NET CLR 3.0.04506.30; .NET CLR 1.1.4322; .NET CLR 3.0.04506.648; .NET CLR 3.0.4506.2152; .NET CLR 3.5.30729; InfoPath.1)'"+ , "Mozilla/5.0 (compatible; Yahoo! Slurp; http://help.yahoo.com/help/us/ysearch/slurp)'"+ ]+++ ---------------+ -- UA Parser --+ ---------------++uaConfig :: UAConfig+uaConfig = either error id $ decodeEither $(embedFile "regexes.yaml")+{-# NOINLINE uaConfig #-}+ --------------------------------------------------------------------------------import System.FilePath.Posix+-- | Parse a given User-Agent string+parseUA :: ByteString -> Maybe UAResult+parseUA bs = msum $ map go uaParsers+ where+ UAConfig{..} = uaConfig++ go UAParser{..} = either (const Nothing) mkRes+ . mapM T.decodeUtf8' =<< match uaRegex bs []+ where+ mkRes [_,f,v1,v2,v3] = Just $ UAResult (repF f) (repV1 v1) (Just v2) (Just v3)+ mkRes [_,f,v1,v2] = Just $ UAResult (repF f) (repV1 v1) (Just v2) Nothing+ mkRes [_,f,v1] = Just $ UAResult (repF f) (repV1 v1) Nothing Nothing+ mkRes [_,f] = Just $ UAResult (repF f) Nothing Nothing Nothing+ mkRes _ = Nothing++ repV1 x = uaV1Rep `mplus` Just x+ repF x = maybe x id uaFamRep+++ --------------------------------------------------------------------------------import Paths_ua_parser-import Web.UAParser.Core+-- | Results datatype for the parsed User-Agent+data UAResult = UAResult {+ uarFamily :: Text+ , uarV1 :: Maybe Text+ , uarV2 :: Maybe Text+ , uarV3 :: Maybe Text+ } deriving (Show, Read, Eq, Typeable, Data)++ -------------------------------------------------------------------------------+-- | Construct a browser version-string from 'UAResult'+uarVersion :: UAResult -> Text+uarVersion UAResult{..} =+ T.intercalate "." . catMaybes . takeWhile isJust $ [uarV1, uarV2, uarV3] ---------------------------------------------------------------------------------- | Load a user agent string parser state, ready to be used with one--- of the parsing functions.------ This function will load the YAML parser definitions stored in--- package's cabal 'getDataDir'.-loadUAParser :: IO UAConfig-loadUAParser = do- dir <- getDataDir- loadConfig $ dir </> "regexes.yaml"+instance Default UAResult where+ def = UAResult "" Nothing Nothing Nothing++++ ---------------+ -- OS Parser --+ ---------------++-------------------------------------------------------------------------------+-- | Parse OS from given User-Agent string+parseOS :: ByteString -> Maybe OSResult+parseOS bs = msum $ map go osParsers+ where+ UAConfig{..} = uaConfig++ go OSParser{..} = either (const Nothing) mkRes+ . mapM T.decodeUtf8' =<< match osRegex bs []+ where+ mkRes [_,f,v1,v2,v3,v4] = Just $ OSResult (repF f) (Just v1) (Just v2) (Just v3) (Just v4)+ mkRes [_,f,v1,v2,v3] = Just $ OSResult (repF f) (Just v1) (Just v2) (Just v3) Nothing+ mkRes [_,f,v1,v2] = Just $ OSResult (repF f) (Just v1) (Just v2) Nothing Nothing+ mkRes [_,f,v1] = Just $ OSResult (repF f) (Just v1) Nothing Nothing Nothing+ mkRes [_,f] = Just $ OSResult (repF f) Nothing Nothing Nothing Nothing+ mkRes _ = Nothing++ repF x = maybe x id osFamRep+++-------------------------------------------------------------------------------+-- | Result type for 'parseOS'+data OSResult = OSResult {+ osrFamily :: Text+ , osrV1 :: Maybe Text+ , osrV2 :: Maybe Text+ , osrV3 :: Maybe Text+ , osrV4 :: Maybe Text+ } deriving (Show,Read,Eq,Typeable,Data)++instance Default OSResult where+ def = OSResult "" Nothing Nothing Nothing Nothing+++-------------------------------------------------------------------------------+-- | Construct a version string from 'OSResult'+osrVersion :: OSResult -> Text+osrVersion OSResult{..} =+ T.intercalate "." . catMaybes . takeWhile isJust $ [osrV1, osrV2, osrV3, osrV4]++ -------------------+ -- Parser Config --+ -------------------++-------------------------------------------------------------------------------+-- | User-Agent string parser data+data UAConfig = UAConfig {+ uaParsers :: [UAParser]+ , osParsers :: [OSParser]+ , devParsers :: [DevParser]+ } deriving (Eq,Show)+++-------------------------------------------------------------------------------+data UAParser = UAParser {+ uaRegex :: Regex+ , uaFamRep :: Maybe Text+ , uaV1Rep :: Maybe Text+ } deriving (Eq,Show)+++-------------------------------------------------------------------------------+data OSParser = OSParser {+ osRegex :: Regex+ , osFamRep :: Maybe Text+ , osRep1 :: Maybe Text+ , osRep2 :: Maybe Text+ } deriving (Eq,Show)+++data DevParser = DevParser {+ devRegex :: Regex+ , devRep :: Maybe Text+ } deriving (Eq,Show)+++-------------------------------------------------------------------------------+parseRegex :: Object -> Parser Regex+parseRegex v = flip compile [] `liftM` (T.encodeUtf8 <$> v .: "regex")+++-------------------------------------------------------------------------------+instance FromJSON UAConfig where+ parseJSON (Object v) =+ UAConfig+ <$> v .: "user_agent_parsers"+ <*> v .: "os_parsers"+ <*> v .: "device_parsers"+ parseJSON _ = error "Object expected when parsing JSON"+++-------------------------------------------------------------------------------+instance FromJSON UAParser where+ parseJSON (Object v) =+ UAParser <$> parseRegex v+ <*> (v .:? "family_replacement" <|> return Nothing)+ <*> (v .:? "v1_replacement" <|> return Nothing)+ parseJSON _ = error "Object expected when parsing JSON"+++-------------------------------------------------------------------------------+instance FromJSON OSParser where+ parseJSON (Object v) =+ OSParser <$> parseRegex v+ <*> (v .:? "os_replacement" <|> return Nothing)+ <*> (v .:? "os_v1_replacement" <|> return Nothing)+ <*> (v .:? "os_v2_replacement" <|> return Nothing)+ parseJSON _ = error "Object expected when parsing JSON"+++-------------------------------------------------------------------------------+instance FromJSON DevParser where+ parseJSON (Object v) =+ DevParser <$> parseRegex v+ <*> v .:? "device_replacement"+ parseJSON _ = error "Object expected when parsing JSON"
− src/Web/UAParser/Core.hs
@@ -1,243 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}--module Web.UAParser.Core- ( UAConfig (..)- , loadConfig- , parseUA- , UAResult (..)- , uarVersion- , parseOS- , OSResult (..)- , osrVersion-- -- * Utilities- , decodeFile'- ) where-----------------------------------------------------------------------------------import Control.Applicative-import Control.Monad-import Data.Aeson-import Data.ByteString.Char8 (ByteString)-import qualified Data.ByteString.Char8 as B-import Data.Default-import Data.Generics-import Data.Maybe-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Yaml-import Text.Regex.PCRE.Light------------------------------------------------------------------------------------test :: [ByteString]-test =- ["SonyEricssonK750i/R1L Browser/SEMC-Browser/4.2 Profile/MIDP-2.0 Configuration/CLDC-1.1"- , "Mozilla/5.0 (Windows; U; Windows NT 5.2; en-GB; rv:1.8.1.18) Gecko/20081029 Firefox/2.0.0.18"- , "Mozilla/5.0 (Macintosh; U; Intel Mac OS X 10_5_5; en-us) AppleWebKit/525.26.2 (KHTML, like Gecko) Version/3.2 Safari/525.26.12'"- , "Mozilla/4.0 (compatible; MSIE 6.0; Windows XP 5.1) Lobo/0.98.4"- , "Mozilla/4.0 (compatible; MSIE 7.0; Windows NT 5.1; )'"- , "Opera/9.80 (Windows NT 5.1; U; cs) Presto/2.2.15 Version/10.00'"- , "boxee (alpha/Darwin 8.7.1 i386 - 0.9.11.5591)'"- , "Mozilla/4.0 (compatible; MSIE 8.0; Windows NT 5.1; Trident/4.0; CSM-NEWUSER; GTB6; byond_4.0; .NET CLR 2.0.50727; .NET CLR 3.0.04506.30; .NET CLR 1.1.4322; .NET CLR 3.0.04506.648; .NET CLR 3.0.4506.2152; .NET CLR 3.5.30729; InfoPath.1)'"- , "Mozilla/5.0 (compatible; Yahoo! Slurp; http://help.yahoo.com/help/us/ysearch/slurp)'"- ]--- ---------------- -- UA Parser --- ---------------------------------------------------------------------------------------------------- | Parse a given User-Agent string-parseUA- :: UAConfig- -- ^ Loaded parser configuration data- -> ByteString- -- ^ User-Agent string to be parsed- -> Maybe UAResult-parseUA UAConfig{..} bs = foldr mplus Nothing $ map go uaParsers- where- go UAParser{..} = mkRes . map T.decodeUtf8 =<< match uaRegex bs []- where- mkRes [] = Nothing- mkRes [_,f,v1,v2,v3] = Just $ UAResult (repF f) (repV1 v1) (Just v2) (Just v3)- mkRes [_,f,v1,v2] = Just $ UAResult (repF f) (repV1 v1) (Just v2) Nothing- mkRes [_,f,v1] = Just $ UAResult (repF f) (repV1 v1) Nothing Nothing- mkRes [_, f] = Just $ UAResult (repF f) Nothing Nothing Nothing- mkRes _ = Nothing- -- error $ "Unsupported match in parseUA" ++ show x-- repV1 x = uaV1Rep `mplus` Just x- repF x = maybe x id uaFamRep-------------------------------------------------------------------------------------- | Results datatype for the parsed User-Agent-data UAResult = UAResult {- uarFamily :: Text- , uarV1 :: Maybe Text- , uarV2 :: Maybe Text- , uarV3 :: Maybe Text- } deriving (Show, Read, Eq, Typeable, Data)------------------------------------------------------------------------------------- | Construct a browser version-string from 'UAResult'-uarVersion :: UAResult -> Text-uarVersion UAResult{..} =- T.intercalate "." . catMaybes . takeWhile isJust $ [uarV1, uarV2, uarV3]-----------------------------------------------------------------------------------instance Default UAResult where- def = UAResult "" Nothing Nothing Nothing---- ---------------- -- OS Parser --- ---------------------------------------------------------------------------------------------------- | Parse OS from given User-Agent string-parseOS- :: UAConfig- -- ^ Loaded parser data- -> ByteString- -- ^ User-Agent string to be parsed- -> Maybe OSResult-parseOS UAConfig{..} bs = foldr mplus Nothing $ map go osParsers- where- go OSParser{..} = mkRes . map T.decodeUtf8 =<< match osRegex bs []- where- mkRes [] = Nothing- mkRes [_,f,v1,v2,v3, v4] = Just $- OSResult (repF f) (Just v1) (Just v2) (Just v3) (Just v4)- mkRes [_,f,v1,v2,v3] = Just $ OSResult (repF f) (Just v1) (Just v2) (Just v3) Nothing- mkRes [_,f,v1,v2] = Just $ OSResult (repF f) (Just v1) (Just v2) Nothing Nothing- mkRes [_,f,v1] = Just $ OSResult (repF f) (Just v1) Nothing Nothing Nothing- mkRes [_, f] = Just $ OSResult (repF f) Nothing Nothing Nothing Nothing- mkRes _ = Nothing- -- error $ "Unsupported match in parseOS" ++ show x-- repF x = maybe x id osFamRep------------------------------------------------------------------------------------- | Result type for 'parseOS'-data OSResult = OSResult {- osrFamily :: Text- , osrV1 :: Maybe Text- , osrV2 :: Maybe Text- , osrV3 :: Maybe Text- , osrV4 :: Maybe Text- } deriving (Show,Read,Eq,Typeable,Data)--instance Default OSResult where- def = OSResult "" Nothing Nothing Nothing Nothing------------------------------------------------------------------------------------- | Construct a version string from 'OSResult'-osrVersion :: OSResult -> Text-osrVersion OSResult{..} =- T.intercalate "." . catMaybes . takeWhile isJust $ [osrV1, osrV2, osrV3, osrV4]-- -------------------- -- Parser Config --- ------------------------------------------------------------------------------------------------------loadConfig :: FilePath -> IO UAConfig-loadConfig fp = either error id `fmap` decodeFile' fp-----------------------------------------------------------------------------------decodeFile' :: FromJSON a => FilePath -> IO (Either String a)-decodeFile' fp = decodeEither `fmap` B.readFile fp------------------------------------------------------------------------------------- | User-Agent string parser data-data UAConfig = UAConfig {- uaParsers :: [UAParser]- , osParsers :: [OSParser]- , devParsers :: [DevParser]- } deriving (Eq,Show)-----------------------------------------------------------------------------------data UAParser = UAParser {- uaRegex :: Regex- , uaFamRep :: Maybe Text- , uaV1Rep :: Maybe Text- } deriving (Eq,Show)-----------------------------------------------------------------------------------data OSParser = OSParser {- osRegex :: Regex- , osFamRep :: Maybe Text- , osRep1 :: Maybe Text- , osRep2 :: Maybe Text- } deriving (Eq,Show)---data DevParser = DevParser {- devRegex :: Regex- , devRep :: Maybe Text- } deriving (Eq,Show)-----------------------------------------------------------------------------------parseRegex :: Object -> Parser Regex-parseRegex v = flip compile [] `liftM` (T.encodeUtf8 <$> v .: "regex")-----------------------------------------------------------------------------------instance FromJSON UAConfig where- parseJSON (Object v) =- UAConfig- <$> v .: "user_agent_parsers"- <*> v .: "os_parsers"- <*> v .: "device_parsers"- parseJSON _ = error "Object expected when parsing JSON"-----------------------------------------------------------------------------------instance FromJSON UAParser where- parseJSON (Object v) =- UAParser <$> parseRegex v- <*> (v .:? "family_replacement" <|> return Nothing)- <*> (v .:? "v1_replacement" <|> return Nothing)- parseJSON _ = error "Object expected when parsing JSON"-----------------------------------------------------------------------------------instance FromJSON OSParser where- parseJSON (Object v) =- OSParser <$> parseRegex v- <*> (v .:? "os_replacement" <|> return Nothing)- <*> (v .:? "os_v1_replacement" <|> return Nothing)- <*> (v .:? "os_v2_replacement" <|> return Nothing)- parseJSON _ = error "Object expected when parsing JSON"-----------------------------------------------------------------------------------instance FromJSON DevParser where- parseJSON (Object v) =- DevParser <$> parseRegex v- <*> v .:? "device_replacement"- parseJSON _ = error "Object expected when parsing JSON"-
test/src/TestSuite.hs view
@@ -25,7 +25,7 @@ import Test.HUnit hiding (Test, path) import Text.Regex.PCRE.Light --------------------------------------------------------------------------------import Web.UAParser.Core+import Web.UAParser ------------------------------------------------------------------------------- @@ -45,11 +45,10 @@ ------------------------------------------------------------------------------- benchMain = do- conf <- loadConfig "../regexes.yaml" cases <- loadTests "test_user_agent_parser.yaml" cases2 <- loadTests "firefox_user_agent_strings.yaml" let allC = cases ++ cases2- ua = bench "UA Parsing" $ nf (map (parseUA conf . uatcString)) allC+ ua = bench "UA Parsing" $ nf (map (parseUA . uatcString)) allC print $ show (length allC) ++ " strings being parsed." C.defaultMain [ua] @@ -74,17 +73,16 @@ ------------------------------------------------------------------------------- uaTests = buildTest $ do- conf <- loadConfig "../regexes.yaml" cases <- loadTests "test_user_agent_parser.yaml" cases2 <- loadTests "firefox_user_agent_strings.yaml" let allC = cases ++ cases2- return $ testGroup "UA Parsing Tests" $ map (testUAParser conf) allC+ return $ testGroup "UA Parsing Tests" $ map testUAParser allC --------------------------------------------------------------------------------testUAParser :: UAConfig -> UserAgentTestCase -> Test-testUAParser config UATC{..} = testCase tn $ do+testUAParser :: UserAgentTestCase -> Test+testUAParser UATC{..} = testCase tn $ do case parsed of Nothing -> assertFailure "Can't produce UAResult" Just UAResult{..} -> do@@ -93,7 +91,7 @@ -- assertEqual "v2 is the same" uatcV2 uarV2 -- assertEqual "v3 is the same" uatcV3 uarV3 where- parsed = parseUA config uatcString+ parsed = parseUA uatcString tn = T.unpack $ T.intercalate "/" ["UA Test: ", uatcFamily, m uatcV1, m uatcV2, m uatcV3] m x = maybe "-" id x @@ -106,15 +104,14 @@ ------------------------------------------------------------------------------- osTests = buildTest $ do- conf <- loadConfig "../regexes.yaml" cases <- loadTests "test_user_agent_parser_os.yaml"- return $ testGroup "OS Parsing Tests" $ map (testOSParser conf) cases+ return $ testGroup "OS Parsing Tests" $ map testOSParser cases --------------------------------------------------------------------------------testOSParser :: UAConfig -> OSTestCase -> Test-testOSParser config OSTC{..} = testCase tn $ do+testOSParser :: OSTestCase -> Test+testOSParser OSTC{..} = testCase tn $ do case parsed of Nothing -> assertFailure "Can't produce OSResult" Just OSResult{..} -> do@@ -124,7 +121,7 @@ assertEqual "patch is the same" ostcV3 osrV3 assertEqual "patch_minor is the same" ostcV4 osrV4 where- parsed = parseOS config ostcString+ parsed = parseOS ostcString tn = T.unpack $ T.intercalate "/" ["OS Test: ", ostcFamily, m ostcV1, m ostcV2, m ostcV3, m ostcV4] m x = maybe "-" id x@@ -140,7 +137,7 @@ ------------------------------------------------------------------------------- loadTests :: FromJSON a => FilePath -> IO a-loadTests fp = parseMonad p =<< either error id `fmap` decodeFile' fp'+loadTests fp = parseMonad p =<< either (error . show) id `fmap` decodeFileEither fp' where fp' = "../test_resources" </> fp p (Object x) = x .: "test_cases"
ua-parser.cabal view
@@ -1,6 +1,6 @@ Name: ua-parser Description: Please refer to the git/github README on the project for example usage.-Version: 0.4+Version: 0.5 Synopsis: A library for parsing User-Agent strings, official Haskell port of ua-parser License: BSD3 License-file: LICENSE@@ -21,21 +21,17 @@ hs-source-dirs: src Exposed-modules: Web.UAParser- Web.UAParser.Core- other-modules:- Paths_ua_parser - Build-depends: - base < 5+ base < 5 , bytestring , text , pcre-light- , yaml >= 0.7 && < 0.9- , aeson >= 0.7 && < 0.8- , filepath+ , yaml >= 0.7 && < 0.9+ , aeson >= 0.7 && < 0.8 , data-default , syb+ , file-embed < 0.1 ghc-options: -O2 -Wall @@ -63,5 +59,6 @@ , data-default , syb , filepath+ , file-embed