diff --git a/examples/CountUpgradeable.hs b/examples/CountUpgradeable.hs index 5b04dd1..2888f27 100644 --- a/examples/CountUpgradeable.hs +++ b/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 /= 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 diff --git a/examples/RedirectProxy.hs b/examples/RedirectProxy.hs index 13c08a9..3dfe2ba 100644 --- a/examples/RedirectProxy.hs +++ b/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 - 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 } diff --git a/src/Data/HTTPSEverywhere/Rules.hs b/src/Data/HTTPSEverywhere/Rules.hs index c20d186..0af322f 100644 --- a/src/Data/HTTPSEverywhere/Rules.hs +++ b/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 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' diff --git a/src/Data/HTTPSEverywhere/Rules/Internal.hs b/src/Data/HTTPSEverywhere/Rules/Internal.hs index f4f1843..9a7ec0b 100644 --- a/src/Data/HTTPSEverywhere/Rules/Internal.hs +++ b/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)