{-# LANGUAGE OverloadedStrings #-}

module SAML2.Util
  ( module SAML2.Util,
    module Text.XML.Util,
  )
where

import Control.Lens
import Control.Monad.Except
import Data.String.Conversions
import qualified Data.Text as ST
import Data.Typeable
import GHC.Stack
import Text.XML.Util
import URI.ByteString

renderURI :: URI -> ST
renderURI :: URI -> ST
renderURI = ByteString -> ST
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> ST) -> (URI -> ByteString) -> URI -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> ByteString
forall a. URIRef a -> ByteString
serializeURIRef'

parseURI' :: MonadError String m => ST -> m URI
parseURI' :: forall (m :: * -> *). MonadError [Char] m => ST -> m URI
parseURI' ST
uri = (URIParseError -> m URI)
-> (URI -> m URI) -> Either URIParseError URI -> m URI
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe [Char] -> Proxy URI -> URIParseError -> m URI
forall a b c (m :: * -> *).
(Typeable a, Show b, MonadError [Char] m) =>
Maybe [Char] -> Proxy a -> b -> m c
die' ([Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ ST -> [Char]
forall a. Show a => a -> [Char]
show ST
uri) (forall t. Proxy t
forall {k} (t :: k). Proxy t
Proxy @URI)) URI -> m URI
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either URIParseError URI -> m URI)
-> (ST -> Either URIParseError URI) -> ST -> m URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URIParserOptions -> ByteString -> Either URIParseError URI
parseURI URIParserOptions
laxURIParserOptions (ByteString -> Either URIParseError URI)
-> (ST -> ByteString) -> ST -> Either URIParseError URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs (ST -> ByteString) -> (ST -> ST) -> ST -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> ST
ST.strip (ST -> m URI) -> ST -> m URI
forall a b. (a -> b) -> a -> b
$ ST
uri

-- | You probably should not use this.  If you have a string literal, consider "URI.ByteString.QQ".
unsafeParseURI :: ST -> URI
unsafeParseURI :: ST -> URI
unsafeParseURI = ([Char] -> URI) -> (URI -> URI) -> Either [Char] URI -> URI
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ([Char] -> URI
forall a. HasCallStack => [Char] -> a
error ([Char] -> URI) -> ([Char] -> [Char]) -> [Char] -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
"could not parse config: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<>) ([Char] -> [Char]) -> ([Char] -> [Char]) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char]
forall a. Show a => a -> [Char]
show) URI -> URI
forall a. a -> a
id (Either [Char] URI -> URI)
-> (ST -> Either [Char] URI) -> ST -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> Either [Char] URI
forall (m :: * -> *). MonadError [Char] m => ST -> m URI
parseURI'

-- | @uriSegments "/one/two" == uriSegments "one/two/" == uriSegments "///one//two///" == ["one", "two"]@
uriSegments :: ST -> [ST]
uriSegments :: ST -> [ST]
uriSegments = (ST -> Bool) -> [ST] -> [ST]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ST -> Bool) -> ST -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> Bool
ST.null) ([ST] -> [ST]) -> (ST -> [ST]) -> ST -> [ST]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => ST -> ST -> [ST]
ST -> ST -> [ST]
ST.splitOn ST
"/"

uriUnSegments :: [ST] -> ST
uriUnSegments :: [ST] -> ST
uriUnSegments = (ST
"/" ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<>) (ST -> ST) -> ([ST] -> ST) -> [ST] -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> [ST] -> ST
ST.intercalate ST
"/"

(-/) :: HasCallStack => ST -> ST -> ST
ST
oldpath -/ :: HasCallStack => ST -> ST -> ST
-/ ST
pathext = [ST] -> ST
uriUnSegments ([ST] -> ST) -> (ST -> [ST]) -> ST -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ST -> [ST]
uriSegments (ST -> ST) -> ST -> ST
forall a b. (a -> b) -> a -> b
$ ST
oldpath ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<> ST
"/" ST -> ST -> ST
forall a. Semigroup a => a -> a -> a
<> ST
pathext

(=/) :: HasCallStack => URI -> ST -> URI
URI
uri =/ :: HasCallStack => URI -> ST -> URI
=/ ST
pathext = URI -> URI
normURI (URI -> URI) -> URI -> URI
forall a b. (a -> b) -> a -> b
$ URI
uri URI -> (URI -> URI) -> URI
forall a b. a -> (a -> b) -> b
& (ByteString -> Identity ByteString) -> URI -> Identity URI
forall a (f :: * -> *).
Functor f =>
(ByteString -> f ByteString) -> URIRef a -> f (URIRef a)
pathL ((ByteString -> Identity ByteString) -> URI -> Identity URI)
-> (ByteString -> ByteString) -> URI -> URI
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"/" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ST -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs ST
pathext)

normURI :: URI -> URI
normURI :: URI -> URI
normURI =
  ST -> URI
unsafeParseURI (ST -> URI) -> (URI -> ST) -> URI -> URI
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ST
forall a b. ConvertibleStrings a b => a -> b
cs
    (ByteString -> ST) -> (URI -> ByteString) -> URI -> ST
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URINormalizationOptions -> URI -> ByteString
forall a. URINormalizationOptions -> URIRef a -> ByteString
normalizeURIRef'
      URINormalizationOptions
        { unoDowncaseScheme :: Bool
unoDowncaseScheme = Bool
True,
          unoDowncaseHost :: Bool
unoDowncaseHost = Bool
True,
          unoDropDefPort :: Bool
unoDropDefPort = Bool
False,
          unoSlashEmptyPath :: Bool
unoSlashEmptyPath = Bool
True,
          unoDropExtraSlashes :: Bool
unoDropExtraSlashes = Bool
True,
          unoSortParameters :: Bool
unoSortParameters = Bool
True,
          unoRemoveDotSegments :: Bool
unoRemoveDotSegments = Bool
True,
          unoDefaultPorts :: Map Scheme Port
unoDefaultPorts = Map Scheme Port
forall a. Monoid a => a
mempty
        }