Supercompiled rule tries.

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, 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 :: Pipe URI Bool IO ()
-check rs = forever $ await >>= yield . isJust . rewriteURL rs
+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
+main = fold proportion (stdinLn >-> parse >-> check) >>= print
-  rulesets <- getRulesets
-  fold proportion (stdinLn >-> parse >-> check rulesets) >>= print

examples/RedirectProxy.hs

@@ -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 :: Request -> Either Response Request
-tryHTTPS rs Request{..} = case parseURI . unpack $ requestPath <> queryString of
+tryHTTPS Request{..} =
-  Just uri -> maybe (return Request{..}) (Left . httpRedirect) (rewriteURL rs uri)
+  case parseURI . unpack $ requestPath <> queryString of
-  Nothing -> return Request{..}
+    Just uri -> maybe
+      (return Request{..})
+      (Left . httpRedirect)
+      (rewriteURL uri)
+    Nothing -> return Request{..}
 
 main :: IO ()
-main = do
+main = runProxySettings $ defaultProxySettings
-  rules <- getRulesets
+  { proxyRequestModifier = return . tryHTTPS }
-  runProxySettings $ defaultProxySettings
-    { proxyRequestModifier = return . tryHTTPS rules }

https-everywhere-rules.cabal

@@ -624,7 +624,10 @@ library
     Data.HTTPSEverywhere.Rules.Internal,
     Data.HTTPSEverywhere.Rules.Internal.Parser,
     Data.HTTPSEverywhere.Rules.Internal.Raw,
+    Data.HTTPSEverywhere.Rules.Internal.Trie,
+    Data.HTTPSEverywhere.Rules.Internal.Trie.Supercompilation,
     Data.HTTPSEverywhere.Rules.Internal.Types,
+    Data.HTTPSEverywhere.Rules.Internal.Types.Serialisable,
     Data.ByteString.RadixTrie,
     Data.Text.RadixTrie,
     Data.Text.ICU.Extras,
@@ -632,6 +635,7 @@ library
   build-depends:
     base,
     attoparsec,
+    bytestring,
     directory,
     errors,
     filepath,
@@ -641,8 +645,9 @@ library
     network,
     network-uri,
     pipes,
-    string-conversions,
     taggy-lens,
+    template-haskell,
+    th-lift-instances,
     text,
     text-icu,
     vector

