module Web.Authenticate.OpenId
( Identifier (..)
, getForwardUrl
, authenticate
, AuthenticateException (..)
) where
import Network.HTTP.Enumerator
import Text.HTML.TagSoup
import "transformers" Control.Monad.IO.Class
import Data.Data
import Control.Failure hiding (Error)
import Control.Exception
import Control.Monad (liftM, unless)
import qualified Data.ByteString.Lazy.Char8 as L8
import Web.Authenticate.Internal (qsEncode)
import Data.List (intercalate)
newtype Identifier = Identifier { identifier :: String }
deriving (Eq, Show)
data Error v = Error String | Ok v
instance Monad Error where
return = Ok
Error s >>= _ = Error s
Ok v >>= f = f v
fail s = Error s
getForwardUrl :: (MonadIO m,
Failure InvalidUrlException m,
Failure HttpException m,
Failure MissingVar m
)
=> String
-> String
-> m String
getForwardUrl openid complete = do
bodyIdent' <- simpleHttp openid
let bodyIdent = L8.unpack bodyIdent'
server <- getOpenIdVar "server" bodyIdent
let delegate = maybe openid id
$ getOpenIdVar "delegate" bodyIdent
return $ constructUrl server
[ ("openid.mode", "checkid_setup")
, ("openid.identity", delegate)
, ("openid.return_to", complete)
]
data MissingVar = MissingVar String
deriving (Typeable, Show)
instance Exception MissingVar
getOpenIdVar :: Failure MissingVar m => String -> String -> m String
getOpenIdVar var content = do
let tags = parseTags content
let secs = sections (~== ("<link rel=openid." ++ var ++ ">")) tags
secs' <- mhead secs
secs'' <- mhead secs'
return $ fromAttrib "href" secs''
where
mhead [] = failure $ MissingVar $ "openid." ++ var
mhead (x:_) = return x
constructUrl :: String -> [(String, String)] -> String
constructUrl url [] = url
constructUrl url args =
url ++ "?" ++ intercalate "&" (map qsPair args)
where
qsPair (x, y) = qsEncode x ++ '=' : qsEncode y
authenticate :: (MonadIO m,
Failure AuthenticateException m,
Failure InvalidUrlException m,
Failure HttpException m,
Failure MissingVar m)
=> [(String, String)]
-> m Identifier
authenticate req = do
unless (lookup "openid.mode" req == Just "id_res") $
failure $ AuthenticateException "authenticate without openid.mode=id_res"
authUrl <- getAuthUrl req
content <- L8.unpack `liftM` simpleHttp authUrl
if contains "is_valid:true" content
then Identifier `liftM` alookup "openid.identity" req
else failure $ AuthenticateException content
alookup :: (Failure AuthenticateException m, Monad m)
=> String
-> [(String, String)]
-> m String
alookup k x = case lookup k x of
Just k' -> return k'
Nothing -> failure $ MissingOpenIdParameter k
data AuthenticateException = AuthenticateException String
| MissingOpenIdParameter String
deriving (Show, Typeable)
instance Exception AuthenticateException
getAuthUrl :: (MonadIO m, Failure AuthenticateException m,
Failure InvalidUrlException m,
Failure HttpException m,
Failure MissingVar m)
=> [(String, String)] -> m String
getAuthUrl req = do
identity <- alookup "openid.identity" req
idContent <- simpleHttp identity
helper $ L8.unpack idContent
where
helper idContent = do
server <- getOpenIdVar "server" idContent
dargs <- mapM makeArg [
"assoc_handle",
"sig",
"signed",
"identity",
"return_to"
]
let sargs = [("openid.mode", "check_authentication")]
return $ constructUrl server $ dargs ++ sargs
makeArg s = do
let k = "openid." ++ s
v <- alookup k req
return (k, v)
contains :: String -> String -> Bool
contains [] _ = True
contains _ [] = False
contains needle haystack =
begins needle haystack ||
(contains needle $ tail haystack)
begins :: String -> String -> Bool
begins [] _ = True
begins _ [] = False
begins (x:xs) (y:ys) = x == y && begins xs ys