Compare commits
4 Commits
Author | SHA1 | Date |
---|---|---|
vi | 83c4cf1227 | |
vi | 0bbc68493f | |
vi | 0ec419feca | |
vi | b93ff6bbb6 |
|
@ -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 }
|
||||
|
|
|
@ -13,7 +13,7 @@ license-file:
|
|||
author:
|
||||
vi
|
||||
maintainer:
|
||||
vi@zalora.com
|
||||
vi@computational.law
|
||||
category:
|
||||
Data
|
||||
build-type:
|
||||
|
@ -624,26 +624,33 @@ 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,
|
||||
Paths_https_everywhere_rules
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.10,
|
||||
attoparsec >= 0.12 && < 0.14,
|
||||
directory >= 1.2 && < 1.4,
|
||||
errors >= 1.4 && < 2.2,
|
||||
filepath >= 1.3 && < 1.5,
|
||||
functor-infix >= 0.0 && < 0.1,
|
||||
http-client >= 0.3 && < 0.6,
|
||||
lens >= 4.3 && < 4.16,
|
||||
mtl >= 2.2 && < 2.3,
|
||||
network >= 2.6 && < 2.7,
|
||||
network-uri >= 2.6 && < 2.7,
|
||||
pipes >= 4.1 && < 4.4,
|
||||
string-conversions >= 0.3 && < 0.5,
|
||||
taggy-lens >= 0.1 && < 0.2,
|
||||
text >= 1.1 && < 1.3,
|
||||
text-icu >= 0.6 && < 0.8
|
||||
base,
|
||||
attoparsec,
|
||||
bytestring,
|
||||
directory,
|
||||
errors,
|
||||
filepath,
|
||||
http-client,
|
||||
lens,
|
||||
mtl,
|
||||
network,
|
||||
network-uri,
|
||||
pipes,
|
||||
taggy-lens,
|
||||
template-haskell,
|
||||
th-lift-instances,
|
||||
text,
|
||||
text-icu,
|
||||
vector
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-language:
|
||||
|
@ -655,24 +662,13 @@ test-suite spec
|
|||
type:
|
||||
exitcode-stdio-1.0
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.10,
|
||||
attoparsec >= 0.12 && < 0.14,
|
||||
directory >= 1.2 && < 1.4,
|
||||
errors >= 1.4 && < 2.2,
|
||||
filepath >= 1.3 && < 1.5,
|
||||
functor-infix >= 0.0 && < 0.1,
|
||||
hspec >= 2.0 && < 2.5,
|
||||
http-client >= 0.3 && < 0.6,
|
||||
lens >= 4.3 && < 4.16,
|
||||
mtl >= 2.2 && < 2.3,
|
||||
network >= 2.6 && < 2.7,
|
||||
network-uri >= 2.6 && < 2.7,
|
||||
pipes >= 4.1 && < 4.4,
|
||||
string-conversions >= 0.3 && < 0.5,
|
||||
taggy-lens >= 0.1 && < 0.2,
|
||||
text >= 1.1 && < 1.3,
|
||||
text-icu >= 0.6 && < 0.8,
|
||||
https-everywhere-rules
|
||||
base,
|
||||
attoparsec,
|
||||
directory,
|
||||
errors,
|
||||
hspec,
|
||||
text,
|
||||
text-icu
|
||||
main-is:
|
||||
Spec.hs
|
||||
hs-source-dirs:
|
||||
|
@ -685,12 +681,6 @@ test-suite spec
|
|||
ghc-options:
|
||||
-Wall
|
||||
other-modules:
|
||||
Data.HTTPSEverywhere.Rules.Internal,
|
||||
Data.HTTPSEverywhere.Rules.Internal.Parser,
|
||||
Data.HTTPSEverywhere.Rules.Internal.ParserSpec,
|
||||
Data.HTTPSEverywhere.Rules.Internal.Raw,
|
||||
Data.HTTPSEverywhere.Rules.Internal.Types,
|
||||
Data.HTTPSEverywhere.Rules.InternalSpec,
|
||||
Data.Text.ICU.Extras,
|
||||
Data.Text.ICU.ExtrasSpec
|
||||
|
||||
|
@ -709,7 +699,7 @@ executable redirect-proxy
|
|||
RedirectProxy.hs
|
||||
if flag(build-examples)
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.10,
|
||||
base,
|
||||
bytestring,
|
||||
http-proxy,
|
||||
http-types,
|
||||
|
|
|
@ -0,0 +1,146 @@
|
|||
{-# LANGUAGE DeriveFunctor #-}
|
||||
{-# LANGUAGE DeriveLift #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}
|
||||
|
||||
module Data.ByteString.RadixTrie (
|
||||
RadixTrie,
|
||||
empty,
|
||||
lookup,
|
||||
lookupDefault,
|
||||
elem,
|
||||
enumerate,
|
||||
singleton,
|
||||
insert,
|
||||
) where
|
||||
|
||||
import Prelude hiding
|
||||
(null, lookup, drop, length, head, tail, take, length, last, elem)
|
||||
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 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 (Lift, Show, Functor)
|
||||
|
||||
data RadixTrie a =
|
||||
RadixTrie { label :: Maybe a, children :: Leaf a }
|
||||
deriving (Lift, Show, Functor)
|
||||
|
||||
empty :: RadixTrie a
|
||||
empty = RadixTrie Nothing Vacuum
|
||||
|
||||
lookup :: ByteString -> (RadixTrie a -> Maybe a)
|
||||
lookup str RadixTrie{..}
|
||||
| null str = label
|
||||
| otherwise = case children of
|
||||
Prefix prefix child ->
|
||||
if prefix `isPrefixOf` str
|
||||
then drop (length prefix) str `lookup` child
|
||||
else Nothing
|
||||
Split vector -> do
|
||||
(c, cs) <- uncons str
|
||||
trie <- vector ! fromIntegral c
|
||||
lookup cs trie
|
||||
Vacuum -> Nothing
|
||||
|
||||
lookupDefault :: a -> ByteString -> (RadixTrie a -> a)
|
||||
lookupDefault def = fmap (fmap (fromMaybe def)) lookup
|
||||
|
||||
elem :: ByteString -> (RadixTrie a -> Bool)
|
||||
elem = fmap (fmap isJust) lookup
|
||||
|
||||
enumerate :: RadixTrie a -> [(ByteString, a)]
|
||||
enumerate (RadixTrie label (Prefix prefix trie)) =
|
||||
maybe [] (\x -> [("", x)]) label ++
|
||||
map (\(x, y) -> (prefix `append` x, y)) (enumerate trie)
|
||||
enumerate (RadixTrie label (Split vector)) =
|
||||
maybe [] (\x -> [("", x)]) label ++
|
||||
concat (Vector.toList
|
||||
(imap (\i t -> maybe []
|
||||
(map (\(x, y) ->
|
||||
(cons (fromIntegral i) x, y)) . enumerate) t)
|
||||
vector))
|
||||
enumerate (RadixTrie a Vacuum) = map ("",) (maybeToList a)
|
||||
|
||||
(?=) :: Eq a => a -> a -> Maybe ()
|
||||
m ?= n = if m == n then return () else Nothing
|
||||
|
||||
singleton' :: ByteString -> (RadixTrie a -> RadixTrie a)
|
||||
singleton' str end
|
||||
| null str = end
|
||||
| length str == 1 = empty { children =
|
||||
Split . generate (2 ^ (8 :: Int)) $ \i -> do
|
||||
_ <- fromIntegral i ?= head str
|
||||
return end }
|
||||
| otherwise = empty { children = Prefix str end }
|
||||
|
||||
singleton :: ByteString -> a -> RadixTrie a
|
||||
singleton str value = singleton' str (empty { label = return value })
|
||||
|
||||
data PrefixResult =
|
||||
Equal |
|
||||
Disjoint |
|
||||
Extends ByteString |
|
||||
Prefixes ByteString
|
||||
|
||||
prefixResult :: ByteString -> ByteString -> PrefixResult
|
||||
prefixResult source target =
|
||||
case (source `isPrefixOf` target, target `isPrefixOf` source) of
|
||||
(True, True) -> Equal
|
||||
(False, False) -> Disjoint
|
||||
(True, False) -> Extends $ drop (length source) target
|
||||
(False, True) -> Prefixes $ drop (length target) source
|
||||
|
||||
update :: Int -> (Maybe a -> a) -> (Vector (Maybe a) -> Vector (Maybe a))
|
||||
update n f v = modify (\v' -> Mutable.modify v' (Just . f) n) v
|
||||
|
||||
insert :: ByteString -> a -> (RadixTrie a -> RadixTrie a)
|
||||
insert (uncons -> Just (fromIntegral -> c, cs)) val
|
||||
r@(RadixTrie _ (Split split)) = r { children = Split $
|
||||
update c (maybe (singleton cs val) (insert cs val)) split }
|
||||
insert _ val r@(RadixTrie _ (Split _)) = r { label = return val }
|
||||
insert text val r@(RadixTrie label (Prefix prefix trie)) =
|
||||
case prefixResult prefix text of
|
||||
Equal -> r { children = Prefix text trie }
|
||||
Extends e -> r { children = Prefix prefix $ insert e val trie }
|
||||
Disjoint ->
|
||||
r { children = Split . generate (2 ^ (8 :: Int)) $ \i ->
|
||||
if i == fromIntegral (head text)
|
||||
then return $ singleton (tail text) val
|
||||
else if i == fromIntegral (head prefix)
|
||||
then return $ singleton' (tail prefix) trie
|
||||
else Nothing }
|
||||
Prefixes p -> case length text of
|
||||
0 -> r { label = return val }
|
||||
1 -> r { children = Split . generate (2 ^ (8 :: Int)) $ \i ->
|
||||
if i == fromIntegral (head text) then
|
||||
return $ singleton (tail text) val
|
||||
else if i == fromIntegral (head prefix) then
|
||||
return $ singleton' (tail prefix) trie
|
||||
else Nothing }
|
||||
_ -> RadixTrie label . Prefix (take (length text) prefix) $
|
||||
case length prefix - length text of
|
||||
0 -> error "The impossible happened!"
|
||||
1 -> RadixTrie (Just val)
|
||||
(Split . generate (2 ^ (8 :: Int)) $ \i ->
|
||||
fmap (const trie) (i ?= fromIntegral (last prefix)))
|
||||
_ -> RadixTrie (Just val) (Prefix p trie)
|
||||
insert text val (RadixTrie value Vacuum) =
|
||||
(singleton' text (empty { label = return val })) { label = value }
|
||||
|
||||
example :: RadixTrie ByteString
|
||||
example = foldr (.) id insertions empty where
|
||||
insertions =
|
||||
map (\x -> insert x x) ["test", "slow", "slower", "water"]
|
|
@ -1,29 +1,22 @@
|
|||
module Data.HTTPSEverywhere.Rules (
|
||||
RuleSet,
|
||||
getRulesets,
|
||||
RuleTrie,
|
||||
rewriteURL,
|
||||
rewriteCookie
|
||||
) where
|
||||
|
||||
import Prelude hiding (null, head)
|
||||
import Data.Bool (bool)
|
||||
import Data.Functor.Infix ((<$$>), (<$$$>))
|
||||
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 = 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 = runIdentity <$$$> rewriteCookie'
|
||||
rewriteCookie :: URI -> (Cookie -> Maybe Cookie)
|
||||
rewriteCookie uri cookie =
|
||||
bool Nothing (Just $ setSecureFlag cookie) . getAny . mconcat $
|
||||
map (Any . havingCookieRulesThatTrigger cookie)
|
||||
(getRulesetsMatching uri)
|
||||
|
|
|
@ -1,71 +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.Functor.Infix ((<$$>))
|
||||
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 . (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 = getTarget <$$> ruleSetTargets
|
||||
|
||||
hasExclusionMatching :: RuleSet -> URI -> Bool
|
||||
hasExclusionMatching ruleset url = getExclusions ruleset <*> [url] & or
|
||||
where getExclusions = getExclusion <$$> ruleSetExclusions
|
||||
|
||||
hasTriggeringRuleOn :: RuleSet -> URI -> Maybe URI -- Nothing ~ False
|
||||
hasTriggeringRuleOn ruleset url = getRules ruleset <*> [url] & find isJust & join
|
||||
where getRules = getRule <$$> ruleSetRules
|
||||
|
||||
hasTriggeringCookieRuleOn :: RuleSet -> Cookie -> Bool
|
||||
hasTriggeringCookieRuleOn ruleset cookie = getCookieRules ruleset <*> [cookie] & or
|
||||
where getCookieRules = getCookieRule <$$> ruleSetCookieRules
|
||||
havingCookieRulesThatTrigger :: Cookie -> RuleSet -> Bool
|
||||
havingCookieRulesThatTrigger cookie RuleSet{..} =
|
||||
any (($ cookie) . getCookieRule) ruleSetCookieRules
|
||||
|
||||
setSecureFlag :: Cookie -> Cookie
|
||||
setSecureFlag cookie = cookie { cookie_secure_only = True }
|
||||
|
|
|
@ -1,74 +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.Functor.Infix ((<$$>))
|
||||
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 = 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 = 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)
|
||||
|
|
|
@ -4,7 +4,6 @@ module Data.HTTPSEverywhere.Rules.Internal.Raw (
|
|||
) where
|
||||
|
||||
import Prelude hiding (readFile)
|
||||
import Data.Functor.Infix ((<$$>))
|
||||
import Data.Text.Lazy (Text)
|
||||
import Data.Text.Lazy.IO (readFile)
|
||||
import System.Directory (getDirectoryContents)
|
||||
|
@ -16,8 +15,8 @@ getRule :: FilePath -> IO Text
|
|||
getRule = readFile
|
||||
|
||||
getRules :: IO [FilePath]
|
||||
getRules = getDataFileName [] >>= filter isXML <$$> getAbsoluteDirectoryContents
|
||||
getRules = getDataFileName [] >>= fmap (filter isXML) <$> getAbsoluteDirectoryContents
|
||||
where isXML = (== ".xml") . takeExtension
|
||||
|
||||
getAbsoluteDirectoryContents :: FilePath -> IO [FilePath]
|
||||
getAbsoluteDirectoryContents x = combine x <$$> getDirectoryContents x
|
||||
getAbsoluteDirectoryContents x = fmap (combine x) <$> getDirectoryContents x
|
||||
|
|
|
@ -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)
|
|
@ -17,7 +17,6 @@ import Control.Applicative ((<$>), (<*>), (*>), (<|>))
|
|||
import Control.Error (hush)
|
||||
import Data.Attoparsec.Text (Parser, char, digit, takeWhile1, string, many', parseOnly)
|
||||
import Data.Char (digitToInt)
|
||||
import Data.Functor.Infix ((<$$>), (<&>))
|
||||
import Data.Maybe (isJust)
|
||||
import Data.Monoid (Monoid(mappend, mconcat))
|
||||
import Data.Text (Text)
|
||||
|
@ -27,7 +26,7 @@ regex :: Text -> Maybe Regex
|
|||
regex = hush . regex' []
|
||||
|
||||
match :: Text -> Maybe (Text -> Bool)
|
||||
match = (isJust <$$> find) <$$> regex
|
||||
match = fmap (fmap isJust <$> find) <$> regex
|
||||
|
||||
findAndReplace :: Text -> Text -> Maybe (Text -> Maybe Text)
|
||||
findAndReplace pattern replacement = (.)
|
||||
|
@ -41,7 +40,7 @@ data Segment = Reference Int | Literal Text deriving (Show, Eq)
|
|||
-- JavaScript admits at most nine capture groups, so this is the correct
|
||||
-- (and likely intended) interpretation.
|
||||
parseReference :: Parser Segment
|
||||
parseReference = char '$' *> digit <&> Reference . digitToInt
|
||||
parseReference = (Reference . digitToInt) <$> (char '$' *> digit)
|
||||
|
||||
parseLiteral :: Parser Segment
|
||||
parseLiteral = Literal <$> takeWhile1 (/= '$')
|
||||
|
|
|
@ -0,0 +1,30 @@
|
|||
module Data.Text.RadixTrie (
|
||||
RadixTrie,
|
||||
empty,
|
||||
lookup,
|
||||
lookupDefault,
|
||||
elem,
|
||||
insert,
|
||||
enumerate
|
||||
) where
|
||||
|
||||
import Prelude hiding (lookup, elem)
|
||||
import Data.ByteString.RadixTrie (RadixTrie, empty)
|
||||
import qualified Data.ByteString.RadixTrie as RT
|
||||
import qualified Data.Text as Strict (Text)
|
||||
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
|
||||
|
||||
lookup :: Strict.Text -> (RadixTrie a -> Maybe a)
|
||||
lookup t r = RT.lookup (encodeUtf8 t) r
|
||||
|
||||
lookupDefault :: a -> Strict.Text -> (RadixTrie a -> a)
|
||||
lookupDefault x t r = RT.lookupDefault x (encodeUtf8 t) r
|
||||
|
||||
elem :: Strict.Text -> (RadixTrie a -> Bool)
|
||||
elem t r = RT.elem (encodeUtf8 t) r
|
||||
|
||||
insert :: Strict.Text -> a -> (RadixTrie a -> RadixTrie a)
|
||||
insert t x r = RT.insert (encodeUtf8 t) x r
|
||||
|
||||
enumerate :: RadixTrie a -> [(Strict.Text, a)]
|
||||
enumerate t = map (\(x, y) -> (decodeUtf8 x, y)) (RT.enumerate t)
|
|
@ -1,6 +1,8 @@
|
|||
packages:
|
||||
- .
|
||||
extra-deps:
|
||||
- functor-infix-0.0.5
|
||||
- http-proxy-0.1.0.5
|
||||
resolver: lts-8.24
|
||||
- taggy-0.2.1
|
||||
- taggy-lens-0.1.2
|
||||
- http-proxy-0.1.0.6
|
||||
resolver: lts-11.14
|
||||
allow-newer: true
|
||||
|
|
|
@ -1,72 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Data.HTTPSEverywhere.Rules.Internal.ParserSpec (
|
||||
spec
|
||||
) where
|
||||
|
||||
import Prelude hiding (unlines)
|
||||
import Data.HTTPSEverywhere.Rules.Internal.Parser (parseTarget, parseRuleSets)
|
||||
import Data.HTTPSEverywhere.Rules.Internal (hasTargetMatching, hasExclusionMatching, hasTriggeringRuleOn)
|
||||
import Data.HTTPSEverywhere.Rules.Internal.Types (Target(..), RuleSet(..))
|
||||
import Data.Maybe (fromJust, isJust)
|
||||
import Data.Text.Lazy (Text, unlines)
|
||||
import Network.URI (parseURI)
|
||||
import Test.Hspec (Spec, describe, it, shouldBe, shouldSatisfy)
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
let unsafeParseURL = fromJust . parseURI
|
||||
describe "parseTarget" $ do
|
||||
let checkTarget = \target domain -> ($ domain) . getTarget $ parseTarget target
|
||||
it "*.facebook.com should match s-static.ak.facebook.com" $ do
|
||||
let url = unsafeParseURL "http://s-static.ak.facebook.com"
|
||||
checkTarget "*.facebook.com" url `shouldBe` True
|
||||
it "google.* should match google.nl" $ do
|
||||
let url = unsafeParseURL "http://google.nl"
|
||||
checkTarget "google.*" url `shouldBe` True
|
||||
-- Right-side wildcards apply only one-level deep.
|
||||
it "google.* should not match google.com.id" $ do
|
||||
let url = unsafeParseURL "http://google.com.id"
|
||||
checkTarget "google.*" url `shouldBe` False
|
||||
-- Wildcards expect there exist some prefix.
|
||||
it "*.google.* should not match google.nl" $ do
|
||||
let url = unsafeParseURL "http://google.nl"
|
||||
checkTarget "*.google.*" url `shouldBe` False
|
||||
describe "parseRuleSets" $ do
|
||||
let rulesets = parseRuleSets fixture
|
||||
it "Should parse a ruleset out of the EFF fixture." $ do
|
||||
rulesets `shouldSatisfy` not . null
|
||||
let effRuleSet = head rulesets
|
||||
it "Should parse out the name of the EFF fixture." $ do
|
||||
ruleSetName effRuleSet `shouldBe` "EFF"
|
||||
it "Should parse out two targets from the EFF fixture." $ do
|
||||
length (ruleSetTargets effRuleSet) `shouldBe` 2
|
||||
it "Should parse out two rules from the EFF fixture." $ do
|
||||
length (ruleSetRules effRuleSet) `shouldBe` 2
|
||||
it "Should parse out one exclusion from the EFF fixture." $ do
|
||||
length (ruleSetExclusions effRuleSet) `shouldBe` 1
|
||||
it "A target in the EFF fixture should match eff.org" $ do
|
||||
let url = unsafeParseURL "http://eff.org/thing"
|
||||
effRuleSet `hasTargetMatching` url `shouldBe` True
|
||||
it "A rule in the EFF fixture should trigger on eff.org" $ do
|
||||
let url = unsafeParseURL "http://eff.org/thing"
|
||||
effRuleSet `hasTriggeringRuleOn` url `shouldSatisfy` isJust
|
||||
it "An exclusion in the EFF fixture should trigger on action.eff.org" $ do
|
||||
let url = unsafeParseURL "http://action.eff.org/thing"
|
||||
effRuleSet `hasExclusionMatching` url `shouldBe` True
|
||||
|
||||
fixture :: Text
|
||||
fixture = unlines $
|
||||
[ "<ruleset name=\"EFF\">"
|
||||
, " <target host=\"eff.org\" />"
|
||||
, " <target host=\"*.eff.org\" />"
|
||||
, ""
|
||||
, " <exclusion pattern=\"^http://action\\.eff\\.org/\"/>"
|
||||
, " <rule from=\"^http://eff\\.org/\" to=\"https://eff.org/\"/>"
|
||||
, " <rule from=\"^http://([^/:@]*)\\.eff\\.org/\" to=\"https://$1.eff.org/\"/>"
|
||||
, "</ruleset>"
|
||||
]
|
||||
|
||||
instance Show RuleSet where
|
||||
show _ = "<RuleSet>"
|
|
@ -1,63 +0,0 @@
|
|||
{-# LANGUAGE OverloadedStrings #-}
|
||||
|
||||
module Data.HTTPSEverywhere.Rules.InternalSpec (
|
||||
spec
|
||||
) where
|
||||
|
||||
import Prelude hiding (unlines)
|
||||
import Control.Monad (join)
|
||||
import Data.Functor ((<$>))
|
||||
import Data.HTTPSEverywhere.Rules.Internal (hasTargetMatching, hasTriggeringRuleOn, hasExclusionMatching)
|
||||
import Data.HTTPSEverywhere.Rules.Internal.Types (RuleSet(..), Target(..), Exclusion(..), Rule(..))
|
||||
import Data.Maybe (fromJust, catMaybes)
|
||||
import Data.Text (pack, unpack)
|
||||
import Data.Text.ICU.Extras (match, findAndReplace)
|
||||
import Network.URI (parseURI)
|
||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||
|
||||
spec :: Spec
|
||||
spec = do
|
||||
let unsafeParseURL = fromJust . parseURI
|
||||
describe "hasTargetMatching" $ do
|
||||
it "Should be True for matching targets." $ do
|
||||
let url = unsafeParseURL "http://eff.org/thing"
|
||||
fixture `hasTargetMatching` url `shouldBe` True
|
||||
it "Should be False for mis-matching targets." $ do
|
||||
let url = unsafeParseURL "http://gnu.org/thing"
|
||||
fixture `hasTargetMatching` url `shouldBe` False
|
||||
describe "hasTriggeringRuleOn" $ do
|
||||
it "Should be 'Just https://...' for matching rules." $ do
|
||||
let url = unsafeParseURL "http://eff.org/thing"
|
||||
fixture `hasTriggeringRuleOn` url `shouldBe` parseURI "https://eff.org/thing"
|
||||
it "Should be Nothing for mis-matching rules." $ do
|
||||
let url = unsafeParseURL "http://gnu.org/thing"
|
||||
fixture `hasTriggeringRuleOn` url `shouldBe` Nothing
|
||||
describe "hasExclusionMatching" $ do
|
||||
it "Should be True for matching targets." $ do
|
||||
let url = unsafeParseURL "http://action.eff.org/thing"
|
||||
fixture `hasExclusionMatching` url `shouldBe` True
|
||||
it "Should be False for mis-matching targets." $ do
|
||||
let url = unsafeParseURL "http://eff.org/thing"
|
||||
fixture `hasExclusionMatching` url `shouldBe` False
|
||||
|
||||
-- We avoid the parser here, for purposes of isolation:
|
||||
|
||||
fixture :: RuleSet
|
||||
fixture = RuleSet
|
||||
{ ruleSetName = "EFF"
|
||||
, ruleSetTargets = catMaybes
|
||||
[ Target . checkURI <$> match "eff\\.org"
|
||||
, Target . checkURI <$> match ".*\\.eff\\.org"
|
||||
]
|
||||
, ruleSetExclusions = catMaybes
|
||||
[ Exclusion . checkURI <$> match "^http://action\\.eff\\.org/"
|
||||
]
|
||||
, ruleSetRules = catMaybes
|
||||
[ Rule . changeURI <$> findAndReplace "^http://eff\\.org/" "https://eff.org/"
|
||||
, Rule . changeURI <$> findAndReplace "^http://([^/:@]*)\\.eff\\.org/" "https://$1.eff.org/"
|
||||
]
|
||||
, ruleSetCookieRules =
|
||||
[]
|
||||
}
|
||||
where checkURI = (. pack . show)
|
||||
changeURI f = join . fmap (parseURI . unpack) . checkURI f
|
|
@ -5,7 +5,6 @@
|
|||
module Data.Text.ICU.ExtrasSpec (spec) where
|
||||
|
||||
import Control.Applicative ((<$>))
|
||||
import Control.Lens ((&))
|
||||
import Data.Text (Text)
|
||||
import Data.Text.ICU.Extras (match, findAndReplace, Segment(..), parseReplacement)
|
||||
import Test.Hspec (Spec, describe, it, shouldBe)
|
||||
|
@ -16,8 +15,8 @@ spec = do
|
|||
it "Should be Nothing if provided an invalid regular expression." $ do
|
||||
match "(" `shouldBe` Nothing
|
||||
it "Should yield a match function if provided a regular expression." $ do
|
||||
("xa" &) <$> match "x" `shouldBe` Just True
|
||||
("xa" &) <$> match "y" `shouldBe` Just False
|
||||
($ "xa") <$> match "x" `shouldBe` Just True
|
||||
($ "xa") <$> match "y" `shouldBe` Just False
|
||||
describe "parseReplacement" $ do
|
||||
it "Should decompose a replacement string into a sequence [Segment]." $ do
|
||||
parseReplacement "foo$1bar$4$1" `shouldBe` Just [Literal "foo", Reference 1, Literal "bar", Reference 4, Reference 1]
|
||||
|
@ -28,9 +27,9 @@ spec = do
|
|||
parseReplacement "$10" `shouldBe` Just [Reference 1, Literal "0"]
|
||||
describe "findAndReplace" $ do
|
||||
it "Should find and replace based upon a regular expression and pattern." $ do
|
||||
("barqux" &) <$> findAndReplace "(bar)" "$1baz" `shouldBe` Just (Just "barbazqux")
|
||||
("barqux" &) <$> findAndReplace "(qux)" "baz$1" `shouldBe` Just (Just "barbazqux")
|
||||
("barqux" &) <$> findAndReplace "u" "uu" `shouldBe` Just (Just "barquux")
|
||||
($ "barqux") <$> findAndReplace "(bar)" "$1baz" `shouldBe` Just (Just "barbazqux")
|
||||
($ "barqux") <$> findAndReplace "(qux)" "baz$1" `shouldBe` Just (Just "barbazqux")
|
||||
($ "barqux") <$> findAndReplace "u" "uu" `shouldBe` Just (Just "barquux")
|
||||
|
||||
instance Show (Text -> Bool) where
|
||||
show _ = "Text -> Bool"
|
||||
|
|
Loading…
Reference in New Issue