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

OpenId2/Discovery.hs

@@ -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)
+                . mapMaybe linkTag
-                . linkTags
+                . parseTags
-                . htmlTags
   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 :: [Tag Text] -> [(Text, Text)]
-linkTags  = mapMaybe f . filter p
+linkTag (TagOpen "link" as) = let x = (,) <$> lookup "rel" as <*> lookup "href" as in traceShow x x
-  where
+linkTag x = Nothing
-    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

OpenId2/Types.hs

@@ -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 }

OpenId2/XRDS.hs

@@ -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 Control.Monad
+import Data.Maybe (listToMaybe)
-import Data.List
+import Text.XML.Enumerator.Resolved (parseLBS, decodeEntities)
-import Data.Maybe
+import Text.XML.Enumerator.Cursor (fromDocument, element, content, ($/), (&|), Cursor, (&/), attribute, node)
-import Text.XML.Light
+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]
+  { serviceTypes      :: [Text]
-  , serviceMediaTypes :: [String]
+  , serviceMediaTypes :: [Text]
-  , serviceURIs       :: [String]
+  , serviceURIs       :: [Text]
-  , serviceLocalIDs   :: [String]
+  , 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.
+parseXRDS' :: Cursor -> [[Service]]
-tag :: String -> Element -> Bool
+parseXRDS' = element "{xri://$xrds}XRDS" &/
-tag n el = qName (elName el) == n
+             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
+parseService :: Cursor -> [Service]
-findAttr' :: (QName -> Bool) -> Element -> Maybe String
+parseService c =
-findAttr' p el = attrVal `fmap` find (p . attrKey) (elAttribs el)
+    if null types then [] else [Service
-
+        { serviceTypes = types
-
+        , serviceMediaTypes = mtypes
--- | Read, maybe
+        , serviceURIs = uris
-readMaybe :: Read a => String -> Maybe a
+        , serviceLocalIDs = localids
-readMaybe str = case reads str of
+        , servicePriority = listToMaybe (attribute "priority" c) >>= readMaybe
-  [(x,"")] -> Just x
+        }]
-  _        -> Nothing
+  where
-
+    types = c $/ element "{xri://$xrd*($v*2.0)}Type" &/ content
-
+    mtypes = c $/ element "{xri://$xrd*($v*2.0)}MediaType" &/ content
--- | Get the text of an element
+    uris = c $/ element "{xri://$xrd*($v*2.0)}URI" &/ content
-getText :: Element -> String
+    localids = c $/ element "{xri://$xrd*($v*2.0)}LocalID" &/ content
-getText el = case elContent el of
+    readMaybe t =
-  [Text cd] -> cdData cd
+        case Data.Text.Read.signed Data.Text.Read.decimal t of
-  _         -> []
+            Right (i, "") -> Just i
-
+            _ -> Nothing
--- 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
-                   }

Web/Authenticate/BrowserId.hs

@@ -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

Web/Authenticate/Internal.hs

@@ -1,11 +1,8 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 module Web.Authenticate.Internal
-    ( qsEncode
+    ( AuthenticateException (..)
-    , qsUrl
-    , 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

Web/Authenticate/Kerberos.hs

@@ -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)
+

Web/Authenticate/OAuth.hs

@@ -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

Web/Authenticate/OpenId.hs

@@ -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 Data.Text.Lazy.Encoding (decodeUtf8With)
-import qualified Data.ByteString.Lazy.UTF8 as BSLU
+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 ->
+        Discovery1 server mdelegate -> helper server
-            return $ pack $ qsUrl server
-                $ map (unpack *** unpack) -- FIXME
                 $ ("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.claimed_id", i')
-                : ("openid.identity", unpack i')
+                : ("openid.identity", i')
-                : ("openid.return_to", unpack complete)
+                : ("openid.return_to", complete)
-                : ("openid.realm", unpack realm)
+                : ("openid.realm", realm)
-                : map (unpack *** unpack) params
+                : 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"

authenticate.cabal

@@ -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.4,
-                     case-insensitive >= 0.2 && < 0.3,
                      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,

browserid.hs

@@ -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

openid2.hs

@@ -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|
+getRootR = defaultLayout [hamlet|\
-%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">
 |]
 
 getForwardR = do
     openid <- runFormGet' $ stringInput "openid_identifier"
     render <- getUrlRender
-    url <- liftIO $ getForwardUrl openid $ render CompleteR
+    url <- liftIO $ getForwardUrl openid (render CompleteR) Nothing []
-    redirectString RedirectTemporary url
+    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