rewrite(URL|Cookie) are now pure.
They have been pure since ed1933f
, but now the types reflect that.
Breaking interface change.
master
parent
b42958031a
commit
c8fa18c5f4
|
@ -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 /= tgt
|
||||
yield $ src /= rewriteURL rs src
|
||||
|
||||
fold :: Monad m => Fold a b -> Producer a m () -> m b
|
||||
fold (Fold step begin done) = Pipes.fold step begin done
|
||||
|
|
|
@ -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
|
||||
then return Request{..}
|
||||
else Left $ httpRedirect rewrite
|
||||
Nothing -> return $ Right Request{..}
|
||||
Just uri ->
|
||||
let rewrite = rewriteURL rs uri in
|
||||
if uri == rewrite then return Request{..} else Left $ httpRedirect rewrite
|
||||
Nothing -> return Request{..}
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
rulesets <- getRulesets
|
||||
runProxySettings $ defaultProxySettings { proxyRequestModifier = tryHTTPS rulesets }
|
||||
rules <- getRulesets
|
||||
runProxySettings $ defaultProxySettings
|
||||
{ proxyRequestModifier = return . tryHTTPS rules }
|
||||
|
|
|
@ -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 rs url = getRulesetsMatching rs url >-> havingRulesThatTrigger url & head <&> fromMaybe url . join
|
||||
rewriteURL' :: Monad m => [RuleSet] -> URI -> m URI
|
||||
rewriteURL' rs url = getRulesetsMatching rs url >-> havingRulesThatTrigger url & head <&> fromMaybe url . join
|
||||
|
||||
rewriteCookie :: [RuleSet] -> URI -> Cookie -> IO Cookie
|
||||
rewriteCookie rs url cookie = null producer <&> setSecureFlag cookie `bool` cookie
|
||||
rewriteURL :: [RuleSet] -> URI -> URI
|
||||
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'
|
||||
|
|
|
@ -38,16 +38,16 @@ getRulesets' = lift Raw.getRules
|
|||
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)
|
||||
|
||||
|
|
Loading…
Reference in New Issue