diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/js/waldo.js b/js/waldo.js new file mode 100644 --- /dev/null +++ b/js/waldo.js @@ -0,0 +1,96 @@ +// Note: jQuery should be included before this script. +var ENDPOINT = 'http://127.0.0.1:3000/story/jarUcyikAg3', + PANELPATH = 'loadedPanels/' + +function renderComic(comicScript) { + var $comic = $('
') + .addClass('comic') + .css({ + width: comicScript.width, + height: comicScript.height + }) + $.each(comicScript.panels, function(idx, panel) { + var $panel = $('
') + .addClass('panel') + .css({ + left: panel.pos.x, + top: panel.pos.y, + width: panel.width, + height: panel.height + }) + .appendTo($comic) + $.each(panel.images, function(idx, image) { + var $img = $('') + .css({ + left: image.pos.x, + top: image.pos.y + }) + .attr('src', PANELPATH + image.url) + .appendTo($panel) + }) + }) + var $cover = $('
') + .addClass('cover') + .css({ + left: 0, + top: 0, + width: $comic.width(), + height: $comic.height() + }) + .attr('title', comicScript.alttext) + .appendTo($comic) + return $comic +} + +comicHandler = { + lastComic: null, + fetchComic: function() { + var details = { + w: $(window).width(), + h: $(window).height(), + r: document.referrer + } + + var sidePadding = 10 + $.ajax(ENDPOINT, { + data: details, + dataType: 'jsonp', + jsonpCallback: 'waldoCallback', + success: $.proxy(function(comicScript) { + if (comicScript.goto) { + window.location = comicScript.goto + } + + var comic = renderComic(comicScript), + comicWidth = comic.outerWidth(true), + comicHeight = comic.height() + + $('#container') + .empty() + .append(comic) + .width(comicWidth) + .height(comicHeight) + + this.lastComic = comicScript + }, this) + }) + } +} + +resizeHandler = { + delay: 250, + timeout: null, + onResize: function() { + if (!this.timeout) { + this.timeout = setTimeout($.proxy(function() { + this.timeout = null + comicHandler.fetchComic() + }, this), this.delay) + } + } +} + +$(document).ready($.proxy(comicHandler, 'fetchComic')) +$(window).resize(function() { + resizeHandler.onResize() +}) diff --git a/panels/a1_1p1s0_0.png b/panels/a1_1p1s0_0.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p1s0_0.png differ diff --git a/panels/a1_1p1s0_1.png b/panels/a1_1p1s0_1.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p1s0_1.png differ diff --git a/panels/a1_1p1s0_2.png b/panels/a1_1p1s0_2.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p1s0_2.png differ diff --git a/panels/a1_1p1s0_3.png b/panels/a1_1p1s0_3.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p1s0_3.png differ diff --git a/panels/a1_1p1s1_0.png b/panels/a1_1p1s1_0.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p1s1_0.png differ diff --git a/panels/a1_1p1s1_1.png b/panels/a1_1p1s1_1.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p1s1_1.png differ diff --git a/panels/a1_1p1s1_2.png b/panels/a1_1p1s1_2.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p1s1_2.png differ diff --git a/panels/a1_1p1s1_3.png b/panels/a1_1p1s1_3.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p1s1_3.png differ diff --git a/panels/a1_1p1s2_0.png b/panels/a1_1p1s2_0.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p1s2_0.png differ diff --git a/panels/a1_1p1s2_1.png b/panels/a1_1p1s2_1.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p1s2_1.png differ diff --git a/panels/a1_1p1s2_2.png b/panels/a1_1p1s2_2.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p1s2_2.png differ diff --git a/panels/a1_1p1s2_3.png b/panels/a1_1p1s2_3.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p1s2_3.png differ diff --git a/panels/a1_1p2s0_0.png b/panels/a1_1p2s0_0.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p2s0_0.png differ diff --git a/panels/a1_1p2s1_0.png b/panels/a1_1p2s1_0.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p2s1_0.png differ diff --git a/panels/a1_1p2s2_0.png b/panels/a1_1p2s2_0.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p2s2_0.png differ diff --git a/panels/a1_1p3s0_0.png b/panels/a1_1p3s0_0.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p3s0_0.png differ diff --git a/panels/a1_1p3s1_0.png b/panels/a1_1p3s1_0.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p3s1_0.png differ diff --git a/panels/a1_1p3s2_0.png b/panels/a1_1p3s2_0.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p3s2_0.png differ diff --git a/panels/a1_1p4s1_0.png b/panels/a1_1p4s1_0.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p4s1_0.png differ diff --git a/panels/a1_1p4s1_1.png b/panels/a1_1p4s1_1.png new file mode 100644 Binary files /dev/null and b/panels/a1_1p4s1_1.png differ diff --git a/resize.sh b/resize.sh new file mode 100644 --- /dev/null +++ b/resize.sh @@ -0,0 +1,11 @@ +#!/bin/sh + +mkdir panels + +rm panels/*.png + +for f in highres/**/*.??g +do + echo $f + convert $f -resize 6% "panels/`basename $f`" +done diff --git a/src/Waldo/CityLoc.hs b/src/Waldo/CityLoc.hs new file mode 100644 --- /dev/null +++ b/src/Waldo/CityLoc.hs @@ -0,0 +1,71 @@ +module Waldo.CityLoc where + +import Control.Monad.Reader +import Data.Geo.Coord +import Data.Geo.Sphere +import Data.Geo.Haversine + +import Waldo.Stalk +import Waldo.Story + +data CityData = CityData { + cityLoc :: Coord + , cityInfluenceKm :: Double + } + +mkCity :: Coord -> Double -> CityData +mkCity l i = CityData l i + +closeTo :: CityData -> StoryGuard +closeTo c = + asks pdLatLon >>= guard . (maybe False (\latlon -> + let kmDist = (haversine earthMean (cityLoc c) latlon)/1000 + in kmDist < (cityInfluenceKm c))) + +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 + +atlanta = mkCity (( 33.755000) !.! (- 84.390000)) 20 +belfast = mkCity (( 54.600000) !.! (- 5.916700)) 6 +boston = mkCity (( 42.357778) !.! (- 71.061667)) 4 +brisbane = mkCity ((-27.466700) !.! ( 153.033300)) 180 +cambridge = mkCity (( 42.373611) !.! (- 71.110556)) 40 +chicago = mkCity (( 41.881944) !.! (- 87.627778)) 40 +christchurch = mkCity ((-43.500000) !.! ( 172.600000)) 13 +cnu = mkCity (( 37.063800) !.! (- 76.494200)) 10 +dallas = mkCity (( 32.782778) !.! (- 96.803889)) 73 +detroit = mkCity (( 42.331389) !.! (- 83.045833)) 50 +greenBay = mkCity (( 44.513333) !.! (- 88.015833)) 180 +halifax = mkCity (( 44.654444) !.! (- 63.599167)) 17 +houston = mkCity (( 29.762778) !.! (- 95.383056)) 20 +jerusalem = mkCity (( 31.783300) !.! ( 35.216700)) 4 +lakeChamplain= mkCity (( 44.533333) !.! (- 73.333333)) 58 +lakeErie = mkCity (( 42.200000) !.! (- 81.200000)) 140 +lakeMead = mkCity (( 36.250000) !.! (-114.390000)) 50 +lakeMichigan = mkCity (( 44.000000) !.! (- 87.000000)) 130 +lasVegas = mkCity (( 36.175000) !.! (-115.136389)) 20 +london = mkCity (( 51.517100) !.! ( 0.106200)) 30 +losAngeles = mkCity (( 34.050000) !.! (-118.250000)) 65 +melbourne = mkCity ((-37.783300) !.! ( 144.966700)) 40 +miami = mkCity (( 25.787778) !.! (- 80.224167)) 30 +montreal = mkCity (( 45.500000) !.! (- 73.666667)) 45 +downtownNYC = mkCity (( 40.664167) !.! (- 73.938611)) 20 +nyc = mkCity (( 40.664167) !.! (- 73.938611)) 20 +ottawa = mkCity (( 45.420833) !.! (- 75.690000)) 50 +paris = mkCity (( 48.874200) !.! ( 2.347000)) 25 +philadelphia = mkCity (( 39.953333) !.! (- 75.170000)) 20 +richmond = mkCity (( 37.540972) !.! (- 77.432889)) 40 +rioDeJaneiro = mkCity ((-22.908300) !.! (- 43.243600)) 70 +riverside = mkCity (( 33.948056) !.! (-117.396111)) 15 +sacramento = mkCity (( 38.555556) !.! (-121.468889)) 45 +sanAntonio = mkCity (( 29.416667) !.! (- 98.500000)) 23 +sanDiego = mkCity (( 32.715000) !.! (-117.162500)) 60 +sanFran = mkCity (( 37.779300) !.! (-122.419200)) 10 +scotland = mkCity (( 57.100000) !.! (- 4.000000)) 250 +seattle = mkCity (( 47.609722) !.! (-122.333056)) 45 +sendai = mkCity (( 31.816700) !.! ( 130.300600)) 35 +sydney = mkCity ((-33.868300) !.! ( 151.208600)) 60 +tampa = mkCity (( 27.947222) !.! (- 82.458611)) 42 +telAviv = mkCity (( 32.083300) !.! ( 34.800000)) 10 +tokyo = mkCity (( 35.683300) !.! ( 139.766700)) 50 +toronto = mkCity (( 43.716589) !.! (- 79.340686)) 30 +vaBeach = mkCity (( 36.850600) !.! (- 75.977900)) 37 diff --git a/src/Waldo/Script.hs b/src/Waldo/Script.hs new file mode 100644 --- /dev/null +++ b/src/Waldo/Script.hs @@ -0,0 +1,195 @@ +{-# LANGUAGE OverloadedStrings #-} +module Waldo.Script ( + Script(..) + , PanelSizes, PanelData(..), Panel(..) + , ImagePart(..) + , TextPart(..) + , Pos(..) + , loadImagePanels, mkScript, scriptName + ) where + +import Data.List +import Control.Monad +import Control.Monad.Reader +import qualified Data.Text as T +import qualified Data.Aeson as JS +import qualified Data.ByteString.Lazy.Char8 as BSL8 +import Control.Monad.Trans.Resource (runResourceT) +import Data.Conduit (($$)) +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.ImageSize as CI +import System.FilePath ((), takeFileName, splitExtension) +import System.FilePath.Glob +import Data.Digest.Pure.SHA +import Control.DeepSeq +import System.Directory + +import Data.Aeson ((.=)) + +pad :: Int +pad = 4 + +panelRightEdge :: Panel -> Int +panelRightEdge p = (pX $ pPos p) + (pWidth p) + +scriptName :: Script -> T.Text +scriptName (s@Script {}) = T.concat $ [sName s, " : "] ++ (intersperse "+" $ map pName (sPanels s)) +scriptName (ScriptTo goto) = T.concat ["Goto : ", goto] + +mkScript :: T.Text -- name + -> T.Text -- alt-text + -> [PanelData] -- panels! + -> Script +mkScript nm alt pds = + let ps = snd $ mapAccumL (\xstart p -> + let newp = panelData2panel xstart p + in (panelRightEdge newp, newp)) 0 pds + in Script { + sAltText = alt + , sPanels = ps + , sHeight = 2*pad + (maximum $ map pHeight ps) + , sWidth = (1+length ps)*pad + (sum $ map pWidth ps) + , sName = nm + } + +hashImgNm :: FilePath -> FilePath +hashImgNm fn = + let (nm, typ) = splitExtension fn + in (showDigest $ sha256 (BSL8.pack ("basfd" ++ nm)))++typ + +loadImagePanels :: Int -- Story + -> Int -- Panel + -> Int -- Choice + -> ReaderT FilePath IO PanelSizes +loadImagePanels s p c = do + bp <- ask + fns <- liftIO $ glob (bp "panels" + ("a1_"++show s++"p"++show p++"s*_"++show c++".*")) + ps <- liftIO $ forM fns $ \fn -> do + mImgInf <- runResourceT $ CB.sourceFile fn $$ CI.sinkImageSize + case mImgInf of + Nothing -> fail "Couldn't read image." + Just sz -> do + let pname = hashImgNm $ takeFileName fn + d <- BSL8.readFile fn + createDirectoryIfMissing False "/tmp/loadedPanels" + BSL8.writeFile ("/tmp/loadedPanels" pname) d + return $ + PanelData { + pdWidth = CI.width sz + , pdHeight = CI.height sz + , pdImages = [ImagePart { ipPos = Pos 0 0, ipImageUrl = T.pack pname }] + , pdText = [] + , pdName = T.pack ("p"++show p++"s"++show s++"_"++show c) + } + if null ps + then fail ("No panels found for "++show (s, p, c)) + else return ps + +panelData2panel :: Int -> PanelData -> Panel +panelData2panel xlast pd = + Panel { + pPos = Pos (xlast+pad) pad + , pWidth = pdWidth pd + , pHeight = pdHeight pd + , pImages = pdImages pd + , pText = pdText pd + , pName = pdName pd + } + +type PanelSizes = [PanelData] + +data Script = + ScriptTo { + sTarget :: !T.Text + } + | Script { + sWidth :: !Int + , sHeight :: !Int + , sAltText :: !T.Text + , sPanels :: [Panel] + , sName :: !T.Text + } + deriving (Eq, Ord, Show) + +instance NFData Script where + rnf (s@ScriptTo {sTarget=t}) = t `seq` s `seq` () + rnf (s@Script {sWidth=w, sHeight=h, sAltText=a, sPanels=p, sName=n}) = + w `seq` h `seq` a `deepseq` p `deepseq` n `deepseq` s `seq` () + +data Panel = Panel { + pPos :: !Pos + , pWidth :: !Int + , pHeight :: !Int + , pImages :: [ImagePart] + , pText :: [TextPart] + , pName :: !T.Text + } deriving (Eq, Ord, Show) + +instance NFData Panel where + rnf (pan@Panel {pPos=p, pWidth=w, pHeight=h, pImages=i, pText=t, pName=n}) = + p `deepseq` w `seq` h `seq` i `deepseq` t `deepseq` n `deepseq` pan `seq` () + +data PanelData = PanelData { + pdWidth :: !Int + , pdHeight :: !Int + , pdImages :: [ImagePart] + , pdText :: [TextPart] + , pdName :: !T.Text + } deriving (Eq, Ord, Show) + +data ImagePart = ImagePart { + ipPos :: !Pos + , ipImageUrl :: !T.Text + } deriving (Eq, Ord, Show) + +instance NFData ImagePart where + rnf (i@ImagePart {ipPos=p, ipImageUrl=u}) = + p `deepseq` u `deepseq` i `seq` () + +data TextPart = TextPart { + tpPos :: !Pos + , tpString :: !T.Text + , tpSize :: !Float + , tpFont :: !T.Text + , tpAngle :: !Float + } deriving (Eq, Ord, Show) + +instance NFData TextPart where + rnf (tp@TextPart {tpPos=p, tpString=t, tpSize=s, tpFont=f, tpAngle=a}) = + p `deepseq` t `deepseq` s `seq` f `deepseq` a `seq` tp `seq` () + +data Pos = Pos { pX :: !Int, pY :: !Int } deriving (Eq, Ord, Show) + +instance NFData Pos where + rnf (p@Pos {pX=x, pY=y}) = x `seq` y `seq` p `seq` () + +instance JS.ToJSON Script where + toJSON (ScriptTo t) = JS.object ["goto" .= t] + toJSON (Script w h alt ps _) = JS.object [ "width" .= w + , "height" .= h + , "alttext" .= alt + , "panels" .= ps + ] + +instance JS.ToJSON Panel where + toJSON (Panel p w h is ts _) = JS.object [ "pos" .= p + , "width" .= w + , "height" .= h + , "images" .= is + , "texts" .= ts + ] + +instance JS.ToJSON ImagePart where + toJSON (ImagePart p url) = JS.object [ "pos" .= p, "url" .= url ] + +instance JS.ToJSON TextPart where + toJSON (TextPart p str sz f r) = JS.object [ "pos" .= p + , "str" .= str + , "size" .= sz + , "font" .= f + , "rad" .= r + ] + +instance JS.ToJSON Pos where + toJSON (Pos x y) = JS.object [ "x" .= x, "y" .= y ] diff --git a/src/Waldo/Server.hs b/src/Waldo/Server.hs new file mode 100644 --- /dev/null +++ b/src/Waldo/Server.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE OverloadedStrings #-} +module Waldo.Server ( + waldoApp + ) where + +import Control.Monad.Trans +import Control.Monad.Reader +import qualified Data.Text as T +import qualified Data.HashMap.Strict as Map +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Aeson as JS +import qualified Network.Wai as WAI +import qualified Network.HTTP.Types as HTTP +import qualified Blaze.ByteString.Builder.Char8 as BB8 +import qualified Blaze.ByteString.Builder.ByteString as BBB + +import Waldo.Waldo +import Waldo.Stalk + +waldoApp :: WaldoData -> WAI.Application +waldoApp wd req resp = + (flip runReaderT wd) $ + case (WAI.requestMethod req, WAI.pathInfo req) of + ("GET", [s]) -> getScript req s >>= (lift . resp) + _ -> lift $ resp resp404 + +resp404 :: WAI.Response +resp404 = + WAI.responseBuilder + HTTP.status404 + [("Content-Type", "text/plain")] $ + BB8.fromString "Not Found" + +getScript :: WAI.Request -> T.Text -> ReaderT WaldoData IO WAI.Response +getScript req storySet = do + let stalkreq = wai2stalk req + wd <- ask + pd <- liftIO $ stalk (wdStalkDB wd) stalkreq + case Map.lookup storySet (wdGenScript wd) of + Nothing -> return resp404 + Just storyGen -> do + script <- liftIO $ storyGen pd + return $ WAI.responseBuilder + HTTP.status200 + [("Content-Type", "application/javascript") + ,("Access-Control-Allow-Origin", "*")] $ + mconcat $ concat [ + [BBB.fromByteString "waldoCallback(" ] + , map BBB.fromByteString $ BSL.toChunks $ JS.encode script + , [BBB.fromByteString ")"] + ] diff --git a/src/Waldo/Stalk.hs b/src/Waldo/Stalk.hs new file mode 100644 --- /dev/null +++ b/src/Waldo/Stalk.hs @@ -0,0 +1,294 @@ +{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-} +module Waldo.Stalk ( + OS(..), Browser(..), NetSpeed(..) + , PersonalData(..) + , StalkRequest, wai2stalk + , StalkDB, loadStalkDB + , stalk + ) where + +import Data.Word +import Data.Bits +import Data.Maybe +import Data.Bifunctor +import Control.Monad +import Data.List (intercalate) +import Data.Geolocation.GeoIP +import Data.ByteString (ByteString) +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Aeson (ToJSON(toJSON), FromJSON(parseJSON), (.=), (.:), (.:?)) +import Network.Socket (SockAddr(SockAddrInet, SockAddrInet6)) +import Data.Either (rights) +import System.FilePath (()) +import qualified Text.Regex.TDFA as R +import qualified Text.Regex.TDFA.ByteString as RB +import qualified Data.Aeson as JS +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Network.Wai as WAI +import qualified Network.HTTP.Types as HTTP +import qualified Data.HashMap.Strict as Map +import qualified Data.CaseInsensitive as CI +import Network.URI +import Data.Geo.Coord +import Safe + +import Data.BrowsCap +import Data.BrowsCap.Aquire + +data Browser = + Chrome + | Safari + | FireFox + | InternetExplorer + | Opera + | Netscape + deriving (Eq, Ord, Show) + +data OS = + BSD + | Linux + | Windows + | Mac + deriving (Eq, Ord, Show) + +data NetSpeed = + Dialup + | Cellular + | CableDSL + | Corporate + deriving (Eq, Ord, Show) + +data PersonalData = + PersonalData { + pdLocal :: [ByteString] -- Order of decreasing precision. + , pdOrg :: Maybe ByteString -- Who owns the IP. + , pdISP :: Maybe ByteString -- Who provides internet to the IP. + , pdNetSpeed :: Maybe NetSpeed + , pdReferer :: Maybe ByteString + , pdRefURI :: Maybe URI + , pdBrowser :: Maybe Browser + , pdOS :: Maybe OS + , pdLatLon :: Maybe Coord + , pdScreen :: (Int, Int) + , pdBrowserEntry :: Maybe BrowserEntry + , pdStalk :: StalkRequest + } deriving (Eq, Show) + +data StalkRequest = + StalkRequest { + srParams :: HTTP.Query + , srHeaders :: HTTP.RequestHeaders + , srFromIP :: Maybe ByteString + , srTrustForward :: Bool + } + deriving (Eq, Ord, Show) + +instance ToJSON StalkRequest where + toJSON (StalkRequest {srParams=p, srHeaders=h, srFromIP=ip, srTrustForward=t}) = + -- FIXME hasty conversion from aeson 0.6, partial format kept for compatability + JS.object [ "params" .= map (bimap TE.decodeUtf8 (fmap TE.decodeUtf8)) p + , "headers" .= map (\(k, v) -> (TE.decodeUtf8 $ CI.original k, TE.decodeUtf8 v)) h + , "ip" .= fmap TE.decodeUtf8 ip + , "trust_forward" .= t + ] + +instance FromJSON StalkRequest where + parseJSON (JS.Object o) = do + ip <- (fmap TE.encodeUtf8) <$> (o .:? "ip") + p <- (map (bimap TE.encodeUtf8 (fmap (TE.encodeUtf8)))) <$> (o .: "params") + t <- o .: "trust_forward" + h <- (map (bimap (CI.mk . TE.encodeUtf8) TE.encodeUtf8)) <$> (o .: "headers") + return $ StalkRequest { + srParams=p + , srHeaders=h + , srFromIP=ip + , srTrustForward=t + } + parseJSON _ = mzero + +data StalkDB = + StalkDB { + sdbBrowserCap :: BrowsCap + , sdbMaxMindCity :: GeoDB + , sdbMaxMindOrg :: GeoDB + , sdbMaxMindISP :: GeoDB + , sdbMaxMindNet :: GeoDB + } + +loadStalkDB :: FilePath -> IO StalkDB +loadStalkDB dd = do + bc <- browsCapFromFile $ dd "full_php_browscap.ini" + cdb <- openGeoDB mmap_cache $ dd "GeoIPCity.dat" + odb <- openGeoDB mmap_cache $ dd "GeoIPOrg.dat" + idb <- openGeoDB mmap_cache $ dd "GeoIPISP.dat" + ndb <- openGeoDB mmap_cache $ dd "GeoIPNet.dat" + return $ StalkDB { + sdbBrowserCap = bc + , sdbMaxMindCity = cdb + , sdbMaxMindOrg = odb + , sdbMaxMindISP = idb + , sdbMaxMindNet = ndb + } + +wai2stalk :: WAI.Request -> StalkRequest +wai2stalk req = + StalkRequest { + srParams = WAI.queryString req + , srHeaders = WAI.requestHeaders req + , srFromIP = ip + , srTrustForward = True + } + where + ip = + case WAI.remoteHost req of + SockAddrInet _ addr4 -> + let (x0, x1, x2, x3) = w32to8 addr4 + in Just $ TE.encodeUtf8 . T.pack $ concat [show x3, ".", show x2, ".", show x1, ".", show x0] + SockAddrInet6 _ _ _ _ -> Nothing + _ -> Nothing + +stalk :: StalkDB -> StalkRequest -> IO PersonalData +stalk sdb req = do + bc <- lookupBrowser (sdbBrowserCap sdb) $ fromMaybe "" agnt + let mips = if srTrustForward req + then (maybeToList $ lookup "X-Forwarded-For" (srHeaders req)) ++ + (map snd $ filter (\h -> (fst h) `elem` ["X-Forward-For"]) (srHeaders req)) + else maybeToList $ srFromIP req + let ips = mapMaybe validIP mips + let browser = str2browser $ fromMaybe "" $ fmap beBrowser bc + let os = str2os $ fromMaybe "" $ fmap bePlatform bc + geos <- forM (ips) $ \ip -> do + gipCityM <- geoLocateByIPAddress (sdbMaxMindCity sdb) ip + gipOrgM <- geoStringByIPAddress (sdbMaxMindOrg sdb) ip + gipISPM <- geoStringByIPAddress (sdbMaxMindISP sdb) ip + gipNetM <- geoStringByIPAddress (sdbMaxMindNet sdb) ip + return $ + if not $ or [isJust gipCityM, isJust gipOrgM, isJust gipISPM, isJust gipNetM] + then Nothing + else Just $ PersonalData { + pdLocal = (fromMaybe [] $ fmap city2locals gipCityM) ++ ["Earth"] + , pdOrg = fmap cleanOrg gipOrgM + , pdISP = gipISPM + , pdNetSpeed = join $ fmap str2speed gipNetM + , pdReferer = referer + , pdRefURI = refUri + , pdBrowser = browser + , pdOS = os + , pdLatLon = parseLatLon gipCityM + , pdScreen = scrn + , pdBrowserEntry = bc + , pdStalk = req + } + return $ fromMaybe (noGeoResult bc browser os) $ listToMaybe $ catMaybes geos + where + parseLatLon gipc = do + c <- gipc + return ((geoLatitude c) !.! (geoLongitude c)) + city2locals :: GeoIPRecord -> [ByteString] + city2locals g = [geoCity g, geoRegion g, geoCountryCode3 g, geoCountryName g, geoContinentCode g] + noGeoResult bc browser os = + PersonalData { + pdLocal = ["Earth"] + , pdOrg = Nothing + , pdISP = Nothing + , pdNetSpeed = Nothing + , pdReferer = referer + , pdRefURI = refUri + , pdBrowser = browser + , pdOS = os + , pdLatLon = Nothing + , pdScreen = scrn + , pdBrowserEntry = bc + , pdStalk = req + } + parms = srParams req + hdrs = srHeaders req + scrn = + let x = case BS8.readInt (fromMaybe "" $ join $ lookup "w" parms) of + Nothing -> 0 + Just (xi, _) -> xi + y = case BS8.readInt (fromMaybe "" $ join $ lookup "h" parms) of + Nothing -> 0 + Just (yi, _) -> yi + in (x, y) + agnt = lookup "User-Agent" hdrs + referer = join $ lookup "r" parms + refUri = join $ fmap (parseURI . T.unpack . TE.decodeUtf8) referer + validIP :: ByteString -> Maybe ByteString + validIP fips0 = do + (x0, fips1) <- BS8.readInt fips0 + (x1, fips2) <- BS8.readInt $ BS.drop 1 fips1 + (x2, fips3) <- BS8.readInt $ BS.drop 1 fips2 + (x3, _) <- BS8.readInt $ BS.drop 1 fips3 + return $ TE.encodeUtf8 . T.pack $ intercalate "." [show x0, show x1, show x2, show x3] + rComp = + R.CompOption {R.multiline=False,R.rightAssoc=True + ,R.caseSensitive=False,R.newSyntax=True,R.lastStarGreedy=False} + rExec = + R.ExecOption { R.captureGroups=False } + rCompile (p, r) = + case RB.compile rComp rExec p of + Left e -> Left e + Right c -> Right (c, r) + clean :: [(ByteString, ByteString)] -> BS.ByteString -> BS.ByteString + clean rules this = fromMaybe this $ + fmap snd $ headMay $ + filter (\(p, _) -> either (const False) isJust $ RB.regexec p this) $ + rights $ map rCompile rules + cleanOrg :: BS.ByteString -> BS.ByteString + cleanOrg = clean [ + ("\\^Google", "Google") + ] + str2speed = + flip Map.lookup (Map.fromList [ + ("Dialup", Dialup) + , ("Cellular", Cellular) + , ("Cable/DSL", CableDSL) + , ("Corporate", Corporate) + ]) + str2browser = + flip Map.lookup (Map.fromList [ + ("Chrome" , Chrome), ("Chromium", Chrome) + , ("Safari", Safari) + , ("Firefox", FireFox), ("Iceweasel", FireFox) + , ("IE", InternetExplorer) + , ("Opera", Opera), ("Opera Mini", Opera) + , ("Netscape", Netscape) + ]) + str2os = + flip Map.lookup (Map.fromList [ + ("MacOSX", Mac) + , ("Linux", Linux), ("Debian", Linux) + , ("FreeBSD", BSD), ("NetBSD", BSD), ("OpenBSD", BSD) + , ("IRIX", BSD), ("IRIX64", BSD) + , ("HP-UX", BSD) + , ("SunOS", BSD), ("Solaris", BSD) + , ("WinCE", Windows) + , ("Win16", Windows), ("Win32", Windows), ("Win64", Windows) + , ("Win31", Windows) + , ("Win95", Windows), ("Win98", Windows), ("WinME", Windows) + , ("WinNT", Windows) + , ("Win2000", Windows), ("Win2003", Windows) + , ("WinXP", Windows), ("WinVista", Windows) + , ("Win7", Windows), ("Win8", Windows) + ]) + +w32to8 :: Word32 -> (Word8, Word8, Word8, Word8) +w32to8 w0 = + let (w0_h, w0_l) = w32to16 w0 + ((x0, x1), (x2, x3)) = (w16to8 w0_h, w16to8 w0_l) + in (x0, x1, x2, x3) + +w32to16 :: Word32 -> (Word16, Word16) +w32to16 w0 = + let w_h = fromIntegral $ w0 `shiftR` 16 + w_l = fromIntegral $ w0 .&. 0xFFFF + in (w_h, w_l) + +w16to8 :: Word16 -> (Word8, Word8) +w16to8 w0 = + let w_h = fromIntegral $ w0 `shiftR` 8 + w_l = fromIntegral $ w0 .&. 0xFF + in (w_h, w_l) diff --git a/src/Waldo/Story.hs b/src/Waldo/Story.hs new file mode 100644 --- /dev/null +++ b/src/Waldo/Story.hs @@ -0,0 +1,118 @@ +{-# LANGUAGE OverloadedStrings #-} +module Waldo.Story ( + selectStory + , knapsackSizer + , Story(..) + , StoryGuard, StoryOption + , isIn, browserIs, osIs, netSpeedIs, orgIs, orgMatch, ispIs + , refererDomainIs + , pdTestJustIs + , giveThem, allocate + ) where + +import Data.Maybe +import Data.List +import Control.Monad.Reader +import Data.ByteString.Char8 (ByteString) +import qualified Data.Text as T +import Network.URI +import Text.Regex.TDFA ((=~)) + +import Waldo.Stalk +import Waldo.Script + +type StoryGuard = ReaderT PersonalData Maybe () +type StoryOption = ReaderT PersonalData Maybe Story + +data Story = + StoryGoto { + storyGoto :: T.Text + } + | Story { + storyAltText :: T.Text + , storyPanelSets :: [PanelSizes] + , storyPadX :: Int + , storyPadY :: Int + , storyName :: T.Text + } + deriving (Show) + +selectStory :: ((Int, Int) -> Story -> Maybe Script) -> Script -> [StoryOption] -> PersonalData -> IO Script +selectStory sizer d storyGens pd = do + --print storyGens + -- generate stories + let stories = catMaybes $ map (flip runReaderT pd) storyGens + --print stories + -- size the selected scripts + let scripts = mapMaybe doSize stories + --print scripts + -- Get our script, either the default or a selected one. + return $ fromMaybe d $ listToMaybe scripts + where + doSize (s@Story {}) = sizer (pdScreen pd) s + doSize (StoryGoto t) = Just (ScriptTo t) + +knapsackSizer :: Int -> (Int, Int) -> Story -> Maybe Script +knapsackSizer sitePad (w, h) s = + -- Get the first entry if there is one, the smallest if none of them fit. + listToMaybe $ (sortCorrectDir sizeLimited) ++ (take 1 areaSortedSized) + where + -- selected sort dir by what we know about the screen + sortCorrectDir = + if (h > 0) && (w > 0) + then reverse + else id + -- The fitting scripts + sizeLimited = fitWidth $ fitHeight $ areaSortedSized + -- sort by area + areaSortedSized = areaSort allScripts + -- Of all scripts + allScripts = do + combo <- mapM id $ storyPanelSets s + return $ mkScript (storyName s) (storyAltText s) combo + areaSort = sortBy (\a b -> compare (scriptArea a) (scriptArea b)) + scriptArea scr = (sHeight scr) * (sWidth scr) + fitHeight scripts = + if h > 0 + then filter (\scr -> h > (sHeight scr+storyPadY s+sitePad)) scripts + else scripts + fitWidth scripts = + if w > 0 + then filter (\scr -> w > (sWidth scr+storyPadX s+sitePad)) scripts + else scripts + +refererDomainIs :: String -> StoryGuard +refererDomainIs d = + asks pdRefURI >>= guard . fromMaybe False . fmap ((isSuffixOf d) . uriRegName) . join . fmap uriAuthority + +--refererMatches :: + +pdTestJustIs :: Eq a => (PersonalData -> Maybe a) -> a -> StoryGuard +pdTestJustIs g v = asks g >>= guard . maybe False (v==) + +isIn :: ByteString -> StoryGuard +isIn locName = asks pdLocal >>= guard . (not . null . (filter (locName==))) + +browserIs :: Browser -> StoryGuard +browserIs b = asks pdBrowser >>= guard . (maybe False (b==)) + +osIs :: OS -> StoryGuard +osIs os = asks pdOS >>= guard . (maybe False (os==)) + +netSpeedIs :: NetSpeed -> StoryGuard +netSpeedIs ns = asks pdNetSpeed >>= guard . (maybe False (ns==)) + +orgIs :: ByteString -> StoryGuard +orgIs o = asks pdOrg >>= guard . (maybe False (o==)) + +orgMatch :: ByteString -> StoryGuard +orgMatch o = asks pdOrg >>= guard . (maybe False (flip (=~) o)) + +ispIs :: ByteString -> StoryGuard +ispIs i = asks pdISP >>= guard . (maybe False (i==)) + +allocate :: MonadPlus m => m () -> a -> m a +allocate cnd r = cnd >> return r + +giveThem :: MonadPlus m => m () -> m a -> m a +giveThem = (>>) diff --git a/src/Waldo/StoryExample.hs b/src/Waldo/StoryExample.hs new file mode 100644 --- /dev/null +++ b/src/Waldo/StoryExample.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} +module Waldo.StoryExample ( + loadScriptGen + ) where + +import Control.Monad +import Control.Monad.Reader +import Data.ByteString.Char8 () +import Data.Text () + +import Paths_waldo +import Waldo.Stalk +import Waldo.Script +import Waldo.Story +import Waldo.CityLoc + +loadScriptGen :: IO (PersonalData -> IO Script) +loadScriptGen = do + bp <- getDataDir + flip runReaderT bp $ do + defaultScript <- loadDefaultScript + stories <- story1example + return $ selectStory (knapsackSizer 100) defaultScript stories + +-- If they really defeat our snooping, they get this one. +loadDefaultScript :: ReaderT FilePath IO Script +loadDefaultScript = do + p1 <- loadImagePanels 1 1 0 + p2 <- loadImagePanels 1 2 0 + p3 <- loadImagePanels 1 3 0 + p4 <- loadImagePanels 1 4 0 + return $ mkScript "failback" alt $ map head [p1, p2, p3, p4 ] + where + alt = "This is the testiest test ever!" + +story1example :: ReaderT FilePath IO [StoryOption] +story1example = do + s1p1c0 <- loadImagePanels 1 1 0 + s1p1c1 <- loadImagePanels 1 1 1 + s1p1c2 <- loadImagePanels 1 1 2 + s1p1c3 <- loadImagePanels 1 1 3 + + s1p2 <- loadImagePanels 1 2 0 + + s1p3 <- loadImagePanels 1 3 0 + + s1p4c0 <- loadImagePanels 1 4 0 + s1p4c1 <- loadImagePanels 1 4 1 + + return [ + do + isIn "NA" -- Only for North Americans + p1 <- msum [ orgIs "Massachusetts Institute of Technology" `allocate` s1p1c1 + , closeTo sydney `allocate` s1p1c2 + , closeTo sanFran `allocate` s1p1c3 + , return s1p1c0 + ] + p4 <- msum [ osIs BSD `allocate` s1p4c1 + , osIs Linux `allocate` s1p4c0 + ] + return $ Story { + storyAltText = "Alt" + , storyPanelSets = [ p1, s1p2, s1p3, p4 ] + , storyPadX = 0, storyPadY = 0 + , storyName = "s01" + } + ] diff --git a/src/Waldo/Waldo.hs b/src/Waldo/Waldo.hs new file mode 100644 --- /dev/null +++ b/src/Waldo/Waldo.hs @@ -0,0 +1,30 @@ +module Waldo.Waldo ( + WaldoData(..) + , loadWaldo + ) where + +import Control.Monad +import Data.HashMap.Strict (HashMap) +import qualified Data.HashMap.Strict as Map +import qualified Data.Text as T + +import Waldo.Stalk +import Waldo.Script + +data WaldoData = + WaldoData { + wdStalkDB :: StalkDB + , wdGenScript :: HashMap T.Text (PersonalData -> IO Script) + } + +loadWaldo :: FilePath -> [(T.Text, IO (PersonalData -> IO Script))] ->IO WaldoData +loadWaldo dd storyGenLoaders = do + sdb <- loadStalkDB dd + storyGens <- forM storyGenLoaders $ \(nm, ldr) -> do + sgen <- ldr + return (nm, sgen) + let wdata = WaldoData { wdStalkDB = sdb + , wdGenScript = Map.fromList storyGens + } + putStrLn "Loading completed!" + return wdata diff --git a/testcomic.html b/testcomic.html new file mode 100644 --- /dev/null +++ b/testcomic.html @@ -0,0 +1,14 @@ + + + + + + + +
+ + diff --git a/tools/LoadTest.hs b/tools/LoadTest.hs new file mode 100644 --- /dev/null +++ b/tools/LoadTest.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Monad.Trans +import Control.Monad.Reader +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy.Char8 as BSL8 +import qualified Data.Aeson as JS +import Data.Conduit (($$), ($=)) +import qualified Data.Conduit.Binary as CB +import qualified Data.Conduit.List as CL +import qualified Data.Conduit.Zlib as CZ +import Control.Monad.Trans.Resource (runResourceT) +import qualified Data.HashMap.Strict as Map +import Data.Maybe +import Control.DeepSeq (deepseq) +import System.Environment + +import Waldo.Stalk +import Waldo.Waldo +import qualified Waldo.StoryExample as SE + +main :: IO () +main = do + env <- getEnvironment + case lookup "WALDO_DATA" env of + Nothing -> do + putStrLn "Please set WALDO_DATA to a directory containing:" + putStrLn " - full_php_browscap.ini" + putStrLn " - GeoIPCity.dat" + putStrLn " - GeoIPNet.dat" + putStrLn " - GeoIPNet.dat" + putStrLn " - GeoIPOrg.dat" + Just dd -> do + wd <- loadWaldo dd [("jarUcyikAg3", SE.loadScriptGen)] + flip runReaderT wd $ runResourceT $ + CB.sourceFile "stalkreqs.gz" $= CZ.ungzip + $= CB.lines + $= CL.concatMap (maybeToList . JS.decode' . s2l::BS8.ByteString -> [StalkRequest]) + $= CL.mapM (\r -> liftIO $ stalk (wdStalkDB wd) r) + $= CL.mapM (\p -> (liftIO $ (fromJust $ Map.lookup "ghenkEggov8" (wdGenScript wd)) p) >>= \r -> r `deepseq` return r) +-- $$ CL.mapM_ (\_ -> return ()) + $$ CL.mapM_ (\d -> liftIO $ print d) + return () + +l2s :: BSL8.ByteString -> BS8.ByteString +l2s = BS8.concat . BSL8.toChunks + +s2l :: BS8.ByteString -> BSL8.ByteString +s2l = BSL8.fromChunks . (:[]) diff --git a/tools/WaldoServer.hs b/tools/WaldoServer.hs new file mode 100644 --- /dev/null +++ b/tools/WaldoServer.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Control.Applicative +import Control.Monad +import Data.Maybe +import qualified Network.Wai.Handler.Warp as Warp +import qualified Waldo.StoryExample as SE +import Waldo.Waldo +import Waldo.Server +import System.Environment +import Network.Wai.UrlMap +import Network.Wai.Application.Static +import WaiAppStatic.Types (unsafeToPiece) +import Safe + +import Paths_waldo + +main :: IO () +main = do + env <- getEnvironment + case lookup "WALDO_DATA" env of + Nothing -> do + putStrLn "Please set WALDO_DATA to a directory containing:" + putStrLn " - full_php_browscap.ini" + putStrLn " - GeoIPCity.dat" + putStrLn " - GeoIPNet.dat" + putStrLn " - GeoIPNet.dat" + putStrLn " - GeoIPOrg.dat" + Just dd -> do + -- This is where we "load" a set of scripts to serve. + -- Conceptually the server can serve any number of scripts. + wdata <- loadWaldo dd [("jarUcyikAg3", SE.loadScriptGen)] + bp <- getDataDir + Warp.runSettings (warpsettings env) . mapUrls $ + mount "story" (waldoApp wdata) + <|> mount "loadedPanels" ((staticApp (defaultFileServerSettings "/tmp/loadedPanels") {ssIndices=[unsafeToPiece "testcomic.html"]})) + <|> mountRoot (staticApp (defaultFileServerSettings bp)) + where + warpsettings env = Warp.setPort (fromMaybe 3000 (join $ fmap readMay $ lookup "WALDO_PORT" env)) Warp.defaultSettings diff --git a/waldo.cabal b/waldo.cabal new file mode 100644 --- /dev/null +++ b/waldo.cabal @@ -0,0 +1,102 @@ +Name: waldo +Version: 0 +Synopsis: A generator of comics based on some ascertainable data about the requester. +Description: This package was writen to power 's 2012 April Fools comic . It uses several datasets and a script to generate a customized story specific to the user viewing it. +License: BSD3 +License-file: LICENSE +Author: davean +Maintainer: oss@xkcd.com +Copyright: davean 2012-2017 +Category: Web +Build-type: Simple +Cabal-version: >=1.10 + +extra-source-files: + resize.sh + +data-files: + js/waldo.js + testcomic.html + panels/*.png + +source-repository head + type: git + location: https://code.xkrd.net/xkcd/waldo.git + +library + default-language: Haskell2010 + hs-source-dirs: src + other-modules: Paths_waldo + exposed-modules: + Waldo.CityLoc + , Waldo.Script + , Waldo.Stalk + , Waldo.StoryExample + , Waldo.Story + , Waldo.Waldo + , Waldo.Server + Build-depends: + base >= 4.9 && < 4.11 + , deepseq >= 1.4 && < 1.5 + , directory >= 1.3 && < 1.4 + , bytestring >= 0.10 && < 0.11 + , text >= 1.2 && < 1.3 + , aeson >= 1.2 && < 1.3 + , aeson-pretty >= 0.8 && < 0.9 + , mtl >= 2.2 && < 2.3 + , unordered-containers >= 0.2 && < 0.3 + , network >= 2.6 && < 2.7 + , network-uri >= 2.6 && < 2.7 + , lrucache >= 1.2 && < 1.3 + , attoparsec >= 0.13 && < 0.14 + , hs-GeoIP >= 0.3 && < 0.4 + , filepath >= 1.4 && < 1.5 + , resourcet >= 1.1 && < 1.2 + , conduit >= 1.2 && < 1.3 + , conduit-extra >= 1.1 && < 1.2 + , imagesize-conduit >= 1.1 && < 1.2 + , zlib-conduit >= 1.1 && < 1.2 + , wai >= 3.2 && < 3.3 + , http-types >= 0.9 && < 0.10 + , case-insensitive >= 1.2 && < 1.3 + , warp >= 3.2 && < 3.3 + , blaze-builder >= 0.4 && < 0.5 + , safe >= 0.3 && < 0.4 + , regex-tdfa >= 1.2 && < 1.3 + , Geodetic >= 0.4 && < 0.5 + , SHA >= 1.6 && < 1.7 + , Glob >= 0.7 && < 0.8 + , browscap >= 0 && < 0.1 + +Executable waldo-example + default-language: Haskell2010 + Ghc-Options: -rtsopts -threaded + Main-is: tools/WaldoServer.hs + other-modules: Paths_waldo + Build-depends: + base + , waldo + , wai >= 3.2 && < 3.3 + , wai-extra >= 3.0 && < 3.1 + , wai-app-static >= 3.1 && < 3.2 + , http-types >= 0.9 && < 0.10 + , warp >= 3.2 && < 3.3 + , safe + +Executable bench + default-language: Haskell2010 + Ghc-Options: -rtsopts -threaded + Main-is: tools/LoadTest.hs + Build-depends: + base + , waldo + , deepseq + , bytestring + , mtl + , aeson + , unordered-containers + , resourcet + , conduit + , conduit-extra + , zlib-conduit +