{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TupleSections #-}

-- |
-- Module      :  Text.URI.Lens
-- Copyright   :  © 2017–present Mark Karpov
-- License     :  BSD 3 clause
--
-- Maintainer  :  Mark Karpov <markkarpov92@gmail.com>
-- Stability   :  experimental
-- Portability :  portable
--
-- Lenses for working with the 'URI' data type and its internals.
module Text.URI.Lens
  ( uriScheme,
    uriAuthority,
    uriPath,
    isPathAbsolute,
    uriTrailingSlash,
    uriQuery,
    uriFragment,
    authUserInfo,
    authHost,
    authPort,
    uiUsername,
    uiPassword,
    _QueryFlag,
    _QueryParam,
    queryFlag,
    queryParam,
    unRText,
  )
where

import Control.Applicative (liftA2)
import Data.Foldable (find)
import Data.Functor.Contravariant
import qualified Data.List.NonEmpty as NE
import Data.Maybe (isJust)
import Data.Profunctor
import Data.Text (Text)
import Text.URI.Types
  ( Authority,
    QueryParam (..),
    RText,
    RTextLabel (..),
    URI,
    UserInfo,
  )
import qualified Text.URI.Types as URI

-- | 'URI' scheme lens.
uriScheme :: Lens' URI (Maybe (RText 'Scheme))
uriScheme :: (Maybe (RText 'Scheme) -> f (Maybe (RText 'Scheme)))
-> URI -> f URI
uriScheme Maybe (RText 'Scheme) -> f (Maybe (RText 'Scheme))
f URI
s = (\Maybe (RText 'Scheme)
x -> URI
s {uriScheme :: Maybe (RText 'Scheme)
URI.uriScheme = Maybe (RText 'Scheme)
x}) (Maybe (RText 'Scheme) -> URI)
-> f (Maybe (RText 'Scheme)) -> f URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RText 'Scheme) -> f (Maybe (RText 'Scheme))
f (URI -> Maybe (RText 'Scheme)
URI.uriScheme URI
s)

-- | 'URI' authority lens.
--
-- __Note__: before version /0.1.0.0/ this lens allowed to focus on @'Maybe'
-- 'URI.Authority'@.
uriAuthority :: Lens' URI (Either Bool URI.Authority)
uriAuthority :: (Either Bool Authority -> f (Either Bool Authority))
-> URI -> f URI
uriAuthority Either Bool Authority -> f (Either Bool Authority)
f URI
s = (\Either Bool Authority
x -> URI
s {uriAuthority :: Either Bool Authority
URI.uriAuthority = Either Bool Authority
x}) (Either Bool Authority -> URI)
-> f (Either Bool Authority) -> f URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Either Bool Authority -> f (Either Bool Authority)
f (URI -> Either Bool Authority
URI.uriAuthority URI
s)

-- | 'URI' path lens.
uriPath :: Lens' URI [RText 'PathPiece]
uriPath :: ([RText 'PathPiece] -> f [RText 'PathPiece]) -> URI -> f URI
uriPath [RText 'PathPiece] -> f [RText 'PathPiece]
f URI
s = (\[RText 'PathPiece]
x -> URI
s {uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath = (Bool
ts,) (NonEmpty (RText 'PathPiece)
 -> (Bool, NonEmpty (RText 'PathPiece)))
-> Maybe (NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RText 'PathPiece] -> Maybe (NonEmpty (RText 'PathPiece))
forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [RText 'PathPiece]
x}) ([RText 'PathPiece] -> URI) -> f [RText 'PathPiece] -> f URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [RText 'PathPiece] -> f [RText 'PathPiece]
f [RText 'PathPiece]
ps
  where
    ts :: Bool
ts = Bool
-> ((Bool, NonEmpty (RText 'PathPiece)) -> Bool)
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
-> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Bool, NonEmpty (RText 'PathPiece)) -> Bool
forall a b. (a, b) -> a
fst Maybe (Bool, NonEmpty (RText 'PathPiece))
path
    ps :: [RText 'PathPiece]
ps = [RText 'PathPiece]
-> ((Bool, NonEmpty (RText 'PathPiece)) -> [RText 'PathPiece])
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
-> [RText 'PathPiece]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (NonEmpty (RText 'PathPiece) -> [RText 'PathPiece]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty (RText 'PathPiece) -> [RText 'PathPiece])
-> ((Bool, NonEmpty (RText 'PathPiece))
    -> NonEmpty (RText 'PathPiece))
-> (Bool, NonEmpty (RText 'PathPiece))
-> [RText 'PathPiece]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Bool, NonEmpty (RText 'PathPiece)) -> NonEmpty (RText 'PathPiece)
forall a b. (a, b) -> b
snd) Maybe (Bool, NonEmpty (RText 'PathPiece))
path
    path :: Maybe (Bool, NonEmpty (RText 'PathPiece))
path = URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath URI
s

-- | A getter that can tell if path component of a 'URI' is absolute.
--
-- @since 0.1.0.0
isPathAbsolute :: Getter URI Bool
isPathAbsolute :: (Bool -> f Bool) -> URI -> f URI
isPathAbsolute = (URI -> Bool) -> (Bool -> f Bool) -> URI -> f URI
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> p a (f a) -> p s (f s)
to URI -> Bool
URI.isPathAbsolute

-- | A 0-1 traversal allowing to view and manipulate trailing slash.
--
-- @since 0.2.0.0
uriTrailingSlash :: Traversal' URI Bool
uriTrailingSlash :: (Bool -> f Bool) -> URI -> f URI
uriTrailingSlash Bool -> f Bool
f URI
s =
  (\Maybe Bool
x -> URI
s {uriPath :: Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath = (Bool
 -> NonEmpty (RText 'PathPiece)
 -> (Bool, NonEmpty (RText 'PathPiece)))
-> Maybe Bool
-> Maybe (NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
forall (f :: * -> *) a b c.
Applicative f =>
(a -> b -> c) -> f a -> f b -> f c
liftA2 (,) Maybe Bool
x Maybe (NonEmpty (RText 'PathPiece))
ps}) (Maybe Bool -> URI) -> f (Maybe Bool) -> f URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Bool -> f Bool) -> Maybe Bool -> f (Maybe Bool)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Bool -> f Bool
f Maybe Bool
ts
  where
    ts :: Maybe Bool
ts = (Bool, NonEmpty (RText 'PathPiece)) -> Bool
forall a b. (a, b) -> a
fst ((Bool, NonEmpty (RText 'PathPiece)) -> Bool)
-> Maybe (Bool, NonEmpty (RText 'PathPiece)) -> Maybe Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Bool, NonEmpty (RText 'PathPiece))
path
    ps :: Maybe (NonEmpty (RText 'PathPiece))
ps = (Bool, NonEmpty (RText 'PathPiece)) -> NonEmpty (RText 'PathPiece)
forall a b. (a, b) -> b
snd ((Bool, NonEmpty (RText 'PathPiece))
 -> NonEmpty (RText 'PathPiece))
-> Maybe (Bool, NonEmpty (RText 'PathPiece))
-> Maybe (NonEmpty (RText 'PathPiece))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Bool, NonEmpty (RText 'PathPiece))
path
    path :: Maybe (Bool, NonEmpty (RText 'PathPiece))
path = URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath URI
s

-- | 'URI' query params lens.
uriQuery :: Lens' URI [URI.QueryParam]
uriQuery :: ([QueryParam] -> f [QueryParam]) -> URI -> f URI
uriQuery [QueryParam] -> f [QueryParam]
f URI
s = (\[QueryParam]
x -> URI
s {uriQuery :: [QueryParam]
URI.uriQuery = [QueryParam]
x}) ([QueryParam] -> URI) -> f [QueryParam] -> f URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [QueryParam] -> f [QueryParam]
f (URI -> [QueryParam]
URI.uriQuery URI
s)

-- | 'URI' fragment lens.
uriFragment :: Lens' URI (Maybe (RText 'Fragment))
uriFragment :: (Maybe (RText 'Fragment) -> f (Maybe (RText 'Fragment)))
-> URI -> f URI
uriFragment Maybe (RText 'Fragment) -> f (Maybe (RText 'Fragment))
f URI
s = (\Maybe (RText 'Fragment)
x -> URI
s {uriFragment :: Maybe (RText 'Fragment)
URI.uriFragment = Maybe (RText 'Fragment)
x}) (Maybe (RText 'Fragment) -> URI)
-> f (Maybe (RText 'Fragment)) -> f URI
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RText 'Fragment) -> f (Maybe (RText 'Fragment))
f (URI -> Maybe (RText 'Fragment)
URI.uriFragment URI
s)

-- | 'Authority' user info lens.
authUserInfo :: Lens' Authority (Maybe URI.UserInfo)
authUserInfo :: (Maybe UserInfo -> f (Maybe UserInfo)) -> Authority -> f Authority
authUserInfo Maybe UserInfo -> f (Maybe UserInfo)
f Authority
s = (\Maybe UserInfo
x -> Authority
s {authUserInfo :: Maybe UserInfo
URI.authUserInfo = Maybe UserInfo
x}) (Maybe UserInfo -> Authority) -> f (Maybe UserInfo) -> f Authority
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UserInfo -> f (Maybe UserInfo)
f (Authority -> Maybe UserInfo
URI.authUserInfo Authority
s)

-- | 'Authority' host lens.
authHost :: Lens' Authority (RText 'Host)
authHost :: (RText 'Host -> f (RText 'Host)) -> Authority -> f Authority
authHost RText 'Host -> f (RText 'Host)
f Authority
s = (\RText 'Host
x -> Authority
s {authHost :: RText 'Host
URI.authHost = RText 'Host
x}) (RText 'Host -> Authority) -> f (RText 'Host) -> f Authority
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RText 'Host -> f (RText 'Host)
f (Authority -> RText 'Host
URI.authHost Authority
s)

-- | 'Authority' port lens.
authPort :: Lens' Authority (Maybe Word)
authPort :: (Maybe Word -> f (Maybe Word)) -> Authority -> f Authority
authPort Maybe Word -> f (Maybe Word)
f Authority
s = (\Maybe Word
x -> Authority
s {authPort :: Maybe Word
URI.authPort = Maybe Word
x}) (Maybe Word -> Authority) -> f (Maybe Word) -> f Authority
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Word -> f (Maybe Word)
f (Authority -> Maybe Word
URI.authPort Authority
s)

-- | 'UserInfo' username lens.
uiUsername :: Lens' UserInfo (RText 'Username)
uiUsername :: (RText 'Username -> f (RText 'Username)) -> UserInfo -> f UserInfo
uiUsername RText 'Username -> f (RText 'Username)
f UserInfo
s = (\RText 'Username
x -> UserInfo
s {uiUsername :: RText 'Username
URI.uiUsername = RText 'Username
x}) (RText 'Username -> UserInfo) -> f (RText 'Username) -> f UserInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RText 'Username -> f (RText 'Username)
f (UserInfo -> RText 'Username
URI.uiUsername UserInfo
s)

-- | 'UserInfo' password lens.
uiPassword :: Lens' UserInfo (Maybe (RText 'Password))
uiPassword :: (Maybe (RText 'Password) -> f (Maybe (RText 'Password)))
-> UserInfo -> f UserInfo
uiPassword Maybe (RText 'Password) -> f (Maybe (RText 'Password))
f UserInfo
s = (\Maybe (RText 'Password)
x -> UserInfo
s {uiPassword :: Maybe (RText 'Password)
URI.uiPassword = Maybe (RText 'Password)
x}) (Maybe (RText 'Password) -> UserInfo)
-> f (Maybe (RText 'Password)) -> f UserInfo
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (RText 'Password) -> f (Maybe (RText 'Password))
f (UserInfo -> Maybe (RText 'Password)
URI.uiPassword UserInfo
s)

-- | 'QueryParam' prism for query flags.
_QueryFlag :: Prism' URI.QueryParam (RText 'QueryKey)
_QueryFlag :: p (RText 'QueryKey) (f (RText 'QueryKey))
-> p QueryParam (f QueryParam)
_QueryFlag = (RText 'QueryKey -> QueryParam)
-> (QueryParam -> Maybe (RText 'QueryKey))
-> Prism QueryParam QueryParam (RText 'QueryKey) (RText 'QueryKey)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' RText 'QueryKey -> QueryParam
QueryFlag ((QueryParam -> Maybe (RText 'QueryKey))
 -> Prism QueryParam QueryParam (RText 'QueryKey) (RText 'QueryKey))
-> (QueryParam -> Maybe (RText 'QueryKey))
-> Prism QueryParam QueryParam (RText 'QueryKey) (RText 'QueryKey)
forall a b. (a -> b) -> a -> b
$ \case
  QueryFlag RText 'QueryKey
x -> RText 'QueryKey -> Maybe (RText 'QueryKey)
forall a. a -> Maybe a
Just RText 'QueryKey
x
  QueryParam
_ -> Maybe (RText 'QueryKey)
forall a. Maybe a
Nothing

-- | 'QueryParam' prism for query parameters.
_QueryParam :: Prism' QueryParam (RText 'QueryKey, RText 'QueryValue)
_QueryParam :: p (RText 'QueryKey, RText 'QueryValue)
  (f (RText 'QueryKey, RText 'QueryValue))
-> p QueryParam (f QueryParam)
_QueryParam = ((RText 'QueryKey, RText 'QueryValue) -> QueryParam)
-> (QueryParam -> Maybe (RText 'QueryKey, RText 'QueryValue))
-> Prism
     QueryParam
     QueryParam
     (RText 'QueryKey, RText 'QueryValue)
     (RText 'QueryKey, RText 'QueryValue)
forall b s a. (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' (RText 'QueryKey, RText 'QueryValue) -> QueryParam
construct QueryParam -> Maybe (RText 'QueryKey, RText 'QueryValue)
pick
  where
    construct :: (RText 'QueryKey, RText 'QueryValue) -> QueryParam
construct (RText 'QueryKey
x, RText 'QueryValue
y) = RText 'QueryKey -> RText 'QueryValue -> QueryParam
QueryParam RText 'QueryKey
x RText 'QueryValue
y
    pick :: QueryParam -> Maybe (RText 'QueryKey, RText 'QueryValue)
pick = \case
      QueryParam RText 'QueryKey
x RText 'QueryValue
y -> (RText 'QueryKey, RText 'QueryValue)
-> Maybe (RText 'QueryKey, RText 'QueryValue)
forall a. a -> Maybe a
Just (RText 'QueryKey
x, RText 'QueryValue
y)
      QueryParam
_ -> Maybe (RText 'QueryKey, RText 'QueryValue)
forall a. Maybe a
Nothing

-- | Check if the given query key is present in the collection of query
-- parameters.
queryFlag :: RText 'QueryKey -> Getter [URI.QueryParam] Bool
queryFlag :: RText 'QueryKey -> Getter [QueryParam] Bool
queryFlag RText 'QueryKey
k = ([QueryParam] -> Bool)
-> (Bool -> f Bool) -> [QueryParam] -> f [QueryParam]
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> p a (f a) -> p s (f s)
to (Maybe QueryParam -> Bool
forall a. Maybe a -> Bool
isJust (Maybe QueryParam -> Bool)
-> ([QueryParam] -> Maybe QueryParam) -> [QueryParam] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QueryParam -> Bool) -> [QueryParam] -> Maybe QueryParam
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
find QueryParam -> Bool
g)
  where
    g :: QueryParam -> Bool
g (QueryFlag RText 'QueryKey
k') = RText 'QueryKey
k' RText 'QueryKey -> RText 'QueryKey -> Bool
forall a. Eq a => a -> a -> Bool
== RText 'QueryKey
k
    g QueryParam
_ = Bool
False

-- | Manipulate a query parameter by its key. Note that since there may be
-- several query parameters with the same key this is a traversal that can
-- return\/modify several items at once.
queryParam :: RText 'QueryKey -> Traversal' [URI.QueryParam] (RText 'QueryValue)
queryParam :: RText 'QueryKey -> Traversal' [QueryParam] (RText 'QueryValue)
queryParam RText 'QueryKey
k RText 'QueryValue -> f (RText 'QueryValue)
f = (QueryParam -> f QueryParam) -> [QueryParam] -> f [QueryParam]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse QueryParam -> f QueryParam
g
  where
    g :: QueryParam -> f QueryParam
g p :: QueryParam
p@(QueryParam RText 'QueryKey
k' RText 'QueryValue
v) =
      if RText 'QueryKey
k RText 'QueryKey -> RText 'QueryKey -> Bool
forall a. Eq a => a -> a -> Bool
== RText 'QueryKey
k'
        then RText 'QueryKey -> RText 'QueryValue -> QueryParam
QueryParam RText 'QueryKey
k' (RText 'QueryValue -> QueryParam)
-> f (RText 'QueryValue) -> f QueryParam
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RText 'QueryValue -> f (RText 'QueryValue)
f RText 'QueryValue
v
        else QueryParam -> f QueryParam
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueryParam
p
    g QueryParam
p = QueryParam -> f QueryParam
forall (f :: * -> *) a. Applicative f => a -> f a
pure QueryParam
p

-- | A getter that can project 'Text' from refined text values.
unRText :: Getter (RText l) Text
unRText :: (Text -> f Text) -> RText l -> f (RText l)
unRText = (RText l -> Text) -> (Text -> f Text) -> RText l -> f (RText l)
forall (p :: * -> * -> *) (f :: * -> *) s a.
(Profunctor p, Contravariant f) =>
(s -> a) -> p a (f a) -> p s (f s)
to RText l -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText

----------------------------------------------------------------------------
-- Helpers

type Lens' s a =
  forall f. Functor f => (a -> f a) -> s -> f s

type Traversal' s a =
  forall f. Applicative f => (a -> f a) -> s -> f s

type Getter s a =
  forall f. (Contravariant f, Functor f) => (a -> f a) -> s -> f s

type Prism s t a b =
  forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t)

type Prism' s a = Prism s s a a

-- | Build a 'Prism'.
prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism :: (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> t
bt s -> Either t a
seta = (s -> Either t a)
-> (Either t (f b) -> f t)
-> p (Either t a) (Either t (f b))
-> p s (f t)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> Either t a
seta ((t -> f t) -> (f b -> f t) -> Either t (f b) -> f t
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either t -> f t
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((b -> t) -> f b -> f t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap b -> t
bt)) (p (Either t a) (Either t (f b)) -> p s (f t))
-> (p a (f b) -> p (Either t a) (Either t (f b)))
-> p a (f b)
-> p s (f t)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. p a (f b) -> p (Either t a) (Either t (f b))
forall (p :: * -> * -> *) a b c.
Choice p =>
p a b -> p (Either c a) (Either c b)
right'

-- | Another way to build a 'Prism'.
prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' :: (b -> s) -> (s -> Maybe a) -> Prism s s a b
prism' b -> s
bs s -> Maybe a
sma = (b -> s) -> (s -> Either s a) -> Prism s s a b
forall b t s a. (b -> t) -> (s -> Either t a) -> Prism s t a b
prism b -> s
bs (\s
s -> Either s a -> (a -> Either s a) -> Maybe a -> Either s a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (s -> Either s a
forall a b. a -> Either a b
Left s
s) a -> Either s a
forall a b. b -> Either a b
Right (s -> Maybe a
sma s
s))

-- | Lift a function into optic.
to :: (Profunctor p, Contravariant f) => (s -> a) -> (p a (f a) -> p s (f s))
to :: (s -> a) -> p a (f a) -> p s (f s)
to s -> a
f = (s -> a) -> (f a -> f s) -> p a (f a) -> p s (f s)
forall (p :: * -> * -> *) a b c d.
Profunctor p =>
(a -> b) -> (c -> d) -> p b c -> p a d
dimap s -> a
f ((s -> a) -> f a -> f s
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
contramap s -> a
f)