module Web.Authenticate.OpenId
( Identifier (..)
, getForwardUrl
, authenticate
) where
import Data.Maybe (fromMaybe, fromJust)
import Network.HTTP.Wget
import Text.HTML.TagSoup
import Numeric (showHex)
data Identifier = Identifier { identifier :: String }
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 :: Monad m
=> String
-> String
-> IO (m String)
getForwardUrl openid complete = do
bodyIdent' <- wget openid [] []
case bodyIdent' of
Error s -> return $ fail s
Ok bodyIdent -> do
server <- getOpenIdVar "server" bodyIdent
let delegate = fromMaybe openid $ getOpenIdVar "delegate" bodyIdent
return $ return $ constructUrl server
[ ("openid.mode", "checkid_setup")
, ("openid.identity", delegate)
, ("openid.return_to", complete)
]
getOpenIdVar :: Monad 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 [] = fail $ "Variable not found: openid." ++ var
mhead (x:_) = return x
constructUrl :: String -> [(String, String)] -> String
constructUrl url [] = url
constructUrl url args = url ++ "?" ++ queryString args
where
queryString [] = error "queryString with empty args cannot happen"
queryString [first] = onePair first
queryString (first:rest) = onePair first ++ "&" ++ queryString rest
onePair (x, y) = urlEncode x ++ "=" ++ urlEncode y
authenticate :: Monad m => [(String, String)] -> IO (m Identifier)
authenticate req = do
authUrl' <- getAuthUrl req
case authUrl' of
Nothing -> return $ fail "Invalid parameters"
Just authUrl -> do
content' <- wget authUrl [] []
case content' of
Error s -> return $ fail s
Ok content -> do
let isValid = contains "is_valid:true" content
if isValid
then return $
return $ Identifier
(fromJust $ lookup "openid.identity" req)
else return $ fail content
getAuthUrl :: [(String, String)] -> IO (Maybe String)
getAuthUrl req = do
let identity' = lookup "openid.identity" req
case identity' of
Nothing -> return Nothing
Just identity -> do
idContent <- wget identity [] []
case idContent of
Nothing -> return Nothing
Just x -> return $ helper x
where
helper :: String -> Maybe String
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 :: String -> Maybe (String, String)
makeArg s = do
let k = "openid." ++ s
v <- lookup 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
urlEncode :: String -> String
urlEncode = concatMap urlEncodeChar
urlEncodeChar :: Char -> String
urlEncodeChar x
| safeChar (fromEnum x) = return x
| otherwise = '%' : showHex (fromEnum x) ""
safeChar :: Int -> Bool
safeChar x
| x >= fromEnum 'a' && x <= fromEnum 'z' = True
| x >= fromEnum 'A' && x <= fromEnum 'Z' = True
| x >= fromEnum '0' && x <= fromEnum '9' = True
| otherwise = False