rewrite(URL|Cookie) are now pure.

They have been pure since ed1933f, but now the types reflect that.

Breaking interface change.

examples/CountUpgradeable.hs

@@ -19,8 +19,7 @@ parse = forever $ parseURI <$> await >>= maybe (return ()) yield
 check :: [RuleSet] -> Pipe URI Bool IO ()
 check rs = forever $ do
   src <- await
-  tgt <- lift $ rewriteURL rs src
+  yield $ src /= rewriteURL rs src
-  yield $ src /= tgt
 
 fold :: Monad m => Fold a b -> Producer a m () -> m b
 fold (Fold step begin done) = Pipes.fold step begin done

examples/RedirectProxy.hs

@@ -12,20 +12,18 @@ import "https-everywhere-rules" Data.HTTPSEverywhere.Rules (getRulesets, rewrite
 import "network-uri" Network.URI (URI, parseURI)
 import "wai" Network.Wai (Response, responseLBS)
 
-(<&>) :: Functor f => f a -> (a -> b) -> f b
-(<&>) = flip fmap; infixl 1 <&>
-
 httpRedirect :: URI -> Response
 httpRedirect to = responseLBS status302 [("Location", pack . show $ to)] ""
 
-tryHTTPS :: [RuleSet] -> Request -> IO (Either Response Request)
+tryHTTPS :: [RuleSet] -> Request -> Either Response Request
 tryHTTPS rs Request{..} = case parseURI . unpack $ requestPath <> queryString of
-  Just uri -> rewriteURL rs uri <&> \rewrite -> if rewrite == uri
+  Just uri ->
-    then return Request{..}
+    let rewrite = rewriteURL rs uri in
-    else Left $ httpRedirect rewrite
+      if uri == rewrite then return Request{..} else Left $ httpRedirect rewrite
-  Nothing -> return $ Right Request{..}
+  Nothing -> return Request{..}
 
 main :: IO ()
 main = do
-  rulesets <- getRulesets
+  rules <- getRulesets
-  runProxySettings $ defaultProxySettings { proxyRequestModifier = tryHTTPS rulesets }
+  runProxySettings $ defaultProxySettings
+    { proxyRequestModifier = return . tryHTTPS rules }

src/Data/HTTPSEverywhere/Rules.hs

@@ -8,17 +8,25 @@ module Data.HTTPSEverywhere.Rules (
 import Prelude hiding (null, head)
 import Control.Lens ((<&>),(&))
 import Data.Bool (bool)
+import Data.Functor.Infix ((<$$>), (<$$$>))
 import Data.Maybe (fromMaybe)
 import Network.HTTP.Client (Cookie)
 import Network.URI (URI)
 import Pipes ((>->))
 import Pipes.Prelude (head, null)
 import Control.Monad (join)
+import Control.Monad.Identity (Identity(runIdentity))
 import Data.HTTPSEverywhere.Rules.Internal (getRulesets, getRulesetsMatching, havingRulesThatTrigger, havingCookieRulesThatTrigger, setSecureFlag, RuleSet)
 
-rewriteURL :: [RuleSet] -> URI -> IO URI
+rewriteURL' :: Monad m => [RuleSet] -> URI -> m URI
-rewriteURL rs url = getRulesetsMatching rs url >-> havingRulesThatTrigger url & head <&> fromMaybe url . join
+rewriteURL' rs url = getRulesetsMatching rs url >-> havingRulesThatTrigger url & head <&> fromMaybe url . join
 
-rewriteCookie :: [RuleSet] -> URI -> Cookie -> IO Cookie
+rewriteURL :: [RuleSet] -> URI -> URI
-rewriteCookie rs url cookie = null producer <&> setSecureFlag cookie `bool` cookie
+rewriteURL = runIdentity <$$> rewriteURL'
+
+rewriteCookie' :: Monad m => [RuleSet] -> URI -> Cookie -> m Cookie
+rewriteCookie' rs url cookie = null producer <&> setSecureFlag cookie `bool` cookie
   where producer = getRulesetsMatching rs url >-> havingCookieRulesThatTrigger cookie
+
+rewriteCookie :: [RuleSet] -> URI -> Cookie -> Cookie
+rewriteCookie = runIdentity <$$$> rewriteCookie'

src/Data/HTTPSEverywhere/Rules/Internal.hs

@@ -33,21 +33,21 @@ import Data.HTTPSEverywhere.Rules.Internal.Types (RuleSet(..), Target(..), Exclu
 
 getRulesets' :: Producer RuleSet IO ()
 getRulesets' = lift Raw.getRules
-          >>= flip (for . each) (flip (for . each) yield <=< lift . (parseRuleSets <$$> Raw.getRule))
+           >>= flip (for . each) (flip (for . each) yield <=< lift . (parseRuleSets <$$> Raw.getRule))
 
 getRulesets :: IO [RuleSet]
 getRulesets = toListM getRulesets'
 
-getRulesetsMatching :: [RuleSet] -> URI -> Producer RuleSet IO ()
+getRulesetsMatching :: Monad m => [RuleSet] -> URI -> Producer RuleSet m ()
 getRulesetsMatching rs url = each rs
                          >-> filter (flip hasTargetMatching url)
                          >-> filter (not . flip hasExclusionMatching url)
 
-havingRulesThatTrigger :: URI -> Pipe RuleSet (Maybe URI) IO ()
+havingRulesThatTrigger :: Monad m => URI -> Pipe RuleSet (Maybe URI) m ()
 havingRulesThatTrigger url = flip hasTriggeringRuleOn url <$> await 
                          >>= maybe (havingRulesThatTrigger url) (yield . Just)
 
-havingCookieRulesThatTrigger :: Cookie -> Pipe RuleSet Bool IO ()
+havingCookieRulesThatTrigger :: Monad m => Cookie -> Pipe RuleSet Bool m ()
 havingCookieRulesThatTrigger cookie = flip hasTriggeringCookieRuleOn cookie <$> await
                                   >>= bool (havingCookieRulesThatTrigger cookie) (yield True)