freckle-ua-parser 0.1.1.1 → 0.1.2.0

raw patch · 4 files changed

+110/−164 lines, 4 filesdep +pcre2dep −pcre-lightPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: pcre2

Dependencies removed: pcre-light

API changes (from Hackage documentation)

Files

• freckle-ua-parser.cabal +4/−4
• package.yaml +2/−2
• src/Web/UAParser.hs +68/−134
• test/Main.hs +36/−24

@@ -1,6 +1,6 @@ cabal-version:      1.12 name:               freckle-ua-parser-version:            0.1.1.1+version:            0.1.2.0 license:            BSD3 license-file:       LICENSE copyright:          2012 Ozgun Ataman, 2026 Renaissance Learning Inc@@ -60,7 +60,7 @@         data-default >=0.7.1.1,         deepseq >=1.4.8.0,         file-embed >=0.0.15.0 && <0.1,-        pcre-light >=0.4.1.2,+        pcre2 >=2.2.1,         text >=2.0.2,         yaml >=0.8.3 @@ -93,7 +93,7 @@         deepseq >=1.4.8.0,         file-embed >=0.0.15.0 && <0.1,         filepath >=1.4.2.2,-        pcre-light >=0.4.1.2,+        pcre2 >=2.2.1,         tasty >=1.4.3,         tasty-hunit >=0.10.1,         tasty-quickcheck >=0.10.2,@@ -130,7 +130,7 @@         file-embed >=0.0.15.0 && <0.1,         filepath >=1.4.2.2,         freckle-ua-parser,-        pcre-light >=0.4.1.2,+        pcre2 >=2.2.1,         text >=2.0.2,         yaml >=0.8.3 

@@ -1,5 +1,5 @@ name: freckle-ua-parser-version: 0.1.1.1+version: 0.1.2.0 synopsis: Parsers for User-Agent strings description: |   Parses User-Agent strings into browser, operating system, and device details,@@ -45,7 +45,7 @@   - data-default   - deepseq   - file-embed < 0.1-  - pcre-light+  - pcre2   - text   - yaml >= 0.8.3 library:

