content: {-# LANGUAGE StrictData #-}
  
  module PatternConverter (
  makePattern,
  parseUrl
  ) where
  import InputParser
  import Control.Applicative hiding (many)
  import Text.ParserCombinators.Parsec hiding (Line, (<|>))
  import Control.Monad
  import Control.Monad.State
  import Data.List
  import Data.Maybe
  import Data.String.Utils (replace)
  import Data.List.Utils (split)
  import ParsecExt
  import Utils
  
  data SideBind = Hard | Soft | None deriving (Show, Eq)
  
  data UrlPattern = UrlPattern {
                     _bindStart :: SideBind,
                     _proto :: String,
                     _host :: String,
                     _query :: String,
                     _bindEnd :: SideBind,
                     _regex :: Bool }
                deriving (Show)
  
  makePattern :: Bool -> UrlPattern -> Pattern
  makePattern matchCase (UrlPattern bindStart proto host query bindEnd isRegex)
              | query' == "" = host'
              | otherwise    = host' ++ separator' ++ query'
      where
          separator'
              | matchCase = "/(?-i)"
              | otherwise = "/"
          host' = case host of
                      "" -> ""
                      _  -> changeFirst.changeLast $ host
                      where
                      changeLast []                                   = []
                      changeLast ['.', '*']
                          | query' == ""                              = "."
                          | otherwise                                 = ".*"
                      changeLast ['*', '.']
                          | query' == ""                              = "*."
                          | otherwise                                 = "*.*"
                      changeLast [lst]
                          | lst == '|' || lst `elem` hostSeparators   =  []
                          | lst == '*' && query' == ""                =  "*."
                          | lst == '*' && query' /= ""                =  "*"
                          | lst == '.'                                =  "."
                          | otherwise                                 =  lst : "*."
                      changeLast (c:cs) = c : changeLast cs
  
                      changeFirst []    = []
                      changeFirst (first:cs)
                          | first == '*'                       =       '.' :  '*'  : cs
                          | first == '.' || bindStart == Hard || proto /= ""   =       first : cs
                          | bindStart == Soft                  =       '.' : first : cs
                          | otherwise                          = '.' : '*' : first : cs
  
          query' = case query of
                      ""     -> ""
                      (start:other) ->
                                if isRegex then query
                                else case query of
                                  '*' : '/' : other' -> replaceQuery '/' other' True
                                  '*' : '^' : other' -> replaceQuery '^' other' True
                                  _                  -> replaceQuery start other (bindStart == None && host == "")
                                where
                                  replaceQuery c cs openStart = replaceFirst c openStart ++ (join . map replaceWildcard $ cs) ++ queryEnd
                                  {- http://blogs.perl.org/users/mauke/2017/05/converting-glob-patterns-to-efficient-regexes-in-perl-and-javascript.html -}
                                  replaceFirst '*' _ = "(*PRUNE).*?"
                                  replaceFirst c openStart
                                      | c == '/' || c == '^' = if openStart
                                                               then "(?:(*PRUNE).*?" ++ replaceWildcard c ++ ")?"
                                                               else ""
                                      | otherwise            = if openStart
                                                               then "(*PRUNE).*?" ++ replaceWildcard c
                                                               else replaceWildcard c
  
                                  queryEnd = if bindEnd == None then "" else "$"
  
                                  replaceWildcard c
                                      | c == '^'         = "[^\\w%.-]"
                                      | c == '*'         = "(*PRUNE).*?"
                                      | c `elem` special = '\\' : [c]
                                      | otherwise        = [c]
                                      where special = "?$.+[]{}()\\|" -- also ^ and * are special
  
  
  hostSeparators :: String
  hostSeparators = "^/"
  
  parseUrl :: Pattern -> Either ParseError [UrlPattern]
  parseUrl =
      let  raw = makeUrls <$> bindStart <*> cases urlParts <*> bindEnd
      in   parse (join <$> (fmap.fmap) postfilter raw) "url"
      where
          makeUrls start mid end = (makeUrl start <$> mid) <*> pure end
          makeUrl start (proto, host, query) end = UrlPattern start proto (trimTrailingNul host) query end False
  
          bindStart = (try (Soft <$ string "||") <|> try (Hard <$ string "|") <|> return None) <?> "query start"
          queryEnd = (char '|' <* eof) <|> ('\0' <$ eof) <|> char '\0' <?> "query end"
          bindEnd = (\c -> if c == '|' then Hard else None) <$> queryEnd
          port = option False $ many1 (noneOf ":") *> char ':' *> many1 (digit <|> char '*') *> optionMaybe (oneOf "/^") *> (True <$ queryEnd)
  
          trimTrailingNul :: String -> String
          trimTrailingNul [] = []
          trimTrailingNul (c:cs)
              | null cs && c == '\0' = []
              | otherwise             = c : trimTrailingNul cs
  
          hostChar :: Parser Char
          hostChar = alphaNum <|> oneOf ".-:"
  
          protocols :: [String]
          protocols = ["https://", "http://"]
  
          protocolsSeparator :: String
          protocolsSeparator = ";"
  
          protocolChar :: Parser Char
          protocolChar = oneOf (delete '/' $ nub $ join protocols)
  
          postfilter :: UrlPattern -> [UrlPattern]
          postfilter url@(UrlPattern bs proto host query be _) = regular ++ regex -- ++ www
              where
                  regex = if     proto == ""
                              && host == ""
                              && "/" `isPrefixOf` query
                              && length query > 2
                              && "/" `isSuffixOf` query
                              then
                                  let query' = take (length query - 2) . drop 1 $ query
                                  in [UrlPattern bs "" "" query' be True]
                              else []
                  regular = let
                               leftBound = bs /= None || proto /= ""
                               rightBound = be /= None || query /= ""
                               orphanQuery = leftBound && host == "" && query /= "" && not ("*" `isPrefixOf` query)
                               duplicateHostStar = host == "*"
                               hostHasDot = isJust $ find (\c -> c == '.' || c == '*') host
                               firstLevelHost = host /= "" && not hostHasDot && leftBound && rightBound
                               hasLegalPort = case parse port "host" host of
                                                  Right val -> val
                                                  _ -> False
                               hasIllegalPort = not hasLegalPort && ":" `isInfixOf` host
                            in if not (orphanQuery || duplicateHostStar || firstLevelHost || hasIllegalPort)
                               then
                                  let
                                      query' = if "*" `isSuffixOf` host && query /= "" then '*' : query else query
                                  in [url {_query = query'}]
                               else []
  
          -- TODO: process port as an url part
          urlParts :: [StringStateParser (String,String,String)]
          urlParts = square3 proto (manyCases host) (oneCase query)
              where
                  append xs x = xs ++ [x]
                  proto :: StringStateParser String
                  proto = do
                          masksString <- get
                          case masksString of
                              Nothing ->
                                  do
                                  put $ Just $ intercalate protocolsSeparator protocols
                                  return "" --allow to skip proto
                              Just masksString' ->
                                  do
                                  let masks = split protocolsSeparator masksString'
                                  if null masks
                                      then lift pzero -- no continuations available (parser have finished on previous iteration)
                                      else
                                          do
                                          lift $ skipMany $ char '*' --skip leading * if presented
                                          name <- lift $ many1 protocolChar
                                          sep <- lift $ many $ oneOf hostSeparators
                                          let chars = name ++ replace "^" "//" sep -- concatenate input and expand separator wildcard
                                          nextChar <- lift $ lookAhead anyChar
                                          let masks' = filterProtoMasks masks chars nextChar -- find possible continuations for current input
                                          if null masks' || null chars
                                              then lift pzero -- fail parser if no continuations or no chars read
                                              else
                                                  do
                                                  put $ Just $ if isJust (find null masks')  -- if empty continuation found (i.e. parser finished)
                                                                  then "" -- make no continuations available next time
                                                                  else intercalate protocolsSeparator masks'
                                                  return $ if nextChar == '*' then chars ++ "*" else chars
                  host = try (append <$> many hostChar <*> char '*') <|>
                         try (append <$> many1 hostChar <*> lookAhead separator) <?> "host"
                  separator = (oneOf hostSeparators <|> queryEnd) <?> "separator"
                  query = notFollowedBy (try $ string "//") *> manyTill anyChar (lookAhead (try queryEnd)) <?> "query"
  
                  filterProtoMasks :: [String] -> String -> Char -> [String]
                  filterProtoMasks masks chars nextChar = mapMaybe filterProtoMask masks
                      where filterProtoMask mask = if nextChar /= '*'
                                      then if chars `isSuffixOf` mask
                                           then Just ""
                                           else Nothing
                                      else let tailFound = find (chars `isPrefixOf`) (tails mask)
                                           in drop (length chars) <$> tailFound
  