freckle-ua-parser 0.1.0.1 → 0.1.0.2
raw patch · 7 files changed
+489/−420 lines, 7 filessetup-changedPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- Setup.hs +1/−0
- bench/Main.hs +13/−15
- freckle-ua-parser.cabal +30/−15
- package.yaml +10/−1
- src/Web/UAParser.hs +291/−251
- src/Web/UAParser/SuiteUtils.hs +75/−73
- test/Main.hs +69/−65
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
bench/Main.hs view
@@ -1,25 +1,23 @@-{-# LANGUAGE TemplateHaskell #-} {-# OPTIONS_GHC -fno-warn-orphans #-}-module Main- ( main- ) where +module Main+ ( main+ ) where ---------------------------------------------------------------------------------import Control.Applicative as A-import Criterion.Main---------------------------------------------------------------------------------import Web.UAParser-import Web.UAParser.SuiteUtils--------------------------------------------------------------------------------+import Prelude +import Control.Applicative as A+import Criterion.Main+import Web.UAParser+import Web.UAParser.SuiteUtils main :: IO () main = do uas <- take 100 A.<$> loadTests "test_resources/firefox_user_agent_strings.yaml" oses <- take 100 <$> loadTests "test_resources/additional_os_tests.yaml" devs <- take 100 <$> loadTests "tests/test_device.yaml"- defaultMain [ bench "Parsing 100 UAs" $ nf (map (parseUA . uatcString)) uas- , bench "Parsing 100 OSes" $ nf (map (parseOS . ostcString)) oses- , bench "Parsing 100 Devices" $ nf (map (parseDev . dtcString)) devs- ]+ defaultMain+ [ bench "Parsing 100 UAs" $ nf (map (parseUA . uatcString)) uas+ , bench "Parsing 100 OSes" $ nf (map (parseOS . ostcString)) oses+ , bench "Parsing 100 Devices" $ nf (map (parseDev . dtcString)) devs+ ]
freckle-ua-parser.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: freckle-ua-parser-version: 0.1.0.1+version: 0.1.0.2 license: BSD3 license-file: LICENSE copyright: 2012 Ozgun Ataman, 2026 Renaissance Learning Inc@@ -44,10 +44,15 @@ manual: True library- exposed-modules: Web.UAParser- hs-source-dirs: src- default-language: Haskell2010- ghc-options: -Wall+ exposed-modules: Web.UAParser+ hs-source-dirs: src+ default-language: Haskell2010+ default-extensions:+ DeriveAnyClass DeriveDataTypeable DeriveGeneric NamedFieldPuns+ NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings+ TemplateHaskell++ ghc-options: -Wall build-depends: aeson >=0.7, base >=4.14.3.0 && <5,@@ -65,16 +70,21 @@ ghc-options: -Werror test-suite test- type: exitcode-stdio-1.0- main-is: Main.hs- hs-source-dirs: src test+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: src test other-modules: Web.UAParser Web.UAParser.SuiteUtils Paths_freckle_ua_parser - default-language: Haskell2010- ghc-options: -Wall -O2 -fwarn-tabs+ default-language: Haskell2010+ default-extensions:+ DeriveAnyClass DeriveDataTypeable DeriveGeneric NamedFieldPuns+ NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings+ TemplateHaskell++ ghc-options: -Wall -O2 -fwarn-tabs build-depends: HUnit >=1.6.2.0, aeson >=0.7,@@ -97,16 +107,21 @@ ghc-options: -Werror benchmark bench- type: exitcode-stdio-1.0- main-is: Main.hs- hs-source-dirs: bench src+ type: exitcode-stdio-1.0+ main-is: Main.hs+ hs-source-dirs: bench src other-modules: Web.UAParser Web.UAParser.SuiteUtils Paths_freckle_ua_parser - default-language: Haskell2010- ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ default-extensions:+ DeriveAnyClass DeriveDataTypeable DeriveGeneric NamedFieldPuns+ NoImplicitPrelude NoMonomorphismRestriction OverloadedStrings+ TemplateHaskell++ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: aeson >=0.7, base >=4.14.3.0 && <5,
package.yaml view
@@ -1,5 +1,5 @@ name: freckle-ua-parser-version: 0.1.0.1+version: 0.1.0.2 synopsis: Parsers for User-Agent strings description: | Parses User-Agent strings into browser, operating system, and device details,@@ -28,6 +28,15 @@ manual: true default: false ghc-options: -Wall+default-extensions:+ - DeriveAnyClass+ - DeriveDataTypeable+ - DeriveGeneric+ - NamedFieldPuns+ - NoImplicitPrelude+ - NoMonomorphismRestriction+ - OverloadedStrings+ - TemplateHaskell when: - condition: flag(lib-Werror) ghc-options: -Werror
src/Web/UAParser.hs view
@@ -1,354 +1,394 @@-{-# LANGUAGE DeriveAnyClass #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE NoMonomorphismRestriction #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}- module Web.UAParser- ( -- * Parsing browser (user agent)- parseUA- , parseUALenient- , UAResult (..)- , uarVersion+ ( -- * Parsing browser (user agent)+ parseUA+ , parseUALenient+ , UAResult (..)+ , uarVersion - -- * Parsing OS- , parseOS- , parseOSLenient- , OSResult (..)- , osrVersion+ -- * Parsing OS+ , parseOS+ , parseOSLenient+ , OSResult (..)+ , osrVersion - -- * Parsing Dev- , parseDev- , parseDevLenient- , DevResult (..)- ) where+ -- * Parsing Dev+ , parseDev+ , parseDevLenient+ , DevResult (..)+ ) where ---------------------------------------------------------------------------------import Control.Applicative-import Control.DeepSeq-import Control.Monad-import Data.Aeson-import Data.ByteString.Char8 (ByteString)-import Data.Data-import Data.Default-import Data.FileEmbed-import Data.Maybe-import Data.Monoid as M-import Data.Text (Text)-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.Yaml-import GHC.Generics-import Text.Regex.PCRE.Light-import Data.Serialize-import Data.Serialize.Text ()--------------------------------------------------------------------------------+import Prelude +import Control.Applicative+import Control.DeepSeq+import Control.Monad+import Data.Aeson+import Data.ByteString.Char8 (ByteString)+import Data.Data+import Data.Default+import Data.FileEmbed+import Data.Maybe+import Data.Monoid as M+import Data.Serialize+import Data.Serialize.Text ()+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Data.Yaml+import GHC.Generics+import Text.Regex.PCRE.Light -------------------------------------------------------------------------------- -- UA Parser-------------------------------------------------------------------------------- uaConfig :: UAConfig-uaConfig = either (error . show) id $ decodeEither' $(embedFile "deps/uap-core/regexes.yaml")+uaConfig =+ either (error . show) id+ $ decodeEither' $(embedFile "deps/uap-core/regexes.yaml") {-# NOINLINE uaConfig #-} --------------------------------------------------------------------------------- -- | Parser that, upon failure to match a pattern returns a result of -- family "Other" with all other fields blank. This is mainly for -- compatibility with the uap-core test suite parseUALenient :: ByteString -> UAResult parseUALenient = fromMaybe def . parseUA --------------------------------------------------------------------------------- -- | Parse a given User-Agent string parseUA :: ByteString -> Maybe UAResult parseUA bs = msum $ map go uaParsers- where- UAConfig{..} = uaConfig-- go UAParser{..} = either (const Nothing) (fmap normalize . mkRes)- . mapM T.decodeUtf8' =<< match uaRegex bs []- where- normalize (UAResult f v1 v2 v3) = UAResult f (normalizeMaybeText v1) (normalizeMaybeText v2) (normalizeMaybeText v3)- normalizeMaybeText (Just "") = Nothing- normalizeMaybeText x = x- mkRes caps@(_:f:v1:v2:v3:_) = Just $ UAResult (repF caps f) (repV1 caps (Just v1)) (repV2 caps (Just v2)) (repV3 caps (Just v3))- mkRes caps@[_,f,v1,v2] = Just $ UAResult (repF caps f) (repV1 caps (Just v1)) (repV2 caps (Just v2)) (repV3 caps Nothing)- mkRes caps@[_,f,v1] = Just $ UAResult (repF caps f) (repV1 caps (Just v1)) (repV2 caps Nothing) (repV3 caps Nothing)- mkRes caps@[_,f] = Just $ UAResult (repF caps f) (repV1 caps Nothing) (repV2 caps Nothing) (repV3 caps Nothing)- mkRes caps@[f] = Just $ UAResult (repF caps f) (repV1 caps Nothing) (repV2 caps Nothing) (repV3 caps Nothing)- mkRes _ = Nothing-- repV1 caps x = maybe (x <|> caps `at` 2) Just (makeReplacements caps <$> uaV1Rep)- repV2 caps x = maybe (x <|> caps `at` 3) Just (makeReplacements caps <$> uaV2Rep)- repV3 caps x = maybe (x <|> caps `at` 4) Just (makeReplacements caps <$> uaV3Rep)+ where+ UAConfig {uaParsers} = uaConfig - repF caps x = maybe x (makeReplacements caps) uaFamRep+ go UAParser {uaRegex, uaFamRep, uaV1Rep, uaV2Rep, uaV3Rep} =+ either (const Nothing) (fmap normalize . mkRes)+ . mapM T.decodeUtf8'+ =<< match uaRegex bs []+ where+ normalize (UAResult f v1 v2 v3) =+ UAResult+ f+ (normalizeMaybeText v1)+ (normalizeMaybeText v2)+ (normalizeMaybeText v3)+ normalizeMaybeText (Just "") = Nothing+ normalizeMaybeText x = x+ mkRes caps@(_ : f : v1 : v2 : v3 : _) =+ Just+ $ UAResult+ (repF caps f)+ (repV1 caps (Just v1))+ (repV2 caps (Just v2))+ (repV3 caps (Just v3))+ mkRes caps@[_, f, v1, v2] =+ Just+ $ UAResult+ (repF caps f)+ (repV1 caps (Just v1))+ (repV2 caps (Just v2))+ (repV3 caps Nothing)+ mkRes caps@[_, f, v1] =+ Just+ $ UAResult+ (repF caps f)+ (repV1 caps (Just v1))+ (repV2 caps Nothing)+ (repV3 caps Nothing)+ mkRes caps@[_, f] =+ Just+ $ UAResult+ (repF caps f)+ (repV1 caps Nothing)+ (repV2 caps Nothing)+ (repV3 caps Nothing)+ mkRes caps@[f] =+ Just+ $ UAResult+ (repF caps f)+ (repV1 caps Nothing)+ (repV2 caps Nothing)+ (repV3 caps Nothing)+ mkRes _ = Nothing + repV1 caps x = maybe (x <|> caps `at` 2) Just (makeReplacements caps <$> uaV1Rep)+ repV2 caps x = maybe (x <|> caps `at` 3) Just (makeReplacements caps <$> uaV2Rep)+ repV3 caps x = maybe (x <|> caps `at` 4) Just (makeReplacements caps <$> uaV3Rep) + repF caps x = maybe x (makeReplacements caps) 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, Generic, NFData, Serialize)-+data UAResult = UAResult+ { uarFamily :: Text+ , uarV1 :: Maybe Text+ , uarV2 :: Maybe Text+ , uarV3 :: Maybe Text+ }+ deriving (Data, Eq, Generic, NFData, Read, Serialize, Show, Typeable) -------------------------------------------------------------------------------- -- | Construct a browser version-string from 'UAResult' uarVersion :: UAResult -> Text-uarVersion UAResult{..} =- T.intercalate "." . catMaybes . takeWhile isJust $ [uarV1, uarV2, uarV3]-+uarVersion UAResult {uarV1, uarV2, uarV3} =+ T.intercalate "." . catMaybes . takeWhile isJust $ [uarV1, uarV2, uarV3] -------------------------------------------------------------------------------- instance Default UAResult where- def = UAResult "Other" Nothing Nothing Nothing-+ def = UAResult "Other" Nothing Nothing Nothing -------------------------------------------------------------------------------- -- OS Parser--------------------------------------------------------------------------------+ -- | Parser that, upon failure to match a pattern returns a result of -- family "Other" with all other fields blank. This is mainly for -- compatibility with the uap-core test suite parseOSLenient :: ByteString -> OSResult parseOSLenient = fromMaybe def . parseOS --------------------------------------------------------------------------------- -- | Parse OS from given User-Agent string parseOS :: ByteString -> Maybe OSResult parseOS bs = msum $ map go osParsers- where- UAConfig{..} = uaConfig+ where+ UAConfig {osParsers} = uaConfig - go OSParser{..} = either (const Nothing) mkRes- . mapM T.decodeUtf8' =<< match osRegex bs []- where- mkRes caps@(_:f:v1:v2:v3:v4:_) = Just $ OSResult (repF caps f) (repV1 caps (Just v1)) (repV2 caps (Just v2)) (repV3 caps (Just v3)) (repV4 caps (Just v4))- mkRes caps@[_,f,v1,v2,v3] = Just $ OSResult (repF caps f) (repV1 caps (Just v1)) (repV2 caps (Just v2)) (repV3 caps (Just v3)) (repV4 caps Nothing)- mkRes caps@[_,f,v1,v2] = Just $ OSResult (repF caps f) (repV1 caps (Just v1)) (repV2 caps (Just v2)) (repV3 caps Nothing) (repV4 caps Nothing)- mkRes caps@[_,f,v1] = Just $ OSResult (repF caps f) (repV1 caps (Just v1)) (repV2 caps Nothing) (repV3 caps Nothing) (repV4 caps Nothing)- mkRes caps@[_,f] = Just $ OSResult (repF caps f) (repV1 caps Nothing) (repV2 caps Nothing) (repV3 caps Nothing) (repV4 caps Nothing)- mkRes caps@[f] = Just $ OSResult (repF caps f) (repV1 caps Nothing) (repV2 caps Nothing) (repV3 caps Nothing) (repV4 caps Nothing)- mkRes _ = Nothing+ go OSParser {osRegex, osFamRep, osRep1, osRep2, osRep3, osRep4} =+ either (const Nothing) mkRes+ . mapM T.decodeUtf8'+ =<< match osRegex bs []+ where+ mkRes caps@(_ : f : v1 : v2 : v3 : v4 : _) =+ Just+ $ OSResult+ (repF caps f)+ (repV1 caps (Just v1))+ (repV2 caps (Just v2))+ (repV3 caps (Just v3))+ (repV4 caps (Just v4))+ mkRes caps@[_, f, v1, v2, v3] =+ Just+ $ OSResult+ (repF caps f)+ (repV1 caps (Just v1))+ (repV2 caps (Just v2))+ (repV3 caps (Just v3))+ (repV4 caps Nothing)+ mkRes caps@[_, f, v1, v2] =+ Just+ $ OSResult+ (repF caps f)+ (repV1 caps (Just v1))+ (repV2 caps (Just v2))+ (repV3 caps Nothing)+ (repV4 caps Nothing)+ mkRes caps@[_, f, v1] =+ Just+ $ OSResult+ (repF caps f)+ (repV1 caps (Just v1))+ (repV2 caps Nothing)+ (repV3 caps Nothing)+ (repV4 caps Nothing)+ mkRes caps@[_, f] =+ Just+ $ OSResult+ (repF caps f)+ (repV1 caps Nothing)+ (repV2 caps Nothing)+ (repV3 caps Nothing)+ (repV4 caps Nothing)+ mkRes caps@[f] =+ Just+ $ OSResult+ (repF caps f)+ (repV1 caps Nothing)+ (repV2 caps Nothing)+ (repV3 caps Nothing)+ (repV4 caps Nothing)+ mkRes _ = Nothing - repF caps x = maybe x (makeReplacements caps) osFamRep+ repF caps x = maybe x (makeReplacements caps) osFamRep - repV1 caps x = maybe (x <|> caps `at` 2) Just (makeReplacements caps <$> osRep1)- repV2 caps x = maybe (x <|> caps `at` 3) Just (makeReplacements caps <$> osRep2)- repV3 caps x = maybe (x <|> caps `at` 4) Just (makeReplacements caps <$> osRep3)- repV4 caps x = maybe (x <|> caps `at` 5) Just (makeReplacements caps <$> osRep4)+ repV1 caps x = maybe (x <|> caps `at` 2) Just (makeReplacements caps <$> osRep1)+ repV2 caps x = maybe (x <|> caps `at` 3) Just (makeReplacements caps <$> osRep2)+ repV3 caps x = maybe (x <|> caps `at` 4) Just (makeReplacements caps <$> osRep3)+ repV4 caps x = maybe (x <|> caps `at` 5) Just (makeReplacements caps <$> osRep4) -------------------------------------------------------------------------------- -- | 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,Generic,NFData,Serialize)+data OSResult = OSResult+ { osrFamily :: Text+ , osrV1 :: Maybe Text+ , osrV2 :: Maybe Text+ , osrV3 :: Maybe Text+ , osrV4 :: Maybe Text+ }+ deriving (Data, Eq, Generic, NFData, Read, Serialize, Show, Typeable) instance Default OSResult where- def = OSResult "Other" Nothing Nothing Nothing Nothing-+ def = OSResult "Other" Nothing Nothing Nothing Nothing -------------------------------------------------------------------------------- -- | Construct a version string from 'OSResult' osrVersion :: OSResult -> Text-osrVersion OSResult{..} =- T.intercalate "." . catMaybes . takeWhile isJust $ [osrV1, osrV2, osrV3, osrV4]-+osrVersion OSResult {osrV1, osrV2, osrV3, osrV4} =+ T.intercalate "." . catMaybes . takeWhile isJust $ [osrV1, osrV2, osrV3, osrV4] -------------------------------------------------------------------------------- -- Dev Parser--------------------------------------------------------------------------------+ -- | Parser that, upon failure to match a pattern returns a result of -- family "Other" with all other fields blank. This is mainly for -- compatibility with the uap-core test suite parseDevLenient :: ByteString -> DevResult parseDevLenient = fromMaybe def . parseDev --------------------------------------------------------------------------------- parseDev :: ByteString -> Maybe DevResult parseDev bs = msum $ map go devParsers- where- UAConfig{..} = uaConfig-- go DevParser{..} = either (const Nothing) mkRes- . mapM T.decodeUtf8' =<< match devRegex bs []- where- mkRes caps@(_:f:b:m:_) = Just $ mkDR (repF caps f) (repBrand caps (Just b)) (repModel caps (Just m))- mkRes caps@[_,f,b] = Just $ mkDR (repF caps f) (repBrand caps (Just b)) (repModel caps Nothing)- mkRes caps@[_,f] = Just $ mkDR (repF caps f) (repBrand caps Nothing) (repModel caps Nothing)- mkRes caps@[f] = Just $ mkDR (repF caps f) (repBrand caps Nothing) (repModel caps Nothing)- mkRes _ = Nothing+ where+ UAConfig {devParsers} = uaConfig - mkDR a b c = DevResult (T.strip a) (strip' =<< b) (strip' =<< c)+ go DevParser {devRegex, devFamRep, devBrandRep, devModelRep} =+ either (const Nothing) mkRes+ . mapM T.decodeUtf8'+ =<< match devRegex bs []+ where+ mkRes caps@(_ : f : b : m : _) = Just $ mkDR (repF caps f) (repBrand caps (Just b)) (repModel caps (Just m))+ mkRes caps@[_, f, b] = Just $ mkDR (repF caps f) (repBrand caps (Just b)) (repModel caps Nothing)+ mkRes caps@[_, f] = Just $ mkDR (repF caps f) (repBrand caps Nothing) (repModel caps Nothing)+ mkRes caps@[f] =+ Just $ mkDR (repF caps f) (repBrand caps Nothing) (repModel caps Nothing)+ mkRes _ = Nothing - strip' t = case T.strip t of- "" -> Nothing- t' -> Just t'+ mkDR a b c = DevResult (T.strip a) (strip' =<< b) (strip' =<< c) - --TODO: update other replacers to be like this if it works- --TODO: some patterns don't capture so you should match on [f]- repBrand caps x = maybe x Just (makeReplacements caps <$> devBrandRep)- -- This technique is used in the python ua-parser. It isn't- -- clear if there's a precedent in the spec but it clears up- -- some remote edge cases (which may be test suite bugs TBH).- repModel caps x = maybe (x <|> caps `at` 1) Just (makeReplacements caps <$> devModelRep)+ strip' t = case T.strip t of+ "" -> Nothing+ t' -> Just t' - repF caps x = maybe x (makeReplacements caps) devFamRep+ -- TODO: update other replacers to be like this if it works+ -- TODO: some patterns don't capture so you should match on [f]+ repBrand caps x = maybe x Just (makeReplacements caps <$> devBrandRep)+ -- This technique is used in the python ua-parser. It isn't+ -- clear if there's a precedent in the spec but it clears up+ -- some remote edge cases (which may be test suite bugs TBH).+ repModel caps x = maybe (x <|> caps `at` 1) Just (makeReplacements caps <$> devModelRep) + repF caps x = maybe x (makeReplacements caps) devFamRep -------------------------------------------------------------------------------- -- | Replace replacement placeholders with captures and remove any -- that are unused. Goes up to $4 as per the spec makeReplacements- :: [Text]- -- ^ Captures- -> Text- -- ^ Replacement text with 1-indexed replace points ($1, $2, $3 or $4)- -> Text-makeReplacements (_:cs) t = makeReplacements' (zip ([1..4] :: [Int]) (cs ++ repeat "")) t- where makeReplacements' [] acc = acc- makeReplacements' ((idx, cap):caps) acc = let acc' = T.replace ("$" M.<> showT idx) cap acc- in makeReplacements' caps acc'+ :: [Text]+ -- ^ Captures+ -> Text+ -- ^ Replacement text with 1-indexed replace points ($1, $2, $3 or $4)+ -> Text+makeReplacements (_ : cs) t = makeReplacements' (zip ([1 .. 4] :: [Int]) (cs ++ repeat "")) t+ where+ makeReplacements' [] acc = acc+ makeReplacements' ((idx, cap) : caps) acc =+ let acc' = T.replace ("$" M.<> showT idx) cap acc+ in makeReplacements' caps acc' makeReplacements _ t = t --------------------------------------------------------------------------------- showT :: Show a => a -> Text showT = T.pack . show --------------------------------------------------------------------------------- -- | Result type for 'parseDev'-data DevResult = DevResult {- drFamily :: Text- , drBrand :: Maybe Text- , drModel :: Maybe Text- } deriving (Show,Read,Eq,Typeable,Data,Generic,NFData,Serialize)-+data DevResult = DevResult+ { drFamily :: Text+ , drBrand :: Maybe Text+ , drModel :: Maybe Text+ }+ deriving (Data, Eq, Generic, NFData, Read, Serialize, Show, Typeable) instance Default DevResult where- def = DevResult "Other" Nothing Nothing-+ def = DevResult "Other" Nothing Nothing -------------------------------------------------------------------------------- -- 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- , uaV2Rep :: Maybe Text- , uaV3Rep :: Maybe Text- } deriving (Eq,Show)-----------------------------------------------------------------------------------data OSParser = OSParser {- osRegex :: Regex- , osFamRep :: Maybe Text- , osRep1 :: Maybe Text- , osRep2 :: Maybe Text- , osRep3 :: Maybe Text- , osRep4 :: Maybe Text- } deriving (Eq,Show)+data UAConfig = UAConfig+ { uaParsers :: [UAParser]+ , osParsers :: [OSParser]+ , devParsers :: [DevParser]+ }+ deriving (Eq, Show) +data UAParser = UAParser+ { uaRegex :: Regex+ , uaFamRep :: Maybe Text+ , uaV1Rep :: Maybe Text+ , uaV2Rep :: Maybe Text+ , uaV3Rep :: Maybe Text+ }+ deriving (Eq, Show) ---------------------------------------------------------------------------------data DevParser = DevParser {- devRegex :: Regex- , devFamRep :: Maybe Text- , devBrandRep :: Maybe Text- , devModelRep :: Maybe Text- } deriving (Eq,Show)+data OSParser = OSParser+ { osRegex :: Regex+ , osFamRep :: Maybe Text+ , osRep1 :: Maybe Text+ , osRep2 :: Maybe Text+ , osRep3 :: Maybe Text+ , osRep4 :: Maybe Text+ }+ deriving (Eq, Show) +data DevParser = DevParser+ { devRegex :: Regex+ , devFamRep :: Maybe Text+ , devBrandRep :: Maybe Text+ , devModelRep :: Maybe Text+ }+ deriving (Eq, Show) -------------------------------------------------------------------------------- parseRegex :: Object -> Parser Regex parseRegex v = do pat <- v .: "regex" flag <- v .:? "regex_flag" :: Parser (Maybe Text) let flags = case flag of- Just "i" -> [caseless]- _ -> []+ Just "i" -> [caseless]+ _ -> [] return (compile (T.encodeUtf8 pat) flags) --------------------------------------------------------------------------------- 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"-+ 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"- <*> v .:? "v1_replacement"- <*> v .:? "v2_replacement"- <*> v .:? "v3_replacement"- parseJSON _ = error "Object expected when parsing JSON"-+ parseJSON (Object v) =+ UAParser+ <$> parseRegex v+ <*> v .:? "family_replacement"+ <*> v .:? "v1_replacement"+ <*> v .:? "v2_replacement"+ <*> v .:? "v3_replacement"+ parseJSON _ = error "Object expected when parsing JSON" -------------------------------------------------------------------------------- instance FromJSON OSParser where- parseJSON (Object v) =- OSParser <$> parseRegex v- <*> v .:? "os_replacement"- <*> v .:? "os_v1_replacement"- <*> v .:? "os_v2_replacement"- <*> v .:? "os_v3_replacement"- <*> v .:? "os_v4_replacement"- parseJSON _ = error "Object expected when parsing JSON"-+ parseJSON (Object v) =+ OSParser+ <$> parseRegex v+ <*> v .:? "os_replacement"+ <*> v .:? "os_v1_replacement"+ <*> v .:? "os_v2_replacement"+ <*> v .:? "os_v3_replacement"+ <*> v .:? "os_v4_replacement"+ parseJSON _ = error "Object expected when parsing JSON" -------------------------------------------------------------------------------- instance FromJSON DevParser where- parseJSON (Object v) = do- r <- parseRegex v- fam <- v .:? "device_replacement"- brandRep <- v .:? "brand_replacement"- modRep <- v .:? "model_replacement"- return (DevParser { devRegex = r- , devFamRep = fam- , devBrandRep = brandRep- , devModelRep = modRep})- parseJSON _ = error "Object expected when parsing JSON"-+ parseJSON (Object v) = do+ r <- parseRegex v+ fam <- v .:? "device_replacement"+ brandRep <- v .:? "brand_replacement"+ modRep <- v .:? "model_replacement"+ return+ ( DevParser+ { devRegex = r+ , devFamRep = fam+ , devBrandRep = brandRep+ , devModelRep = modRep+ }+ )+ parseJSON _ = error "Object expected when parsing JSON" -------------------------------------------------------------------------------- at :: [a] -> Int -> Maybe a at [] _ = Nothing-at (a:_) 0 = Just a-at (_:as) n- | n > 0 = at as (pred n)+at (a : _) 0 = Just a+at (_ : as) n+ | n > 0 = at as (pred n) | otherwise = Nothing
src/Web/UAParser/SuiteUtils.hs view
@@ -1,75 +1,78 @@-{-# LANGUAGE OverloadedStrings #-} module Web.UAParser.SuiteUtils- ( UserAgentTestCase(..)- , OSTestCase(..)- , DevTestCase(..)- , loadTests- ) where-+ ( UserAgentTestCase (..)+ , OSTestCase (..)+ , DevTestCase (..)+ , loadTests+ ) where ---------------------------------------------------------------------------------import Control.Applicative-import Control.Monad (join)-import Data.Aeson hiding ((.:?))-import qualified Data.Aeson as A-import Data.ByteString (ByteString)-import Data.String (fromString)-import Data.Text (Text)-import qualified Data.Text.Encoding as T-import Data.Yaml hiding ((.:?))-import System.FilePath--------------------------------------------------------------------------------+import Prelude +import Control.Applicative+import Control.Monad (join)+import Data.Aeson hiding ((.:?))+import qualified Data.Aeson as A+import Data.ByteString (ByteString)+import Data.String (fromString)+import Data.Text (Text)+import qualified Data.Text.Encoding as T+import Data.Yaml hiding ((.:?))+import System.FilePath -- Loading Test Cases loadTests :: FromJSON a => FilePath -> IO a-loadTests fp = either (error . show) (either error id . parseEither p) `fmap` decodeFileEither fp'- where- fp' = "deps/uap-core" </> fp- p = withObject "Value" $ \x -> x .: "test_cases"-----------------------------------------------------------------------------------data UserAgentTestCase = UATC {- uatcString :: ByteString- , uatcFamily :: Text- , uatcV1 :: Maybe Text- , uatcV2 :: Maybe Text- , uatcV3 :: Maybe Text- } deriving (Show)+loadTests fp =+ either (error . show) (either error id . parseEither p)+ `fmap` decodeFileEither fp'+ where+ fp' = "deps/uap-core" </> fp+ p = withObject "Value" $ \x -> x .: "test_cases" +data UserAgentTestCase = UATC+ { uatcString :: ByteString+ , uatcFamily :: Text+ , uatcV1 :: Maybe Text+ , uatcV2 :: Maybe Text+ , uatcV3 :: Maybe Text+ }+ deriving (Show) instance FromJSON UserAgentTestCase where parseJSON = withObject "UserAgentTestCase" parse- where parse v = UATC <$> T.encodeUtf8 <$> v .: "user_agent_string"- <*> v .: "family"- <*> v .:? "major"- <*> v .:? "minor"- <*> v .:? "patch"-----------------------------------------------------------------------------------data OSTestCase = OSTC {- ostcString :: ByteString- , ostcFamily :: Text- , ostcV1 :: Maybe Text- , ostcV2 :: Maybe Text- , ostcV3 :: Maybe Text- , ostcV4 :: Maybe Text- } deriving (Show)+ where+ parse v =+ UATC+ <$> T.encodeUtf8+ <$> v .: "user_agent_string"+ <*> v .: "family"+ <*> v .:? "major"+ <*> v .:? "minor"+ <*> v .:? "patch" +data OSTestCase = OSTC+ { ostcString :: ByteString+ , ostcFamily :: Text+ , ostcV1 :: Maybe Text+ , ostcV2 :: Maybe Text+ , ostcV3 :: Maybe Text+ , ostcV4 :: Maybe Text+ }+ deriving (Show) instance FromJSON OSTestCase where parseJSON = withObject "OSTestCase" parse- where parse v = OSTC <$> (T.encodeUtf8 <$> v .: "user_agent_string" <|> return "")- <*> v .: "family"- <*> nonBlank (v .:? "major")- <*> nonBlank (v .:? "minor")- <*> nonBlank (v .:? "patch")- <*> nonBlank (v .:? "patch_minor")+ where+ parse v =+ OSTC+ <$> (T.encodeUtf8 <$> v .: "user_agent_string" <|> return "")+ <*> v .: "family"+ <*> nonBlank (v .:? "major")+ <*> nonBlank (v .:? "minor")+ <*> nonBlank (v .:? "patch")+ <*> nonBlank (v .:? "patch_minor") -nonBlank :: (Monad m) =>- m (Maybe Text) -> m (Maybe Text)+nonBlank+ :: Monad m+ => m (Maybe Text) -> m (Maybe Text) nonBlank f = do res <- f return $ case res of@@ -77,26 +80,25 @@ Just x -> Just x Nothing -> Nothing ----------------------------------------------------------------------------------data DevTestCase = DTC {- dtcString :: ByteString- , dtcFamily :: Text- , dtcBrand :: Maybe Text- , dtcModel :: Maybe Text- } deriving (Show, Eq)-+data DevTestCase = DTC+ { dtcString :: ByteString+ , dtcFamily :: Text+ , dtcBrand :: Maybe Text+ , dtcModel :: Maybe Text+ }+ deriving (Eq, Show) instance FromJSON DevTestCase where parseJSON = withObject "DevTestCase" parse- where parse o = DTC <$> (T.encodeUtf8 <$> o .: "user_agent_string")- <*> o .: "family"- <*> nonBlank (o .:? "brand")- <*> nonBlank (o .:? "model")-+ where+ parse o =+ DTC+ <$> (T.encodeUtf8 <$> o .: "user_agent_string")+ <*> o .: "family"+ <*> nonBlank (o .:? "brand")+ <*> nonBlank (o .:? "model") -------------------------------------------------------------------------------- -- | Backport a more lenient version of .:? from newer versions of -- aeson. It accepts an explicit null as well as an omitted field.-(.:?) :: (FromJSON a) => Object -> String -> Parser (Maybe a)+(.:?) :: FromJSON a => Object -> String -> Parser (Maybe a) o .:? k = join <$> (o A..:? fromString k)
test/Main.hs view
@@ -1,98 +1,102 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE RecordWildCards #-} module Main where ----------------------------------------------------------------------------------import Control.Applicative as A-import qualified Data.ByteString.Char8 as B-import Data.Monoid as M-import qualified Data.Text as T-import Test.Tasty-import Test.Tasty.HUnit---------------------------------------------------------------------------------import Web.UAParser-import Web.UAParser.SuiteUtils--------------------------------------------------------------------------------+import Prelude +import Control.Applicative as A+import qualified Data.ByteString.Char8 as B+import Data.Monoid as M+import qualified Data.Text as T+import Test.Tasty+import Test.Tasty.HUnit+import Web.UAParser+import Web.UAParser.SuiteUtils main :: IO () main = do- uaCases <- M.mconcat A.<$> mapM loadTests ["test_resources/firefox_user_agent_strings.yaml"- ,"test_resources/pgts_browser_list.yaml"- ,"tests/test_ua.yaml"]- osCases <- mconcat <$> mapM loadTests [ "test_resources/additional_os_tests.yaml"- , "tests/test_os.yaml" ]+ uaCases <-+ M.mconcat+ A.<$> mapM+ loadTests+ [ "test_resources/firefox_user_agent_strings.yaml"+ , "test_resources/pgts_browser_list.yaml"+ , "tests/test_ua.yaml"+ ]+ osCases <-+ mconcat+ <$> mapM+ loadTests+ [ "test_resources/additional_os_tests.yaml"+ , "tests/test_os.yaml"+ ] devCases <- loadTests "tests/test_device.yaml"- defaultMain $ testGroup "ua-parser" [ uaTests uaCases- , osTests osCases- , devTests devCases- ]-+ defaultMain+ $ testGroup+ "ua-parser"+ [ uaTests uaCases+ , osTests osCases+ , devTests devCases+ ] -------------------------------------------------------------------------------- uaTests :: [UserAgentTestCase] -> TestTree uaTests = testGroup "UA Parsing Tests" . map testUAParser --------------------------------------------------------------------------------- testUAParser :: UserAgentTestCase -> TestTree-testUAParser UATC{..} = testCase tn $ do+testUAParser UATC {uatcString, uatcFamily, uatcV1, uatcV2, uatcV3} = testCase tn $ do assertEqual "family is same" uatcFamily uarFamily assertEqual "v1 is the same" uatcV1 uarV1 assertEqual "v2 is the same" uatcV2 uarV2 assertEqual "v3 is the same" uatcV3 uarV3- where- UAResult {..} = parseUALenient uatcString- tn = T.unpack $ T.intercalate "/" ["UA Test: ", uatcFamily, m uatcV1, m uatcV2, m uatcV3]- m x = maybe "-" id x-+ where+ UAResult {uarFamily, uarV1, uarV2, uarV3} = parseUALenient uatcString+ tn =+ T.unpack+ $ T.intercalate "/" ["UA Test: ", uatcFamily, m uatcV1, m uatcV2, m uatcV3]+ m x = maybe "-" id x -------------------------------------------------------------------------------- -- OS Testing osTests :: [OSTestCase] -> TestTree osTests = testGroup "OS Parsing Tests" . map testOSParser --------------------------------------------------------------------------------- testOSParser :: OSTestCase -> TestTree-testOSParser OSTC{..} = testCase tn $ do+testOSParser OSTC {ostcString, ostcFamily, ostcV1, ostcV2, ostcV3, ostcV4} = testCase tn $ do assertEqual "family is same" ostcFamily osrFamily- assertEqual "major is the same" ostcV1 osrV1- assertEqual "minor is the same" ostcV2 osrV2- assertEqual "patch is the same" ostcV3 osrV3+ assertEqual "major is the same" ostcV1 osrV1+ assertEqual "minor is the same" ostcV2 osrV2+ assertEqual "patch is the same" ostcV3 osrV3 assertEqual "patch_minor is the same" ostcV4 osrV4- where- OSResult {..} = parseOSLenient ostcString- tn = B.unpack ostcString <> " - " <> T.unpack summary- summary = T.intercalate "/" [ "OS Test: "- , ostcFamily- , m ostcV1- , m ostcV2- , m ostcV3- , m ostcV4- ]- m x = maybe "-" id x-+ where+ OSResult {osrFamily, osrV1, osrV2, osrV3, osrV4} = parseOSLenient ostcString+ tn = B.unpack ostcString <> " - " <> T.unpack summary+ summary =+ T.intercalate+ "/"+ [ "OS Test: "+ , ostcFamily+ , m ostcV1+ , m ostcV2+ , m ostcV3+ , m ostcV4+ ]+ m x = maybe "-" id x -------------------------------------------------------------------------------- -- Dev Testing devTests :: [DevTestCase] -> TestTree devTests = testGroup "Dev Parsing Tests" . map testDevParser --------------------------------------------------------------------------------- testDevParser :: DevTestCase -> TestTree-testDevParser DTC{..} = testCase tn $ do+testDevParser DTC {dtcString, dtcFamily, dtcBrand, dtcModel} = testCase tn $ do assertEqual "family is same" dtcFamily drFamily assertEqual "brand is the same" dtcBrand drBrand assertEqual "model is the same" dtcModel drModel- where- DevResult {..} = parseDevLenient dtcString- tn = B.unpack dtcString <> " - " <> T.unpack summary- summary = T.intercalate "/" [ "Dev Test: "- , dtcFamily- , m dtcBrand- , m dtcModel- ]- m x = maybe "-" id x+ where+ DevResult {drFamily, drBrand, drModel} = parseDevLenient dtcString+ tn = B.unpack dtcString <> " - " <> T.unpack summary+ summary =+ T.intercalate+ "/"+ [ "Dev Test: "+ , dtcFamily+ , m dtcBrand+ , m dtcModel+ ]+ m x = maybe "-" id x