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

Better test program for OpenID

Browse Source
This commit is contained in:
Michael Snoyman 2012-04-20 09:41:08 +03:00
parent 182d193cbb
commit cda399131b
1 changed files with 64 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
authenticate/openid2.hs
View File

@ -1,9 +1,11 @@
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-} {-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
import Yesod import Yesod.Core
import Web.Authenticate.OpenId import Web.Authenticate.OpenId
import Data.Object import qualified Web.Authenticate.OpenId.Providers as P
import Data.Maybe (fromMaybe) import Network.HTTP.Conduit
import Network.HTTP.Enumerator import Yesod.Form
import Network.Wai.Handler.Warp (run)
import Text.Lucius (lucius)
data OID = OID data OID = OID
mkYesod "OID" [parseRoutes| mkYesod "OID" [parseRoutes|
@ -12,25 +14,71 @@ mkYesod "OID" [parseRoutes|
/complete CompleteR GET /complete CompleteR GET
|] |]
instance Yesod OID where approot _ = "http://10.0.0.3:3000" instance Yesod OID where
approot = ApprootStatic "http://localhost:3000"
getRootR = defaultLayout [hamlet|\ getRootR :: Handler RepHtml
getRootR = defaultLayout [whamlet|
<form action="@{ForwardR}"> <form action="@{ForwardR}">
\OpenId: OpenId: #
<input type="text" name="openid_identifier" value="http://"> <input type="text" name="openid_identifier" value="http://">
<input type="submit"> <input type="submit">
<form action="@{ForwardR}">
<input type="hidden" name="openid_identifier" value=#{P.google}>
<input type="submit" value=Google>
|] |]
getForwardR = do instance RenderMessage OID FormMessage where
openid <- runFormGet' $ stringInput "openid_identifier" renderMessage _ _ = defaultFormMessage
render <- getUrlRender
url <- liftIO $ getForwardUrl openid (render CompleteR) Nothing []
redirectText RedirectTemporary url
return ()
getForwardR :: Handler ()
getForwardR = do
openid <- runInputGet $ ireq textField "openid_identifier"
render <- getUrlRender
url <- withManager $ getForwardUrl openid (render CompleteR) Nothing []
redirect url
getCompleteR :: Handler RepHtml
getCompleteR = do getCompleteR = do
params <- reqGetParams `fmap` getRequest params <- reqGetParams `fmap` getRequest
ident <- liftIO $ authenticate params (ident, retparams) <- withManager $ authenticate params
return $ RepPlain $ toContent $ show ident defaultLayout $ do
toWidget [lucius|
table {
border-collapse: collapse;
}
th, td {
border: 1px solid #666;
padding: 5px;
vertical-align: top;
}
th {
text-align: right;
}
|]
[whamlet|
<p>Successfully logged in.
<table>
<tr>
<th>Ident
<td>#{show ident}
<tr>
<th>Params
<td>
<table>
$forall (k, v) <- retparams
<tr>
<th>#{k}
<td>#{v}
<tr>
<th>GET params
<td>
<table>
$forall (k, v) <- params
<tr>
<th>#{k}
<td>#{v}
|]
main = warp 3000 OID main :: IO ()
main = toWaiApp OID >>= run 3000