{-# LANGUAGE OverloadedStrings #-}

-- | Validate hostnames.

module Text.Hostname
  (validHostname)
  where

import Control.Applicative
import Data.Attoparsec hiding (Parser)
import Data.Attoparsec.Combinator
import Data.Attoparsec.Types (Parser)
import Data.ByteString (ByteString)
import GHC.Word

--------------------------------------------------------------------------------
-- Exported

-- | Is the input a valid host name?
validHostname :: ByteString -> Bool
validHostname :: ByteString -> Bool
validHostname = Parser ByteString () -> ByteString -> Bool
forall b. Parser ByteString b -> ByteString -> Bool
test (Parser ByteString [[[Word8]]]
host Parser ByteString [[[Word8]]]
-> Parser ByteString () -> Parser ByteString ()
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString ()
forall t. Chunk t => Parser t ()
endOfInput)

--------------------------------------------------------------------------------
-- Parser

-- | Test the given parser on the given input.
test :: Parser ByteString b -> ByteString -> Bool
test :: forall b. Parser ByteString b -> ByteString -> Bool
test Parser ByteString b
p ByteString
x = (String -> Bool) -> (b -> Bool) -> Either String b -> Bool
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Bool -> String -> Bool
forall a b. a -> b -> a
const Bool
False) (Bool -> b -> Bool
forall a b. a -> b -> a
const Bool
True) (Parser ByteString b -> ByteString -> Either String b
forall a. Parser a -> ByteString -> Either String a
parseOnly Parser ByteString b
p ByteString
x)

-- | A host name.
host :: Parser ByteString [[[Word8]]]
host :: Parser ByteString [[[Word8]]]
host = Parser ByteString [[Word8]]
labelStart Parser ByteString [[Word8]]
-> Parser ByteString [[[Word8]]] -> Parser ByteString [[[Word8]]]
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString [[Word8]] -> Parser ByteString [[[Word8]]]
forall a. Parser ByteString a -> Parser ByteString [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ByteString [[Word8]]
label

-- | A name part.
name :: Parser ByteString [Word8]
name :: Parser ByteString [Word8]
name = (Parser ByteString Word8 -> Parser ByteString [Word8]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 (Char -> Parser ByteString Word8
char Char
'-') Parser ByteString [Word8]
-> Parser ByteString [Word8] -> Parser ByteString [Word8]
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString Word8 -> Parser ByteString [Word8]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 Parser ByteString Word8
diglet) Parser ByteString [Word8]
-> Parser ByteString [Word8] -> Parser ByteString [Word8]
forall a.
Parser ByteString a -> Parser ByteString a -> Parser ByteString a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Parser ByteString Word8 -> Parser ByteString [Word8]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many1 Parser ByteString Word8
diglet

-- | A host part.
label :: Parser ByteString [[Word8]]
label :: Parser ByteString [[Word8]]
label = Char -> Parser ByteString Word8
char Char
'.' Parser ByteString Word8
-> Parser ByteString Word8 -> Parser ByteString Word8
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString Word8
diglet Parser ByteString Word8
-> Parser ByteString [[Word8]] -> Parser ByteString [[Word8]]
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString [Word8] -> Parser ByteString [[Word8]]
forall a. Parser ByteString a -> Parser ByteString [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ByteString [Word8]
name

-- | Start of a host part.
labelStart :: Parser ByteString [[Word8]]
labelStart :: Parser ByteString [[Word8]]
labelStart = Parser ByteString Word8
diglet Parser ByteString Word8
-> Parser ByteString [[Word8]] -> Parser ByteString [[Word8]]
forall a b.
Parser ByteString a -> Parser ByteString b -> Parser ByteString b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Parser ByteString [Word8] -> Parser ByteString [[Word8]]
forall a. Parser ByteString a -> Parser ByteString [a]
forall (f :: * -> *) a. Alternative f => f a -> f [a]
many Parser ByteString [Word8]
name

-- | Match the character.
char :: Char -> Parser ByteString Word8
char :: Char -> Parser ByteString Word8
char Char
c = Word8 -> Parser ByteString Word8
word8 (Int -> Word8
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c))

-- | ASCII letters and digits.
diglet :: Parser ByteString Word8
diglet :: Parser ByteString Word8
diglet = (Word8 -> Bool) -> Parser ByteString Word8
satisfy ((Char -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem ([Char
'a'..Char
'z'] String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Char
'0'..Char
'9']) (Char -> Bool) -> (Word8 -> Char) -> Word8 -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Char
forall a. Enum a => Int -> a
toEnum (Int -> Char) -> (Word8 -> Int) -> Word8 -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral)

--------------------------------------------------------------------------------
-- Unit tests

-- | Do all tests pass?
testsPass :: Bool
testsPass :: Bool
testsPass = (ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ByteString -> Bool
validHostname [ByteString]
correctTests Bool -> Bool -> Bool
&& Bool -> Bool
not ((ByteString -> Bool) -> [ByteString] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ByteString -> Bool
validHostname [ByteString]
incorrectTests)

-- | Tests that should pass.
correctTests :: [ByteString]
correctTests :: [ByteString]
correctTests =
  [ByteString
"a"
  ,ByteString
"a.com"
  ,ByteString
"a-c"
  ,ByteString
"a--b"
  ,ByteString
"64"
  ,ByteString
"54.com"
  -- Non-alpha languages use this encoding
  ,ByteString
"aaa-bbb-ccc.dooo-bar--zot"
  ,ByteString
"xn--mgbh0fb.xn--kgbechtv"
  ,ByteString
"xn--fsqu00a.xn--0zwm56d"
  ,ByteString
"xn--fsqu00a.xn--g6w251d"
  ,ByteString
"xn--hxajbheg2az3al.xn--jxalpdlp"
  ,ByteString
"xn--p1b6ci4b4b3a.xn--11b5bs3a9aj6g"
  ,ByteString
"xn--r8jz45g.xn--zckzah"
  ,ByteString
"xn--9n2bp8q.xn--9t4b11yi5a"
  ,ByteString
"xn--mgbh0fb.xn--hgbk6aj7f53bba"
  ,ByteString
"xn--e1afmkfd.xn--80akhbyknj4f"
  ,ByteString
"xn--zkc6cc5bi7f6e.xn--hlcj6aya9esc7a"
  ,ByteString
"xn--6dbbec0c.xn--deba0ad"
  ,ByteString
"xn--fdbk5d8ap9b8a8d.xn--deba0ad"]

-- | Tests that should passfail.
incorrectTests :: [ByteString]
incorrectTests :: [ByteString]
incorrectTests =
  [ByteString
""
  ,ByteString
"a-"
  ,ByteString
"-"
  ,ByteString
"-a"
  ,ByteString
"a--"
  ,ByteString
"a.-"
  ,ByteString
".a"
  ,ByteString
".a-z"]