happstack-authenticate-2.3.4.6/0000755000000000000000000000000012777524361014522 5ustar0000000000000000happstack-authenticate-2.3.4.6/happstack-authenticate.cabal0000644000000000000000000001060012777524361022135 0ustar0000000000000000Name: happstack-authenticate Version: 2.3.4.6 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-2015 SeeReason Partners, LLC Category: Web Build-type: Simple Cabal-version: >=1.8 tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.1 data-files: messages/core/en.msg messages/openid/error/en.msg messages/openid/partials/en.msg messages/password/error/en.msg messages/password/partials/en.msg source-repository head type: git location: https://github.com/Happstack/happstack-authenticate.git Library Exposed-modules: Happstack.Authenticate.Core Happstack.Authenticate.Controller Happstack.Authenticate.Route Happstack.Authenticate.Password.Controllers Happstack.Authenticate.Password.Core Happstack.Authenticate.Password.Partials Happstack.Authenticate.Password.PartialsURL Happstack.Authenticate.Password.Route Happstack.Authenticate.Password.URL Happstack.Authenticate.OpenId.Controllers Happstack.Authenticate.OpenId.Core Happstack.Authenticate.OpenId.Partials Happstack.Authenticate.OpenId.PartialsURL Happstack.Authenticate.OpenId.Route Happstack.Authenticate.OpenId.URL Build-depends: base > 4 && < 5, acid-state >= 0.6 && < 0.15, aeson (>= 0.4 && < 0.10) || (>= 0.11 && < 1.1), authenticate == 1.3.*, base64-bytestring >= 1.0 && < 1.1, boomerang >= 1.4 && < 1.5, bytestring >= 0.9 && < 0.11, containers >= 0.4 && < 0.6, data-default >= 0.5 && < 0.8, email-validate >= 2.1 && < 2.3, filepath >= 1.3 && < 1.5, hsx2hs >= 0.13 && < 0.15, jmacro >= 0.6.11 && < 0.7, jwt >= 0.3 && < 0.8, ixset-typed >= 0.3 && < 0.4, happstack-jmacro >= 7.0 && < 7.1, happstack-server >= 6.0 && < 7.5, happstack-hsp >= 7.3 && < 7.4, http-conduit >= 1.4 && < 2.3, http-types >= 0.6 && < 0.10, hsp >= 0.10 && < 0.11, hsx-jmacro >= 7.3 && < 7.4, safecopy >= 0.8 && < 0.10, mime-mail >= 0.4 && < 0.5, mtl >= 2.0 && < 2.3, lens >= 4.2 && < 4.16, pwstore-purehaskell == 2.1.*, text >= 0.11 && < 1.3, time >= 1.2 && < 1.7, userid >= 0.1 && < 0.2, random >= 1.0 && < 1.2, shakespeare >= 2.0 && < 2.1, unordered-containers == 0.2.*, web-routes >= 0.26 && < 0.28, web-routes-boomerang >= 0.28 && < 0.29, web-routes-happstack == 0.23.*, web-routes-th >= 0.22 && < 0.23, web-routes-hsp >= 0.24 && < 0.25happstack-authenticate-2.3.4.6/LICENSE0000644000000000000000000000300512777524361015525 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-2.3.4.6/Setup.hs0000644000000000000000000000005612777524361016157 0ustar0000000000000000import Distribution.Simple main = defaultMain happstack-authenticate-2.3.4.6/Happstack/0000755000000000000000000000000012777524361016440 5ustar0000000000000000happstack-authenticate-2.3.4.6/Happstack/Authenticate/0000755000000000000000000000000012777524361021056 5ustar0000000000000000happstack-authenticate-2.3.4.6/Happstack/Authenticate/Controller.hs0000644000000000000000000001142012777524361023533 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Happstack.Authenticate.Controller where import Data.Text (Text) import qualified Data.Text as T import Happstack.Authenticate.Core (AuthenticateURL) import Language.Javascript.JMacro import Web.Routes (RouteT, askRouteFn) authenticateCtrl :: (Monad m) => RouteT AuthenticateURL m JStat authenticateCtrl = do fn <- askRouteFn return $ authenticateCtrlJs fn authenticateCtrlJs :: (AuthenticateURL -> [(Text, Maybe Text)] -> Text) -> JStat authenticateCtrlJs showURL = [jmacro| { //this is used to parse the profile function url_base64_decode(str) { var output = str.replace('-', '+').replace('_', '/'); switch (output.length % 4) { case 0: break; case 2: output += '=='; break; case 3: output += '='; break; default: throw 'Illegal base64url string!'; } return window.atob(output); //polifyll https://github.com/davidchambers/Base64.js } // declare happstackAuthentication module var happstackAuthentication = angular.module('happstackAuthentication', []); // add controller happstackAuthentication.controller('AuthenticationCtrl', ['$scope', 'userService', function ($scope, userService) { $scope.isAuthenticated = userService.getUser().isAuthenticated; $scope.$watch(function () { return userService.getUser().isAuthenticated; }, function(newVal, oldVal) { $scope.isAuthenticated = newVal; }); $scope.claims = userService.getUser().claims; $scope.$watch(function () { return userService.getUser().claims; }, function(newVal, oldVal) { $scope.claims = newVal; } ); $scope.logout = function () { userService.clearUser(); document.cookie = 'atc=; path=/; expires=Thu, 01-Jan-70 00:00:01 GMT;'; }; }]); happstackAuthentication.factory('authInterceptor', ['$rootScope', '$q', '$window', 'userService', function ($rootScope, $q, $window, userService) { return { 'request': function (config) { config.headers = config.headers || {}; u = userService.getUser(); if (u && u.token) { config.headers.Authorization = 'Bearer ' + u.token; } return config; }, 'responseError': function (rejection) { if (rejection.status === 401) { // handle the case where the user is not authenticated userService.clearUser(); document.cookie = 'atc=; path=/; expires=Thu, 01-Jan-70 00:00:01 GMT;'; } return $q.reject(rejection); } }; }]); happstackAuthentication.config(['$httpProvider', function ($httpProvider) { $httpProvider.interceptors.push('authInterceptor'); }]); // add userService happstackAuthentication.factory('userService', ['$rootScope', function ($rootScope) { var service = { userCache: null, userCacheInit: function () { var item = localStorage.getItem('user'); if (item) { // alert('getUser: ' + item); this.setUser(JSON.parse(item)); } else { // alert('no user saved.'); service.clearUser(); } }, updateFromToken: function (token) { var encodedClaims = token.split('.')[1]; var claims = JSON.parse(url_base64_decode(encodedClaims)); u = this.getUser(); u.isAuthenticated = true; u.token = token; u.claims = claims; // alert(JSON.stringify(u)); this.setUser(u); return(u); }, setUser: function(u) { // alert('setUser:' + JSON.stringify(u)); this.userCache = u; localStorage.setItem('user', JSON.stringify(u)); }, getUser: function() { function getCookie(cname) { var name = cname + "="; var ca = document.cookie.split(';'); for(var i=0; i), optional) import Control.Category ((.), id) import Control.Exception (SomeException) import qualified Control.Exception as E import Control.Lens ((?=), (.=), (^.), (.~), makeLenses, view, set) import Control.Lens.At (IxValue(..), Ixed(..), Index(..), At(at)) import Control.Monad.Trans (MonadIO(liftIO)) import Control.Monad.Reader (ask) import Control.Monad.State (get, put, modify) import Data.Aeson (FromJSON(..), ToJSON(..), Result(..), fromJSON) import qualified Data.Aeson as A import Data.Aeson.Types (Options(fieldLabelModifier), defaultOptions, genericToJSON, genericParseJSON) import Data.Acid (AcidState, Update, Query, makeAcidic) import Data.Acid.Advanced (update', query') import Data.ByteString.Base64 (encode) import qualified Data.ByteString.Char8 as B import Data.Data (Data, Typeable) import Data.Default (def) import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, maybeToList) import Data.Monoid ((<>), mconcat) import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) import Data.IxSet.Typed import qualified Data.IxSet.Typed as IxSet import Data.Set (Set) import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text import Data.Time (UTCTime, addUTCTime, diffUTCTime, getCurrentTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime) import Data.UserId (UserId(..), rUserId, succUserId, unUserId) import GHC.Generics (Generic) import Happstack.Server (Cookie(secure), CookieLife(Session, MaxAge), Happstack, ServerPartT, Request(rqSecure), Response, addCookie, askRq, expireCookie, getHeaderM, lookCookie, lookCookieValue, mkCookie, notFound, toResponseBS) -- import Happstack.Server.Internal.Clock (getApproximateUTCTime) import Language.Javascript.JMacro import Prelude hiding ((.), id, exp) import System.IO (IOMode(ReadMode), withFile) import System.Random (randomRIO) import Text.Boomerang.TH (makeBoomerangs) import Text.Shakespeare.I18N (RenderMessage(renderMessage), mkMessageFor) import Web.JWT (Algorithm(HS256), JWT, VerifiedJWT, JWTClaimsSet(..), encodeSigned, claims, decode, decodeAndVerifySignature, secondsSinceEpoch, intDate, secret, verify) import Web.Routes (RouteT, PathInfo(..), nestURL) import Web.Routes.Boomerang import Web.Routes.Happstack () import Web.Routes.TH (derivePathInfo) -- | when creating JSON field names, drop the first character. Since -- we are using lens, the leading character should always be _. jsonOptions :: Options jsonOptions = defaultOptions { fieldLabelModifier = drop 1 } data HappstackAuthenticateI18N = HappstackAuthenticateI18N ------------------------------------------------------------------------------ -- CoreError ------------------------------------------------------------------------------ -- | the `CoreError` type is used to represent errors in a language -- agnostic manner. The errors are translated into human readable form -- via the I18N translations. data CoreError = HandlerNotFound -- AuthenticationMethod | URLDecodeFailed | UsernameAlreadyExists | AuthorizationRequired | Forbidden | JSONDecodeFailed | InvalidUserId | UsernameNotAcceptable | InvalidEmail | TextError Text deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) instance ToJSON CoreError where toJSON = genericToJSON jsonOptions instance FromJSON CoreError where parseJSON = genericParseJSON jsonOptions instance ToJExpr CoreError where toJExpr = toJExpr . toJSON deriveSafeCopy 0 'base ''CoreError mkMessageFor "HappstackAuthenticateI18N" "CoreError" "messages/core" ("en") data Status = Ok | NotOk deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) deriveSafeCopy 1 'base ''Status -- makeLenses ''Status makeBoomerangs ''Status instance ToJSON Status where toJSON = genericToJSON jsonOptions instance FromJSON Status where parseJSON = genericParseJSON jsonOptions data JSONResponse = JSONResponse { _jrStatus :: Status , _jrData :: A.Value } deriving (Eq, Read, Show, Data, Typeable, Generic) -- deriveSafeCopy 1 'base ''JSONResponse makeLenses ''JSONResponse makeBoomerangs ''JSONResponse instance ToJSON JSONResponse where toJSON = genericToJSON jsonOptions instance FromJSON JSONResponse where parseJSON = genericParseJSON jsonOptions -- | convert a value to a JSON encoded 'Response' toJSONResponse :: (RenderMessage HappstackAuthenticateI18N e, ToJSON a) => Either e a -> Response toJSONResponse (Left e) = toJSONError e toJSONResponse (Right a) = toJSONSuccess a -- | convert a value to a JSON encoded 'Response' toJSONSuccess :: (ToJSON a) => a -> Response toJSONSuccess a = toResponseBS "application/json" (A.encode (JSONResponse Ok (A.toJSON a))) -- | convert an error to a JSON encoded 'Response' -- -- FIXME: I18N toJSONError :: forall e. (RenderMessage HappstackAuthenticateI18N e) => e -> Response toJSONError e = toResponseBS "application/json" (A.encode (JSONResponse NotOk (A.toJSON (renderMessage HappstackAuthenticateI18N ["en"] e)))) -- (A.encode (A.object ["error" A..= renderMessage HappstackAuthenticateI18N ["en"] e])) ------------------------------------------------------------------------------ ------------------------------------------------------------------------------ -- UserId ------------------------------------------------------------------------------ {- -- | a 'UserId' uniquely identifies a user. newtype UserId = UserId { _unUserId :: Integer } deriving (Eq, Ord, Enum, Read, Show, Data, Typeable, Generic) deriveSafeCopy 1 'base ''UserId makeLenses ''UserId makeBoomerangs ''UserId instance ToJSON UserId where toJSON (UserId i) = toJSON i instance FromJSON UserId where parseJSON v = UserId <$> parseJSON v instance PathInfo UserId where toPathSegments (UserId i) = toPathSegments i fromPathSegments = UserId <$> fromPathSegments -- | get the next `UserId` succUserId :: UserId -> UserId succUserId (UserId i) = UserId (succ i) -} ------------------------------------------------------------------------------ -- Username ------------------------------------------------------------------------------ -- | an arbitrary, but unique string that the user uses to identify themselves newtype Username = Username { _unUsername :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) deriveSafeCopy 1 'base ''Username makeLenses ''Username makeBoomerangs ''Username instance ToJSON Username where toJSON (Username i) = toJSON i instance FromJSON Username where parseJSON v = Username <$> parseJSON v instance PathInfo Username where toPathSegments (Username t) = toPathSegments t fromPathSegments = Username <$> fromPathSegments ------------------------------------------------------------------------------ -- Email ------------------------------------------------------------------------------ -- | an `Email` address. No validation in performed. newtype Email = Email { _unEmail :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) deriveSafeCopy 1 'base ''Email makeLenses ''Email instance ToJSON Email where toJSON (Email i) = toJSON i instance FromJSON Email where parseJSON v = Email <$> parseJSON v instance PathInfo Email where toPathSegments (Email t) = toPathSegments t fromPathSegments = Email <$> fromPathSegments ------------------------------------------------------------------------------ -- User ------------------------------------------------------------------------------ -- | A unique 'User' data User = User { _userId :: UserId , _username :: Username , _email :: Maybe Email } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) deriveSafeCopy 1 'base ''User makeLenses ''User instance ToJSON User where toJSON = genericToJSON jsonOptions instance FromJSON User where parseJSON = genericParseJSON jsonOptions type UserIxs = '[UserId, Username, Email] type IxUser = IxSet UserIxs User instance Indexable UserIxs User where indices = ixList (ixFun $ (:[]) . view userId) (ixFun $ (:[]) . view username) (ixFun $ maybeToList . view email) ------------------------------------------------------------------------------ -- AuthenticateConfig ------------------------------------------------------------------------------ -- | Various configuration options that apply to all authentication methods data AuthenticateConfig = AuthenticateConfig { _isAuthAdmin :: UserId -> IO Bool -- ^ can user administrate the authentication system? , _usernameAcceptable :: Username -> Maybe CoreError -- ^ enforce username policies, valid email, etc. 'Nothing' == ok, 'Just Text' == error message , _requireEmail :: Bool } deriving (Typeable, Generic) makeLenses ''AuthenticateConfig -- | a very basic policy for 'userAcceptable' -- -- Enforces: -- -- 'Username' can not be empty usernamePolicy :: Username -> Maybe CoreError usernamePolicy username = if Text.null $ username ^. unUsername then Just UsernameNotAcceptable else Nothing ------------------------------------------------------------------------------ -- SharedSecret ------------------------------------------------------------------------------ -- | The shared secret is used to encrypt a users data on a per-user basis. -- We can invalidate a JWT value by changing the shared secret. newtype SharedSecret = SharedSecret { _unSharedSecret :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) deriveSafeCopy 1 'base ''SharedSecret makeLenses ''SharedSecret -- | Generate a 'Salt' from 128 bits of data from @\/dev\/urandom@, with the -- system RNG as a fallback. This is the function used to generate salts by -- 'makePassword'. genSharedSecret :: (MonadIO m) => m SharedSecret genSharedSecret = liftIO $ E.catch genSharedSecretDevURandom (\(_::SomeException) -> genSharedSecretSysRandom) -- | Generate a 'SharedSecret' from @\/dev\/urandom@. -- -- see: `genSharedSecret` genSharedSecretDevURandom :: IO SharedSecret genSharedSecretDevURandom = withFile "/dev/urandom" ReadMode $ \h -> do secret <- B.hGet h 32 return $ SharedSecret . Text.decodeUtf8 . encode $ secret -- | Generate a 'SharedSecret' from 'System.Random'. -- -- see: `genSharedSecret` genSharedSecretSysRandom :: IO SharedSecret genSharedSecretSysRandom = randomChars >>= return . SharedSecret . Text.decodeUtf8 . encode . B.pack where randomChars = sequence $ replicate 32 $ randomRIO ('\NUL', '\255') ------------------------------------------------------------------------------ -- SharedSecrets ------------------------------------------------------------------------------ -- | A map which stores the `SharedSecret` for each `UserId` type SharedSecrets = Map UserId SharedSecret -- | An empty `SharedSecrets` initialSharedSecrets :: SharedSecrets initialSharedSecrets = Map.empty ------------------------------------------------------------------------------ -- NewAccountMode ------------------------------------------------------------------------------ -- | This value is used to configure the type of new user registrations -- permitted for this system. data NewAccountMode = OpenRegistration -- ^ new users can create their own accounts | ModeratedRegistration -- ^ new users can apply to create their own accounts, but a moderator must approve them before they are active | ClosedRegistration -- ^ only the admin can create a new account deriving (Eq, Show, Typeable, Generic) deriveSafeCopy 1 'base ''NewAccountMode ------------------------------------------------------------------------------ -- AuthenticateState ------------------------------------------------------------------------------ -- | this acid-state value contains the state common to all -- authentication methods data AuthenticateState = AuthenticateState { _sharedSecrets :: SharedSecrets , _users :: IxUser , _nextUserId :: UserId , _defaultSessionTimeout :: Int -- ^ default session time out in seconds , _newAccountMode :: NewAccountMode } deriving (Eq, Show, Typeable, Generic) deriveSafeCopy 1 'base ''AuthenticateState makeLenses ''AuthenticateState -- | a reasonable initial 'AuthenticateState' initialAuthenticateState :: AuthenticateState initialAuthenticateState = AuthenticateState { _sharedSecrets = initialSharedSecrets , _users = IxSet.empty , _nextUserId = UserId 1 , _defaultSessionTimeout = 60*60 , _newAccountMode = OpenRegistration } ------------------------------------------------------------------------------ -- SharedSecrets AcidState Methods ------------------------------------------------------------------------------ -- | set the 'SharedSecret' for 'UserId' overwritten any previous secret. setSharedSecret :: UserId -> SharedSecret -> Update AuthenticateState () setSharedSecret userId sharedSecret = sharedSecrets . at userId ?= sharedSecret -- | get the 'SharedSecret' for 'UserId' getSharedSecret :: UserId -> Query AuthenticateState (Maybe SharedSecret) getSharedSecret userId = view (sharedSecrets . at userId) ------------------------------------------------------------------------------ -- SessionTimeout AcidState Methods ------------------------------------------------------------------------------ -- | set the default inactivity timeout for new sessions setDefaultSessionTimeout :: Int -- ^ default timout in seconds (should be >= 180) -> Update AuthenticateState () setDefaultSessionTimeout newTimeout = modify $ \as@AuthenticateState{..} -> as { _defaultSessionTimeout = newTimeout } -- | set the default inactivity timeout for new sessions getDefaultSessionTimeout :: Query AuthenticateState Int getDefaultSessionTimeout = view defaultSessionTimeout <$> ask ------------------------------------------------------------------------------ -- NewAccountMode AcidState Methods ------------------------------------------------------------------------------ -- | set the 'NewAccountMode' setNewAccountMode :: NewAccountMode -> Update AuthenticateState () setNewAccountMode mode = newAccountMode .= mode -- | get the 'NewAccountMode' getNewAccountMode :: Query AuthenticateState NewAccountMode getNewAccountMode = view newAccountMode ------------------------------------------------------------------------------ -- User related AcidState Methods ------------------------------------------------------------------------------ -- | Create a new 'User'. This will allocate a new 'UserId'. The -- returned 'User' value will have the updated 'UserId'. createUser :: User -> Update AuthenticateState (Either CoreError User) createUser u = do as@AuthenticateState{..} <- get if IxSet.null $ (as ^. users) @= (u ^. username) then do let user' = set userId _nextUserId u as' = as { _users = IxSet.insert user' _users , _nextUserId = succ _nextUserId } put as' return (Right user') else return (Left UsernameAlreadyExists) -- | Create a new 'User'. This will allocate a new 'UserId'. The -- returned 'User' value will have the updated 'UserId'. createAnonymousUser :: Update AuthenticateState User createAnonymousUser = do as@AuthenticateState{..} <- get let user = User { _userId = _nextUserId , _username = Username ("Anonymous " <> Text.pack (show _nextUserId)) , _email = Nothing } as' = as { _users = IxSet.insert user _users , _nextUserId = succ _nextUserId } put as' return user -- | Update an existing 'User'. Must already have a valid 'UserId'. updateUser :: User -> Update AuthenticateState () updateUser u = do as@AuthenticateState{..} <- get let as' = as { _users = IxSet.updateIx (u ^. userId) u _users } put as' -- | Delete 'User' with the specified 'UserId' deleteUser :: UserId -> Update AuthenticateState () deleteUser uid = do as@AuthenticateState{..} <- get let as' = as { _users = IxSet.deleteIx uid _users } put as' -- | look up a 'User' by their 'Username' getUserByUsername :: Username -> Query AuthenticateState (Maybe User) getUserByUsername username = do us <- view users return $ getOne $ us @= username -- | look up a 'User' by their 'UserId' getUserByUserId :: UserId -> Query AuthenticateState (Maybe User) getUserByUserId userId = do us <- view users return $ getOne $ us @= userId -- | look up a 'User' by their 'Email' -- -- NOTE: if the email is associated with more than one account this will return 'Nothing' getUserByEmail :: Email -> Query AuthenticateState (Maybe User) getUserByEmail email = do us <- view users return $ getOne $ us @= email -- | get the entire AuthenticateState value getAuthenticateState :: Query AuthenticateState AuthenticateState getAuthenticateState = ask makeAcidic ''AuthenticateState [ 'setDefaultSessionTimeout , 'getDefaultSessionTimeout , 'setSharedSecret , 'getSharedSecret , 'setNewAccountMode , 'getNewAccountMode , 'createUser , 'createAnonymousUser , 'updateUser , 'deleteUser , 'getUserByUsername , 'getUserByUserId , 'getUserByEmail , 'getAuthenticateState ] ------------------------------------------------------------------------------ -- Shared Secret Functions ------------------------------------------------------------------------------ -- | get the 'SharedSecret' for 'UserId'. Generate one if they don't have one yet. getOrGenSharedSecret :: (MonadIO m) => AcidState AuthenticateState -> UserId -> m (SharedSecret) getOrGenSharedSecret authenticateState uid = do mSSecret <- query' authenticateState (GetSharedSecret uid) case mSSecret of (Just ssecret) -> return ssecret Nothing -> do ssecret <- genSharedSecret update' authenticateState (SetSharedSecret uid ssecret) return ssecret ------------------------------------------------------------------------------ -- Token Functions ------------------------------------------------------------------------------ -- | The `Token` type represents the encrypted data used to identify a -- user. data Token = Token { _tokenUser :: User , _tokenIsAuthAdmin :: Bool } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) makeLenses ''Token instance ToJSON Token where toJSON = genericToJSON jsonOptions instance FromJSON Token where parseJSON = genericParseJSON jsonOptions -- | `TokenText` is the encrypted form of the `Token` which is passed -- between the server and the client. type TokenText = Text -- | create a `Token` for `User` -- -- The @isAuthAdmin@ paramater is a function which will be called to -- determine if `UserId` is a user who should be given Administrator -- privileges. This includes the ability to things such as set the -- `OpenId` realm, change the registeration mode, etc. issueToken :: (MonadIO m) => AcidState AuthenticateState -> AuthenticateConfig -> User -- ^ the user -> m TokenText issueToken authenticateState authenticateConfig user = do ssecret <- getOrGenSharedSecret authenticateState (user ^. userId) admin <- liftIO $ (authenticateConfig ^. isAuthAdmin) (user ^. userId) now <- liftIO getCurrentTime let claims = def { exp = intDate $ utcTimeToPOSIXSeconds (addUTCTime (60*60*24*30) now) , unregisteredClaims = Map.fromList [ ("user" , toJSON user) , ("authAdmin", toJSON admin) ] } return $ encodeSigned HS256 (secret $ _unSharedSecret ssecret) claims -- | decode and verify the `TokenText`. If successful, return the -- `Token` otherwise `Nothing`. decodeAndVerifyToken :: (MonadIO m) => AcidState AuthenticateState -> UTCTime -> TokenText -> m (Maybe (Token, JWT VerifiedJWT)) decodeAndVerifyToken authenticateState now token = do -- decode unverified token let mUnverified = decode token case mUnverified of Nothing -> return Nothing (Just unverified) -> -- check that token has user claim case Map.lookup "user" (unregisteredClaims (claims unverified)) of Nothing -> return Nothing (Just uv) -> -- decode user json value case fromJSON uv of (Error _) -> return Nothing (Success u) -> do -- get the shared secret for userId mssecret <- query' authenticateState (GetSharedSecret (u ^. userId)) case mssecret of Nothing -> return Nothing (Just ssecret) -> -- finally we can verify all the claims case verify (secret (_unSharedSecret ssecret)) unverified of Nothing -> return Nothing (Just verified) -> -- check expiration case exp (claims verified) of -- exp field missing, expire now Nothing -> return Nothing (Just exp') -> if (utcTimeToPOSIXSeconds now) > (secondsSinceEpoch exp') then return Nothing else case Map.lookup "authAdmin" (unregisteredClaims (claims verified)) of Nothing -> return (Just (Token u False, verified)) (Just a) -> case fromJSON a of (Error _) -> return (Just (Token u False, verified)) (Success b) -> return (Just (Token u b, verified)) ------------------------------------------------------------------------------ -- Token in a Cookie ------------------------------------------------------------------------------ -- | name of the `Cookie` used to hold the `TokenText` authCookieName :: String authCookieName = "atc" -- | create a `Token` for `User` and add a `Cookie` to the `Response` -- -- see also: `issueToken` addTokenCookie :: (Happstack m) => AcidState AuthenticateState -> AuthenticateConfig -> User -> m TokenText addTokenCookie authenticateState authenticateConfig user = do token <- issueToken authenticateState authenticateConfig user s <- rqSecure <$> askRq -- FIXME: this isn't that accurate in the face of proxies addCookie (MaxAge (60*60*24*30)) ((mkCookie authCookieName (Text.unpack token)) { secure = s }) -- addCookie (MaxAge 60) ((mkCookie authCookieName (Text.unpack token)) { secure = s }) return token -- | delete the `Token` `Cookie` deleteTokenCookie :: (Happstack m) => m () deleteTokenCookie = expireCookie authCookieName -- | get, decode, and verify the `Token` from the `Cookie`. getTokenCookie :: (Happstack m) => AcidState AuthenticateState -> m (Maybe (Token, JWT VerifiedJWT)) getTokenCookie authenticateState = do mToken <- optional $ lookCookieValue authCookieName case mToken of Nothing -> return Nothing (Just token) -> do now <- liftIO getCurrentTime decodeAndVerifyToken authenticateState now (Text.pack token) ------------------------------------------------------------------------------ -- Token in a Header ------------------------------------------------------------------------------ -- | get, decode, and verify the `Token` from the @Authorization@ HTTP header getTokenHeader :: (Happstack m) => AcidState AuthenticateState -> m (Maybe (Token, JWT VerifiedJWT)) getTokenHeader authenticateState = do mAuth <- getHeaderM "Authorization" case mAuth of Nothing -> return Nothing (Just auth') -> do let auth = B.drop 7 auth' now <- liftIO getCurrentTime decodeAndVerifyToken authenticateState now (Text.decodeUtf8 auth) ------------------------------------------------------------------------------ -- Token in a Header or Cookie ------------------------------------------------------------------------------ -- | get, decode, and verify the `Token` looking first in the -- @Authorization@ header and then in `Cookie`. -- -- see also: `getTokenHeader`, `getTokenCookie` getToken :: (Happstack m) => AcidState AuthenticateState -> m (Maybe (Token, JWT VerifiedJWT)) getToken authenticateState = do mToken <- getTokenHeader authenticateState case mToken of Nothing -> getTokenCookie authenticateState (Just token) -> return (Just token) ------------------------------------------------------------------------------ -- helper function: calls `getToken` but only returns the `UserId` ------------------------------------------------------------------------------ -- | get the `UserId` -- -- calls `getToken` but returns only the `UserId` getUserId :: (Happstack m) => AcidState AuthenticateState -> m (Maybe UserId) getUserId authenticateState = do mToken <- getToken authenticateState case mToken of Nothing -> return Nothing (Just (token, _)) -> return $ Just (token ^. tokenUser ^. userId) ------------------------------------------------------------------------------ -- AuthenticationMethod ------------------------------------------------------------------------------ -- | `AuthenticationMethod` is used by the routing system to select which -- authentication backend should handle this request. newtype AuthenticationMethod = AuthenticationMethod { _unAuthenticationMethod :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) derivePathInfo ''AuthenticationMethod deriveSafeCopy 1 'base ''AuthenticationMethod makeLenses ''AuthenticationMethod makeBoomerangs ''AuthenticationMethod instance ToJSON AuthenticationMethod where toJSON (AuthenticationMethod method) = toJSON method instance FromJSON AuthenticationMethod where parseJSON v = AuthenticationMethod <$> parseJSON v type AuthenticationHandler = [Text] -> RouteT AuthenticateURL (ServerPartT IO) Response type AuthenticationHandlers = Map AuthenticationMethod AuthenticationHandler ------------------------------------------------------------------------------ -- AuthenticationURL ------------------------------------------------------------------------------ data AuthenticateURL = -- Users (Maybe UserId) AuthenticationMethods (Maybe (AuthenticationMethod, [Text])) | Controllers deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) makeBoomerangs ''AuthenticateURL -- | a `Router` for `AuthenicateURL` authenticateURL :: Router () (AuthenticateURL :- ()) authenticateURL = ( -- "users" ( rUsers . rMaybe userId ) "authentication-methods" ( rAuthenticationMethods . rMaybe authenticationMethod) <> "controllers" . rControllers ) where userId = rUserId . integer authenticationMethod = rPair . (rAuthenticationMethod . anyText) (rListSep anyText eos) instance PathInfo AuthenticateURL where fromPathSegments = boomerangFromPathSegments authenticateURL toPathSegments = boomerangToPathSegments authenticateURL -- | helper function which converts a URL for an authentication -- backend into an `AuthenticateURL`. nestAuthenticationMethod :: (PathInfo methodURL) => AuthenticationMethod -> RouteT methodURL m a -> RouteT AuthenticateURL m a nestAuthenticationMethod authenticationMethod = nestURL $ \methodURL -> AuthenticationMethods $ Just (authenticationMethod, toPathSegments methodURL) happstack-authenticate-2.3.4.6/Happstack/Authenticate/Route.hs0000644000000000000000000000655612777524361022524 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} module Happstack.Authenticate.Route where import Control.Applicative ((<$>)) import Control.Monad.Trans (MonadIO(liftIO)) import Data.Acid (AcidState) import Data.Acid.Local (openLocalStateFrom, createCheckpointAndClose) import qualified Data.Map as Map (fromList, lookup) import Data.Maybe (fromMaybe, Maybe(..)) import Data.Monoid (mconcat) import Data.Traversable (sequence) import Data.Unique (hashUnique, newUnique) import Data.UserId (UserId) import HSP.JMacro (IntegerSupply(..)) import Happstack.Authenticate.Controller (authenticateCtrl) import Happstack.Authenticate.Core (AuthenticateConfig, AuthenticateState, AuthenticateURL(..), AuthenticationHandler, AuthenticationHandlers, AuthenticationMethod, CoreError(HandlerNotFound), initialAuthenticateState, toJSONError) import Happstack.Server (notFound, ok, Response, ServerPartT, ToMessage(toResponse)) import Happstack.Server.JMacro () import Language.Javascript.JMacro (JStat) import Prelude (($), (.), Bool(True), FilePath, fromIntegral, Functor(..), Integral(mod), IO, map, mapM, Monad(return), sequence_, unzip3) import Prelude hiding (sequence) import System.FilePath (combine) import Web.Routes (RouteT) ------------------------------------------------------------------------------ -- route ------------------------------------------------------------------------------ route :: [RouteT AuthenticateURL (ServerPartT IO) JStat] -> AuthenticationHandlers -> AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response route controllers authenticationHandlers url = do case url of (AuthenticationMethods (Just (authenticationMethod, pathInfo))) -> case Map.lookup authenticationMethod authenticationHandlers of (Just handler) -> handler pathInfo Nothing -> notFound $ toJSONError (HandlerNotFound {- authenticationMethod-} ) --FIXME Controllers -> do js <- sequence (authenticateCtrl:controllers) ok $ toResponse (mconcat js) ------------------------------------------------------------------------------ -- initAuthenticate ------------------------------------------------------------------------------ initAuthentication :: Maybe FilePath -> AuthenticateConfig -> [FilePath -> AcidState AuthenticateState -> AuthenticateConfig -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat)] -> IO (IO (), AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response, AcidState AuthenticateState) initAuthentication mBasePath authenticateConfig initMethods = do let authenticatePath = combine (fromMaybe "state" mBasePath) "authenticate" authenticateState <- openLocalStateFrom (combine authenticatePath "core") initialAuthenticateState -- FIXME: need to deal with one of the initMethods throwing an exception (cleanupPartial, handlers, javascript) <- unzip3 <$> mapM (\initMethod -> initMethod authenticatePath authenticateState authenticateConfig) initMethods let cleanup = sequence_ $ createCheckpointAndClose authenticateState : (map (\c -> c True) cleanupPartial) h = route javascript (Map.fromList handlers) return (cleanup, h, authenticateState) instance (Functor m, MonadIO m) => IntegerSupply (RouteT AuthenticateURL m) where nextInteger = fmap (fromIntegral . (`mod` 1024) . hashUnique) (liftIO newUnique) happstack-authenticate-2.3.4.6/Happstack/Authenticate/OpenId/0000755000000000000000000000000012777524361022234 5ustar0000000000000000happstack-authenticate-2.3.4.6/Happstack/Authenticate/OpenId/Controllers.hs0000644000000000000000000000672012777524361025103 0ustar0000000000000000{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} module Happstack.Authenticate.OpenId.Controllers where import Control.Lens ((^.)) import Control.Monad.Trans (MonadIO(..)) import Data.Acid (AcidState) import Data.Acid.Advanced (query') import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T import Happstack.Authenticate.Core (AuthenticateState, AuthenticateURL, getToken, tokenIsAuthAdmin) import Happstack.Authenticate.OpenId.Core (GetOpenIdRealm(..), OpenIdState) import Happstack.Authenticate.OpenId.URL (OpenIdURL(BeginDance, Partial, ReturnTo), nestOpenIdURL) import Happstack.Authenticate.OpenId.PartialsURL (PartialURL(UsingGoogle, UsingYahoo, RealmForm)) import Happstack.Server (Happstack) import Language.Javascript.JMacro import Web.Routes openIdCtrl :: (Happstack m) => AcidState AuthenticateState -> AcidState OpenIdState -> RouteT AuthenticateURL m JStat openIdCtrl authenticateState openIdState = nestOpenIdURL $ do fn <- askRouteFn mt <- getToken authenticateState mRealm <- case mt of (Just (token, _)) | token ^. tokenIsAuthAdmin -> query' openIdState GetOpenIdRealm | otherwise -> return Nothing Nothing -> return Nothing return $ openIdCtrlJs mRealm fn openIdCtrlJs :: Maybe Text -> (OpenIdURL -> [(Text, Maybe Text)] -> Text) -> JStat openIdCtrlJs mRealm showURL = [jmacro| var openId = angular.module('openId', ['happstackAuthentication']); var openIdWindow; tokenCB = function (token) { alert('tokenCB: ' + token); }; openId.controller('OpenIdCtrl', ['$scope','$http','$window', '$location', 'userService', function ($scope, $http, $window, $location, userService) { $scope.openIdRealm = { srOpenIdRealm: `(fromMaybe "" mRealm)` }; $scope.openIdWindow = function (providerUrl) { tokenCB = function(token) { var u = userService.updateFromToken(token); $scope.isAuthenticated = u.isAuthenticated; $scope.$apply(); }; openIdWindow = window.open(providerUrl, "_blank", "toolbar=0"); }; $scope.setOpenIdRealm = function (setRealmUrl) { function callback(datum, status, headers, config) { if (datum == null) { $scope.username_password_error = 'error communicating with the server.'; } else { if (datum.jrStatus == "Ok") { $scope.set_openid_realm_msg = 'Realm Updated.'; // FIXME -- I18N // $scope.openIdRealm = ''; } else { $scope.set_open_id_realm_msg = datum.jrData; } } }; $http.post(setRealmUrl, $scope.openIdRealm). success(callback). error(callback); }; }]); openId.directive('openidGoogle', ['$rootScope', function ($rootScope) { return { restrict: 'E', replace: true, templateUrl: `(showURL (Partial UsingGoogle) [])` }; }]); openId.directive('openidYahoo', ['$rootScope', function ($rootScope) { return { restrict: 'E', replace: true, templateUrl: `(showURL (Partial UsingYahoo) [])` }; }]); openId.directive('openidRealm', ['$rootScope', function ($rootScope) { return { restrict: 'E', templateUrl: `(showURL (Partial RealmForm) [])` }; }]); |] happstack-authenticate-2.3.4.6/Happstack/Authenticate/OpenId/Core.hs0000644000000000000000000002503312777524361023463 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, MultiParamTypeClasses, OverloadedStrings, TemplateHaskell, TypeFamilies #-} module Happstack.Authenticate.OpenId.Core where import Control.Applicative (Alternative) import Control.Monad (msum) import Control.Lens ((?=), (^.), (.=), makeLenses, view, at) import Control.Monad.Trans (MonadIO(liftIO)) import Data.Acid (AcidState, Query, Update, makeAcidic) import Data.Acid.Advanced (query', update') import qualified Data.Aeson as Aeson import Data.Aeson (Object(..), Value(..), decode, encode) import Data.Aeson.Types (ToJSON(..), FromJSON(..), Options(fieldLabelModifier), defaultOptions, genericToJSON, genericParseJSON) import Data.Data (Data, Typeable) import qualified Data.HashMap.Strict as HashMap import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (mapMaybe) import Data.Monoid ((<>)) import Data.SafeCopy (Migrate(..), SafeCopy, base, extension, deriveSafeCopy) import qualified Data.Text as T import Data.Text (Text) import qualified Data.Text.Encoding as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import qualified Data.Map as Map import Data.UserId (UserId) import GHC.Generics (Generic) import Happstack.Authenticate.Core (AuthenticateConfig(..), AuthenticateState, CoreError(..), CreateAnonymousUser(..), GetUserByUserId(..), HappstackAuthenticateI18N(..), addTokenCookie, getToken, jsonOptions, toJSONError, toJSONSuccess, toJSONResponse, tokenIsAuthAdmin, userId) import Happstack.Authenticate.OpenId.URL import Happstack.Server (RqBody(..), Happstack, Method(..), Response, askRq, unauthorized, badRequest, internalServerError, forbidden, lookPairsBS, method, resp, takeRequestBody, toResponse, toResponseBS, ok) import Language.Javascript.JMacro import Network.HTTP.Conduit (withManager) import Text.Shakespeare.I18N (RenderMessage(..), Lang, mkMessageFor) import Web.Authenticate.OpenId (Identifier) import Web.Authenticate.OpenId (Identifier, OpenIdResponse(..), authenticateClaimed, getForwardUrl) {- The OpenId authentication scheme works as follows: - the user tells us which OpenId provider they want to use - we call 'getForwardUrl' to construct a url for that provider - the user is redirected to that 'url' -- typically a 3rd party site - the user interacts with site to confirm the login - that site redirects the user back to a url at our site with some 'claims' in the query string - we then talk to the user's OpenId server and verify those claims - we know have a verified OpenId identifier for the user -} $(deriveSafeCopy 1 'base ''Identifier) ------------------------------------------------------------------------------ -- OpenIdError ------------------------------------------------------------------------------ data OpenIdError = UnknownIdentifier | CoreError { openIdErrorMessageE :: CoreError } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) instance ToJSON OpenIdError where toJSON = genericToJSON jsonOptions instance FromJSON OpenIdError where parseJSON = genericParseJSON jsonOptions instance ToJExpr OpenIdError where toJExpr = toJExpr . toJSON mkMessageFor "HappstackAuthenticateI18N" "OpenIdError" "messages/openid/error" ("en") ------------------------------------------------------------------------------ -- OpenIdState ------------------------------------------------------------------------------ data OpenIdState_1 = OpenIdState_1 { _identifiers_1 :: Map Identifier UserId } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) deriveSafeCopy 1 'base ''OpenIdState_1 makeLenses ''OpenIdState_1 data OpenIdState = OpenIdState { _identifiers :: Map Identifier UserId , _openIdRealm :: Maybe Text } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) deriveSafeCopy 2 'extension ''OpenIdState makeLenses ''OpenIdState instance Migrate OpenIdState where type MigrateFrom OpenIdState = OpenIdState_1 migrate (OpenIdState_1 ids) = OpenIdState ids Nothing initialOpenIdState :: OpenIdState initialOpenIdState = OpenIdState { _identifiers = Map.fromList [] , _openIdRealm = Nothing } ------------------------------------------------------------------------------ -- 'OpenIdState' acid-state methods ------------------------------------------------------------------------------ identifierToUserId :: Identifier -> Query OpenIdState (Maybe UserId) identifierToUserId identifier = view (identifiers . at identifier) associateIdentifierWithUserId :: Identifier -> UserId -> Update OpenIdState () associateIdentifierWithUserId ident uid = identifiers . at ident ?= uid -- | Get the OpenId realm to use for authentication getOpenIdRealm :: Query OpenIdState (Maybe Text) getOpenIdRealm = view openIdRealm -- | set the realm used for OpenId Authentication -- -- IMPORTANT: Changing this value after users have registered is -- likely to invalidate existing OpenId tokens resulting in users no -- longer being able to access their old accounts. setOpenIdRealm :: Maybe Text -> Update OpenIdState () setOpenIdRealm realm = openIdRealm .= realm makeAcidic ''OpenIdState [ 'identifierToUserId , 'associateIdentifierWithUserId , 'getOpenIdRealm , 'setOpenIdRealm ] data SetRealmData = SetRealmData { _srOpenIdRealm :: Maybe Text } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) makeLenses ''SetRealmData instance ToJSON SetRealmData where toJSON = genericToJSON jsonOptions instance FromJSON SetRealmData where parseJSON = genericParseJSON jsonOptions realm :: (Happstack m) => AcidState AuthenticateState -> AcidState OpenIdState -> m Response realm authenticateState openIdState = do mt <- getToken authenticateState case mt of Nothing -> unauthorized $ toJSONError (CoreError AuthorizationRequired) (Just (token,_)) | token ^. tokenIsAuthAdmin == False -> forbidden $ toJSONError (CoreError Forbidden) | otherwise -> msum [ do method GET mRealm <- query' openIdState GetOpenIdRealm ok $ toJSONSuccess mRealm , do method POST (Just (Body body)) <- takeRequestBody =<< askRq case Aeson.decode body of Nothing -> badRequest $ toJSONError (CoreError JSONDecodeFailed) (Just (SetRealmData mRealm)) -> do -- liftIO $ putStrLn $ "mRealm from JSON: " ++ show mRealm update' openIdState (SetOpenIdRealm mRealm) ok $ toJSONSuccess () ] -- 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) token :: (Alternative m, Happstack m) => AcidState AuthenticateState -> AuthenticateConfig -> AcidState OpenIdState -> m Response token authenticateState authenticateConfig openIdState = do identifier <- getIdentifier mUserId <- query' openIdState (IdentifierToUserId identifier) mUser <- case mUserId of Nothing -> -- badRequest $ toJSONError UnknownIdentifier do user <- update' authenticateState CreateAnonymousUser update' openIdState (AssociateIdentifierWithUserId identifier (user ^. userId)) -- addTokenCookie authenticateState user return (Just user) (Just uid) -> do mu <- query' authenticateState (GetUserByUserId uid) case mu of Nothing -> return Nothing (Just u) -> return (Just u) case mUser of Nothing -> internalServerError $ toJSONError $ CoreError InvalidUserId (Just user) -> do token <- addTokenCookie authenticateState authenticateConfig user let tokenBS = TL.encodeUtf8 $ TL.fromStrict token -- ok $ toResponse token ok $ toResponseBS "text/html" $ "" -- liftIO $ print token -- ok $ toResponseBS "text/html" $ "wheee" {- do token <- addTokenCookie authenticateState u resp 201 $ toResponseBS "application/json" $ encode $ Object $ HashMap.fromList [("token", toJSON token)] -} {- account :: (Happstack m) => AcidState AuthenticateState -> AcidState OpenIdState -> Maybe (UserId, AccountURL) -> m (Either OpenIdError UserId) -- handle new account created via POST to /account account authenticateState openIdState Nothing = undefined -} {- 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) 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) -} happstack-authenticate-2.3.4.6/Happstack/Authenticate/OpenId/Partials.hs0000644000000000000000000001047212777524361024353 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, QuasiQuotes, TemplateHaskell, TypeOperators, TypeSynonymInstances, OverloadedStrings #-} module Happstack.Authenticate.OpenId.Partials where import Control.Category ((.), id) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Monad.Trans (MonadIO(..), lift) import Data.Acid (AcidState) import Data.Acid.Advanced (query') import Data.Data (Data, Typeable) import Data.Monoid ((<>)) import Data.Maybe (fromMaybe) import Data.Text (Text) import Data.UserId (UserId) import qualified Data.Text as Text import qualified Data.Text.Lazy as LT import HSP import Happstack.Server.HSP.HTML () import Language.Haskell.HSX.QQ (hsx) import Language.Javascript.JMacro import Happstack.Authenticate.Core (AuthenticateState, AuthenticateURL, User(..), HappstackAuthenticateI18N(..), getToken) import Happstack.Authenticate.OpenId.Core (OpenIdState(..), GetOpenIdRealm(..)) import Happstack.Authenticate.OpenId.URL (OpenIdURL(..), nestOpenIdURL) import Happstack.Authenticate.OpenId.PartialsURL (PartialURL(..)) import Happstack.Server (Happstack, unauthorized) import Happstack.Server.XMLGenT () import HSP.JMacro () import Prelude hiding ((.), id) import Text.Shakespeare.I18N (Lang, mkMessageFor, renderMessage) import Web.Authenticate.OpenId.Providers (google, yahoo) import Web.Routes import Web.Routes.XMLGenT () import Web.Routes.TH (derivePathInfo) type Partial' m = (RouteT AuthenticateURL (ReaderT [Lang] m)) type Partial m = XMLGenT (RouteT AuthenticateURL (ReaderT [Lang] m)) data PartialMsgs = UsingGoogleMsg | UsingYahooMsg | SetRealmMsg | OpenIdRealmMsg mkMessageFor "HappstackAuthenticateI18N" "PartialMsgs" "messages/openid/partials" "en" instance (Functor m, Monad m) => EmbedAsChild (Partial' m) PartialMsgs where asChild msg = do lang <- ask asChild $ renderMessage HappstackAuthenticateI18N lang msg instance (Functor m, Monad m) => EmbedAsAttr (Partial' m) (Attr LT.Text PartialMsgs) where asAttr (k := v) = do lang <- ask asAttr (k := renderMessage HappstackAuthenticateI18N lang v) routePartial :: (Functor m, Monad m, Happstack m) => AcidState AuthenticateState -> AcidState OpenIdState -> PartialURL -> Partial m XML routePartial authenticateState openIdState url = case url of UsingGoogle -> usingGoogle UsingYahoo -> usingYahoo RealmForm -> realmForm openIdState usingGoogle :: (Functor m, Monad m) => Partial m XML usingGoogle = do danceURL <- lift $ nestOpenIdURL $ showURL (BeginDance (Text.pack google)) [hsx| danceURL <> "')")>UsingGoogleMsg |] usingYahoo :: (Functor m, Monad m) => Partial m XML usingYahoo = do danceURL <- lift $ nestOpenIdURL $ showURL (BeginDance (Text.pack yahoo)) [hsx| danceURL <> "')")>UsingYahooMsg |] realmForm :: (Functor m, MonadIO m) => AcidState OpenIdState -> Partial m XML realmForm openIdState = do url <- lift $ nestOpenIdURL $ showURL Realm let setOpenIdRealmFn = "setOpenIdRealm('" <> url <> "')" [hsx|
{{set_openid_realm_msg}}
|] happstack-authenticate-2.3.4.6/Happstack/Authenticate/OpenId/PartialsURL.hs0000644000000000000000000000213112777524361024727 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TemplateHaskell, TypeOperators, OverloadedStrings #-} module Happstack.Authenticate.OpenId.PartialsURL where import Data.Data (Data, Typeable) import Control.Category ((.), id) import GHC.Generics (Generic) import Prelude hiding ((.), id) import Text.Boomerang.TH (makeBoomerangs) import Web.Routes (PathInfo(..)) import Web.Routes.Boomerang (Router, (:-), (<>), boomerangFromPathSegments, boomerangToPathSegments) data PartialURL = UsingGoogle | UsingYahoo | RealmForm deriving (Eq, Ord, Data, Typeable, Generic, Read, Show) makeBoomerangs ''PartialURL partialURL :: Router () (PartialURL :- ()) partialURL = ( "using-google" . rUsingGoogle <> "using-yahoo" . rUsingYahoo <> "realm" . rRealmForm ) instance PathInfo PartialURL where fromPathSegments = boomerangFromPathSegments partialURL toPathSegments = boomerangToPathSegments partialURL happstack-authenticate-2.3.4.6/Happstack/Authenticate/OpenId/Route.hs0000644000000000000000000000775712777524361023706 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Happstack.Authenticate.OpenId.Route where import Control.Applicative ((<$>)) import Control.Monad.Reader (ReaderT, runReaderT) import Control.Monad.Trans (liftIO) import Data.Acid (AcidState, closeAcidState, makeAcidic) import Data.Acid.Advanced (query') import Data.Acid.Local (createCheckpointAndClose, openLocalStateFrom) import Data.Text (Text) import Data.UserId (UserId) import Happstack.Authenticate.Core (AuthenticationHandler, AuthenticationMethod, AuthenticateConfig, AuthenticateState, AuthenticateURL, CoreError(..), toJSONError, toJSONResponse) import Happstack.Authenticate.OpenId.Core (GetOpenIdRealm(..), OpenIdError(..), OpenIdState, initialOpenIdState, realm, token) import Happstack.Authenticate.OpenId.Controllers (openIdCtrl) import Happstack.Authenticate.OpenId.URL (OpenIdURL(..), openIdAuthenticationMethod, nestOpenIdURL) import Happstack.Authenticate.OpenId.Partials (routePartial) import Happstack.Server (Happstack, Response, ServerPartT, acceptLanguage, bestLanguage, lookTexts', mapServerPartT, ok, notFound, queryString, toResponse, seeOther) import Happstack.Server.JMacro () import HSP (unXMLGenT) import HSP.HTML4 (html4StrictFrag) import Language.Javascript.JMacro (JStat) import Network.HTTP.Conduit (withManager) import System.FilePath (combine) import Text.Shakespeare.I18N (Lang) import Web.Authenticate.OpenId (Identifier, OpenIdResponse(..), authenticateClaimed, getForwardUrl) import Web.Routes (PathInfo(..), RouteT(..), mapRouteT, nestURL, parseSegments, showURL) ------------------------------------------------------------------------------ -- routeOpenId ------------------------------------------------------------------------------ routeOpenId :: (Happstack m) => AcidState AuthenticateState -> AuthenticateConfig -> AcidState OpenIdState -> [Text] -> RouteT AuthenticateURL (ReaderT [Lang] m) Response routeOpenId authenticateState authenticateConfig openIdState pathSegments = case parseSegments fromPathSegments pathSegments of (Left _) -> notFound $ toJSONError URLDecodeFailed (Right url) -> case url of (Partial u) -> do xml <- unXMLGenT (routePartial authenticateState openIdState u) ok $ toResponse (html4StrictFrag, xml) (BeginDance providerURL) -> do returnURL <- nestOpenIdURL $ showURL ReturnTo realm <- query' openIdState GetOpenIdRealm forwardURL <- liftIO $ withManager $ getForwardUrl providerURL returnURL realm [] -- [("Email", "http://schema.openid.net/contact/email")] seeOther forwardURL (toResponse ()) ReturnTo -> token authenticateState authenticateConfig openIdState Realm -> realm authenticateState openIdState ------------------------------------------------------------------------------ -- initOpenId ------------------------------------------------------------------------------ initOpenId :: FilePath -> AcidState AuthenticateState -> AuthenticateConfig -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat) initOpenId basePath authenticateState authenticateConfig = do openIdState <- openLocalStateFrom (combine basePath "openId") initialOpenIdState let shutdown = \normal -> if normal then createCheckpointAndClose openIdState else closeAcidState openIdState authenticationHandler pathSegments = do langsOveride <- queryString $ lookTexts' "_LANG" langs <- bestLanguage <$> acceptLanguage mapRouteT (flip runReaderT (langsOveride ++ langs)) $ routeOpenId authenticateState authenticateConfig openIdState pathSegments return (shutdown, (openIdAuthenticationMethod, authenticationHandler), openIdCtrl authenticateState openIdState) happstack-authenticate-2.3.4.6/Happstack/Authenticate/OpenId/URL.hs0000644000000000000000000000401112777524361023226 0ustar0000000000000000{-# LANGUAGE DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, TypeOperators, OverloadedStrings #-} module Happstack.Authenticate.OpenId.URL where import Control.Category ((.), id) import Data.Data (Data, Typeable) import Data.Text (Text) import Data.UserId (UserId, rUserId) import GHC.Generics (Generic) import Prelude hiding ((.), id) import Happstack.Authenticate.Core (AuthenticateURL, AuthenticationMethod(..), nestAuthenticationMethod) import Happstack.Authenticate.OpenId.PartialsURL (PartialURL(..), partialURL) import Text.Boomerang.TH (makeBoomerangs) import Web.Routes (PathInfo(..), RouteT(..)) import Web.Routes.TH (derivePathInfo) import Web.Routes.Boomerang ------------------------------------------------------------------------------ -- openIdAuthenticationMethod ------------------------------------------------------------------------------ openIdAuthenticationMethod :: AuthenticationMethod openIdAuthenticationMethod = AuthenticationMethod "openId" ------------------------------------------------------------------------------ -- OpenIdURL ------------------------------------------------------------------------------ data OpenIdURL = Partial PartialURL | BeginDance Text | ReturnTo | Realm deriving (Eq, Ord, Data, Typeable, Generic, Read, Show) makeBoomerangs ''OpenIdURL openIdURL :: Router () (OpenIdURL :- ()) openIdURL = ( "partial" rPartial . partialURL <> "begin-dance" rBeginDance . anyText <> "return-to" rReturnTo <> "realm" rRealm ) instance PathInfo OpenIdURL where fromPathSegments = boomerangFromPathSegments openIdURL toPathSegments = boomerangToPathSegments openIdURL -- showOpenIdURL :: (MonadRoute m) => OpenIdURL -> m Text nestOpenIdURL :: RouteT OpenIdURL m a -> RouteT AuthenticateURL m a nestOpenIdURL = nestAuthenticationMethod openIdAuthenticationMethod happstack-authenticate-2.3.4.6/Happstack/Authenticate/Password/0000755000000000000000000000000012777524361022660 5ustar0000000000000000happstack-authenticate-2.3.4.6/Happstack/Authenticate/Password/Controllers.hs0000644000000000000000000002422012777524361025522 0ustar0000000000000000{-# LANGUAGE QuasiQuotes #-} module Happstack.Authenticate.Password.Controllers where import Data.Text (Text) import qualified Data.Text as T import Happstack.Authenticate.Core (AuthenticateURL) import Happstack.Authenticate.Password.URL (PasswordURL(Account, Token, Partial, PasswordReset, PasswordRequestReset), nestPasswordURL) import Happstack.Authenticate.Password.PartialsURL (PartialURL(ChangePassword, Logout, Login, LoginInline, SignupPassword, ResetPasswordForm, RequestResetPasswordForm)) import Language.Javascript.JMacro import Web.Routes usernamePasswordCtrl :: (Monad m) => RouteT AuthenticateURL m JStat usernamePasswordCtrl = nestPasswordURL $ do fn <- askRouteFn return $ usernamePasswordCtrlJs fn usernamePasswordCtrlJs :: (PasswordURL -> [(Text, Maybe Text)] -> Text) -> JStat usernamePasswordCtrlJs showURL = [jmacro| { var usernamePassword = angular.module('usernamePassword', ['happstackAuthentication']); usernamePassword.controller('UsernamePasswordCtrl', ['$scope','$http','$window', '$location', 'userService', function ($scope, $http, $window, $location, userService) { // login() emptyUser = function() { return { user: '', password: '' }; }; $scope.user = emptyUser(); $scope.login = function () { function callback(datum, status, headers, config) { if (datum == null) { $scope.username_password_error = 'error communicating with the server.'; } else { if (datum.jrStatus == "Ok") { $scope.username_password_error = ''; userService.updateFromToken(datum.jrData.token); } else { userService.clearUser(); $scope.username_password_error = datum.jrData; } } }; $http. post(`(showURL Token [])`, $scope.user). success(callback). error(callback); }; // signupPassword() emptySignup = function () { return { naUser: { username: '', email: '' }, naPassword: '', naPasswordConfirm: '' }; }; $scope.signup = emptySignup(); $scope.signupPassword = function () { $scope.signup.naUser.userId = 0; function callback(datum, status, headers, config) { if (datum == null) { $scope.username_password_error = 'error communicating with server.'; } else { if (datum.jrStatus == "Ok") { $scope.signup_error = 'Account Created'; // FIXME -- I18N $scope.signup = emptySignup(); } else { $scope.signup_error = datum.jrData; } } }; $http. post(`(showURL (Account Nothing) [])`, $scope.signup). success(callback). error(callback); }; // changePassword() emptyPassword = function () { return { cpOldPassword: '', cpNewPassword: '', cpNewPasswordConfirm: '' }; }; $scope.password = emptyPassword(); $scope.changePassword = function (url) { var u = userService.getUser(); function callback(datum, status, headers, config) { if (datum == null) { $scope.username_password_error = 'error communicating with server.'; } else { if (datum.jrStatus == "Ok") { $scope.change_password_error = 'Password Changed.'; // FIXME -- I18N $scope.password = emptyPassword(); } else { $scope.change_password_error = datum.jrData; } } }; if (u.isAuthenticated) { $http. post(url, $scope.password). success(callback). error(callback); } else { $scope.change_password_error = 'Not Authenticated.'; // FIXME -- I18N } }; // requestResetPassword() requestResetEmpty = function () { return { rrpUsername: '' }; }; $scope.requestReset = requestResetEmpty(); $scope.requestResetPassword = function () { function callback(datum, status, headers, config) { if (datum == null) { $scope.request_reset_password_msg = 'error communicating with the server.'; } else { if (datum.jrStatus == "Ok") { $scope.request_reset_password_msg = datum.jrData; $scope.requestReset = requestResetEmpty(); } else { $scope.request_reset_password_msg = datum.jrData; } } } $http.post(`(showURL PasswordRequestReset [])`, $scope.requestReset). success(callback). error(callback); }; // resetPassword() resetEmpty = function () { return { rpPassword: '', rpPasswordConfirm: '' }; }; $scope.reset = resetEmpty(); $scope.resetPassword = function () { function callback(datum, status, headers, config) { if (datum == null) { $scope.reset_password_msg = 'error communicating with the server.'; } else { if (datum.jrStatus == "Ok") { $scope.reset_password_msg = datum.jrData; $scope.reset = resetEmpty(); } else { $scope.reset_password_msg = datum.jrData; } } } var resetToken = $location.search().reset_token; if (resetToken) { $scope.reset.rpResetToken = resetToken; $http.post(`(showURL PasswordReset [])`, $scope.reset). success(callback). error(callback); } else { $scope.reset_password_msg = "reset token not found."; // FIXME -- I18N } }; }]); /* usernamePassword.factory('authInterceptor', ['$rootScope', '$q', '$window', 'userService', function ($rootScope, $q, $window, userService) { return { request: function (config) { config.headers = config.headers || {}; u = userService.getUser(); if (u && u.token) { config.headers.Authorization = 'Bearer ' + u.token; } return config; }, responseError: function (rejection) { if (rejection.status === 401) { // handle the case where the user is not authenticated userService.clearUser(); document.cookie = 'atc=; path=/; expires=Thu, 01-Jan-70 00:00:01 GMT;'; } return $q.reject(rejection); } }; }]); usernamePassword.config(['$httpProvider', function ($httpProvider) { $httpProvider.interceptors.push('authInterceptor'); }]); */ // upAuthenticated directive usernamePassword.directive('upAuthenticated', ['$rootScope', 'userService', function ($rootScope, userService) { return { restrict: 'A', link: function (scope, element, attrs) { var prevDisp = element.css('display'); $rootScope.$watch(function () { return userService.getUser().isAuthenticated; }, function(auth) { if (auth != (attrs.upAuthenticated == 'true')) { element.css('display', 'none'); } else { element.css('display', prevDisp); } }); } }; }]); // upLogout directive usernamePassword.directive('upLogout', ['$rootScope', 'userService', function ($rootScope, userService) { return { restrict: 'E', replace: true, templateUrl: `(showURL (Partial Logout) [])` }; }]); // upLogin directive usernamePassword.directive('upLogin', ['$rootScope', 'userService', function ($rootScope, userService) { return { restrict: 'E', replace: true, templateUrl: `(showURL (Partial Login) [])` }; }]); // upLoginInline directive usernamePassword.directive('upLoginInline', ['$rootScope', 'userService', function ($rootScope, userService) { return { restrict: 'E', replace: true, templateUrl: `(showURL (Partial LoginInline) [])` }; }]); // upChangePassword directive usernamePassword.directive('upChangePassword', ['$rootScope', '$http', '$compile', 'userService', function ($rootScope, $http, $compile, userService) { function link(scope, element, attrs) { $rootScope.$watch(function() { return userService.getUser().isAuthenticated; }, function(auth) { if (auth == true) { $http.get(`(showURL (Partial ChangePassword) [])`). success(function(datum, status, headers, config) { element.empty(); var newElem = angular.element(datum); element.append(newElem); $compile(newElem)(scope); }); } else { element.empty(); } }); } return { restrict: 'E', link: link }; }]); // upRequestResetPassword directive usernamePassword.directive('upRequestResetPassword', [function () { return { restrict: 'E', templateUrl: `(showURL (Partial RequestResetPasswordForm) [])` }; }]); // upResetPassword directive usernamePassword.directive('upResetPassword', [function () { return { restrict: 'E', templateUrl: `(showURL (Partial ResetPasswordForm) [])` }; }]); // upSignupPassword directive usernamePassword.directive('upSignupPassword', [function () { return { restrict: 'E', templateUrl: `(showURL (Partial SignupPassword) [])` }; }]); } |] happstack-authenticate-2.3.4.6/Happstack/Authenticate/Password/Core.hs0000644000000000000000000005337212777524361024116 0ustar0000000000000000{-# LANGUAGE DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, OverloadedStrings #-} module Happstack.Authenticate.Password.Core where import Control.Applicative ((<$>), optional) import Control.Monad.Trans (MonadIO(..)) import Control.Lens ((?~), (^.), (.=), (?=), assign, makeLenses, set, use, view, over) import Control.Lens.At (at) import qualified Crypto.PasswordStore as PasswordStore import Crypto.PasswordStore (genSaltIO, exportSalt, makePassword) import Data.Acid (AcidState, Query, Update, closeAcidState, makeAcidic) import Data.Acid.Advanced (query', update') import Data.Acid.Local (createCheckpointAndClose, openLocalStateFrom) import qualified Data.Aeson as Aeson import Data.Aeson (Value(..), Object(..), Result(..), decode, encode, fromJSON) import Data.Aeson.Types (ToJSON(..), FromJSON(..), Options(fieldLabelModifier), defaultOptions, genericToJSON, genericParseJSON) import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as B import Data.Data (Data, Typeable) import qualified Data.HashMap.Strict as HashMap import Data.Map (Map) import qualified Data.Map as Map import Data.Maybe (fromMaybe, fromJust) import Data.Monoid ((<>)) import Data.SafeCopy (SafeCopy, base, deriveSafeCopy) import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.IO as Text import qualified Data.Text.Encoding as Text import qualified Data.Text.Lazy as LT import Data.Time.Clock.POSIX (getPOSIXTime) import Data.UserId (UserId) import GHC.Generics (Generic) import Happstack.Authenticate.Core (AuthenticationHandler, AuthenticationMethod(..), AuthenticateState(..), AuthenticateConfig, usernameAcceptable, requireEmail, AuthenticateURL, CoreError(..), CreateUser(..), Email(..), unEmail, GetUserByUsername(..), HappstackAuthenticateI18N(..), SharedSecret(..), User(..), Username(..), GetSharedSecret(..), addTokenCookie, email, getToken, getOrGenSharedSecret, jsonOptions, userId, username, toJSONSuccess, toJSONResponse, toJSONError, tokenUser) import Happstack.Authenticate.Password.URL (AccountURL(..)) import Happstack.Server import HSP.JMacro import Language.Javascript.JMacro import Network.HTTP.Types (toQuery, renderQuery) import Network.Mail.Mime (Address(..), Mail, simpleMail', renderMail', renderSendMail, sendmail) import System.FilePath (combine) import qualified Text.Email.Validate as Email import Text.Shakespeare.I18N (RenderMessage(..), Lang, mkMessageFor) import qualified Web.JWT as JWT import Web.JWT (Algorithm(HS256), JWT, VerifiedJWT, JWTClaimsSet(..), encodeSigned, claims, decode, decodeAndVerifySignature, intDate, secret, secondsSinceEpoch, verify) import Web.Routes import Web.Routes.TH ------------------------------------------------------------------------------ -- PasswordConfig ------------------------------------------------------------------------------ data PasswordConfig = PasswordConfig { _resetLink :: Text , _domain :: Text , _passwordAcceptable :: Text -> Maybe Text } deriving (Typeable, Generic) makeLenses ''PasswordConfig ------------------------------------------------------------------------------ -- PasswordError ------------------------------------------------------------------------------ data PasswordError = NotAuthenticated | NotAuthorized | InvalidUsername | InvalidPassword | InvalidUsernamePassword | NoEmailAddress | MissingResetToken | InvalidResetToken | PasswordMismatch | UnacceptablePassword { passwordErrorMessageMsg :: Text } | CoreError { passwordErrorMessageE :: CoreError } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) instance ToJSON PasswordError where toJSON = genericToJSON jsonOptions instance FromJSON PasswordError where parseJSON = genericParseJSON jsonOptions instance ToJExpr PasswordError where toJExpr = toJExpr . toJSON mkMessageFor "HappstackAuthenticateI18N" "PasswordError" "messages/password/error" ("en") ------------------------------------------------------------------------------ -- HashedPass ------------------------------------------------------------------------------ newtype HashedPass = HashedPass { _unHashedPass :: ByteString } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) deriveSafeCopy 1 'base ''HashedPass makeLenses ''HashedPass -- | hash a password string mkHashedPass :: (Functor m, MonadIO m) => Text -- ^ password in plain text -> m HashedPass -- ^ salted and hashed mkHashedPass pass = HashedPass <$> (liftIO $ makePassword (Text.encodeUtf8 pass) 12) -- | verify a password verifyHashedPass :: Text -- ^ password in plain text -> HashedPass -- ^ hashed version of password -> Bool verifyHashedPass passwd (HashedPass hashedPass) = PasswordStore.verifyPassword (Text.encodeUtf8 passwd) hashedPass ------------------------------------------------------------------------------ -- PasswordState ------------------------------------------------------------------------------ data PasswordState = PasswordState { _passwords :: Map UserId HashedPass } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) deriveSafeCopy 1 'base ''PasswordState makeLenses ''PasswordState initialPasswordState :: PasswordState initialPasswordState = PasswordState { _passwords = Map.empty } ------------------------------------------------------------------------------ -- AcidState PasswordState queries/updates ------------------------------------------------------------------------------ -- | set the password for 'UserId' setPassword :: UserId -- ^ UserId -> HashedPass -- ^ the hashed password -> Update PasswordState () setPassword userId hashedPass = passwords . at userId ?= hashedPass -- | delete the password for 'UserId' deletePassword :: UserId -- ^ UserId -> Update PasswordState () deletePassword userId = passwords . at userId .= Nothing -- | verify that the supplied password matches the stored hashed password for 'UserId' verifyPasswordForUserId :: UserId -- ^ UserId -> Text -- ^ plain-text password -> Query PasswordState Bool verifyPasswordForUserId userId plainPassword = do mHashed <- view (passwords . at userId) case mHashed of Nothing -> return False (Just hashed) -> return (verifyHashedPass plainPassword hashed) makeAcidic ''PasswordState [ 'setPassword , 'deletePassword , 'verifyPasswordForUserId ] ------------------------------------------------------------------------------ -- Functions ------------------------------------------------------------------------------ -- | verify that the supplied username/password is valid verifyPassword :: (MonadIO m) => AcidState AuthenticateState -> AcidState PasswordState -> Username -> Text -> m Bool verifyPassword authenticateState passwordState username password = do mUser <- query' authenticateState (GetUserByUsername username) case mUser of Nothing -> return False (Just user) -> query' passwordState (VerifyPasswordForUserId (view userId user) password) ------------------------------------------------------------------------------ -- API ------------------------------------------------------------------------------ data UserPass = UserPass { _user :: Username , _password :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) makeLenses ''UserPass instance ToJSON UserPass where toJSON = genericToJSON jsonOptions instance FromJSON UserPass where parseJSON = genericParseJSON jsonOptions instance ToJExpr UserPass where toJExpr = toJExpr . toJSON ------------------------------------------------------------------------------ -- token ------------------------------------------------------------------------------ token :: (Happstack m) => AcidState AuthenticateState -> AuthenticateConfig -> AcidState PasswordState -> m Response token authenticateState authenticateConfig passwordState = do method POST (Just (Body body)) <- takeRequestBody =<< askRq case Aeson.decode body of Nothing -> badRequest $ toJSONError (CoreError JSONDecodeFailed) (Just (UserPass username password)) -> do mUser <- query' authenticateState (GetUserByUsername username) case mUser of Nothing -> forbidden $ toJSONError InvalidPassword (Just u) -> do valid <- query' passwordState (VerifyPasswordForUserId (u ^. userId) password) if not valid then unauthorized $ toJSONError InvalidUsernamePassword else do token <- addTokenCookie authenticateState authenticateConfig u resp 201 $ toJSONSuccess (Object $ HashMap.fromList [("token", toJSON token)]) -- toResponseBS "application/json" $ encode $ Object $ HashMap.fromList [("token", toJSON token)] ------------------------------------------------------------------------------ -- account ------------------------------------------------------------------------------ -- | JSON record for new account data data NewAccountData = NewAccountData { _naUser :: User , _naPassword :: Text , _naPasswordConfirm :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) makeLenses ''NewAccountData instance ToJSON NewAccountData where toJSON = genericToJSON jsonOptions instance FromJSON NewAccountData where parseJSON = genericParseJSON jsonOptions -- | JSON record for change password data data ChangePasswordData = ChangePasswordData { _cpOldPassword :: Text , _cpNewPassword :: Text , _cpNewPasswordConfirm :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) makeLenses ''ChangePasswordData instance ToJSON ChangePasswordData where toJSON = genericToJSON jsonOptions instance FromJSON ChangePasswordData where parseJSON = genericParseJSON jsonOptions -- | account handler account :: (Happstack m) => AcidState AuthenticateState -> AcidState PasswordState -> AuthenticateConfig -> PasswordConfig -> Maybe (UserId, AccountURL) -> m (Either PasswordError UserId) -- handle new account creation via POST to /account -- FIXME: check that password and password confirmation match account authenticateState passwordState authenticateConfig passwordConfig Nothing = do method POST (Just (Body body)) <- takeRequestBody =<< askRq case Aeson.decode body of Nothing -> badRequest (Left $ CoreError JSONDecodeFailed) (Just newAccount) -> case (authenticateConfig ^. usernameAcceptable) (newAccount ^. naUser ^. username) of (Just e) -> return $ Left (CoreError e) Nothing -> case validEmail (authenticateConfig ^. requireEmail) (newAccount ^. naUser ^. email) of (Just e) -> return $ Left e Nothing -> if (newAccount ^. naPassword /= newAccount ^. naPasswordConfirm) then ok $ Left PasswordMismatch else case (passwordConfig ^. passwordAcceptable) (newAccount ^. naPassword) of (Just passwdError) -> ok $ Left (UnacceptablePassword passwdError) Nothing -> do eUser <- update' authenticateState (CreateUser $ _naUser newAccount) case eUser of (Left e) -> return $ Left (CoreError e) (Right user) -> do hashed <- mkHashedPass (_naPassword newAccount) update' passwordState (SetPassword (user ^. userId) hashed) ok $ (Right (user ^. userId)) where validEmail :: Bool -> Maybe Email -> Maybe PasswordError validEmail required mEmail = case (required, mEmail) of (True, Nothing) -> Just $ CoreError InvalidEmail (False, Just (Email "")) -> Nothing (False, Nothing) -> Nothing (_, Just email) -> if Email.isValid (Text.encodeUtf8 (email ^. unEmail)) then Nothing else Just $ CoreError InvalidEmail -- handle updates to /account//* account authenticateState passwordState authenticateConfig passwordConfig (Just (uid, url)) = case url of Password -> do method POST mUser <- getToken authenticateState case mUser of Nothing -> unauthorized (Left NotAuthenticated) (Just (token, _)) -> -- here we could have fancier policies that allow super-users to change passwords if ((token ^. tokenUser ^. userId) /= uid) then return (Left NotAuthorized) else do mBody <- takeRequestBody =<< askRq case mBody of Nothing -> badRequest (Left $ CoreError JSONDecodeFailed) (Just (Body body)) -> case Aeson.decode body of Nothing -> do -- liftIO $ print body badRequest (Left $ CoreError JSONDecodeFailed) (Just changePassword) -> do b <- verifyPassword authenticateState passwordState (token ^. tokenUser ^. username) (changePassword ^. cpOldPassword) if not b then forbidden (Left InvalidPassword) else if (changePassword ^. cpNewPassword /= changePassword ^. cpNewPasswordConfirm) then ok $ (Left PasswordMismatch) else case (passwordConfig ^. passwordAcceptable) (changePassword ^. cpNewPassword) of (Just e) -> ok (Left $ UnacceptablePassword e) Nothing -> do pw <- mkHashedPass (changePassword ^. cpNewPassword) update' passwordState (SetPassword uid pw) ok $ (Right uid) ------------------------------------------------------------------------------ -- passwordReset ------------------------------------------------------------------------------ -- | JSON record for new account data data RequestResetPasswordData = RequestResetPasswordData { _rrpUsername :: Username } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) makeLenses ''RequestResetPasswordData instance ToJSON RequestResetPasswordData where toJSON = genericToJSON jsonOptions instance FromJSON RequestResetPasswordData where parseJSON = genericParseJSON jsonOptions -- | request reset password passwordRequestReset :: (Happstack m) => PasswordConfig -> AcidState AuthenticateState -> AcidState PasswordState -> m (Either PasswordError Text) passwordRequestReset passwordConfig authenticateState passwordState = do method POST (Just (Body body)) <- takeRequestBody =<< askRq case Aeson.decode body of Nothing -> badRequest $ Left $ CoreError JSONDecodeFailed (Just (RequestResetPasswordData username)) -> do mUser <- query' authenticateState (GetUserByUsername username) case mUser of Nothing -> notFound $ Left InvalidUsername (Just user) -> case user ^. email of Nothing -> return $ Left NoEmailAddress (Just toEm) -> do eResetToken <- issueResetToken authenticateState user case eResetToken of (Left err) -> return (Left err) (Right resetToken) -> do let resetLink' = (passwordConfig ^. resetLink) <> (Text.decodeUtf8 $ renderQuery True $ toQuery [("reset_token"::Text, resetToken)]) liftIO $ Text.putStrLn resetLink' -- FIXME: don't print to stdout sendResetEmail toEm (Email ("no-reply@" <> (passwordConfig ^. domain))) resetLink' return (Right "password reset request email sent.") -- FIXME: I18N -- | issueResetToken issueResetToken :: (MonadIO m) => AcidState AuthenticateState -> User -> m (Either PasswordError JWT.JSON) issueResetToken authenticateState user = case user ^. email of Nothing -> return (Left NoEmailAddress) (Just addr) -> do ssecret <- getOrGenSharedSecret authenticateState (user ^. userId) -- FIXME: add expiration time now <- liftIO getPOSIXTime let claims = JWT.def { unregisteredClaims = Map.singleton "reset-password" (toJSON user) , JWT.exp = intDate $ now + 60 } return $ Right $ encodeSigned HS256 (secret $ _unSharedSecret ssecret) claims -- FIXME: I18N -- FIXME: call renderSendMail sendResetEmail :: (MonadIO m) => Email -> Email -> Text -> m () sendResetEmail (Email toEm) (Email fromEm) resetLink = liftIO $ do mailBS <- renderMail' $ simpleMail' (Address Nothing toEm) (Address (Just "no-reply") fromEm) "Reset Password Request" (LT.fromStrict resetLink) -- B.putStr mailBS sendmail mailBS -- | JSON record for new account data data ResetPasswordData = ResetPasswordData { _rpPassword :: Text , _rpPasswordConfirm :: Text , _rpResetToken :: Text } deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) makeLenses ''ResetPasswordData instance ToJSON ResetPasswordData where toJSON = genericToJSON jsonOptions instance FromJSON ResetPasswordData where parseJSON = genericParseJSON jsonOptions passwordReset :: (Happstack m) => AcidState AuthenticateState -> AcidState PasswordState -> PasswordConfig -> m (Either PasswordError Text) passwordReset authenticateState passwordState passwordConfig = do method POST (Just (Body body)) <- takeRequestBody =<< askRq case Aeson.decode body of Nothing -> badRequest $ Left $ CoreError JSONDecodeFailed (Just (ResetPasswordData password passwordConfirm resetToken)) -> do mUser <- decodeAndVerifyResetToken authenticateState resetToken case mUser of Nothing -> return (Left InvalidResetToken) (Just (user, _)) -> if password /= passwordConfirm then return (Left PasswordMismatch) else case (passwordConfig ^. passwordAcceptable) password of (Just e) -> ok $ Left $ UnacceptablePassword e Nothing -> do pw <- mkHashedPass password update' passwordState (SetPassword (user ^. userId) pw) ok $ Right "Password Reset." -- I18N {- do mTokenTxt <- optional $ queryString $ lookText' "reset_btoken" case mTokenTxt of Nothing -> badRequest $ Left MissingResetToken (Just tokenTxt) -> do mUser <- decodeAndVerifyResetToken authenticateState tokenTxt case mUser of Nothing -> return (Left InvalidResetToken) (Just (user, _)) -> if password /= passwordConfirm then return (Left PasswordMismatch) else do pw <- mkHashedPass password update' passwordState (SetPassword (user ^. userId) pw) ok $ Right () -- ok $ Right $ Text.pack $ show (password, passwordConfirm) -} {- do mToken <- optional <$> queryString $ lookText "token" case mToken of Nothing -> return (Left MissingResetToken) (Just token) -> do method GET -} decodeAndVerifyResetToken :: (MonadIO m) => AcidState AuthenticateState -> Text -> m (Maybe (User, JWT VerifiedJWT)) decodeAndVerifyResetToken authenticateState token = do let mUnverified = JWT.decode token case mUnverified of Nothing -> return Nothing (Just unverified) -> case Map.lookup "reset-password" (unregisteredClaims (claims unverified)) of Nothing -> return Nothing (Just uv) -> case fromJSON uv of (Error _) -> return Nothing (Success u) -> do mssecret <- query' authenticateState (GetSharedSecret (u ^. userId)) case mssecret of Nothing -> return Nothing (Just ssecret) -> case verify (secret (_unSharedSecret ssecret)) unverified of Nothing -> return Nothing (Just verified) -> do now <- liftIO getPOSIXTime case JWT.exp (claims verified) of Nothing -> return Nothing (Just exp') -> if (now > secondsSinceEpoch exp') then return Nothing else return (Just (u, verified)) happstack-authenticate-2.3.4.6/Happstack/Authenticate/Password/Partials.hs0000644000000000000000000002242612777524361025001 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, QuasiQuotes, TemplateHaskell, TypeOperators, TypeSynonymInstances, OverloadedStrings #-} module Happstack.Authenticate.Password.Partials where import Control.Category ((.), id) import Control.Lens ((^.)) import Control.Monad.Reader (ReaderT, ask, runReaderT) import Control.Monad.Trans (MonadIO, lift) import Data.Acid (AcidState) import Data.Data (Data, Typeable) import Data.Monoid ((<>)) import Data.Text (Text) import Data.UserId (UserId) import qualified Data.Text as Text import qualified Data.Text.Lazy as LT import HSP import Happstack.Server.HSP.HTML () import Language.Haskell.HSX.QQ (hsx) import Language.Javascript.JMacro import Happstack.Authenticate.Core (AuthenticateState, AuthenticateURL, User(..), HappstackAuthenticateI18N(..), getToken, tokenUser, userId) import Happstack.Authenticate.Password.Core (PasswordError(NotAuthenticated)) import Happstack.Authenticate.Password.URL (AccountURL(..), PasswordURL(..), nestPasswordURL) import Happstack.Authenticate.Password.PartialsURL (PartialURL(..)) import Happstack.Server (Happstack, unauthorized) import Happstack.Server.XMLGenT () import HSP.JMacro () import Prelude hiding ((.), id) import Text.Shakespeare.I18N (Lang, mkMessageFor, renderMessage) import Web.Routes import Web.Routes.XMLGenT () import Web.Routes.TH (derivePathInfo) type Partial' m = (RouteT AuthenticateURL (ReaderT [Lang] m)) type Partial m = XMLGenT (RouteT AuthenticateURL (ReaderT [Lang] m)) data PartialMsgs = UsernameMsg | EmailMsg | PasswordMsg | PasswordConfirmationMsg | SignUpMsg | SignInMsg | LogoutMsg | OldPasswordMsg | NewPasswordMsg | NewPasswordConfirmationMsg | ChangePasswordMsg | RequestPasswordResetMsg mkMessageFor "HappstackAuthenticateI18N" "PartialMsgs" "messages/password/partials" "en" instance (Functor m, Monad m) => EmbedAsChild (Partial' m) PartialMsgs where asChild msg = do lang <- ask asChild $ renderMessage HappstackAuthenticateI18N lang msg instance (Functor m, Monad m) => EmbedAsAttr (Partial' m) (Attr LT.Text PartialMsgs) where asAttr (k := v) = do lang <- ask asAttr (k := renderMessage HappstackAuthenticateI18N lang v) routePartial :: (Functor m, Monad m, Happstack m) => AcidState AuthenticateState -> PartialURL -> Partial m XML routePartial authenticateState url = case url of LoginInline -> usernamePasswordForm True Login -> usernamePasswordForm False Logout -> logoutForm SignupPassword -> signupPasswordForm ChangePassword -> do mUser <- getToken authenticateState case mUser of Nothing -> unauthorized =<< [hsx|

