Use more structured URI representation; targets match only hosts.

This resolves #2.

https-everywhere-rules.cabal

@@ -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,

src/Data/HTTPSEverywhere/Rules.hs

@@ -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)

src/Data/HTTPSEverywhere/Rules/Internal.hs

@@ -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
 

src/Data/HTTPSEverywhere/Rules/Internal/Parser.hs

@@ -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
+parseTarget = Target . checkRegName . fromJust . match . fromWildcard . replace "." "\\."
-  where fromWildcard str = if
+  where fromWildcard str
-          | head str == '*' -> prepend ".*" $ tail str
+          | head str == '*' = flip append ".*" $ tail str
-          | last str == '*' -> append  ".*" $ init str
+          | last str == '*' = append ".*" $ init str
-          | otherwise       -> str
+          | otherwise       = str
-        escapeInput = replace "." "\\."
+        checkRegName predicate = fromMaybe False . (predicate <$$> getRegName)
-        prepend = flip append
+        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

src/Data/HTTPSEverywhere/Rules/Internal/Types.hs

@@ -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 Rule       = Rule       { getRule :: URI -> Maybe URI     }
-newtype Target     = Target     { getTarget :: Text -> Bool       }
+newtype Target     = Target     { getTarget :: URI  -> Bool       }
-newtype Exclusion  = Exclusion  { getExclusion :: Text -> Bool    }
+newtype Exclusion  = Exclusion  { getExclusion :: URI -> Bool     }
 newtype CookieRule = CookieRule { getCookieRule :: Cookie -> Bool }
 
 data RuleSet = RuleSet

test/Data/HTTPSEverywhere/Rules/Internal/ParserSpec.hs

@@ -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