Permalink
Browse files

Initial checkin.

  • Loading branch information...
0 parents commit 4b3aa415f30eda73480a2d32cc8fc389f122504b @davean committed Jun 10, 2012
32 LICENSE
@@ -0,0 +1,32 @@
+Images are under the http://creativecommons.org/licenses/by-nc-sa/3.0/us/
+Code:
+Copyright (c)2012, xkcd inc
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+ * Redistributions of source code must retain the above copyright
+ notice, this list of conditions and the following disclaimer.
+
+ * Redistributions in binary form must reproduce the above
+ copyright notice, this list of conditions and the following
+ disclaimer in the documentation and/or other materials provided
+ with the distribution.
+
+ * Neither the name of davean nor the names of other
+ contributors may be used to endorse or promote products derived
+ from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
@@ -0,0 +1,339 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Waldo.BrowserCap (
+ BrowserCap
+ , BrowserEntry(..)
+ , loadBrowserCap
+ , lookupBrowser
+ ) where
+
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import qualified Data.Text.Encoding as T
+import qualified Data.HashSet as Set
+import qualified Data.HashMap.Lazy as MapL
+import qualified Data.Attoparsec.Text as AP
+import qualified Data.Cache.LRU.IO as LRU
+import Data.Maybe
+import Data.Cache.LRU.IO (AtomicLRU)
+import Data.List
+import Control.Monad
+import Control.DeepSeq
+import System.Timeout
+--import Debug.Trace
+
+data BrowserCap = BrowserCap {
+ bcEntries :: ![BrowserEntry]
+ , bcCache :: AtomicLRU BS8.ByteString BrowserEntry
+ }
+
+instance NFData BrowserCap where
+
+data MatchPart =
+ TPart !T.Text
+ | One
+ | Many
+ deriving (Eq, Ord, Show)
+
+data BrowserEntry = BrowserEntry {
+ beParent :: !T.Text
+ , beUserAgent :: !T.Text
+ , beUserAgentMatcher :: ![MatchPart]
+ , beBrowser :: !T.Text
+ , beVersion :: !T.Text
+ , beMajorVersion :: !T.Text
+ , beMinorVersion :: !T.Text
+ , bePlatform :: !T.Text
+ , beWin16 :: !Bool
+ , beWin32 :: !Bool
+ , beWin64 :: !Bool
+ , beFrames :: !Bool
+ , beIFrames :: !Bool
+ , beTables :: !Bool
+ , beCookies :: !Bool
+ , beBackgroundSounds :: !Bool
+ , beJavaScript :: !Bool
+ , beVBScript :: !Bool
+ , beJavaApplets :: !Bool
+ , beActiveXControls :: !Bool
+ , beBanned :: !Bool
+ , beMobileDevice :: !Bool
+ , beSyndicationReader :: !Bool
+ , beCrawler :: !Bool
+ , beCSSVersion :: !T.Text
+ , beAolVersion :: !T.Text
+ , beMasterParent :: !Bool
+ , beSortOrder :: !T.Text
+ , beInternalID :: !T.Text
+ } deriving (Eq, Ord, Show)
+
+instance NFData BrowserEntry where
+
+data BrowserEntryShim = BrowserEntryShim {
+ besParent :: T.Text
+ , besUserAgent :: T.Text
+ , besUserAgentMatcher :: [MatchPart]
+ , besBrowser :: T.Text
+ , besVersion :: T.Text
+ , besMajorVersion :: T.Text
+ , besMinorVersion :: T.Text
+ , besPlatform :: T.Text
+ , besAlpha :: T.Text
+ , besBeta :: T.Text
+ , besWin16 :: T.Text
+ , besWin32 :: T.Text
+ , besWin64 :: T.Text
+ , besFrames :: T.Text
+ , besIFrames :: T.Text
+ , besTables :: T.Text
+ , besCookies :: T.Text
+ , besBackgroundSounds :: T.Text
+ , besJavaScript :: T.Text
+ , besVBScript :: T.Text
+ , besJavaApplets :: T.Text
+ , besActiveXControls :: T.Text
+ , besBanned :: T.Text
+ , besMobileDevice :: T.Text
+ , besSyndicationReader :: T.Text
+ , besCrawler :: T.Text
+ , besCSSVersion :: T.Text
+ , besAolVersion :: T.Text
+ , besMasterParent :: T.Text
+ , besSortOrder :: T.Text
+ , besInternalID :: T.Text
+ } deriving (Eq, Ord, Show)
+
+-- This would be faster if it returned a list of offsets
+-- and took the origional string and dropped the already-matched length.
+-- That is because it would improve match simplification.
+nextOptions :: [MatchPart] -> T.Text -> [T.Text]
+nextOptions ((TPart t0):_) rest = maybeToList $ T.stripPrefix t0 rest
+nextOptions (Many:(TPart t0):_) rest = map snd $ T.breakOnAll t0 rest
+nextOptions (One:_) rest = maybeToList $ fmap snd $ T.uncons rest
+nextOptions [Many] _ = [""]
+nextOptions [] rest = if T.null rest then [""] else []
+nextOptions mp _ = error $ "Failed match: " ++ show mp
+
+isMatch :: T.Text -> [MatchPart] -> Bool
+isMatch t mparts =
+ let finalEnds = foldl (\ends mp -> concatMap (Set.toList . Set.fromList . nextOptions mp) ends) [t] $ tails mparts
+ in "" `elem` finalEnds
+
+toMatcher :: T.Text -> [MatchPart]
+toMatcher t =
+ optimize $ map toMatchPart $ T.unpack t
+ where
+ toMatchPart '?' = One
+ toMatchPart '*' = Many
+ toMatchPart c = TPart (T.pack [c])
+ optimize ((TPart t0):(TPart t1):r) = optimize ((TPart (t0 `T.append` t1)):r)
+ optimize (Many:Many:r) = optimize (Many : r)
+ optimize (One:Many:r) = optimize (Many : r)
+ optimize (Many:One:r) = optimize (Many : r)
+ optimize (x:xs) = x : optimize xs
+ optimize [] = []
+
+lookupBrowser :: BrowserCap -> BS8.ByteString -> IO (Maybe BrowserEntry)
+lookupBrowser BrowserCap {bcEntries=entries, bcCache=cacheRef} ua = do
+ r <- timeout (10^(6::Int)) $ do
+ cache <- LRU.lookup ua cacheRef
+ case cache of
+ Just be -> return $ Just be
+ Nothing -> do
+ case bestMatching of
+ Nothing -> return Nothing
+ Just be -> do
+ LRU.insert ua be cacheRef
+ return $ Just be
+ return $ join r
+ where
+ bestMatching = listToMaybe $ map snd $ sortBy cmpByFst $ map (\be -> (T.length $ beUserAgent be, be)) allMatching
+ allMatching = mapMaybe match entries
+ cmpByFst a b = compare (fst b) (fst a)
+ match :: BrowserEntry -> Maybe BrowserEntry
+ match be =
+ if isMatch (T.concat ["[", T.decodeUtf8 ua, "]"]) $ beUserAgentMatcher be
+ then Just be
+ else Nothing
+
+loadBrowserCap :: FilePath -> IO BrowserCap
+loadBrowserCap fn = do
+ bcf <- T.readFile fn
+ let bcl = drop 3 $ T.lines bcf
+ let bce = catMaybes $ map (AP.maybeResult . AP.parse parseBCLine) bcl
+ bccR <- LRU.newAtomicLRU (Just 16)
+ let bces = force $ convertShims bce
+ (force bces) `seq` return $
+ BrowserCap { bcEntries = bces
+ , bcCache = bccR
+ }
+
+parseBCLine :: AP.Parser BrowserEntryShim
+parseBCLine = do
+ parent <- parseQuoted
+ _ <- AP.string ","
+ userAgent <- parseQuoted
+ _ <- AP.string ","
+ browser <- parseQuoted
+ _ <- AP.string ","
+ version <- parseQuoted
+ _ <- AP.string ","
+ majorVersion <- parseQuoted
+ _ <- AP.string ","
+ minorVersion <- parseQuoted
+ _ <- AP.string ","
+ platform <- parseQuoted
+ _ <- AP.string ","
+ alpha <- parseQuoted
+ _ <- AP.string ","
+ beta <- parseQuoted
+ _ <- AP.string ","
+ win16 <- parseQuoted
+ _ <- AP.string ","
+ win32 <- parseQuoted
+ _ <- AP.string ","
+ win64 <- parseQuoted
+ _ <- AP.string ","
+ frames <- parseQuoted
+ _ <- AP.string ","
+ iFrames <- parseQuoted
+ _ <- AP.string ","
+ tables <- parseQuoted
+ _ <- AP.string ","
+ cookies <- parseQuoted
+ _ <- AP.string ","
+ backgroundSounds <- parseQuoted
+ _ <- AP.string ","
+ javaScript <- parseQuoted
+ _ <- AP.string ","
+ vBScript <- parseQuoted
+ _ <- AP.string ","
+ javaApplets <- parseQuoted
+ _ <- AP.string ","
+ activeXControls <- parseQuoted
+ _ <- AP.string ","
+ banned <- parseQuoted
+ _ <- AP.string ","
+ mobileDevice <- parseQuoted
+ _ <- AP.string ","
+ syndicationReader <- parseQuoted
+ _ <- AP.string ","
+ crawler <- parseQuoted
+ _ <- AP.string ","
+ cSSVersion <- parseQuoted
+ _ <- AP.string ","
+ aolVersion <- parseQuoted
+ _ <- AP.string ","
+ masterParent <- parseQuoted
+ _ <- AP.string ","
+ sortOrder <- parseQuoted
+ _ <- AP.string ","
+ internalID <- parseQuoted
+ return $ BrowserEntryShim {
+ besParent = parent
+ , besUserAgent = userAgent
+ , besUserAgentMatcher = toMatcher userAgent
+ , besBrowser = browser
+ , besVersion = version
+ , besMajorVersion = majorVersion
+ , besMinorVersion = minorVersion
+ , besPlatform = platform
+ , besAlpha = alpha
+ , besBeta = beta
+ , besWin16 = win16
+ , besWin32 = win32
+ , besWin64 = win64
+ , besFrames = frames
+ , besIFrames = iFrames
+ , besTables = tables
+ , besCookies = cookies
+ , besBackgroundSounds = backgroundSounds
+ , besJavaScript = javaScript
+ , besVBScript = vBScript
+ , besJavaApplets = javaApplets
+ , besActiveXControls = activeXControls
+ , besBanned = banned
+ , besMobileDevice = mobileDevice
+ , besSyndicationReader = syndicationReader
+ , besCrawler = crawler
+ , besCSSVersion = cSSVersion
+ , besAolVersion = aolVersion
+ , besMasterParent = masterParent
+ , besSortOrder = sortOrder
+ , besInternalID = internalID
+ }
+ where
+ parseQuoted :: AP.Parser T.Text
+ parseQuoted = do
+ _ <- AP.string "\""
+ str <- AP.takeWhile (/='"')
+ _ <- AP.string "\""
+ return str
+
+convertShims :: [BrowserEntryShim] -> [BrowserEntry]
+convertShims shims =
+ let convMap = MapL.fromList $ map (\bes -> (besUserAgent bes, mergeBE bes convMap)) shims
+ in MapL.elems convMap
+
+mergeBE :: BrowserEntryShim -> MapL.HashMap T.Text BrowserEntry -> BrowserEntry
+mergeBE c converted =
+ let ourparent = -- trace ("=============\ngetting parent for: " ++ (T.unpack $ besUserAgent c)) $
+ if (besParent c) == "DefaultProperties"
+ then Nothing -- base case
+ else
+ if (besMasterParent c) == "true"
+ then MapL.lookup "[DefaultProperties]" converted
+ else MapL.lookup (T.concat ["[", besParent c, "]"]) converted
+ be = BrowserEntry {
+ beParent = besParent c
+ , beUserAgent = besUserAgent c
+ , beUserAgentMatcher = besUserAgentMatcher c
+ , beBrowser = mergeText (besBrowser c) (fmap beBrowser ourparent)
+ , beVersion = mergeText (besVersion c) (fmap beVersion ourparent)
+ , beMajorVersion = mergeText (besMajorVersion c) (fmap beMajorVersion ourparent)
+ , beMinorVersion = mergeText (besMinorVersion c) (fmap beMinorVersion ourparent)
+ , bePlatform = mergeText (besPlatform c) (fmap bePlatform ourparent)
+ , beWin16 = mergeBool (besWin16 c) (fmap beWin16 ourparent)
+ , beWin32 = mergeBool (besWin32 c) (fmap beWin32 ourparent)
+ , beWin64 = mergeBool (besWin32 c) (fmap beWin64 ourparent)
+ , beFrames = mergeBool (besFrames c) (fmap beFrames ourparent)
+ , beIFrames = mergeBool (besIFrames c) (fmap beIFrames ourparent)
+ , beTables = mergeBool (besTables c) (fmap beTables ourparent)
+ , beCookies = mergeBool (besCookies c) (fmap beCookies ourparent)
+ , beBackgroundSounds = mergeBool (besBackgroundSounds c) (fmap beBackgroundSounds ourparent)
+ , beJavaScript = mergeBool (besJavaScript c) (fmap beJavaScript ourparent)
+ , beVBScript = mergeBool (besVBScript c) (fmap beVBScript ourparent)
+ , beJavaApplets = mergeBool (besJavaApplets c) (fmap beJavaApplets ourparent)
+ , beActiveXControls = mergeBool (besActiveXControls c) (fmap beActiveXControls ourparent)
+ , beBanned = mergeBool (besBanned c) (fmap beBanned ourparent)
+ , beMobileDevice = mergeBool (besBanned c) (fmap beMobileDevice ourparent)
+ , beSyndicationReader = mergeBool (besSyndicationReader c) (fmap beSyndicationReader ourparent)
+ , beCrawler = mergeBool (besCrawler c) (fmap beCrawler ourparent)
+ , beCSSVersion = mergeText (besCSSVersion c) (fmap beCSSVersion ourparent)
+ , beAolVersion = mergeText (besAolVersion c) (fmap beAolVersion ourparent)
+ , beMasterParent = mergeBool (besMasterParent c) (Just $ error "WTF?")
+ , beSortOrder = besSortOrder c
+ , beInternalID = besInternalID c
+ }
+ in -- trace ("\n\n" ++ show ourparent ++ "\n" ++ show be ++ "\n\n") $
+ be
+ where
+ mergeText :: T.Text -> Maybe T.Text -> T.Text
+ mergeText ours mparents =
+ if not $ ours `elem` ["default", ""]
+ then ours
+ else case mparents of
+ Nothing -> ""
+ Just parents -> parents
+ mergeBool :: T.Text -> Maybe Bool -> Bool
+ mergeBool ours mparents =
+ case ours of
+ "true" -> True
+ "false" -> False
+ "True" -> True
+ "False" -> False
+ "default" ->
+ case mparents of
+ Nothing -> error $ "lacking bool parent"
+ Just parents -> parents
+ e -> error $ "unknown bool type: " ++ (T.unpack e)
Oops, something went wrong.

0 comments on commit 4b3aa41

Please sign in to comment.