1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
|
{-# 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 ident =
case normalizeIdentifier $ Identifier ident of
Just i -> return i
Nothing -> liftIO $ throwIO $ NormalizationException $ unpack ident
-- | Normalize an identifier, discarding XRIs.
normalizeIdentifier :: Identifier -> Maybe Identifier
normalizeIdentifier = normalizeIdentifier' (const Nothing)
-- | Normalize the user supplied identifier, using a supplied function to
-- normalize an XRI.
normalizeIdentifier' :: (String -> Maybe String) -> Identifier
-> Maybe Identifier
normalizeIdentifier' xri (Identifier str')
| null str = Nothing
| "xri://" `isPrefixOf` str = (Identifier . pack) `fmap` xri str
| head str `elem` "=@+$!" = (Identifier . pack) `fmap` xri str
| otherwise = fmt `fmap` (url >>= norm)
where
str = unpack str'
url = parseURI str <|> parseURI ("http://" ++ str)
norm uri = validScheme >> return u
where
scheme' = uriScheme uri
validScheme = guard (scheme' == "http:" || scheme' == "https:")
u = uri { uriFragment = "", uriPath = path' }
path' | null (uriPath uri) = "/"
| otherwise = uriPath uri
fmt u = Identifier
$ pack
$ normalizePathSegments
$ normalizeEscape
$ normalizeCase
$ uriToString (const "") u []
|
