Broken domain logic.
This commit is contained in:
parent
e154ef7404
commit
5060883c5a
|
@ -3,13 +3,23 @@ module Data.HTTPSEverywhere.Rules (
|
|||
rewriteCookie
|
||||
) where
|
||||
|
||||
import Prelude hiding (take, null)
|
||||
import Control.Applicative ((<$))
|
||||
import Control.Lens ((<&>))
|
||||
import Data.Bool (bool)
|
||||
import Data.Text (Text)
|
||||
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 = undefined
|
||||
rewriteURL :: Text -> IO (Maybe Text)
|
||||
rewriteURL url = runEffect
|
||||
$ (Nothing <$ getRulesetsMatching url)
|
||||
>-> (Nothing <$ havingRulesThatTrigger url)
|
||||
>-> (Nothing <$ take 1)
|
||||
|
||||
rewriteCookie :: Cookie -> IO Cookie
|
||||
rewriteCookie = undefined
|
||||
rewriteCookie :: Text -> Cookie -> IO Cookie
|
||||
rewriteCookie url cookie = null producer <&> setSecureFlag cookie `bool` cookie
|
||||
where producer = getRulesetsMatching url >-> (() <$ havingCookieRulesThatTrigger cookie)
|
||||
|
|
|
@ -1,15 +1,59 @@
|
|||
module Data.HTTPSEverywhere.Rules.Internal (
|
||||
getRulesets
|
||||
getRulesetsMatching,
|
||||
havingRulesThatTrigger,
|
||||
havingCookieRulesThatTrigger,
|
||||
setSecureFlag
|
||||
) where
|
||||
|
||||
import Prelude hiding (readFile)
|
||||
import Control.Monad ((<=<))
|
||||
import Prelude hiding (readFile, filter)
|
||||
import Control.Applicative ((<*>), (<$>))
|
||||
import Control.Lens ((&))
|
||||
import Control.Monad ((<=<), join)
|
||||
import Data.Bool (bool)
|
||||
import Data.Functor.Infix ((<$$>))
|
||||
import Data.HTTPSEverywhere.Rules.Raw (getRule, getRules)
|
||||
import Pipes (Producer, for, each, yield, lift)
|
||||
import Data.List (find)
|
||||
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.Types (RuleSet)
|
||||
import Data.HTTPSEverywhere.Rules.Internal.Types (RuleSet(..), Target(..), Exclusion(..), Rule(..), CookieRule(..))
|
||||
|
||||
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