From 83c4cf1227cfa6397729a2727404d70f08146e14 Mon Sep 17 00:00:00 2001 From: vi Date: Fri, 29 Jun 2018 00:35:12 -0600 Subject: [PATCH] Supercompiled rule tries. --- examples/CountUpgradeable.hs | 10 +- examples/RedirectProxy.hs | 26 +++-- https-everywhere-rules.cabal | 7 +- src/Data/ByteString/RadixTrie.hs | 9 +- src/Data/HTTPSEverywhere/Rules.hs | 32 +++--- src/Data/HTTPSEverywhere/Rules/Internal.hs | 87 ++++++--------- .../HTTPSEverywhere/Rules/Internal/Parser.hs | 104 ++++++++---------- .../HTTPSEverywhere/Rules/Internal/Trie.hs | 89 +++++++++++++++ .../Rules/Internal/Trie/Supercompilation.hs | 41 +++++++ .../HTTPSEverywhere/Rules/Internal/Types.hs | 70 +++++++++++- .../Rules/Internal/Types/Serialisable.hs | 30 +++++ 11 files changed, 349 insertions(+), 156 deletions(-) create mode 100644 src/Data/HTTPSEverywhere/Rules/Internal/Trie.hs create mode 100644 src/Data/HTTPSEverywhere/Rules/Internal/Trie/Supercompilation.hs create mode 100644 src/Data/HTTPSEverywhere/Rules/Internal/Types/Serialisable.hs diff --git a/examples/CountUpgradeable.hs b/examples/CountUpgradeable.hs index 7d58dd0..eca1769 100644 --- a/examples/CountUpgradeable.hs +++ b/examples/CountUpgradeable.hs @@ -6,7 +6,7 @@ import "foldl" Control.Foldl (Fold(..)) import qualified "foldl" Control.Foldl as Foldl import "base" Control.Monad (forever) import "base" Data.Bool (bool) -import "https-everywhere-rules" Data.HTTPSEverywhere.Rules (rewriteURL, RuleSet, getRulesets) +import "https-everywhere-rules" Data.HTTPSEverywhere.Rules (rewriteURL) import "base" Data.Maybe (isJust) import "base" Data.Monoid (Sum(..)) import "network-uri" Network.URI (URI, parseURI) @@ -17,8 +17,8 @@ import qualified "pipes" Pipes.Prelude as Pipes (fold) parse :: Monad m => Pipe String URI m () parse = forever $ parseURI <$> await >>= maybe (return ()) yield -check :: [RuleSet] -> Pipe URI Bool IO () -check rs = forever $ await >>= yield . isJust . rewriteURL rs +check :: Pipe URI Bool IO () +check = forever $ await >>= yield . isJust . rewriteURL fold :: Monad m => Fold a b -> Producer a m () -> m b fold (Fold step begin done) = Pipes.fold step begin done @@ -27,6 +27,4 @@ proportion :: Fold Bool (Int, Int) proportion = (,) <$> Foldl.foldMap (Sum . bool 0 1) getSum <*> Foldl.length main :: IO () -main = do - rulesets <- getRulesets - fold proportion (stdinLn >-> parse >-> check rulesets) >>= print +main = fold proportion (stdinLn >-> parse >-> check) >>= print diff --git a/examples/RedirectProxy.hs b/examples/RedirectProxy.hs index f4ba4fa..8cb3785 100644 --- a/examples/RedirectProxy.hs +++ b/examples/RedirectProxy.hs @@ -7,22 +7,26 @@ module Main (main) where import "base" Data.Maybe (maybe) import "base" Data.Monoid ((<>)) import "bytestring" Data.ByteString.Char8 (pack, unpack) -import "http-proxy" Network.HTTP.Proxy (runProxySettings, defaultProxySettings, Settings(..), Request(..)) +import "http-proxy" Network.HTTP.Proxy + (runProxySettings, defaultProxySettings, Settings(..), Request(..)) import "http-types" Network.HTTP.Types (status302) -import "https-everywhere-rules" Data.HTTPSEverywhere.Rules (getRulesets, rewriteURL, RuleSet) +import "https-everywhere-rules" Data.HTTPSEverywhere.Rules (rewriteURL) import "network-uri" Network.URI (URI, parseURI) import "wai" Network.Wai (Response, responseLBS) httpRedirect :: URI -> Response -httpRedirect to = responseLBS status302 [("Location", pack . show $ to)] "" +httpRedirect to = + responseLBS status302 [("Location", pack . show $ to)] "" -tryHTTPS :: [RuleSet] -> Request -> Either Response Request -tryHTTPS rs Request{..} = case parseURI . unpack $ requestPath <> queryString of - Just uri -> maybe (return Request{..}) (Left . httpRedirect) (rewriteURL rs uri) - Nothing -> return Request{..} +tryHTTPS :: Request -> Either Response Request +tryHTTPS Request{..} = + case parseURI . unpack $ requestPath <> queryString of + Just uri -> maybe + (return Request{..}) + (Left . httpRedirect) + (rewriteURL uri) + Nothing -> return Request{..} main :: IO () -main = do - rules <- getRulesets - runProxySettings $ defaultProxySettings - { proxyRequestModifier = return . tryHTTPS rules } +main = runProxySettings $ defaultProxySettings + { proxyRequestModifier = return . tryHTTPS } diff --git a/https-everywhere-rules.cabal b/https-everywhere-rules.cabal index 1416570..7e29cb1 100644 --- a/https-everywhere-rules.cabal +++ b/https-everywhere-rules.cabal @@ -624,7 +624,10 @@ library Data.HTTPSEverywhere.Rules.Internal, Data.HTTPSEverywhere.Rules.Internal.Parser, Data.HTTPSEverywhere.Rules.Internal.Raw, + Data.HTTPSEverywhere.Rules.Internal.Trie, + Data.HTTPSEverywhere.Rules.Internal.Trie.Supercompilation, Data.HTTPSEverywhere.Rules.Internal.Types, + Data.HTTPSEverywhere.Rules.Internal.Types.Serialisable, Data.ByteString.RadixTrie, Data.Text.RadixTrie, Data.Text.ICU.Extras, @@ -632,6 +635,7 @@ library build-depends: base, attoparsec, + bytestring, directory, errors, filepath, @@ -641,8 +645,9 @@ library network, network-uri, pipes, - string-conversions, taggy-lens, + template-haskell, + th-lift-instances, text, text-icu, vector diff --git a/src/Data/ByteString/RadixTrie.hs b/src/Data/ByteString/RadixTrie.hs index db8a792..79d034b 100644 --- a/src/Data/ByteString/RadixTrie.hs +++ b/src/Data/ByteString/RadixTrie.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveLift #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} @@ -21,19 +22,21 @@ import Prelude hiding import Data.ByteString (ByteString, uncons, isPrefixOf, null, drop, length, head, tail, take, length, last, append, cons) +import Data.Maybe (fromMaybe, isJust, maybeToList) import Data.Vector (Vector, (!), generate, modify, imap) import qualified Data.Vector as Vector (toList) import qualified Data.Vector.Mutable as Mutable (modify) -import Data.Maybe (fromMaybe, isJust, maybeToList) +import Language.Haskell.TH.Syntax (Lift) +import Instances.TH.Lift () data Leaf a = Prefix ByteString (RadixTrie a) | Split (Vector {- 2 ^ 8 -} (Maybe (RadixTrie a))) | - Vacuum deriving (Show, Functor) + Vacuum deriving (Lift, Show, Functor) data RadixTrie a = RadixTrie { label :: Maybe a, children :: Leaf a } - deriving (Show, Functor) + deriving (Lift, Show, Functor) empty :: RadixTrie a empty = RadixTrie Nothing Vacuum diff --git a/src/Data/HTTPSEverywhere/Rules.hs b/src/Data/HTTPSEverywhere/Rules.hs index 9c1ec2e..02f7b11 100644 --- a/src/Data/HTTPSEverywhere/Rules.hs +++ b/src/Data/HTTPSEverywhere/Rules.hs @@ -1,28 +1,22 @@ module Data.HTTPSEverywhere.Rules ( - RuleSet, - getRulesets, + RuleTrie, rewriteURL, rewriteCookie ) where -import Prelude hiding (null, head) -import Data.Bool (bool) -import Network.HTTP.Client (Cookie) import Network.URI (URI) -import Pipes ((>->)) -import Pipes.Prelude (head, null) -import Control.Monad.Identity (Identity(runIdentity)) -import Data.HTTPSEverywhere.Rules.Internal (getRulesets, getRulesetsMatching, havingRulesThatTrigger, havingCookieRulesThatTrigger, setSecureFlag, RuleSet) +import Data.Monoid (First(..), Any(..)) +import Data.Bool (bool) +import Network.HTTP.Client (Cookie(..)) -rewriteURL' :: Monad m => [RuleSet] -> URI -> m (Maybe URI) -rewriteURL' rs url = head $ getRulesetsMatching rs url >-> havingRulesThatTrigger url +import Data.HTTPSEverywhere.Rules.Internal -rewriteURL :: [RuleSet] -> (URI -> Maybe URI) -rewriteURL = fmap runIdentity <$> rewriteURL' +rewriteURL :: URI -> Maybe URI +rewriteURL uri = getFirst . mconcat $ + map (First . havingRulesThatTrigger uri) (getRulesetsMatching uri) -rewriteCookie' :: Monad m => [RuleSet] -> URI -> Cookie -> m (Maybe Cookie) -rewriteCookie' rs url cookie = Just (setSecureFlag cookie) `bool` Nothing <$> null producer - where producer = getRulesetsMatching rs url >-> havingCookieRulesThatTrigger cookie - -rewriteCookie :: [RuleSet] -> URI -> (Cookie -> Maybe Cookie) -rewriteCookie = fmap (fmap runIdentity) <$> rewriteCookie' +rewriteCookie :: URI -> (Cookie -> Maybe Cookie) +rewriteCookie uri cookie = + bool Nothing (Just $ setSecureFlag cookie) . getAny . mconcat $ + map (Any . havingCookieRulesThatTrigger cookie) + (getRulesetsMatching uri) diff --git a/src/Data/HTTPSEverywhere/Rules/Internal.hs b/src/Data/HTTPSEverywhere/Rules/Internal.hs index f90b938..36af51a 100644 --- a/src/Data/HTTPSEverywhere/Rules/Internal.hs +++ b/src/Data/HTTPSEverywhere/Rules/Internal.hs @@ -1,70 +1,49 @@ -{-# LANGUAGE CPP #-} - +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE RecordWildCards #-} + module Data.HTTPSEverywhere.Rules.Internal ( - getRulesets, + RuleTrie, getRulesetsMatching, havingRulesThatTrigger, havingCookieRulesThatTrigger, - setSecureFlag, - RuleSet, -#ifdef TEST - hasTargetMatching, - hasTriggeringRuleOn, - hasExclusionMatching -#endif + setSecureFlag ) where -import Prelude hiding (readFile, filter) -import Control.Applicative ((<*>), (<$>)) -import Control.Lens ((&)) -import Control.Monad ((<=<), join) -import Data.Bool (bool) -import Data.List (find) -import Data.Maybe (isJust) +import Control.Monad (MonadPlus(..)) +import Data.Text (pack) +import Data.Maybe (maybeToList) +import Data.Monoid (First(..)) import Network.HTTP.Client (Cookie(..)) -import Network.URI (URI) -import Pipes (Pipe, Producer, for, each, await, yield, lift, (>->)) -import Pipes.Prelude (filter, toListM) +import Network.URI (URI, uriAuthority, uriRegName) -import Data.HTTPSEverywhere.Rules.Internal.Parser (parseRuleSets) -import qualified Data.HTTPSEverywhere.Rules.Internal.Raw as Raw (getRule, getRules) -import Data.HTTPSEverywhere.Rules.Internal.Types (RuleSet(..), Target(..), Exclusion(..), Rule(..), CookieRule(..)) +import Data.HTTPSEverywhere.Rules.Internal.Trie (RuleTrie) +import qualified Data.HTTPSEverywhere.Rules.Internal.Trie as Trie +import Data.HTTPSEverywhere.Rules.Internal.Types + (RuleSet(..), getRule, getExclusion, getCookieRule) +import qualified Data.HTTPSEverywhere.Rules.Internal.Trie.Supercompilation + as Supercompilation (trie) -getRulesets' :: Producer RuleSet IO () -getRulesets' = lift Raw.getRules - >>= flip (for . each) (flip (for . each) yield <=< lift . (fmap parseRuleSets <$> Raw.getRule)) +trie :: RuleTrie +trie = $(Supercompilation.trie) -getRulesets :: IO [RuleSet] -getRulesets = toListM getRulesets' +unless :: MonadPlus m => Bool -> m a -> m a +unless True action = action +unless False _ = mzero -getRulesetsMatching :: Monad m => [RuleSet] -> URI -> Producer RuleSet m () -getRulesetsMatching rs url = each rs - >-> filter (flip hasTargetMatching url) - >-> filter (not . flip hasExclusionMatching url) +getRulesetsMatching :: URI -> [RuleSet] +getRulesetsMatching uri = do + let hostname = fmap (pack . uriRegName) (uriAuthority uri) + r@RuleSet{..} <- maybeToList hostname >>= Trie.lookup trie + unless (any (\e -> getExclusion e uri) ruleSetExclusions) $ + return r -havingRulesThatTrigger :: Monad m => URI -> Pipe RuleSet URI m () -havingRulesThatTrigger url = flip hasTriggeringRuleOn url <$> await - >>= maybe (havingRulesThatTrigger url) yield +havingRulesThatTrigger :: URI -> RuleSet -> Maybe URI +havingRulesThatTrigger uri RuleSet{..} = + getFirst . mconcat $ map (First . ($ uri) . getRule) ruleSetRules -havingCookieRulesThatTrigger :: Monad m => Cookie -> Pipe RuleSet Bool m () -havingCookieRulesThatTrigger cookie = flip hasTriggeringCookieRuleOn cookie <$> await - >>= bool (havingCookieRulesThatTrigger cookie) (yield True) - -hasTargetMatching :: RuleSet -> URI -> Bool -hasTargetMatching ruleset url = getTargets ruleset <*> [url] & or - where getTargets = fmap getTarget <$> ruleSetTargets - -hasExclusionMatching :: RuleSet -> URI -> Bool -hasExclusionMatching ruleset url = getExclusions ruleset <*> [url] & or - where getExclusions = fmap getExclusion <$> ruleSetExclusions - -hasTriggeringRuleOn :: RuleSet -> URI -> Maybe URI -- Nothing ~ False -hasTriggeringRuleOn ruleset url = getRules ruleset <*> [url] & find isJust & join - where getRules = fmap getRule <$> ruleSetRules - -hasTriggeringCookieRuleOn :: RuleSet -> Cookie -> Bool -hasTriggeringCookieRuleOn ruleset cookie = getCookieRules ruleset <*> [cookie] & or - where getCookieRules = fmap getCookieRule <$> ruleSetCookieRules +havingCookieRulesThatTrigger :: Cookie -> RuleSet -> Bool +havingCookieRulesThatTrigger cookie RuleSet{..} = + any (($ cookie) . getCookieRule) ruleSetCookieRules setSecureFlag :: Cookie -> Cookie setSecureFlag cookie = cookie { cookie_secure_only = True } diff --git a/src/Data/HTTPSEverywhere/Rules/Internal/Parser.hs b/src/Data/HTTPSEverywhere/Rules/Internal/Parser.hs index dc1c97b..f062bbe 100644 --- a/src/Data/HTTPSEverywhere/Rules/Internal/Parser.hs +++ b/src/Data/HTTPSEverywhere/Rules/Internal/Parser.hs @@ -1,73 +1,61 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} module Data.HTTPSEverywhere.Rules.Internal.Parser ( parseRuleSets, -#ifdef TEST - parseTarget -#endif + parseSerialisable ) where import Prelude hiding (take, drop) import Control.Applicative ((<$>)) import Control.Lens (toListOf, only, to, (^..), (^.), (&), (<&>), _Just) -import Control.Monad (join) -import Control.Monad.State (State, evalState, modify', gets) -import Data.Bifunctor (bimap) -import Data.Bool (bool) import Data.Maybe (catMaybes) -import Data.String.Conversions (cs) -import qualified Data.Text as Strict (Text) -import Data.Text (dropEnd, dropWhileEnd, drop, isSuffixOf, takeEnd, take) import qualified Data.Text.Lazy as Lazy (Text) -import Network.HTTP.Client (Cookie(..)) -import Network.URI (URI(uriAuthority), URIAuth(uriRegName), parseURI) import Text.Taggy.Lens (html, allNamed, attr, Element) -import Data.HTTPSEverywhere.Rules.Internal.Types (RuleSet(..), Target(..), Rule(..), Exclusion(..), CookieRule(..)) -import Data.Text.ICU.Extras (match, findAndReplace) +import Data.HTTPSEverywhere.Rules.Internal.Types + (RuleSet(..), fromSerialisable) +import qualified + Data.HTTPSEverywhere.Rules.Internal.Types.Serialisable as Serialisable + +parseRule :: Element -> Maybe Serialisable.Rule +parseRule element = Serialisable.Rule + <$> element ^. attr "from" + <*> element ^. attr "to" + +parseCookieRule :: Element -> Maybe Serialisable.CookieRule +parseCookieRule element = Serialisable.CookieRule + <$> element ^. attr "host" + <*> element ^. attr "name" + +parseSerialisable' :: Element -> Maybe Serialisable.RuleSet +parseSerialisable' txt = txt ^. attr "name" <&> \ruleSetName -> do + let + ruleSetTargets = txt ^.. allNamed (only "target") + . attr "host" + . _Just + . to Serialisable.Target + ruleSetRules = txt ^.. allNamed (only "rule") + . to parseRule + & catMaybes + ruleSetExclusions = txt ^.. allNamed (only "exclusion") + . attr "pattern" + . _Just + . to Serialisable.Exclusion + ruleSetCookieRules = txt ^.. allNamed (only "securecookie") + . to parseCookieRule + & catMaybes + Serialisable.RuleSet + ruleSetName + ruleSetTargets + ruleSetRules + ruleSetExclusions + ruleSetCookieRules + +parseSerialisable :: Lazy.Text -> [Serialisable.RuleSet] +parseSerialisable = fmap catMaybes `fmap` toListOf $ + html . allNamed (only "ruleset") . to parseSerialisable' parseRuleSets :: Lazy.Text -> [RuleSet] -parseRuleSets = fmap catMaybes <$> toListOf $ html . allNamed (only "ruleset") . to parseRuleSet +parseRuleSets = fmap fromSerialisable . parseSerialisable -parseRuleSet :: Element -> Maybe RuleSet -parseRuleSet xml = xml ^. attr "name" <&> \ruleSetName -> do - let ruleSetTargets = xml ^.. allNamed (only "target") . attr "host" . _Just . to parseTarget - ruleSetRules = xml ^.. allNamed (only "rule") . to parseRule & catMaybes - ruleSetExclusions = xml ^.. allNamed (only "exclusion") . attr "pattern" . _Just . to parseExclusion & catMaybes - ruleSetCookieRules = xml ^.. allNamed (only "securecookie") . to parseCookieRule & catMaybes - RuleSet ruleSetName ruleSetTargets ruleSetRules ruleSetExclusions ruleSetCookieRules - -parseTarget' :: State (Strict.Text, Strict.Text) Bool -parseTarget' = do - gets ((== ".*") . takeEnd 2 . fst) >>= bool (return ()) - (modify' (bimap (dropEnd 2) (dropEnd 1 . dropWhileEnd (/= '.')))) - gets (take 2 . fst) >>= \case - "*." -> do - suffix <- gets (drop 1 . fst) -- Don't drop the dot, we expect some prefix. - isSuffixOf suffix <$> gets snd - _ -> gets (uncurry (==)) - -parseTarget :: Strict.Text -> Target -parseTarget target = Target $ \uri -> do - case uriRegName <$> uriAuthority uri of - Just domain -> evalState parseTarget' (target, cs domain) - Nothing -> False - -parseRule :: Element -> Maybe Rule -parseRule element = do - pattern <- element ^. attr "from" - replacement <- element ^. attr "to" - substitute <- findAndReplace pattern replacement - return . Rule $ join . fmap (parseURI . cs) . substitute . cs . show - -parseExclusion :: Strict.Text -> Maybe Exclusion -parseExclusion = fmap (Exclusion . (. cs . show)) <$> match - -parseCookieRule :: Element -> Maybe CookieRule -parseCookieRule element = CookieRule <$> do - hostMatches <- element ^. attr "host" . to (>>= match) - nameMatches <- element ^. attr "name" . to (>>= match) - return $ \Cookie{..} -> nameMatches (cs cookie_name) && hostMatches (cs cookie_domain) diff --git a/src/Data/HTTPSEverywhere/Rules/Internal/Trie.hs b/src/Data/HTTPSEverywhere/Rules/Internal/Trie.hs new file mode 100644 index 0000000..c1823e5 --- /dev/null +++ b/src/Data/HTTPSEverywhere/Rules/Internal/Trie.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveLift #-} + +module Data.HTTPSEverywhere.Rules.Internal.Trie ( + RuleTrie, + RuleSet, + empty, + insert, + lookup, + enumerate +) where + +import Prelude hiding (lookup, null) +import Data.Maybe (fromMaybe, maybeToList) +import Data.Text (Text, null, split, snoc, append) +import Language.Haskell.TH.Syntax (Lift) + +import Data.Text.RadixTrie (RadixTrie) +import qualified Data.Text.RadixTrie as RadixTrie +import qualified + Data.HTTPSEverywhere.Rules.Internal.Types as Types + +data Trie a = Trie + { rule :: Maybe a -- set if terminal + , wildcard :: Maybe a + , children :: RadixTrie (Trie a) + } deriving (Show, Functor, Lift) + +data RuleSet a = RuleSet { wild :: Trie a, tame :: Trie a } + deriving (Show, Functor, Lift) + +type RuleTrie = RuleSet Types.RuleSet + +snoc' :: Text -> Char -> Text +snoc' txt c = if null txt then txt else snoc txt c + +enumerate' :: Trie a -> [(Text, a)] +enumerate' (Trie r w c) = + maybe [] (\x -> [("", x)]) r ++ + maybe [] (\x -> [("*", x)]) w ++ + concatMap (\(x, y) -> map (\(a, b) -> (append (snoc' a '.') x, b)) (enumerate' y)) (RadixTrie.enumerate c) + +enumerate :: RuleSet a -> [(Text, a)] +enumerate (RuleSet wild tame) = + (map (\(x, y) -> (append x ".*", y)) (enumerate' wild)) ++ + enumerate' tame + +emptyTrie :: Trie a +emptyTrie = Trie Nothing Nothing RadixTrie.empty + +empty :: RuleSet a +empty = RuleSet emptyTrie emptyTrie + +isDot :: Char -> Bool +isDot = (== '.') + +insert' :: ([Text], a) -> (Trie a -> Trie a) +insert' ([], a) trie = trie { rule = return a } +insert' (t : ts, a) trie + | t == "*" = trie { wildcard = return a } + | otherwise = trie { children = + RadixTrie.insert t + (insert' (ts, a) + (RadixTrie.lookupDefault emptyTrie + t (children trie))) + (children trie) } + +insert :: (Text, a) -> (RuleSet a -> RuleSet a) +insert (s, a) rs = + let parts@(_:_) = reverse (split isDot s) in + if head parts == "*" + then rs { wild = insert' (tail parts, a) (wild rs) } + else rs { tame = insert' (parts, a) (tame rs) } + +lookup' :: Trie a -> ([Text] -> [a]) +lookup' (Trie rule _ _) [] = maybeToList rule +lookup' (Trie _ wild children) (sub : subsub) = + fromMaybe [] (fmap (flip lookup' subsub) + (sub `RadixTrie.lookup` children)) ++ + maybeToList wild + +lookup :: RuleSet a -> (Text -> [a]) +lookup RuleSet{..} host = + let parts@(_:_) = reverse (split isDot host) in + lookup' tame parts ++ lookup' wild (tail parts) diff --git a/src/Data/HTTPSEverywhere/Rules/Internal/Trie/Supercompilation.hs b/src/Data/HTTPSEverywhere/Rules/Internal/Trie/Supercompilation.hs new file mode 100644 index 0000000..fb7ed3a --- /dev/null +++ b/src/Data/HTTPSEverywhere/Rules/Internal/Trie/Supercompilation.hs @@ -0,0 +1,41 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Data.HTTPSEverywhere.Rules.Internal.Trie.Supercompilation ( + trie +) where + +import Control.Monad ((<=<)) +import Pipes (Producer, for, each, yield, lift) +import Pipes.Prelude (fold) +import Language.Haskell.TH + +import Data.HTTPSEverywhere.Rules.Internal.Parser (parseSerialisable) +import qualified Data.HTTPSEverywhere.Rules.Internal.Raw as Raw + (getRule, getRules) +import qualified + Data.HTTPSEverywhere.Rules.Internal.Types.Serialisable as Serialisable +import Data.HTTPSEverywhere.Rules.Internal.Trie (RuleSet, empty, insert) +import qualified + Data.HTTPSEverywhere.Rules.Internal.Types as Types + +getRulesets :: Producer Serialisable.RuleSet IO () +getRulesets = lift Raw.getRules >>= (flip (for . each) (flip (for . each) yield <=< lift . (fmap parseSerialisable `fmap` Raw.getRule))) + +getTrie :: IO (RuleSet Serialisable.RuleSet) +getTrie = fold + (\tree rule -> + foldr (.) id + (map + (\target -> insert (Serialisable.targetHost target, rule)) + (Serialisable.ruleSetTargets rule)) + tree) + empty + id + getRulesets + +-- getTrie :: IO RuleTrie +-- getTrie = fmap (fmap Types.fromSerialisable) getTrie' + +trie :: Q Exp {- :: RuleTrie -} +trie = runIO getTrie >>= \t -> + [| fmap Types.fromSerialisable t |] diff --git a/src/Data/HTTPSEverywhere/Rules/Internal/Types.hs b/src/Data/HTTPSEverywhere/Rules/Internal/Types.hs index d6a4e15..def3b16 100644 --- a/src/Data/HTTPSEverywhere/Rules/Internal/Types.hs +++ b/src/Data/HTTPSEverywhere/Rules/Internal/Types.hs @@ -1,14 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + module Data.HTTPSEverywhere.Rules.Internal.Types ( RuleSet(..), Target(..), Rule(..), Exclusion(..), - CookieRule(..) + CookieRule(..), + fromSerialisable ) where -import Data.Text (Text) -import Network.HTTP.Client (Cookie) -import Network.URI (URI) +import Prelude hiding (take, drop) +import Control.Monad (join) +import Control.Monad.State (State, evalState, modify', gets) +import Data.Bool (bool) +import Data.Bifunctor (bimap) +import Data.Maybe (catMaybes) +import Data.Text (Text, take, takeEnd, drop, dropEnd, dropWhileEnd, isSuffixOf, pack, unpack) +import Data.Text.Encoding (decodeUtf8) +import Network.HTTP.Client (Cookie(..)) +import Network.URI (URI, uriRegName, uriAuthority, parseURI) + +import qualified Data.HTTPSEverywhere.Rules.Internal.Types.Serialisable + as Serialisable +import Data.Text.ICU.Extras (match, findAndReplace) newtype Rule = Rule { getRule :: URI -> Maybe URI } newtype Target = Target { getTarget :: URI -> Bool } @@ -22,3 +39,48 @@ data RuleSet = RuleSet , ruleSetExclusions :: [Exclusion] , ruleSetCookieRules :: [CookieRule] } + +instance Show RuleSet where + show r = "" + +parseTarget' :: State (Text, Text) Bool +parseTarget' = do + gets ((== ".*") . takeEnd 2 . fst) >>= bool (return ()) + (modify' (bimap (dropEnd 2) (dropEnd 1 . dropWhileEnd (/= '.')))) + gets (take 2 . fst) >>= \case + "*." -> do + suffix <- gets (drop 1 . fst) -- Don't drop the dot, we expect + -- some prefix. + isSuffixOf suffix <$> gets snd + _ -> gets (uncurry (==)) + +parseTarget :: Text -> Target +parseTarget target = Target $ \uri -> do + case uriRegName <$> uriAuthority uri of + Just domain -> evalState parseTarget' (target, pack domain) + Nothing -> False + +parseExclusion :: Text -> Maybe Exclusion +parseExclusion = fmap (Exclusion . (. pack . show)) `fmap` match + +fromSerialisable :: Serialisable.RuleSet -> RuleSet +fromSerialisable Serialisable.RuleSet{..} = RuleSet + { ruleSetName = ruleSetName + , ruleSetTargets = + map (parseTarget . Serialisable.targetHost) ruleSetTargets + , ruleSetRules = catMaybes . flip map ruleSetRules $ + \Serialisable.Rule{..} -> do + substitute <- findAndReplace ruleFrom ruleTo + return . Rule $ + join . fmap (parseURI . unpack) . substitute . pack . show + , ruleSetExclusions = catMaybes $ map + (parseExclusion . Serialisable.exclusionPattern) + ruleSetExclusions + , ruleSetCookieRules = catMaybes . flip map ruleSetCookieRules $ + \Serialisable.CookieRule{..} -> do + hostMatches <- match cookieRuleHost + nameMatches <- match cookieRuleName + return . CookieRule $ \Cookie{..} -> + nameMatches (decodeUtf8 cookie_name) && + hostMatches (decodeUtf8 cookie_domain) + } diff --git a/src/Data/HTTPSEverywhere/Rules/Internal/Types/Serialisable.hs b/src/Data/HTTPSEverywhere/Rules/Internal/Types/Serialisable.hs new file mode 100644 index 0000000..df9ae7b --- /dev/null +++ b/src/Data/HTTPSEverywhere/Rules/Internal/Types/Serialisable.hs @@ -0,0 +1,30 @@ +{-# Language DeriveLift #-} + +module Data.HTTPSEverywhere.Rules.Internal.Types.Serialisable +where + +import Data.Text (Text) +import Language.Haskell.TH.Syntax (Lift) +import Instances.TH.Lift () + +data Rule = Rule { ruleFrom :: Text, ruleTo :: Text } + deriving (Show, Lift) + +data Target = Target { targetHost :: Text } + deriving (Show, Lift) + +data Exclusion = Exclusion { exclusionPattern :: Text } + deriving (Show, Lift) + +data CookieRule = CookieRule + { cookieRuleHost :: Text + , cookieRuleName :: Text + } deriving (Show, Lift) + +data RuleSet = RuleSet + { ruleSetName :: Text + , ruleSetTargets :: [Target] + , ruleSetRules :: [Rule] + , ruleSetExclusions :: [Exclusion] + , ruleSetCookieRules :: [CookieRule] + } deriving (Show, Lift)