{-# 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 :: 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 (m :: * -> *) a. Monad m => a -> m a
return Identifier
i
        Maybe Identifier
Nothing -> IO Identifier -> m Identifier
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. 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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` String -> Maybe String
xri String
str
  | String -> Char
forall a. [a] -> a
head String
str Char -> String -> 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 (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 (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (Maybe URI
url Maybe URI -> (URI -> Maybe URI) -> Maybe URI
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 (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 (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> URI -> m URI
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 :: String
uriFragment = String
"", uriPath :: String
uriPath = String
path' }
        path' :: String
path' | String -> 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 []