-- |
-- 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.

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

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 Data.Maybe (isJust)
import Data.Profunctor
import Data.Text (Text)
import Text.URI.Types (URI, Authority, UserInfo, QueryParam (..), RText, RTextLabel (..))
import qualified Data.List.NonEmpty as NE
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 f :: Maybe (RText 'Scheme) -> f (Maybe (RText 'Scheme))
f s :: URI
s = (\x :: 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 f :: Either Bool Authority -> f (Either Bool Authority)
f s :: URI
s = (\x :: 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 f :: [RText 'PathPiece] -> f [RText 'PathPiece]
f s :: URI
s = (\x :: [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 f :: Bool -> f Bool
f s :: URI
s =
  (\x :: 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 f :: [QueryParam] -> f [QueryParam]
f s :: URI
s = (\x :: [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 f :: Maybe (RText 'Fragment) -> f (Maybe (RText 'Fragment))
f s :: URI
s = (\x :: 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 f :: Maybe UserInfo -> f (Maybe UserInfo)
f s :: Authority
s = (\x :: 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 f :: RText 'Host -> f (RText 'Host)
f s :: Authority
s = (\x :: 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 f :: Maybe Word -> f (Maybe Word)
f s :: Authority
s = (\x :: 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 f :: RText 'Username -> f (RText 'Username)
f s :: UserInfo
s = (\x :: 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 f :: Maybe (RText 'Password) -> f (Maybe (RText 'Password))
f s :: UserInfo
s = (\x :: 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))
 -> p (RText 'QueryKey) (f (RText 'QueryKey))
 -> p QueryParam (f QueryParam))
-> (QueryParam -> Maybe (RText 'QueryKey))
-> p (RText 'QueryKey) (f (RText 'QueryKey))
-> p QueryParam (f QueryParam)
forall a b. (a -> b) -> a -> b
$ \case
  QueryFlag x :: RText 'QueryKey
x -> RText 'QueryKey -> Maybe (RText 'QueryKey)
forall a. a -> Maybe a
Just RText 'QueryKey
x
  _           -> 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 (x :: RText 'QueryKey
x, y :: 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 x :: RText 'QueryKey
x y :: RText 'QueryValue
y -> (RText 'QueryKey, RText 'QueryValue)
-> Maybe (RText 'QueryKey, RText 'QueryValue)
forall a. a -> Maybe a
Just (RText 'QueryKey
x, RText 'QueryValue
y)
      _              -> 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 k :: 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 k' :: RText 'QueryKey
k') = RText 'QueryKey
k' RText 'QueryKey -> RText 'QueryKey -> Bool
forall a. Eq a => a -> a -> Bool
== RText 'QueryKey
k
    g _              = 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 k :: RText 'QueryKey
k f :: 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 k' :: RText 'QueryKey
k' v :: 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 p :: 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 bt :: b -> t
bt seta :: 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' bs :: b -> s
bs sma :: 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
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 f :: 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)