92 lines
2.2 KiB
Haskell
92 lines
2.2 KiB
Haskell
{-# LANGUAGE TypeFamilies, QuasiQuotes, TemplateHaskell, MultiParamTypeClasses, OverloadedStrings #-}
|
|
import Yesod.Core
|
|
import Web.Authenticate.OpenId
|
|
import qualified Web.Authenticate.OpenId.Providers as P
|
|
import Network.HTTP.Conduit
|
|
import Yesod.Form
|
|
import Network.Wai.Handler.Warp (run)
|
|
import Text.Lucius (lucius)
|
|
|
|
data OID = OID
|
|
mkYesod "OID" [parseRoutes|
|
|
/ RootR GET
|
|
/forward ForwardR GET
|
|
/complete CompleteR GET
|
|
|]
|
|
|
|
instance Yesod OID where
|
|
approot = ApprootStatic "http://localhost:3000"
|
|
|
|
getRootR :: Handler RepHtml
|
|
getRootR = defaultLayout [whamlet|
|
|
<form action="@{ForwardR}">
|
|
OpenId: #
|
|
<input type="text" name="openid_identifier" value="http://">
|
|
<input type="submit">
|
|
<form action="@{ForwardR}">
|
|
<input type="hidden" name="openid_identifier" value=#{P.google}>
|
|
<input type="submit" value=Google>
|
|
|]
|
|
|
|
instance RenderMessage OID FormMessage where
|
|
renderMessage _ _ = defaultFormMessage
|
|
|
|
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
|
|
params <- reqGetParams `fmap` getRequest
|
|
oir <- withManager $ authenticateClaimed params
|
|
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>OP Local
|
|
<td>#{identifier $ oirOpLocal oir}
|
|
<tr>
|
|
<th>Claimed
|
|
<td>
|
|
$maybe c <- oirClaimed oir
|
|
\#{identifier c}
|
|
$nothing
|
|
<i>none
|
|
<tr>
|
|
<th>Params
|
|
<td>
|
|
<table>
|
|
$forall (k, v) <- oirParams oir
|
|
<tr>
|
|
<th>#{k}
|
|
<td>#{v}
|
|
<tr>
|
|
<th>GET params
|
|
<td>
|
|
<table>
|
|
$forall (k, v) <- params
|
|
<tr>
|
|
<th>#{k}
|
|
<td>#{v}
|
|
|]
|
|
|
|
main :: IO ()
|
|
main = toWaiApp OID >>= run 3000
|