    {-# LANGUAGE DeriveDataTypeable #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE NoMonomorphismRestriction #-}
    {-# LANGUAGE CPP #-}

    {-|
    This script parses the public suffix list, and constructs a data structure which can
    be used with the isSuffix function in Lookup.hs. It exports a GSink which produces
    the opaque 'DataStructure' and can be fed any Source as input.

    This makes an few assumption about the information in the public suffix list:
    namely, that no rule is a suffix of another rule. For example, if there is a rule
    abc.def.ghi
    then then is no other rule
    def.ghi
    or
    !def.ghi

    The actual data structure involved here is a tree where the nodes have no value and
    the edges are DNS labels. There are two trees: one to handle the exception rules,
    and one to handle the regular rules.
    -}

    module Network.PublicSuffixList.Create (PublicSuffixListException, sink) where

    import           Control.Exception
    import           Control.Monad.Catch (MonadThrow)
    import qualified Data.ByteString      as BS
    import qualified Data.Conduit         as C
    import qualified Data.Conduit.List    as CL
    import qualified Data.Conduit.Text    as CT
    import           Data.Default
    import qualified Data.Map             as M
    import qualified Data.Text            as T
    import           Data.Typeable
    import           Text.IDNA

    import           Network.PublicSuffixList.Types

    data PublicSuffixListException = PublicSuffixListException
      deriving (Int -> PublicSuffixListException -> ShowS
    [PublicSuffixListException] -> ShowS
    PublicSuffixListException -> String
    (Int -> PublicSuffixListException -> ShowS)
    -> (PublicSuffixListException -> String)
    -> ([PublicSuffixListException] -> ShowS)
    -> Show PublicSuffixListException
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> PublicSuffixListException -> ShowS
    showsPrec :: Int -> PublicSuffixListException -> ShowS
    $cshow :: PublicSuffixListException -> String
    show :: PublicSuffixListException -> String
    $cshowList :: [PublicSuffixListException] -> ShowS
    showList :: [PublicSuffixListException] -> ShowS
    Show, Typeable)

    instance Exception PublicSuffixListException

    insert :: (Ord e) => Tree e -> [e] -> Tree e
    insert :: forall e. Ord e => Tree e -> [e] -> Tree e
    insert Tree e
    _ [] = Tree e
    forall a. Default a => a
    def
    insert Tree e
    t (e
    p : [e]
    ps) = case e -> Map e (Tree e) -> Maybe (Tree e)
    forall k a. Ord k => k -> Map k a -> Maybe a
    M.lookup e
    p (Map e (Tree e) -> Maybe (Tree e))
    -> Map e (Tree e) -> Maybe (Tree e)
    forall a b. (a -> b) -> a -> b
    $ Tree e -> Map e (Tree e)
    forall e. Tree e -> Map e (Tree e)
    children Tree e
    t of
      Maybe (Tree e)
    Nothing -> Tree e
    t { children :: Map e (Tree e)
    children = e -> Tree e -> Map e (Tree e) -> Map e (Tree e)
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    M.insert e
    p (Tree e -> [e] -> Tree e
    forall e. Ord e => Tree e -> [e] -> Tree e
    insert Tree e
    forall a. Default a => a
    def [e]
    ps) (Map e (Tree e) -> Map e (Tree e))
    -> Map e (Tree e) -> Map e (Tree e)
    forall a b. (a -> b) -> a -> b
    $ Tree e -> Map e (Tree e)
    forall e. Tree e -> Map e (Tree e)
    children Tree e
    t }
      Just Tree e
    l -> Tree e
    t { children :: Map e (Tree e)
    children = e -> Tree e -> Map e (Tree e) -> Map e (Tree e)
    forall k a. Ord k => k -> a -> Map k a -> Map k a
    M.insert e
    p (Tree e -> [e] -> Tree e
    forall e. Ord e => Tree e -> [e] -> Tree e
    insert Tree e
    l [e]
    ps) (Map e (Tree e) -> Map e (Tree e))
    -> Map e (Tree e) -> Map e (Tree e)
    forall a b. (a -> b) -> a -> b
    $ Tree e -> Map e (Tree e)
    forall e. Tree e -> Map e (Tree e)
    children Tree e
    t }

    foldingFunction :: DataStructure -> T.Text -> DataStructure
    foldingFunction :: DataStructure -> Text -> DataStructure
    foldingFunction d :: DataStructure
    d@(Tree Text
    rules, Tree Text
    exceptions) Text
    s'
      | Text -> Bool
    T.null Text
    s = DataStructure
    d
      | Int -> Text -> Text
    T.take Int
    2 Text
    s Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "//" = DataStructure
    d
      | HasCallStack => Text -> Char
    Text -> Char
    T.head Text
    s Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '!' = (Tree Text
    rules, Tree Text -> [Text] -> Tree Text
    forall e. Ord e => Tree e -> [e] -> Tree e
    insert Tree Text
    exceptions ([Text] -> Tree Text) -> [Text] -> Tree Text
    forall a b. (a -> b) -> a -> b
    $ Text -> [Text]
    labelList (Text -> [Text]) -> Text -> [Text]
    forall a b. (a -> b) -> a -> b
    $ HasCallStack => Text -> Text
    Text -> Text
    T.tail Text
    s)
      | Bool
    otherwise = (Tree Text -> [Text] -> Tree Text
    forall e. Ord e => Tree e -> [e] -> Tree e
    insert Tree Text
    rules ([Text] -> Tree Text) -> [Text] -> Tree Text
    forall a b. (a -> b) -> a -> b
    $ Text -> [Text]
    labelList Text
    s, Tree Text
    exceptions)
      where ss :: [Text]
    ss = (Text -> Bool) -> [Text] -> [Text]
    forall a. (a -> Bool) -> [a] -> [a]
    filter (Bool -> Bool
    not (Bool -> Bool) -> (Text -> Bool) -> Text -> Bool
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> Bool
    T.null) ([Text] -> [Text]) -> [Text] -> [Text]
    forall a b. (a -> b) -> a -> b
    $ Text -> [Text]
    T.words Text
    s'
            s :: Text
    s
              | [Text] -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null [Text]
    ss = Text
    ""
              | Bool
    otherwise = [Text] -> Text
    forall a. HasCallStack => [a] -> a
    head [Text]
    ss
            labelList :: Text -> [Text]
    labelList = [Text] -> [Text]
    forall a. [a] -> [a]
    reverse ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Text -> Text) -> [Text] -> [Text]
    forall a b. (a -> b) -> [a] -> [b]
    map Text -> Text
    internationalize ([Text] -> [Text]) -> (Text -> [Text]) -> Text -> [Text]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Char -> Bool) -> Text -> [Text]
    T.split (Char -> Char -> Bool
    forall a. Eq a => a -> a -> Bool
    == Char
    '.')
            internationalize :: Text -> Text
    internationalize Text
    str
              | Text
    str Text -> Text -> Bool
    forall a. Eq a => a -> a -> Bool
    == Text
    "*" = Text
    str
              | Bool
    otherwise = case Bool -> Bool -> Text -> Maybe Text
    toASCII Bool
    False Bool
    True (Text -> Maybe Text) -> Text -> Maybe Text
    forall a b. (a -> b) -> a -> b
    $ Text -> Text
    T.toLower Text
    str of
                              Just Text
    x -> Text
    x
                              Maybe Text
    Nothing -> PublicSuffixListException -> Text
    forall a e. Exception e => e -> a
    throw PublicSuffixListException
    PublicSuffixListException

    {-
    Generate the opaque 'DataStructure'
    -}
    sink :: MonadThrow m => C.Sink BS.ByteString m DataStructure
    sink :: forall (m :: * -> *).
    MonadThrow m =>
    Sink ByteString m DataStructure
    sink = Codec -> ConduitT ByteString Text m ()
    forall (m :: * -> *).
    MonadThrow m =>
    Codec -> ConduitT ByteString Text m ()
    CT.decode Codec
    CT.utf8 ConduitT ByteString Text m ()
    -> ConduitT Text Void m DataStructure
    -> ConduitT ByteString Void m DataStructure
    forall (m :: * -> *) a b c r.
    Monad m =>
    Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
    C.=$ ConduitT Text Text m ()
    forall (m :: * -> *). Monad m => ConduitT Text Text m ()
    CT.lines ConduitT Text Text m ()
    -> ConduitT Text Void m DataStructure
    -> ConduitT Text Void m DataStructure
    forall (m :: * -> *) a b c r.
    Monad m =>
    Conduit a m b -> ConduitT b c m r -> ConduitT a c m r
    C.=$ (DataStructure -> Text -> DataStructure)
    -> DataStructure -> ConduitT Text Void m DataStructure
    forall (m :: * -> *) b a o.
    Monad m =>
    (b -> a -> b) -> b -> ConduitT a o m b
    CL.fold DataStructure -> Text -> DataStructure
    foldingFunction DataStructure
    forall a. Default a => a
    def