happstack-authenticate-0.10.7/0000755000000000000000000000000012226553112014416 5ustar0000000000000000happstack-authenticate-0.10.7/LICENSE0000644000000000000000000000300512226553112015421 0ustar0000000000000000Copyright (c)2011, SeeReason Partners LLC 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. * Neither the name of SeeReason Partners LLC nor the names of other contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "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 OWNER OR CONTRIBUTORS 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. happstack-authenticate-0.10.7/happstack-authenticate.cabal0000644000000000000000000000524612226553112022043 0ustar0000000000000000Name: happstack-authenticate Version: 0.10.7 Synopsis: Happstack Authentication Library Description: A themeable authentication library with support for username+password and OpenId. Homepage: http://www.happstack.com/ License: BSD3 License-file: LICENSE Author: Jeremy Shaw. Maintainer: jeremy@seereason.com Copyright: 2011 SeeReason Partners, LLC Category: Web Build-type: Simple Cabal-version: >=1.6 source-repository head type: darcs subdir: happstack-authenticate location: http://hub.darcs.net/stepcut/happstack Library Exposed-modules: Happstack.Auth Happstack.Auth.Blaze.Templates Happstack.Auth.Core.Profile, Happstack.Auth.Core.Auth, Happstack.Auth.Core.ProfileURL, Happstack.Auth.Core.AuthParts, Happstack.Auth.Core.ProfileParts, Happstack.Auth.Core.AuthURL, Happstack.Auth.Core.AuthProfileURL Build-depends: base > 4 && < 5, acid-state >= 0.6 && <= 0.13, aeson >= 0.4 && < 0.7, authenticate == 1.3.*, blaze-html >= 0.5 && < 0.7, bytestring >= 0.9 && < 0.11, containers >= 0.4 && < 0.6, ixset >= 1.0 && < 1.1, happstack-server >= 6.0 && < 7.4, http-conduit >= 1.4 && < 1.10, http-types >= 0.6 && < 0.9, fb >= 0.13 && < 0.15, safecopy >= 0.6, mtl >= 2.0, pwstore-purehaskell == 2.1.*, QuickCheck >= 2, text == 0.11.*, time >= 1.2 && < 1.5, reform == 0.2.*, reform-blaze == 0.2.*, reform-happstack == 0.2.*, unordered-containers == 0.2.*, web-routes >= 0.26 && < 0.28, web-routes-happstack == 0.23.*happstack-authenticate-0.10.7/Setup.hs0000644000000000000000000000005612226553112016053 0ustar0000000000000000import Distribution.Simple main = defaultMain happstack-authenticate-0.10.7/Happstack/0000755000000000000000000000000012226553112016334 5ustar0000000000000000happstack-authenticate-0.10.7/Happstack/Auth.hs0000644000000000000000000000137312226553112017575 0ustar0000000000000000module Happstack.Auth ( UserId(..) , AuthState(..) , ProfileState(..) , AuthProfileURL(..) , AuthURL(..) , ProfileURL(..) , getUserId , authProfileHandler , handleAuth , handleProfile , handleAuthProfile , handleAuthProfileRouteT ) where import Happstack.Auth.Core.Profile (UserId(..), getUserId) import Happstack.Auth.Core.Auth (AuthState(..)) import Happstack.Auth.Core.AuthURL (AuthURL(..)) import Happstack.Auth.Core.Profile (ProfileState(..)) import Happstack.Auth.Core.ProfileURL (ProfileURL(..)) import Happstack.Auth.Core.AuthProfileURL (AuthProfileURL(..)) import Happstack.Auth.Blaze.Templates (authProfileHandler, handleAuth, handleProfile, handleAuthProfile, handleAuthProfileRouteT)happstack-authenticate-0.10.7/Happstack/Auth/0000755000000000000000000000000012226553112017235 5ustar0000000000000000happstack-authenticate-0.10.7/Happstack/Auth/Core/0000755000000000000000000000000012226553112020125 5ustar0000000000000000happstack-authenticate-0.10.7/Happstack/Auth/Core/ProfileURL.hs0000644000000000000000000000336712226553112022455 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, OverloadedStrings #-} module Happstack.Auth.Core.ProfileURL where import Control.Applicative ((<$>)) import Control.Monad (msum) import Data.Data (Data, Typeable) import Happstack.Auth.Core.Auth (AuthId(..)) import Happstack.Auth.Core.Profile (UserId(..)) import Test.QuickCheck (Arbitrary(..), Property, arbitrary, property, oneof) import Web.Routes data ProfileURL = P_SetPersonality UserId | P_SetAuthId AuthId | P_PickProfile deriving (Eq, Ord, Read, Show, Data, Typeable) instance Arbitrary ProfileURL where arbitrary = oneof $ [ P_SetPersonality . UserId <$> arbitrary , P_SetAuthId . AuthId <$> arbitrary , return P_PickProfile ] instance PathInfo ProfileURL where toPathSegments (P_SetPersonality userId) = "set_personality" : toPathSegments userId toPathSegments (P_SetAuthId authId) = "set_authid" : toPathSegments authId toPathSegments P_PickProfile = ["pick_profile"] fromPathSegments = msum [ do segment "set_personality" userId <- fromPathSegments return (P_SetPersonality userId) , do segment "set_authid" authId <- fromPathSegments return (P_SetAuthId authId) , do segment "pick_profile" return P_PickProfile ] authUrlInverse :: Property authUrlInverse = property (pathInfoInverse_prop :: ProfileURL -> Bool) {- instance EmbedAsAttr (RouteT ProfileURL (ServerPartT IO)) (Attr String ProfileURL) where asAttr (n := u) = do url <- showURL u asAttr $ MkAttr (toName n, pAttrVal url) -}happstack-authenticate-0.10.7/Happstack/Auth/Core/Auth.hs0000644000000000000000000005413012226553112021365 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, TypeFamilies, TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, GeneralizedNewtypeDeriving, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances, TypeOperators, RecordWildCards, StandaloneDeriving #-} module Happstack.Auth.Core.Auth ( UserPass(..) , UserPassId(..) , UserName(..) , UserPassError(..) , userPassErrorString , SetUserName(..) , AuthState(..) , initialAuthState , AuthToken(..) , AuthId(..) , FacebookId(..) , AuthMethod(..) , AuthMethod_v1(..) , AuthMap(..) , HashedPass(..) , mkHashedPass , genAuthToken , AskUserPass(..) , CheckUserPass(..) , CreateUserPass(..) , SetPassword(..) , AddAuthToken(..) , AskAuthToken(..) , UpdateAuthToken(..) , DeleteAuthToken(..) , GenAuthId(..) , AddAuthMethod(..) , NewAuthMethod(..) , RemoveAuthIdentifier(..) , IdentifierAuthIds(..) , FacebookAuthIds(..) , AddAuthUserPassId(..) , RemoveAuthUserPassId(..) , UserPassIdAuthIds(..) , AskAuthState(..) , SetDefaultSessionTimeout(..) , GetDefaultSessionTimeout(..) , addAuthCookie , deleteAuthCookie , getAuthId , getAuthToken ) where import Control.Applicative (Alternative, (<$>), optional) import Control.Monad (replicateM) import Control.Monad.Reader (ask) import Control.Monad.State (get, put, modify) import Control.Monad.Trans (MonadIO(..)) import Crypto.PasswordStore import Data.Acid import Data.Acid.Advanced (query', update') import Data.ByteString (ByteString) import qualified Data.ByteString.Char8 as B import Data.Data (Data, Typeable) import qualified Data.IxSet as IxSet import Data.IxSet (Indexable(..), IxSet, (@=), inferIxSet, noCalcs, inferIxSet, ixFun, ixSet, noCalcs, getOne, updateIx) import Data.Map (Map) import qualified Data.Map as Map import Data.SafeCopy -- (base, deriveSafeCopy) import Data.Set (Set) import qualified Data.Set as Set import Data.Time.Clock (UTCTime, addUTCTime, diffUTCTime, getCurrentTime) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Text (Text) import Facebook (UserId, Id(..)) import Web.Authenticate.OpenId (Identifier) import Web.Routes (PathInfo(..)) import Happstack.Server (Cookie(..), CookieLife(..), Happstack, Request(rqSecure), addCookie, askRq, expireCookie, lookCookieValue, mkCookie) newtype AuthId = AuthId { unAuthId :: Integer } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''AuthId) instance PathInfo AuthId where toPathSegments (AuthId i) = toPathSegments i fromPathSegments = AuthId <$> fromPathSegments succAuthId :: AuthId -> AuthId succAuthId (AuthId i) = AuthId (succ i) -- * UserPass newtype HashedPass = HashedPass ByteString deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''HashedPass) -- | NOTE: The Eq and Ord instances are 'case-insensitive'. They apply 'toCaseFold' before comparing. newtype UserName = UserName { unUserName :: Text } deriving (Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''UserName) instance Eq UserName where (UserName x) == (UserName y) = (Text.toCaseFold x) == (Text.toCaseFold y) (UserName x) /= (UserName y) = (Text.toCaseFold x) /= (Text.toCaseFold y) instance Ord UserName where compare (UserName x) (UserName y) = compare (Text.toCaseFold x) (Text.toCaseFold y) (UserName x) < (UserName y) = (Text.toCaseFold x) < (Text.toCaseFold y) (UserName x) >= (UserName y) = (Text.toCaseFold x) >= (Text.toCaseFold y) (UserName x) > (UserName y) = (Text.toCaseFold x) > (Text.toCaseFold y) (UserName x) <= (UserName y) = (Text.toCaseFold x) <= (Text.toCaseFold y) max (UserName x) (UserName y) = UserName $ max (Text.toCaseFold x) (Text.toCaseFold y) min (UserName x) (UserName y) = UserName $ min (Text.toCaseFold x) (Text.toCaseFold y) newtype UserPassId = UserPassId { unUserPassId :: Integer } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''UserPassId) succUserPassId :: UserPassId -> UserPassId succUserPassId (UserPassId i) = UserPassId (succ i) data UserPass = UserPass { upName :: UserName , upPassword :: HashedPass , upId :: UserPassId } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''UserPass) $(inferIxSet "UserPasses" ''UserPass 'noCalcs [''UserName, ''HashedPass, ''AuthId, ''UserPassId]) -- * Identifier $(deriveSafeCopy 1 'base ''Identifier) -- * AuthMap newtype FacebookId_001 = FacebookId_001 { unFacebookId_001 :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable, SafeCopy) newtype FacebookId_002 = FacebookId_002 { unFacebookId_002 :: B.ByteString } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 2 'extension ''FacebookId_002) instance Migrate FacebookId_002 where type MigrateFrom FacebookId_002 = FacebookId_001 migrate (FacebookId_001 fid) = FacebookId_002 (Text.encodeUtf8 fid) deriving instance Data Id $(deriveSafeCopy 0 'base ''Id) newtype FacebookId = FacebookId { unFacebookId :: UserId } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 3 'extension ''FacebookId) instance Migrate FacebookId where type MigrateFrom FacebookId = FacebookId_002 migrate (FacebookId_002 fid) = FacebookId (Id $ Text.decodeUtf8 fid) data AuthMethod_v1 = AuthIdentifier_v1 { amIdentifier_v1 :: Identifier } | AuthUserPassId_v1 { amUserPassId_v1 :: UserPassId } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''AuthMethod_v1) data AuthMethod = AuthIdentifier { amIdentifier :: Identifier } | AuthUserPassId { amUserPassId :: UserPassId } | AuthFacebook { amFacebookId :: FacebookId } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 2 'extension ''AuthMethod) instance Migrate AuthMethod where type MigrateFrom AuthMethod = AuthMethod_v1 migrate (AuthIdentifier_v1 ident) = AuthIdentifier ident migrate (AuthUserPassId_v1 up) = AuthUserPassId up -- | This links an authentication method (such as on OpenId 'Identifier', a 'FacebookId', or 'UserPassId') to an 'AuthId'. data AuthMap = AuthMap { amMethod :: AuthMethod , amAuthId :: AuthId } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''AuthMap) $(inferIxSet "AuthMaps" ''AuthMap 'noCalcs [''AuthId, ''AuthMethod, ''Identifier, ''UserPassId, ''FacebookId]) -- * AuthToken data AuthToken_001 = AuthToken_001 { tokenString_001 :: String , tokenExpires_001 :: UTCTime , tokenAuthId_001 :: Maybe AuthId , tokenAuthMethod_001 :: AuthMethod } deriving (Eq, Ord, Data, Show, Typeable) $(deriveSafeCopy 1 'base ''AuthToken_001) data AuthToken = AuthToken { tokenString :: String , tokenExpires :: UTCTime , tokenLifetime :: Int , tokenAuthId :: Maybe AuthId , tokenAuthMethod :: AuthMethod } deriving (Eq, Ord, Data, Show, Typeable) $(deriveSafeCopy 2 'extension ''AuthToken) instance Migrate AuthToken where type MigrateFrom AuthToken = AuthToken_001 migrate (AuthToken_001 ts te tid tam) = (AuthToken ts te 3600 tid tam) instance Indexable AuthToken where empty = ixSet [ ixFun $ (:[]) . tokenString , ixFun $ (:[]) . tokenAuthId ] type AuthTokens = IxSet AuthToken -- * AuthState -- how to we remove expired AuthTokens? -- -- Since the user might be logged in a several machines they might have several auth tokens. So we can not just expire the old ones everytime they log in. -- -- Basically we can expired them on: logout and time -- -- time is tricky because we do not really want to do a db update everytime they access the site data AuthState_1 = AuthState_1 { userPasses_1 :: UserPasses , nextUserPassId_1 :: UserPassId , authMaps_1 :: AuthMaps , nextAuthId_1 :: AuthId , authTokens_1 :: AuthTokens } deriving (Data, Eq, Show, Typeable) $(deriveSafeCopy 1 'base ''AuthState_1) data AuthState = AuthState { userPasses :: UserPasses , nextUserPassId :: UserPassId , authMaps :: AuthMaps , nextAuthId :: AuthId , authTokens :: AuthTokens , defaultSessionTimeout :: Int } deriving (Data, Eq, Show, Typeable) $(deriveSafeCopy 2 'extension ''AuthState) instance Migrate AuthState where type MigrateFrom AuthState = AuthState_1 migrate (AuthState_1 up nup am nai at) = (AuthState up nup am nai at (60*60)) -- | a reasonable initial 'AuthState' initialAuthState :: AuthState initialAuthState = AuthState { userPasses = IxSet.empty , nextUserPassId = UserPassId 1 , authMaps = IxSet.empty , authTokens = IxSet.empty , nextAuthId = AuthId 1 , defaultSessionTimeout = 60*60 } -- ** UserPass modifyUserPass :: UserPassId -> (UserPass -> UserPass) -> Update AuthState (Maybe UserPassError) modifyUserPass upid fn = do as@(AuthState {..}) <- get case getOne $ userPasses @= upid of Nothing -> return (Just $ InvalidUserPassId upid) (Just userPass) -> do let userPass' = fn userPass put as { userPasses = IxSet.updateIx upid userPass' userPasses } return Nothing -- | errors that can occur when working with 'UserPass' data UserPassError = UsernameInUse UserName | InvalidUserPassId UserPassId | InvalidUserName UserName | InvalidPassword deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''UserPassError) -- | return a user-friendly error message string for an 'AddAuthError' userPassErrorString :: UserPassError -> String userPassErrorString (UsernameInUse (UserName txt)) = "Username already in use: " ++ Text.unpack txt userPassErrorString (InvalidUserPassId (UserPassId i)) = "Invalid UserPassId " ++ show i userPassErrorString (InvalidUserName (UserName name)) = "Invalid username " ++ Text.unpack name userPassErrorString InvalidPassword = "Invalid password" -- | creates a new 'UserPass' createUserPass :: UserName -- ^ desired username -> HashedPass -- ^ hashed password -> Update AuthState (Either UserPassError UserPass) createUserPass name hashedPass = do as@(AuthState{..}) <- get if not (IxSet.null $ userPasses @= name) then return (Left (UsernameInUse name)) else do let userPass = UserPass { upName = name , upPassword = hashedPass , upId = nextUserPassId } put $ as { userPasses = IxSet.insert userPass userPasses , nextUserPassId = succUserPassId nextUserPassId } return (Right userPass) -- | change the 'UserName' associated with a 'UserPassId' -- this will break password salting... setUserName :: UserPassId -> Text -> Update AuthState (Maybe UserPassError) setUserName upid name = do as <- get if nameAvailable (userPasses as) then case getOne $ (userPasses as) @= upid of (Just userPass) -> do put $ as { userPasses = IxSet.updateIx upid (userPass { upName = UserName name }) (userPasses as) } return Nothing Nothing -> return (Just $ InvalidUserPassId upid) else return (Just $ UsernameInUse (UserName name)) where nameAvailable userPasses = case IxSet.toList (userPasses @= (UserName name)) of [] -> True [a] | (upId a == upid) -> True _ -> False -- | hash a password string mkHashedPass :: Text -- ^ password in plain text -> IO HashedPass -- ^ salted and hashed mkHashedPass pass = HashedPass <$> makePassword (Text.encodeUtf8 pass) 12 -- | verify a password verifyHashedPass :: Text -- ^ password in plain text -> HashedPass -- ^ hashed version of password -> Bool verifyHashedPass passwd (HashedPass hashedPass) = verifyPassword (Text.encodeUtf8 passwd) hashedPass -- | change the password for the give 'UserPassId' setPassword :: UserPassId -> HashedPass -> Update AuthState (Maybe UserPassError) setPassword upid hashedPass = modifyUserPass upid $ \userPass -> userPass { upPassword = hashedPass } checkUserPass :: Text -> Text -> Query AuthState (Either UserPassError UserPassId) checkUserPass username password = do as@(AuthState{..}) <- ask case IxSet.getOne $ userPasses @= (UserName username) of Nothing -> return (Left $ InvalidUserName (UserName username)) (Just userPass) | verifyHashedPass password (upPassword userPass) -> do return (Right (upId userPass)) | otherwise -> return (Left InvalidPassword) askUserPass :: UserPassId -> Query AuthState (Maybe UserPass) askUserPass uid = do as@(AuthState{..}) <-ask return $ getOne $ userPasses @= uid -- ** AuthMap addAuthMethod :: AuthMethod -> AuthId -> Update AuthState () addAuthMethod authMethod authid = do as@(AuthState{..}) <- get put $ as { authMaps = IxSet.insert (AuthMap authMethod authid) authMaps } newAuthMethod :: AuthMethod -> Update AuthState AuthId newAuthMethod authMethod = do as@(AuthState{..}) <- get put $ as { authMaps = IxSet.insert (AuthMap authMethod nextAuthId) authMaps , nextAuthId = succAuthId nextAuthId } return nextAuthId removeAuthIdentifier :: Identifier -> AuthId -> Update AuthState () removeAuthIdentifier identifier authid = do as@(AuthState{..}) <- get put $ as { authMaps = IxSet.delete (AuthMap (AuthIdentifier identifier) authid) authMaps } identifierAuthIds :: Identifier -> Query AuthState (Set AuthId) identifierAuthIds identifier = do as@(AuthState{..}) <- ask return $ Set.map amAuthId $ IxSet.toSet $ authMaps @= identifier facebookAuthIds :: FacebookId -> Query AuthState (Set AuthId) facebookAuthIds facebookId = do as@(AuthState{..}) <- ask return $ Set.map amAuthId $ IxSet.toSet $ authMaps @= facebookId addAuthUserPassId :: UserPassId -> AuthId -> Update AuthState () addAuthUserPassId upid authid = do as@(AuthState{..}) <- get put $ as { authMaps = IxSet.insert (AuthMap (AuthUserPassId upid) authid) authMaps } removeAuthUserPassId :: UserPassId -> AuthId -> Update AuthState () removeAuthUserPassId upid authid = do as@(AuthState{..}) <- get put $ as { authMaps = IxSet.delete (AuthMap (AuthUserPassId upid) authid) authMaps } userPassIdAuthIds :: UserPassId -> Query AuthState (Set AuthId) userPassIdAuthIds upid = do as@(AuthState{..}) <- ask return $ Set.map amAuthId $ IxSet.toSet $ authMaps @= upid -- * Default timeout setDefaultSessionTimeout :: Int -- ^ default timout in seconds (should be >= 180) -> Update AuthState () setDefaultSessionTimeout newTimeout = modify $ \as@AuthState{..} -> as { defaultSessionTimeout = newTimeout } getDefaultSessionTimeout :: Query AuthState Int getDefaultSessionTimeout = defaultSessionTimeout <$> ask -- * AuthToken addAuthToken :: AuthToken -> Update AuthState () addAuthToken authToken = do as@AuthState{..} <- get put (as { authTokens = IxSet.insert authToken authTokens }) -- | look up the 'AuthToken' associated with the 'String' askAuthToken :: String -- ^ token string (used in the cookie) -> Query AuthState (Maybe AuthToken) askAuthToken tokenStr = do as@AuthState{..} <- ask return $ getOne $ authTokens @= tokenStr updateAuthToken :: AuthToken -> Update AuthState () updateAuthToken authToken = do as@AuthState{..} <- get put (as { authTokens = IxSet.updateIx (tokenString authToken) authToken authTokens }) deleteAuthToken :: String -> Update AuthState () deleteAuthToken tokenStr = do as@AuthState{..} <- get put (as { authTokens = IxSet.deleteIx tokenStr authTokens }) purgeExpiredTokens :: UTCTime -> Update AuthState () purgeExpiredTokens now = do as@AuthState{..} <- get let authTokens' = IxSet.fromList $ filter (\at -> (tokenExpires at) > now) (IxSet.toList authTokens) put as { authTokens = authTokens'} -- | deprecated -- -- this function is deprecated because it is not possible to check if the session has expired authTokenAuthId :: String -> Query AuthState (Maybe AuthId) authTokenAuthId tokenString = do as@(AuthState{..}) <- ask case getOne $ authTokens @= tokenString of Nothing -> return Nothing (Just authToken) -> return $ (tokenAuthId authToken) -- | generate a new, unused 'AuthId' genAuthId :: Update AuthState AuthId genAuthId = do as@(AuthState {..}) <- get put (as { nextAuthId = succAuthId nextAuthId }) return nextAuthId askAuthState :: Query AuthState AuthState askAuthState = ask $(makeAcidic ''AuthState [ 'askUserPass , 'checkUserPass , 'createUserPass , 'setUserName , 'setPassword , 'addAuthToken , 'askAuthToken , 'updateAuthToken , 'deleteAuthToken , 'purgeExpiredTokens , 'authTokenAuthId , 'genAuthId , 'addAuthMethod , 'newAuthMethod , 'removeAuthIdentifier , 'identifierAuthIds , 'facebookAuthIds , 'addAuthUserPassId , 'removeAuthUserPassId , 'userPassIdAuthIds , 'askAuthState , 'setDefaultSessionTimeout , 'getDefaultSessionTimeout ]) -- * happstack-server level stuff -- TODO: -- - expireAuthTokens -- - tickleAuthToken -- | generate an new authentication token -- genAuthToken :: (MonadIO m) => Maybe AuthId -> AuthMethod -> Int -> m AuthToken genAuthToken aid authMethod lifetime = do random <- liftIO $ B.unpack . exportSalt <$> genSaltIO -- the docs promise that the salt will be base64, so 'B.unpack' should be safe now <- liftIO $ getCurrentTime let expires = addUTCTime (fromIntegral lifetime) now prefix = case aid of Nothing -> "0" (Just a) -> show (unAuthId a) return $ AuthToken { tokenString = prefix ++ random , tokenExpires = expires , tokenLifetime = lifetime , tokenAuthId = aid , tokenAuthMethod = authMethod } -- Also calls 'PurgeExpiredTokens' addAuthCookie :: (Happstack m) => AcidState AuthState -> Maybe AuthId -> AuthMethod -> m () addAuthCookie acidH aid authMethod = do lifetime <- query' acidH GetDefaultSessionTimeout authToken <- genAuthToken aid authMethod lifetime now <- liftIO $ getCurrentTime update' acidH (PurgeExpiredTokens now) update' acidH (AddAuthToken authToken) s <- rqSecure <$> askRq addCookie Session ((mkCookie "authToken" (tokenString authToken)) { secure = s }) return () deleteAuthCookie :: (Happstack m, Alternative m) => AcidState AuthState -> m () deleteAuthCookie acidH = do mTokenStr <- optional $ lookCookieValue "authToken" case mTokenStr of Nothing -> return () (Just tokenStr) -> do expireCookie "authToken" update' acidH (DeleteAuthToken tokenStr) {- getAuthCookie :: (Alternative m, Happstack m) => AcidState AuthState -> m (Maybe AuthToken) getAuthCookie acidH = do mTokenStr <- optional $ lookCookieValue "authToken" -} getAuthToken :: (Alternative m, Happstack m) => AcidState AuthState -> m (Maybe AuthToken) getAuthToken acidH = do mTokenStr <- optional $ lookCookieValue "authToken" case mTokenStr of Nothing -> return Nothing (Just tokenStr) -> do mAuthToken <- query' acidH (AskAuthToken tokenStr) case mAuthToken of Nothing -> return Nothing (Just authToken) -> do now <- liftIO $ getCurrentTime if now > (tokenExpires authToken) then do expireCookie "authToken" update' acidH (DeleteAuthToken tokenStr) return Nothing else if (diffUTCTime (addUTCTime (fromIntegral $ tokenLifetime authToken) now) (tokenExpires authToken)) > 60 then do let newAuthToken = authToken { tokenExpires = addUTCTime (fromIntegral $ tokenLifetime authToken) now } update' acidH (UpdateAuthToken newAuthToken) return (Just newAuthToken) else return (Just authToken) getAuthId :: (Alternative m, Happstack m) => AcidState AuthState -> m (Maybe AuthId) getAuthId acidH = do mAuthToken <- getAuthToken acidH case mAuthToken of Nothing -> return Nothing (Just authToken) -> return $ (tokenAuthId authToken) happstack-authenticate-0.10.7/Happstack/Auth/Core/AuthURL.hs0000644000000000000000000001237012226553112021750 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, FlexibleContexts, FlexibleInstances, OverloadedStrings #-} module Happstack.Auth.Core.AuthURL where import Control.Applicative ((<$>), (<*>)) import Control.Monad (msum) import Data.Data (Data, Typeable) import Data.Text (unpack) import Test.QuickCheck (Arbitrary(..), Property, property, oneof) import Web.Routes (PathInfo(..), pathInfoInverse_prop, segment) data OpenIdProvider = Google | Yahoo | Myspace | LiveJournal | Generic deriving (Eq, Ord, Read, Show, Data, Typeable, Enum, Bounded) instance PathInfo OpenIdProvider where toPathSegments Google = ["google"] toPathSegments Yahoo = ["yahoo"] toPathSegments Myspace = ["myspace"] toPathSegments LiveJournal = ["livejournal"] toPathSegments Generic = ["generic"] fromPathSegments = msum [ do segment "google" return Google , do segment "yahoo" return Yahoo , do segment "myspace" return Myspace , do segment "livejournal" return LiveJournal , do segment "generic" return Generic ] instance Arbitrary OpenIdProvider where arbitrary = oneof $ map return [ minBound .. maxBound ] data AuthMode = LoginMode | AddIdentifierMode deriving (Eq, Ord, Read, Show, Data, Typeable) instance PathInfo AuthMode where toPathSegments LoginMode = ["login"] toPathSegments AddIdentifierMode = ["add_identifier"] fromPathSegments = msum [ do segment "login" return LoginMode , do segment "add_identifier" return AddIdentifierMode ] instance Arbitrary AuthMode where arbitrary = oneof [ return LoginMode , return AddIdentifierMode ] data AuthURL = A_Login | A_AddAuth | A_Logout | A_Local | A_CreateAccount | A_ChangePassword | A_OpenId OpenIdURL | A_OpenIdProvider AuthMode OpenIdProvider | A_Facebook AuthMode | A_FacebookRedirect AuthMode deriving (Eq, Ord, Read, Show, Data, Typeable) data OpenIdURL = O_OpenId AuthMode | O_Connect AuthMode deriving (Eq, Ord, Read, Show, Data, Typeable) instance Arbitrary OpenIdURL where arbitrary = oneof [ O_OpenId <$> arbitrary , O_Connect <$> arbitrary ] instance Arbitrary AuthURL where arbitrary = oneof [ return A_Login , return A_Logout , return A_Local , return A_AddAuth , return A_CreateAccount , return A_ChangePassword , A_OpenId <$> arbitrary , A_OpenIdProvider <$> arbitrary <*> arbitrary , A_Facebook <$> arbitrary , A_FacebookRedirect <$> arbitrary ] instance PathInfo OpenIdURL where toPathSegments (O_OpenId authMode) = "openid_return" : toPathSegments authMode toPathSegments (O_Connect authMode) = "connect" : toPathSegments authMode fromPathSegments = msum [ do segment "openid_return" mode <- fromPathSegments return (O_OpenId mode) , do segment "connect" authMode <- fromPathSegments return (O_Connect authMode) ] instance PathInfo AuthURL where toPathSegments A_Login = ["login"] toPathSegments A_Logout = ["logout"] toPathSegments A_Local = ["local"] toPathSegments A_CreateAccount = ["create"] toPathSegments A_ChangePassword = ["change_password"] toPathSegments A_AddAuth = ["add_auth"] toPathSegments (A_OpenId o) = "openid" : toPathSegments o toPathSegments (A_OpenIdProvider authMode provider) = "provider" : toPathSegments authMode ++ toPathSegments provider toPathSegments (A_Facebook authMode) = "facebook" : toPathSegments authMode toPathSegments (A_FacebookRedirect authMode) = "facebook-redirect" : toPathSegments authMode fromPathSegments = msum [ do segment "login" return A_Login , do segment "logout" return A_Logout , do segment "local" return A_Local , do segment "create" return A_CreateAccount , do segment "change_password" return A_ChangePassword , do segment "openid" A_OpenId <$> fromPathSegments , do segment "add_auth" return A_AddAuth , do segment "provider" authMode <- fromPathSegments provider <- fromPathSegments return (A_OpenIdProvider authMode provider) , do segment "facebook" authMode <- fromPathSegments return (A_Facebook authMode) , do segment "facebook-redirect" authMode <- fromPathSegments return (A_FacebookRedirect authMode) ] authUrlInverse :: Property authUrlInverse = property (pathInfoInverse_prop :: AuthURL -> Bool) happstack-authenticate-0.10.7/Happstack/Auth/Core/Profile.hs0000644000000000000000000001041512226553112022062 0ustar0000000000000000{-# LANGUAGE TemplateHaskell, TypeFamilies, TypeSynonymInstances, DeriveDataTypeable, FlexibleInstances, MultiParamTypeClasses, FlexibleContexts, UndecidableInstances, TypeOperators, RecordWildCards #-} module Happstack.Auth.Core.Profile where import Control.Applicative import Control.Monad.Reader import Control.Monad.State import Data.Acid (AcidState, Update, Query, makeAcidic) import Data.Acid.Advanced (query', update') import Data.Data import Data.IxSet (IxSet, (@=), inferIxSet, noCalcs) import qualified Data.IxSet as IxSet import Data.Map (Map) import qualified Data.Map as Map import Data.SafeCopy (base, deriveSafeCopy) import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text import Happstack.Auth.Core.Auth import Happstack.Server import Web.Routes newtype UserId = UserId { unUserId :: Integer } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''UserId) instance PathInfo UserId where toPathSegments (UserId i) = toPathSegments i fromPathSegments = UserId <$> fromPathSegments succUserId :: UserId -> UserId succUserId (UserId i) = UserId (succ i) data Profile = Profile { userId :: UserId , auths :: Set AuthId , nickName :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''Profile) $(inferIxSet "Profiles" ''Profile 'noCalcs [''UserId, ''AuthId]) data ProfileState = ProfileState { profiles :: Profiles , authUserMap :: Map AuthId UserId -- ^ map of what 'UserId' an 'AuthId' is currently defaulting to , nextUserId :: UserId } deriving (Eq, Ord, Read, Show, Data, Typeable) $(deriveSafeCopy 1 'base ''ProfileState) -- | a reasonable initial 'ProfileState' initialProfileState :: ProfileState initialProfileState = ProfileState { profiles = IxSet.empty , authUserMap = Map.empty , nextUserId = UserId 1 } -- | Retrieve the entire ProfileState -- Warning, this is an admin level function? getProfileState :: Query ProfileState ProfileState getProfileState = do ps <- ask return ps genUserId :: Update ProfileState UserId genUserId = do as@(ProfileState {..}) <- get put (as { nextUserId = succUserId nextUserId }) return nextUserId -- return the UserId currently prefered by this AuthId -- -- can be Nothing if no preference is set, even if there are possible UserIds authIdUserId :: AuthId -> Query ProfileState (Maybe UserId) authIdUserId aid = do ps@(ProfileState {..}) <- ask return $ Map.lookup aid authUserMap -- return all the Profiles associated with this AuthId authIdProfiles :: AuthId -> Query ProfileState (Set Profile) authIdProfiles aid = do ps@(ProfileState {..}) <- ask return $ IxSet.toSet (profiles @= aid) setAuthIdUserId :: AuthId -> UserId -> Update ProfileState () setAuthIdUserId authId userId = do ps@(ProfileState{..}) <- get put $ ps { authUserMap = Map.insert authId userId authUserMap } createNewProfile :: Set AuthId -> Update ProfileState UserId createNewProfile authIds = do ps@(ProfileState{..}) <- get let profile = Profile { userId = nextUserId , auths = authIds , nickName = Text.pack "Anonymous" } put $ (ps { profiles = IxSet.insert profile profiles , nextUserId = succUserId nextUserId }) return nextUserId $(makeAcidic ''ProfileState [ 'authIdUserId , 'authIdProfiles , 'setAuthIdUserId , 'createNewProfile , 'genUserId , 'getProfileState ]) getUserId :: (Alternative m, Happstack m) => AcidState AuthState -> AcidState ProfileState -> m (Maybe UserId) getUserId authStateH profileStateH = do mAuthToken <- getAuthToken authStateH case mAuthToken of Nothing -> return Nothing (Just authToken) -> case tokenAuthId authToken of Nothing -> return Nothing (Just authId) -> query' profileStateH (AuthIdUserId authId) happstack-authenticate-0.10.7/Happstack/Auth/Core/AuthParts.hs0000644000000000000000000001553612226553112022406 0ustar0000000000000000{-# LANGUAGE GADTs, TypeFamilies, ViewPatterns, RecordWildCards #-} module Happstack.Auth.Core.AuthParts where import Control.Applicative (Alternative) import Control.Monad.Trans (liftIO) import Data.Acid (AcidState) import Data.Acid.Advanced (query', update') import Data.Aeson (Value(..)) import qualified Data.HashMap.Lazy as HashMap import Data.Maybe (mapMaybe) import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Text as T import Data.Text (Text) import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import Facebook (Credentials, AccessToken(UserAccessToken), getUserAccessTokenStep1, getUserAccessTokenStep2, runFacebookT) import Happstack.Server (Happstack, Response, lookPairsBS, lookText, seeOther, toResponse, internalServerError) import Happstack.Auth.Core.Auth import Happstack.Auth.Core.AuthURL import Network.HTTP.Conduit (withManager) import Web.Authenticate.OpenId (Identifier, OpenIdResponse(..), authenticateClaimed, getForwardUrl) -- import Web.Authenticate.Facebook (Facebook(..), getAccessToken, getGraphData) -- import qualified Web.Authenticate.Facebook as Facebook import Web.Routes -- this verifies the identifier -- and sets authToken cookie -- if the identifier was not associated with an AuthId, then a new AuthId will be created and associated with it. openIdPage :: (Alternative m, Happstack m) => AcidState AuthState -> AuthMode -> Text -> m Response openIdPage acid LoginMode onAuthURL = do identifier <- getIdentifier identifierAddAuthIdsCookie acid identifier seeOther (T.unpack onAuthURL) (toResponse ()) openIdPage acid AddIdentifierMode onAuthURL = do identifier <- getIdentifier mAuthId <- getAuthId acid case mAuthId of Nothing -> undefined -- FIXME (Just authId) -> do update' acid (AddAuthMethod (AuthIdentifier identifier) authId) seeOther (T.unpack onAuthURL) (toResponse ()) -- this get's the identifier the openid provider provides. It is our only chance to capture the Identifier. So, before we send a Response we need to have some sort of cookie set that identifies the user. We can not just put the identifier in the cookie because we don't want some one to fake it. getIdentifier :: (Happstack m) => m Identifier getIdentifier = do pairs' <- lookPairsBS let pairs = mapMaybe (\(k, ev) -> case ev of (Left _) -> Nothing ; (Right v) -> Just (T.pack k, TL.toStrict $ TL.decodeUtf8 v)) pairs' oir <- liftIO $ withManager $ authenticateClaimed pairs return (oirOpLocal oir) -- calling this will log you in as 1 or more AuthIds -- problem.. if the Identifier is not associated with any Auths, then we are in trouble, because the identifier will be 'lost'. -- so, if there are no AuthIds associated with the identifier, we create one. -- -- we have another problem though.. we want to allow a user to specify a prefered AuthId. But that preference needs to be linked to a specific Identifier ? identifierAddAuthIdsCookie :: (Happstack m) => AcidState AuthState -> Identifier -> m (Maybe AuthId) identifierAddAuthIdsCookie acid identifier = do authId <- do authIds <- query' acid (IdentifierAuthIds identifier) case Set.size authIds of 1 -> return $ (Just $ head $ Set.toList $ authIds) n -> return $ Nothing addAuthCookie acid authId (AuthIdentifier identifier) return authId facebookAddAuthIdsCookie :: (Happstack m) => AcidState AuthState -> FacebookId -> m (Maybe AuthId) facebookAddAuthIdsCookie acid facebookId = do authId <- do authIds <- query' acid (FacebookAuthIds facebookId) case Set.size authIds of 1 -> return $ (Just $ head $ Set.toList $ authIds) n -> return $ Nothing addAuthCookie acid authId (AuthFacebook facebookId) return authId connect :: (Happstack m, MonadRoute m, URL m ~ OpenIdURL) => AuthMode -- ^ authentication mode -> Maybe Text -- ^ realm -> Text -- ^ openid url -> m Response connect authMode realm url = do openIdUrl <- showURL (O_OpenId authMode) gotoURL <- liftIO $ withManager $ getForwardUrl url openIdUrl realm [] seeOther (T.unpack gotoURL) (toResponse gotoURL) -- type ProviderPage m p = (OpenIdURL p) -> AuthMode -> m Response handleOpenId :: (Alternative m, Happstack m, MonadRoute m, URL m ~ OpenIdURL) => AcidState AuthState -> Maybe Text -- ^ realm -> Text -- ^ onAuthURL -> OpenIdURL -- ^ this url -> m Response handleOpenId acid realm onAuthURL url = case url of (O_OpenId authMode) -> openIdPage acid authMode onAuthURL (O_Connect authMode) -> do url <- lookText "url" connect authMode realm (TL.toStrict url) facebookPage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) => Credentials -> AuthMode -> m Response facebookPage credentials authMode = do redirectUri <- showURL (A_FacebookRedirect authMode) uri <- liftIO $ withManager $ \m -> runFacebookT credentials m $ getUserAccessTokenStep1 redirectUri [] seeOther (T.unpack uri) (toResponse ()) facebookRedirectPage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) => AcidState AuthState -> Credentials -> Text -- ^ onAuthURL -> AuthMode -> m Response facebookRedirectPage acidAuth credentials onAuthURL authMode = do redirectUri <- showURL (A_FacebookRedirect authMode) userAccessToken <- liftIO $ withManager $ \m -> runFacebookT credentials m $ getUserAccessTokenStep2 redirectUri [] case (authMode, userAccessToken) of (LoginMode, UserAccessToken facebookId _ _) -> do facebookAddAuthIdsCookie acidAuth (FacebookId facebookId) seeOther (T.unpack onAuthURL) (toResponse ()) (AddIdentifierMode, UserAccessToken facebookId _ _) -> do mAuthId <- getAuthId acidAuth case mAuthId of Nothing -> internalServerError $ toResponse $ "Could not add new authentication method because the user is not logged in." (Just authId) -> do update' acidAuth (AddAuthMethod (AuthFacebook (FacebookId facebookId)) authId) seeOther (T.unpack onAuthURL) (toResponse ()) happstack-authenticate-0.10.7/Happstack/Auth/Core/AuthProfileURL.hs0000644000000000000000000000213212226553112023264 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} module Happstack.Auth.Core.AuthProfileURL where import Control.Applicative ((<$>)) import Control.Monad (msum) import Data.Data (Data, Typeable) import Happstack.Auth.Core.AuthURL (AuthURL(..)) import Happstack.Auth.Core.ProfileURL (ProfileURL(..)) import Web.Routes (PathInfo(..), segment) import Test.QuickCheck (Arbitrary(..), oneof) data AuthProfileURL = AuthURL AuthURL | ProfileURL ProfileURL deriving (Eq, Ord, Read, Show, Data, Typeable) instance PathInfo AuthProfileURL where toPathSegments (AuthURL authURL) = "auth" : toPathSegments authURL toPathSegments (ProfileURL profileURL) = "profile" : toPathSegments profileURL fromPathSegments = msum [ do segment "auth" AuthURL <$> fromPathSegments , do segment "profile" ProfileURL <$> fromPathSegments ] instance Arbitrary AuthProfileURL where arbitrary = oneof [ AuthURL <$> arbitrary , ProfileURL <$> arbitrary ] happstack-authenticate-0.10.7/Happstack/Auth/Core/ProfileParts.hs0000644000000000000000000000730612226553112023101 0ustar0000000000000000module Happstack.Auth.Core.ProfileParts where import Control.Applicative (Alternative(..)) import Data.Acid (AcidState) import Data.Acid.Advanced (update', query') import Data.Set (Set) import qualified Data.Set as Set import Happstack.Server import Happstack.Auth.Core.Auth import Happstack.Auth.Core.ProfileURL import Happstack.Auth.Core.Profile import Web.Routes import Web.Routes.Happstack -- * ProfileURL stuff -- can we pick an AuthId with only the information in the Auth stuff? Or should that be a profile action ? pickAuthId :: (Happstack m, Alternative m) => AcidState AuthState -> m (Either (Set AuthId) AuthId) pickAuthId authStateH = do (Just authToken) <- getAuthToken authStateH -- FIXME: Just case tokenAuthId authToken of (Just authId) -> return (Right authId) Nothing -> do authIds <- case tokenAuthMethod authToken of (AuthIdentifier identifier) -> query' authStateH (IdentifierAuthIds identifier) (AuthFacebook facebookId) -> query' authStateH (FacebookAuthIds facebookId) case Set.size authIds of 0 -> do authId <- update' authStateH (NewAuthMethod (tokenAuthMethod authToken)) update' authStateH (UpdateAuthToken (authToken { tokenAuthId = Just authId })) return (Right authId) 1 -> do let aid = head $ Set.toList authIds update' authStateH (UpdateAuthToken (authToken { tokenAuthId = Just aid })) return (Right aid) n -> return (Left authIds) setAuthIdPage :: (Alternative m, Happstack m) => AcidState AuthState -> AuthId -> m Bool setAuthIdPage authStateH authId = do mAuthToken <- getAuthToken authStateH case mAuthToken of Nothing -> undefined -- FIXME (Just authToken) -> do authIds <- case tokenAuthMethod authToken of (AuthIdentifier identifier) -> query' authStateH (IdentifierAuthIds identifier) (AuthFacebook facebookId) -> query' authStateH (FacebookAuthIds facebookId) if Set.member authId authIds then do update' authStateH (UpdateAuthToken (authToken { tokenAuthId = Just authId })) return True else return False data PickProfile = Picked UserId | PickPersonality (Set Profile) | PickAuthId (Set AuthId) pickProfile :: (Happstack m, Alternative m) => AcidState AuthState -> AcidState ProfileState -> m PickProfile pickProfile authStateH profileStateH = do eAid <- pickAuthId authStateH case eAid of (Right aid) -> do mUid <- query' profileStateH (AuthIdUserId aid) case mUid of Nothing -> do profiles <- query' profileStateH (AuthIdProfiles aid) case Set.size profiles of 0 -> do uid <- update' profileStateH (CreateNewProfile (Set.singleton aid)) update' profileStateH (SetAuthIdUserId aid uid) return (Picked uid) -- seeOther onLoginURL (toResponse onLoginURL) 1 -> do let profile = head $ Set.toList profiles update' profileStateH (SetAuthIdUserId aid (userId profile)) return (Picked (userId profile)) n -> do return (PickPersonality profiles) (Just uid) -> return (Picked uid) (Left aids) -> return (PickAuthId aids) happstack-authenticate-0.10.7/Happstack/Auth/Blaze/0000755000000000000000000000000012226553112020272 5ustar0000000000000000happstack-authenticate-0.10.7/Happstack/Auth/Blaze/Templates.hs0000644000000000000000000007543512226553112022602 0ustar0000000000000000{-# 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) return $ H.div ! A.id "happstack-authenticate" $ 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 () 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 tag -- > -> Html -- ^ extra headers to add to the <head> tag -- > -> Html -- ^ contents to stick in the <body> tag handleAuth :: (Happstack m, MonadRoute m, URL m ~ AuthURL) => AcidState AuthState -- ^ database handle for 'AuthState' -> (String -> Html -> Html -> m Response) -- ^ page template function -> Maybe Credentials -- ^ config information for facebook connect -> Maybe Text -- ^ authentication realm -> Text -- ^ URL to redirect to after succesful authentication -> AuthURL -- ^ url to route -> m Response handleAuth authStateH appTemplate mFacebook realm onAuthURL url = case url of A_Login -> appTemplate "Login" mempty =<< loginPage mFacebook A_AddAuth -> appTemplate "Add Auth" mempty =<< addAuthPage mFacebook A_Logout -> appTemplate "Logout" mempty =<< logoutPage authStateH A_Local -> localLoginPage authStateH appTemplate url onAuthURL A_CreateAccount -> createAccountPage authStateH appTemplate onAuthURL url A_ChangePassword -> changePasswordPage authStateH appTemplate url (A_OpenId oidURL) -> do showFn <- askRouteFn unRouteT (nestURL A_OpenId $ handleOpenId authStateH realm onAuthURL oidURL) showFn (A_OpenIdProvider authMode provider) -> providerPage appTemplate provider url authMode (A_Facebook authMode) -> case mFacebook of Nothing -> do resp <- appTemplate "Facebook authentication not configured." mempty $ H.div ! A.id "happstack-authenticate" $ p "Facebook authentication not configured." internalServerError resp (Just facebook) -> facebookPage facebook authMode (A_FacebookRedirect authMode) -> case mFacebook of Nothing -> do resp <- appTemplate "Facebook authentication not configured." mempty $ H.div ! A.id "happstack-authenticate" $ p "Facebook authentication not configured." internalServerError resp (Just facebook) -> facebookRedirectPage authStateH facebook onAuthURL authMode -- | Function which takes care of all 'ProfileURL' 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 <title> tag -- > -> Html -- ^ extra headers to add to the <head> tag -- > -> Html -- ^ contents to stick in the <body> tag handleProfile :: (Happstack m, Alternative m, MonadRoute m, URL m ~ ProfileURL) => AcidState AuthState -- ^ database handle for 'AuthState' -> AcidState ProfileState -- ^ database handle for 'ProfileState' -> (String -> Html -> Html -> m Response) -- ^ page template function -> Text -- ^ URL to redirect to after successfully picking an identity -> ProfileURL -- ^ URL to route -> m Response handleProfile authStateH profileStateH appTemplate postPickedURL url = case url of P_PickProfile -> do r <- pickProfile authStateH profileStateH case r of (Picked {}) -> seeOther (Text.unpack postPickedURL) (toResponse postPickedURL) (PickPersonality profiles) -> appTemplate "Pick Personality" mempty =<< (personalityPicker profiles) (PickAuthId authIds) -> appTemplate "Pick Auth" mempty =<< (authPicker authIds) (P_SetAuthId authId) -> do b <- setAuthIdPage authStateH authId if b then seeOther ("/" :: String) (toResponse ()) -- FIXME: don't hardcode destination else do resp <- appTemplate "Unauthorized" mempty $ H.div ! A.id "happstack-authenticate" $ p $ do " Attempted to set AuthId to " toHtml $ show $ unAuthId authId ", but failed because the Identifier is not associated with that AuthId." unauthorized resp -- handleAuthProfile :: (Happstack m, Alternative m, MonadRoute m, URL m ~ AuthProfileURL) => authProfileSite :: (Happstack m) => AcidState AuthState -> AcidState ProfileState -> (String -> Html -> Html -> m Response) -> Maybe Credentials -> Maybe Text -> Text -> Site AuthProfileURL (m Response) authProfileSite acidAuth acidProfile appTemplate mFacebook realm postPickedURL = Site { handleSite = \f u -> unRouteT (handleAuthProfileRouteT acidAuth acidProfile appTemplate mFacebook realm postPickedURL u) f , formatPathSegments = \u -> (toPathSegments u, []) , parsePathSegments = parseSegments fromPathSegments } -- | this is a simple entry point into @happstack-authenticate@ that -- provides reasonable default behavior. A majority of the time you -- will just call this function. authProfileHandler :: (Happstack m) => Text -- ^ baseURI for this server part -> Text -- ^ unique path prefix -> AcidState AuthState -- ^ handle for 'AcidState AuthState' -> AcidState ProfileState -- ^ handle for 'AcidState ProfileState' -> (String -> Html -> Html -> m Response) -- ^ template function used to render pages -> Maybe Credentials -- ^ optional Facebook 'Credentials' -> Maybe Text -- ^ optional realm to use for @OpenId@ authentication -> Text -- ^ url to redirect to if authentication and profile selection is successful -> m Response authProfileHandler baseURI pathPrefix acidAuth acidProfile appTemplate mFacebook realm postPickedURL = do r <- implSite_ baseURI pathPrefix (authProfileSite acidAuth acidProfile appTemplate mFacebook realm postPickedURL) case r of (Left e) -> mzero (Right r) -> return r handleAuthProfile :: forall m. (Happstack m, MonadRoute m, URL m ~ AuthProfileURL) => AcidState AuthState -> AcidState ProfileState -> (String -> Html -> Html -> m Response) -> Maybe Credentials -> Maybe Text -> Text -> AuthProfileURL -> m Response handleAuthProfile authStateH profileStateH appTemplate mFacebook mRealm postPickedURL url = do routeFn <- askRouteFn unRouteT (handleAuthProfileRouteT authStateH profileStateH appTemplate mFacebook mRealm postPickedURL url) routeFn handleAuthProfileRouteT :: forall m. (Happstack m) => AcidState AuthState -> AcidState ProfileState -> (String -> Html -> Html -> m Response) -> Maybe Credentials -> Maybe Text -> Text -> AuthProfileURL -> RouteT AuthProfileURL m Response handleAuthProfileRouteT authStateH profileStateH appTemplate mFacebook mRealm postPickedURL url = case url of (AuthURL authURL) -> do onAuthURL <- showURL (ProfileURL P_PickProfile) let template t h b = liftRouteT (appTemplate t h b) nestURL AuthURL $ handleAuth authStateH template mFacebook mRealm onAuthURL authURL (ProfileURL profileURL) -> do let template t h b = liftRouteT (appTemplate t h b) nestURL ProfileURL $ handleProfile authStateH profileStateH template postPickedURL profileURL localLoginPage authStateH appTemplate here onAuthURL = do actionURL <- showURL here createURL <- showURL A_CreateAccount e <- happstackEitherForm (R.form actionURL) "lf" (loginForm createURL) case e of (Left errorForm) -> do r <- appTemplate "Login" mempty $ H.div ! A.id "happstack-authenticate" $ do h1 "Login" errorForm ok r (Right userPassId) -> do authId <- do authIds <- query' authStateH (UserPassIdAuthIds userPassId) case Set.size authIds of 1 -> return (Just $ head $ Set.toList $ authIds) n -> return Nothing addAuthCookie authStateH authId (AuthUserPassId userPassId) seeOther (Text.unpack onAuthURL) (toResponse ()) where loginForm createURL = divHorizontal $ fieldset $ (errorList ++> (((,) <$> (divControlGroup $ errorList ++> label' "username: " ++> divControls (inputText mempty)) <*> (divControlGroup $ errorList ++> label' "password: " ++> divControls (inputPassword)) <* divFormActions (inputSubmit' "Login")) `transformEitherM` checkAuth) <* (create createURL)) create createURL = view $ p $ do "or " H.a ! href (toValue createURL) $ "create a new account" checkAuth :: (MonadIO m) => (Text, Text) -> m (Either AuthTemplateError UserPassId) checkAuth (username, password) = do r <- query' authStateH (CheckUserPass username password) case r of (Left e) -> return (Left $ UPE e) (Right userPassId) -> return (Right userPassId) createAccountPage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) => AcidState AuthState -> (String -> Html -> Html -> m Response) -> Text -> AuthURL -> m Response createAccountPage authStateH appTemplate onAuthURL here = do actionURL <- showURL here e <- happstackEitherForm (R.form actionURL) "naf" (newAccountForm authStateH) case e of (Left formHtml) -> do r <- appTemplate "Create New Account" mempty $ H.div ! A.id "happstack-authenticate" $ do h1 "Create an account" formHtml ok r (Right (authId, userPassId)) -> do addAuthCookie authStateH (Just authId) (AuthUserPassId userPassId) seeOther (Text.unpack onAuthURL) (toResponse ()) newAccountForm :: (Functor v, MonadIO v) => AcidState AuthState -> AuthForm v (AuthId, UserPassId) newAccountForm authStateH = divHorizontal $ (R.fieldset (errorList ++> (((,) <$> username <*> password <* submitButton))) `transformEitherM` createAccount) where submitButton = divFormActions $ inputSubmit' "Create Account" username = divControlGroup $ errorList ++> ((label' "username: " ++> divControls (inputText mempty)) `transformEither` (minLength 1)) password1 = divControlGroup $ label' "password: " ++> divControls inputPassword password2 = divControlGroup $ label' "confirm password: " ++> divControls inputPassword password = errorList ++> (((,) <$> password1 <*> password2) `transformEither` samePassword) `transformEither` minLength 6 samePassword (p1, p2) = if p1 /= p2 then (Left $ PasswordMismatch) else (Right p1) createAccount (username, password) = do passHash <- liftIO $ mkHashedPass password r <- update' authStateH $ CreateUserPass (UserName username) passHash -- fixme: race condition case r of (Left e) -> return (Left $ UPE e) (Right userPass) -> do authId <- update' authStateH (NewAuthMethod (AuthUserPassId (upId userPass))) return (Right (authId, upId userPass)) changePasswordPage :: (Happstack m, MonadRoute m, URL m ~ AuthURL) => AcidState AuthState -> (String -> Html -> Html -> m Response) -> AuthURL -> m Response changePasswordPage authStateH appTemplate here = do actionURL <- showURL here mAuthToken <- getAuthToken authStateH case mAuthToken of Nothing -> seeOtherURL A_Login (Just authToken) -> case tokenAuthMethod authToken of (AuthUserPassId userPassId) -> do mUserPass <- query' authStateH (AskUserPass userPassId) case mUserPass of Nothing -> do resp <- appTemplate "Invalid UserPassId" mempty $ do H.div ! A.id "happstack-authenticate" $ p $ do "Invalid UserPassId" toHtml $ show $ unUserPassId userPassId internalServerError resp (Just userPass) -> do e <- happstackEitherForm (R.form actionURL) "cpf" (changePasswordForm authStateH userPass) case e of (Left formHtml) -> do r <- appTemplate "Change Passowrd" mempty $ H.div ! A.id "happstack-authenticate" $ do h1 $ do "Change password for " toHtml $ unUserName $ upName userPass formHtml ok r (Right passwd) -> do hashedPass <- liftIO $ mkHashedPass passwd r <- update' authStateH (SetPassword userPassId hashedPass) case r of (Just e) -> do resp <- appTemplate "Change Password Failed" mempty $ H.div ! A.id "happstack-authenticate" $ p $ toHtml (userPassErrorString e) internalServerError resp Nothing -> do resp <- appTemplate "Password Changed!" mempty $ H.div ! A.id "happstack-authenticate" $ p $ "Your password has been updated." ok resp changePasswordForm :: (Functor v, MonadIO v) => AcidState AuthState -> UserPass -> AuthForm v Text changePasswordForm authStateH userPass = divHorizontal $ fieldset $ oldPassword *> newPassword <* changeBtn where -- form elements oldPassword = errorList ++> (divControlGroup $ label' "old password: " ++> divControls inputPassword) `transformEitherM` checkAuth checkAuth password = do r <- query' authStateH (CheckUserPass (unUserName $ upName userPass) password) case r of (Left e) -> return (Left $ UPE e) (Right _) -> return (Right password) password1, password2 :: (Functor v, MonadIO v) => AuthForm v Text password1 = divControlGroup $ label' "new password: " ++> divControls inputPassword password2 = divControlGroup $ label' "new confirm password: " ++> divControls inputPassword newPassword :: (Functor v, MonadIO v) => AuthForm v Text newPassword = errorList ++> (((((,) <$> password1 <*> password2)) `transformEither` samePassword) `transformEither` minLength 6) samePassword :: (Text, Text) -> Either AuthTemplateError Text samePassword (p1, p2) = if p1 /= p2 then (Left $ PasswordMismatch) else (Right p1) changeBtn :: (Functor v, MonadIO v) => AuthForm v (Maybe Text) changeBtn = divFormActions $ inputSubmit' "change" -- li $ mapView (\html -> html ! A.class_ "submit") $ inputSubmit "change" minLength :: Int -> Text -> Either AuthTemplateError Text minLength n s = if Text.length s >= n then (Right s) else (Left $ MinLength n) divControlGroup :: (Functor m, MonadIO m) => AuthForm m a -> AuthForm m a divControlGroup = mapView (\html -> H.div ! class_ "control-group" $ html) divControls :: (Functor m, MonadIO m) => AuthForm m a -> AuthForm m a divControls = mapView (\html -> H.div ! class_ "controls" $ html) label' :: (Functor m, MonadIO m) => String -> AuthForm m () label' str = mapView (\html -> html ! class_"control-label") (R.label str) divHorizontal :: (Functor m, MonadIO m) => AuthForm m a -> AuthForm m a divHorizontal = mapView (\html -> H.div ! class_ "form-horizontal" $ html) divInline :: (Functor m, MonadIO m) => AuthForm m a -> AuthForm m a divInline = mapView (\html -> H.div ! class_ "form-inline" $ html) divFormActions :: (Functor m, MonadIO m) => AuthForm m a -> AuthForm m a divFormActions = mapView (\html -> H.div ! class_ "form-actions" $ html) inputSubmit' :: (Functor m, MonadIO m) => Text -> AuthForm m (Maybe Text) inputSubmit' str = mapView (\html -> html ! class_ "btn") (R.inputSubmit str) {- inputSubmit' str = inputSubmit str `setAttrs` [("class":="btn")] inputCheckboxLabel lbl b = mapView (\xml -> [<label class="checkbox"><% xml %><% lbl %></label>]) (inputCheckbox b) label' str = (label str `setAttrs` [("class":="control-label")]) labelCB str = label str `setAttrs` [("class":="checkbox")] -- divInline = mapView (\xml -> [<div class="checkbox inline"><% xml %></div>]) divFormActions = mapView (\xml -> [<div class="form-actions"><% xml %></div>]) divHorizontal = mapView (\xml -> [<div class="form-horizontal"><% xml %></div>]) divControlGroup = mapView (\xml -> [<div class="control-group"><% xml %></div>]) divControls = mapView (\xml -> [<div class="controls"><% xml %></div>]) -}���������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������������