    {-# LANGUAGE FlexibleContexts #-}
    --------------------------------------------------------------------------------
    -- |
    -- Module      : Network.OpenID.Normalization
    -- Copyright   : (c) Trevor Elliott, 2008
    -- License     : BSD3
    --
    -- Maintainer  : Trevor Elliott <trevor@geekgateway.com>
    -- Stability   :
    -- Portability :
    --

    module OpenId2.Normalization
        ( normalize
        ) where

    -- Friends
    import OpenId2.Types

    -- Libraries
    import Control.Applicative
    import Control.Monad
    import Data.List
    import Network.URI
        ( uriToString, normalizeCase, normalizeEscape
        , normalizePathSegments, parseURI, uriPath, uriScheme, uriFragment
        )
    import Data.Text (Text, pack, unpack)
    import Control.Monad.IO.Class
    import Control.Exception (throwIO)

    normalize :: MonadIO m => Text -> m Identifier
    normalize :: forall (m :: * -> *). MonadIO m => Text -> m Identifier
    normalize Text
    ident =
        case Identifier -> Maybe Identifier
    normalizeIdentifier (Identifier -> Maybe Identifier) -> Identifier -> Maybe Identifier
    forall a b. (a -> b) -> a -> b
    $ Text -> Identifier
    Identifier Text
    ident of
            Just Identifier
    i -> Identifier -> m Identifier
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Identifier
    i
            Maybe Identifier
    Nothing -> IO Identifier -> m Identifier
    forall a. IO a -> m a
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO Identifier -> m Identifier) -> IO Identifier -> m Identifier
    forall a b. (a -> b) -> a -> b
    $ AuthenticateException -> IO Identifier
    forall e a. (HasCallStack, Exception e) => e -> IO a
    throwIO (AuthenticateException -> IO Identifier)
    -> AuthenticateException -> IO Identifier
    forall a b. (a -> b) -> a -> b
    $ String -> AuthenticateException
    NormalizationException (String -> AuthenticateException)
    -> String -> AuthenticateException
    forall a b. (a -> b) -> a -> b
    $ Text -> String
    unpack Text
    ident

    -- | Normalize an identifier, discarding XRIs.
    normalizeIdentifier :: Identifier -> Maybe Identifier
    normalizeIdentifier :: Identifier -> Maybe Identifier
    normalizeIdentifier  = (String -> Maybe String) -> Identifier -> Maybe Identifier
    normalizeIdentifier' (Maybe String -> String -> Maybe String
    forall a b. a -> b -> a
    const Maybe String
    forall a. Maybe a
    Nothing)

    -- | Normalize the user supplied identifier, using a supplied function to
    -- normalize an XRI.
    normalizeIdentifier' :: (String -> Maybe String) -> Identifier
                         -> Maybe Identifier
    normalizeIdentifier' :: (String -> Maybe String) -> Identifier -> Maybe Identifier
    normalizeIdentifier' String -> Maybe String
    xri (Identifier Text
    str')
      | String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null String
    str                  = Maybe Identifier
    forall a. Maybe a
    Nothing
      | String
    "xri://" String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` String
    str = (Text -> Identifier
    Identifier (Text -> Identifier) -> (String -> Text) -> String -> Identifier
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Text
    pack) (String -> Identifier) -> Maybe String -> Maybe Identifier
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` String -> Maybe String
    xri String
    str
      | String -> Char
    forall a. HasCallStack => [a] -> a
    head String
    str Char -> String -> Bool
    forall a. Eq a => a -> [a] -> Bool
    forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
    `elem` String
    "=@+$!"   = (Text -> Identifier
    Identifier (Text -> Identifier) -> (String -> Text) -> String -> Identifier
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . String -> Text
    pack) (String -> Identifier) -> Maybe String -> Maybe Identifier
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` String -> Maybe String
    xri String
    str
      | Bool
    otherwise = URI -> Identifier
    fmt (URI -> Identifier) -> Maybe URI -> Maybe Identifier
    forall a b. (a -> b) -> Maybe a -> Maybe b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` (Maybe URI
    url Maybe URI -> (URI -> Maybe URI) -> Maybe URI
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
    >>= URI -> Maybe URI
    forall {m :: * -> *}. (Monad m, Alternative m) => URI -> m URI
    norm)
      where
        str :: String
    str = Text -> String
    unpack Text
    str'
        url :: Maybe URI
    url = String -> Maybe URI
    parseURI String
    str Maybe URI -> Maybe URI -> Maybe URI
    forall a. Maybe a -> Maybe a -> Maybe a
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
    <|> String -> Maybe URI
    parseURI (String
    "http://" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    str)

        norm :: URI -> m URI
    norm URI
    uri = m ()
    validScheme m () -> m URI -> m URI
    forall a b. m a -> m b -> m b
    forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
    >> URI -> m URI
    forall a. a -> m a
    forall (m :: * -> *) a. Monad m => a -> m a
    return URI
    u
          where
            scheme' :: String
    scheme'     = URI -> String
    uriScheme URI
    uri
            validScheme :: m ()
    validScheme = Bool -> m ()
    forall (f :: * -> *). Alternative f => Bool -> f ()
    guard (String
    scheme' String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    "http:" Bool -> Bool -> Bool
    || String
    scheme' String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    "https:")
            u :: URI
    u = URI
    uri { uriFragment = "", uriPath = path' }
            path' :: String
    path' | String -> Bool
    forall a. [a] -> Bool
    forall (t :: * -> *) a. Foldable t => t a -> Bool
    null (URI -> String
    uriPath URI
    uri) = String
    "/"
                  | Bool
    otherwise          = URI -> String
    uriPath URI
    uri

        fmt :: URI -> Identifier
    fmt URI
    u = Text -> Identifier
    Identifier
              (Text -> Identifier) -> Text -> Identifier
    forall a b. (a -> b) -> a -> b
    $ String -> Text
    pack
              (String -> Text) -> String -> Text
    forall a b. (a -> b) -> a -> b
    $ String -> String
    normalizePathSegments
              (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ String -> String
    normalizeEscape
              (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ String -> String
    normalizeCase
              (String -> String) -> String -> String
    forall a b. (a -> b) -> a -> b
    $ (String -> String) -> URI -> String -> String
    uriToString (String -> String -> String
    forall a b. a -> b -> a
    const String
    "") URI
    u []