{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE CPP #-}
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
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