/usr/share/doc/libghc-authenticate-doc/html/src/OpenId2-Discovery.html is in libghc-authenticate-doc 1.0.0.1-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 | <?xml version="1.0" encoding="UTF-8"?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<html>
<head>
<!-- Generated by HsColour, http://code.haskell.org/~malcolm/hscolour/ -->
<title>OpenId2/Discovery.hs</title>
<link type='text/css' rel='stylesheet' href='hscolour.css' />
</head>
<body>
<pre><a name="line-1"></a><span class='hs-comment'>{-# LANGUAGE FlexibleContexts #-}</span>
<a name="line-2"></a><span class='hs-comment'>{-# LANGUAGE OverloadedStrings #-}</span>
<a name="line-3"></a>
<a name="line-4"></a><span class='hs-comment'>--------------------------------------------------------------------------------</span>
<a name="line-5"></a><span class='hs-comment'>-- |</span>
<a name="line-6"></a><span class='hs-comment'>-- Module : Network.OpenID.Discovery</span>
<a name="line-7"></a><span class='hs-comment'>-- Copyright : (c) Trevor Elliott, 2008</span>
<a name="line-8"></a><span class='hs-comment'>-- License : BSD3</span>
<a name="line-9"></a><span class='hs-comment'>--</span>
<a name="line-10"></a><span class='hs-comment'>-- Maintainer : Trevor Elliott <trevor@geekgateway.com></span>
<a name="line-11"></a><span class='hs-comment'>-- Stability :</span>
<a name="line-12"></a><span class='hs-comment'>-- Portability :</span>
<a name="line-13"></a><span class='hs-comment'>--</span>
<a name="line-14"></a>
<a name="line-15"></a><span class='hs-keyword'>module</span> <span class='hs-conid'>OpenId2</span><span class='hs-varop'>.</span><span class='hs-conid'>Discovery</span> <span class='hs-layout'>(</span>
<a name="line-16"></a> <span class='hs-comment'>-- * Discovery</span>
<a name="line-17"></a> <span class='hs-varid'>discover</span>
<a name="line-18"></a> <span class='hs-layout'>,</span> <span class='hs-conid'>Discovery</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>..</span><span class='hs-layout'>)</span>
<a name="line-19"></a> <span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>
<a name="line-20"></a>
<a name="line-21"></a><span class='hs-comment'>-- Friends</span>
<a name="line-22"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>OpenId2</span><span class='hs-varop'>.</span><span class='hs-conid'>Types</span>
<a name="line-23"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>OpenId2</span><span class='hs-varop'>.</span><span class='hs-conid'>XRDS</span>
<a name="line-24"></a>
<a name="line-25"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Debug</span><span class='hs-varop'>.</span><span class='hs-conid'>Trace</span>
<a name="line-26"></a><span class='hs-comment'>-- Libraries</span>
<a name="line-27"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Char</span>
<a name="line-28"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Maybe</span>
<a name="line-29"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Network</span><span class='hs-varop'>.</span><span class='hs-conid'>HTTP</span><span class='hs-varop'>.</span><span class='hs-conid'>Conduit</span>
<a name="line-30"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Conduit</span> <span class='hs-layout'>(</span><span class='hs-conid'>ResourceT</span><span class='hs-layout'>,</span> <span class='hs-conid'>ResourceIO</span><span class='hs-layout'>)</span>
<a name="line-31"></a><span class='hs-keyword'>import</span> <span class='hs-keyword'>qualified</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>ByteString</span><span class='hs-varop'>.</span><span class='hs-conid'>Char8</span> <span class='hs-keyword'>as</span> <span class='hs-conid'>S8</span>
<a name="line-32"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Arrow</span> <span class='hs-layout'>(</span><span class='hs-varid'>first</span><span class='hs-layout'>)</span>
<a name="line-33"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>IO</span><span class='hs-varop'>.</span><span class='hs-conid'>Class</span> <span class='hs-layout'>(</span><span class='hs-conid'>MonadIO</span> <span class='hs-layout'>(</span><span class='hs-varid'>liftIO</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-34"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span> <span class='hs-layout'>(</span><span class='hs-varid'>mplus</span><span class='hs-layout'>)</span>
<a name="line-35"></a><span class='hs-keyword'>import</span> <span class='hs-keyword'>qualified</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>CaseInsensitive</span> <span class='hs-keyword'>as</span> <span class='hs-conid'>CI</span>
<a name="line-36"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Text</span> <span class='hs-layout'>(</span><span class='hs-conid'>Text</span><span class='hs-layout'>,</span> <span class='hs-varid'>unpack</span><span class='hs-layout'>)</span>
<a name="line-37"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Text</span><span class='hs-varop'>.</span><span class='hs-conid'>Lazy</span> <span class='hs-layout'>(</span><span class='hs-varid'>toStrict</span><span class='hs-layout'>)</span>
<a name="line-38"></a><span class='hs-keyword'>import</span> <span class='hs-keyword'>qualified</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Text</span> <span class='hs-keyword'>as</span> <span class='hs-conid'>T</span>
<a name="line-39"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Text</span><span class='hs-varop'>.</span><span class='hs-conid'>Lazy</span><span class='hs-varop'>.</span><span class='hs-conid'>Encoding</span> <span class='hs-layout'>(</span><span class='hs-varid'>decodeUtf8With</span><span class='hs-layout'>)</span>
<a name="line-40"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Text</span><span class='hs-varop'>.</span><span class='hs-conid'>Encoding</span><span class='hs-varop'>.</span><span class='hs-conid'>Error</span> <span class='hs-layout'>(</span><span class='hs-varid'>lenientDecode</span><span class='hs-layout'>)</span>
<a name="line-41"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Text</span><span class='hs-varop'>.</span><span class='hs-conid'>HTML</span><span class='hs-varop'>.</span><span class='hs-conid'>TagSoup</span> <span class='hs-layout'>(</span><span class='hs-varid'>parseTags</span><span class='hs-layout'>,</span> <span class='hs-conid'>Tag</span> <span class='hs-layout'>(</span><span class='hs-conid'>TagOpen</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-42"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Applicative</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varop'><$></span><span class='hs-layout'>)</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varop'><*></span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-43"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Network</span><span class='hs-varop'>.</span><span class='hs-conid'>HTTP</span><span class='hs-varop'>.</span><span class='hs-conid'>Types</span> <span class='hs-layout'>(</span><span class='hs-varid'>status200</span><span class='hs-layout'>)</span>
<a name="line-44"></a><span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Exception</span> <span class='hs-layout'>(</span><span class='hs-varid'>throwIO</span><span class='hs-layout'>)</span>
<a name="line-45"></a>
<a name="line-46"></a><a name="Discovery"></a><span class='hs-keyword'>data</span> <span class='hs-conid'>Discovery</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Discovery1</span> <span class='hs-conid'>Text</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-conid'>Text</span><span class='hs-layout'>)</span>
<a name="line-47"></a> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Discovery2</span> <span class='hs-conid'>Provider</span> <span class='hs-conid'>Identifier</span> <span class='hs-conid'>IdentType</span>
<a name="line-48"></a> <span class='hs-keyword'>deriving</span> <span class='hs-conid'>Show</span>
<a name="line-49"></a>
<a name="line-50"></a><a name="discover"></a><span class='hs-comment'>-- | Attempt to resolve an OpenID endpoint, and user identifier.</span>
<a name="line-51"></a><span class='hs-definition'>discover</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ResourceIO</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>Identifier</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Manager</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ResourceT</span> <span class='hs-varid'>m</span> <span class='hs-conid'>Discovery</span>
<a name="line-52"></a><span class='hs-definition'>discover</span> <span class='hs-varid'>ident</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>Identifier</span> <span class='hs-varid'>i</span><span class='hs-layout'>)</span> <span class='hs-varid'>manager</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-53"></a> <span class='hs-varid'>res1</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>discoverYADIS</span> <span class='hs-varid'>ident</span> <span class='hs-conid'>Nothing</span> <span class='hs-num'>10</span> <span class='hs-varid'>manager</span>
<a name="line-54"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>res1</span> <span class='hs-keyword'>of</span>
<a name="line-55"></a> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-layout'>,</span> <span class='hs-varid'>y</span><span class='hs-layout'>,</span> <span class='hs-varid'>z</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-conid'>Discovery2</span> <span class='hs-varid'>x</span> <span class='hs-varid'>y</span> <span class='hs-varid'>z</span>
<a name="line-56"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-57"></a> <span class='hs-varid'>res2</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>discoverHTML</span> <span class='hs-varid'>ident</span> <span class='hs-varid'>manager</span>
<a name="line-58"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>res2</span> <span class='hs-keyword'>of</span>
<a name="line-59"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varid'>x</span>
<a name="line-60"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>liftIO</span> <span class='hs-varop'>$</span> <span class='hs-varid'>throwIO</span> <span class='hs-varop'>$</span> <span class='hs-conid'>DiscoveryException</span> <span class='hs-varop'>$</span> <span class='hs-varid'>unpack</span> <span class='hs-varid'>i</span>
<a name="line-61"></a>
<a name="line-62"></a><span class='hs-comment'>-- YADIS-Based Discovery -------------------------------------------------------</span>
<a name="line-63"></a>
<a name="line-64"></a><a name="discoverYADIS"></a><span class='hs-comment'>-- | Attempt a YADIS based discovery, given a valid identifier. The result is</span>
<a name="line-65"></a><span class='hs-comment'>-- an OpenID endpoint, and the actual identifier for the user.</span>
<a name="line-66"></a><span class='hs-definition'>discoverYADIS</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ResourceIO</span> <span class='hs-varid'>m</span>
<a name="line-67"></a> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>Identifier</span>
<a name="line-68"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-conid'>String</span>
<a name="line-69"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Int</span> <span class='hs-comment'>-- ^ remaining redirects</span>
<a name="line-70"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Manager</span>
<a name="line-71"></a> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ResourceT</span> <span class='hs-varid'>m</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-layout'>(</span><span class='hs-conid'>Provider</span><span class='hs-layout'>,</span> <span class='hs-conid'>Identifier</span><span class='hs-layout'>,</span> <span class='hs-conid'>IdentType</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-72"></a><span class='hs-definition'>discoverYADIS</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-num'>0</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>liftIO</span> <span class='hs-varop'>$</span> <span class='hs-varid'>throwIO</span> <span class='hs-conid'>TooManyRedirects</span>
<a name="line-73"></a><span class='hs-definition'>discoverYADIS</span> <span class='hs-varid'>ident</span> <span class='hs-varid'>mb_loc</span> <span class='hs-varid'>redirects</span> <span class='hs-varid'>manager</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-74"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>uri</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>fromMaybe</span> <span class='hs-layout'>(</span><span class='hs-varid'>unpack</span> <span class='hs-varop'>$</span> <span class='hs-varid'>identifier</span> <span class='hs-varid'>ident</span><span class='hs-layout'>)</span> <span class='hs-varid'>mb_loc</span>
<a name="line-75"></a> <span class='hs-varid'>req</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>liftIO</span> <span class='hs-varop'>$</span> <span class='hs-varid'>parseUrl</span> <span class='hs-varid'>uri</span>
<a name="line-76"></a> <span class='hs-varid'>res</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>httpLbs</span> <span class='hs-varid'>req</span> <span class='hs-layout'>{</span> <span class='hs-varid'>checkStatus</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Nothing</span> <span class='hs-layout'>}</span> <span class='hs-varid'>manager</span>
<a name="line-77"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>mloc</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>fmap</span> <span class='hs-conid'>S8</span><span class='hs-varop'>.</span><span class='hs-varid'>unpack</span>
<a name="line-78"></a> <span class='hs-varop'>$</span> <span class='hs-varid'>lookup</span> <span class='hs-str'>"x-xrds-location"</span>
<a name="line-79"></a> <span class='hs-varop'>$</span> <span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>first</span> <span class='hs-varop'>$</span> <span class='hs-varid'>map</span> <span class='hs-varid'>toLower</span> <span class='hs-varop'>.</span> <span class='hs-conid'>S8</span><span class='hs-varop'>.</span><span class='hs-varid'>unpack</span> <span class='hs-varop'>.</span> <span class='hs-conid'>CI</span><span class='hs-varop'>.</span><span class='hs-varid'>original</span><span class='hs-layout'>)</span>
<a name="line-80"></a> <span class='hs-varop'>$</span> <span class='hs-varid'>responseHeaders</span> <span class='hs-varid'>res</span>
<a name="line-81"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>mloc'</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>if</span> <span class='hs-varid'>mloc</span> <span class='hs-varop'>==</span> <span class='hs-varid'>mb_loc</span> <span class='hs-keyword'>then</span> <span class='hs-conid'>Nothing</span> <span class='hs-keyword'>else</span> <span class='hs-varid'>mloc</span>
<a name="line-82"></a> <span class='hs-keyword'>if</span> <span class='hs-varid'>statusCode</span> <span class='hs-varid'>res</span> <span class='hs-varop'>==</span> <span class='hs-varid'>status200</span>
<a name="line-83"></a> <span class='hs-keyword'>then</span>
<a name="line-84"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>mloc'</span> <span class='hs-keyword'>of</span>
<a name="line-85"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>loc</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>discoverYADIS</span> <span class='hs-varid'>ident</span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>loc</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>redirects</span> <span class='hs-comment'>-</span> <span class='hs-num'>1</span><span class='hs-layout'>)</span> <span class='hs-varid'>manager</span>
<a name="line-86"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>do</span>
<a name="line-87"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>mdoc</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>parseXRDS</span> <span class='hs-varop'>$</span> <span class='hs-varid'>responseBody</span> <span class='hs-varid'>res</span>
<a name="line-88"></a> <span class='hs-keyword'>case</span> <span class='hs-varid'>mdoc</span> <span class='hs-keyword'>of</span>
<a name="line-89"></a> <span class='hs-conid'>Just</span> <span class='hs-varid'>doc</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-varid'>parseYADIS</span> <span class='hs-varid'>ident</span> <span class='hs-varid'>doc</span>
<a name="line-90"></a> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-conid'>Nothing</span>
<a name="line-91"></a> <span class='hs-keyword'>else</span> <span class='hs-varid'>return</span> <span class='hs-conid'>Nothing</span>
<a name="line-92"></a>
<a name="line-93"></a>
<a name="line-94"></a><a name="parseYADIS"></a><span class='hs-comment'>-- | Parse out an OpenID endpoint, and actual identifier from a YADIS xml</span>
<a name="line-95"></a><span class='hs-comment'>-- document.</span>
<a name="line-96"></a><span class='hs-definition'>parseYADIS</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Identifier</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>XRDS</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-layout'>(</span><span class='hs-conid'>Provider</span><span class='hs-layout'>,</span> <span class='hs-conid'>Identifier</span><span class='hs-layout'>,</span> <span class='hs-conid'>IdentType</span><span class='hs-layout'>)</span>
<a name="line-97"></a><span class='hs-definition'>parseYADIS</span> <span class='hs-varid'>ident</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>listToMaybe</span> <span class='hs-varop'>.</span> <span class='hs-varid'>mapMaybe</span> <span class='hs-varid'>isOpenId</span> <span class='hs-varop'>.</span> <span class='hs-varid'>concat</span>
<a name="line-98"></a> <span class='hs-keyword'>where</span>
<a name="line-99"></a> <span class='hs-varid'>isOpenId</span> <span class='hs-varid'>svc</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-100"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>tys</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>serviceTypes</span> <span class='hs-varid'>svc</span>
<a name="line-101"></a> <span class='hs-varid'>localId</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>maybe</span> <span class='hs-varid'>ident</span> <span class='hs-conid'>Identifier</span> <span class='hs-varop'>$</span> <span class='hs-varid'>listToMaybe</span> <span class='hs-varop'>$</span> <span class='hs-varid'>serviceLocalIDs</span> <span class='hs-varid'>svc</span>
<a name="line-102"></a> <span class='hs-varid'>f</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-layout'>,</span><span class='hs-varid'>y</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>x</span> <span class='hs-varop'>`elem`</span> <span class='hs-varid'>tys</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Just</span> <span class='hs-varid'>y</span>
<a name="line-103"></a> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Nothing</span>
<a name="line-104"></a> <span class='hs-layout'>(</span><span class='hs-varid'>lid</span><span class='hs-layout'>,</span> <span class='hs-varid'>itype</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>listToMaybe</span> <span class='hs-varop'>$</span> <span class='hs-varid'>mapMaybe</span> <span class='hs-varid'>f</span>
<a name="line-105"></a> <span class='hs-keyglyph'>[</span> <span class='hs-layout'>(</span><span class='hs-str'>"http://specs.openid.net/auth/2.0/server"</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varid'>ident</span><span class='hs-layout'>,</span> <span class='hs-conid'>OPIdent</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-106"></a> <span class='hs-comment'>-- claimed identifiers</span>
<a name="line-107"></a> <span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-str'>"http://specs.openid.net/auth/2.0/signon"</span><span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varid'>localId</span><span class='hs-layout'>,</span> <span class='hs-conid'>ClaimedIdent</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-108"></a> <span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-str'>"http://openid.net/signon/1.0"</span> <span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varid'>localId</span><span class='hs-layout'>,</span> <span class='hs-conid'>ClaimedIdent</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-109"></a> <span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-str'>"http://openid.net/signon/1.1"</span> <span class='hs-layout'>,</span> <span class='hs-layout'>(</span><span class='hs-varid'>localId</span><span class='hs-layout'>,</span> <span class='hs-conid'>ClaimedIdent</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>
<a name="line-110"></a> <span class='hs-keyglyph'>]</span>
<a name="line-111"></a> <span class='hs-varid'>uri</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>listToMaybe</span> <span class='hs-varop'>$</span> <span class='hs-varid'>serviceURIs</span> <span class='hs-varid'>svc</span>
<a name="line-112"></a> <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-conid'>Provider</span> <span class='hs-varid'>uri</span><span class='hs-layout'>,</span> <span class='hs-varid'>lid</span><span class='hs-layout'>,</span> <span class='hs-varid'>itype</span><span class='hs-layout'>)</span>
<a name="line-113"></a>
<a name="line-114"></a>
<a name="line-115"></a><span class='hs-comment'>-- HTML-Based Discovery --------------------------------------------------------</span>
<a name="line-116"></a>
<a name="line-117"></a><a name="discoverHTML"></a><span class='hs-comment'>-- | Attempt to discover an OpenID endpoint, from an HTML document. The result</span>
<a name="line-118"></a><span class='hs-comment'>-- will be an endpoint on success, and the actual identifier of the user.</span>
<a name="line-119"></a><span class='hs-definition'>discoverHTML</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ResourceIO</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>Identifier</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Manager</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ResourceT</span> <span class='hs-varid'>m</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-conid'>Discovery</span><span class='hs-layout'>)</span>
<a name="line-120"></a><span class='hs-definition'>discoverHTML</span> <span class='hs-varid'>ident'</span><span class='hs-keyglyph'>@</span><span class='hs-layout'>(</span><span class='hs-conid'>Identifier</span> <span class='hs-varid'>ident</span><span class='hs-layout'>)</span> <span class='hs-varid'>manager</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-121"></a> <span class='hs-varid'>req</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>liftIO</span> <span class='hs-varop'>$</span> <span class='hs-varid'>parseUrl</span> <span class='hs-varop'>$</span> <span class='hs-varid'>unpack</span> <span class='hs-varid'>ident</span>
<a name="line-122"></a> <span class='hs-conid'>Response</span> <span class='hs-keyword'>_</span> <span class='hs-keyword'>_</span> <span class='hs-varid'>lbs</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>httpLbs</span> <span class='hs-varid'>req</span> <span class='hs-varid'>manager</span>
<a name="line-123"></a> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-varid'>parseHTML</span> <span class='hs-varid'>ident'</span> <span class='hs-varop'>.</span> <span class='hs-varid'>toStrict</span> <span class='hs-varop'>.</span> <span class='hs-varid'>decodeUtf8With</span> <span class='hs-varid'>lenientDecode</span> <span class='hs-varop'>$</span> <span class='hs-varid'>lbs</span>
<a name="line-124"></a>
<a name="line-125"></a><a name="parseHTML"></a><span class='hs-comment'>-- | Parse out an OpenID endpoint and an actual identifier from an HTML</span>
<a name="line-126"></a><span class='hs-comment'>-- document.</span>
<a name="line-127"></a><span class='hs-definition'>parseHTML</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Identifier</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Text</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-conid'>Discovery</span>
<a name="line-128"></a><span class='hs-definition'>parseHTML</span> <span class='hs-varid'>ident</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>resolve</span>
<a name="line-129"></a> <span class='hs-varop'>.</span> <span class='hs-varid'>filter</span> <span class='hs-varid'>isOpenId</span>
<a name="line-130"></a> <span class='hs-varop'>.</span> <span class='hs-varid'>mapMaybe</span> <span class='hs-varid'>linkTag</span>
<a name="line-131"></a> <span class='hs-varop'>.</span> <span class='hs-varid'>parseTags</span>
<a name="line-132"></a> <span class='hs-keyword'>where</span>
<a name="line-133"></a> <span class='hs-varid'>isOpenId</span> <span class='hs-layout'>(</span><span class='hs-varid'>rel</span><span class='hs-layout'>,</span> <span class='hs-sel'>_x</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-str'>"openid"</span> <span class='hs-varop'>`</span><span class='hs-conid'>T</span><span class='hs-varop'>.</span><span class='hs-varid'>isPrefixOf</span><span class='hs-varop'>`</span> <span class='hs-varid'>rel</span>
<a name="line-134"></a> <span class='hs-varid'>resolve1</span> <span class='hs-varid'>ls</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-135"></a> <span class='hs-varid'>server</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lookup</span> <span class='hs-str'>"openid.server"</span> <span class='hs-varid'>ls</span>
<a name="line-136"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>delegate</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lookup</span> <span class='hs-str'>"openid.delegate"</span> <span class='hs-varid'>ls</span>
<a name="line-137"></a> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-conid'>Discovery1</span> <span class='hs-varid'>server</span> <span class='hs-varid'>delegate</span>
<a name="line-138"></a> <span class='hs-varid'>resolve2</span> <span class='hs-varid'>ls</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>
<a name="line-139"></a> <span class='hs-varid'>prov</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lookup</span> <span class='hs-str'>"openid2.provider"</span> <span class='hs-varid'>ls</span>
<a name="line-140"></a> <span class='hs-keyword'>let</span> <span class='hs-varid'>lid</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>maybe</span> <span class='hs-varid'>ident</span> <span class='hs-conid'>Identifier</span> <span class='hs-varop'>$</span> <span class='hs-varid'>lookup</span> <span class='hs-str'>"openid2.local_id"</span> <span class='hs-varid'>ls</span>
<a name="line-141"></a> <span class='hs-comment'>-- Based on OpenID 2.0 spec, section 7.3.3, HTML discovery can only</span>
<a name="line-142"></a> <span class='hs-comment'>-- result in a claimed identifier.</span>
<a name="line-143"></a> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-conid'>Discovery2</span> <span class='hs-layout'>(</span><span class='hs-conid'>Provider</span> <span class='hs-varid'>prov</span><span class='hs-layout'>)</span> <span class='hs-varid'>lid</span> <span class='hs-conid'>ClaimedIdent</span>
<a name="line-144"></a> <span class='hs-varid'>resolve</span> <span class='hs-varid'>ls</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>resolve2</span> <span class='hs-varid'>ls</span> <span class='hs-varop'>`mplus`</span> <span class='hs-varid'>resolve1</span> <span class='hs-varid'>ls</span>
<a name="line-145"></a>
<a name="line-146"></a>
<a name="line-147"></a><a name="linkTag"></a><span class='hs-comment'>-- | Filter out link tags from a list of html tags.</span>
<a name="line-148"></a><span class='hs-definition'>linkTag</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Tag</span> <span class='hs-conid'>Text</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-layout'>(</span><span class='hs-conid'>Text</span><span class='hs-layout'>,</span> <span class='hs-conid'>Text</span><span class='hs-layout'>)</span>
<a name="line-149"></a><span class='hs-definition'>linkTag</span> <span class='hs-layout'>(</span><span class='hs-conid'>TagOpen</span> <span class='hs-str'>"link"</span> <span class='hs-keyword'>as</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>let</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>(,)</span> <span class='hs-varop'><$></span> <span class='hs-varid'>lookup</span> <span class='hs-str'>"rel"</span> <span class='hs-keyword'>as</span> <span class='hs-varop'><*></span> <span class='hs-varid'>lookup</span> <span class='hs-str'>"href"</span> <span class='hs-keyword'>as</span> <span class='hs-keyword'>in</span> <span class='hs-varid'>traceShow</span> <span class='hs-varid'>x</span> <span class='hs-varid'>x</span>
<a name="line-150"></a><span class='hs-definition'>linkTag</span> <span class='hs-sel'>_x</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Nothing</span>
</pre></body>
</html>
|