content: {-# LANGUAGE StrictData #-}
  
  module InputParser (
  Line (..),
  Restrictions (..),
  RequestOptions (..),
  Record (..),
  RequestType (..),
  Pattern,
  Domain,
  Policy (..),
  RecordSource (..),
  adblockFile,
  recordSourceText
  )
  where
  import Control.Applicative hiding ((<|>))
  import Text.ParserCombinators.Parsec hiding (Line, many, optional)
  import Data.List.Utils (split)
  import Data.List
  import Data.Char
  import Data.Containers.ListUtils
  import Data.Functor
  import Data.Monoid
  import Control.Monad
  import Text.Parsec.Permutation
  import System.FilePath
  
  --------------------------------------------------------------------------
  ---------------------------- data model  ---------------------------------
  --------------------------------------------------------------------------
  
  -- composite 
  data Line = Line RecordSource Record
          deriving (Show,Eq)
  
  data RecordSource = RecordSource { _position :: SourcePos, _rawRecord :: String } deriving (Show,Eq)
  data Policy = Block | Unblock deriving (Show, Eq, Read, Ord)
  data Record =   Error String |
                  Comment String |
                  ElementHide (Restrictions Domain) Policy Pattern |
                  RequestBlock Policy Pattern RequestOptions
          deriving (Read,Show,Eq)
  
  data RequestType =  Script | Image | Stylesheet | Object | Xmlhttprequest | Popup |
                      ObjectSubrequest | Subdocument | Document | Other
                      deriving (Read,Show,Eq,Ord)
  
  data RequestOptions = RequestOptions {
                              _requestType :: Restrictions RequestType,
                              _thirdParty  :: Maybe Bool,
                              _domain      :: Restrictions Domain,
                              _matchCase   :: Bool,
                              _collapse    :: Maybe Bool,
                              _doNotTrack  :: Bool,
                              _elemHide    :: Bool,
                              _unknown     :: [String]
                        }
          deriving (Read,Show,Eq)
  
  -- primitive
  type Pattern = String
  type Domain = String
  
  -- helpers
  data Restrictions a = Restrictions {
                            _positive :: Maybe [a],
                            _negative :: [a]}
          deriving (Read,Show,Eq,Ord)
  
  recordSourceText :: RecordSource -> String
  recordSourceText (RecordSource position rawRecord)
     = concat [rawRecord, " (", takeFileName $ sourceName position, ": ", show $ sourceLine position, ")"]
  
  --------------------------------------------------------------------------
  ---------------------------- parsers  ------------------------------------
  --------------------------------------------------------------------------
  
  adblockFile :: Parser [Line]
  adblockFile = header *> sepEndBy line (oneOf eol)
      where
          header = string "[Adblock Plus " <* version <* string "]"  <* lineEnd
          version = join <$> sepBy (many1 digit) (char '.')
  
  
  line :: Parser Line
  line = do
      position <- getPosition
      let text = lookAhead (manyTill anyChar lineEnd)
          sourcePosition = RecordSource position <$> text
      Line <$> sourcePosition <*> choice (try <$> [comment, elementHide, match, unknown]) <?> "filtering rule"
  
  
  
  elementHide :: Parser Record
  elementHide = ElementHide <$> domains ',' <*> excludeMatch <*> pattern
      where
          excludeMatch = char '#' *> ((Block <$ string "#") <|> (Unblock <$ string "@#"))
          pattern = manyTill anyChar (lookAhead lineEnd)
  
  match :: Parser Record
  match = RequestBlock <$> excludeMatch <*> pattern <*> options
      where
          excludeMatch = option Block $ Unblock <$ count 2 (char '@')
          patternEnd = try (void (char '$') <* requestOptions <* lineEnd) <|> try (void lineEnd)
          pattern = manyTill (noneOf "#") (lookAhead patternEnd)
          options = option '$' (char '$') *> requestOptions
  
  comment :: Parser Record
  comment = Comment <$> (separatorLine <|> commentText)
              where commentText = char '!' *> many notLineEnd
                    separatorLine = lookAhead lineEnd $> ""
  
  unknown :: Parser Record
  unknown = Error "Record type detection failed" <$ skipMany notLineEnd
  
  requestOptions :: Parser RequestOptions
  requestOptions = runPermParser $ RequestOptions
                                      <$> (fixRestrictions <$> requestTypes)
                                      <*> (getMaybeAll <$> requestOptionNorm "ThirdParty")
                                      <*> (fixRestrictions <$> optionalDomain)
                                      <*> (getAllOrFalse <$> requestOptionNorm  "MatchCase")
                                      <*> (getMaybeAll <$> requestOptionNorm "Collapse")
                                      <*> (getAllOrFalse <$> requestOptionNorm "Donottrack")
                                      <*> (getAllOrFalse <$> requestOptionNorm "Elemhide")
                                      <* manyPerm separator
                                      <*> unknownOption
      where
          optionalDomain = optionPerm noRestrictions $ try domainOption
          requestTypes = Restrictions <$> (Just <$> manyPerm  (try requestTypeOption)) <*> manyPerm (try notRequestTypeOption)
          notRequestTypeOption = char '~' *> requestTypeOption
          requestOptionNorm = manyPerm.try.requestOption
          separator = try (lineSpaces *> char ',' <* lineSpaces)
          unknownOption = manyPerm $ try optionName
  
  requestOption :: String -> Parser All
  requestOption name = All <$> option True (char '~' $> False) <* checkOptionName name
  
  
  
  requestTypeOption :: Parser RequestType
  requestTypeOption =  do  t <- optionName
                           case reads t of
                              [(result, "")] -> return result
                              _ -> pzero <?> "request type"
  
  
  
  domainOption :: Parser (Restrictions Domain)
  domainOption =  checkOptionName "Domain" *> lineSpaces *> char '=' *> lineSpaces *> domains '|'
  
  optionName :: Parser String
  optionName = asOptionName <$> ((:) <$> letter <*> many (alphaNum <|> char '-'))
                  where
                       capitalize [] = ""
                       capitalize (x:xs) = toUpper x:(toLower<$>xs)
                       ws = split "-"
                       asOptionName = capitalize <=< ws
  
  checkOptionName :: String -> Parser ()
  checkOptionName name =  do t <- optionName
                             when (name /= t) (pzero <?> "option type")
  
  domain :: Parser Domain
  domain = join . intersperse "." <$> parts
              where
              parts = sepBy1 domainPart (char '.')
              domainPart = many1 (alphaNum <|> char '-')
  
  domains :: Char -> Parser (Restrictions Domain)
  domains sep = fixRestrictions <$> runPermParser restrictions
      where
          restrictions = Restrictions <$> (Just <$> manyPerm  (try domain)) <*> manyPerm  (try notDomain) <* manyPerm (try separator)
          separator = lineSpaces *> char sep <* lineSpaces
          notDomain = char '~' *> domain
  
  --helpers
  eol :: String
  eol = "\r\n"
  
  lineSpaces :: Parser ()
  lineSpaces = skipMany (satisfy isLineSpace) <?> "white space"
      where isLineSpace c = c == ' ' || c == '\t'
  
  lineEnd :: Parser Char
  lineEnd = oneOf eol <|> ('\0' <$ eof)
  
  notLineEnd :: Parser Char
  notLineEnd = noneOf eol
  
  
  getMaybeAll :: [All] -> Maybe Bool
  getMaybeAll [] = Nothing
  getMaybeAll list = Just $ getAll $ mconcat list
  
  getAllOrFalse :: [All] -> Bool
  getAllOrFalse [] = False
  getAllOrFalse list = getAll $ mconcat list
  
  noRestrictions :: Restrictions a
  noRestrictions = Restrictions Nothing []
  
  fixRestrictions :: (Eq a, Ord a) => Restrictions a -> Restrictions a
  fixRestrictions = deduplicate.allowAll
          where
          allowAll (Restrictions (Just []) n) = Restrictions Nothing n
          allowAll a = a
          deduplicate (Restrictions (Just p) n) = Restrictions (Just $ nubOrd p) (nubOrd n)
          deduplicate a = a
  