56 lines
2.4 KiB
Haskell
56 lines
2.4 KiB
Haskell
{-# LANGUAGE MultiWayIf #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE RecordWildCards #-}
|
|
|
|
module Data.HTTPSEverywhere.Rules.Internal.Parser (
|
|
parseRuleSets
|
|
) where
|
|
|
|
import Prelude hiding (head, last, tail, init)
|
|
import Control.Lens (toListOf, only, to, (^..), (^.), (&), (<&>), _Just)
|
|
import Data.Functor.Infix ((<$>),(<$$>))
|
|
import Data.Maybe (catMaybes, fromJust)
|
|
import Data.String.Conversions (cs)
|
|
import qualified Data.Text as Strict (Text)
|
|
import Data.Text (append, head, last, tail, init)
|
|
import qualified Data.Text.Lazy as Lazy (Text)
|
|
import Network.HTTP.Client (Cookie(..))
|
|
import Text.Taggy.Lens (html, allNamed, attr, Element)
|
|
|
|
import Data.HTTPSEverywhere.Rules.Internal.Types (RuleSet(..), Target(..), Rule(..), Exclusion(..), CookieRule(..))
|
|
import Data.Text.ICU.Extras (match, findAndReplace)
|
|
|
|
parseRuleSets :: Lazy.Text -> [RuleSet]
|
|
parseRuleSets = catMaybes <$$> toListOf $ html . allNamed (only "ruleset") . to parseRuleSet
|
|
|
|
parseRuleSet :: Element -> Maybe RuleSet
|
|
parseRuleSet xml = xml ^. attr "name" <&> \ruleSetName -> do
|
|
let ruleSetTargets = xml ^.. allNamed (only "target") . attr "name" . _Just . to parseTarget
|
|
ruleSetRules = xml ^.. allNamed (only "rule") . to parseRule & catMaybes
|
|
ruleSetExclusions = xml ^.. allNamed (only "exclusion") . attr "pattern" . _Just . to parseExclusion & catMaybes
|
|
ruleSetCookieRules = xml ^.. allNamed (only "securecookie") . to parseCookieRule & catMaybes
|
|
RuleSet ruleSetName ruleSetTargets ruleSetRules ruleSetExclusions ruleSetCookieRules
|
|
|
|
parseTarget :: Strict.Text -> Target
|
|
parseTarget = Target . fromJust . match . fromWildcard
|
|
where fromWildcard str = if
|
|
| head str == '*' -> prepend ".*" $ tail str
|
|
| last str == '*' -> append ".*" $ init str
|
|
| otherwise -> str
|
|
prepend = flip append
|
|
|
|
parseRule :: Element -> Maybe Rule
|
|
parseRule element = do
|
|
pattern <- element ^. attr "from"
|
|
replace <- element ^. attr "to"
|
|
findAndReplace pattern replace <&> Rule
|
|
|
|
parseExclusion :: Strict.Text -> Maybe Exclusion
|
|
parseExclusion = Exclusion <$$> match
|
|
|
|
parseCookieRule :: Element -> Maybe CookieRule
|
|
parseCookieRule element = CookieRule <$> do
|
|
hostMatches <- element ^. attr "host" . to (>>= match)
|
|
nameMatches <- element ^. attr "name" . to (>>= match)
|
|
return $ \Cookie{..} -> hostMatches (cs cookie_name) && nameMatches (cs cookie_domain)
|