Add 'yesod-auth/' from commit 'fe498e3dac01bfc999cad33b90a2b1b397785178'

git-subtree-dir: yesod-auth
git-subtree-mainline: a7df753
git-subtree-split: fe498e3

yesod-auth/.gitignore

@@ -0,0 +1,4 @@
+dist
+*.swp
+auth2.db3
+client_session_key.aes

yesod-auth/LICENSE

@@ -0,0 +1,25 @@
+The following license covers this documentation, and the source code, except
+where otherwise indicated.
+
+Copyright 2010, Michael Snoyman. All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+* Redistributions of source code must retain the above copyright notice, this
+  list of conditions and the following disclaimer.
+
+* Redistributions in binary form must reproduce the above copyright notice,
+  this list of conditions and the following disclaimer in the documentation
+  and/or other materials provided with the distribution.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR
+IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
+MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO
+EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT,
+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
+NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA,
+OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
+LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
+OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
+ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

yesod-auth/Setup.lhs

@@ -0,0 +1,8 @@
+#!/usr/bin/env runhaskell
+
+> module Main where
+> import Distribution.Simple
+> import System.Cmd (system)
+
+> main :: IO ()
+> main = defaultMain

yesod-auth/Yesod/Auth.hs

@@ -0,0 +1,211 @@
+{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+module Yesod.Auth
+    ( -- * Subsite
+      Auth
+    , AuthPlugin (..)
+    , AuthRoute (..)
+    , getAuth
+    , YesodAuth (..)
+      -- * Plugin interface
+    , Creds (..)
+    , setCreds
+      -- * User functions
+    , maybeAuthId
+    , maybeAuth
+    , requireAuthId
+    , requireAuth
+    ) where
+
+#include "qq.h"
+
+import Control.Monad                 (when)  
+import Control.Monad.Trans.Class     (lift)
+import Control.Monad.Trans.Maybe
+
+import Data.Aeson
+import Data.Text.Encoding (decodeUtf8With)
+import Data.Text.Encoding.Error (lenientDecode)
+import           Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Map as Map
+
+import Language.Haskell.TH.Syntax hiding (lift)
+
+import qualified Network.Wai as W
+import Text.Hamlet (html)
+
+import Yesod.Core
+import Yesod.Persist
+import Yesod.Json
+import Yesod.Auth.Message (AuthMessage, defaultMessage)
+import qualified Yesod.Auth.Message as Msg
+import Yesod.Form (FormMessage)
+
+data Auth = Auth
+
+type Method = Text
+type Piece = Text
+
+data AuthPlugin m = AuthPlugin
+    { apName :: Text
+    , apDispatch :: Method -> [Piece] -> GHandler Auth m ()
+    , apLogin :: forall s. (Route Auth -> Route m) -> GWidget s m ()
+    }
+
+getAuth :: a -> Auth
+getAuth = const Auth
+
+-- | User credentials
+data Creds m = Creds
+    { credsPlugin :: Text -- ^ How the user was authenticated
+    , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin.
+    , credsExtra :: [(Text, Text)]
+    }
+
+class (Yesod m, SinglePiece (AuthId m), RenderMessage m FormMessage) => YesodAuth m where
+    type AuthId m
+
+    -- | Default destination on successful login, if no other
+    -- destination exists.
+    loginDest :: m -> Route m
+
+    -- | Default destination on successful logout, if no other
+    -- destination exists.
+    logoutDest :: m -> Route m
+
+    getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m))
+
+    authPlugins :: [AuthPlugin m]
+
+    -- | What to show on the login page.
+    loginHandler :: GHandler Auth m RepHtml
+    loginHandler = defaultLayout $ do
+        setTitleI Msg.LoginTitle
+        tm <- lift getRouteToMaster
+        mapM_ (flip apLogin tm) authPlugins
+
+    renderAuthMessage :: m
+                      -> [Text] -- ^ languages
+                      -> AuthMessage -> Text
+    renderAuthMessage _ _ = defaultMessage
+
+mkYesodSub "Auth"
+    [ ClassP ''YesodAuth [VarT $ mkName "master"]
+    ]
+#define STRINGS *Texts
+    [QQ(parseRoutes)|
+/check                 CheckR      GET
+/login                 LoginR      GET
+/logout                LogoutR     GET POST
+/page/#Text/STRINGS PluginR
+|]
+
+credsKey :: Text
+credsKey = "_ID"
+
+-- | FIXME: won't show up till redirect
+setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m ()
+setCreds doRedirects creds = do
+    y    <- getYesod
+    maid <- getAuthId creds
+    case maid of
+        Nothing ->
+          when doRedirects $ do
+            case authRoute y of
+              Nothing -> do rh <- defaultLayout $ addHtml [QQ(html)| <h1>Invalid login |]
+                            sendResponse rh
+              Just ar -> do setMessageI Msg.InvalidLogin
+                            redirect RedirectTemporary ar
+        Just aid -> do
+            setSession credsKey $ toSinglePiece aid
+            when doRedirects $ do
+              setMessageI Msg.NowLoggedIn
+              redirectUltDest RedirectTemporary $ loginDest y
+
+getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson
+getCheckR = do
+    creds <- maybeAuthId
+    defaultLayoutJson (do
+        setTitle "Authentication Status"
+        addHtml $ html' creds) (json' creds)
+  where
+    html' creds =
+        [QQ(html)|
+<h1>Authentication Status
+$maybe _ <- creds
+    <p>Logged in.
+$nothing
+    <p>Not logged in.
+|]
+    json' creds =
+        Object $ Map.fromList
+            [ (T.pack "logged_in", Bool $ maybe False (const True) creds)
+            ]
+
+getLoginR :: YesodAuth m => GHandler Auth m RepHtml
+getLoginR = setUltDestReferer >> loginHandler
+
+getLogoutR :: YesodAuth m => GHandler Auth m ()
+getLogoutR = setUltDestReferer >> postLogoutR -- FIXME redirect to post
+
+postLogoutR :: YesodAuth m => GHandler Auth m ()
+postLogoutR = do
+    y <- getYesod
+    deleteSession credsKey
+    redirectUltDest RedirectTemporary $ logoutDest y
+
+handlePluginR :: YesodAuth m => Text -> [Text] -> GHandler Auth m ()
+handlePluginR plugin pieces = do
+    env <- waiRequest
+    let method = decodeUtf8With lenientDecode $ W.requestMethod env
+    case filter (\x -> apName x == plugin) authPlugins of
+        [] -> notFound
+        ap:_ -> apDispatch ap method pieces
+
+-- | Retrieves user credentials, if user is authenticated.
+maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m))
+maybeAuthId = do
+    ms <- lookupSession credsKey
+    case ms of
+        Nothing -> return Nothing
+        Just s -> return $ fromSinglePiece s
+
+maybeAuth :: ( YesodAuth m
+             , Key val ~ AuthId m
+             , PersistBackend (YesodDB m (GGHandler s m IO))
+             , PersistEntity val
+             , YesodPersist m
+             ) => GHandler s m (Maybe (Key val, val))
+maybeAuth = runMaybeT $ do
+    aid <- MaybeT $ maybeAuthId
+    a   <- MaybeT $ runDB $ get aid
+    return (aid, a)
+
+requireAuthId :: YesodAuth m => GHandler s m (AuthId m)
+requireAuthId = maybeAuthId >>= maybe redirectLogin return
+
+requireAuth :: ( YesodAuth m
+               , Key val ~ AuthId m
+               , PersistBackend (YesodDB m (GGHandler s m IO))
+               , PersistEntity val
+               , YesodPersist m
+               ) => GHandler s m (Key val, val)
+requireAuth = maybeAuth >>= maybe redirectLogin return
+
+redirectLogin :: Yesod m => GHandler s m a
+redirectLogin = do
+    y <- getYesod
+    setUltDest'
+    case authRoute y of
+        Just z -> redirect RedirectTemporary z
+        Nothing -> permissionDenied "Please configure authRoute"
+
+instance YesodAuth m => RenderMessage m AuthMessage where
+    renderMessage = renderAuthMessage

