From 00d234139419278fc7d59e9b7f149b3bd35cb23a Mon Sep 17 00:00:00 2001 From: vi Date: Mon, 11 Dec 2017 05:52:40 +0100 Subject: [PATCH] Tighten some loops, change more interface. This will save.. five comparisons.. occasionally? But it's a more transparent design, and it seems more charitable to group interface changes together. --- README.md | 6 +----- examples/CountUpgradeable.hs | 5 ++--- examples/RedirectProxy.hs | 5 ++--- src/Data/HTTPSEverywhere/Rules.hs | 15 ++++++--------- src/Data/HTTPSEverywhere/Rules/Internal.hs | 4 ++-- 5 files changed, 13 insertions(+), 22 deletions(-) diff --git a/README.md b/README.md index f7ad137..7c50ced 100644 --- a/README.md +++ b/README.md @@ -12,9 +12,5 @@ connections when possible." λ: rules <- getRulesets λ: let Just it = parseURI "http://httpsnow.org" λ: rewriteURL rules it -https://httpsnow.org -λ: :m + Network.HTTP.Client Network.HTTP.Client.TLS Control.Applicative Control.Lens -λ: (req, hub) <- (,) <*> getUri <$> parseUrl "https://github.com/fmap/https-everywhere-rules" -λ: newManager tlsManagerSettings >>= httpNoBody req <&> destroyCookieJar . responseCookieJar >>= mapM (rewriteCookie rules hub) -[Cookie {cookie_name = "_gh_sess", cookie_value = "eyJzZXNzaW9uX2lkIjoiNjBlM2FiOTIxNTdhZTNhNDE5YWQ0ZTk4ZWQzNDRjMjEiLCJzcHlfcmVwbyI6ImZtYXAvaHR0cHMtZXZlcnl3aGVyZS1ydWxlcyIsInNweV9yZXBvX2F0IjoxNDA4ODk2OTM2LCJfY3NyZl90b2tlbiI6IktkbTlwN2JqNGptVmhrYjFIUm9BbkV0a1JTQXRDUXJid2g4VWo4N1g0Q1U9In0%3D--d378daa262b8c12bb82246d5de6b3adc353a3db7", cookie_expiry_time = 3013-12-25 00:00:00 UTC, cookie_domain = "github.com", cookie_path = "/", cookie_creation_time = 2014-08-24 16:15:37.815144 UTC, cookie_last_access_time = 2014-08-24 16:15:37.815144 UTC, cookie_persistent = False, cookie_host_only = True, cookie_secure_only = True, cookie_http_only = True},Cookie {cookie_name = "logged_in", cookie_value = "no", cookie_expiry_time = 2034-08-24 16:15:36 UTC, cookie_domain = "github.com", cookie_path = "/", cookie_creation_time = 2014-08-24 16:15:37.815144 UTC, cookie_last_access_time = 2014-08-24 16:15:37.815144 UTC, cookie_persistent = True, cookie_host_only = False, cookie_secure_only = True, cookie_http_only = True}] +Just https://httpsnow.org ``` diff --git a/examples/CountUpgradeable.hs b/examples/CountUpgradeable.hs index 2888f27..7d58dd0 100644 --- a/examples/CountUpgradeable.hs +++ b/examples/CountUpgradeable.hs @@ -7,6 +7,7 @@ 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 "base" Data.Maybe (isJust) import "base" Data.Monoid (Sum(..)) import "network-uri" Network.URI (URI, parseURI) import "pipes" Pipes (Pipe, Producer, lift, yield, await, (>->)) @@ -17,9 +18,7 @@ parse :: Monad m => Pipe String URI m () parse = forever $ parseURI <$> await >>= maybe (return ()) yield check :: [RuleSet] -> Pipe URI Bool IO () -check rs = forever $ do - src <- await - yield $ src /= rewriteURL rs src +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 diff --git a/examples/RedirectProxy.hs b/examples/RedirectProxy.hs index 3dfe2ba..f4ba4fa 100644 --- a/examples/RedirectProxy.hs +++ b/examples/RedirectProxy.hs @@ -4,6 +4,7 @@ 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(..)) @@ -17,9 +18,7 @@ httpRedirect to = responseLBS status302 [("Location", pack . show $ to)] "" tryHTTPS :: [RuleSet] -> Request -> Either Response Request tryHTTPS rs Request{..} = case parseURI . unpack $ requestPath <> queryString of - Just uri -> - let rewrite = rewriteURL rs uri in - if uri == rewrite then return Request{..} else Left $ httpRedirect rewrite + Just uri -> maybe (return Request{..}) (Left . httpRedirect) (rewriteURL rs uri) Nothing -> return Request{..} main :: IO () diff --git a/src/Data/HTTPSEverywhere/Rules.hs b/src/Data/HTTPSEverywhere/Rules.hs index 0af322f..e8cb96d 100644 --- a/src/Data/HTTPSEverywhere/Rules.hs +++ b/src/Data/HTTPSEverywhere/Rules.hs @@ -6,27 +6,24 @@ module Data.HTTPSEverywhere.Rules ( ) where 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' :: Monad m => [RuleSet] -> URI -> m URI -rewriteURL' rs url = getRulesetsMatching rs url >-> havingRulesThatTrigger url & head <&> fromMaybe url . join +rewriteURL' :: Monad m => [RuleSet] -> URI -> m (Maybe URI) +rewriteURL' rs url = head $ getRulesetsMatching rs url >-> havingRulesThatTrigger url -rewriteURL :: [RuleSet] -> URI -> URI +rewriteURL :: [RuleSet] -> (URI -> Maybe URI) rewriteURL = runIdentity <$$> rewriteURL' -rewriteCookie' :: Monad m => [RuleSet] -> URI -> Cookie -> m Cookie -rewriteCookie' rs url cookie = null producer <&> setSecureFlag cookie `bool` cookie +rewriteCookie' :: Monad m => [RuleSet] -> URI -> Cookie -> m (Maybe Cookie) +rewriteCookie' rs url cookie = Just (setSecureFlag cookie) `bool` Nothing <$> null producer where producer = getRulesetsMatching rs url >-> havingCookieRulesThatTrigger cookie -rewriteCookie :: [RuleSet] -> URI -> Cookie -> Cookie +rewriteCookie :: [RuleSet] -> URI -> (Cookie -> Maybe Cookie) rewriteCookie = runIdentity <$$$> rewriteCookie' diff --git a/src/Data/HTTPSEverywhere/Rules/Internal.hs b/src/Data/HTTPSEverywhere/Rules/Internal.hs index 9a7ec0b..ae8c09f 100644 --- a/src/Data/HTTPSEverywhere/Rules/Internal.hs +++ b/src/Data/HTTPSEverywhere/Rules/Internal.hs @@ -43,9 +43,9 @@ getRulesetsMatching rs url = each rs >-> filter (flip hasTargetMatching url) >-> filter (not . flip hasExclusionMatching url) -havingRulesThatTrigger :: Monad m => URI -> Pipe RuleSet (Maybe URI) m () +havingRulesThatTrigger :: Monad m => URI -> Pipe RuleSet URI m () havingRulesThatTrigger url = flip hasTriggeringRuleOn url <$> await - >>= maybe (havingRulesThatTrigger url) (yield . Just) + >>= maybe (havingRulesThatTrigger url) yield havingCookieRulesThatTrigger :: Monad m => Cookie -> Pipe RuleSet Bool m () havingCookieRulesThatTrigger cookie = flip hasTriggeringCookieRuleOn cookie <$> await