https-everywhere-else
/
https-everywhere-rules
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Use more structured URI representation; targets match only hosts. 

This resolves #2.
master
vi 2014-08-11 03:32:49 +08:00
parent 2a409bfdc7
commit 49be7aa1a0
6 changed files with 39 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
https-everywhere-rules.cabal
View File

@ -38,6 +38,7 @@ library
functor-infix >= 0.0 && < 0.1,
http-client >= 0.3 && < 0.4,
lens >= 4.3 && < 4.4,
network >= 2.5 && < 2.6,
pipes >= 4.1 && < 4.2,
string-conversions >= 0.3 && < 0.4,
taggy-lens >= 0.1 && < 0.2,
@ -62,6 +63,7 @@ test-suite spec
hspec >= 1.10 && < 1.11,
http-client >= 0.3 && < 0.4,
lens >= 4.3 && < 4.4,
network >= 2.5 && < 2.6,
pipes >= 4.1 && < 4.2,
string-conversions >= 0.3 && < 0.4,
taggy-lens >= 0.1 && < 0.2,

6
src/Data/HTTPSEverywhere/Rules.hs
View File

@ -7,19 +7,19 @@ import Prelude hiding (take, null)
import Control.Applicative ((<$))
import Control.Lens ((<&>))
import Data.Bool (bool)
import Data.Text (Text)
import Network.HTTP.Client (Cookie)
import Network.URI (URI)
import Pipes (runEffect, (>->))
import Pipes.Prelude (take, null)
import Data.HTTPSEverywhere.Rules.Internal (getRulesetsMatching, havingRulesThatTrigger, havingCookieRulesThatTrigger, setSecureFlag)
rewriteURL :: Text -> IO (Maybe Text)
rewriteURL :: URI -> IO (Maybe URI)
rewriteURL url = runEffect
$ (Nothing <$ getRulesetsMatching url)
>-> (Nothing <$ havingRulesThatTrigger url)
>-> (Nothing <$ take 1)
rewriteCookie :: Text -> Cookie -> IO Cookie
rewriteCookie :: URI -> Cookie -> IO Cookie
rewriteCookie url cookie = null producer <&> setSecureFlag cookie `bool` cookie
where producer = getRulesetsMatching url >-> (() <$ havingCookieRulesThatTrigger cookie)

12
src/Data/HTTPSEverywhere/Rules/Internal.hs
View File

@ -14,8 +14,8 @@ import Data.Functor.Infix ((<$$>))
import Data.List (find)
import Data.Maybe (isJust)
import qualified Data.HTTPSEverywhere.Rules.Raw as Raw (getRule, getRules)
import Data.Text (Text)
import Network.HTTP.Client (Cookie(..))
import Network.URI (URI)
import Pipes (Producer, Consumer, for, each, await, yield, lift, (>->))
import Pipes.Prelude (filter)
@ -26,12 +26,12 @@ getRulesets :: Producer RuleSet IO ()
getRulesets = lift Raw.getRules
>>= flip (for . each) (flip (for . each) yield <=< lift . (parseRuleSets <$$> Raw.getRule))
getRulesetsMatching :: Text -> Producer RuleSet IO ()
getRulesetsMatching :: URI -> Producer RuleSet IO ()
getRulesetsMatching url = getRulesets
>-> filter (flip hasTargetMatching url)
>-> filter (not . flip hasExclusionMatching url)
havingRulesThatTrigger :: Text -> Consumer RuleSet IO (Maybe Text)
havingRulesThatTrigger :: URI -> Consumer RuleSet IO (Maybe URI)
havingRulesThatTrigger url = flip hasTriggeringRuleOn url <$> await
>>= maybe (havingRulesThatTrigger url) (return . Just)
@ -39,15 +39,15 @@ havingCookieRulesThatTrigger :: Cookie -> Consumer RuleSet IO Bool
havingCookieRulesThatTrigger cookie = flip hasTriggeringCookieRuleOn cookie <$> await
>>= bool (havingCookieRulesThatTrigger cookie) (return True)
hasTargetMatching :: RuleSet -> Text -> Bool
hasTargetMatching :: RuleSet -> URI -> Bool
hasTargetMatching ruleset url = getTargets ruleset <*> [url] & or
where getTargets = getTarget <$$> ruleSetTargets
hasExclusionMatching :: RuleSet -> Text -> Bool
hasExclusionMatching :: RuleSet -> URI -> Bool
hasExclusionMatching ruleset url = getExclusions ruleset <*> [url] & or & not
where getExclusions = getExclusion <$$> ruleSetExclusions
hasTriggeringRuleOn :: RuleSet -> Text -> Maybe Text -- Nothing ~ False
hasTriggeringRuleOn :: RuleSet -> URI -> Maybe URI -- Nothing ~ False
hasTriggeringRuleOn ruleset url = getRules ruleset <*> [url] & find isJust & join
where getRules = getRule <$$> ruleSetRules

