{-# 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 forall a b. (a -> b) -> a -> b
$ Text -> Identifier
Identifier Text
ident of
        Just Identifier
i -> forall (m :: * -> *) a. Monad m => a -> m a
return Identifier
i
        Maybe Identifier
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => e -> IO a
throwIO forall a b. (a -> b) -> a -> b
$ String -> AuthenticateException
NormalizationException 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' (forall a b. a -> b -> a
const 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')
  | forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
str                  = forall a. Maybe a
Nothing
  | String
"xri://" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
str = (Text -> Identifier
Identifier forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Maybe String
xri String
str
  | forall a. [a] -> a
head String
str forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
"=@+$!"   = (Text -> Identifier
Identifier forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
pack) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Maybe String
xri String
str
  | Bool
otherwise = URI -> Identifier
fmt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Maybe URI
url forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= 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 forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> String -> Maybe URI
parseURI (String
"http://" forall a. [a] -> [a] -> [a]
++ String
str)

    norm :: URI -> m URI
norm URI
uri = m ()
validScheme forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *) a. Monad m => a -> m a
return URI
u
      where
        scheme' :: String
scheme'     = URI -> String
uriScheme URI
uri
        validScheme :: m ()
validScheme = forall (f :: * -> *). Alternative f => Bool -> f ()
guard (String
scheme' forall a. Eq a => a -> a -> Bool
== String
"http:" Bool -> Bool -> Bool
|| String
scheme' forall a. Eq a => a -> a -> Bool
== String
"https:")
        u :: URI
u = URI
uri { uriFragment :: String
uriFragment = String
"", uriPath :: String
uriPath = String
path' }
        path' :: String
path' | 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
          forall a b. (a -> b) -> a -> b
$ String -> Text
pack
          forall a b. (a -> b) -> a -> b
$ String -> String
normalizePathSegments
          forall a b. (a -> b) -> a -> b
$ String -> String
normalizeEscape
          forall a b. (a -> b) -> a -> b
$ String -> String
normalizeCase
          forall a b. (a -> b) -> a -> b
$ (String -> String) -> URI -> String -> String
uriToString (forall a b. a -> b -> a
const String
"") URI
u []