diff --git a/regexes.yaml b/regexes.yaml --- a/regexes.yaml +++ b/regexes.yaml @@ -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' diff --git a/src/Web/UAParser.hs b/src/Web/UAParser.hs --- a/src/Web/UAParser.hs +++ b/src/Web/UAParser.hs @@ -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" diff --git a/src/Web/UAParser/Core.hs b/src/Web/UAParser/Core.hs deleted file mode 100644 --- a/src/Web/UAParser/Core.hs +++ /dev/null @@ -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" - diff --git a/test/src/TestSuite.hs b/test/src/TestSuite.hs --- a/test/src/TestSuite.hs +++ b/test/src/TestSuite.hs @@ -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" diff --git a/ua-parser.cabal b/ua-parser.cabal --- a/ua-parser.cabal +++ b/ua-parser.cabal @@ -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