https-everywhere-else
/
https-everywhere-rules
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Correct pipeline semantics.

master
vi 2014-08-24 12:40:06 +08:00
parent c6c5eae311
commit 5af781291f
3 changed files with 21 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
ref/pipes.txt Normal file
View File

@ -0,0 +1,8 @@
| Upstream output | Upstream input | Downstream input | Downstream output | Base monad | Return value
Proxy a' a b' b m r | a' | a | b' | b | m | r
Effect m r | Void | () | () | Void | m | r
Pipe a b m r | () | a | () | b | m | r
Producer b m r | Void | () | () | b | m | r
Consumer a m r | () | a | () | Void | m | r
Client a' a m r | a' | a | () | Void | m | r
Server b' b m r | Void | () | b' | b | m | r

18
src/Data/HTTPSEverywhere/Rules.hs
View File

@ -3,23 +3,19 @@ module Data.HTTPSEverywhere.Rules (
rewriteCookie
) where
import Prelude hiding (take, null)
import Control.Applicative ((<$))
import Control.Lens ((<&>))
import Prelude hiding (null, head)
import Control.Lens ((<&>),(&))
import Data.Bool (bool)
import Network.HTTP.Client (Cookie)
import Network.URI (URI)
import Pipes (runEffect, (>->))
import Pipes.Prelude (take, null)
import Pipes ((>->))
import Pipes.Prelude (head, null)
import Control.Monad (join)
import Data.HTTPSEverywhere.Rules.Internal (getRulesetsMatching, havingRulesThatTrigger, havingCookieRulesThatTrigger, setSecureFlag)
rewriteURL :: URI -> IO (Maybe URI)
rewriteURL url = runEffect
$ (Nothing <$ getRulesetsMatching url)
>-> (Nothing <$ havingRulesThatTrigger url)
>-> (Nothing <$ take 1)
rewriteURL url = getRulesetsMatching url >-> havingRulesThatTrigger url & head <&> join
rewriteCookie :: URI -> Cookie -> IO Cookie
rewriteCookie url cookie = null producer <&> setSecureFlag cookie `bool` cookie
where producer = getRulesetsMatching url >-> (() <$ havingCookieRulesThatTrigger cookie)
where producer = getRulesetsMatching url >-> havingCookieRulesThatTrigger cookie

12
src/Data/HTTPSEverywhere/Rules/Internal.hs
View File

@ -23,7 +23,7 @@ import Data.Maybe (isJust)
import qualified Data.HTTPSEverywhere.Rules.Raw as Raw (getRule, getRules)
import Network.HTTP.Client (Cookie(..))
import Network.URI (URI)
import Pipes (Producer, Consumer, for, each, await, yield, lift, (>->))
import Pipes (Pipe, Producer, for, each, await, yield, lift, (>->))
import Pipes.Prelude (filter)
import Data.HTTPSEverywhere.Rules.Internal.Parser (parseRuleSets)
@ -38,13 +38,13 @@ getRulesetsMatching url = getRulesets
>-> filter (flip hasTargetMatching url)
>-> filter (not . flip hasExclusionMatching url)
havingRulesThatTrigger :: URI -> Consumer RuleSet IO (Maybe URI)
havingRulesThatTrigger url = flip hasTriggeringRuleOn url <$> await
>>= maybe (havingRulesThatTrigger url) (return . Just)
havingRulesThatTrigger :: URI -> Pipe RuleSet (Maybe URI) IO ()
havingRulesThatTrigger url = flip hasTriggeringRuleOn url <$> await
>>= maybe (havingRulesThatTrigger url) (yield . Just)
havingCookieRulesThatTrigger :: Cookie -> Consumer RuleSet IO Bool
havingCookieRulesThatTrigger :: Cookie -> Pipe RuleSet Bool IO ()
havingCookieRulesThatTrigger cookie = flip hasTriggeringCookieRuleOn cookie <$> await
>>= bool (havingCookieRulesThatTrigger cookie) (return True)
>>= bool (havingCookieRulesThatTrigger cookie) (yield True)
hasTargetMatching :: RuleSet -> URI -> Bool
hasTargetMatching ruleset url = getTargets ruleset <*> [url] & or