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.master
parent
c8fa18c5f4
commit
00d2341394
|
@ -12,9 +12,5 @@ connections when possible."
|
||||||
λ: rules <- getRulesets
|
λ: rules <- getRulesets
|
||||||
λ: let Just it = parseURI "http://httpsnow.org"
|
λ: let Just it = parseURI "http://httpsnow.org"
|
||||||
λ: rewriteURL rules it
|
λ: rewriteURL rules it
|
||||||
https://httpsnow.org
|
Just 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}]
|
|
||||||
```
|
```
|
||||||
|
|
|
@ -7,6 +7,7 @@ import qualified "foldl" Control.Foldl as Foldl
|
||||||
import "base" Control.Monad (forever)
|
import "base" Control.Monad (forever)
|
||||||
import "base" Data.Bool (bool)
|
import "base" Data.Bool (bool)
|
||||||
import "https-everywhere-rules" Data.HTTPSEverywhere.Rules (rewriteURL, RuleSet, getRulesets)
|
import "https-everywhere-rules" Data.HTTPSEverywhere.Rules (rewriteURL, RuleSet, getRulesets)
|
||||||
|
import "base" Data.Maybe (isJust)
|
||||||
import "base" Data.Monoid (Sum(..))
|
import "base" Data.Monoid (Sum(..))
|
||||||
import "network-uri" Network.URI (URI, parseURI)
|
import "network-uri" Network.URI (URI, parseURI)
|
||||||
import "pipes" Pipes (Pipe, Producer, lift, yield, await, (>->))
|
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
|
parse = forever $ parseURI <$> await >>= maybe (return ()) yield
|
||||||
|
|
||||||
check :: [RuleSet] -> Pipe URI Bool IO ()
|
check :: [RuleSet] -> Pipe URI Bool IO ()
|
||||||
check rs = forever $ do
|
check rs = forever $ await >>= yield . isJust . rewriteURL rs
|
||||||
src <- await
|
|
||||||
yield $ src /= rewriteURL rs src
|
|
||||||
|
|
||||||
fold :: Monad m => Fold a b -> Producer a m () -> m b
|
fold :: Monad m => Fold a b -> Producer a m () -> m b
|
||||||
fold (Fold step begin done) = Pipes.fold step begin done
|
fold (Fold step begin done) = Pipes.fold step begin done
|
||||||
|
|
|
@ -4,6 +4,7 @@
|
||||||
|
|
||||||
module Main (main) where
|
module Main (main) where
|
||||||
|
|
||||||
|
import "base" Data.Maybe (maybe)
|
||||||
import "base" Data.Monoid ((<>))
|
import "base" Data.Monoid ((<>))
|
||||||
import "bytestring" Data.ByteString.Char8 (pack, unpack)
|
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(..))
|
||||||
|
@ -17,9 +18,7 @@ httpRedirect to = responseLBS status302 [("Location", pack . show $ to)] ""
|
||||||
|
|
||||||
tryHTTPS :: [RuleSet] -> Request -> Either Response Request
|
tryHTTPS :: [RuleSet] -> Request -> Either Response Request
|
||||||
tryHTTPS rs Request{..} = case parseURI . unpack $ requestPath <> queryString of
|
tryHTTPS rs Request{..} = case parseURI . unpack $ requestPath <> queryString of
|
||||||
Just uri ->
|
Just uri -> maybe (return Request{..}) (Left . httpRedirect) (rewriteURL rs uri)
|
||||||
let rewrite = rewriteURL rs uri in
|
|
||||||
if uri == rewrite then return Request{..} else Left $ httpRedirect rewrite
|
|
||||||
Nothing -> return Request{..}
|
Nothing -> return Request{..}
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
|
|
|
@ -6,27 +6,24 @@ module Data.HTTPSEverywhere.Rules (
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prelude hiding (null, head)
|
import Prelude hiding (null, head)
|
||||||
import Control.Lens ((<&>),(&))
|
|
||||||
import Data.Bool (bool)
|
import Data.Bool (bool)
|
||||||
import Data.Functor.Infix ((<$$>), (<$$$>))
|
import Data.Functor.Infix ((<$$>), (<$$$>))
|
||||||
import Data.Maybe (fromMaybe)
|
|
||||||
import Network.HTTP.Client (Cookie)
|
import Network.HTTP.Client (Cookie)
|
||||||
import Network.URI (URI)
|
import Network.URI (URI)
|
||||||
import Pipes ((>->))
|
import Pipes ((>->))
|
||||||
import Pipes.Prelude (head, null)
|
import Pipes.Prelude (head, null)
|
||||||
import Control.Monad (join)
|
|
||||||
import Control.Monad.Identity (Identity(runIdentity))
|
import Control.Monad.Identity (Identity(runIdentity))
|
||||||
import Data.HTTPSEverywhere.Rules.Internal (getRulesets, getRulesetsMatching, havingRulesThatTrigger, havingCookieRulesThatTrigger, setSecureFlag, RuleSet)
|
import Data.HTTPSEverywhere.Rules.Internal (getRulesets, getRulesetsMatching, havingRulesThatTrigger, havingCookieRulesThatTrigger, setSecureFlag, RuleSet)
|
||||||
|
|
||||||
rewriteURL' :: Monad m => [RuleSet] -> URI -> m URI
|
rewriteURL' :: Monad m => [RuleSet] -> URI -> m (Maybe URI)
|
||||||
rewriteURL' rs url = getRulesetsMatching rs url >-> havingRulesThatTrigger url & head <&> fromMaybe url . join
|
rewriteURL' rs url = head $ getRulesetsMatching rs url >-> havingRulesThatTrigger url
|
||||||
|
|
||||||
rewriteURL :: [RuleSet] -> URI -> URI
|
rewriteURL :: [RuleSet] -> (URI -> Maybe URI)
|
||||||
rewriteURL = runIdentity <$$> rewriteURL'
|
rewriteURL = runIdentity <$$> rewriteURL'
|
||||||
|
|
||||||
rewriteCookie' :: Monad m => [RuleSet] -> URI -> Cookie -> m Cookie
|
rewriteCookie' :: Monad m => [RuleSet] -> URI -> Cookie -> m (Maybe Cookie)
|
||||||
rewriteCookie' rs url cookie = null producer <&> setSecureFlag cookie `bool` cookie
|
rewriteCookie' rs url cookie = Just (setSecureFlag cookie) `bool` Nothing <$> null producer
|
||||||
where producer = getRulesetsMatching rs url >-> havingCookieRulesThatTrigger cookie
|
where producer = getRulesetsMatching rs url >-> havingCookieRulesThatTrigger cookie
|
||||||
|
|
||||||
rewriteCookie :: [RuleSet] -> URI -> Cookie -> Cookie
|
rewriteCookie :: [RuleSet] -> URI -> (Cookie -> Maybe Cookie)
|
||||||
rewriteCookie = runIdentity <$$$> rewriteCookie'
|
rewriteCookie = runIdentity <$$$> rewriteCookie'
|
||||||
|
|
|
@ -43,9 +43,9 @@ getRulesetsMatching rs url = each rs
|
||||||
>-> filter (flip hasTargetMatching url)
|
>-> filter (flip hasTargetMatching url)
|
||||||
>-> filter (not . flip hasExclusionMatching 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
|
havingRulesThatTrigger url = flip hasTriggeringRuleOn url <$> await
|
||||||
>>= maybe (havingRulesThatTrigger url) (yield . Just)
|
>>= maybe (havingRulesThatTrigger url) yield
|
||||||
|
|
||||||
havingCookieRulesThatTrigger :: Monad m => Cookie -> Pipe RuleSet Bool m ()
|
havingCookieRulesThatTrigger :: Monad m => Cookie -> Pipe RuleSet Bool m ()
|
||||||
havingCookieRulesThatTrigger cookie = flip hasTriggeringCookieRuleOn cookie <$> await
|
havingCookieRulesThatTrigger cookie = flip hasTriggeringCookieRuleOn cookie <$> await
|
||||||
|
|
Loading…
Reference in New Issue