From 5af781291f654a2634f66ad1bc7178f93ec4fbcf Mon Sep 17 00:00:00 2001
From: vi <me@vikramverma.com>
Date: Sun, 24 Aug 2014 12:40:06 +0800
Subject: [PATCH] Correct pipeline semantics.

---
 ref/pipes.txt                              |  8 ++++++++
 src/Data/HTTPSEverywhere/Rules.hs          | 18 +++++++-----------
 src/Data/HTTPSEverywhere/Rules/Internal.hs | 12 ++++++------
 3 files changed, 21 insertions(+), 17 deletions(-)
 create mode 100644 ref/pipes.txt

diff --git a/ref/pipes.txt b/ref/pipes.txt
new file mode 100644
index 0000000..558c7f8
--- /dev/null
+++ b/ref/pipes.txt
@@ -0,0 +1,8 @@
+                    | Upstream output | Upstream input | Downstream input | Downstream output | Base monad | Return value
+Proxy a' a b' b m r | a'              | a              | b'               | b                 | m          | r
+Effect m r          | Void            | ()             | ()               | Void              | m          | r
+Pipe a b m r        | ()              | a              | ()               | b                 | m          | r
+Producer b m r      | Void            | ()             | ()               | b                 | m          | r
+Consumer a m r      | ()              | a              | ()               | Void              | m          | r
+Client a' a m r     | a'              | a              | ()               | Void              | m          | r
+Server b' b m r     | Void            | ()             | b'               | b                 | m          | r
diff --git a/src/Data/HTTPSEverywhere/Rules.hs b/src/Data/HTTPSEverywhere/Rules.hs
index 26898bb..c7d51bd 100644
--- a/src/Data/HTTPSEverywhere/Rules.hs
+++ b/src/Data/HTTPSEverywhere/Rules.hs
@@ -3,23 +3,19 @@ module Data.HTTPSEverywhere.Rules (
   rewriteCookie
 ) where
 
-import Prelude hiding (take, null)
-import Control.Applicative ((<$))
-import Control.Lens ((<&>))
+import Prelude hiding (null, head)
+import Control.Lens ((<&>),(&))
 import Data.Bool (bool)
 import Network.HTTP.Client (Cookie)
 import Network.URI (URI)
-import Pipes (runEffect, (>->))
-import Pipes.Prelude (take, null)
-
+import Pipes ((>->))
+import Pipes.Prelude (head, null)
+import Control.Monad (join)
 import Data.HTTPSEverywhere.Rules.Internal (getRulesetsMatching, havingRulesThatTrigger, havingCookieRulesThatTrigger, setSecureFlag)
 
 rewriteURL :: URI -> IO (Maybe URI)
-rewriteURL url = runEffect
-               $ (Nothing <$ getRulesetsMatching url)
-             >-> (Nothing <$ havingRulesThatTrigger url)
-             >-> (Nothing <$ take 1)
+rewriteURL url = getRulesetsMatching url >-> havingRulesThatTrigger url & head <&> join
 
 rewriteCookie :: URI -> Cookie -> IO Cookie
 rewriteCookie url cookie = null producer <&> setSecureFlag cookie `bool` cookie
-  where producer = getRulesetsMatching url >-> (() <$ havingCookieRulesThatTrigger cookie)
+  where producer = getRulesetsMatching url >-> havingCookieRulesThatTrigger cookie
diff --git a/src/Data/HTTPSEverywhere/Rules/Internal.hs b/src/Data/HTTPSEverywhere/Rules/Internal.hs
index 17e8b27..d9fda07 100644
--- a/src/Data/HTTPSEverywhere/Rules/Internal.hs
+++ b/src/Data/HTTPSEverywhere/Rules/Internal.hs
@@ -23,7 +23,7 @@ import Data.Maybe (isJust)
 import qualified Data.HTTPSEverywhere.Rules.Raw as Raw (getRule, getRules)
 import Network.HTTP.Client (Cookie(..))
 import Network.URI (URI)
-import Pipes (Producer, Consumer, for, each, await, yield, lift, (>->))
+import Pipes (Pipe, Producer, for, each, await, yield, lift, (>->))
 import Pipes.Prelude (filter)
 
 import Data.HTTPSEverywhere.Rules.Internal.Parser (parseRuleSets)
@@ -38,13 +38,13 @@ getRulesetsMatching url = getRulesets
                       >-> filter (flip hasTargetMatching url)
                       >-> filter (not . flip hasExclusionMatching url)
 
-havingRulesThatTrigger :: URI -> Consumer RuleSet IO (Maybe URI)
-havingRulesThatTrigger url = flip hasTriggeringRuleOn url <$> await
-                         >>= maybe (havingRulesThatTrigger url) (return . Just)
+havingRulesThatTrigger :: URI -> Pipe RuleSet (Maybe URI) IO ()
+havingRulesThatTrigger url = flip hasTriggeringRuleOn url <$> await 
+                         >>= maybe (havingRulesThatTrigger url) (yield . Just)
 
-havingCookieRulesThatTrigger :: Cookie -> Consumer RuleSet IO Bool
+havingCookieRulesThatTrigger :: Cookie -> Pipe RuleSet Bool IO ()
 havingCookieRulesThatTrigger cookie = flip hasTriggeringCookieRuleOn cookie <$> await
-                                  >>= bool (havingCookieRulesThatTrigger cookie) (return True)
+                                  >>= bool (havingCookieRulesThatTrigger cookie) (yield True)
 
 hasTargetMatching :: RuleSet -> URI -> Bool
 hasTargetMatching ruleset url = getTargets ruleset <*> [url] & or