Supercompiled rule tries.
parent
0bbc68493f
commit
83c4cf1227
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -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 |]
|
||||
|
|
@ -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 = "<RuleSet " ++ unpack (ruleSetName 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)
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
Loading…
Reference in New Issue