diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/bench/Main.hs b/bench/Main.hs --- a/bench/Main.hs +++ b/bench/Main.hs @@ -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 + ] diff --git a/freckle-ua-parser.cabal b/freckle-ua-parser.cabal --- a/freckle-ua-parser.cabal +++ b/freckle-ua-parser.cabal @@ -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, diff --git a/package.yaml b/package.yaml --- a/package.yaml +++ b/package.yaml @@ -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 diff --git a/src/Web/UAParser.hs b/src/Web/UAParser.hs --- a/src/Web/UAParser.hs +++ b/src/Web/UAParser.hs @@ -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 diff --git a/src/Web/UAParser/SuiteUtils.hs b/src/Web/UAParser/SuiteUtils.hs --- a/src/Web/UAParser/SuiteUtils.hs +++ b/src/Web/UAParser/SuiteUtils.hs @@ -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) diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -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