├── .ghci ├── .gitignore ├── .gitmodules ├── .travis.yml ├── CONTRIBUTORS.md ├── LICENSE ├── README.md ├── Setup.hs ├── bench └── Main.hs ├── changelog.md ├── src └── Web │ ├── UAParser.hs │ └── UAParser │ └── SuiteUtils.hs ├── stack.yaml ├── stack.yaml.lock ├── test ├── .ghci └── Main.hs └── ua-parser.cabal /.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | cabal-dev 3 | *.o 4 | *.hi 5 | *.chi 6 | *.chs.h 7 | *.dyn_o 8 | *.dyn_hi 9 | .hpc 10 | .hsenv 11 | .cabal-sandbox/ 12 | cabal.sandbox.config 13 | *.prof 14 | *.aux 15 | *.hp 16 | .stack-work 17 | dist-newstyle 18 | -------------------------------------------------------------------------------- /.gitmodules: -------------------------------------------------------------------------------- 1 | [submodule "deps/uap-core"] 2 | path = deps/uap-core 3 | url = https://github.com/ua-parser/uap-core.git 4 | 5 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | # Use new container infrastructure to enable caching 2 | sudo: false 3 | 4 | # Choose a lightweight base image; we provide our own build tools. 5 | language: c 6 | 7 | # GHC depends on GMP. You can add other dependencies here as well. 8 | addons: 9 | apt: 10 | packages: 11 | - libgmp-dev 12 | 13 | # The different configurations we want to test. You could also do things like 14 | # change flags or use --stack-yaml to point to a different file. 15 | env: 16 | - ARGS="--resolver=lts-13" 17 | - ARGS="--resolver=lts-14" 18 | - ARGS="--resolver=lts-15" 19 | - ARGS="" 20 | - ARGS="--resolver=nightly" 21 | 22 | before_install: 23 | # Download and unpack the stack executable 24 | - mkdir -p ~/.local/bin 25 | - export PATH=$HOME/.local/bin:$PATH 26 | - travis_retry curl -L https://www.stackage.org/stack/linux-x86_64 | tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack' 27 | 28 | # This line does all of the work: installs GHC if necessary, build the library, 29 | # executables, and test suites, and runs the test suites. --no-terminal works 30 | # around some quirks in Travis's terminal implementation. 31 | script: 32 | - stack $ARGS setup 33 | # Our tests output tons of text. Travis will fail a test for outputting > 4MB of output. If you have a smart terminal, it will still use ansi-terminal to display test headings. When we set TERM to dumb, it should print nothing on success but hopefully print an error on failure (unlike --quiet). 34 | - TERM=dumb stack $ARGS test --no-terminal --haddock --no-haddock-deps --test-arguments="--hide-successes" 35 | - stack $ARGS bench 36 | - stack $ARGS build 37 | - stack $ARGS sdist 38 | 39 | # Caching so the next build will be fast too. 40 | cache: 41 | directories: 42 | - .stack-work 43 | -------------------------------------------------------------------------------- /CONTRIBUTORS.md: -------------------------------------------------------------------------------- 1 | # Authors 2 | 3 | - Ozgun Ataman (@ozataman) 4 | 5 | # Contributors 6 | 7 | - Bas van Dijk (@basvandijk) 8 | - Greg Weber (@gregwebs) 9 | - Chris Allen (@bitemyapp) 10 | - Michael Xavier (@michaelxavier) 11 | - Fredrik Olsen (@folsen) 12 | - Kostiantyn Rybnikov (@k-bx) 13 | - Alexander Shestakov (@maksar) 14 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c)2012, Ozgun Ataman 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Ozgun Ataman nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # uap-haskell is the ua-parser library for Haskell 2 | [![Build Status](https://travis-ci.org/ua-parser/uap-haskell.svg?branch=master)](https://travis-ci.org/ua-parser/uap-haskell) 3 | [![Hackage](https://img.shields.io/hackage/v/ua-parser.svg?style=flat)](https://hackage.haskell.org/package/ua-parser) 4 | 5 | ## Hackage 6 | 7 | http://hackage.haskell.org/package/ua-parser 8 | 9 | ## Github 10 | 11 | https://github.com/ua-parser/uap-haskell 12 | 13 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /bench/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | {-# OPTIONS_GHC -fno-warn-orphans #-} 3 | module Main 4 | ( main 5 | ) where 6 | 7 | 8 | ------------------------------------------------------------------------------- 9 | import Control.Applicative as A 10 | import Criterion.Main 11 | ------------------------------------------------------------------------------- 12 | import Web.UAParser 13 | import Web.UAParser.SuiteUtils 14 | ------------------------------------------------------------------------------- 15 | 16 | 17 | main :: IO () 18 | main = do 19 | uas <- take 100 A.<$> loadTests "test_resources/firefox_user_agent_strings.yaml" 20 | oses <- take 100 <$> loadTests "test_resources/additional_os_tests.yaml" 21 | devs <- take 100 <$> loadTests "tests/test_device.yaml" 22 | defaultMain [ bench "Parsing 100 UAs" $ nf (map (parseUA . uatcString)) uas 23 | , bench "Parsing 100 OSes" $ nf (map (parseOS . ostcString)) oses 24 | , bench "Parsing 100 Devices" $ nf (map (parseDev . dtcString)) devs 25 | ] 26 | -------------------------------------------------------------------------------- /changelog.md: -------------------------------------------------------------------------------- 1 | 0.7.7.0 2 | * [Add NFData and Serialize instances](https://github.com/ua-parser/uap-haskell/pull/16) 3 | 4 | 0.7.6.0 5 | * Newer GHC support 6 | * Update regexes 7 | 8 | 0.7.5.1 9 | * Resolve deprecation warning in YAML parsing. 10 | 11 | 0.7.5.0 12 | * Remove aeson and yaml upper bounds 13 | 14 | 0.7.4.1 15 | * Loosen aeson bounds 16 | 17 | 0.7.4 18 | * Update uap-core 19 | 20 | 0.7.3 21 | * Allow for aeson 1.1 22 | 23 | 0.7.2 24 | * Allow for aeson 1.0 25 | -------------------------------------------------------------------------------- /src/Web/UAParser.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveAnyClass #-} 2 | {-# LANGUAGE DeriveDataTypeable #-} 3 | {-# LANGUAGE DeriveGeneric #-} 4 | {-# LANGUAGE NoMonomorphismRestriction #-} 5 | {-# LANGUAGE OverloadedStrings #-} 6 | {-# LANGUAGE RecordWildCards #-} 7 | {-# LANGUAGE TemplateHaskell #-} 8 | 9 | module Web.UAParser 10 | ( -- * Parsing browser (user agent) 11 | parseUA 12 | , parseUALenient 13 | , UAResult (..) 14 | , uarVersion 15 | 16 | -- * Parsing OS 17 | , parseOS 18 | , parseOSLenient 19 | , OSResult (..) 20 | , osrVersion 21 | 22 | -- * Parsing Dev 23 | , parseDev 24 | , parseDevLenient 25 | , DevResult (..) 26 | ) where 27 | 28 | ------------------------------------------------------------------------------- 29 | import Control.Applicative 30 | import Control.DeepSeq 31 | import Control.Monad 32 | import Data.Aeson 33 | import Data.ByteString.Char8 (ByteString) 34 | import Data.Data 35 | import Data.Default 36 | import Data.FileEmbed 37 | import Data.Maybe 38 | import Data.Monoid as M 39 | import Data.Text (Text) 40 | import qualified Data.Text as T 41 | import qualified Data.Text.Encoding as T 42 | import Data.Yaml 43 | import GHC.Generics 44 | import Text.Regex.PCRE.Light 45 | import Data.Serialize 46 | import Data.Serialize.Text () 47 | ------------------------------------------------------------------------------- 48 | 49 | 50 | ------------------------------------------------------------------------------- 51 | -- UA Parser 52 | ------------------------------------------------------------------------------- 53 | uaConfig :: UAConfig 54 | uaConfig = either (error . show) id $ decodeEither' $(embedFile "deps/uap-core/regexes.yaml") 55 | {-# NOINLINE uaConfig #-} 56 | 57 | 58 | ------------------------------------------------------------------------------- 59 | -- | Parser that, upon failure to match a pattern returns a result of 60 | -- family "Other" with all other fields blank. This is mainly for 61 | -- compatibility with the uap-core test suite 62 | parseUALenient :: ByteString -> UAResult 63 | parseUALenient = fromMaybe def . parseUA 64 | 65 | 66 | ------------------------------------------------------------------------------- 67 | -- | Parse a given User-Agent string 68 | parseUA :: ByteString -> Maybe UAResult 69 | parseUA bs = msum $ map go uaParsers 70 | where 71 | UAConfig{..} = uaConfig 72 | 73 | go UAParser{..} = either (const Nothing) (fmap normalize . mkRes) 74 | . mapM T.decodeUtf8' =<< match uaRegex bs [] 75 | where 76 | normalize (UAResult f v1 v2 v3) = UAResult f (normalizeMaybeText v1) (normalizeMaybeText v2) (normalizeMaybeText v3) 77 | normalizeMaybeText (Just "") = Nothing 78 | normalizeMaybeText x = x 79 | mkRes caps@(_:f:v1:v2:v3:_) = Just $ UAResult (repF caps f) (repV1 caps (Just v1)) (repV2 caps (Just v2)) (repV3 caps (Just v3)) 80 | mkRes caps@[_,f,v1,v2] = Just $ UAResult (repF caps f) (repV1 caps (Just v1)) (repV2 caps (Just v2)) (repV3 caps Nothing) 81 | mkRes caps@[_,f,v1] = Just $ UAResult (repF caps f) (repV1 caps (Just v1)) (repV2 caps Nothing) (repV3 caps Nothing) 82 | mkRes caps@[_,f] = Just $ UAResult (repF caps f) (repV1 caps Nothing) (repV2 caps Nothing) (repV3 caps Nothing) 83 | mkRes caps@[f] = Just $ UAResult (repF caps f) (repV1 caps Nothing) (repV2 caps Nothing) (repV3 caps Nothing) 84 | mkRes _ = Nothing 85 | 86 | repV1 caps x = maybe (x <|> caps `at` 2) Just (makeReplacements caps <$> uaV1Rep) 87 | repV2 caps x = maybe (x <|> caps `at` 3) Just (makeReplacements caps <$> uaV2Rep) 88 | repV3 caps x = maybe (x <|> caps `at` 4) Just (makeReplacements caps <$> uaV3Rep) 89 | 90 | repF caps x = maybe x (makeReplacements caps) uaFamRep 91 | 92 | 93 | 94 | ------------------------------------------------------------------------------- 95 | -- | Results datatype for the parsed User-Agent 96 | data UAResult = UAResult { 97 | uarFamily :: Text 98 | , uarV1 :: Maybe Text 99 | , uarV2 :: Maybe Text 100 | , uarV3 :: Maybe Text 101 | } deriving (Show, Read, Eq, Typeable, Data, Generic, NFData, Serialize) 102 | 103 | 104 | ------------------------------------------------------------------------------- 105 | -- | Construct a browser version-string from 'UAResult' 106 | uarVersion :: UAResult -> Text 107 | uarVersion UAResult{..} = 108 | T.intercalate "." . catMaybes . takeWhile isJust $ [uarV1, uarV2, uarV3] 109 | 110 | 111 | ------------------------------------------------------------------------------- 112 | instance Default UAResult where 113 | def = UAResult "Other" Nothing Nothing Nothing 114 | 115 | 116 | ------------------------------------------------------------------------------- 117 | -- OS Parser 118 | ------------------------------------------------------------------------------- 119 | -- | Parser that, upon failure to match a pattern returns a result of 120 | -- family "Other" with all other fields blank. This is mainly for 121 | -- compatibility with the uap-core test suite 122 | parseOSLenient :: ByteString -> OSResult 123 | parseOSLenient = fromMaybe def . parseOS 124 | 125 | 126 | ------------------------------------------------------------------------------- 127 | -- | Parse OS from given User-Agent string 128 | parseOS :: ByteString -> Maybe OSResult 129 | parseOS bs = msum $ map go osParsers 130 | where 131 | UAConfig{..} = uaConfig 132 | 133 | go OSParser{..} = either (const Nothing) mkRes 134 | . mapM T.decodeUtf8' =<< match osRegex bs [] 135 | where 136 | 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)) 137 | 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) 138 | mkRes caps@[_,f,v1,v2] = Just $ OSResult (repF caps f) (repV1 caps (Just v1)) (repV2 caps (Just v2)) (repV3 caps Nothing) (repV4 caps Nothing) 139 | mkRes caps@[_,f,v1] = Just $ OSResult (repF caps f) (repV1 caps (Just v1)) (repV2 caps Nothing) (repV3 caps Nothing) (repV4 caps Nothing) 140 | mkRes caps@[_,f] = Just $ OSResult (repF caps f) (repV1 caps Nothing) (repV2 caps Nothing) (repV3 caps Nothing) (repV4 caps Nothing) 141 | mkRes caps@[f] = Just $ OSResult (repF caps f) (repV1 caps Nothing) (repV2 caps Nothing) (repV3 caps Nothing) (repV4 caps Nothing) 142 | mkRes _ = Nothing 143 | 144 | repF caps x = maybe x (makeReplacements caps) osFamRep 145 | 146 | repV1 caps x = maybe (x <|> caps `at` 2) Just (makeReplacements caps <$> osRep1) 147 | repV2 caps x = maybe (x <|> caps `at` 3) Just (makeReplacements caps <$> osRep2) 148 | repV3 caps x = maybe (x <|> caps `at` 4) Just (makeReplacements caps <$> osRep3) 149 | repV4 caps x = maybe (x <|> caps `at` 5) Just (makeReplacements caps <$> osRep4) 150 | 151 | ------------------------------------------------------------------------------- 152 | -- | Result type for 'parseOS' 153 | data OSResult = OSResult { 154 | osrFamily :: Text 155 | , osrV1 :: Maybe Text 156 | , osrV2 :: Maybe Text 157 | , osrV3 :: Maybe Text 158 | , osrV4 :: Maybe Text 159 | } deriving (Show,Read,Eq,Typeable,Data,Generic,NFData,Serialize) 160 | 161 | instance Default OSResult where 162 | def = OSResult "Other" Nothing Nothing Nothing Nothing 163 | 164 | 165 | ------------------------------------------------------------------------------- 166 | -- | Construct a version string from 'OSResult' 167 | osrVersion :: OSResult -> Text 168 | osrVersion OSResult{..} = 169 | T.intercalate "." . catMaybes . takeWhile isJust $ [osrV1, osrV2, osrV3, osrV4] 170 | 171 | 172 | ------------------------------------------------------------------------------- 173 | -- Dev Parser 174 | ------------------------------------------------------------------------------- 175 | -- | Parser that, upon failure to match a pattern returns a result of 176 | -- family "Other" with all other fields blank. This is mainly for 177 | -- compatibility with the uap-core test suite 178 | parseDevLenient :: ByteString -> DevResult 179 | parseDevLenient = fromMaybe def . parseDev 180 | 181 | 182 | ------------------------------------------------------------------------------- 183 | parseDev :: ByteString -> Maybe DevResult 184 | parseDev bs = msum $ map go devParsers 185 | where 186 | UAConfig{..} = uaConfig 187 | 188 | go DevParser{..} = either (const Nothing) mkRes 189 | . mapM T.decodeUtf8' =<< match devRegex bs [] 190 | where 191 | mkRes caps@(_:f:b:m:_) = Just $ mkDR (repF caps f) (repBrand caps (Just b)) (repModel caps (Just m)) 192 | mkRes caps@[_,f,b] = Just $ mkDR (repF caps f) (repBrand caps (Just b)) (repModel caps Nothing) 193 | mkRes caps@[_,f] = Just $ mkDR (repF caps f) (repBrand caps Nothing) (repModel caps Nothing) 194 | mkRes caps@[f] = Just $ mkDR (repF caps f) (repBrand caps Nothing) (repModel caps Nothing) 195 | mkRes _ = Nothing 196 | 197 | mkDR a b c = DevResult (T.strip a) (strip' =<< b) (strip' =<< c) 198 | 199 | strip' t = case T.strip t of 200 | "" -> Nothing 201 | t' -> Just t' 202 | 203 | --TODO: update other replacers to be like this if it works 204 | --TODO: some patterns don't capture so you should match on [f] 205 | repBrand caps x = maybe x Just (makeReplacements caps <$> devBrandRep) 206 | -- This technique is used in the python ua-parser. It isn't 207 | -- clear if there's a precedent in the spec but it clears up 208 | -- some remote edge cases (which may be test suite bugs TBH). 209 | repModel caps x = maybe (x <|> caps `at` 1) Just (makeReplacements caps <$> devModelRep) 210 | 211 | repF caps x = maybe x (makeReplacements caps) devFamRep 212 | 213 | 214 | ------------------------------------------------------------------------------- 215 | -- | Replace replacement placeholders with captures and remove any 216 | -- that are unused. Goes up to $4 as per the spec 217 | makeReplacements 218 | :: [Text] 219 | -- ^ Captures 220 | -> Text 221 | -- ^ Replacement text with 1-indexed replace points ($1, $2, $3 or $4) 222 | -> Text 223 | makeReplacements (_:cs) t = makeReplacements' (zip ([1..4] :: [Int]) (cs ++ repeat "")) t 224 | where makeReplacements' [] acc = acc 225 | makeReplacements' ((idx, cap):caps) acc = let acc' = T.replace ("$" M.<> showT idx) cap acc 226 | in makeReplacements' caps acc' 227 | makeReplacements _ t = t 228 | 229 | 230 | ------------------------------------------------------------------------------- 231 | showT :: Show a => a -> Text 232 | showT = T.pack . show 233 | 234 | 235 | ------------------------------------------------------------------------------- 236 | -- | Result type for 'parseDev' 237 | data DevResult = DevResult { 238 | drFamily :: Text 239 | , drBrand :: Maybe Text 240 | , drModel :: Maybe Text 241 | } deriving (Show,Read,Eq,Typeable,Data,Generic,NFData,Serialize) 242 | 243 | 244 | instance Default DevResult where 245 | def = DevResult "Other" Nothing Nothing 246 | 247 | 248 | ------------------------------------------------------------------------------- 249 | -- Parser Config 250 | ------------------------------------------------------------------------------- 251 | 252 | -- | User-Agent string parser data 253 | data UAConfig = UAConfig { 254 | uaParsers :: [UAParser] 255 | , osParsers :: [OSParser] 256 | , devParsers :: [DevParser] 257 | } deriving (Eq,Show) 258 | 259 | 260 | ------------------------------------------------------------------------------- 261 | data UAParser = UAParser { 262 | uaRegex :: Regex 263 | , uaFamRep :: Maybe Text 264 | , uaV1Rep :: Maybe Text 265 | , uaV2Rep :: Maybe Text 266 | , uaV3Rep :: Maybe Text 267 | } deriving (Eq,Show) 268 | 269 | 270 | ------------------------------------------------------------------------------- 271 | data OSParser = OSParser { 272 | osRegex :: Regex 273 | , osFamRep :: Maybe Text 274 | , osRep1 :: Maybe Text 275 | , osRep2 :: Maybe Text 276 | , osRep3 :: Maybe Text 277 | , osRep4 :: Maybe Text 278 | } deriving (Eq,Show) 279 | 280 | 281 | ------------------------------------------------------------------------------- 282 | data DevParser = DevParser { 283 | devRegex :: Regex 284 | , devFamRep :: Maybe Text 285 | , devBrandRep :: Maybe Text 286 | , devModelRep :: Maybe Text 287 | } deriving (Eq,Show) 288 | 289 | 290 | ------------------------------------------------------------------------------- 291 | parseRegex :: Object -> Parser Regex 292 | parseRegex v = do 293 | pat <- v .: "regex" 294 | flag <- v .:? "regex_flag" :: Parser (Maybe Text) 295 | let flags = case flag of 296 | Just "i" -> [caseless] 297 | _ -> [] 298 | return (compile (T.encodeUtf8 pat) flags) 299 | 300 | 301 | ------------------------------------------------------------------------------- 302 | instance FromJSON UAConfig where 303 | parseJSON (Object v) = 304 | UAConfig 305 | <$> v .: "user_agent_parsers" 306 | <*> v .: "os_parsers" 307 | <*> v .: "device_parsers" 308 | parseJSON _ = error "Object expected when parsing JSON" 309 | 310 | 311 | ------------------------------------------------------------------------------- 312 | instance FromJSON UAParser where 313 | parseJSON (Object v) = 314 | UAParser <$> parseRegex v 315 | <*> v .:? "family_replacement" 316 | <*> v .:? "v1_replacement" 317 | <*> v .:? "v2_replacement" 318 | <*> v .:? "v3_replacement" 319 | parseJSON _ = error "Object expected when parsing JSON" 320 | 321 | 322 | ------------------------------------------------------------------------------- 323 | instance FromJSON OSParser where 324 | parseJSON (Object v) = 325 | OSParser <$> parseRegex v 326 | <*> v .:? "os_replacement" 327 | <*> v .:? "os_v1_replacement" 328 | <*> v .:? "os_v2_replacement" 329 | <*> v .:? "os_v3_replacement" 330 | <*> v .:? "os_v4_replacement" 331 | parseJSON _ = error "Object expected when parsing JSON" 332 | 333 | 334 | ------------------------------------------------------------------------------- 335 | instance FromJSON DevParser where 336 | parseJSON (Object v) = do 337 | r <- parseRegex v 338 | fam <- v .:? "device_replacement" 339 | brandRep <- v .:? "brand_replacement" 340 | modRep <- v .:? "model_replacement" 341 | return (DevParser { devRegex = r 342 | , devFamRep = fam 343 | , devBrandRep = brandRep 344 | , devModelRep = modRep}) 345 | parseJSON _ = error "Object expected when parsing JSON" 346 | 347 | 348 | ------------------------------------------------------------------------------- 349 | at :: [a] -> Int -> Maybe a 350 | at [] _ = Nothing 351 | at (a:_) 0 = Just a 352 | at (_:as) n 353 | | n > 0 = at as (pred n) 354 | | otherwise = Nothing 355 | -------------------------------------------------------------------------------- /src/Web/UAParser/SuiteUtils.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | module Web.UAParser.SuiteUtils 3 | ( UserAgentTestCase(..) 4 | , OSTestCase(..) 5 | , DevTestCase(..) 6 | , loadTests 7 | ) where 8 | 9 | 10 | ------------------------------------------------------------------------------- 11 | import Control.Applicative 12 | import Control.Monad (join) 13 | import Data.Aeson hiding ((.:?)) 14 | import qualified Data.Aeson as A 15 | import Data.ByteString (ByteString) 16 | import Data.Text (Text) 17 | import qualified Data.Text.Encoding as T 18 | import Data.Yaml hiding ((.:?)) 19 | import System.FilePath 20 | ------------------------------------------------------------------------------- 21 | 22 | 23 | -- Loading Test Cases 24 | loadTests :: FromJSON a => FilePath -> IO a 25 | loadTests fp = either (error . show) (either error id . parseEither p) `fmap` decodeFileEither fp' 26 | where 27 | fp' = "deps/uap-core" fp 28 | p = withObject "Value" $ \x -> x .: "test_cases" 29 | 30 | 31 | ------------------------------------------------------------------------------- 32 | data UserAgentTestCase = UATC { 33 | uatcString :: ByteString 34 | , uatcFamily :: Text 35 | , uatcV1 :: Maybe Text 36 | , uatcV2 :: Maybe Text 37 | , uatcV3 :: Maybe Text 38 | } deriving (Show) 39 | 40 | 41 | instance FromJSON UserAgentTestCase where 42 | parseJSON = withObject "UserAgentTestCase" parse 43 | where parse v = UATC <$> T.encodeUtf8 <$> v .: "user_agent_string" 44 | <*> v .: "family" 45 | <*> v .:? "major" 46 | <*> v .:? "minor" 47 | <*> v .:? "patch" 48 | 49 | 50 | ------------------------------------------------------------------------------- 51 | data OSTestCase = OSTC { 52 | ostcString :: ByteString 53 | , ostcFamily :: Text 54 | , ostcV1 :: Maybe Text 55 | , ostcV2 :: Maybe Text 56 | , ostcV3 :: Maybe Text 57 | , ostcV4 :: Maybe Text 58 | } deriving (Show) 59 | 60 | 61 | instance FromJSON OSTestCase where 62 | parseJSON = withObject "OSTestCase" parse 63 | where parse v = OSTC <$> (T.encodeUtf8 <$> v .: "user_agent_string" <|> return "") 64 | <*> v .: "family" 65 | <*> nonBlank (v .:? "major") 66 | <*> nonBlank (v .:? "minor") 67 | <*> nonBlank (v .:? "patch") 68 | <*> nonBlank (v .:? "patch_minor") 69 | 70 | nonBlank :: (Monad m) => 71 | m (Maybe Text) -> m (Maybe Text) 72 | nonBlank f = do 73 | res <- f 74 | return $ case res of 75 | Just "" -> Nothing 76 | Just x -> Just x 77 | Nothing -> Nothing 78 | 79 | 80 | ------------------------------------------------------------------------------- 81 | data DevTestCase = DTC { 82 | dtcString :: ByteString 83 | , dtcFamily :: Text 84 | , dtcBrand :: Maybe Text 85 | , dtcModel :: Maybe Text 86 | } deriving (Show, Eq) 87 | 88 | 89 | instance FromJSON DevTestCase where 90 | parseJSON = withObject "DevTestCase" parse 91 | where parse o = DTC <$> (T.encodeUtf8 <$> o .: "user_agent_string") 92 | <*> o .: "family" 93 | <*> nonBlank (o .:? "brand") 94 | <*> nonBlank (o .:? "model") 95 | 96 | 97 | ------------------------------------------------------------------------------- 98 | -- | Backport a more lenient version of .:? from newer versions of 99 | -- aeson. It accepts an explicit null as well as an omitted field. 100 | (.:?) :: (FromJSON a) => Object -> Text -> Parser (Maybe a) 101 | o .:? k = join <$> (o A..:? k) 102 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-18.28 2 | packages: 3 | - "." 4 | extra-deps: [] 5 | flags: 6 | ua-parser: 7 | lib-Werror: true 8 | extra-package-dbs: [] 9 | nix: 10 | enable: false 11 | packages: 12 | - pcre 13 | -------------------------------------------------------------------------------- /stack.yaml.lock: -------------------------------------------------------------------------------- 1 | # This file was autogenerated by Stack. 2 | # You should not edit this file by hand. 3 | # For more information, please see the documentation at: 4 | # https://docs.haskellstack.org/en/stable/lock_files 5 | 6 | packages: [] 7 | snapshots: 8 | - completed: 9 | size: 590100 10 | url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/18/28.yaml 11 | sha256: 428ec8d5ce932190d3cbe266b9eb3c175cd81e984babf876b64019e2cbe4ea68 12 | original: lts-18.28 13 | -------------------------------------------------------------------------------- /test/.ghci: -------------------------------------------------------------------------------- 1 | :set -isrc 2 | :set -i../src 3 | -------------------------------------------------------------------------------- /test/Main.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE RecordWildCards #-} 3 | module Main where 4 | 5 | 6 | ------------------------------------------------------------------------------- 7 | import Control.Applicative as A 8 | import qualified Data.ByteString.Char8 as B 9 | import Data.Monoid as M 10 | import qualified Data.Text as T 11 | import Test.Tasty 12 | import Test.Tasty.HUnit 13 | ------------------------------------------------------------------------------- 14 | import Web.UAParser 15 | import Web.UAParser.SuiteUtils 16 | ------------------------------------------------------------------------------- 17 | 18 | 19 | main :: IO () 20 | main = do 21 | uaCases <- M.mconcat A.<$> mapM loadTests ["test_resources/firefox_user_agent_strings.yaml" 22 | ,"test_resources/pgts_browser_list.yaml" 23 | ,"tests/test_ua.yaml"] 24 | osCases <- mconcat <$> mapM loadTests [ "test_resources/additional_os_tests.yaml" 25 | , "tests/test_os.yaml" ] 26 | devCases <- loadTests "tests/test_device.yaml" 27 | defaultMain $ testGroup "ua-parser" [ uaTests uaCases 28 | , osTests osCases 29 | , devTests devCases 30 | ] 31 | 32 | 33 | ------------------------------------------------------------------------------- 34 | uaTests :: [UserAgentTestCase] -> TestTree 35 | uaTests = testGroup "UA Parsing Tests" . map testUAParser 36 | 37 | 38 | ------------------------------------------------------------------------------- 39 | testUAParser :: UserAgentTestCase -> TestTree 40 | testUAParser UATC{..} = testCase tn $ do 41 | assertEqual "family is same" uatcFamily uarFamily 42 | assertEqual "v1 is the same" uatcV1 uarV1 43 | assertEqual "v2 is the same" uatcV2 uarV2 44 | assertEqual "v3 is the same" uatcV3 uarV3 45 | where 46 | UAResult {..} = parseUALenient uatcString 47 | tn = T.unpack $ T.intercalate "/" ["UA Test: ", uatcFamily, m uatcV1, m uatcV2, m uatcV3] 48 | m x = maybe "-" id x 49 | 50 | 51 | ------------------------------------------------------------------------------- 52 | -- OS Testing 53 | osTests :: [OSTestCase] -> TestTree 54 | osTests = testGroup "OS Parsing Tests" . map testOSParser 55 | 56 | 57 | ------------------------------------------------------------------------------- 58 | testOSParser :: OSTestCase -> TestTree 59 | testOSParser OSTC{..} = testCase tn $ do 60 | assertEqual "family is same" ostcFamily osrFamily 61 | assertEqual "major is the same" ostcV1 osrV1 62 | assertEqual "minor is the same" ostcV2 osrV2 63 | assertEqual "patch is the same" ostcV3 osrV3 64 | assertEqual "patch_minor is the same" ostcV4 osrV4 65 | where 66 | OSResult {..} = parseOSLenient ostcString 67 | tn = B.unpack ostcString <> " - " <> T.unpack summary 68 | summary = T.intercalate "/" [ "OS Test: " 69 | , ostcFamily 70 | , m ostcV1 71 | , m ostcV2 72 | , m ostcV3 73 | , m ostcV4 74 | ] 75 | m x = maybe "-" id x 76 | 77 | 78 | ------------------------------------------------------------------------------- 79 | -- Dev Testing 80 | devTests :: [DevTestCase] -> TestTree 81 | devTests = testGroup "Dev Parsing Tests" . map testDevParser 82 | 83 | 84 | ------------------------------------------------------------------------------- 85 | testDevParser :: DevTestCase -> TestTree 86 | testDevParser DTC{..} = testCase tn $ do 87 | assertEqual "family is same" dtcFamily drFamily 88 | assertEqual "brand is the same" dtcBrand drBrand 89 | assertEqual "model is the same" dtcModel drModel 90 | where 91 | DevResult {..} = parseDevLenient dtcString 92 | tn = B.unpack dtcString <> " - " <> T.unpack summary 93 | summary = T.intercalate "/" [ "Dev Test: " 94 | , dtcFamily 95 | , m dtcBrand 96 | , m dtcModel 97 | ] 98 | m x = maybe "-" id x 99 | -------------------------------------------------------------------------------- /ua-parser.cabal: -------------------------------------------------------------------------------- 1 | name: ua-parser 2 | description: Please refer to the git/github README on the project for example usage. 3 | version: 0.7.7.0 4 | synopsis: A library for parsing User-Agent strings, official Haskell port of ua-parser 5 | license: BSD3 6 | license-file: LICENSE 7 | author: Ozgun Ataman 8 | maintainer: ozgun.ataman@soostone.com 9 | category: Web 10 | build-type: Simple 11 | cabal-version: >=1.10 12 | tested-with: GHC == 8.6.5 13 | , GHC == 8.8.4 14 | 15 | extra-source-files: src/Web/UAParser/SuiteUtils.hs 16 | README.md 17 | changelog.md 18 | 19 | data-files: ./deps/uap-core/*.yaml 20 | ./deps/uap-core/test_resources/*.yaml 21 | ./deps/uap-core/tests/*.yaml 22 | 23 | source-repository head 24 | type: git 25 | location: https://github.com/ua-parser/uap-haskell 26 | subdir: haskell 27 | 28 | flag lib-Werror 29 | default: False 30 | manual: True 31 | 32 | library 33 | hs-source-dirs: src 34 | default-language: Haskell2010 35 | exposed-modules: 36 | Web.UAParser 37 | 38 | build-depends: 39 | base < 5 40 | , bytestring 41 | , text 42 | , pcre-light 43 | , yaml >= 0.8.3 44 | , aeson >= 0.7 45 | , data-default 46 | , file-embed < 0.1 47 | , deepseq 48 | , cereal 49 | , cereal-text 50 | 51 | if flag(lib-Werror) 52 | ghc-options: -Werror 53 | 54 | ghc-options: -Wall 55 | 56 | test-suite test 57 | type: exitcode-stdio-1.0 58 | main-is: Main.hs 59 | hs-source-dirs: src test 60 | ghc-options: -O2 -Wall -fwarn-tabs 61 | default-language: Haskell2010 62 | other-modules: 63 | Web.UAParser 64 | Web.UAParser.SuiteUtils 65 | 66 | if flag(lib-Werror) 67 | ghc-options: -Werror 68 | 69 | build-depends: 70 | base 71 | , bytestring 72 | , text 73 | , HUnit 74 | , pcre-light 75 | , yaml >= 0.7 76 | , aeson 77 | , tasty 78 | , tasty-hunit 79 | , tasty-quickcheck 80 | , data-default 81 | , filepath 82 | , file-embed 83 | , deepseq 84 | , cereal 85 | , cereal-text 86 | 87 | benchmark bench 88 | type: exitcode-stdio-1.0 89 | main-is: Main.hs 90 | hs-source-dirs: bench, src 91 | default-language: Haskell2010 92 | other-modules: 93 | Web.UAParser 94 | Web.UAParser.SuiteUtils 95 | build-depends: 96 | base 97 | , ua-parser 98 | , criterion 99 | , deepseq 100 | , bytestring 101 | , text 102 | , yaml 103 | , filepath 104 | , aeson 105 | , pcre-light 106 | , file-embed 107 | , data-default 108 | , cereal 109 | , cereal-text 110 | 111 | if flag(lib-Werror) 112 | ghc-options: -Werror 113 | 114 | ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N 115 | --------------------------------------------------------------------------------