src/Data/ByteString/RadixTrie.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE DeriveFunctor                 #-}
+{-# LANGUAGE DeriveLift                    #-}
 {-# LANGUAGE OverloadedStrings             #-}
 {-# LANGUAGE RecordWildCards               #-}
 {-# LANGUAGE TupleSections                 #-}
@@ -21,19 +22,21 @@ import Prelude hiding
 import Data.ByteString
   (ByteString, uncons, isPrefixOf, null, drop, length, head, tail,
    take, length, last, append, cons)
+import Data.Maybe (fromMaybe, isJust, maybeToList)
 import Data.Vector (Vector, (!), generate, modify, imap)
 import qualified Data.Vector as Vector (toList)
 import qualified Data.Vector.Mutable as Mutable (modify)
-import Data.Maybe (fromMaybe, isJust, maybeToList)
+import Language.Haskell.TH.Syntax (Lift)
+import Instances.TH.Lift ()
 
 data Leaf a =
   Prefix ByteString (RadixTrie a) |
   Split (Vector {- 2 ^ 8 -} (Maybe (RadixTrie a))) |
-  Vacuum deriving (Show, Functor)
+  Vacuum deriving (Lift, Show, Functor)
 
 data RadixTrie a =
   RadixTrie { label :: Maybe a, children :: Leaf a }
-  deriving (Show, Functor)
+  deriving (Lift, Show, Functor)
 
 empty :: RadixTrie a
 empty = RadixTrie Nothing Vacuum

src/Data/HTTPSEverywhere/Rules.hs

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

src/Data/HTTPSEverywhere/Rules/Internal.hs

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

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

@@ -1,73 +1,61 @@
-{-# LANGUAGE CPP                 #-}
+{-# LANGUAGE OverloadedStrings           #-}
-{-# LANGUAGE OverloadedStrings   #-}
+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
-{-# LANGUAGE RecordWildCards     #-}
-{-# LANGUAGE LambdaCase          #-}
 
 module Data.HTTPSEverywhere.Rules.Internal.Parser (
   parseRuleSets,
-#ifdef TEST
+  parseSerialisable
-  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.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.HTTPSEverywhere.Rules.Internal.Types
-import Data.Text.ICU.Extras (match, findAndReplace)
+  (RuleSet(..), fromSerialisable)
+import qualified
+  Data.HTTPSEverywhere.Rules.Internal.Types.Serialisable as Serialisable
+
+parseRule :: Element -> Maybe Serialisable.Rule
+parseRule element = Serialisable.Rule
+  <$> element ^. attr "from"
+  <*> element ^. attr "to"
+
+parseCookieRule :: Element -> Maybe Serialisable.CookieRule
+parseCookieRule element = Serialisable.CookieRule
+  <$> element ^. attr "host"
+  <*> element ^. attr "name"
+
+parseSerialisable' :: Element -> Maybe Serialisable.RuleSet
+parseSerialisable' txt = txt ^. attr "name" <&> \ruleSetName -> do
+   let
+     ruleSetTargets = txt ^.. allNamed (only "target")
+       . attr "host"
+       . _Just
+       . to Serialisable.Target
+     ruleSetRules = txt ^.. allNamed (only "rule")
+       . to parseRule
+       & catMaybes
+     ruleSetExclusions = txt ^.. allNamed (only "exclusion")
+       . attr "pattern"
+       . _Just
+       . to Serialisable.Exclusion
+     ruleSetCookieRules = txt ^.. allNamed (only "securecookie")
+       . to parseCookieRule
+       & catMaybes
+   Serialisable.RuleSet
+     ruleSetName
+     ruleSetTargets
+     ruleSetRules
+     ruleSetExclusions
+     ruleSetCookieRules
+
+parseSerialisable :: Lazy.Text -> [Serialisable.RuleSet]
+parseSerialisable = fmap catMaybes `fmap` toListOf $
+  html . allNamed (only "ruleset") . to parseSerialisable'
 
 parseRuleSets :: Lazy.Text -> [RuleSet]
-parseRuleSets = fmap catMaybes <$> toListOf $ html . allNamed (only "ruleset") . to parseRuleSet
+parseRuleSets = fmap fromSerialisable . parseSerialisable
 
-parseRuleSet :: Element -> Maybe RuleSet
-parseRuleSet xml = xml ^. attr "name" <&> \ruleSetName -> do
-  let ruleSetTargets     = xml ^.. allNamed (only "target") . attr "host" . _Just . to parseTarget
-      ruleSetRules       = xml ^.. allNamed (only "rule") . to parseRule & catMaybes
-      ruleSetExclusions  = xml ^.. allNamed (only "exclusion") . attr "pattern" . _Just . to parseExclusion & catMaybes
-      ruleSetCookieRules = xml ^.. allNamed (only "securecookie") . to parseCookieRule & catMaybes
-  RuleSet ruleSetName ruleSetTargets ruleSetRules ruleSetExclusions ruleSetCookieRules
-
-parseTarget' :: State (Strict.Text, Strict.Text) Bool
-parseTarget' = do
-  gets ((== ".*") . takeEnd 2 . fst) >>= bool (return ())
-    (modify' (bimap (dropEnd 2) (dropEnd 1 . dropWhileEnd (/= '.'))))
-  gets (take 2 . fst) >>= \case
-    "*." -> do
-      suffix <- gets (drop 1 . fst) -- Don't drop the dot, we expect some prefix.
-      isSuffixOf suffix <$> gets snd
-    _ -> gets (uncurry (==))
-
-parseTarget :: Strict.Text -> Target
-parseTarget target = Target $ \uri -> do
-  case uriRegName <$> uriAuthority uri of
-    Just domain -> evalState parseTarget' (target, cs domain)
-    Nothing -> False
-
-parseRule :: Element -> Maybe Rule
-parseRule element = do
-  pattern     <- element ^. attr "from"
-  replacement <- element ^. attr "to"
-  substitute  <- findAndReplace pattern replacement 
-  return . Rule $ join . fmap (parseURI . cs) . substitute . cs . show
-
-parseExclusion :: Strict.Text -> Maybe Exclusion
-parseExclusion = fmap (Exclusion . (. cs . show))  <$> match
-
-parseCookieRule :: Element -> Maybe CookieRule
-parseCookieRule element = CookieRule <$> do
-  hostMatches <- element ^. attr "host" . to (>>= match)
-  nameMatches <- element ^. attr "name" . to (>>= match)
-  return $ \Cookie{..} -> nameMatches (cs cookie_name) && hostMatches (cs cookie_domain)

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

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

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

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

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

@@ -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 Prelude hiding (take, drop)
-import Network.HTTP.Client (Cookie)
+import Control.Monad (join)
-import Network.URI (URI)
+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)
+  }

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

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