browserid

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
{-# LANGUAGE ViewPatterns #-}

-- | BrowserID login.

module App.BrowserID  where

import App.Session
import App.Types

import Control.Monad
import Control.Monad.Trans
import Graphics.UI.Ji
import Graphics.UI.Ji.DOM
import Graphics.UI.Ji.Elements
import Network.Curl
import Text.JSON

-- | Make login button.
makeLoginButton :: App Element
makeLoginButton = do
  a <- newAnchor #. "browserid-login-button" # set "href" "#"
  onClick a $ \_ -> do
    browserIdLogin $ \token -> do
      debug "Got token, checking…"
      (ok,email) <- verifyToken token
      when ok $ do
        setSession email
        debug $ "OK, " ++ email ++ "!"
  return a

-- | Trigger the BrowserID login.
browserIdLogin :: MonadJi m => (String -> m a) -> m ()
browserIdLogin cont = do
  callDeferredFunction "navigator.id.get" [] $ \token ->
    case token of
      [Just t] -> cont t >> return ()
      _        -> return ()

-- | Download a POST request.
verifyToken :: (MonadIO m,MonadConfig m) => String -> m (Bool,String)
verifyToken token = do
  domain <- liftM configDomain askConfig
  liftIO $ withCurlDo $ do
    (code,ret) <-
      curlGetString "https://browserid.org/verify"
                    [CurlPostFields ["assertion=" ++ token
                                    ,"audience=" ++ domain]]
    case code of
      CurlOK ->
        case decode ret >>= parseReply of
          Ok (status,email) -> return (status == "okay",email)
          Error err         -> error (show err)
      other  -> error (show other)

-- | Parse the browserid JSON reply.
parseReply :: JSObject JSValue -> Result (String,String)
parseReply o = do
  status <- valFromObj "status" o
  email <- valFromObj "email" o
  return (status,email)
1:1: Error: Unused LANGUAGE pragma
Found:
{-# LANGUAGE ViewPatterns #-}
Why not remove it.
22:21: Error: Redundant do
Found:
do browserIdLogin $
\ token ->
do debug "Got token, checking\8230"
(ok, email) <- verifyToken token
when ok $
do setSession email
debug $ "OK, " ++ email ++ "!"
Why not:
browserIdLogin $
\ token ->
do debug "Got token, checking\8230"
(ok, email) <- verifyToken token
when ok $
do setSession email
debug $ "OK, " ++ email ++ "!"
33:23: Error: Redundant do
Found:
do callDeferredFunction "navigator.id.get" [] $
\ token ->
case token of
[Just t] -> cont t >> return ()
_ -> return ()
Why not:
callDeferredFunction "navigator.id.get" [] $
\ token ->
case token of
[Just t] -> cont t >> return ()
_ -> return ()
36:19: Warning: Use void
Found:
cont t >> return ()
Why not:
void (cont t)