An invitation, in anticipation of Yori's declamation.

README.md

@@ -1,16 +1,51 @@
-[https-everywhere-rules](https://github.com/fmap/https-everywhere-rules)
+https-everywhere-rules
-========================================================================
+======================
 
-Haskell package providing high-level access to [HTTPS Everywhere][1]
+Unencrypted HTTP requests leave users vulnerable to surveillance, content filtering, and in some cases content tampering. While the number of websites making encrypted connections available are steadily increasing, only a fraction of those send visitors to their HTTPS version by default. While efforts to encourage broader and safer adoption of HTTPS-as-default are praiseworthy, we hold that automatic client-local TLS upgrades are a worthwhile privacy measure for the forseeable future. 
-rulesets. It aims to make it easier to specify: "use secure HTTP
-connections when possible."
 
-  [1]: https://www.eff.org/https-everywhere
+[HTTPS Everywhere](https://www.eff.org/https-everywhere) provides these facilities within the two most common web browsers. But there exist HTTP clients which aren’t browsers, and unsupported browsers. We wish to supply broader protections; discouraging adversaries from intercepting and manipulating traffic from a wider variety of clients. This library serves as the bedrock of that effort; it provides high-level programmatic access to the HTTPS Everywhere rules database, making it easier to specify "substitute this HTTP endpoint for a corresponding secure endpoint, if you know how."
+
+It's very much a work-in-progress now, though you are very welcome to [contribute](#contributing) to that progress.
+
+Usage
+-----
+
+The interface is straightforward:
 
 ```haskell
-λ: :m + Data.HTTPSEverywhere.Rules Network.URI
+λ: :m + Data.HTTPSEverywhere.Rules Network.URI
-λ: rules <- getRulesets
+λ: rules <- getRulesets
-λ: let Just it = parseURI "http://httpsnow.org"
+λ: let Just it = parseURI "http://httpsnow.org"
-λ: rewriteURL rules it
+λ: rewriteURL rules it
 Just https://httpsnow.org
 ```
+
+There exist demonstration programs:
+
+- [`redirect-proxy`](examples/RedirectProxy.hs) implements a naive redirecting HTTP proxy, writing 302s for any URI HTTPS Everywhere knows how to upgrade.
+
+	```
+	% nohup redirect-proxy &>/dev/null &
+	[1] 674
+	% curl -w '%{remote_ip} %{http_code} %{redirect_url}\n' -x localhost:3100 httpsnow.org
+	127.0.0.1 302 https://httpsnow.org/
+	```
+
+- [`count-upgradeable`](examples/CountUpgradeable.hs) announces the fraction of URIs received on standard input that HE knows how to upgrade:
+
+	```
+	% find vendor/https-everywhere/src/chrome/content/rules -name '*.xml' | shuf -n100 > some_rules
+	% < some_rules xargs grep default_off | wc -l
+	20
+	% < some_rules xargs grep -Pohr '(?<=test url=")[^"]+(?=")' | count-upgradeable
+	(44,76)
+	```
+
+Contributing
+------------
+
+First of all, thank you.
+
+This is all fairly immature as-is, but you're more than welcome to plod in. The best step you can take right now is to drop by the IRC channel [#https-everywhere-else](irc://irc.freenode.net/#https-everywhere-else) on Freenode: indicate what you want to be doing, and we'll work out how to make it happen; indicate any uncertainty, and we will try to clarify it.
+
+Our current focus is on performance improvements. The current implementation relies on a linear search of the ruleset upon each rewrite attempt; this is compromisingly inefficient. We're going to modify the library to perform search on a supercompiled suffix tree, where rather than lookup being on the order of the number of rules, it will be on the order of the depth of the domain - the previous cost being incurred once at compile time.

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)
+import "https-everywhere-rules" Data.HTTPSEverywhere.Rules (rewriteURL, RuleSet, getRulesets)
 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 :: Pipe URI Bool IO ()
+check :: [RuleSet] -> Pipe URI Bool IO ()
-check = forever $ await >>= yield . isJust . rewriteURL
+check rs = forever $ await >>= yield . isJust . rewriteURL rs
 
 fold :: Monad m => Fold a b -> Producer a m () -> m b
 fold (Fold step begin done) = Pipes.fold step begin done
@@ -27,4 +27,6 @@ proportion :: Fold Bool (Int, Int)
 proportion = (,) <$> Foldl.foldMap (Sum . bool 0 1) getSum <*> Foldl.length
 
 main :: IO ()
-main = fold proportion (stdinLn >-> parse >-> check) >>= print
+main = do
+  rulesets <- getRulesets
+  fold proportion (stdinLn >-> parse >-> check rulesets) >>= print

examples/RedirectProxy.hs

@@ -7,26 +7,22 @@ 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
+import "http-proxy" Network.HTTP.Proxy (runProxySettings, defaultProxySettings, Settings(..), Request(..))
-  (runProxySettings, defaultProxySettings, Settings(..), Request(..))
 import "http-types" Network.HTTP.Types (status302)
-import "https-everywhere-rules" Data.HTTPSEverywhere.Rules (rewriteURL)
+import "https-everywhere-rules" Data.HTTPSEverywhere.Rules (getRulesets, rewriteURL, RuleSet)
 import "network-uri" Network.URI (URI, parseURI)
 import "wai" Network.Wai (Response, responseLBS)
 
 httpRedirect :: URI -> Response
-httpRedirect to =
+httpRedirect to = responseLBS status302 [("Location", pack . show $ to)] ""
-  responseLBS status302 [("Location", pack . show $ to)] ""
 
-tryHTTPS :: Request -> Either Response Request
+tryHTTPS :: [RuleSet] -> Request -> Either Response Request
-tryHTTPS Request{..} =
+tryHTTPS rs Request{..} = case parseURI . unpack $ requestPath <> queryString of
-  case parseURI . unpack $ requestPath <> queryString of
+  Just uri -> maybe (return Request{..}) (Left . httpRedirect) (rewriteURL rs uri)
-    Just uri -> maybe
+  Nothing -> return Request{..}
-      (return Request{..})
-      (Left . httpRedirect)
-      (rewriteURL uri)
-    Nothing -> return Request{..}
 
 main :: IO ()
-main = runProxySettings $ defaultProxySettings
+main = do
-  { proxyRequestModifier = return . tryHTTPS }
+  rules <- getRulesets
+  runProxySettings $ defaultProxySettings
+    { proxyRequestModifier = return . tryHTTPS rules }

https-everywhere-rules.cabal

@@ -13,7 +13,7 @@ license-file:
 author:
   vi
 maintainer:
-  vi@computational.law
+  vi@zalora.com
 category:
   Data
 build-type:
@@ -624,33 +624,26 @@ 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,
+    base               >= 4.7  && < 4.10,
-    attoparsec,
+    attoparsec         >= 0.12 && < 0.14,
-    bytestring,
+    directory          >= 1.2  && < 1.4,
-    directory,
+    errors             >= 1.4  && < 2.2,
-    errors,
+    filepath           >= 1.3  && < 1.5,
-    filepath,
+    functor-infix      >= 0.0  && < 0.1,
-    http-client,
+    http-client        >= 0.3  && < 0.6,
-    lens,
+    lens               >= 4.3  && < 4.16,
-    mtl,
+    mtl                >= 2.2  && < 2.3,
-    network,
+    network            >= 2.6  && < 2.7,
-    network-uri,
+    network-uri        >= 2.6  && < 2.7,
-    pipes,
+    pipes              >= 4.1  && < 4.4,
-    taggy-lens,
+    string-conversions >= 0.3  && < 0.5,
-    template-haskell,
+    taggy-lens         >= 0.1  && < 0.2,
-    th-lift-instances,
+    text               >= 1.1  && < 1.3,
-    text,
+    text-icu           >= 0.6  && < 0.8
-    text-icu,
-    vector
   hs-source-dirs:
     src
   default-language:
@@ -662,13 +655,24 @@ test-suite spec
   type:
     exitcode-stdio-1.0
   build-depends:
-    base,
+    base               >= 4.7  && < 4.10,
-    attoparsec,
+    attoparsec         >= 0.12 && < 0.14,
-    directory,
+    directory          >= 1.2  && < 1.4,
-    errors,
+    errors             >= 1.4  && < 2.2,
-    hspec,
+    filepath           >= 1.3  && < 1.5,
-    text,
+    functor-infix      >= 0.0  && < 0.1,
-    text-icu
+    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
   main-is:
     Spec.hs
   hs-source-dirs:
@@ -681,6 +685,12 @@ 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
 
@@ -699,7 +709,7 @@ executable redirect-proxy
     RedirectProxy.hs
   if flag(build-examples)
     build-depends:
-      base,
+      base >= 4.7  && < 4.10,
       bytestring,
       http-proxy,
       http-types,

src/Data/ByteString/RadixTrie.hs

@@ -1,146 +0,0 @@
-{-# 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"]

src/Data/HTTPSEverywhere/Rules.hs

@@ -1,22 +1,29 @@
 module Data.HTTPSEverywhere.Rules (
-  RuleTrie,
+  RuleSet,
+  getRulesets,
   rewriteURL,
   rewriteCookie
 ) where
 
-import Network.URI (URI)
+import Prelude hiding (null, head)
-import Data.Monoid (First(..), Any(..))
 import Data.Bool (bool)
-import Network.HTTP.Client (Cookie(..))
+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.HTTPSEverywhere.Rules.Internal
+rewriteURL' :: Monad m => [RuleSet] -> URI -> m (Maybe URI)
+rewriteURL' rs url = head $ getRulesetsMatching rs url >-> havingRulesThatTrigger url
 
-rewriteURL :: URI -> Maybe URI
+rewriteURL :: [RuleSet] -> (URI -> Maybe URI)
-rewriteURL uri = getFirst . mconcat $
+rewriteURL = runIdentity <$$> rewriteURL'
-  map (First . havingRulesThatTrigger uri) (getRulesetsMatching uri)
 
-rewriteCookie :: URI -> (Cookie -> Maybe Cookie)
+rewriteCookie' :: Monad m => [RuleSet] -> URI -> Cookie -> m (Maybe Cookie)
-rewriteCookie uri cookie =
+rewriteCookie' rs url cookie = Just (setSecureFlag cookie) `bool` Nothing <$> null producer
-  bool Nothing (Just $ setSecureFlag cookie) . getAny . mconcat $
+  where producer = getRulesetsMatching rs url >-> havingCookieRulesThatTrigger cookie
-    map (Any . havingCookieRulesThatTrigger cookie)
+
-      (getRulesetsMatching uri)
+rewriteCookie :: [RuleSet] -> URI -> (Cookie -> Maybe Cookie)
+rewriteCookie = runIdentity <$$$> rewriteCookie'

src/Data/HTTPSEverywhere/Rules/Internal.hs

@@ -1,49 +1,71 @@
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE CPP #-}
-{-# LANGUAGE RecordWildCards #-}
 
 module Data.HTTPSEverywhere.Rules.Internal (
-  RuleTrie,
+  getRulesets,
   getRulesetsMatching,
   havingRulesThatTrigger,
   havingCookieRulesThatTrigger,
-  setSecureFlag
+  setSecureFlag,
+  RuleSet,
+#ifdef TEST
+  hasTargetMatching,
+  hasTriggeringRuleOn,
+  hasExclusionMatching
+#endif
 ) where
 
-import Control.Monad (MonadPlus(..))
+import Prelude hiding (readFile, filter)
-import Data.Text (pack)
+import Control.Applicative ((<*>), (<$>))
-import Data.Maybe (maybeToList)
+import Control.Lens ((&))
-import Data.Monoid (First(..))
+import Control.Monad ((<=<), join)
+import Data.Bool (bool)
+import Data.Functor.Infix ((<$$>))
+import Data.List (find)
+import Data.Maybe (isJust)
 import Network.HTTP.Client (Cookie(..))
-import Network.URI (URI, uriAuthority, uriRegName)
+import Network.URI (URI)
+import Pipes (Pipe, Producer, for, each, await, yield, lift, (>->))
+import Pipes.Prelude (filter, toListM)
 
-import Data.HTTPSEverywhere.Rules.Internal.Trie (RuleTrie)
+import Data.HTTPSEverywhere.Rules.Internal.Parser (parseRuleSets)
-import qualified Data.HTTPSEverywhere.Rules.Internal.Trie as Trie
+import qualified Data.HTTPSEverywhere.Rules.Internal.Raw as Raw (getRule, getRules)
-import Data.HTTPSEverywhere.Rules.Internal.Types
+import Data.HTTPSEverywhere.Rules.Internal.Types (RuleSet(..), Target(..), Exclusion(..), Rule(..), CookieRule(..))
-  (RuleSet(..), getRule, getExclusion, getCookieRule)
-import qualified Data.HTTPSEverywhere.Rules.Internal.Trie.Supercompilation
-  as Supercompilation (trie)
 
-trie :: RuleTrie
+getRulesets' :: Producer RuleSet IO ()
-trie = $(Supercompilation.trie)
+getRulesets' = lift Raw.getRules
+           >>= flip (for . each) (flip (for . each) yield <=< lift . (parseRuleSets <$$> Raw.getRule))
 
-unless :: MonadPlus m => Bool -> m a -> m a
+getRulesets :: IO [RuleSet]
-unless True action = action
+getRulesets = toListM getRulesets'
-unless False _ = mzero
 
-getRulesetsMatching :: URI -> [RuleSet]
+getRulesetsMatching :: Monad m => [RuleSet] -> URI -> Producer RuleSet m ()
-getRulesetsMatching uri = do
+getRulesetsMatching rs url = each rs
-  let hostname = fmap (pack . uriRegName) (uriAuthority uri)
+                         >-> filter (flip hasTargetMatching url)
-  r@RuleSet{..} <- maybeToList hostname >>= Trie.lookup trie
+                         >-> filter (not . flip hasExclusionMatching url)
-  unless (any (\e -> getExclusion e uri) ruleSetExclusions) $
-    return r
 
-havingRulesThatTrigger :: URI -> RuleSet -> Maybe URI
+havingRulesThatTrigger :: Monad m => URI -> Pipe RuleSet URI m ()
-havingRulesThatTrigger uri RuleSet{..} =
+havingRulesThatTrigger url = flip hasTriggeringRuleOn url <$> await 
-  getFirst . mconcat $ map (First . ($ uri) . getRule) ruleSetRules
+                         >>= maybe (havingRulesThatTrigger url) yield
 
-havingCookieRulesThatTrigger :: Cookie -> RuleSet -> Bool
+havingCookieRulesThatTrigger :: Monad m => Cookie -> Pipe RuleSet Bool m ()
-havingCookieRulesThatTrigger cookie RuleSet{..} =
+havingCookieRulesThatTrigger cookie = flip hasTriggeringCookieRuleOn cookie <$> await
-  any (($ cookie) . getCookieRule) ruleSetCookieRules
+                                  >>= 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
 
 setSecureFlag :: Cookie -> Cookie
 setSecureFlag cookie = cookie { cookie_secure_only = True }

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

@@ -1,61 +1,74 @@
-{-# LANGUAGE OverloadedStrings           #-}
+{-# LANGUAGE CPP                 #-}
-{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
+{-# LANGUAGE OverloadedStrings   #-}
+{-# LANGUAGE RecordWildCards     #-}
+{-# LANGUAGE LambdaCase          #-}
 
 module Data.HTTPSEverywhere.Rules.Internal.Parser (
   parseRuleSets,
-  parseSerialisable
+#ifdef TEST
+  parseTarget
+#endif
 ) 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
+import Data.HTTPSEverywhere.Rules.Internal.Types (RuleSet(..), Target(..), Rule(..), Exclusion(..), CookieRule(..))
-  (RuleSet(..), fromSerialisable)
+import Data.Text.ICU.Extras (match, findAndReplace)
-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 fromSerialisable . parseSerialisable
+parseRuleSets = catMaybes <$$> toListOf $ html . allNamed (only "ruleset") . to parseRuleSet
 
+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)

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

@@ -4,6 +4,7 @@ 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)
@@ -15,8 +16,8 @@ getRule :: FilePath -> IO Text
 getRule = readFile
 
 getRules :: IO [FilePath]
-getRules = getDataFileName [] >>= fmap (filter isXML) <$> getAbsoluteDirectoryContents
+getRules = getDataFileName [] >>= filter isXML <$$> getAbsoluteDirectoryContents
   where isXML = (== ".xml") . takeExtension
 
 getAbsoluteDirectoryContents :: FilePath -> IO [FilePath]
-getAbsoluteDirectoryContents x = fmap (combine x) <$> getDirectoryContents x
+getAbsoluteDirectoryContents x = combine x <$$> getDirectoryContents x

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

@@ -1,89 +0,0 @@
-{-# 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)

src/Data/HTTPSEverywhere/Rules/Internal/Trie/Supercompilation.hs

@@ -1,41 +0,0 @@
-{-# 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 |]

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

@@ -1,31 +1,14 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE LambdaCase        #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE RecordWildCards   #-}
-
 module Data.HTTPSEverywhere.Rules.Internal.Types (
   RuleSet(..),
   Target(..),
   Rule(..),
   Exclusion(..),
-  CookieRule(..),
+  CookieRule(..)
-  fromSerialisable
 ) where
 
-import Prelude hiding (take, drop)
+import Data.Text (Text)
-import Control.Monad (join)
+import Network.HTTP.Client (Cookie)
-import Control.Monad.State (State, evalState, modify', gets)
+import Network.URI (URI)
-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       }
@@ -39,48 +22,3 @@ 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)
-  }

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

@@ -1,30 +0,0 @@
-{-# 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)

src/Data/Text/ICU/Extras.hs

@@ -17,6 +17,7 @@ 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)
@@ -26,7 +27,7 @@ regex :: Text -> Maybe Regex
 regex = hush . regex' []
 
 match :: Text -> Maybe (Text -> Bool)
-match = fmap (fmap isJust <$> find) <$> regex
+match = (isJust <$$> find) <$$> regex
 
 findAndReplace :: Text -> Text -> Maybe (Text -> Maybe Text)
 findAndReplace pattern replacement = (.)
@@ -40,7 +41,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 = (Reference . digitToInt) <$> (char '$' *> digit)
+parseReference = char '$' *> digit <&> Reference . digitToInt
 
 parseLiteral :: Parser Segment
 parseLiteral = Literal <$> takeWhile1 (/= '$')

src/Data/Text/RadixTrie.hs

@@ -1,30 +0,0 @@
-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)

stack.yaml

@@ -1,8 +1,6 @@
 packages:
 - .
 extra-deps:
-- taggy-0.2.1
+- functor-infix-0.0.5
-- taggy-lens-0.1.2
+- http-proxy-0.1.0.5
-- http-proxy-0.1.0.6
+resolver: lts-8.24
-resolver: lts-11.14
-allow-newer: true

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

@@ -0,0 +1,72 @@
+{-# 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>"

test/Data/HTTPSEverywhere/Rules/InternalSpec.hs

@@ -0,0 +1,63 @@
+{-# 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

test/Data/Text/ICU/ExtrasSpec.hs

@@ -5,6 +5,7 @@
 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)
@@ -15,8 +16,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 "x" `shouldBe` Just True
-     ($ "xa") <$> match "y" `shouldBe` Just False
+     ("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]
@@ -27,9 +28,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 "(bar)" "$1baz" `shouldBe` Just (Just "barbazqux")
-      ($ "barqux") <$> findAndReplace "(qux)" "baz$1" `shouldBe` Just (Just "barbazqux")
+      ("barqux" &) <$> findAndReplace "(qux)" "baz$1" `shouldBe` Just (Just "barbazqux")
-      ($ "barqux") <$> findAndReplace "u" "uu" `shouldBe` Just (Just "barquux")
+      ("barqux" &) <$> findAndReplace "u" "uu" `shouldBe` Just (Just "barquux")
 
 instance Show (Text -> Bool) where
   show _ = "Text -> Bool"