{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DeriveLift #-}

module Dormouse.Uri.Types
  ( UriReferenceType(..)
  , Authority(..)
  , Fragment(..)
  , Host(..)
  , Path(..)
  , PathSegment(..)
  , Query(..)
  , Scheme(..)
  , UserInfo(..)
  , Uri(..)
  , RelRef(..)
  , UriReference(..)
  ) where

import Data.String (IsString(..))
import qualified Data.List as L
import Data.Text (Text, unpack, pack)
import qualified Data.Text as T
import Language.Haskell.TH.Syntax (Lift(..))

-- | The UserInfo subcomponent of a URI Authority
newtype UserInfo = UserInfo 
  { UserInfo -> Text
unUserInfo :: Text
  } deriving (UserInfo -> UserInfo -> Bool
(UserInfo -> UserInfo -> Bool)
-> (UserInfo -> UserInfo -> Bool) -> Eq UserInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UserInfo -> UserInfo -> Bool
$c/= :: UserInfo -> UserInfo -> Bool
== :: UserInfo -> UserInfo -> Bool
$c== :: UserInfo -> UserInfo -> Bool
Eq, UserInfo -> Q Exp
UserInfo -> Q (TExp UserInfo)
(UserInfo -> Q Exp)
-> (UserInfo -> Q (TExp UserInfo)) -> Lift UserInfo
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: UserInfo -> Q (TExp UserInfo)
$cliftTyped :: UserInfo -> Q (TExp UserInfo)
lift :: UserInfo -> Q Exp
$clift :: UserInfo -> Q Exp
Lift)

instance Show UserInfo where
  show :: UserInfo -> String
show UserInfo
userInfo = -- applications should not render as clear text anything after the first colon
    case (Char -> Bool) -> Text -> [Text]
T.split (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
==Char
':') (Text -> [Text]) -> Text -> [Text]
forall a b. (a -> b) -> a -> b
$ UserInfo -> Text
unUserInfo UserInfo
userInfo of 
      [] -> String
""
      [Text
x] -> Text -> String
unpack Text
x
      Text
x:[Text]
_ -> Text -> String
unpack Text
x String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
":****"

-- | The Host subcomponent of a URI Authority
newtype Host = Host { Host -> Text
unHost :: Text } deriving (Host -> Host -> Bool
(Host -> Host -> Bool) -> (Host -> Host -> Bool) -> Eq Host
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Host -> Host -> Bool
$c/= :: Host -> Host -> Bool
== :: Host -> Host -> Bool
$c== :: Host -> Host -> Bool
Eq, Host -> Q Exp
Host -> Q (TExp Host)
(Host -> Q Exp) -> (Host -> Q (TExp Host)) -> Lift Host
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Host -> Q (TExp Host)
$cliftTyped :: Host -> Q (TExp Host)
lift :: Host -> Q Exp
$clift :: Host -> Q Exp
Lift)

instance IsString Host where
  fromString :: String -> Host
fromString String
s = Text -> Host
Host (Text -> Host) -> Text -> Host
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
s

instance Show Host where
  show :: Host -> String
show Host
host = Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Host -> Text
unHost Host
host

-- | The Authority component of a URI
data Authority = Authority 
  { Authority -> Maybe UserInfo
authorityUserInfo :: Maybe UserInfo
  , Authority -> Host
authorityHost :: Host
  , Authority -> Maybe Int
authorityPort :: Maybe Int
  } deriving (Authority -> Authority -> Bool
(Authority -> Authority -> Bool)
-> (Authority -> Authority -> Bool) -> Eq Authority
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Authority -> Authority -> Bool
$c/= :: Authority -> Authority -> Bool
== :: Authority -> Authority -> Bool
$c== :: Authority -> Authority -> Bool
Eq, Int -> Authority -> ShowS
[Authority] -> ShowS
Authority -> String
(Int -> Authority -> ShowS)
-> (Authority -> String)
-> ([Authority] -> ShowS)
-> Show Authority
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Authority] -> ShowS
$cshowList :: [Authority] -> ShowS
show :: Authority -> String
$cshow :: Authority -> String
showsPrec :: Int -> Authority -> ShowS
$cshowsPrec :: Int -> Authority -> ShowS
Show, Authority -> Q Exp
Authority -> Q (TExp Authority)
(Authority -> Q Exp)
-> (Authority -> Q (TExp Authority)) -> Lift Authority
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Authority -> Q (TExp Authority)
$cliftTyped :: Authority -> Q (TExp Authority)
lift :: Authority -> Q Exp
$clift :: Authority -> Q Exp
Lift)