24
src/Data/HTTPSEverywhere/Rules/Internal/Parser.hs
View File

@ -1,5 +1,4 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
@ -12,13 +11,15 @@ module Data.HTTPSEverywhere.Rules.Internal.Parser (
import Prelude hiding (head, last, tail, init)
import Control.Lens (toListOf, only, to, (^..), (^.), (&), (<&>), _Just)
import Control.Monad (join)
import Data.Functor.Infix ((<$>),(<$$>))
import Data.Maybe (catMaybes, fromJust)
import Data.Maybe (catMaybes, fromJust, fromMaybe)
import Data.String.Conversions (cs)
import qualified Data.Text as Strict (Text)
import Data.Text (append, head, last, tail, init, replace)
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(..))
@ -36,22 +37,23 @@ parseRuleSet xml = xml ^. attr "name" <&> \ruleSetName -> do
RuleSet ruleSetName ruleSetTargets ruleSetRules ruleSetExclusions ruleSetCookieRules
parseTarget :: Strict.Text -> Target
parseTarget = Target . fromJust . match . fromWildcard . escapeInput
where fromWildcard str = if
| head str == '*' -> prepend ".*" $ tail str
| last str == '*' -> append ".*" $ init str
| otherwise -> str
escapeInput = replace "." "\\."
prepend = flip append
parseTarget = Target . checkRegName . fromJust . match . fromWildcard . replace "." "\\."
where fromWildcard str
| head str == '*' = flip append ".*" $ tail str
| last str == '*' = append ".*" $ init str
| otherwise = str
checkRegName predicate = fromMaybe False . (predicate <$$> getRegName)
getRegName = cs . uriRegName <$$> uriAuthority
parseRule :: Element -> Maybe Rule
parseRule element = do
pattern <- element ^. attr "from"
replacement <- element ^. attr "to"
findAndReplace pattern replacement <&> Rule
substitute <- findAndReplace pattern replacement
return . Rule $ join . fmap (parseURI . cs) . substitute . cs . show
parseExclusion :: Strict.Text -> Maybe Exclusion
parseExclusion = Exclusion <$$> match
parseExclusion = Exclusion . (. cs . show) <$$> match
parseCookieRule :: Element -> Maybe CookieRule
parseCookieRule element = CookieRule <$> do

7
src/Data/HTTPSEverywhere/Rules/Internal/Types.hs
View File

@ -8,10 +8,11 @@ module Data.HTTPSEverywhere.Rules.Internal.Types (
import Data.Text (Text)
import Network.HTTP.Client (Cookie)
import Network.URI (URI)
newtype Rule = Rule { getRule :: Text -> Maybe Text }
newtype Target = Target { getTarget :: Text -> Bool }
newtype Exclusion = Exclusion { getExclusion :: Text -> Bool }
newtype Rule = Rule { getRule :: URI -> Maybe URI }
newtype Target = Target { getTarget :: URI -> Bool }
newtype Exclusion = Exclusion { getExclusion :: URI -> Bool }
newtype CookieRule = CookieRule { getCookieRule :: Cookie -> Bool }
data RuleSet = RuleSet

16
test/Data/HTTPSEverywhere/Rules/Internal/ParserSpec.hs
View File

@ -4,17 +4,23 @@ module Data.HTTPSEverywhere.Rules.Internal.ParserSpec (
spec
) where
import Data.HTTPSEverywhere.Rules.Internal.Types (Target(..))
import Data.HTTPSEverywhere.Rules.Internal.Parser (parseTarget)
import Data.HTTPSEverywhere.Rules.Internal.Types (Target(..))
import Data.Maybe (fromJust)
import Network.URI (parseURI)
import Test.Hspec (Spec, describe, it, shouldBe)
spec :: Spec
spec = do
describe "parseTarget" $ do
let parseTarget' = \target domain -> ($ domain) . getTarget $ parseTarget target
let checkTarget = \target domain -> ($ domain) . getTarget $ parseTarget target
unsafeParseURL = fromJust . parseURI
it "*.facebook.com should match s-static.ak.facebook.com" $ do
parseTarget' "*.facebook.com" "s-static.ak.facebook.com" `shouldBe` True
let url = unsafeParseURL "http://s-static.ak.facebook.com"
checkTarget "*.facebook.com" url `shouldBe` True
it "google.* should match google.com.id" $ do
parseTarget' "google.*" "google.com.id" `shouldBe` True
let url = unsafeParseURL "http://google.com.id"
checkTarget "google.*" url `shouldBe` True
it "*.google.* should not match google.com.id" $ do
parseTarget' "*.google.*" "google.com.id" `shouldBe` False
let url = unsafeParseURL "http://google.com.id"
checkTarget "*.google.*" url `shouldBe` False