packages feed

https-everywhere-rules (empty) → 0.0.1

raw patch · 10 files changed

+376/−0 lines, 10 filesdep +attoparsecdep +basedep +errorssetup-changed

Dependencies added: attoparsec, base, errors, functor-infix, hspec, http-client, https-everywhere-rules-raw, lens, network, pipes, string-conversions, taggy-lens, text, text-icu

Files

+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,28 @@+[https-everywhere-rules](https://github.com/fmap/https-everywhere-rules)+========================================================================++Haskell package providing high-level access to [HTTPS Everywhere][1]+rulesets. This makes it easier to tell other programs: "I'd like if you+used secure HTTP connections when possible."++  [1]: https://www.eff.org/https-everywhere++```haskell+λ: :m + Data.HTTPSEverywhere.Rules Network.URI+λ: let Just eff = parseURI "http://www.eff.org/document/eff-and-aclu-amicus-brief-klayman"+λ: rewriteURL eff+Just https://www.eff.org/document/eff-and-aclu-amicus-brief-klayman+λ: :m + Web.Cookie Network.HTTP.Client Data.Time.Clock Control.Applicative+λ: :set -XOverloadedStrings+λ: (now, req) <- (,) <$> getCurrentTime <*> parseUrl "https://github.com"+λ: let (Just gh, Just ck) = (parseURI "https://github.com", generateCookie (def{setCookieDomain=Just "github.com"}) req now True)+λ: rewriteCookie gh ck+Cookie {cookie_name = "name", cookie_value = "value", cookie_expiry_time = 3013-12-25 00:00:00 UTC, cookie_domain = "github.com", cookie_path = "/", cookie_creation_time = 2014-08-24 05:58:20.691866 UTC, cookie_last_access_time = 2014-08-24 05:58:20.691866 UTC, cookie_persistent = False, cookie_host_only = False, cookie_secure_only = True, cookie_http_only = False}+```++Rules are provided via [`https-everywhere-rules-raw`][2], which is+versioned consistently with upstream releases. Thus, the version of+the rule database used here is configurable via the installed version of+that package.++  [2]: https://github.com/fmap/https-everywhere-rules-raw
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ https-everywhere-rules.cabal view
@@ -0,0 +1,83 @@+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,+    Data.Text.ICU.Extras+  build-depends:+    base               >= 4.7  && < 4.8,+    attoparsec         >= 0.12 && < 0.13,+    errors             >= 1.4  && < 1.5,+    functor-infix      >= 0.0  && < 0.1,+    http-client        >= 0.3  && < 0.4,+    lens               >= 4.3  && < 4.4,+    network            >= 2.5  && < 2.6,+    pipes              >= 4.1  && < 4.2,+    string-conversions >= 0.3  && < 0.4,+    taggy-lens         >= 0.1  && < 0.2,+    text               >= 1.1  && < 1.2,+    text-icu           >= 0.6  && < 0.7,+    https-everywhere-rules-raw+  hs-source-dirs:+    src+  default-language:+    Haskell2010+  ghc-options:+    -Wall++test-suite spec+  type:+    exitcode-stdio-1.0+  build-depends:+    base               >= 4.7  && < 4.8,+    attoparsec         >= 0.12 && < 0.13,+    errors             >= 1.4  && < 1.5,+    functor-infix      >= 0.0  && < 0.1,+    hspec              >= 1.10 && < 1.12,+    http-client        >= 0.3  && < 0.4,+    lens               >= 4.3  && < 4.4,+    network            >= 2.5  && < 2.6,+    pipes              >= 4.1  && < 4.2,+    string-conversions >= 0.3  && < 0.4,+    taggy-lens         >= 0.1  && < 0.2,+    text               >= 1.1  && < 1.2,+    text-icu           >= 0.6  && < 0.7,+    https-everywhere-rules-raw+  main-is:+    Spec.hs+  hs-source-dirs:+    src,+    test+  default-language:+    Haskell2010+  cpp-options:+    -DTEST+  ghc-options:+    -Wall
+ src/Data/HTTPSEverywhere/Rules.hs view
@@ -0,0 +1,21 @@+module Data.HTTPSEverywhere.Rules (+  rewriteURL,+  rewriteCookie+) where++import Prelude hiding (null, head)+import Control.Lens ((<&>),(&))+import Data.Bool (bool)+import Network.HTTP.Client (Cookie)+import Network.URI (URI)+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 = 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
+ src/Data/HTTPSEverywhere/Rules/Internal.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE CPP #-}++module Data.HTTPSEverywhere.Rules.Internal (+  getRulesetsMatching,+  havingRulesThatTrigger,+  havingCookieRulesThatTrigger,+  setSecureFlag,+#ifdef TEST+  hasTargetMatching,+  hasTriggeringRuleOn,+  hasExclusionMatching+#endif+) where++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.List (find)+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 (Pipe, Producer, for, each, await, yield, lift, (>->))+import Pipes.Prelude (filter)++import Data.HTTPSEverywhere.Rules.Internal.Parser (parseRuleSets)+import Data.HTTPSEverywhere.Rules.Internal.Types (RuleSet(..), Target(..), Exclusion(..), Rule(..), CookieRule(..))++getRulesets :: Producer RuleSet IO ()+getRulesets = lift Raw.getRules+          >>= flip (for . each) (flip (for . each) yield <=< lift . (parseRuleSets <$$> Raw.getRule))++getRulesetsMatching :: URI -> Producer RuleSet IO ()+getRulesetsMatching url = getRulesets+                      >-> filter (flip hasTargetMatching url)+                      >-> filter (not . flip hasExclusionMatching url)++havingRulesThatTrigger :: URI -> Pipe RuleSet (Maybe URI) IO ()+havingRulesThatTrigger url = flip hasTriggeringRuleOn url <$> await +                         >>= maybe (havingRulesThatTrigger url) (yield . Just)++havingCookieRulesThatTrigger :: Cookie -> Pipe RuleSet Bool IO ()+havingCookieRulesThatTrigger cookie = flip hasTriggeringCookieRuleOn cookie <$> await+                                  >>= bool (havingCookieRulesThatTrigger cookie) (yield True)++hasTargetMatching :: RuleSet -> URI -> Bool+hasTargetMatching ruleset url = getTargets ruleset <*> [url] & or+  where getTargets = getTarget <$$> ruleSetTargets++hasExclusionMatching :: RuleSet -> URI -> Bool+hasExclusionMatching ruleset url = getExclusions ruleset <*> [url] & or+  where getExclusions = getExclusion <$$> ruleSetExclusions++hasTriggeringRuleOn :: RuleSet -> URI -> Maybe URI -- 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 }
+ src/Data/HTTPSEverywhere/Rules/Internal/Parser.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}++module Data.HTTPSEverywhere.Rules.Internal.Parser (+  parseRuleSets,+#ifdef TEST+  parseTarget+#endif+) where++import Prelude hiding (head, last, tail, init)+import Control.Lens (toListOf, only, to, (^..), (^.), (&), (<&>), _Just)+import Control.Monad (join)+import Data.Functor.Infix ((<$>),(<$$>))+import Data.Maybe (catMaybes, fromJust, fromMaybe)+import Data.String.Conversions (cs)+import qualified Data.Text as Strict (Text)+import Data.Text (append, head, last, tail, init, replace)+import qualified Data.Text.Lazy as Lazy (Text)+import Network.HTTP.Client (Cookie(..))+import Network.URI (URI(uriAuthority), URIAuth(uriRegName), parseURI)+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 "host" . _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 . checkRegName . fromJust . match . fromWildcard . replace "." "\\."+  where fromWildcard str+          | head str == '*' = flip append ".*" $ tail str+          | last str == '*' = append ".*" $ init str+          | otherwise       = str+        checkRegName predicate = fromMaybe False . (predicate <$$> getRegName)+        getRegName = cs . uriRegName <$$> uriAuthority++parseRule :: Element -> Maybe Rule+parseRule element = do+  pattern     <- element ^. attr "from"+  replacement <- element ^. attr "to"+  substitute  <- findAndReplace pattern replacement +  return . Rule $ join . fmap (parseURI . cs) . substitute . cs . show++parseExclusion :: Strict.Text -> Maybe Exclusion+parseExclusion = Exclusion . (. cs . show) <$$> match++parseCookieRule :: Element -> Maybe CookieRule+parseCookieRule element = CookieRule <$> do+  hostMatches <- element ^. attr "host" . to (>>= match)+  nameMatches <- element ^. attr "name" . to (>>= match)+  return $ \Cookie{..} -> nameMatches (cs cookie_name) && hostMatches (cs cookie_domain)
+ src/Data/HTTPSEverywhere/Rules/Internal/Types.hs view
@@ -0,0 +1,24 @@+module Data.HTTPSEverywhere.Rules.Internal.Types (+  RuleSet(..),+  Target(..),+  Rule(..),+  Exclusion(..),+  CookieRule(..)+) where++import Data.Text (Text)+import Network.HTTP.Client (Cookie)+import Network.URI (URI)++newtype Rule       = Rule       { getRule :: URI -> Maybe URI     }+newtype Target     = Target     { getTarget :: URI  -> Bool       }+newtype Exclusion  = Exclusion  { getExclusion :: URI -> Bool     }+newtype CookieRule = CookieRule { getCookieRule :: Cookie -> Bool }++data RuleSet = RuleSet+  { ruleSetName        :: Text+  , ruleSetTargets     :: [Target]+  , ruleSetRules       :: [Rule]+  , ruleSetExclusions  :: [Exclusion]+  , ruleSetCookieRules :: [CookieRule]+  }
+ src/Data/Text/ICU/Extras.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE CPP                         #-}+{-# LANGUAGE LambdaCase                  #-}+{-# LANGUAGE OverloadedStrings           #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}++module Data.Text.ICU.Extras (+  match,+  findAndReplace,+#ifdef TEST+  Segment(..),+  parseReplacement+#endif+) where++import Prelude hiding (span)+import Control.Applicative ((<$>), (<*>), (*>), (<|>))+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(mconcat))+import Data.Text (Text)+import Data.Text.ICU (regex', find, findAll, group, span, Match, suffix, groupCount)++match :: Text -> Maybe (Text -> Bool)+match = isJust <$$> find <$$> hush . regex' []++findAndReplace :: Text -> Text -> Maybe (Text -> Maybe Text)+findAndReplace pattern replacement = do+  findAnd <- findAll <$$> hush $ regex' [] pattern+  replace <- flip runReplacement <$> parseReplacement replacement+  return $ replace . findAnd++type Replacement = [Segment]++data Segment = Reference Int | Literal Text+  deriving (Show, Eq)++parseReference :: Parser Segment+parseReference = char '$' *> digit <&> Reference . read . return++parseLiteral :: Parser Segment+parseLiteral = Literal <$> takeWhile1 (/= '$')++parseLiteralDollar :: Parser Segment+parseLiteralDollar = Literal <$> string "$"++parseSegment :: Parser Segment+parseSegment = parseLiteral <|> parseReference <|> parseLiteralDollar++parseReplacement :: Text -> Maybe Replacement+parseReplacement = hush . parseOnly (many' parseSegment)++runReplacement :: [Match] -> Replacement -> Maybe Text+runReplacement matches replacement = mconcat <$$> invert . adornSuffix matches $ do+  match <- matches+  Just (span match) : map (dereference $ flip group match) replacement++adornSuffix :: [Match] -> ([Maybe Text] -> [Maybe Text])+adornSuffix = \case {[] -> id; ms -> (++ [flip suffix <*> groupCount $ last ms])}++dereference :: (Int -> Maybe Text) -> Segment -> Maybe Text+dereference group = \case+  Reference n -> group n+  Literal str -> Just str++invert :: [Maybe a] -> Maybe [a]+invert xs | all isJust xs = Just $ fromJust <$> xs+          | otherwise     = Nothing
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}