')
14 | .addClass('panel')
15 | .css({
16 | left: panel.pos.x,
17 | top: panel.pos.y,
18 | width: panel.width,
19 | height: panel.height
20 | })
21 | .appendTo($comic)
22 | $.each(panel.images, function(idx, image) {
23 | var $img = $('![]()
')
24 | .css({
25 | left: image.pos.x,
26 | top: image.pos.y
27 | })
28 | .attr('src', PANELPATH + image.url)
29 | .appendTo($panel)
30 | })
31 | })
32 | var $cover = $('
')
33 | .addClass('cover')
34 | .css({
35 | left: 0,
36 | top: 0,
37 | width: $comic.width(),
38 | height: $comic.height()
39 | })
40 | .attr('title', comicScript.alttext)
41 | .appendTo($comic)
42 | return $comic
43 | }
44 |
45 | comicHandler = {
46 | lastComic: null,
47 | fetchComic: function() {
48 | var details = {
49 | w: $(window).width(),
50 | h: $(window).height(),
51 | r: document.referrer
52 | }
53 |
54 | var sidePadding = 10
55 | $.ajax(ENDPOINT, {
56 | data: details,
57 | dataType: 'jsonp',
58 | jsonpCallback: 'waldoCallback',
59 | success: $.proxy(function(comicScript) {
60 | if (comicScript.goto) {
61 | window.location = comicScript.goto
62 | }
63 |
64 | var comic = renderComic(comicScript),
65 | comicWidth = comic.outerWidth(true),
66 | comicHeight = comic.height()
67 |
68 | $('#container')
69 | .empty()
70 | .append(comic)
71 | .width(comicWidth)
72 | .height(comicHeight)
73 |
74 | this.lastComic = comicScript
75 | }, this)
76 | })
77 | }
78 | }
79 |
80 | resizeHandler = {
81 | delay: 250,
82 | timeout: null,
83 | onResize: function() {
84 | if (!this.timeout) {
85 | this.timeout = setTimeout($.proxy(function() {
86 | this.timeout = null
87 | comicHandler.fetchComic()
88 | }, this), this.delay)
89 | }
90 | }
91 | }
92 |
93 | $(document).ready($.proxy(comicHandler, 'fetchComic'))
94 | $(window).resize(function() {
95 | resizeHandler.onResize()
96 | })
97 |
--------------------------------------------------------------------------------
/waldo.cabal:
--------------------------------------------------------------------------------
1 | -- waldo.cabal auto-generated by cabal init. For additional options,
2 | -- see
3 | -- http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.
4 | -- The name of the package.
5 | Name: waldo
6 |
7 | -- The package version. See the Haskell package versioning policy
8 | -- (http://www.haskell.org/haskellwiki/Package_versioning_policy) for
9 | -- standards guiding when and how versions should be incremented.
10 | Version: 0.1
11 |
12 | -- A short (one-line) description of the package.
13 | Synopsis: A small Haskell server for generating visual stories based on some ascertainable data about the requester.
14 |
15 | -- A longer description of the package.
16 | Description: This package was writen to power xkcd.com's 2012 April Fools comic "Umwelt" (http://xkcd.com/1037). It uses several datasets and a script to generate a customized story specific to the user viewing it.
17 |
18 | -- The license under which the package is released.
19 | License: BSD3
20 |
21 | -- The file containing the license text.
22 | License-file: LICENSE
23 |
24 | -- The package author(s).
25 | Author: davean
26 |
27 | -- An email address to which users can send suggestions, bug reports,
28 | -- and patches.
29 | Maintainer: davean@xkcd.com
30 |
31 | -- A copyright notice.
32 | -- Copyright:
33 |
34 | Category: Web
35 |
36 | Build-type: Simple
37 |
38 | -- Extra files to be distributed with the package, such as examples or
39 | -- a README.
40 | -- Extra-source-files:
41 |
42 | -- Constraint on the version of Cabal needed to build this package.
43 | Cabal-version: >=1.2
44 |
45 | Executable waldo
46 | -- .hs or .lhs file containing the Main module.
47 | Main-is: Waldo/Server.hs
48 |
49 | -- Packages needed in order to build this package.
50 | Build-depends:
51 | base
52 | , deepseq == 1.3.*
53 | , bytestring == 0.9.*
54 | , text == 0.11.*
55 | , aeson == 0.6.*
56 | , aeson-pretty == 0.6.*
57 | , mtl == 2.*
58 | , network == 2.3.*
59 | , unordered-containers == 0.2.*
60 | , lrucache == 1.*
61 | , attoparsec == 0.10.*
62 | , hs-GeoIP == 0.2.*
63 | , filepath == 1.3.*
64 | , conduit == 0.2.*
65 | , imagesize-conduit == 0.2.*
66 | , zlib-conduit == 0.2.*
67 | , wai == 1.1.*
68 | , http-types == 0.6.*
69 | , case-insensitive == 0.4.*
70 | , warp == 1.1.*
71 | , blaze-builder == 0.3.*
72 | , safe == 0.3.*
73 | , regex-tdfa == 1.*
74 | , Geodetic == 0.4
75 | , SHA == 1.5.*
76 |
77 | Ghc-Options: -Wall -O2 -rtsopts
78 | Ghc-Prof-Options: -prof -auto-all
79 |
80 | Executable bench
81 | -- .hs or .lhs file containing the Main module.
82 | Main-is: Waldo/LoadTest.hs
83 |
84 | -- Packages needed in order to build this package.
85 | Build-depends:
86 | base
87 | , deepseq == 1.3.*
88 | , bytestring == 0.9.*
89 | , text == 0.11.*
90 | , aeson == 0.6.*
91 | , aeson-pretty == 0.6.*
92 | , mtl == 2.*
93 | , network == 2.3.*
94 | , unordered-containers == 0.2.*
95 | , lrucache == 1.*
96 | , attoparsec == 0.10.*
97 | , hs-GeoIP == 0.2.*
98 | , filepath == 1.3.*
99 | , conduit == 0.2.*
100 | , imagesize-conduit == 0.2.*
101 | , wai == 1.1.*
102 | , http-types == 0.6.*
103 | , case-insensitive == 0.4.*
104 | , blaze-builder == 0.3.*
105 | , safe == 0.3.*
106 | , regex-tdfa == 1.*
107 | , MissingH == 1.*
108 | , Geodetic == 0.4
109 | , SHA == 1.5.*
110 |
111 | Ghc-Options: -Wall -O2 -rtsopts
112 | Ghc-Prof-Options: -prof -auto-all
113 |
--------------------------------------------------------------------------------
/Waldo/CityLoc.hs:
--------------------------------------------------------------------------------
1 | module Waldo.CityLoc where
2 |
3 | import Control.Monad.Reader
4 | import Data.Geo.Coord
5 | import Data.Geo.Sphere
6 | import Data.Geo.Haversine
7 |
8 | import Waldo.Stalk
9 | import Waldo.Story
10 |
11 | data CityData = CityData {
12 | cityLoc :: Coord
13 | , cityInfluenceKm :: Double
14 | }
15 |
16 | mkCity :: Coord -> Double -> CityData
17 | mkCity l i = CityData l i
18 |
19 | closeTo :: CityData -> StoryGuard
20 | closeTo c =
21 | asks pdLatLon >>= guard . (maybe False (\latlon ->
22 | let kmDist = (haversine earthMean (cityLoc c) latlon)/1000
23 | in kmDist < (cityInfluenceKm c)))
24 |
25 | atlanta, belfast, boston, brisbane, cambridge, chicago, christchurch, cnu, dallas, detroit, downtownNYC, greenBay, halifax, houston, jerusalem, lakeChamplain, lakeErie, lakeMead, lakeMichigan, lasVegas, london, losAngeles, melbourne, miami, montreal, nyc, ottawa, paris, philadelphia, richmond, rioDeJaneiro, riverside, sacramento, sanAntonio, sanDiego, sanFran, scotland, seattle, sendai, sydney, tampa, telAviv, tokyo, toronto, vaBeach :: CityData
26 |
27 | atlanta = mkCity (( 33.755000) !.! (- 84.390000)) 20
28 | belfast = mkCity (( 54.600000) !.! (- 5.916700)) 6
29 | boston = mkCity (( 42.357778) !.! (- 71.061667)) 4
30 | brisbane = mkCity ((-27.466700) !.! ( 153.033300)) 180
31 | cambridge = mkCity (( 42.373611) !.! (- 71.110556)) 40
32 | chicago = mkCity (( 41.881944) !.! (- 87.627778)) 40
33 | christchurch = mkCity ((-43.500000) !.! ( 172.600000)) 13
34 | cnu = mkCity (( 37.063800) !.! (- 76.494200)) 10
35 | dallas = mkCity (( 32.782778) !.! (- 96.803889)) 73
36 | detroit = mkCity (( 42.331389) !.! (- 83.045833)) 50
37 | greenBay = mkCity (( 44.513333) !.! (- 88.015833)) 180
38 | halifax = mkCity (( 44.654444) !.! (- 63.599167)) 17
39 | houston = mkCity (( 29.762778) !.! (- 95.383056)) 20
40 | jerusalem = mkCity (( 31.783300) !.! ( 35.216700)) 4
41 | lakeChamplain= mkCity (( 44.533333) !.! (- 73.333333)) 58
42 | lakeErie = mkCity (( 42.200000) !.! (- 81.200000)) 140
43 | lakeMead = mkCity (( 36.250000) !.! (-114.390000)) 50
44 | lakeMichigan = mkCity (( 44.000000) !.! (- 87.000000)) 130
45 | lasVegas = mkCity (( 36.175000) !.! (-115.136389)) 20
46 | london = mkCity (( 51.517100) !.! ( 0.106200)) 30
47 | losAngeles = mkCity (( 34.050000) !.! (-118.250000)) 65
48 | melbourne = mkCity ((-37.783300) !.! ( 144.966700)) 40
49 | miami = mkCity (( 25.787778) !.! (- 80.224167)) 30
50 | montreal = mkCity (( 45.500000) !.! (- 73.666667)) 45
51 | downtownNYC = mkCity (( 40.664167) !.! (- 73.938611)) 20
52 | nyc = mkCity (( 40.664167) !.! (- 73.938611)) 20
53 | ottawa = mkCity (( 45.420833) !.! (- 75.690000)) 50
54 | paris = mkCity (( 48.874200) !.! ( 2.347000)) 25
55 | philadelphia = mkCity (( 39.953333) !.! (- 75.170000)) 20
56 | richmond = mkCity (( 37.540972) !.! (- 77.432889)) 40
57 | rioDeJaneiro = mkCity ((-22.908300) !.! (- 43.243600)) 70
58 | riverside = mkCity (( 33.948056) !.! (-117.396111)) 15
59 | sacramento = mkCity (( 38.555556) !.! (-121.468889)) 45
60 | sanAntonio = mkCity (( 29.416667) !.! (- 98.500000)) 23
61 | sanDiego = mkCity (( 32.715000) !.! (-117.162500)) 60
62 | sanFran = mkCity (( 37.779300) !.! (-122.419200)) 10
63 | scotland = mkCity (( 57.100000) !.! (- 4.000000)) 250
64 | seattle = mkCity (( 47.609722) !.! (-122.333056)) 45
65 | sendai = mkCity (( 31.816700) !.! ( 130.300600)) 35
66 | sydney = mkCity ((-33.868300) !.! ( 151.208600)) 60
67 | tampa = mkCity (( 27.947222) !.! (- 82.458611)) 42
68 | telAviv = mkCity (( 32.083300) !.! ( 34.800000)) 10
69 | tokyo = mkCity (( 35.683300) !.! ( 139.766700)) 50
70 | toronto = mkCity (( 43.716589) !.! (- 79.340686)) 30
71 | vaBeach = mkCity (( 36.850600) !.! (- 75.977900)) 37
72 |
--------------------------------------------------------------------------------
/Waldo/Story.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module Waldo.Story (
3 | selectStory
4 | , knapsackSizer
5 | , Story(..)
6 | , StoryGuard, StoryOption
7 | , isIn, browserIs, osIs, netSpeedIs, orgIs, orgMatch, ispIs
8 | , refererDomainIs
9 | , pdTestJustIs
10 | , giveThem, allocate
11 | ) where
12 |
13 | import Data.Maybe
14 | import Data.List
15 | import Control.Monad.Reader
16 | import Data.ByteString.Char8 (ByteString)
17 | import qualified Data.Text as T
18 | import Network.URI
19 | import Text.Regex.TDFA ((=~))
20 |
21 | import Waldo.Stalk
22 | import Waldo.Script
23 |
24 | type StoryGuard = ReaderT PersonalData Maybe ()
25 | type StoryOption = ReaderT PersonalData Maybe Story
26 |
27 | data Story =
28 | StoryGoto {
29 | storyGoto :: T.Text
30 | }
31 | | Story {
32 | storyAltText :: T.Text
33 | , storyPanelSets :: [PanelSizes]
34 | , storyPadX :: Int
35 | , storyPadY :: Int
36 | , storyName :: T.Text
37 | }
38 | deriving (Show)
39 |
40 | selectStory :: ((Int, Int) -> Story -> Maybe Script) -> Script -> [StoryOption] -> PersonalData -> IO Script
41 | selectStory sizer d storyGens pd = do
42 | --print storyGens
43 | -- generate stories
44 | let stories = catMaybes $ map (flip runReaderT pd) storyGens
45 | --print stories
46 | -- size the selected scripts
47 | let scripts = mapMaybe doSize stories
48 | --print scripts
49 | -- Get our script, either the default or a selected one.
50 | return $ fromMaybe d $ listToMaybe scripts
51 | where
52 | doSize (s@Story {}) = sizer (pdScreen pd) s
53 | doSize (StoryGoto t) = Just (ScriptTo t)
54 |
55 | knapsackSizer :: Int -> (Int, Int) -> Story -> Maybe Script
56 | knapsackSizer sitePad (w, h) s =
57 | -- Get the first entry if there is one, the smallest if none of them fit.
58 | listToMaybe $ (sortCorrectDir sizeLimited) ++ (take 1 areaSortedSized)
59 | where
60 | -- selected sort dir by what we know about the screen
61 | sortCorrectDir =
62 | if (h > 0) && (w > 0)
63 | then reverse
64 | else id
65 | -- The fitting scripts
66 | sizeLimited = fitWidth $ fitHeight $ areaSortedSized
67 | -- sort by area
68 | areaSortedSized = areaSort allScripts
69 | -- Of all scripts
70 | allScripts = do
71 | combo <- mapM id $ storyPanelSets s
72 | return $ mkScript (storyName s) (storyAltText s) combo
73 | areaSort = sortBy (\a b -> compare (scriptArea a) (scriptArea b))
74 | scriptArea scr = (sHeight scr) * (sWidth scr)
75 | fitHeight scripts =
76 | if h > 0
77 | then filter (\scr -> h > (sHeight scr+storyPadY s+sitePad)) scripts
78 | else scripts
79 | fitWidth scripts =
80 | if w > 0
81 | then filter (\scr -> w > (sWidth scr+storyPadX s+sitePad)) scripts
82 | else scripts
83 |
84 | refererDomainIs :: String -> StoryGuard
85 | refererDomainIs d =
86 | asks pdRefURI >>= guard . fromMaybe False . fmap ((isSuffixOf d) . uriRegName) . join . fmap uriAuthority
87 |
88 | --refererMatches ::
89 |
90 | pdTestJustIs :: Eq a => (PersonalData -> Maybe a) -> a -> StoryGuard
91 | pdTestJustIs g v = asks g >>= guard . maybe False (v==)
92 |
93 | isIn :: ByteString -> StoryGuard
94 | isIn locName = asks pdLocal >>= guard . (not . null . (filter (locName==)))
95 |
96 | browserIs :: Browser -> StoryGuard
97 | browserIs b = asks pdBrowser >>= guard . (maybe False (b==))
98 |
99 | osIs :: OS -> StoryGuard
100 | osIs os = asks pdOS >>= guard . (maybe False (os==))
101 |
102 | netSpeedIs :: NetSpeed -> StoryGuard
103 | netSpeedIs ns = asks pdNetSpeed >>= guard . (maybe False (ns==))
104 |
105 | orgIs :: ByteString -> StoryGuard
106 | orgIs o = asks pdOrg >>= guard . (maybe False (o==))
107 |
108 | orgMatch :: ByteString -> StoryGuard
109 | orgMatch o = asks pdOrg >>= guard . (maybe False (flip (=~) o))
110 |
111 | ispIs :: ByteString -> StoryGuard
112 | ispIs i = asks pdISP >>= guard . (maybe False (i==))
113 |
114 | allocate :: MonadPlus m => m () -> a -> m a
115 | allocate cnd r = cnd >> return r
116 |
117 | giveThem :: MonadPlus m => m () -> m a -> m a
118 | giveThem = (>>)
119 |
--------------------------------------------------------------------------------
/Waldo/Script.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module Waldo.Script (
3 | Script(..)
4 | , PanelSizes, PanelData(..), Panel(..)
5 | , ImagePart(..)
6 | , TextPart(..)
7 | , Pos(..)
8 | , loadImagePanels, mkScript, scriptName
9 | ) where
10 |
11 | import Data.List
12 | import Control.Monad
13 | import qualified Data.Text as T
14 | import qualified Data.Aeson as JS
15 | import qualified Data.ByteString.Lazy.Char8 as BSL8
16 | import Control.Monad.Trans.Resource (runResourceT)
17 | import Data.Conduit (($$))
18 | import qualified Data.Conduit.Binary as CB
19 | import qualified Data.Conduit.ImageSize as CI
20 | import System.FilePath ((), takeFileName, splitExtension)
21 | import System.Path.Glob
22 | import Data.Digest.Pure.SHA
23 | import Control.DeepSeq
24 |
25 | import Data.Aeson ((.=))
26 |
27 | pad :: Int
28 | pad = 4
29 |
30 | panelRightEdge :: Panel -> Int
31 | panelRightEdge p = (pX $ pPos p) + (pWidth p)
32 |
33 | scriptName :: Script -> T.Text
34 | scriptName (s@Script {}) = T.concat $ [sName s, " : "] ++ (intersperse "+" $ map pName (sPanels s))
35 | scriptName (ScriptTo goto) = T.concat ["Goto : ", goto]
36 |
37 | mkScript :: T.Text -- name
38 | -> T.Text -- alt-text
39 | -> [PanelData] -- panels!
40 | -> Script
41 | mkScript nm alt pds =
42 | let ps = snd $ mapAccumL (\xstart p ->
43 | let newp = panelData2panel xstart p
44 | in (panelRightEdge newp, newp)) 0 pds
45 | in Script {
46 | sAltText = alt
47 | , sPanels = ps
48 | , sHeight = 2*pad + (maximum $ map pHeight ps)
49 | , sWidth = (1+length ps)*pad + (sum $ map pWidth ps)
50 | , sName = nm
51 | }
52 |
53 | hashImgNm :: FilePath -> FilePath
54 | hashImgNm fn =
55 | let (nm, typ) = splitExtension fn
56 | in (showDigest $ sha256 (BSL8.pack ("basfd" ++ nm)))++typ
57 |
58 | loadImagePanels :: Int -- Story
59 | -> Int -- Panel
60 | -> Int -- Choice
61 | -> IO PanelSizes
62 | loadImagePanels s p c = do
63 | fns <- glob ("panels"
64 | ("a1_"++show s++"p"++show p++"s*_"++show c++".*"))
65 | ps <- forM fns $ \fn -> do
66 | mImgInf <- runResourceT $ CB.sourceFile fn $$ CI.sinkImageSize
67 | case mImgInf of
68 | Nothing -> fail "Couldn't read image."
69 | Just sz -> do
70 | let pname = hashImgNm $ takeFileName fn
71 | d <- BSL8.readFile fn
72 | BSL8.writeFile ("loadedPanels" pname) d
73 | return $
74 | PanelData {
75 | pdWidth = CI.width sz
76 | , pdHeight = CI.height sz
77 | , pdImages = [ImagePart { ipPos = Pos 0 0, ipImageUrl = T.pack pname }]
78 | , pdText = []
79 | , pdName = T.pack ("p"++show p++"s"++show s++"_"++show c)
80 | }
81 | if null ps
82 | then fail ("No panels found for "++show (s, p, c))
83 | else return ps
84 |
85 | panelData2panel :: Int -> PanelData -> Panel
86 | panelData2panel xlast pd =
87 | Panel {
88 | pPos = Pos (xlast+pad) pad
89 | , pWidth = pdWidth pd
90 | , pHeight = pdHeight pd
91 | , pImages = pdImages pd
92 | , pText = pdText pd
93 | , pName = pdName pd
94 | }
95 |
96 | type PanelSizes = [PanelData]
97 |
98 | data Script =
99 | ScriptTo {
100 | sTarget :: !T.Text
101 | }
102 | | Script {
103 | sWidth :: !Int
104 | , sHeight :: !Int
105 | , sAltText :: !T.Text
106 | , sPanels :: [Panel]
107 | , sName :: !T.Text
108 | }
109 | deriving (Eq, Ord, Show)
110 |
111 | instance NFData Script where
112 | rnf (s@ScriptTo {sTarget=t}) = t `seq` s `seq` ()
113 | rnf (s@Script {sWidth=w, sHeight=h, sAltText=a, sPanels=p, sName=n}) =
114 | w `seq` h `seq` a `deepseq` p `deepseq` n `deepseq` s `seq` ()
115 |
116 | data Panel = Panel {
117 | pPos :: !Pos
118 | , pWidth :: !Int
119 | , pHeight :: !Int
120 | , pImages :: [ImagePart]
121 | , pText :: [TextPart]
122 | , pName :: !T.Text
123 | } deriving (Eq, Ord, Show)
124 |
125 | instance NFData Panel where
126 | rnf (pan@Panel {pPos=p, pWidth=w, pHeight=h, pImages=i, pText=t, pName=n}) =
127 | p `deepseq` w `seq` h `seq` i `deepseq` t `deepseq` n `deepseq` pan `seq` ()
128 |
129 | data PanelData = PanelData {
130 | pdWidth :: !Int
131 | , pdHeight :: !Int
132 | , pdImages :: [ImagePart]
133 | , pdText :: [TextPart]
134 | , pdName :: !T.Text
135 | } deriving (Eq, Ord, Show)
136 |
137 | data ImagePart = ImagePart {
138 | ipPos :: !Pos
139 | , ipImageUrl :: !T.Text
140 | } deriving (Eq, Ord, Show)
141 |
142 | instance NFData ImagePart where
143 | rnf (i@ImagePart {ipPos=p, ipImageUrl=u}) =
144 | p `deepseq` u `deepseq` i `seq` ()
145 |
146 | data TextPart = TextPart {
147 | tpPos :: !Pos
148 | , tpString :: !T.Text
149 | , tpSize :: !Float
150 | , tpFont :: !T.Text
151 | , tpAngle :: !Float
152 | } deriving (Eq, Ord, Show)
153 |
154 | instance NFData TextPart where
155 | rnf (tp@TextPart {tpPos=p, tpString=t, tpSize=s, tpFont=f, tpAngle=a}) =
156 | p `deepseq` t `deepseq` s `seq` f `deepseq` a `seq` tp `seq` ()
157 |
158 | data Pos = Pos { pX :: !Int, pY :: !Int } deriving (Eq, Ord, Show)
159 |
160 | instance NFData Pos where
161 | rnf (p@Pos {pX=x, pY=y}) = x `seq` y `seq` p `seq` ()
162 |
163 | instance JS.ToJSON Script where
164 | toJSON (ScriptTo t) = JS.object ["goto" .= t]
165 | toJSON (Script w h alt ps _) = JS.object [ "width" .= w
166 | , "height" .= h
167 | , "alttext" .= alt
168 | , "panels" .= ps
169 | ]
170 |
171 | instance JS.ToJSON Panel where
172 | toJSON (Panel p w h is ts _) = JS.object [ "pos" .= p
173 | , "width" .= w
174 | , "height" .= h
175 | , "images" .= is
176 | , "texts" .= ts
177 | ]
178 |
179 | instance JS.ToJSON ImagePart where
180 | toJSON (ImagePart p url) = JS.object [ "pos" .= p, "url" .= url ]
181 |
182 | instance JS.ToJSON TextPart where
183 | toJSON (TextPart p str sz f r) = JS.object [ "pos" .= p
184 | , "str" .= str
185 | , "size" .= sz
186 | , "font" .= f
187 | , "rad" .= r
188 | ]
189 |
190 | instance JS.ToJSON Pos where
191 | toJSON (Pos x y) = JS.object [ "x" .= x, "y" .= y ]
192 |
--------------------------------------------------------------------------------
/Waldo/Stalk.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings, TemplateHaskell #-}
2 | module Waldo.Stalk (
3 | OS(..), Browser(..), NetSpeed(..)
4 | , PersonalData(..)
5 | , StalkRequest, wai2stalk
6 | , StalkDB, loadStalkDB
7 | , stalk
8 | ) where
9 |
10 | import Data.Word
11 | import Data.Bits
12 | import Data.Maybe
13 | import Control.Monad
14 | import Data.List (intercalate)
15 | import Data.Geolocation.GeoIP
16 | import Data.ByteString.Char8 (ByteString)
17 | import Data.Aeson (ToJSON(toJSON), FromJSON(parseJSON), (.=), (.:), (.:?))
18 | import Network.Socket (SockAddr(SockAddrInet, SockAddrInet6))
19 | import Data.Either (rights)
20 | import qualified Text.Regex.TDFA as R
21 | import qualified Text.Regex.TDFA.ByteString as RB
22 | import qualified Data.Aeson as JS
23 | import qualified Data.ByteString as BS
24 | import qualified Data.ByteString.Char8 as BS8
25 | import qualified Network.Wai as WAI
26 | import qualified Network.HTTP.Types as HTTP
27 | import qualified Data.HashMap.Strict as Map
28 | import qualified Data.CaseInsensitive as CI
29 | import Network.URI
30 | import Data.Geo.Coord
31 | import Safe
32 |
33 | import Waldo.BrowserCap
34 |
35 | data Browser =
36 | Chrome
37 | | Safari
38 | | FireFox
39 | | InternetExplorer
40 | | Opera
41 | | Netscape
42 | deriving (Eq, Ord, Show)
43 |
44 | data OS =
45 | BSD
46 | | Linux
47 | | Windows
48 | | Mac
49 | deriving (Eq, Ord, Show)
50 |
51 | data NetSpeed =
52 | Dialup
53 | | Cellular
54 | | CableDSL
55 | | Corporate
56 | deriving (Eq, Ord, Show)
57 |
58 | data PersonalData =
59 | PersonalData {
60 | pdLocal :: [ByteString] -- Order of decreasing precision.
61 | , pdOrg :: Maybe ByteString -- Who owns the IP.
62 | , pdISP :: Maybe ByteString -- Who provides internet to the IP.
63 | , pdNetSpeed :: Maybe NetSpeed
64 | , pdReferer :: Maybe ByteString
65 | , pdRefURI :: Maybe URI
66 | , pdBrowser :: Maybe Browser
67 | , pdOS :: Maybe OS
68 | , pdLatLon :: Maybe Coord
69 | , pdScreen :: (Int, Int)
70 | , pdBrowserEntry :: Maybe BrowserEntry
71 | , pdStalk :: StalkRequest
72 | } deriving (Eq, Show)
73 |
74 | data StalkRequest =
75 | StalkRequest {
76 | srParams :: HTTP.Query
77 | , srHeaders :: HTTP.RequestHeaders
78 | , srFromIP :: Maybe ByteString
79 | , srTrustForward :: Bool
80 | }
81 | deriving (Eq, Ord, Show)
82 |
83 | instance ToJSON StalkRequest where
84 | toJSON (StalkRequest {srParams=p, srHeaders=h, srFromIP=ip, srTrustForward=t}) =
85 | JS.object [ "params" .= p
86 | , "headers" .= map (\(k, v) -> (CI.original k, v)) h
87 | , "ip" .= ip
88 | , "trust_forward" .= t
89 | ]
90 |
91 | instance FromJSON StalkRequest where
92 | parseJSON (JS.Object o) = do
93 | ip <- o .:? "ip"
94 | p <- o .: "params"
95 | t <- o .: "trust_forward"
96 | h <- o .: "headers"
97 | return $ StalkRequest {
98 | srParams=p
99 | , srHeaders= map (\(k, v) -> (CI.mk k ,v)) h
100 | , srFromIP=ip
101 | , srTrustForward=t
102 | }
103 | parseJSON _ = mzero
104 |
105 | data StalkDB =
106 | StalkDB {
107 | sdbBrowserCap :: BrowserCap
108 | , sdbMaxMindCity :: GeoDB
109 | , sdbMaxMindOrg :: GeoDB
110 | , sdbMaxMindISP :: GeoDB
111 | , sdbMaxMindNet :: GeoDB
112 | }
113 |
114 | loadStalkDB :: IO StalkDB
115 | loadStalkDB = do
116 | bc <- loadBrowserCap "datasets/browsercap.csv"
117 | cdb <- openGeoDB mmap_cache "datasets/GeoIPCity.dat"
118 | odb <- openGeoDB mmap_cache "datasets/GeoIPOrg.dat"
119 | idb <- openGeoDB mmap_cache "datasets/GeoIPISP.dat"
120 | ndb <- openGeoDB mmap_cache "datasets/GeoIPNet.dat"
121 | return $ StalkDB {
122 | sdbBrowserCap = bc
123 | , sdbMaxMindCity = cdb
124 | , sdbMaxMindOrg = odb
125 | , sdbMaxMindISP = idb
126 | , sdbMaxMindNet = ndb
127 | }
128 |
129 | wai2stalk :: WAI.Request -> StalkRequest
130 | wai2stalk req =
131 | StalkRequest {
132 | srParams = WAI.queryString req
133 | , srHeaders = WAI.requestHeaders req
134 | , srFromIP = ip
135 | , srTrustForward = True
136 | }
137 | where
138 | ip =
139 | case WAI.remoteHost req of
140 | SockAddrInet _ addr4 ->
141 | let (x0, x1, x2, x3) = w32to8 addr4
142 | in Just $ BS8.pack $ concat [show x3, ".", show x2, ".", show x1, ".", show x0]
143 | SockAddrInet6 _ _ _ _ -> Nothing
144 | _ -> Nothing
145 |
146 | stalk :: StalkDB -> StalkRequest -> IO PersonalData
147 | stalk sdb req = do
148 | bc <- lookupBrowser (sdbBrowserCap sdb) $ fromMaybe "" agnt
149 | let mips = if srTrustForward req
150 | -- This first one had a special key attached to avoid an issue
151 | -- with injection of false Forward-Fors.
152 | then (maybeToList $ lookup "X-Forwarded-For" (srHeaders req)) ++
153 | (map snd $ filter (\h -> (fst h) `elem` ["X-Forwarded-For", "X-Forward-For"]) (srHeaders req))
154 | else maybeToList $ srFromIP req
155 | let ips = mapMaybe validIP mips
156 | let browser = str2browser $ fromMaybe "" $ fmap beBrowser bc
157 | let os = str2os $ fromMaybe "" $ fmap bePlatform bc
158 | geos <- forM (ips) $ \ip -> do
159 | gipCityM <- geoLocateByIPAddress (sdbMaxMindCity sdb) ip
160 | gipOrgM <- geoStringByIPAddress (sdbMaxMindOrg sdb) ip
161 | gipISPM <- geoStringByIPAddress (sdbMaxMindISP sdb) ip
162 | gipNetM <- geoStringByIPAddress (sdbMaxMindNet sdb) ip
163 | return $
164 | if not $ or [isJust gipCityM, isJust gipOrgM, isJust gipISPM, isJust gipNetM]
165 | then Nothing
166 | else Just $ PersonalData {
167 | pdLocal = (fromMaybe [] $ fmap city2locals gipCityM) ++ ["Earth"]
168 | , pdOrg = fmap cleanOrg gipOrgM
169 | , pdISP = gipISPM
170 | , pdNetSpeed = join $ fmap str2speed gipNetM
171 | , pdReferer = referer
172 | , pdRefURI = refUri
173 | , pdBrowser = browser
174 | , pdOS = os
175 | , pdLatLon = parseLatLon gipCityM
176 | , pdScreen = scrn
177 | , pdBrowserEntry = bc
178 | , pdStalk = req
179 | }
180 | return $ fromMaybe (noGeoResult bc browser os) $ listToMaybe $ catMaybes geos
181 | where
182 | parseLatLon gipc = do
183 | c <- gipc
184 | return ((geoLatitude c) !.! (geoLongitude c))
185 | city2locals :: GeoIPRecord -> [ByteString]
186 | city2locals g = [geoCity g, geoRegion g, geoCountryCode3 g, geoCountryName g, geoContinentCode g]
187 | noGeoResult bc browser os =
188 | PersonalData {
189 | pdLocal = ["Earth"]
190 | , pdOrg = Nothing
191 | , pdISP = Nothing
192 | , pdNetSpeed = Nothing
193 | , pdReferer = referer
194 | , pdRefURI = refUri
195 | , pdBrowser = browser
196 | , pdOS = os
197 | , pdLatLon = Nothing
198 | , pdScreen = scrn
199 | , pdBrowserEntry = bc
200 | , pdStalk = req
201 | }
202 | parms = srParams req
203 | hdrs = srHeaders req
204 | scrn =
205 | let x = case BS8.readInt (fromMaybe "" $ join $ lookup "w" parms) of
206 | Nothing -> 0
207 | Just (xi, _) -> xi
208 | y = case BS8.readInt (fromMaybe "" $ join $ lookup "h" parms) of
209 | Nothing -> 0
210 | Just (yi, _) -> yi
211 | in (x, y)
212 | agnt = lookup "User-Agent" hdrs
213 | referer = join $ lookup "r" parms
214 | refUri = join $ fmap (parseURI . BS8.unpack) referer
215 | validIP :: ByteString -> Maybe ByteString
216 | validIP fips0 = do
217 | (x0, fips1) <- BS8.readInt fips0
218 | (x1, fips2) <- BS8.readInt $ BS.drop 1 fips1
219 | (x2, fips3) <- BS8.readInt $ BS.drop 1 fips2
220 | (x3, _) <- BS8.readInt $ BS.drop 1 fips3
221 | return $ BS8.pack $ intercalate "." [show x0, show x1, show x2, show x3]
222 | rComp =
223 | R.CompOption {R.multiline=False,R.rightAssoc=True
224 | ,R.caseSensitive=False,R.newSyntax=True,R.lastStarGreedy=False}
225 | rExec =
226 | R.ExecOption { R.captureGroups=False }
227 | rCompile (p, r) =
228 | case RB.compile rComp rExec p of
229 | Left e -> Left e
230 | Right c -> Right (c, r)
231 | clean :: [(ByteString, ByteString)] -> BS.ByteString -> BS.ByteString
232 | clean rules this = fromMaybe this $
233 | fmap snd $ headMay $
234 | filter (\(p, _) -> either (const False) isJust $ RB.regexec p this) $
235 | rights $ map rCompile rules
236 | cleanOrg :: BS.ByteString -> BS.ByteString
237 | cleanOrg = clean [
238 | ("\\^Google", "Google")
239 | ]
240 | str2speed =
241 | flip Map.lookup (Map.fromList [
242 | ("Dialup", Dialup)
243 | , ("Cellular", Cellular)
244 | , ("Cable/DSL", CableDSL)
245 | , ("Corporate", Corporate)
246 | ])
247 | str2browser =
248 | flip Map.lookup (Map.fromList [
249 | ("Chrome" , Chrome), ("Chromium", Chrome)
250 | , ("Safari", Safari)
251 | , ("Firefox", FireFox), ("Iceweasel", FireFox)
252 | , ("IE", InternetExplorer)
253 | , ("Opera", Opera), ("Opera Mini", Opera)
254 | , ("Netscape", Netscape)
255 | ])
256 | str2os =
257 | flip Map.lookup (Map.fromList [
258 | ("MacOSX", Mac)
259 | , ("Linux", Linux), ("Debian", Linux)
260 | , ("FreeBSD", BSD), ("NetBSD", BSD), ("OpenBSD", BSD)
261 | , ("IRIX", BSD), ("IRIX64", BSD)
262 | , ("HP-UX", BSD)
263 | , ("SunOS", BSD), ("Solaris", BSD)
264 | , ("WinCE", Windows)
265 | , ("Win16", Windows), ("Win32", Windows), ("Win64", Windows)
266 | , ("Win31", Windows)
267 | , ("Win95", Windows), ("Win98", Windows), ("WinME", Windows)
268 | , ("WinNT", Windows)
269 | , ("Win2000", Windows), ("Win2003", Windows)
270 | , ("WinXP", Windows), ("WinVista", Windows)
271 | , ("Win7", Windows), ("Win8", Windows)
272 | ])
273 |
274 | w32to8 :: Word32 -> (Word8, Word8, Word8, Word8)
275 | w32to8 w0 =
276 | let (w0_h, w0_l) = w32to16 w0
277 | ((x0, x1), (x2, x3)) = (w16to8 w0_h, w16to8 w0_l)
278 | in (x0, x1, x2, x3)
279 |
280 | w32to16 :: Word32 -> (Word16, Word16)
281 | w32to16 w0 =
282 | let w_h = fromIntegral $ w0 `shiftR` 16
283 | w_l = fromIntegral $ w0 .&. 0xFFFF
284 | in (w_h, w_l)
285 |
286 | w16to8 :: Word16 -> (Word8, Word8)
287 | w16to8 w0 =
288 | let w_h = fromIntegral $ w0 `shiftR` 8
289 | w_l = fromIntegral $ w0 .&. 0xFF
290 | in (w_h, w_l)
291 |
--------------------------------------------------------------------------------
/Waldo/BrowserCap.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 | module Waldo.BrowserCap (
3 | BrowserCap
4 | , BrowserEntry(..)
5 | , loadBrowserCap
6 | , lookupBrowser
7 | ) where
8 |
9 | import qualified Data.ByteString.Char8 as BS8
10 | import qualified Data.Text as T
11 | import qualified Data.Text.IO as T
12 | import qualified Data.Text.Encoding as T
13 | import qualified Data.HashSet as Set
14 | import qualified Data.HashMap.Lazy as MapL
15 | import qualified Data.Attoparsec.Text as AP
16 | import qualified Data.Cache.LRU.IO as LRU
17 | import Data.Maybe
18 | import Data.Cache.LRU.IO (AtomicLRU)
19 | import Data.List
20 | import Control.Monad
21 | import Control.DeepSeq
22 | import System.Timeout
23 | --import Debug.Trace
24 |
25 | data BrowserCap = BrowserCap {
26 | bcEntries :: ![BrowserEntry]
27 | , bcCache :: AtomicLRU BS8.ByteString BrowserEntry
28 | }
29 |
30 | instance NFData BrowserCap where
31 |
32 | data MatchPart =
33 | TPart !T.Text
34 | | One
35 | | Many
36 | deriving (Eq, Ord, Show)
37 |
38 | data BrowserEntry = BrowserEntry {
39 | beParent :: !T.Text
40 | , beUserAgent :: !T.Text
41 | , beUserAgentMatcher :: ![MatchPart]
42 | , beBrowser :: !T.Text
43 | , beVersion :: !T.Text
44 | , beMajorVersion :: !T.Text
45 | , beMinorVersion :: !T.Text
46 | , bePlatform :: !T.Text
47 | , beWin16 :: !Bool
48 | , beWin32 :: !Bool
49 | , beWin64 :: !Bool
50 | , beFrames :: !Bool
51 | , beIFrames :: !Bool
52 | , beTables :: !Bool
53 | , beCookies :: !Bool
54 | , beBackgroundSounds :: !Bool
55 | , beJavaScript :: !Bool
56 | , beVBScript :: !Bool
57 | , beJavaApplets :: !Bool
58 | , beActiveXControls :: !Bool
59 | , beBanned :: !Bool
60 | , beMobileDevice :: !Bool
61 | , beSyndicationReader :: !Bool
62 | , beCrawler :: !Bool
63 | , beCSSVersion :: !T.Text
64 | , beAolVersion :: !T.Text
65 | , beMasterParent :: !Bool
66 | , beSortOrder :: !T.Text
67 | , beInternalID :: !T.Text
68 | } deriving (Eq, Ord, Show)
69 |
70 | instance NFData BrowserEntry where
71 |
72 | data BrowserEntryShim = BrowserEntryShim {
73 | besParent :: T.Text
74 | , besUserAgent :: T.Text
75 | , besUserAgentMatcher :: [MatchPart]
76 | , besBrowser :: T.Text
77 | , besVersion :: T.Text
78 | , besMajorVersion :: T.Text
79 | , besMinorVersion :: T.Text
80 | , besPlatform :: T.Text
81 | , besAlpha :: T.Text
82 | , besBeta :: T.Text
83 | , besWin16 :: T.Text
84 | , besWin32 :: T.Text
85 | , besWin64 :: T.Text
86 | , besFrames :: T.Text
87 | , besIFrames :: T.Text
88 | , besTables :: T.Text
89 | , besCookies :: T.Text
90 | , besBackgroundSounds :: T.Text
91 | , besJavaScript :: T.Text
92 | , besVBScript :: T.Text
93 | , besJavaApplets :: T.Text
94 | , besActiveXControls :: T.Text
95 | , besBanned :: T.Text
96 | , besMobileDevice :: T.Text
97 | , besSyndicationReader :: T.Text
98 | , besCrawler :: T.Text
99 | , besCSSVersion :: T.Text
100 | , besAolVersion :: T.Text
101 | , besMasterParent :: T.Text
102 | , besSortOrder :: T.Text
103 | , besInternalID :: T.Text
104 | } deriving (Eq, Ord, Show)
105 |
106 | -- This would be faster if it returned a list of offsets
107 | -- and took the origional string and dropped the already-matched length.
108 | -- That is because it would improve match simplification.
109 | nextOptions :: [MatchPart] -> T.Text -> [T.Text]
110 | nextOptions ((TPart t0):_) rest = maybeToList $ T.stripPrefix t0 rest
111 | nextOptions (Many:(TPart t0):_) rest = map snd $ T.breakOnAll t0 rest
112 | nextOptions (One:_) rest = maybeToList $ fmap snd $ T.uncons rest
113 | nextOptions [Many] _ = [""]
114 | nextOptions [] rest = if T.null rest then [""] else []
115 | nextOptions mp _ = error $ "Failed match: " ++ show mp
116 |
117 | isMatch :: T.Text -> [MatchPart] -> Bool
118 | isMatch t mparts =
119 | let finalEnds = foldl (\ends mp -> concatMap (Set.toList . Set.fromList . nextOptions mp) ends) [t] $ tails mparts
120 | in "" `elem` finalEnds
121 |
122 | toMatcher :: T.Text -> [MatchPart]
123 | toMatcher t =
124 | optimize $ map toMatchPart $ T.unpack t
125 | where
126 | toMatchPart '?' = One
127 | toMatchPart '*' = Many
128 | toMatchPart c = TPart (T.pack [c])
129 | optimize ((TPart t0):(TPart t1):r) = optimize ((TPart (t0 `T.append` t1)):r)
130 | optimize (Many:Many:r) = optimize (Many : r)
131 | optimize (One:Many:r) = optimize (Many : r)
132 | optimize (Many:One:r) = optimize (Many : r)
133 | optimize (x:xs) = x : optimize xs
134 | optimize [] = []
135 |
136 | lookupBrowser :: BrowserCap -> BS8.ByteString -> IO (Maybe BrowserEntry)
137 | lookupBrowser BrowserCap {bcEntries=entries, bcCache=cacheRef} ua = do
138 | r <- timeout (10^(6::Int)) $ do
139 | cache <- LRU.lookup ua cacheRef
140 | case cache of
141 | Just be -> return $ Just be
142 | Nothing -> do
143 | case bestMatching of
144 | Nothing -> return Nothing
145 | Just be -> do
146 | LRU.insert ua be cacheRef
147 | return $ Just be
148 | return $ join r
149 | where
150 | bestMatching = listToMaybe $ map snd $ sortBy cmpByFst $ map (\be -> (T.length $ beUserAgent be, be)) allMatching
151 | allMatching = mapMaybe match entries
152 | cmpByFst a b = compare (fst b) (fst a)
153 | match :: BrowserEntry -> Maybe BrowserEntry
154 | match be =
155 | if isMatch (T.concat ["[", T.decodeUtf8 ua, "]"]) $ beUserAgentMatcher be
156 | then Just be
157 | else Nothing
158 |
159 | loadBrowserCap :: FilePath -> IO BrowserCap
160 | loadBrowserCap fn = do
161 | bcf <- T.readFile fn
162 | let bcl = drop 3 $ T.lines bcf
163 | let bce = catMaybes $ map (AP.maybeResult . AP.parse parseBCLine) bcl
164 | bccR <- LRU.newAtomicLRU (Just 16)
165 | let bces = force $ convertShims bce
166 | (force bces) `seq` return $
167 | BrowserCap { bcEntries = bces
168 | , bcCache = bccR
169 | }
170 |
171 | parseBCLine :: AP.Parser BrowserEntryShim
172 | parseBCLine = do
173 | parent <- parseQuoted
174 | _ <- AP.string ","
175 | userAgent <- parseQuoted
176 | _ <- AP.string ","
177 | browser <- parseQuoted
178 | _ <- AP.string ","
179 | version <- parseQuoted
180 | _ <- AP.string ","
181 | majorVersion <- parseQuoted
182 | _ <- AP.string ","
183 | minorVersion <- parseQuoted
184 | _ <- AP.string ","
185 | platform <- parseQuoted
186 | _ <- AP.string ","
187 | alpha <- parseQuoted
188 | _ <- AP.string ","
189 | beta <- parseQuoted
190 | _ <- AP.string ","
191 | win16 <- parseQuoted
192 | _ <- AP.string ","
193 | win32 <- parseQuoted
194 | _ <- AP.string ","
195 | win64 <- parseQuoted
196 | _ <- AP.string ","
197 | frames <- parseQuoted
198 | _ <- AP.string ","
199 | iFrames <- parseQuoted
200 | _ <- AP.string ","
201 | tables <- parseQuoted
202 | _ <- AP.string ","
203 | cookies <- parseQuoted
204 | _ <- AP.string ","
205 | backgroundSounds <- parseQuoted
206 | _ <- AP.string ","
207 | javaScript <- parseQuoted
208 | _ <- AP.string ","
209 | vBScript <- parseQuoted
210 | _ <- AP.string ","
211 | javaApplets <- parseQuoted
212 | _ <- AP.string ","
213 | activeXControls <- parseQuoted
214 | _ <- AP.string ","
215 | banned <- parseQuoted
216 | _ <- AP.string ","
217 | mobileDevice <- parseQuoted
218 | _ <- AP.string ","
219 | syndicationReader <- parseQuoted
220 | _ <- AP.string ","
221 | crawler <- parseQuoted
222 | _ <- AP.string ","
223 | cSSVersion <- parseQuoted
224 | _ <- AP.string ","
225 | aolVersion <- parseQuoted
226 | _ <- AP.string ","
227 | masterParent <- parseQuoted
228 | _ <- AP.string ","
229 | sortOrder <- parseQuoted
230 | _ <- AP.string ","
231 | internalID <- parseQuoted
232 | return $ BrowserEntryShim {
233 | besParent = parent
234 | , besUserAgent = userAgent
235 | , besUserAgentMatcher = toMatcher userAgent
236 | , besBrowser = browser
237 | , besVersion = version
238 | , besMajorVersion = majorVersion
239 | , besMinorVersion = minorVersion
240 | , besPlatform = platform
241 | , besAlpha = alpha
242 | , besBeta = beta
243 | , besWin16 = win16
244 | , besWin32 = win32
245 | , besWin64 = win64
246 | , besFrames = frames
247 | , besIFrames = iFrames
248 | , besTables = tables
249 | , besCookies = cookies
250 | , besBackgroundSounds = backgroundSounds
251 | , besJavaScript = javaScript
252 | , besVBScript = vBScript
253 | , besJavaApplets = javaApplets
254 | , besActiveXControls = activeXControls
255 | , besBanned = banned
256 | , besMobileDevice = mobileDevice
257 | , besSyndicationReader = syndicationReader
258 | , besCrawler = crawler
259 | , besCSSVersion = cSSVersion
260 | , besAolVersion = aolVersion
261 | , besMasterParent = masterParent
262 | , besSortOrder = sortOrder
263 | , besInternalID = internalID
264 | }
265 | where
266 | parseQuoted :: AP.Parser T.Text
267 | parseQuoted = do
268 | _ <- AP.string "\""
269 | str <- AP.takeWhile (/='"')
270 | _ <- AP.string "\""
271 | return str
272 |
273 | convertShims :: [BrowserEntryShim] -> [BrowserEntry]
274 | convertShims shims =
275 | let convMap = MapL.fromList $ map (\bes -> (besUserAgent bes, mergeBE bes convMap)) shims
276 | in MapL.elems convMap
277 |
278 | mergeBE :: BrowserEntryShim -> MapL.HashMap T.Text BrowserEntry -> BrowserEntry
279 | mergeBE c converted =
280 | let ourparent = -- trace ("=============\ngetting parent for: " ++ (T.unpack $ besUserAgent c)) $
281 | if (besParent c) == "DefaultProperties"
282 | then Nothing -- base case
283 | else
284 | if (besMasterParent c) == "true"
285 | then MapL.lookup "[DefaultProperties]" converted
286 | else MapL.lookup (T.concat ["[", besParent c, "]"]) converted
287 | be = BrowserEntry {
288 | beParent = besParent c
289 | , beUserAgent = besUserAgent c
290 | , beUserAgentMatcher = besUserAgentMatcher c
291 | , beBrowser = mergeText (besBrowser c) (fmap beBrowser ourparent)
292 | , beVersion = mergeText (besVersion c) (fmap beVersion ourparent)
293 | , beMajorVersion = mergeText (besMajorVersion c) (fmap beMajorVersion ourparent)
294 | , beMinorVersion = mergeText (besMinorVersion c) (fmap beMinorVersion ourparent)
295 | , bePlatform = mergeText (besPlatform c) (fmap bePlatform ourparent)
296 | , beWin16 = mergeBool (besWin16 c) (fmap beWin16 ourparent)
297 | , beWin32 = mergeBool (besWin32 c) (fmap beWin32 ourparent)
298 | , beWin64 = mergeBool (besWin32 c) (fmap beWin64 ourparent)
299 | , beFrames = mergeBool (besFrames c) (fmap beFrames ourparent)
300 | , beIFrames = mergeBool (besIFrames c) (fmap beIFrames ourparent)
301 | , beTables = mergeBool (besTables c) (fmap beTables ourparent)
302 | , beCookies = mergeBool (besCookies c) (fmap beCookies ourparent)
303 | , beBackgroundSounds = mergeBool (besBackgroundSounds c) (fmap beBackgroundSounds ourparent)
304 | , beJavaScript = mergeBool (besJavaScript c) (fmap beJavaScript ourparent)
305 | , beVBScript = mergeBool (besVBScript c) (fmap beVBScript ourparent)
306 | , beJavaApplets = mergeBool (besJavaApplets c) (fmap beJavaApplets ourparent)
307 | , beActiveXControls = mergeBool (besActiveXControls c) (fmap beActiveXControls ourparent)
308 | , beBanned = mergeBool (besBanned c) (fmap beBanned ourparent)
309 | , beMobileDevice = mergeBool (besBanned c) (fmap beMobileDevice ourparent)
310 | , beSyndicationReader = mergeBool (besSyndicationReader c) (fmap beSyndicationReader ourparent)
311 | , beCrawler = mergeBool (besCrawler c) (fmap beCrawler ourparent)
312 | , beCSSVersion = mergeText (besCSSVersion c) (fmap beCSSVersion ourparent)
313 | , beAolVersion = mergeText (besAolVersion c) (fmap beAolVersion ourparent)
314 | , beMasterParent = mergeBool (besMasterParent c) (Just $ error "WTF?")
315 | , beSortOrder = besSortOrder c
316 | , beInternalID = besInternalID c
317 | }
318 | in -- trace ("\n\n" ++ show ourparent ++ "\n" ++ show be ++ "\n\n") $
319 | be
320 | where
321 | mergeText :: T.Text -> Maybe T.Text -> T.Text
322 | mergeText ours mparents =
323 | if not $ ours `elem` ["default", ""]
324 | then ours
325 | else case mparents of
326 | Nothing -> ""
327 | Just parents -> parents
328 | mergeBool :: T.Text -> Maybe Bool -> Bool
329 | mergeBool ours mparents =
330 | case ours of
331 | "true" -> True
332 | "false" -> False
333 | "True" -> True
334 | "False" -> False
335 | "default" ->
336 | case mparents of
337 | Nothing -> error $ "lacking bool parent"
338 | Just parents -> parents
339 | e -> error $ "unknown bool type: " ++ (T.unpack e)
340 |
--------------------------------------------------------------------------------