yesod-auth/Yesod/Auth/BrowserId.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Yesod.Auth.BrowserId
+    ( authBrowserId
+    ) where
+
+import Yesod.Auth
+import Web.Authenticate.BrowserId
+import Data.Text (Text)
+import Yesod.Core
+import Text.Hamlet (hamlet)
+import Control.Monad.IO.Class (liftIO)
+
+#include "qq.h"
+
+pid :: Text
+pid = "browserid"
+
+complete :: AuthRoute
+complete = PluginR pid []
+
+authBrowserId :: YesodAuth m
+              => Text -- ^ audience
+              -> AuthPlugin m
+authBrowserId audience = AuthPlugin
+    { apName = pid
+    , apDispatch = \m ps ->
+        case (m, ps) of
+            ("GET", [assertion]) -> do
+                memail <- liftIO $ checkAssertion audience assertion
+                case memail of
+                    Nothing -> error "Invalid assertion"
+                    Just email -> setCreds True Creds
+                        { credsPlugin = pid
+                        , credsIdent = email
+                        , credsExtra = []
+                        }
+            (_, []) -> badMethod
+            _ -> notFound
+    , apLogin = \toMaster -> do
+        addScriptRemote browserIdJs
+        addHamlet [QQ(hamlet)|
+<p>
+    <a href="javascript:navigator.id.getVerifiedEmail(function(a){if(a)document.location='@{toMaster complete}/'+a});">
+        <img src="https://browserid.org/i/sign_in_green.png">
+|]
+    }

yesod-auth/Yesod/Auth/Dummy.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+-- | Provides a dummy authentication module that simply lets a user specify
+-- his/her identifier. This is not intended for real world use, just for
+-- testing.
+module Yesod.Auth.Dummy
+    ( authDummy
+    ) where
+
+#include "qq.h"
+
+import Yesod.Auth
+import Yesod.Form (runInputPost, textField, ireq)
+import Yesod.Handler (notFound)
+import Text.Hamlet (hamlet)
+import Yesod.Widget (addHamlet)
+
+authDummy :: YesodAuth m => AuthPlugin m
+authDummy =
+    AuthPlugin "dummy" dispatch login
+  where
+    dispatch "POST" [] = do
+        ident <- runInputPost $ ireq textField "ident"
+        setCreds True $ Creds "dummy" ident []
+    dispatch _ _ = notFound
+    url = PluginR "dummy" []
+    login authToMaster =
+        addHamlet [QQ(hamlet)|
+<form method="post" action="@{authToMaster url}">
+    \Your new identifier is: 
+    <input type="text" name="ident">
+    <input type="submit" value="Dummy Login">
+|]