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.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)

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)

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 (return () <* char '$' <* requestOptions <* lineEnd) <|> try (return () <* 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 *> return ""

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 '~' *> return 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 = join.liftA 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) => 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 $ nub p) (nub n)
        deduplicate a = a