-- | The Fragment component of a URI
newtype Fragment = Fragment { Fragment -> Text
unFragment :: Text } deriving (Fragment -> Fragment -> Bool
(Fragment -> Fragment -> Bool)
-> (Fragment -> Fragment -> Bool) -> Eq Fragment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Fragment -> Fragment -> Bool
$c/= :: Fragment -> Fragment -> Bool
== :: Fragment -> Fragment -> Bool
$c== :: Fragment -> Fragment -> Bool
Eq, Fragment -> Q Exp
Fragment -> Q (TExp Fragment)
(Fragment -> Q Exp)
-> (Fragment -> Q (TExp Fragment)) -> Lift Fragment
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Fragment -> Q (TExp Fragment)
$cliftTyped :: Fragment -> Q (TExp Fragment)
lift :: Fragment -> Q Exp
$clift :: Fragment -> Q Exp
Lift)

instance IsString Fragment where
  fromString :: String -> Fragment
fromString String
s = Text -> Fragment
Fragment (Text -> Fragment) -> Text -> Fragment
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
s

instance Show Fragment where
  show :: Fragment -> String
show Fragment
fragment = Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Fragment -> Text
unFragment Fragment
fragment

data UriReferenceType = Absolute | Relative

-- | The Path component of a URI, including a series of individual Path Segments
newtype Path (ref :: UriReferenceType) = Path { Path ref -> [PathSegment]
unPath :: [PathSegment]} deriving (Path ref -> Path ref -> Bool
(Path ref -> Path ref -> Bool)
-> (Path ref -> Path ref -> Bool) -> Eq (Path ref)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (ref :: UriReferenceType). Path ref -> Path ref -> Bool
/= :: Path ref -> Path ref -> Bool
$c/= :: forall (ref :: UriReferenceType). Path ref -> Path ref -> Bool
== :: Path ref -> Path ref -> Bool
$c== :: forall (ref :: UriReferenceType). Path ref -> Path ref -> Bool
Eq, Path ref -> Q Exp
Path ref -> Q (TExp (Path ref))
(Path ref -> Q Exp)
-> (Path ref -> Q (TExp (Path ref))) -> Lift (Path ref)
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
forall (ref :: UriReferenceType). Path ref -> Q Exp
forall (ref :: UriReferenceType). Path ref -> Q (TExp (Path ref))
liftTyped :: Path ref -> Q (TExp (Path ref))
$cliftTyped :: forall (ref :: UriReferenceType). Path ref -> Q (TExp (Path ref))
lift :: Path ref -> Q Exp
$clift :: forall (ref :: UriReferenceType). Path ref -> Q Exp
Lift)

instance Show (Path ref) where
  show :: Path ref -> String
