{-# LANGUAGE FlexibleInstances, RankNTypes, TypeFamilies, OverloadedStrings #-} -- | This modules provides templates and routing functions which can -- be used to integrate authentication into your site. -- -- In most cases, you only need to call the 'handleAuth' and -- 'hanldeProfile' functions. The other functions are exported in case -- you wish to create your own alternatives to 'handleAuth' \/ -- 'handleProfile' -- module Happstack.Auth.Blaze.Templates ( -- * handlers handleAuth , handleProfile , handleAuthProfile , handleAuthProfileRouteT , authProfileHandler -- * page functions , addAuthPage , authPicker , createAccountPage , googlePage , genericOpenIdPage , yahooPage , liveJournalPage , liveJournalForm , myspacePage , localLoginPage , newAccountForm , personalityPicker , providerPage , loginPage , logoutPage , changePasswordPage , changePasswordForm ) where import Control.Applicative (Alternative, (<*>), (<$>), (<*), (*>), optional) import Control.Monad (replicateM, mplus, mzero) import Control.Monad.Trans (MonadIO(liftIO)) import Data.Acid (AcidState) import Data.Acid.Advanced (query', update') import Data.Maybe (mapMaybe) import Data.Monoid (mempty) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text import Data.Time.Clock (getCurrentTime) import Facebook (Credentials) import Happstack.Auth.Core.Auth import Happstack.Auth.Core.AuthParts import Happstack.Auth.Core.AuthURL import Happstack.Auth.Core.ProfileURL import Happstack.Auth.Core.Profile import Happstack.Auth.Core.ProfileParts import Happstack.Auth.Core.AuthProfileURL (AuthProfileURL(..)) import Happstack.Server (Happstack, Input, Response, internalServerError, ok, seeOther, toResponse, unauthorized) import Text.Blaze.Html5 as H hiding (fieldset, ol, li, label, head) import qualified Text.Blaze.Html5 as H import Text.Blaze.Html5.Attributes as A hiding (label) import Text.Reform import Text.Reform.Blaze.Text as R import Text.Reform.Happstack as R import Web.Authenticate.OpenId (Identifier, authenticate, getForwardUrl) import Web.Authenticate.OpenId.Providers (google, yahoo, livejournal, myspace) import Web.Routes (RouteT(..), Site(..), PathInfo(..), MonadRoute(askRouteFn), parseSegments, showURL, showURLParams, nestURL, liftRouteT, URL) import Web.Routes.Happstack (implSite_, seeOtherURL) smap :: (String -> String) -> Text -> Text smap f = Text.pack . f . Text.unpack data AuthTemplateError = ATECommon (CommonFormError [Input]) | UPE UserPassError | MinLength Int | PasswordMismatch instance FormError AuthTemplateError where type ErrorInputType AuthTemplateError = [Input] commonFormError = ATECommon instance ToMarkup (CommonFormError [Input]) where toMarkup e = toMarkup $ show e instance ToMarkup AuthTemplateError where toMarkup (ATECommon e) = toHtml $ e toMarkup (UPE e) = toHtml $ userPassErrorString e toMarkup (MinLength n) = toHtml $ "mimimum length: " ++ show n toMarkup PasswordMismatch = "Passwords do not match." type AuthForm m a = Form m [Input] AuthTemplateError Html () a logoutPage :: (MonadRoute m, URL m ~ AuthURL, Alternative m, Happstack m) => AcidState AuthState -> m Html logoutPage authStateH = do deleteAuthCookie authStateH url <- H.toValue <$> showURL A_Login return $ H.div ! A.id "happstack-authenticate" $ p $ do "You are now logged out. Click " a ! href url $ "here" " to log in again." loginPage :: (MonadRoute m, URL m ~ AuthURL, Happstack m) => Maybe Credentials -> m Html loginPage mFacebook = do googleURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode Google) yahooURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode Yahoo) liveJournalURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode LiveJournal) myspaceURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode Myspace) genericURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode Generic) localURL <- H.toValue <$> showURL A_Local facebookURL <- H.toValue <$> showURL (A_Facebook LoginMode) signupURL <- H.toValue <$> showURL A_Signup return $ H.div ! A.id "happstack-authenticate" $ do H.ol $ do H.li $ (a ! href googleURL $ "Login") >> " with your Google account" H.li $ (a ! href yahooURL $ "Login") >> " with your Yahoo account" H.li $ (a ! href liveJournalURL $ "Login") >> " with your Live Journal account" H.li $ (a ! href myspaceURL $ "Login") >> " with your Myspace account" H.li $ (a ! href genericURL $ "Login") >> " with your OpenId account" H.li $ (a ! href localURL $ "Login") >> " with a username and password" case mFacebook of (Just _) -> H.li $ (a ! href facebookURL $ "Login") >> " with your Facebook account" Nothing -> return () H.p $ (a ! href signupURL $ "Create a New Account.") signupPage :: (MonadRoute m, URL m ~ AuthURL, Happstack m) => Maybe Credentials -> m Html signupPage mFacebook = do googleURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode Google) yahooURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode Yahoo) liveJournalURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode LiveJournal) myspaceURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode Myspace) genericURL <- H.toValue <$> showURL (A_OpenIdProvider LoginMode Generic) localURL <- H.toValue <$> showURL A_CreateAccount facebookURL <- H.toValue <$> showURL (A_Facebook LoginMode) return $ H.div ! A.id "happstack-authenticate" $ H.ol $ do H.li $ (a ! href googleURL $ "Signup") >> " with your Google account" H.li $ (a ! href yahooURL $ "Signup") >> " with your Yahoo account" H.li $ (a ! href liveJournalURL $ "Signup") >> " with your Live Journal account" H.li $ (a ! href myspaceURL $ "Signup") >> " with your Myspace account" H.li $ (a ! href genericURL $ "Signup") >> " with your OpenId account" H.li $ (a ! href localURL $ "Signup") >> " with a username and password" case mFacebook of (Just _) -> H.li $ (a ! href facebookURL $ "Signup") >> " with your Facebook account" Nothing -> return () addAuthPage :: (MonadRoute m, URL m ~ AuthURL, Happstack m) => Maybe Credentials -> m Html addAuthPage mFacebook = do googleURL <- H.toValue <$> showURL (A_OpenIdProvider AddIdentifierMode Google) yahooURL <- H.toValue <$> showURL (A_OpenIdProvider AddIdentifierMode Yahoo) liveJournalURL <- H.toValue <$> showURL (A_OpenIdProvider AddIdentifierMode LiveJournal) myspaceURL <- H.toValue <$> showURL (A_OpenIdProvider AddIdentifierMode Myspace) genericURL <- H.toValue <$> showURL (A_OpenIdProvider AddIdentifierMode Generic) facebookURL <- H.toValue <$> showURL (A_Facebook AddIdentifierMode) return $ H.div ! A.id "happstack-authenticate" $ H.ol $ do H.li $ (a ! href googleURL $ "Add") >> " your Google account" H.li $ (a ! href yahooURL $ "Add") >> " your Yahoo account" H.li $ (a ! href liveJournalURL $ "Add") >> " your Live Journal account" H.li $ (a ! href myspaceURL $ "Add") >> " your Myspace account" H.li $ (a ! href genericURL $ "Add") >> " your OpenId account" case mFacebook of (Just _) -> H.li $ (a ! href facebookURL $ "Add") >> " your Facebook account" Nothing -> return () authPicker :: (MonadRoute m, URL m ~ ProfileURL, Happstack m) => Set AuthId -> m Html authPicker authIds = do auths <- mapM auth (Set.toList authIds) return $ H.div ! A.id "happstack-authenticate" $ H.ul $ sequence_ auths where auth authId = do url <- H.toValue <$> showURL (P_SetAuthId authId) return $ H.li $ a ! href url $ (H.toHtml $ show authId) -- FIXME: give a more informative view. personalityPicker :: (MonadRoute m, URL m ~ ProfileURL, Happstack m) => Set Profile -> m Html personalityPicker profiles = do personalities <- mapM personality (Set.toList profiles) return $ H.div ! A.id "happstack-authenticate" $ H.ul $ sequence_ personalities where personality profile = do url <- H.toValue <$> showURL (P_SetPersonality (userId profile)) return $ H.li $ a ! href url $ (H.toHtml $ nickName profile) providerPage :: (URL m ~ AuthURL, Happstack m, MonadRoute m) => (String -> Html -> Html -> m Response) -> OpenIdProvider -> AuthURL -> AuthMode -> m Response providerPage appTemplate provider = case provider of Google -> googlePage Yahoo -> yahooPage LiveJournal -> liveJournalPage appTemplate Myspace -> myspacePage appTemplate Generic -> genericOpenIdPage appTemplate googlePage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) => AuthURL -> AuthMode -> m Response googlePage _here authMode = do u <- showURLParams (A_OpenId (O_Connect authMode)) [("url", Just $ Text.pack google)] seeOther (Text.unpack u) (toResponse ()) yahooPage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) => AuthURL -> AuthMode -> m Response yahooPage _here authMode = do u <- showURLParams (A_OpenId (O_Connect authMode)) [(Text.pack "url", Just $ Text.pack yahoo)] seeOther (Text.unpack u) (toResponse ()) myspacePage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) => (String -> Html -> Html -> m Response) -> AuthURL -> AuthMode -> m Response myspacePage appTemplate here authMode = do actionURL <- showURL here e <- happstackEitherForm (R.form actionURL) "msp" usernameForm case e of (Left formHtml) -> do r <- appTemplate "Login via Myspace" mempty $ H.div ! A.id "happstack-authenticate" $ do h1 "Login using your myspace account" p "Enter your Myspace account name to connect." formHtml ok r (Right username) -> do u <- showURLParams (A_OpenId (O_Connect authMode)) [("url", Just $ smap myspace username)] seeOther (Text.unpack u) (toResponse ()) where usernameForm :: (Functor m, MonadIO m) => AuthForm m Text usernameForm = divInline (label' "http://www.myspace.com/" ++> inputText mempty) <* (divFormActions $ inputSubmit' "Login") liveJournalPage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) => (String -> Html -> Html -> m Response) -> AuthURL -> AuthMode -> m Response liveJournalPage appTemplate here authMode = do actionURL <- showURL here e <- happstackEitherForm (R.form actionURL) "ljp" liveJournalForm case e of (Left formHtml) -> do r <- appTemplate "Login via LiveJournal" mempty $ H.div ! A.id "happstack-authenticate" $ do h1 $ "Login using your Live Journal account" p $ "Enter your livejournal account name to connect. You may be prompted to log into your livejournal account and to confirm the login." formHtml ok r (Right username) -> do u <- showURLParams (A_OpenId (O_Connect authMode)) [("url", Just $ smap livejournal username)] seeOther (Text.unpack u) (toResponse ()) liveJournalForm :: (Functor m, MonadIO m) => AuthForm m Text liveJournalForm = divInline (label' "http://" ++> inputText mempty <++ label' ".livejournal.com/") <* divFormActions (inputSubmit' "Connect") genericOpenIdPage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) => (String -> Html -> Html -> m Response) -> AuthURL -> AuthMode -> m Response genericOpenIdPage appTemplate here authMode = do actionURL <- showURL here e <- happstackEitherForm (R.form actionURL) "oiu" openIdURLForm case e of (Left formHtml) -> do r <- appTemplate "Login via Generic OpenId" mempty $ H.div ! A.id "happstack-authenticate" $ do h1 "Login using your OpenId account" formHtml ok r (Right url) -> do u <- showURLParams (A_OpenId (O_Connect authMode)) [("url", Just url)] seeOther (Text.unpack u) (toResponse ()) where openIdURLForm :: (Functor m, MonadIO m) => AuthForm m Text openIdURLForm = divInline (label' ("Your OpenId url: " :: String) ++> inputText mempty) <* divFormActions (inputSubmit "Connect") -- | Function which takes care of all 'AuthURL' routes. -- -- The caller provides a page template function which will be used to -- render pages. The provided page template function takes three -- arguments: -- -- > String -- ^ string to use in the