From 5060883c5a8acdaf0b845161b9b490e8a0f21031 Mon Sep 17 00:00:00 2001
From: vi <me@vikramverma.com>
Date: Sun, 10 Aug 2014 07:16:57 +0800
Subject: [PATCH] Broken domain logic.

---
 src/Data/HTTPSEverywhere/Rules.hs          | 20 ++++++--
 src/Data/HTTPSEverywhere/Rules/Internal.hs | 58 +++++++++++++++++++---
 2 files changed, 66 insertions(+), 12 deletions(-)

diff --git a/src/Data/HTTPSEverywhere/Rules.hs b/src/Data/HTTPSEverywhere/Rules.hs
index c57fa2e..32c9ebf 100644
--- a/src/Data/HTTPSEverywhere/Rules.hs
+++ b/src/Data/HTTPSEverywhere/Rules.hs
@@ -3,13 +3,23 @@ module Data.HTTPSEverywhere.Rules (
   rewriteCookie
 ) where
 
+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 Pipes (runEffect, (>->))
+import Pipes.Prelude (take, null)
 
-import Data.HTTPSEverywhere.Rules.Internal ()
+import Data.HTTPSEverywhere.Rules.Internal (getRulesetsMatching, havingRulesThatTrigger, havingCookieRulesThatTrigger, setSecureFlag)
 
-rewriteURL :: Text -> IO Text
-rewriteURL = undefined
+rewriteURL :: Text -> IO (Maybe Text)
+rewriteURL url = runEffect
+               $ (Nothing <$ getRulesetsMatching url)
+             >-> (Nothing <$ havingRulesThatTrigger url)
+             >-> (Nothing <$ take 1)
 
-rewriteCookie :: Cookie -> IO Cookie
-rewriteCookie = undefined
+rewriteCookie :: Text -> Cookie -> IO Cookie
+rewriteCookie url cookie = null producer <&> setSecureFlag cookie `bool` cookie
+  where producer = getRulesetsMatching url >-> (() <$ havingCookieRulesThatTrigger cookie)
diff --git a/src/Data/HTTPSEverywhere/Rules/Internal.hs b/src/Data/HTTPSEverywhere/Rules/Internal.hs
index c1a5bf4..cf55f54 100644
--- a/src/Data/HTTPSEverywhere/Rules/Internal.hs
+++ b/src/Data/HTTPSEverywhere/Rules/Internal.hs
@@ -1,15 +1,59 @@
 module Data.HTTPSEverywhere.Rules.Internal (
-  getRulesets
+  getRulesetsMatching,
+  havingRulesThatTrigger,
+  havingCookieRulesThatTrigger,
+  setSecureFlag
 ) where
 
-import Prelude hiding (readFile)
-import Control.Monad ((<=<))
+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.HTTPSEverywhere.Rules.Raw (getRule, getRules)
-import Pipes (Producer, for, each, yield, lift)
+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 Pipes (Producer, Consumer, for, each, await, yield, lift, (>->))
+import Pipes.Prelude (filter)
 
 import Data.HTTPSEverywhere.Rules.Internal.Parser (parseRuleSets)
-import Data.HTTPSEverywhere.Rules.Internal.Types (RuleSet)
+import Data.HTTPSEverywhere.Rules.Internal.Types (RuleSet(..), Target(..), Exclusion(..), Rule(..), CookieRule(..))
 
 getRulesets :: Producer RuleSet IO ()
-getRulesets = lift getRules >>= flip (for . each) (flip (for . each) yield <=< lift . (parseRuleSets <$$> getRule))
+getRulesets = lift Raw.getRules
+          >>= flip (for . each) (flip (for . each) yield <=< lift . (parseRuleSets <$$> Raw.getRule))
+
+getRulesetsMatching :: Text -> Producer RuleSet IO ()
+getRulesetsMatching url = getRulesets
+                      >-> filter (flip hasTargetMatching url)
+                      >-> filter (not . flip hasExclusionMatching url)
+
+havingRulesThatTrigger :: Text -> Consumer RuleSet IO (Maybe Text)
+havingRulesThatTrigger url = flip hasTriggeringRuleOn url <$> await
+                         >>= maybe (havingRulesThatTrigger url) (return . Just)
+
+havingCookieRulesThatTrigger :: Cookie -> Consumer RuleSet IO Bool
+havingCookieRulesThatTrigger cookie = flip hasTriggeringCookieRuleOn cookie <$> await
+                                  >>= bool (havingCookieRulesThatTrigger cookie) (return True)
+
+hasTargetMatching :: RuleSet -> Text -> Bool
+hasTargetMatching ruleset url = getTargets ruleset <*> [url] & or
+  where getTargets = getTarget <$$> ruleSetTargets
+
+hasExclusionMatching :: RuleSet -> Text -> Bool
+hasExclusionMatching ruleset url = getExclusions ruleset <*> [url] & or & not
+  where getExclusions = getExclusion <$$> ruleSetExclusions
+
+hasTriggeringRuleOn :: RuleSet -> Text -> Maybe Text -- 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 }