show Path ref
path = String
"[" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
L.intercalate String
"," ((PathSegment -> String) -> [PathSegment] -> [String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PathSegment -> String
forall a. Show a => a -> String
show ([PathSegment] -> [String])
-> (Path ref -> [PathSegment]) -> Path ref -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path ref -> [PathSegment]
forall (ref :: UriReferenceType). Path ref -> [PathSegment]
unPath (Path ref -> [String]) -> Path ref -> [String]
forall a b. (a -> b) -> a -> b
$ Path ref
path) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"]"

-- | An individial Path segment of a URI
newtype PathSegment = PathSegment { PathSegment -> Text
unPathSegment :: Text } deriving (PathSegment -> PathSegment -> Bool
(PathSegment -> PathSegment -> Bool)
-> (PathSegment -> PathSegment -> Bool) -> Eq PathSegment
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PathSegment -> PathSegment -> Bool
$c/= :: PathSegment -> PathSegment -> Bool
== :: PathSegment -> PathSegment -> Bool
$c== :: PathSegment -> PathSegment -> Bool
Eq, PathSegment -> Q Exp
PathSegment -> Q (TExp PathSegment)
(PathSegment -> Q Exp)
-> (PathSegment -> Q (TExp PathSegment)) -> Lift PathSegment
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: PathSegment -> Q (TExp PathSegment)
$cliftTyped :: PathSegment -> Q (TExp PathSegment)
lift :: PathSegment -> Q Exp
$clift :: PathSegment -> Q Exp
Lift)

instance IsString PathSegment where
  fromString :: String -> PathSegment
fromString String
s = Text -> PathSegment
PathSegment (Text -> PathSegment) -> Text -> PathSegment
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
s

instance Show PathSegment where
  show :: PathSegment -> String
show PathSegment
seg = Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ PathSegment -> Text
unPathSegment PathSegment
seg

-- | The Query component of a URI
newtype Query = Query { Query -> Text
unQuery :: Text } deriving (Query -> Query -> Bool
(Query -> Query -> Bool) -> (Query -> Query -> Bool) -> Eq Query
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Query -> Query -> Bool
$c/= :: Query -> Query -> Bool
== :: Query -> Query -> Bool
$c== :: Query -> Query -> Bool
Eq, Query -> Q Exp
Query -> Q (TExp Query)
(Query -> Q Exp) -> (Query -> Q (TExp Query)) -> Lift Query
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Query -> Q (TExp Query)
$cliftTyped :: Query -> Q (TExp Query)
lift :: Query -> Q Exp
$clift :: Query -> Q Exp
Lift)

instance IsString Query where
  fromString :: String -> Query
fromString String
s = Text -> Query
Query (Text -> Query) -> Text -> Query
forall a b. (a -> b) -> a -> b
$ String -> Text
pack String
s

instance Show Query where
  show :: Query -> String
show Query
query = Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Query -> Text
unQuery Query
query

-- | The Scheme component of a URI
newtype Scheme = Scheme { Scheme -> Text
unScheme :: Text } deriving (Scheme -> Scheme -> Bool
(Scheme -> Scheme -> Bool)
-> (Scheme -> Scheme -> Bool) -> Eq Scheme
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Scheme -> Scheme -> Bool
$c/= :: Scheme -> Scheme -> Bool
== :: Scheme -> Scheme -> Bool
$c== :: Scheme -> Scheme -> Bool
Eq, Scheme -> Q Exp
Scheme -> Q (TExp Scheme)
(Scheme -> Q Exp) -> (Scheme -> Q (TExp Scheme)) -> Lift Scheme
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Scheme -> Q (TExp Scheme)
$cliftTyped :: Scheme -> Q (TExp Scheme)
lift :: Scheme -> Q Exp
$clift :: Scheme -> Q Exp
Lift)

instance Show Scheme where
  show :: Scheme -> String
show Scheme
scheme = Text -> String
unpack (Text -> String) -> (Scheme -> Text) -> Scheme -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Scheme -> Text
unScheme (Scheme -> String) -> Scheme -> String
forall a b. (a -> b) -> a -> b
$ Scheme
scheme

-- | A Uniform Resource Identifier (URI) is a compact sequence of characters that identifies an abstract or physical resource.
-- It is defined according to RFC 3986 (<https://tools.ietf.org/html/rfc3986>).
data Uri = Uri
  { Uri -> Scheme
uriScheme :: Scheme
  , Uri -> Maybe Authority
uriAuthority :: Maybe Authority
  , Uri -> Path 'Absolute
uriPath :: Path 'Absolute
  , Uri -> Maybe Query
uriQuery :: Maybe Query
  , Uri -> Maybe Fragment
uriFragment :: Maybe Fragment
  } deriving (Uri -> Uri -> Bool
(Uri -> Uri -> Bool) -> (Uri -> Uri -> Bool) -> Eq Uri
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Uri -> Uri -> Bool
$c/= :: Uri -> Uri -> Bool
== :: Uri -> Uri -> Bool
$c== :: Uri -> Uri -> Bool
Eq, Int -> Uri -> ShowS
[Uri] -> ShowS
Uri -> String
(Int -> Uri -> ShowS)
-> (Uri -> String) -> ([Uri] -> ShowS) -> Show Uri
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Uri] -> ShowS
$cshowList :: [Uri] -> ShowS
show :: Uri -> String
$cshow :: Uri -> String
showsPrec :: Int -> Uri -> ShowS
$cshowsPrec :: Int -> Uri -> ShowS
Show, Uri -> Q Exp
Uri -> Q (TExp Uri)
(Uri -> Q Exp) -> (Uri -> Q (TExp Uri)) -> Lift Uri
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: Uri -> Q (TExp Uri)
$cliftTyped :: Uri -> Q (TExp Uri)
lift :: Uri -> Q Exp
$clift :: Uri -> Q Exp
Lift)

-- | The data associated with a URI Relative Reference
data RelRef = RelRef
  { RelRef -> Maybe Authority
relRefAuthority :: Maybe Authority
  , RelRef -> Path 'Relative
relRefPath :: Path 'Relative
  , RelRef -> Maybe Query
relRefQuery :: Maybe Query
  , RelRef -> Maybe Fragment
relRefFragment :: Maybe Fragment
  } deriving (RelRef -> RelRef -> Bool
(RelRef -> RelRef -> Bool)
-> (RelRef -> RelRef -> Bool) -> Eq RelRef
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelRef -> RelRef -> Bool
$c/= :: RelRef -> RelRef -> Bool
== :: RelRef -> RelRef -> Bool
$c== :: RelRef -> RelRef -> Bool
Eq, Int -> RelRef -> ShowS
[RelRef] -> ShowS
RelRef -> String
(Int -> RelRef -> ShowS)
-> (RelRef -> String) -> ([RelRef] -> ShowS) -> Show RelRef
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RelRef] -> ShowS
$cshowList :: [RelRef] -> ShowS
show :: RelRef -> String
$cshow :: RelRef -> String
showsPrec :: Int -> RelRef -> ShowS
$cshowsPrec :: Int -> RelRef -> ShowS
Show, RelRef -> Q Exp
RelRef -> Q (TExp RelRef)
(RelRef -> Q Exp) -> (RelRef -> Q (TExp RelRef)) -> Lift RelRef
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: RelRef -> Q (TExp RelRef)
$cliftTyped :: RelRef -> Q (TExp RelRef)
lift :: RelRef -> Q Exp
$clift :: RelRef -> Q Exp
Lift)