<% show NotAuthenticated %>

|] -- FIXME: I18N (Just (token, _)) -> changePasswordForm (token ^. tokenUser ^. userId) RequestResetPasswordForm -> requestResetPasswordForm ResetPasswordForm -> resetPasswordForm signupPasswordForm :: (Functor m, Monad m) => Partial m XML signupPasswordForm = [hsx|
{{signup_error}}
|] usernamePasswordForm :: (Functor m, Monad m) => Bool -> Partial m XML usernamePasswordForm inline = [hsx|
{{username_password_error}}
<% " " :: Text %>
<% " " :: Text %>
|] logoutForm :: (Functor m, MonadIO m) => Partial m XML logoutForm = [hsx|
<% LogoutMsg %>
|] changePasswordForm :: (Functor m, MonadIO m) => UserId -> Partial m XML changePasswordForm userId = do url <- lift $ nestPasswordURL $ showURL (Account (Just (userId, Password))) let changePasswordFn = "changePassword('" <> url <> "')" [hsx|
{{change_password_error}}
|] requestResetPasswordForm :: (Functor m, MonadIO m) => Partial m XML requestResetPasswordForm = do -- url <- lift $ nestPasswordURL $ showURL PasswordReset -- let changePasswordFn = "resetPassword('" <> url <> "')" [hsx|
{{request_reset_password_msg}}
|] resetPasswordForm :: (Functor m, MonadIO m) => Partial m XML resetPasswordForm = [hsx|
{{reset_password_msg}}
|] happstack-authenticate-2.3.4.6/Happstack/Authenticate/Password/PartialsURL.hs0000644000000000000000000000254612777524361025365 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, DeriveGeneric, TemplateHaskell, TypeOperators, OverloadedStrings #-} module Happstack.Authenticate.Password.PartialsURL where import Data.Data (Data, Typeable) import Control.Category ((.), id) import GHC.Generics (Generic) import Prelude hiding ((.), id) import Text.Boomerang.TH (makeBoomerangs) import Web.Routes (PathInfo(..)) import Web.Routes.Boomerang (Router, (:-), (<>), boomerangFromPathSegments, boomerangToPathSegments) data PartialURL = LoginInline | Login | Logout | SignupPassword | ChangePassword | RequestResetPasswordForm | ResetPasswordForm deriving (Eq, Ord, Data, Typeable, Generic) makeBoomerangs ''PartialURL partialURL :: Router () (PartialURL :- ()) partialURL = ( "login-inline" . rLoginInline <> "login" . rLogin <> "logout" . rLogout <> "signup-password" . rSignupPassword <> "change-password" . rChangePassword <> "reset-password-form" . rResetPasswordForm <> "request-reset-password-form" . rRequestResetPasswordForm ) instance PathInfo PartialURL where fromPathSegments = boomerangFromPathSegments partialURL toPathSegments = boomerangToPathSegments partialURL happstack-authenticate-2.3.4.6/Happstack/Authenticate/Password/Route.hs0000644000000000000000000000762012777524361024317 0ustar0000000000000000module Happstack.Authenticate.Password.Route where import Control.Applicative ((<$>)) import Control.Monad.Reader (ReaderT, runReaderT) import Data.Acid (AcidState, closeAcidState, makeAcidic) import Data.Acid.Local (createCheckpointAndClose, openLocalStateFrom) import Data.Text (Text) import Data.UserId (UserId) import Happstack.Authenticate.Core (AuthenticationHandler, AuthenticationMethod, AuthenticateConfig(..), AuthenticateState, AuthenticateURL, CoreError(..), toJSONError, toJSONResponse) import Happstack.Authenticate.Password.Core (PasswordConfig(..), PasswordError(..), PasswordState, account, initialPasswordState, passwordReset, passwordRequestReset, token) import Happstack.Authenticate.Password.Controllers (usernamePasswordCtrl) import Happstack.Authenticate.Password.URL (PasswordURL(..), passwordAuthenticationMethod) import Happstack.Authenticate.Password.Partials (routePartial) import Happstack.Server (Happstack, Response, ServerPartT, acceptLanguage, bestLanguage, lookTexts', mapServerPartT, ok, notFound, queryString, toResponse) import Happstack.Server.JMacro () import HSP (unXMLGenT) import HSP.HTML4 (html4StrictFrag) import Language.Javascript.JMacro (JStat) import System.FilePath (combine) import Text.Shakespeare.I18N (Lang) import Web.Routes (PathInfo(..), RouteT(..), mapRouteT, parseSegments) ------------------------------------------------------------------------------ -- routePassword ------------------------------------------------------------------------------ routePassword :: (Happstack m) => PasswordConfig -> AcidState AuthenticateState -> AuthenticateConfig -> AcidState PasswordState -> [Text] -> RouteT AuthenticateURL (ReaderT [Lang] m) Response routePassword passwordConfig authenticateState authenticateConfig passwordState pathSegments = case parseSegments fromPathSegments pathSegments of (Left _) -> notFound $ toJSONError URLDecodeFailed (Right url) -> case url of Token -> token authenticateState authenticateConfig passwordState Account mUrl -> toJSONResponse <$> account authenticateState passwordState authenticateConfig passwordConfig mUrl (Partial u) -> do xml <- unXMLGenT (routePartial authenticateState u) return $ toResponse (html4StrictFrag, xml) PasswordRequestReset -> toJSONResponse <$> passwordRequestReset passwordConfig authenticateState passwordState PasswordReset -> toJSONResponse <$> passwordReset authenticateState passwordState passwordConfig UsernamePasswordCtrl -> toResponse <$> usernamePasswordCtrl ------------------------------------------------------------------------------ -- initPassword ------------------------------------------------------------------------------ initPassword :: PasswordConfig -> FilePath -> AcidState AuthenticateState -> AuthenticateConfig -> IO (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler), RouteT AuthenticateURL (ServerPartT IO) JStat) initPassword passwordConfig basePath authenticateState authenticateConfig = do passwordState <- openLocalStateFrom (combine basePath "password") initialPasswordState let shutdown = \normal -> if normal then createCheckpointAndClose passwordState else closeAcidState passwordState authenticationHandler pathSegments = do langsOveride <- queryString $ lookTexts' "_LANG" langs <- bestLanguage <$> acceptLanguage mapRouteT (flip runReaderT (langsOveride ++ langs)) $ routePassword passwordConfig authenticateState authenticateConfig passwordState pathSegments return (shutdown, (passwordAuthenticationMethod, authenticationHandler), usernamePasswordCtrl) happstack-authenticate-2.3.4.6/Happstack/Authenticate/Password/URL.hs0000644000000000000000000000543712777524361023667 0ustar0000000000000000{-# LANGUAGE DataKinds, DeriveDataTypeable, DeriveGeneric, FlexibleInstances, MultiParamTypeClasses, RecordWildCards, TemplateHaskell, TypeFamilies, TypeSynonymInstances, TypeOperators, OverloadedStrings #-} module Happstack.Authenticate.Password.URL where import Control.Category ((.), id) import Data.Data (Data, Typeable) import Data.UserId (UserId(..), rUserId) import GHC.Generics (Generic) import Prelude hiding ((.), id) import Web.Routes (RouteT(..)) import Web.Routes.TH (derivePathInfo) import Happstack.Authenticate.Core (AuthenticateURL, AuthenticationMethod(..), nestAuthenticationMethod) import Happstack.Authenticate.Password.PartialsURL (PartialURL(..), partialURL) import Text.Boomerang.TH (makeBoomerangs) import Web.Routes (PathInfo(..)) import Web.Routes.Boomerang ------------------------------------------------------------------------------ -- passwordAuthenticationMethod ------------------------------------------------------------------------------ passwordAuthenticationMethod :: AuthenticationMethod passwordAuthenticationMethod = AuthenticationMethod "password" ------------------------------------------------------------------------------ -- AccountURL ------------------------------------------------------------------------------ data AccountURL = Password deriving (Eq, Ord, Read, Show, Data, Typeable, Generic) makeBoomerangs ''AccountURL accountURL :: Router () (AccountURL :- ()) accountURL = ( rPassword . "password" ) instance PathInfo AccountURL where fromPathSegments = boomerangFromPathSegments accountURL toPathSegments = boomerangToPathSegments accountURL ------------------------------------------------------------------------------ -- PasswordURL ------------------------------------------------------------------------------ data PasswordURL = Token | Account (Maybe (UserId, AccountURL)) | Partial PartialURL | PasswordRequestReset | PasswordReset | UsernamePasswordCtrl deriving (Eq, Ord, Data, Typeable, Generic) makeBoomerangs ''PasswordURL passwordURL :: Router () (PasswordURL :- ()) passwordURL = ( "token" . rToken <> "account" rAccount . rMaybe (rPair . (rUserId . integer) accountURL) <> "partial" rPartial . partialURL <> "password-request-reset" . rPasswordRequestReset <> "password-reset" . rPasswordReset <> "js" rUsernamePasswordCtrl ) instance PathInfo PasswordURL where fromPathSegments = boomerangFromPathSegments passwordURL toPathSegments = boomerangToPathSegments passwordURL -- showPasswordURL :: (MonadRoute m) => PasswordURL -> m Text nestPasswordURL :: RouteT PasswordURL m a -> RouteT AuthenticateURL m a nestPasswordURL = nestAuthenticationMethod passwordAuthenticationMethod happstack-authenticate-2.3.4.6/messages/0000755000000000000000000000000012777524361016331 5ustar0000000000000000happstack-authenticate-2.3.4.6/messages/core/0000755000000000000000000000000012777524361017261 5ustar0000000000000000happstack-authenticate-2.3.4.6/messages/core/en.msg0000644000000000000000000000054412777524361020376 0ustar0000000000000000HandlerNotFound: Handler Not Found. URLDecodeFailed: Failed to decode URL. UsernameAlreadyExists: Username already exists. AuthorizationRequired: Authorization required. Forbidden: Forbidden. JSONDecodeFailed: Failed to decode JSON data. InvalidUserId: Invalid UserId UsernameNotAcceptable: Username not acceptable. InvalidEmail: Invalid email address. happstack-authenticate-2.3.4.6/messages/openid/0000755000000000000000000000000012777524361017607 5ustar0000000000000000happstack-authenticate-2.3.4.6/messages/openid/error/0000755000000000000000000000000012777524361020740 5ustar0000000000000000happstack-authenticate-2.3.4.6/messages/openid/error/en.msg0000644000000000000000000000024412777524361022052 0ustar0000000000000000UnknownIdentifier: OpenId identifier is not associated with any account on this system. CoreError e@CoreError: #{renderMessage HappstackAuthenticateI18N ["en"] e} happstack-authenticate-2.3.4.6/messages/openid/partials/0000755000000000000000000000000012777524361021426 5ustar0000000000000000happstack-authenticate-2.3.4.6/messages/openid/partials/en.msg0000644000000000000000000000017112777524361022537 0ustar0000000000000000UsingGoogleMsg: Google OpenId UsingYahooMsg: Yahoo OpenId SetRealmMsg: Update OpenId Realm OpenIdRealmMsg: OpenId Realm happstack-authenticate-2.3.4.6/messages/password/0000755000000000000000000000000012777524361020173 5ustar0000000000000000happstack-authenticate-2.3.4.6/messages/password/error/0000755000000000000000000000000012777524361021324 5ustar0000000000000000happstack-authenticate-2.3.4.6/messages/password/error/en.msg0000644000000000000000000000074212777524361022441 0ustar0000000000000000NotAuthenticated: Not Authenticated NotAuthorized: Not Authorized InvalidUsername: Invalid Username InvalidPassword: Invalid Password InvalidUsernamePassword: Invalid username or password NoEmailAddress: No email address found MissingResetToken: Missing reset token InvalidResetToken: Invalid reset token PasswordMismatch: Passwords do not match UnacceptablePassword msg@Text: Unacceptable Password. #{msg} CoreError e@CoreError: #{renderMessage HappstackAuthenticateI18N ["en"] e} happstack-authenticate-2.3.4.6/messages/password/partials/0000755000000000000000000000000012777524361022012 5ustar0000000000000000happstack-authenticate-2.3.4.6/messages/password/partials/en.msg0000644000000000000000000000054612777524361023131 0ustar0000000000000000UsernameMsg: username EmailMsg: email PasswordMsg: password PasswordConfirmationMsg: password confirmation SignUpMsg: sign up SignInMsg: sign in LogoutMsg: logout OldPasswordMsg: old password NewPasswordMsg: new password NewPasswordConfirmationMsg: new password confirmation ChangePasswordMsg: change password RequestPasswordResetMsg: request password reset