Incomplete parser for HTTPS Everywhere rulesets.
commit
f78421e09f
|
@ -0,0 +1 @@
|
|||
dist/
|
|
@ -0,0 +1,2 @@
|
|||
* HTTPSEverywhere rewrites are expressed using Javascript regular expressions,
|
||||
our parser uses ICU. What are the differences between these two languages?
|
|
@ -0,0 +1,20 @@
|
|||
Copyright (c) 2014 vi
|
||||
|
||||
Permission is hereby granted, free of charge, to any person obtaining
|
||||
a copy of this software and associated documentation files (the
|
||||
"Software"), to deal in the Software without restriction, including
|
||||
without limitation the rights to use, copy, modify, merge, publish,
|
||||
distribute, sublicense, and/or sell copies of the Software, and to
|
||||
permit persons to whom the Software is furnished to do so, subject to
|
||||
the following conditions:
|
||||
|
||||
The above copyright notice and this permission notice shall be included
|
||||
in all copies or substantial portions of the Software.
|
||||
|
||||
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
||||
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
||||
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
|
||||
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
|
||||
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
|
||||
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
|
||||
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
|
|
@ -0,0 +1,8 @@
|
|||
[https-everywhere-rules](https://github.com/fmap/https-everywhere-rules)
|
||||
========================================================================
|
||||
|
||||
![](https://encrypted-tbn0.gstatic.com/images?q=tbn:ANd9GcTqn7bFPbRaxk-XU6PWLnbTvo7MtjGMFQw4RA4SZ0u23vzUS7AD5Q)
|
||||
|
||||
Haskell package providing high-level access to [HTTPS Everywhere][1] rulesets.
|
||||
|
||||
[1]: https://www.eff.org/https-everywhere
|
|
@ -0,0 +1,51 @@
|
|||
name:
|
||||
https-everywhere-rules
|
||||
version:
|
||||
0.0.1
|
||||
synopsis:
|
||||
High-level access to HTTPS Everywhere rulesets.
|
||||
homepage:
|
||||
https://github.com/fmap/https-everywhere-rules
|
||||
license:
|
||||
MIT
|
||||
license-file:
|
||||
LICENSE
|
||||
author:
|
||||
vi
|
||||
maintainer:
|
||||
vi@zalora.com
|
||||
category:
|
||||
Data
|
||||
build-type:
|
||||
Simple
|
||||
extra-source-files:
|
||||
README.md
|
||||
cabal-version:
|
||||
>=1.10
|
||||
|
||||
library
|
||||
exposed-modules:
|
||||
Data.HTTPSEverywhere.Rules
|
||||
other-modules:
|
||||
Data.HTTPSEverywhere.Rules.Internal,
|
||||
Data.HTTPSEverywhere.Rules.Internal.Parser,
|
||||
Data.HTTPSEverywhere.Rules.Internal.Types
|
||||
build-depends:
|
||||
base >= 4.7 && < 4.8,
|
||||
attoparsec >= 0.12 && < 0.13,
|
||||
http-client >= 0.3 && < 0.4,
|
||||
https-everywhere-rules-raw >= 4.0 && < 4.1,
|
||||
text >= 1.1 && < 1.2,
|
||||
pipes >= 4.1 && < 4.2,
|
||||
errors >= 1.4 && < 1.5,
|
||||
lens >= 4.3 && < 4.4,
|
||||
functor-infix >= 0.0 && < 0.1,
|
||||
string-conversions >= 0.3 && < 0.4,
|
||||
text-icu >= 0.6 && < 0.7,
|
||||
taggy-lens >= 0.1 && < 0.2
|
||||
hs-source-dirs:
|
||||
src
|
||||
default-language:
|
||||
Haskell2010
|
||||
ghc-options:
|
||||
-Wall
|
|
@ -0,0 +1,15 @@
|
|||
module Data.HTTPSEverywhere.Rules (
|
||||
rewriteURL,
|
||||
rewriteCookie
|
||||
) where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Network.HTTP.Client (Cookie)
|
||||
|
||||
import Data.HTTPSEverywhere.Rules.Internal ()
|
||||
|
||||
rewriteURL :: Text -> IO Text
|
||||
rewriteURL = undefined
|
||||
|
||||
rewriteCookie :: Cookie -> IO Cookie
|
||||
rewriteCookie = undefined
|
|
@ -0,0 +1,15 @@
|
|||
module Data.HTTPSEverywhere.Rules.Internal (
|
||||
getRulesets
|
||||
) where
|
||||
|
||||
import Prelude hiding (readFile)
|
||||
import Control.Monad ((<=<))
|
||||
import Data.Functor.Infix ((<$$>))
|
||||
import Data.HTTPSEverywhere.Rules.Raw (getRule, getRules)
|
||||
import Pipes (Producer, for, each, yield, lift)
|
||||
|
||||
import Data.HTTPSEverywhere.Rules.Internal.Parser (parseRuleSets)
|
||||
import Data.HTTPSEverywhere.Rules.Internal.Types (RuleSet)
|
||||
|
||||
getRulesets :: Producer RuleSet IO ()
|
||||
getRulesets = lift getRules >>= flip (for . each) (flip (for . each) yield <=< lift . (parseRuleSets <$$> getRule))
|
|
@ -0,0 +1,55 @@
|
|||
{-# 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)
|
|
@ -0,0 +1,23 @@
|
|||
module Data.HTTPSEverywhere.Rules.Internal.Types (
|
||||
RuleSet(..),
|
||||
Target(..),
|
||||
Rule(..),
|
||||
Exclusion(..),
|
||||
CookieRule(..)
|
||||
) where
|
||||
|
||||
import Data.Text (Text)
|
||||
import Network.HTTP.Client (Cookie)
|
||||
|
||||
newtype Rule = Rule { getRule :: Text -> Maybe Text }
|
||||
newtype Target = Target { getTarget :: Text -> Bool }
|
||||
newtype Exclusion = Exclusion { getExclusion :: Text -> Bool }
|
||||
newtype CookieRule = CookieRule { getCookieRule :: Cookie -> Bool }
|
||||
|
||||
data RuleSet = RuleSet
|
||||
{ ruleSetName :: Text
|
||||
, ruleSetTargets :: [Target]
|
||||
, ruleSetRules :: [Rule]
|
||||
, ruleSetExclusions :: [Exclusion]
|
||||
, ruleSetCookieRules :: [CookieRule]
|
||||
}
|
|
@ -0,0 +1,56 @@
|
|||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# OPTIONS_GHC -fno-warn-name-shadowing #-}
|
||||
|
||||
module Data.Text.ICU.Extras (
|
||||
match,
|
||||
findAndReplace
|
||||
) where
|
||||
|
||||
import Control.Applicative ((<$>), (*>), (<*>), (<|>))
|
||||
import Control.Monad ((<=<))
|
||||
import Control.Error (hush)
|
||||
import Data.Attoparsec.Text (Parser, char, digit, takeWhile1, string, many', parseOnly)
|
||||
import Data.Functor.Infix ((<$$>), (<&>))
|
||||
import Data.Maybe (isJust, fromJust)
|
||||
import Data.Monoid (Monoid(mappend,mconcat))
|
||||
import Data.Text (Text)
|
||||
import Data.Text.ICU (regex', find, group, Match)
|
||||
|
||||
match :: Text -> Maybe (Text -> Bool)
|
||||
match = isJust <$$> find <$$> hush . regex' []
|
||||
|
||||
findAndReplace :: Text -> Text -> Maybe (Text -> Maybe Text)
|
||||
findAndReplace pattern replacement = do
|
||||
findAnd <- find <$$> hush $ regex' [] pattern
|
||||
replace <- flip runReplacement <$> parseReplacement replacement
|
||||
return $ replace <=< findAnd
|
||||
|
||||
type Replacement = [Segment]
|
||||
|
||||
data Segment = Reference Int | Literal Text deriving (Show)
|
||||
|
||||
parseReference :: Parser Segment
|
||||
parseReference = char '$' *> digit <&> Reference . read . return
|
||||
|
||||
parseLiteral :: Parser Segment
|
||||
parseLiteral = Literal <$> takeWhile1 (/= '$')
|
||||
|
||||
parseLiteralWithPrecedingDollar :: Parser Segment
|
||||
parseLiteralWithPrecedingDollar = Literal <$$> mappend <$> string "$" <*> takeWhile1 (/= '$')
|
||||
|
||||
parseSegment :: Parser Segment
|
||||
parseSegment = parseLiteral <|> parseReference <|> parseLiteralWithPrecedingDollar
|
||||
|
||||
parseReplacement :: Text -> Maybe Replacement
|
||||
parseReplacement = hush . parseOnly (many' parseSegment)
|
||||
|
||||
runReplacement :: Match -> Replacement -> Maybe Text
|
||||
runReplacement (flip group -> group) = mconcat <$$> invert . map dereference
|
||||
where dereference = \case
|
||||
Reference n -> group n
|
||||
Literal str -> Just str
|
||||
invert xs = if all isJust xs
|
||||
then Just $ fromJust <$> xs
|
||||
else Nothing
|
Loading…
Reference in New Issue