haskell/yesod
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch 'master' of git://github.com/snoyberg/authenticate into proposed

Browse Source
This commit is contained in:
Hiromi Ishii 2011-08-25 11:32:53 +09:00
commit 0d7c6a222b
11 changed files with 264 additions and 190 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
OpenId2/Discovery.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- |
@ -21,12 +22,12 @@ module OpenId2.Discovery (
import OpenId2.Types
import OpenId2.XRDS
import Debug.Trace
-- Libraries
import Data.Char
import Data.List
import Data.Maybe
import Network.HTTP.Enumerator
import qualified Data.ByteString.Lazy.UTF8 as BSLU
import qualified Data.ByteString.Char8 as S8
import Control.Arrow (first, (***))
import Control.Monad.IO.Class (MonadIO (liftIO))
@ -34,8 +35,14 @@ import Control.Failure (Failure (failure))
import Control.Monad (mplus, liftM)
import qualified Data.CaseInsensitive as CI
import Data.Text (Text, pack, unpack)
import Data.Text.Lazy (toStrict)
import qualified Data.Text as T
import Data.Text.Lazy.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Text.HTML.TagSoup (parseTags, Tag (TagOpen))
import Control.Applicative ((<$>), (<*>))
data Discovery = Discovery1 String (Maybe String)
data Discovery = Discovery1 Text (Maybe Text)
| Discovery2 Provider Identifier IdentType
deriving Show
@ -82,7 +89,8 @@ discoverYADIS ident mb_loc redirects = do
case mloc' of
Just loc -> discoverYADIS ident (Just loc) (redirects - 1)
Nothing -> do
let mdoc = parseXRDS $ BSLU.toString $ responseBody res
let mdoc = parseXRDS $ responseBody res
liftIO $ print mdoc
case mdoc of
Just doc -> return $ parseYADIS ident doc
Nothing -> return Nothing
@ -96,7 +104,7 @@ parseYADIS ident = listToMaybe . mapMaybe isOpenId . concat
where
isOpenId svc = do
let tys = serviceTypes svc
localId = maybe ident (Identifier . pack) $ listToMaybe $ serviceLocalIDs svc
localId = maybe ident Identifier $ listToMaybe $ serviceLocalIDs svc
f (x,y) | x `elem` tys = Just y
| otherwise = Nothing
(lid, itype) <- listToMaybe $ mapMaybe f
@ -118,72 +126,31 @@ discoverHTML :: ( MonadIO m, Failure HttpException m)
=> Identifier
-> m (Maybe Discovery)
discoverHTML ident'@(Identifier ident) =
(parseHTML ident' . BSLU.toString) `liftM` simpleHttp (unpack ident)
(parseHTML ident' . toStrict . decodeUtf8With lenientDecode) `liftM` simpleHttp (unpack ident)
-- | Parse out an OpenID endpoint and an actual identifier from an HTML
-- document.
parseHTML :: Identifier -> String -> Maybe Discovery
parseHTML :: Identifier -> Text -> Maybe Discovery
parseHTML ident = resolve
. filter isOpenId
. map (dropQuotes *** dropQuotes)
. linkTags
. htmlTags
. mapMaybe linkTag
. parseTags
where
isOpenId (rel,_) = "openid" `isPrefixOf` rel
isOpenId (rel, x) = "openid" `T.isPrefixOf` rel
resolve1 ls = do
server <- lookup "openid.server" ls
let delegate = lookup "openid.delegate" ls
return $ Discovery1 server delegate
resolve2 ls = do
prov <- lookup "openid2.provider" ls
let lid = maybe ident (Identifier . pack) $ lookup "openid2.local_id" ls
let lid = maybe ident Identifier $ lookup "openid2.local_id" ls
-- Based on OpenID 2.0 spec, section 7.3.3, HTML discovery can only
-- result in a claimed identifier.
return $ Discovery2 (Provider prov) lid ClaimedIdent
resolve ls = resolve2 ls `mplus` resolve1 ls
-- FIXME this would all be a lot better if it used tagsoup
-- | Filter out link tags from a list of html tags.
linkTags :: [String] -> [(String,String)]
linkTags = mapMaybe f . filter p
where
p = ("link " `isPrefixOf`)
f xs = do
let ys = unfoldr splitAttr (drop 5 xs)
x <- lookup "rel" ys
y <- lookup "href" ys
return (x,y)
-- | Split a string into strings of html tags.
htmlTags :: String -> [String]
htmlTags [] = []
htmlTags xs = case break (== '<') xs of
(as,_:bs) -> fmt as : htmlTags bs
(as,[]) -> [as]
where
fmt as = case break (== '>') as of
(bs,_) -> bs
-- | Split out values from a key="value" like string, in a way that
-- is suitable for use with unfoldr.
splitAttr :: String -> Maybe ((String,String),String)
splitAttr xs = case break (== '=') xs of
(_,[]) -> Nothing
(key,_:'"':ys) -> f key (== '"') ys
(key,_:ys) -> f key isSpace ys
where
f key p cs = case break p cs of
(_,[]) -> Nothing
(value,_:rest) -> Just ((key,value), dropWhile isSpace rest)
dropQuotes :: String -> String
dropQuotes s@('\'':x:y)
| last y == '\'' = x : init y
| otherwise = s
dropQuotes s@('"':x:y)
| last y == '"' = x : init y
| otherwise = s
dropQuotes s = s
--linkTags :: [Tag Text] -> [(Text, Text)]
linkTag (TagOpen "link" as) = let x = (,) <$> lookup "rel" as <*> lookup "href" as in traceShow x x
linkTag x = Nothing

2
OpenId2/Types.hs
View File

@ -24,7 +24,7 @@ import Web.Authenticate.Internal
import Data.Text (Text)
-- | An OpenID provider.
newtype Provider = Provider { providerURI :: String } deriving (Eq,Show)
newtype Provider = Provider { providerURI :: Text } deriving (Eq,Show)
-- | A valid OpenID identifier.
newtype Identifier = Identifier { identifier :: Text }

108
OpenId2/XRDS.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------------------
-- |
-- Module : Text.XRDS
@ -20,12 +20,13 @@ module OpenId2.XRDS (
) where
-- Libraries
import Control.Arrow
import Control.Monad
import Data.List
import Data.Maybe
import Text.XML.Light
import Control.Monad ((>=>))
import Data.Maybe (listToMaybe)
import Text.XML.Enumerator.Resolved (parseLBS, decodeEntities)
import Text.XML.Enumerator.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute, node)
import qualified Data.ByteString.Lazy as L
import Data.Text (Text)
import qualified Data.Text.Read
-- Types -----------------------------------------------------------------------
@ -34,68 +35,43 @@ type XRDS = [XRD]
type XRD = [Service]
data Service = Service
{ serviceTypes :: [String]
, serviceMediaTypes :: [String]
, serviceURIs :: [String]
, serviceLocalIDs :: [String]
{ serviceTypes :: [Text]
, serviceMediaTypes :: [Text]
, serviceURIs :: [Text]
, serviceLocalIDs :: [Text]
, servicePriority :: Maybe Int
, serviceExtra :: [Element]
} deriving Show
-- Utilities -------------------------------------------------------------------
parseXRDS :: L.ByteString -> Maybe XRDS
parseXRDS str =
either
(const Nothing)
(Just . parseXRDS' . fromDocument)
(parseLBS str decodeEntities)
-- | Generate a tag name predicate, that ignores prefix and namespace.
tag :: String -> Element -> Bool
tag n el = qName (elName el) == n
parseXRDS' :: Cursor -> [[Service]]
parseXRDS' = element "{xri://$xrds}XRDS" &/
element "{xri://$xrd*($v*2.0)}XRD" &|
parseXRD
parseXRD :: Cursor -> [Service]
parseXRD c = c $/ element "{xri://$xrd*($v*2.0)}Service" >=> parseService
-- | Filter the attributes of an element by some predicate
findAttr' :: (QName -> Bool) -> Element -> Maybe String
findAttr' p el = attrVal `fmap` find (p . attrKey) (elAttribs el)
-- | Read, maybe
readMaybe :: Read a => String -> Maybe a
readMaybe str = case reads str of
[(x,"")] -> Just x
_ -> Nothing
-- | Get the text of an element
getText :: Element -> String
getText el = case elContent el of
[Text cd] -> cdData cd
_ -> []
-- Parsing ---------------------------------------------------------------------
parseXRDS :: String -> Maybe XRDS
parseXRDS str = do
doc <- parseXMLDoc str
let xrds = filterChildren (tag "XRD") doc
return $ map parseXRD xrds
parseXRD :: Element -> XRD
parseXRD el =
let svcs = filterChildren (tag "Service") el
in mapMaybe parseService svcs
parseService :: Element -> Maybe Service
parseService el = do
let vals t x = first (map getText) $ partition (tag t) x
(tys,tr) = vals "Type" (elChildren el)
(mts,mr) = vals "MediaType" tr
(uris,ur) = vals "URI" mr
(lids,rest) = vals "LocalID" ur
priority = readMaybe =<< findAttr' (("priority" ==) . qName) el
guard $ not $ null tys
return $ Service { serviceTypes = tys
, serviceMediaTypes = mts
, serviceURIs = uris
, serviceLocalIDs = lids
, servicePriority = priority
, serviceExtra = rest
}
parseService :: Cursor -> [Service]
parseService c =
if null types then [] else [Service
{ serviceTypes = types
, serviceMediaTypes = mtypes
, serviceURIs = uris
, serviceLocalIDs = localids
, servicePriority = listToMaybe (attribute "priority" c) >>= readMaybe
}]
where
types = c $/ element "{xri://$xrd*($v*2.0)}Type" &/ content
mtypes = c $/ element "{xri://$xrd*($v*2.0)}MediaType" &/ content
uris = c $/ element "{xri://$xrd*($v*2.0)}URI" &/ content
localids = c $/ element "{xri://$xrd*($v*2.0)}LocalID" &/ content
readMaybe t =
case Data.Text.Read.signed Data.Text.Read.decimal t of
Right (i, "") -> Just i
_ -> Nothing

36
Web/Authenticate/BrowserId.hs Normal file
View File

@ -0,0 +1,36 @@
{-# LANGUAGE OverloadedStrings #-}
module Web.Authenticate.BrowserId
( browserIdJs
, checkAssertion
) where
import Data.Text (Text)
import Network.HTTP.Enumerator (parseUrl, responseBody, httpLbs, withManager, method, urlEncodedBody)
import Network.HTTP.Types (queryTextToQuery)
import Data.Aeson (json, Value (Object, String))
import Data.Attoparsec.Lazy (parse, maybeResult)
import qualified Data.Map as Map
import Data.Text.Encoding (encodeUtf8)
-- | Location of the Javascript file hosted by browserid.org
browserIdJs :: Text
browserIdJs = "https://browserid.org/include.js"
checkAssertion :: Text -- ^ audience
-> Text -- ^ assertion
-> IO (Maybe Text)
checkAssertion audience assertion = do
req' <- parseUrl "https://browserid.org/verify"
let req = urlEncodedBody
[ ("audience", encodeUtf8 audience)
, ("assertion", encodeUtf8 assertion)
] req' { method = "POST" }
res <- withManager $ httpLbs req
let lbs = responseBody res
return $ maybeResult (parse json lbs) >>= getEmail
where
getEmail (Object o) =
case (Map.lookup "status" o, Map.lookup "email" o) of
(Just (String "okay"), Just (String e)) -> Just e
_ -> Nothing
getEmail _ = Nothing

29
Web/Authenticate/Internal.hs
View File

@ -1,11 +1,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
module Web.Authenticate.Internal
( qsEncode
, qsUrl
, AuthenticateException (..)
( AuthenticateException (..)
) where
import Codec.Binary.UTF8.String (encode)
import Numeric (showHex)
import Data.List (intercalate)
import Data.Typeable (Typeable)
@ -18,27 +15,3 @@ data AuthenticateException =
| AuthenticationException String
deriving (Show, Typeable)
instance Exception AuthenticateException
qsUrl :: String -> [(String, String)] -> String
qsUrl s [] = s
qsUrl url pairs =
url ++ delim : intercalate "&" (map qsPair pairs)
where
qsPair (x, y) = qsEncode x ++ '=' : qsEncode y
delim = if '?' `elem` url then '&' else '?'
qsEncode :: String -> String
qsEncode =
concatMap go . encode
where
go 32 = "+" -- space
go 46 = "."
go 45 = "-"
go 126 = "~"
go 95 = "_"
go c
| 48 <= c && c <= 57 = [w2c c]
| 65 <= c && c <= 90 = [w2c c]
| 97 <= c && c <= 122 = [w2c c]
go c = '%' : showHex c ""
w2c = toEnum . fromEnum

72
Web/Authenticate/Kerberos.hs Normal file
View File

@ -0,0 +1,72 @@
{-# LANGUAGE OverloadedStrings #-}
-- | Module for using a kerberos authentication service.
--
-- Please note that all configuration should have been done
-- manually on the machine prior to running the code.
--
-- On linux machines the configuration might be in /etc/krb5.conf.
-- It's worth checking if the Kerberos service provider (e.g. your university)
-- already provide a complete configuration file.
--
-- Be certain that you can manually login from a shell by typing
--
-- > kinit username
--
-- If you fill in your password and the program returns no error code,
-- then your kerberos configuration is setup properly.
-- Only then can this module be of any use.
module Web.Authenticate.Kerberos
( loginKerberos
, KerberosAuthResult(..)
) where
import Data.Text (Text)
import qualified Data.Text as T
import Data.Maybe (fromJust)
import Control.Monad (msum, guard)
import System.Process (readProcessWithExitCode)
import System.Timeout (timeout)
import System.Exit (ExitCode(..))
-- | Occurreable results of a Kerberos login
data KerberosAuthResult = Ok
| NoSuchUser
| WrongPassword
| TimeOut
| UnknownError Text
instance Show KerberosAuthResult where
show Ok = "Login sucessful"
show NoSuchUser = "Wrong username"
show WrongPassword = "Wrong password"
show TimeOut = "kinit respone timeout"
show (UnknownError msg) = "Unkown error: " ++ T.unpack msg
-- Given the errcode and stderr, return error-value
interpretError :: Int -> Text -> KerberosAuthResult
interpretError _ errmsg = fromJust . msum $
["Client not found in Kerberos database while getting" --> NoSuchUser,
"Preauthentication failed while getting" --> WrongPassword,
Just $ UnknownError errmsg]
where
substr --> kError = guard (substr `T.isInfixOf` errmsg) >> Just kError
-- | Given the username and password, try login to Kerberos service
loginKerberos :: Text -- ^ Username
-> Text -- ^ Password
-> IO KerberosAuthResult
loginKerberos username password = do
timedFetch <- timeout (10*1000000) fetch
case timedFetch of
Just res -> return res
Nothing -> return TimeOut
where
fetch :: IO KerberosAuthResult
fetch = do
(exitCode, _out, err) <- readProcessWithExitCode
"kinit" [T.unpack username] (T.unpack password)
case exitCode of
ExitSuccess -> return Ok
ExitFailure x -> return $ interpretError x (T.pack err)

4
Web/Authenticate/OAuth.hs
View File

@ -17,7 +17,6 @@ module Web.Authenticate.OAuth
paramEncode, addScope, addMaybeProxy
) where
import Network.HTTP.Enumerator
import Web.Authenticate.Internal (qsUrl)
import Data.Data
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as BSL
@ -41,6 +40,7 @@ import Data.Enumerator (($$), run_, Stream (..), continue)
import Data.Monoid (mconcat)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.IORef (newIORef, readIORef, atomicModifyIORef)
import Network.HTTP.Types (renderSimpleQuery)
-- | Data type for OAuth client (consumer).
data OAuth = OAuth { oauthServerName :: String -- ^ Service name
@ -128,7 +128,7 @@ getTemporaryCredential' hook oa = do
authorizeUrl :: OAuth -- ^ OAuth Application
-> Credential -- ^ Temporary Credential (Request Token & Secret)
-> String -- ^ URL to authorize
authorizeUrl oa cr = qsUrl (oauthAuthorizeUri oa) [("oauth_token", BS.unpack $ token cr)]
authorizeUrl oa cr = oauthAuthorizeUri oa ++ BS.unpack (renderSimpleQuery True [("oauth_token", token cr)])
-- | Get Access token.
getAccessToken, getTokenCredential

36
Web/Authenticate/OpenId.hs
View File

@ -12,19 +12,22 @@ import OpenId2.Normalization (normalize)
import OpenId2.Discovery (discover, Discovery (..))
import Control.Failure (Failure (failure))
import OpenId2.Types
import Web.Authenticate.Internal (qsUrl)
import Control.Monad (unless)
import qualified Data.ByteString.UTF8 as BSU
import qualified Data.ByteString.Lazy.UTF8 as BSLU
import Data.Text.Lazy.Encoding (decodeUtf8With)
import Data.Text.Encoding.Error (lenientDecode)
import Data.Text.Lazy (toStrict)
import Network.HTTP.Enumerator
( parseUrl, urlEncodedBody, responseBody, httpLbsRedirect
, HttpException, withManager
)
import Control.Arrow ((***))
import Control.Arrow ((***), second)
import Data.List (unfoldr)
import Data.Maybe (fromMaybe)
import Data.Text (Text, pack, unpack)
import Data.Text.Encoding (encodeUtf8)
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Blaze.ByteString.Builder (toByteString)
import Network.HTTP.Types (renderQueryText)
import Data.Monoid (mappend)
getForwardUrl
:: ( MonadIO m
@ -39,12 +42,11 @@ getForwardUrl
getForwardUrl openid' complete mrealm params = do
let realm = fromMaybe complete mrealm
disc <- normalize openid' >>= discover
let helper s q = return $ s `mappend` decodeUtf8 (toByteString $ renderQueryText True $ map (second Just) q)
case disc of
Discovery1 server mdelegate ->
return $ pack $ qsUrl server
$ map (unpack *** unpack) -- FIXME
Discovery1 server mdelegate -> helper server
$ ("openid.mode", "checkid_setup")
: ("openid.identity", maybe openid' pack mdelegate)
: ("openid.identity", maybe openid' id mdelegate)
: ("openid.return_to", complete)
: ("openid.realm", realm)
: ("openid.trust_root", complete)
@ -54,14 +56,14 @@ getForwardUrl openid' complete mrealm params = do
case itype of
ClaimedIdent -> i
OPIdent -> "http://specs.openid.net/auth/2.0/identifier_select"
return $ pack $ qsUrl p
helper p
$ ("openid.ns", "http://specs.openid.net/auth/2.0")
: ("openid.mode", "checkid_setup")
: ("openid.claimed_id", unpack i')
: ("openid.identity", unpack i')
: ("openid.return_to", unpack complete)
: ("openid.realm", unpack realm)
: map (unpack *** unpack) params
: ("openid.claimed_id", i')
: ("openid.identity", i')
: ("openid.return_to", complete)
: ("openid.realm", realm)
: params
authenticate
:: ( MonadIO m
@ -91,10 +93,10 @@ authenticate params = do
let params' = map (encodeUtf8 *** encodeUtf8)
$ ("openid.mode", "check_authentication")
: filter (\(k, _) -> k /= "openid.mode") params
req' <- parseUrl endpoint
req' <- parseUrl $ unpack endpoint
let req = urlEncodedBody params' req'
rsp <- liftIO $ withManager $ httpLbsRedirect req
let rps = parseDirectResponse $ pack $ BSLU.toString $ responseBody rsp -- FIXME
let rps = parseDirectResponse $ toStrict $ decodeUtf8With lenientDecode $ responseBody rsp
case lookup "is_valid" rps of
Just "true" -> return (Identifier ident, rps)
_ -> failure $ AuthenticationException "OpenID provider did not validate"

20
authenticate.cabal
View File

@ -1,8 +1,8 @@
name: authenticate
version: 0.9.1.6
version: 0.10.0
license: BSD3
license-file: LICENSE
author: Michael Snoyman, Hiromi Ishii
author: Michael Snoyman, Hiromi Ishii, Arash Rouhani
maintainer: Michael Snoyman <michael@snoyman.com>
synopsis: Authentication methods for Haskell web applications.
description: Focus is on third-party authentication methods, such as OpenID,
@ -15,33 +15,35 @@ homepage: http://github.com/snoyberg/authenticate/tree/master
library
build-depends: base >= 4 && < 5,
aeson >= 0.3.1.1 && < 0.4,
aeson-native >= 0.3.2.11 && < 0.4,
http-enumerator >= 0.6.5.4 && < 0.7,
tagsoup >= 0.6 && < 0.13,
tagsoup >= 0.12 && < 0.13,
failure >= 0.0.0 && < 0.2,
transformers >= 0.1 && < 0.3,
bytestring >= 0.9 && < 0.10,
utf8-string >= 0.3 && < 0.4,
network >= 2.2.1 && < 2.4,
xml >= 1.3.7 && < 1.4,
case-insensitive >= 0.2 && < 0.3,
case-insensitive >= 0.2 && < 0.4,
RSA >= 1.0 && < 1.1,
time >= 1.1 && < 1.3,
time >= 1.1 && < 1.4,
base64-bytestring >= 0.1 && < 0.2,
SHA >= 1.4 && < 1.6,
random >= 1.0 && < 1.1,
text >= 0.5 && < 1.0,
http-types >= 0.6 && < 0.7,
enumerator >= 0.4.7 && < 0.5,
xml-enumerator >= 0.3.4 && < 0.4,
blaze-builder >= 0.2 && < 0.4,
attoparsec >= 0.9 && < 0.10,
tls >= 0.7 && < 0.8,
containers
containers,
process >= 1.0.1.1 && < 1.2
exposed-modules: Web.Authenticate.Rpxnow,
Web.Authenticate.OpenId,
Web.Authenticate.BrowserId,
Web.Authenticate.OpenId.Providers,
Web.Authenticate.OAuth,
Web.Authenticate.Facebook
Web.Authenticate.Kerberos
other-modules: Web.Authenticate.Internal,
OpenId2.Discovery,
OpenId2.Normalization,

46
browserid.hs Normal file
View File

@ -0,0 +1,46 @@
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
import Yesod
import Web.Authenticate.BrowserId
import Data.Object
import Data.Maybe (fromMaybe)
import Network.HTTP.Enumerator
import Data.Text (Text)
data BID = BID
mkYesod "BID" [parseRoutes|
/ RootR GET
/complete/#Text CompleteR GET
|]
instance Yesod BID where approot _ = "http://localhost:3000"
getRootR = defaultLayout $ do
addScriptRemote browserIdJs
addJulius [julius|
function bidClick() {
navigator.id.getVerifiedEmail(function(assertion) {
if (assertion) {
document.location = "@{CompleteR ""}" + assertion;
} else {
alert("Invalid BrowserId login");
}
});
}
|]
addHamlet [hamlet|
<p>
<a href="javascript:bidClick();">
<img src="https://browserid.org/i/sign_in_red.png">
|]
getCompleteR assertion = do
memail <- liftIO $ checkAssertion "localhost:3000" assertion
defaultLayout $ addHamlet [hamlet|
<p>You tried to log in, let's see if it worked.
$maybe email <- memail
<p>Yes it did! You are: #{email}
$nothing
<p>Nope, sorry
|]
main = warp 3000 BID

26
openid2.hs
View File

@ -1,36 +1,36 @@
{-# LANGUAGE TypeFamilies, QuasiQuotes #-}
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
import Yesod
import Web.Authenticate.OpenId2
import Web.Authenticate.OpenId
import Data.Object
import Data.Maybe (fromMaybe)
import Network.HTTP.Enumerator
data OID = OID
mkYesod "OID" [$parseRoutes|
mkYesod "OID" [parseRoutes|
/ RootR GET
/forward ForwardR GET
/complete CompleteR GET
|]
instance Yesod OID where approot _ = "http://localhost:3000"
instance Yesod OID where approot _ = "http://10.0.0.3:3000"
getRootR = defaultLayout [$hamlet|
%form!action=@ForwardR@
OpenId:
%input!type=text!name=openid_identifier!value="http://"
%input!type=submit
getRootR = defaultLayout [hamlet|\
<form action="@{ForwardR}">
\OpenId:
<input type="text" name="openid_identifier" value="http://">
<input type="submit">
|]
getForwardR = do
openid <- runFormGet' $ stringInput "openid_identifier"
render <- getUrlRender
url <- liftIO $ getForwardUrl openid $ render CompleteR
redirectString RedirectTemporary url
url <- liftIO $ getForwardUrl openid (render CompleteR) Nothing []
redirectText RedirectTemporary url
return ()
getCompleteR = do
params <- reqGetParams `fmap` getRequest
ident <- liftIO $ authenticate params
return $ RepPlain $ toContent ident
return $ RepPlain $ toContent $ show ident
main = withHttpEnumerator $ basicHandler 3000 OID
main = warp 3000 OID