@@ -27,6 +27,8 @@ import Data.Data import Data.Default import Data.FileEmbed+import Data.List.NonEmpty (NonEmpty)+import Data.List.NonEmpty qualified as NE import Data.Maybe import Data.Monoid as M import Data.Serialize@@ -34,9 +36,10 @@ import Data.Text (Text) import Data.Text qualified as T import Data.Text.Encoding qualified as T+import Data.Text.Encoding.Error (lenientDecode) import Data.Yaml import GHC.Generics-import Text.Regex.PCRE.Light+import Text.Regex.Pcre2 (Option (Caseless), capturesOpt)  -- UA Parser uaConfig :: UAConfig@@ -56,11 +59,10 @@ parseUA bs = msum $ map go uaParsers  where   UAConfig {uaParsers} = uaConfig+  subject = decodeSubject bs -  go UAParser {uaRegex, uaFamRep, uaV1Rep, uaV2Rep, uaV3Rep} =-    either (const Nothing) (fmap normalize . mkRes)-      . mapM T.decodeUtf8'-      =<< match uaRegex bs []+  go UAParser {uaMatch, uaFamRep, uaV1Rep, uaV2Rep, uaV3Rep} =+    normalize . mkRes . NE.toList <$> uaMatch subject    where     normalize (UAResult f v1 v2 v3) =       UAResult@@ -70,47 +72,18 @@         (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)+    mkRes caps =+      UAResult+        (repF caps (familyCap caps))+        (repV1 caps)+        (repV2 caps)+        (repV3 caps) +    repV1 caps = maybe (capture caps 2) Just (makeReplacements caps <$> uaV1Rep)+    repV2 caps = maybe (capture caps 3) Just (makeReplacements caps <$> uaV2Rep)+    repV3 caps = maybe (capture caps 4) Just (makeReplacements caps <$> uaV3Rep)+     repF caps x = maybe x (makeReplacements caps) uaFamRep  -- | Results datatype for the parsed User-Agent@@ -143,68 +116,25 @@ parseOS bs = msum $ map go osParsers  where   UAConfig {osParsers} = uaConfig+  subject = decodeSubject bs -  go OSParser {osRegex, osFamRep, osRep1, osRep2, osRep3, osRep4} =-    either (const Nothing) mkRes-      . mapM T.decodeUtf8'-      =<< match osRegex bs []+  go OSParser {osMatch, osFamRep, osRep1, osRep2, osRep3, osRep4} =+    mkRes . NE.toList <$> osMatch subject    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+    mkRes caps =+      OSResult+        (repF caps (familyCap caps))+        (repV1 caps)+        (repV2 caps)+        (repV3 caps)+        (repV4 caps)      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 = maybe (capture caps 2) Just (makeReplacements caps <$> osRep1)+    repV2 caps = maybe (capture caps 3) Just (makeReplacements caps <$> osRep2)+    repV3 caps = maybe (capture caps 4) Just (makeReplacements caps <$> osRep3)+    repV4 caps = maybe (capture caps 5) Just (makeReplacements caps <$> osRep4)  -- | Result type for 'parseOS' data OSResult = OSResult@@ -236,18 +166,13 @@ parseDev bs = msum $ map go devParsers  where   UAConfig {devParsers} = uaConfig+  subject = decodeSubject bs -  go DevParser {devRegex, devFamRep, devBrandRep, devModelRep} =-    either (const Nothing) mkRes-      . mapM T.decodeUtf8'-      =<< match devRegex bs []+  go DevParser {devMatch, devFamRep, devBrandRep, devModelRep} =+    mkRes . NE.toList <$> devMatch subject    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+    mkRes caps =+      mkDR (repF caps (familyCap caps)) (repBrand caps) (repModel caps)      mkDR a b c = DevResult (T.strip a) (strip' =<< b) (strip' =<< c) @@ -255,13 +180,16 @@       "" -> Nothing       t' -> Just t' -    -- 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)+    repBrand caps =+      maybe (capture caps 2) 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)+    repModel caps =+      maybe+        (capture caps 3 <|> capture caps 1)+        Just+        (makeReplacements caps <$> devModelRep)      repF caps x = maybe x (makeReplacements caps) devFamRep @@ -303,43 +231,39 @@   , osParsers :: [OSParser]   , devParsers :: [DevParser]   }-  deriving (Eq, Show)  data UAParser = UAParser-  { uaRegex :: Regex+  { uaMatch :: Text -> Maybe (NonEmpty Text)   , uaFamRep :: Maybe Text   , uaV1Rep :: Maybe Text   , uaV2Rep :: Maybe Text   , uaV3Rep :: Maybe Text   }-  deriving (Eq, Show)  data OSParser = OSParser-  { osRegex :: Regex+  { osMatch :: Text -> Maybe (NonEmpty Text)   , osFamRep :: Maybe Text   , osRep1 :: Maybe Text   , osRep2 :: Maybe Text   , osRep3 :: Maybe Text   , osRep4 :: Maybe Text   }-  deriving (Eq, Show)  data DevParser = DevParser-  { devRegex :: Regex+  { devMatch :: Text -> Maybe (NonEmpty Text)   , devFamRep :: Maybe Text   , devBrandRep :: Maybe Text   , devModelRep :: Maybe Text   }-  deriving (Eq, Show) -parseRegex :: Object -> Parser Regex+parseRegex :: Object -> Parser (Text -> Maybe (NonEmpty Text)) parseRegex v = do   pat <- v .: "regex"   flag <- v .:? "regex_flag" :: Parser (Maybe Text)-  let flags = case flag of-        Just "i" -> [caseless]-        _ -> []-  return (compile (T.encodeUtf8 pat) flags)+  let opts = case flag of+        Just "i" -> Caseless+        _ -> mempty+  return (capturesOpt opts pat)  instance FromJSON UAConfig where   parseJSON (Object v) =@@ -378,7 +302,7 @@     modRep <- v .:? "model_replacement"     return       ( DevParser-          { devRegex = r+          { devMatch = r           , devFamRep = fam           , devBrandRep = brandRep           , devModelRep = modRep@@ -386,9 +310,19 @@       )   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)-  | otherwise = Nothing+decodeSubject :: ByteString -> Text+decodeSubject = T.decodeUtf8With lenientDecode++-- | A capture group by index (0 is the whole match). Groups that are absent,+-- unset or empty are all 'Nothing'.+capture :: [Text] -> Int -> Maybe Text+capture caps n = case drop n caps of+  t : _ | not (T.null t) -> Just t+  _ -> Nothing++-- | The first capture group, or the whole match when the pattern has none+familyCap :: [Text] -> Text+familyCap caps = case caps of+  _ : f : _ -> f+  whole : _ -> whole+  [] -> ""

@@ -105,64 +105,76 @@   m x = maybe "-" id x  -- Input that is not ASCII, or not UTF-8 at all, is outside what the shared--- uap-core test cases (deps/uap-core) cover.+-- uap-core test cases (deps/uap-core) cover. The subject is decoded as UTF-8+-- before matching, leniently, so invalid bytes become U+FFFD. encodingTests :: TestTree encodingTests =   testGroup     "Encoding"-    [ testCase "invalid UTF-8 in a captured family falls through to a later parser"+    [ testCase "invalid UTF-8 in a captured family is replaced and still matches"         $ parseUA "77 WABC\xff/11 CFNetwork/758.3.15 Darwin/15.4.0"           @?= Just             UAResult-              { uarFamily = "CFNetwork"-              , uarV1 = Just "758"-              , uarV2 = Just "3"-              , uarV3 = Just "15"+              { uarFamily = "77 WABC\xfffd"+              , uarV1 = Just "11"+              , uarV2 = Nothing+              , uarV3 = Nothing               }-    , testCase-        "invalid UTF-8 in a captured device falls through to the generic parser"+    , testCase "invalid UTF-8 in a captured device is replaced and still matches"         $ parseDev "Amazon.com/2.8.0 (Android/2.3.5/HTC\xe9 Desire HD A9191)"           @?= Just             DevResult-              { drFamily = "Generic Smartphone"-              , drBrand = Just "Generic"-              , drModel = Just "Smartphone"+              { drFamily = "HTC \xfffd Desire HD A9191"+              , drBrand = Just "HTC"+              , drModel = Just "\xfffd Desire HD A9191"               }-    , testCase "invalid UTF-8 can prevent an OS match"+    , testCase "invalid UTF-8 does not prevent an OS match"         $ parseOS "App/1.0.0 CFNetwork/897.\xc3\&5 Darwin/17.5.0"-          @?= Nothing-    , testCase "invalid UTF-8 can change which OS version is captured"+          @?= Just+            OSResult+              { osrFamily = "iOS"+              , osrV1 = Just "11"+              , osrV2 = Just "3"+              , osrV3 = Nothing+              , osrV4 = Nothing+              }+    , testCase "invalid UTF-8 does not change which OS version is captured"         $ parseOS           "Box \xc3Sync/4.0.7848;Windows/10;Intel64 Family 6 Model 158 Stepping 9, GenuineIntel/64bit"           @?= Just             OSResult               { osrFamily = "Windows"-              , osrV1 = Nothing+              , osrV1 = Just "10"               , osrV2 = Nothing               , osrV3 = Nothing               , osrV4 = Nothing               }-    , testCase "a multibyte character ending a family name prevents a UA match"+    , testCase "a multibyte character ending a family name is part of the match"         $ parseUA "FollowSit\xc3\xa9 Bot ( http://www.followsite.com/bot.html )"-          @?= Nothing-    , testCase "a multibyte character is matched as separate bytes"+          @?= Just+            UAResult+              { uarFamily = "FollowSit\xe9 Bot"+              , uarV1 = Nothing+              , uarV2 = Nothing+              , uarV3 = Nothing+              }+    , testCase "a multibyte character is matched as one character"         $ parseUA "8bo Crawle\xe6\x97\xa5 Bot"           @?= Just             UAResult-              { uarFamily = "bo Crawle"+              { uarFamily = "bo Crawle\x65e5 Bot"               , uarV1 = Nothing               , uarV2 = Nothing               , uarV3 = Nothing               }-    , testCase-        "a multibyte character inside a device name falls through to the generic parser"+    , testCase "a multibyte character inside a device name is part of the match"         $ parseDev           "Android 4.0.4;AppleWebKit/534.30;Build/IMM76D;T-\xf0\x9f\x98\x80\&70 Build/IMM76D"           @?= Just             DevResult-              { drFamily = "Generic Smartphone"-              , drBrand = Just "Generic"-              , drModel = Just "Smartphone"+              { drFamily = "T-\x1f600\&70"+              , drBrand = Just "Audiosonic"+              , drModel = Just "T-\x1f600\&70"               }     , testCase "trailing invalid UTF-8 after a complete match is ignored"         $ parseUA