{-# LANGUAGE OverloadedStrings #-}
module Network.PublicSuffixList.Lookup (effectiveTLDPlusOne, effectiveTLDPlusOne', isSuffix, isSuffix') where

import qualified Data.Map          as M
import           Data.Maybe (isNothing)
import qualified Data.Text         as T

import qualified Network.PublicSuffixList.DataStructure as DS
import           Network.PublicSuffixList.Types

{-|
OffEnd's Bool argument represents whether we fell off a
leaf or whether we fell off a non-leaf. True means that
we fell off a leaf. Its Text argument is the component
that pushed us off the end, along with all the components
to the right of that one, interspersed with "."s
-}
data LookupResult = Inside | AtLeaf | OffEnd Bool T.Text
  deriving (LookupResult -> LookupResult -> Bool
(LookupResult -> LookupResult -> Bool)
-> (LookupResult -> LookupResult -> Bool) -> Eq LookupResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LookupResult -> LookupResult -> Bool
$c/= :: LookupResult -> LookupResult -> Bool
== :: LookupResult -> LookupResult -> Bool
$c== :: LookupResult -> LookupResult -> Bool
Eq)

{-|
This function returns whether or not this domain is owned by a
registrar or a regular person. 'Nothing' means that this is a registrar
domain; 'Just x' means it's owned by a person. This is used to determine
if a cookie is allowed to bet set for a particular domain. For
example, you shouldn't be able to set a cookie for \"com\".

If the value is 'Just x', then the x value is what is known as the
effective TLD plus one. This is one segment more than the suffix of the
domain. For example, the eTLD+1 for "this.is.a.subdom.com" is Just
"subdom.com"

Note that this function expects lowercase ASCII strings. These strings
should be gotten from the toASCII algorithm as described in RFC 3490.
These strings should not start or end with the \'.\' character, and should
not have two \'.\' characters next to each other.
(The toASCII algorithm is implemented in the \'idna\' hackage package,
though that package doesn't always map strings to lowercase)
-}
effectiveTLDPlusOne' :: DataStructure -> T.Text -> Maybe T.Text
effectiveTLDPlusOne' :: DataStructure -> Text -> Maybe Text
effectiveTLDPlusOne' DataStructure
dataStructure Text
s
  -- Any TLD is a suffix
  | [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ss Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 = Maybe Text
forall a. Maybe a
Nothing
  | Bool
otherwise = LookupResult -> LookupResult -> Maybe Text
output LookupResult
rulesResult LookupResult
exceptionResult
  where ss :: [Text]
ss = HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
s
        ps :: [Text]
ps = [Text] -> [Text]
forall a. [a] -> [a]
reverse [Text]
ss
        exceptionResult :: LookupResult
exceptionResult = [Text] -> [Text] -> Tree Text -> LookupResult
recurse [Text]
ps [] (Tree Text -> LookupResult) -> Tree Text -> LookupResult
forall a b. (a -> b) -> a -> b
$ DataStructure -> Tree Text
forall a b. (a, b) -> b
snd DataStructure
dataStructure
        rulesResult :: LookupResult
rulesResult = [Text] -> [Text] -> Tree Text -> LookupResult
recurse [Text]
ps [] (Tree Text -> LookupResult) -> Tree Text -> LookupResult
forall a b. (a -> b) -> a -> b
$ DataStructure -> Tree Text
forall a b. (a, b) -> a
fst DataStructure
dataStructure
        -- If we fell off, did we do it at a leaf? Otherwise, what's the
        -- subtree that we're at
        getNext :: Tree T.Text -> T.Text -> Either Bool (Tree T.Text)
        getNext :: Tree Text -> Text -> Either Bool (Tree Text)
getNext Tree Text
t Text
s' = case Text -> Map Text (Tree Text) -> Maybe (Tree Text)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Text
s' (Map Text (Tree Text) -> Maybe (Tree Text))
-> Map Text (Tree Text) -> Maybe (Tree Text)
forall a b. (a -> b) -> a -> b
$ Tree Text -> Map Text (Tree Text)
forall e. Tree e -> Map e (Tree e)
children Tree Text
t of
          Maybe (Tree Text)
Nothing -> Bool -> Either Bool (Tree Text)
forall a b. a -> Either a b
Left (Map Text (Tree Text) -> Bool
forall k a. Map k a -> Bool
M.null (Map Text (Tree Text) -> Bool) -> Map Text (Tree Text) -> Bool
forall a b. (a -> b) -> a -> b
$ Tree Text -> Map Text (Tree Text)
forall e. Tree e -> Map e (Tree e)
children Tree Text
t)
          Just Tree Text
t' -> Tree Text -> Either Bool (Tree Text)
forall a b. b -> Either a b
Right Tree Text
t'
        -- Look up the component we're looking for...
        getNextWithStar :: Tree Text -> Text -> Either Bool (Tree Text)
getNextWithStar Tree Text
t Text
s' = case Tree Text -> Text -> Either Bool (Tree Text)
getNext Tree Text
t Text
s' of
          -- and if that fails, look up "*"
          Left Bool
_ -> Tree Text -> Text -> Either Bool (Tree Text)
getNext Tree Text
t Text
"*"
          Either Bool (Tree Text)
r -> Either Bool (Tree Text)
r
        recurse :: [T.Text] -> [T.Text] -> Tree T.Text -> LookupResult
        recurse :: [Text] -> [Text] -> Tree Text -> LookupResult
recurse [] [Text]
_ Tree Text
t
          | Map Text (Tree Text) -> Bool
forall k a. Map k a -> Bool
M.null (Map Text (Tree Text) -> Bool) -> Map Text (Tree Text) -> Bool
forall a b. (a -> b) -> a -> b
$ Tree Text -> Map Text (Tree Text)
forall e. Tree e -> Map e (Tree e)
children Tree Text
t = LookupResult
AtLeaf
          | Bool
otherwise = LookupResult
Inside
        recurse (Text
c : [Text]
cs) [Text]
prev Tree Text
t = case Tree Text -> Text -> Either Bool (Tree Text)
getNextWithStar Tree Text
t Text
c of
          Left Bool
b -> Bool -> Text -> LookupResult
OffEnd Bool
b (Text -> LookupResult) -> Text -> LookupResult
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"." (Text
c Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
prev)
          Right Tree Text
t' -> [Text] -> [Text] -> Tree Text -> LookupResult
recurse [Text]
cs (Text
c Text -> [Text] -> [Text]
forall a. a -> [a] -> [a]
: [Text]
prev) Tree Text
t'
        -- Only match against the exception rules if we have a full match
        output :: LookupResult -> LookupResult -> Maybe Text
output LookupResult
_ LookupResult
AtLeaf = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
s
        output LookupResult
_ (OffEnd Bool
True Text
x) = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"." ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ [Text] -> [Text]
forall a. [a] -> [a]
tail ([Text] -> [Text]) -> [Text] -> [Text]
forall a b. (a -> b) -> a -> b
$ HasCallStack => Text -> Text -> [Text]
Text -> Text -> [Text]
T.splitOn Text
"." Text
x
        -- If we have a subdomain on an existing rule, we're not a suffix
        output (OffEnd Bool
_ Text
x) LookupResult
_
          -- A single level domain can never be a eTLD+1
          | Maybe Char -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Char -> Bool) -> Maybe Char -> Bool
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> Maybe Char
T.find (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') Text
x = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> Text -> Maybe Text
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"." ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$ Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
drop ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
ss Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
2) [Text]
ss
          | Bool
otherwise = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
x
        -- Otherwise, we're a suffix of a suffix, which is a suffix
        output LookupResult
_ LookupResult
_ = Maybe Text
forall a. Maybe a
Nothing

-- | >>> effectiveTLDPlusOne = effectiveTLDPlusOne' Network.PublicSuffixList.DataStructure.dataStructure
effectiveTLDPlusOne :: T.Text -> Maybe T.Text
effectiveTLDPlusOne :: Text -> Maybe Text
effectiveTLDPlusOne = DataStructure -> Text -> Maybe Text
effectiveTLDPlusOne' DataStructure
DS.dataStructure

-- | >>> isSuffix' dataStructure = isNothing . effectiveTLDPlusOne' dataStructure
isSuffix' :: DataStructure -> T.Text -> Bool
isSuffix' :: DataStructure -> Text -> Bool
isSuffix' DataStructure
dataStructure = Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Text -> Bool) -> (Text -> Maybe Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataStructure -> Text -> Maybe Text
effectiveTLDPlusOne' DataStructure
dataStructure

-- | >>> isSuffix = isSuffix' Network.PublicSuffixList.DataStructure.dataStructure
isSuffix :: T.Text -> Bool
isSuffix :: Text -> Bool
isSuffix = Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Text -> Bool) -> (Text -> Maybe Text) -> Text -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Text
effectiveTLDPlusOne