-- | A URI-reference is either a URI or a relative reference.  If the URI-reference's prefix does not match the syntax of a scheme 
-- followed by its colon separator, then the URI-reference is a relative reference.
data UriReference 
  = AbsoluteUri Uri
  | RelativeRef RelRef
  deriving (UriReference -> Q Exp
UriReference -> Q (TExp UriReference)
(UriReference -> Q Exp)
-> (UriReference -> Q (TExp UriReference)) -> Lift UriReference
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: UriReference -> Q (TExp UriReference)
$cliftTyped :: UriReference -> Q (TExp UriReference)
lift :: UriReference -> Q Exp
$clift :: UriReference -> Q Exp
Lift, UriReference -> UriReference -> Bool
(UriReference -> UriReference -> Bool)
-> (UriReference -> UriReference -> Bool) -> Eq UriReference
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UriReference -> UriReference -> Bool
$c/= :: UriReference -> UriReference -> Bool
== :: UriReference -> UriReference -> Bool
$c== :: UriReference -> UriReference -> Bool
Eq, Int -> UriReference -> ShowS
[UriReference] -> ShowS
UriReference -> String
(Int -> UriReference -> ShowS)
-> (UriReference -> String)
-> ([UriReference] -> ShowS)
-> Show UriReference
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UriReference] -> ShowS
$cshowList :: [UriReference] -> ShowS
show :: UriReference -> String
$cshow :: UriReference -> String
showsPrec :: Int -> UriReference -> ShowS
$cshowsPrec :: Int -> UriReference -> ShowS
Show)