-- |
-- Domainname parsers (specialization of "Web.Route.Invertible.Sequence").
-- These can be used for virtual hosting or otherwise matching on hostnames.
{-# LANGUAGE GeneralizedNewtypeDeriving, StandaloneDeriving, FlexibleInstances, FlexibleContexts #-}
module Web.Route.Invertible.Host
  ( HostString
  , splitHost
  , joinHost
  , Host(..)
  , renderHost
  ) where

import Prelude hiding (lookup)

import Control.Invertible.Monoidal
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as BSC
import qualified Data.Invertible as I
import Data.String (IsString(..))

import Web.Route.Invertible.Parameter
import Web.Route.Invertible.Placeholder
import Web.Route.Invertible.Sequence

-- |The representation for domain names or domain name segments (after 'splitHost').
type HostString = BS.ByteString

-- |Split (and reverse) a domainname on \".\" for use with 'Host'.
splitHost :: BS.ByteString -> [HostString]
splitHost :: ByteString -> [ByteString]
splitHost = [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> [ByteString]
BSC.split Char
'.'

-- |Reverse and join a hostname with \".\".
joinHost :: [HostString] -> BS.ByteString
joinHost :: [ByteString] -> ByteString
joinHost = ByteString -> [ByteString] -> ByteString
BS.intercalate (Char -> ByteString
BSC.singleton Char
'.') ([ByteString] -> ByteString)
-> ([ByteString] -> [ByteString]) -> [ByteString] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> [ByteString]
forall a. [a] -> [a]
reverse

-- |A hostname matcher.
-- These should typically be constructed using the 'IsString' and 'Parameterized' instances.
-- This matches hostnames in reverse order (from TLD down), but the 'Monoidal' instance and 'splitHost' automatically deal with this for you.
-- Example:
--
-- > parameter >* "domain" >* "com" :: Host String
--
-- matches (or generates) @*.domain.com@ and returns the @*@ component.
newtype Host a = HostRev { Host a -> Sequence ByteString a
hostSequence :: Sequence HostString a }
  deriving ((a <-> b) -> Host a -> Host b
(forall a b. (a <-> b) -> Host a -> Host b) -> Functor Host
forall a b. (a <-> b) -> Host a -> Host b
forall (f :: * -> *).
(forall a b. (a <-> b) -> f a -> f b) -> Functor f
fmap :: (a <-> b) -> Host a -> Host b
$cfmap :: forall a b. (a <-> b) -> Host a -> Host b
I.Functor, Monoidal Host
Host Void
Monoidal Host
-> Host Void
-> (forall a b. Host a -> Host b -> Host (Either a b))
-> MonoidalAlt Host
Host a -> Host b -> Host (Either a b)
forall a b. Host a -> Host b -> Host (Either a b)
forall (f :: * -> *).
Monoidal f
-> f Void
-> (forall a b. f a -> f b -> f (Either a b))
-> MonoidalAlt f
>|< :: Host a -> Host b -> Host (Either a b)
$c>|< :: forall a b. Host a -> Host b -> Host (Either a b)
zero :: Host Void
$czero :: Host Void
$cp1MonoidalAlt :: Monoidal Host
MonoidalAlt, Parameterized HostString, Int -> Host a -> ShowS
[Host a] -> ShowS
Host a -> String
(Int -> Host a -> ShowS)
-> (Host a -> String) -> ([Host a] -> ShowS) -> Show (Host a)
forall a. Int -> Host a -> ShowS
forall a. [Host a] -> ShowS
forall a. Host a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Host a] -> ShowS
$cshowList :: forall a. [Host a] -> ShowS
show :: Host a -> String
$cshow :: forall a. Host a -> String
showsPrec :: Int -> Host a -> ShowS
$cshowsPrec :: forall a. Int -> Host a -> ShowS
Show)

instance Monoidal Host where
  unit :: Host ()
unit = Sequence ByteString () -> Host ()
forall a. Sequence ByteString a -> Host a
HostRev Sequence ByteString ()
forall (f :: * -> *). Monoidal f => f ()
unit
  HostRev Sequence ByteString a
p >*< :: Host a -> Host b -> Host (a, b)
>*< HostRev Sequence ByteString b
q = (b, a) <-> (a, b)
forall a b. (a, b) <-> (b, a)
I.swap ((b, a) <-> (a, b)) -> Host (b, a) -> Host (a, b)
forall (f :: * -> *) a b. Functor f => (a <-> b) -> f a -> f b
>$< Sequence ByteString (b, a) -> Host (b, a)
forall a. Sequence ByteString a -> Host a
HostRev (Sequence ByteString b
q Sequence ByteString b
-> Sequence ByteString a -> Sequence ByteString (b, a)
forall (f :: * -> *) a b. Monoidal f => f a -> f b -> f (a, b)
>*< Sequence ByteString a
p)

-- |Since domain components cannot contain \".\", @"foo.com"@ is equivalent to @"foo" *< "com"@ (unlike other 'Sequence's).
instance IsString (Host ()) where
  fromString :: String -> Host ()
fromString String
s = Sequence ByteString () -> Host ()
forall a. Sequence ByteString a -> Host a
HostRev (Sequence ByteString () -> Host ())
-> Sequence ByteString () -> Host ()
forall a b. (a -> b) -> a -> b
$ (ByteString -> Sequence ByteString ())
-> [ByteString] -> Sequence ByteString ()
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Monoidal f) =>
(a -> f ()) -> t a -> f ()
mapI_ (Placeholder ByteString () -> Sequence ByteString ()
forall s a. Placeholder s a -> Sequence s a
placeholderSequence (Placeholder ByteString () -> Sequence ByteString ())
-> (ByteString -> Placeholder ByteString ())
-> ByteString
-> Sequence ByteString ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Placeholder ByteString ()
forall s. s -> Placeholder s ()
PlaceholderFixed) ([ByteString] -> Sequence ByteString ())
-> [ByteString] -> Sequence ByteString ()
forall a b. (a -> b) -> a -> b
$ ByteString -> [ByteString]
splitHost (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall a b. (a -> b) -> a -> b
$ String -> ByteString
forall a. IsString a => String -> a
fromString String
s

-- |Instantiate a host with a value and render it as a domainname.
renderHost :: Host a -> a -> BS.ByteString
renderHost :: Host a -> a -> ByteString
renderHost (HostRev Sequence ByteString a
p) a
a = [ByteString] -> ByteString
joinHost ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ Sequence ByteString a -> a -> [ByteString]
forall s a. Sequence s a -> a -> [s]
renderSequence Sequence ByteString a
p a
a