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

module Dormouse.Uri.Types
  ( UriReference(..)
  , Authority(..)
  , Fragment(..)
  , Host(..)
  , Path(..)
  , PathSegment(..)
  , Query(..)
  , Scheme(..)
  , Username(..)
  , Password(..)
  , UserInfo(..)
  , Uri(..)
  , AbsUri(..)
  , RelUri(..)
  ) where

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

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

instance Show Username where
  show :: Username -> String
show Username
username = Text -> String
unpack (Text -> String) -> Text -> String
forall a b. (a -> b) -> a -> b
$ Username -> Text
unUsername Username
username

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

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

instance Show Password where
  show :: Password -> String
show Password
_ = String
"****"

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

-- | The UserInfo subcomponent of a URI Authority
data UserInfo = UserInfo 
  { UserInfo -> Username
userInfoUsername :: Username
  , UserInfo -> Maybe Password
userInfoPassword :: Maybe Password
  } 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, Int -> UserInfo -> ShowS
[UserInfo] -> ShowS
UserInfo -> String
(Int -> UserInfo -> ShowS)
-> (UserInfo -> String) -> ([UserInfo] -> ShowS) -> Show UserInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [UserInfo] -> ShowS
$cshowList :: [UserInfo] -> ShowS
show :: UserInfo -> String
$cshow :: UserInfo -> String
showsPrec :: Int -> UserInfo -> ShowS
$cshowsPrec :: Int -> UserInfo -> ShowS
Show, 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)

-- | 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 UriReference = Absolute | Relative

-- | The Path component of a URI, including a series of individual Path Segments
newtype Path (ref :: UriReference) = 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 :: UriReference). Path ref -> Path ref -> Bool
/= :: Path ref -> Path ref -> Bool
$c/= :: forall (ref :: UriReference). Path ref -> Path ref -> Bool
== :: Path ref -> Path ref -> Bool
$c== :: forall (ref :: UriReference). 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 :: UriReference). Path ref -> Q Exp
forall (ref :: UriReference). Path ref -> Q (TExp (Path ref))
liftTyped :: Path ref -> Q (TExp (Path ref))
$cliftTyped :: forall (ref :: UriReference). Path ref -> Q (TExp (Path ref))
lift :: Path ref -> Q Exp
$clift :: forall (ref :: UriReference). 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 :: UriReference). 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

-- | The data associated with an Absolute URI
data AbsUri = AbsUri
  { AbsUri -> Scheme
uriScheme :: Scheme
  , AbsUri -> Maybe Authority
uriAuthority :: Maybe Authority
  , AbsUri -> Path 'Absolute
uriPath :: Path 'Absolute
  , AbsUri -> Maybe Query
uriQuery :: Maybe Query
  , AbsUri -> Maybe Fragment
uriFragment :: Maybe Fragment
  } deriving (AbsUri -> AbsUri -> Bool
(AbsUri -> AbsUri -> Bool)
-> (AbsUri -> AbsUri -> Bool) -> Eq AbsUri
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AbsUri -> AbsUri -> Bool
$c/= :: AbsUri -> AbsUri -> Bool
== :: AbsUri -> AbsUri -> Bool
$c== :: AbsUri -> AbsUri -> Bool
Eq, Int -> AbsUri -> ShowS
[AbsUri] -> ShowS
AbsUri -> String
(Int -> AbsUri -> ShowS)
-> (AbsUri -> String) -> ([AbsUri] -> ShowS) -> Show AbsUri
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AbsUri] -> ShowS
$cshowList :: [AbsUri] -> ShowS
show :: AbsUri -> String
$cshow :: AbsUri -> String
showsPrec :: Int -> AbsUri -> ShowS
$cshowsPrec :: Int -> AbsUri -> ShowS
Show, AbsUri -> Q Exp
AbsUri -> Q (TExp AbsUri)
(AbsUri -> Q Exp) -> (AbsUri -> Q (TExp AbsUri)) -> Lift AbsUri
forall t. (t -> Q Exp) -> (t -> Q (TExp t)) -> Lift t
liftTyped :: AbsUri -> Q (TExp AbsUri)
$cliftTyped :: AbsUri -> Q (TExp AbsUri)
lift :: AbsUri -> Q Exp
$clift :: AbsUri -> Q Exp
Lift)

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

-- | 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>).  URIs can be absolute (i.e. defined against a
-- specific scheme) or relative.
data Uri 
  = AbsoluteUri AbsUri
  | RelativeUri RelUri
  deriving (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, 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)