Broken domain logic.
This commit is contained in:
parent
e154ef7404
commit
5060883c5a
|
@ -3,13 +3,23 @@ module Data.HTTPSEverywhere.Rules (
|
||||||
rewriteCookie
|
rewriteCookie
|
||||||
) where
|
) where
|
||||||
|
|
||||||
|
import Prelude hiding (take, null)
|
||||||
|
import Control.Applicative ((<$))
|
||||||
|
import Control.Lens ((<&>))
|
||||||
|
import Data.Bool (bool)
|
||||||
import Data.Text (Text)
|
import Data.Text (Text)
|
||||||
import Network.HTTP.Client (Cookie)
|
import Network.HTTP.Client (Cookie)
|
||||||
|
import Pipes (runEffect, (>->))
|
||||||
|
import Pipes.Prelude (take, null)
|
||||||
|
|
||||||
import Data.HTTPSEverywhere.Rules.Internal ()
|
import Data.HTTPSEverywhere.Rules.Internal (getRulesetsMatching, havingRulesThatTrigger, havingCookieRulesThatTrigger, setSecureFlag)
|
||||||
|
|
||||||
rewriteURL :: Text -> IO Text
|
rewriteURL :: Text -> IO (Maybe Text)
|
||||||
rewriteURL = undefined
|
rewriteURL url = runEffect
|
||||||
|
$ (Nothing <$ getRulesetsMatching url)
|
||||||
|
>-> (Nothing <$ havingRulesThatTrigger url)
|
||||||
|
>-> (Nothing <$ take 1)
|
||||||
|
|
||||||
rewriteCookie :: Cookie -> IO Cookie
|
rewriteCookie :: Text -> Cookie -> IO Cookie
|
||||||
rewriteCookie = undefined
|
rewriteCookie url cookie = null producer <&> setSecureFlag cookie `bool` cookie
|
||||||
|
where producer = getRulesetsMatching url >-> (() <$ havingCookieRulesThatTrigger cookie)
|
||||||
|
|
|
@ -1,15 +1,59 @@
|
||||||
module Data.HTTPSEverywhere.Rules.Internal (
|
module Data.HTTPSEverywhere.Rules.Internal (
|
||||||
getRulesets
|
getRulesetsMatching,
|
||||||
|
havingRulesThatTrigger,
|
||||||
|
havingCookieRulesThatTrigger,
|
||||||
|
setSecureFlag
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Prelude hiding (readFile)
|
import Prelude hiding (readFile, filter)
|
||||||
import Control.Monad ((<=<))
|
import Control.Applicative ((<*>), (<$>))
|
||||||
|
import Control.Lens ((&))
|
||||||
|
import Control.Monad ((<=<), join)
|
||||||
|
import Data.Bool (bool)
|
||||||
import Data.Functor.Infix ((<$$>))
|
import Data.Functor.Infix ((<$$>))
|
||||||
import Data.HTTPSEverywhere.Rules.Raw (getRule, getRules)
|
import Data.List (find)
|
||||||
import Pipes (Producer, for, each, yield, lift)
|
import Data.Maybe (isJust)
|
||||||
|
import qualified Data.HTTPSEverywhere.Rules.Raw as Raw (getRule, getRules)
|
||||||
|
import Data.Text (Text)
|
||||||
|
import Network.HTTP.Client (Cookie(..))
|
||||||
|
import Pipes (Producer, Consumer, for, each, await, yield, lift, (>->))
|
||||||
|
import Pipes.Prelude (filter)
|
||||||
|
|
||||||
import Data.HTTPSEverywhere.Rules.Internal.Parser (parseRuleSets)
|
import Data.HTTPSEverywhere.Rules.Internal.Parser (parseRuleSets)
|
||||||
import Data.HTTPSEverywhere.Rules.Internal.Types (RuleSet)
|
import Data.HTTPSEverywhere.Rules.Internal.Types (RuleSet(..), Target(..), Exclusion(..), Rule(..), CookieRule(..))
|
||||||
|
|
||||||
getRulesets :: Producer RuleSet IO ()
|
getRulesets :: Producer RuleSet IO ()
|
||||||
getRulesets = lift getRules >>= flip (for . each) (flip (for . each) yield <=< lift . (parseRuleSets <$$> getRule))
|
getRulesets = lift Raw.getRules
|
||||||
|
>>= flip (for . each) (flip (for . each) yield <=< lift . (parseRuleSets <$$> Raw.getRule))
|
||||||
|
|
||||||
|
getRulesetsMatching :: Text -> Producer RuleSet IO ()
|
||||||
|
getRulesetsMatching url = getRulesets
|
||||||
|
>-> filter (flip hasTargetMatching url)
|
||||||
|
>-> filter (not . flip hasExclusionMatching url)
|
||||||
|
|
||||||
|
havingRulesThatTrigger :: Text -> Consumer RuleSet IO (Maybe Text)
|
||||||
|
havingRulesThatTrigger url = flip hasTriggeringRuleOn url <$> await
|
||||||
|
>>= maybe (havingRulesThatTrigger url) (return . Just)
|
||||||
|
|
||||||
|
havingCookieRulesThatTrigger :: Cookie -> Consumer RuleSet IO Bool
|
||||||
|
havingCookieRulesThatTrigger cookie = flip hasTriggeringCookieRuleOn cookie <$> await
|
||||||
|
>>= bool (havingCookieRulesThatTrigger cookie) (return True)
|
||||||
|
|
||||||
|
hasTargetMatching :: RuleSet -> Text -> Bool
|
||||||
|
hasTargetMatching ruleset url = getTargets ruleset <*> [url] & or
|
||||||
|
where getTargets = getTarget <$$> ruleSetTargets
|
||||||
|
|
||||||
|
hasExclusionMatching :: RuleSet -> Text -> Bool
|
||||||
|
hasExclusionMatching ruleset url = getExclusions ruleset <*> [url] & or & not
|
||||||
|
where getExclusions = getExclusion <$$> ruleSetExclusions
|
||||||
|
|
||||||
|
hasTriggeringRuleOn :: RuleSet -> Text -> Maybe Text -- Nothing ~ False
|
||||||
|
hasTriggeringRuleOn ruleset url = getRules ruleset <*> [url] & find isJust & join
|
||||||
|
where getRules = getRule <$$> ruleSetRules
|
||||||
|
|
||||||
|
hasTriggeringCookieRuleOn :: RuleSet -> Cookie -> Bool
|
||||||
|
hasTriggeringCookieRuleOn ruleset cookie = getCookieRules ruleset <*> [cookie] & or
|
||||||
|
where getCookieRules = getCookieRule <$$> ruleSetCookieRules
|
||||||
|
|
||||||
|
setSecureFlag :: Cookie -> Cookie
|
||||||
|
setSecureFlag cookie = cookie { cookie_secure_only = True }
|
||||||
|
|
Loading…
Reference in a new issue