diff --git a/yesod-auth/.gitignore b/yesod-auth/.gitignore new file mode 100644 index 00000000..d6197881 --- /dev/null +++ b/yesod-auth/.gitignore @@ -0,0 +1,4 @@ +dist +*.swp +auth2.db3 +client_session_key.aes diff --git a/yesod-auth/LICENSE b/yesod-auth/LICENSE new file mode 100644 index 00000000..8643e5d8 --- /dev/null +++ b/yesod-auth/LICENSE @@ -0,0 +1,25 @@ +The following license covers this documentation, and the source code, except +where otherwise indicated. + +Copyright 2010, Michael Snoyman. All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + +* Redistributions of source code must retain the above copyright notice, this + list of conditions and the following disclaimer. + +* Redistributions in binary form must reproduce the above copyright notice, + this list of conditions and the following disclaimer in the documentation + and/or other materials provided with the distribution. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "AS IS" AND ANY EXPRESS OR +IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO +EVENT SHALL THE COPYRIGHT HOLDERS BE LIABLE FOR ANY DIRECT, INDIRECT, +INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT +NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, +OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE +OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF +ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/yesod-auth/README b/yesod-auth/README new file mode 100644 index 00000000..e69de29b diff --git a/yesod-auth/Setup.lhs b/yesod-auth/Setup.lhs new file mode 100755 index 00000000..1bc517f6 --- /dev/null +++ b/yesod-auth/Setup.lhs @@ -0,0 +1,8 @@ +#!/usr/bin/env runhaskell + +> module Main where +> import Distribution.Simple +> import System.Cmd (system) + +> main :: IO () +> main = defaultMain diff --git a/yesod-auth/Yesod/Auth.hs b/yesod-auth/Yesod/Auth.hs new file mode 100644 index 00000000..4b6b5062 --- /dev/null +++ b/yesod-auth/Yesod/Auth.hs @@ -0,0 +1,211 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies, TemplateHaskell #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Yesod.Auth + ( -- * Subsite + Auth + , AuthPlugin (..) + , AuthRoute (..) + , getAuth + , YesodAuth (..) + -- * Plugin interface + , Creds (..) + , setCreds + -- * User functions + , maybeAuthId + , maybeAuth + , requireAuthId + , requireAuth + ) where + +#include "qq.h" + +import Control.Monad (when) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Maybe + +import Data.Aeson +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Map as Map + +import Language.Haskell.TH.Syntax hiding (lift) + +import qualified Network.Wai as W +import Text.Hamlet (html) + +import Yesod.Core +import Yesod.Persist +import Yesod.Json +import Yesod.Auth.Message (AuthMessage, defaultMessage) +import qualified Yesod.Auth.Message as Msg +import Yesod.Form (FormMessage) + +data Auth = Auth + +type Method = Text +type Piece = Text + +data AuthPlugin m = AuthPlugin + { apName :: Text + , apDispatch :: Method -> [Piece] -> GHandler Auth m () + , apLogin :: forall s. (Route Auth -> Route m) -> GWidget s m () + } + +getAuth :: a -> Auth +getAuth = const Auth + +-- | User credentials +data Creds m = Creds + { credsPlugin :: Text -- ^ How the user was authenticated + , credsIdent :: Text -- ^ Identifier. Exact meaning depends on plugin. + , credsExtra :: [(Text, Text)] + } + +class (Yesod m, SinglePiece (AuthId m), RenderMessage m FormMessage) => YesodAuth m where + type AuthId m + + -- | Default destination on successful login, if no other + -- destination exists. + loginDest :: m -> Route m + + -- | Default destination on successful logout, if no other + -- destination exists. + logoutDest :: m -> Route m + + getAuthId :: Creds m -> GHandler s m (Maybe (AuthId m)) + + authPlugins :: [AuthPlugin m] + + -- | What to show on the login page. + loginHandler :: GHandler Auth m RepHtml + loginHandler = defaultLayout $ do + setTitleI Msg.LoginTitle + tm <- lift getRouteToMaster + mapM_ (flip apLogin tm) authPlugins + + renderAuthMessage :: m + -> [Text] -- ^ languages + -> AuthMessage -> Text + renderAuthMessage _ _ = defaultMessage + +mkYesodSub "Auth" + [ ClassP ''YesodAuth [VarT $ mkName "master"] + ] +#define STRINGS *Texts + [QQ(parseRoutes)| +/check CheckR GET +/login LoginR GET +/logout LogoutR GET POST +/page/#Text/STRINGS PluginR +|] + +credsKey :: Text +credsKey = "_ID" + +-- | FIXME: won't show up till redirect +setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m () +setCreds doRedirects creds = do + y <- getYesod + maid <- getAuthId creds + case maid of + Nothing -> + when doRedirects $ do + case authRoute y of + Nothing -> do rh <- defaultLayout $ addHtml [QQ(html)|

Invalid login |] + sendResponse rh + Just ar -> do setMessageI Msg.InvalidLogin + redirect RedirectTemporary ar + Just aid -> do + setSession credsKey $ toSinglePiece aid + when doRedirects $ do + setMessageI Msg.NowLoggedIn + redirectUltDest RedirectTemporary $ loginDest y + +getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson +getCheckR = do + creds <- maybeAuthId + defaultLayoutJson (do + setTitle "Authentication Status" + addHtml $ html' creds) (json' creds) + where + html' creds = + [QQ(html)| +

Authentication Status +$maybe _ <- creds +

Logged in. +$nothing +

Not logged in. +|] + json' creds = + Object $ Map.fromList + [ (T.pack "logged_in", Bool $ maybe False (const True) creds) + ] + +getLoginR :: YesodAuth m => GHandler Auth m RepHtml +getLoginR = setUltDestReferer >> loginHandler + +getLogoutR :: YesodAuth m => GHandler Auth m () +getLogoutR = setUltDestReferer >> postLogoutR -- FIXME redirect to post + +postLogoutR :: YesodAuth m => GHandler Auth m () +postLogoutR = do + y <- getYesod + deleteSession credsKey + redirectUltDest RedirectTemporary $ logoutDest y + +handlePluginR :: YesodAuth m => Text -> [Text] -> GHandler Auth m () +handlePluginR plugin pieces = do + env <- waiRequest + let method = decodeUtf8With lenientDecode $ W.requestMethod env + case filter (\x -> apName x == plugin) authPlugins of + [] -> notFound + ap:_ -> apDispatch ap method pieces + +-- | Retrieves user credentials, if user is authenticated. +maybeAuthId :: YesodAuth m => GHandler s m (Maybe (AuthId m)) +maybeAuthId = do + ms <- lookupSession credsKey + case ms of + Nothing -> return Nothing + Just s -> return $ fromSinglePiece s + +maybeAuth :: ( YesodAuth m + , Key val ~ AuthId m + , PersistBackend (YesodDB m (GGHandler s m IO)) + , PersistEntity val + , YesodPersist m + ) => GHandler s m (Maybe (Key val, val)) +maybeAuth = runMaybeT $ do + aid <- MaybeT $ maybeAuthId + a <- MaybeT $ runDB $ get aid + return (aid, a) + +requireAuthId :: YesodAuth m => GHandler s m (AuthId m) +requireAuthId = maybeAuthId >>= maybe redirectLogin return + +requireAuth :: ( YesodAuth m + , Key val ~ AuthId m + , PersistBackend (YesodDB m (GGHandler s m IO)) + , PersistEntity val + , YesodPersist m + ) => GHandler s m (Key val, val) +requireAuth = maybeAuth >>= maybe redirectLogin return + +redirectLogin :: Yesod m => GHandler s m a +redirectLogin = do + y <- getYesod + setUltDest' + case authRoute y of + Just z -> redirect RedirectTemporary z + Nothing -> permissionDenied "Please configure authRoute" + +instance YesodAuth m => RenderMessage m AuthMessage where + renderMessage = renderAuthMessage diff --git a/yesod-auth/Yesod/Auth/BrowserId.hs b/yesod-auth/Yesod/Auth/BrowserId.hs new file mode 100644 index 00000000..ddb975ef --- /dev/null +++ b/yesod-auth/Yesod/Auth/BrowserId.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Auth.BrowserId + ( authBrowserId + ) where + +import Yesod.Auth +import Web.Authenticate.BrowserId +import Data.Text (Text) +import Yesod.Core +import Text.Hamlet (hamlet) +import Control.Monad.IO.Class (liftIO) + +#include "qq.h" + +pid :: Text +pid = "browserid" + +complete :: AuthRoute +complete = PluginR pid [] + +authBrowserId :: YesodAuth m + => Text -- ^ audience + -> AuthPlugin m +authBrowserId audience = AuthPlugin + { apName = pid + , apDispatch = \m ps -> + case (m, ps) of + ("GET", [assertion]) -> do + memail <- liftIO $ checkAssertion audience assertion + case memail of + Nothing -> error "Invalid assertion" + Just email -> setCreds True Creds + { credsPlugin = pid + , credsIdent = email + , credsExtra = [] + } + (_, []) -> badMethod + _ -> notFound + , apLogin = \toMaster -> do + addScriptRemote browserIdJs + addHamlet [QQ(hamlet)| +

+ + +|] + } diff --git a/yesod-auth/Yesod/Auth/Dummy.hs b/yesod-auth/Yesod/Auth/Dummy.hs new file mode 100644 index 00000000..bd42c1bc --- /dev/null +++ b/yesod-auth/Yesod/Auth/Dummy.hs @@ -0,0 +1,34 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +-- | Provides a dummy authentication module that simply lets a user specify +-- his/her identifier. This is not intended for real world use, just for +-- testing. +module Yesod.Auth.Dummy + ( authDummy + ) where + +#include "qq.h" + +import Yesod.Auth +import Yesod.Form (runInputPost, textField, ireq) +import Yesod.Handler (notFound) +import Text.Hamlet (hamlet) +import Yesod.Widget (addHamlet) + +authDummy :: YesodAuth m => AuthPlugin m +authDummy = + AuthPlugin "dummy" dispatch login + where + dispatch "POST" [] = do + ident <- runInputPost $ ireq textField "ident" + setCreds True $ Creds "dummy" ident [] + dispatch _ _ = notFound + url = PluginR "dummy" [] + login authToMaster = + addHamlet [QQ(hamlet)| +

+ \Your new identifier is: + + +|] diff --git a/yesod-auth/Yesod/Auth/Email.hs b/yesod-auth/Yesod/Auth/Email.hs new file mode 100644 index 00000000..8e9b9b8e --- /dev/null +++ b/yesod-auth/Yesod/Auth/Email.hs @@ -0,0 +1,276 @@ +{-# LANGUAGE QuasiQuotes, TypeFamilies #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +module Yesod.Auth.Email + ( -- * Plugin + authEmail + , YesodAuthEmail (..) + , EmailCreds (..) + , saltPass + -- * Routes + , loginR + , registerR + , setpassR + ) where + +#include "qq.h" + +import Network.Mail.Mime (randomString) +import Yesod.Auth +import System.Random +import Control.Monad (when) +import Control.Applicative ((<$>), (<*>)) +import Data.Digest.Pure.MD5 +import qualified Data.Text.Lazy as T +import qualified Data.Text as TS +import Data.Text.Lazy.Encoding (encodeUtf8) +import Data.Text (Text) +import qualified Crypto.PasswordStore as PS +import qualified Data.Text.Encoding as DTE + +import Yesod.Form +import Yesod.Handler +import Yesod.Content +import Yesod.Widget +import Yesod.Core +import Control.Monad.IO.Class (liftIO) +import qualified Yesod.Auth.Message as Msg + +loginR, registerR, setpassR :: AuthRoute +loginR = PluginR "email" ["login"] +registerR = PluginR "email" ["register"] +setpassR = PluginR "email" ["set-password"] + +verify :: Text -> Text -> AuthRoute -- FIXME +verify eid verkey = PluginR "email" ["verify", eid, verkey] + +type Email = Text +type VerKey = Text +type VerUrl = Text +type SaltedPass = Text +type VerStatus = Bool + +-- | Data stored in a database for each e-mail address. +data EmailCreds m = EmailCreds + { emailCredsId :: AuthEmailId m + , emailCredsAuthId :: Maybe (AuthId m) + , emailCredsStatus :: VerStatus + , emailCredsVerkey :: Maybe VerKey + } + +class (YesodAuth m, SinglePiece (AuthEmailId m)) => YesodAuthEmail m where + type AuthEmailId m + + addUnverified :: Email -> VerKey -> GHandler Auth m (AuthEmailId m) + sendVerifyEmail :: Email -> VerKey -> VerUrl -> GHandler Auth m () + getVerifyKey :: AuthEmailId m -> GHandler Auth m (Maybe VerKey) + setVerifyKey :: AuthEmailId m -> VerKey -> GHandler Auth m () + verifyAccount :: AuthEmailId m -> GHandler Auth m (Maybe (AuthId m)) + getPassword :: AuthId m -> GHandler Auth m (Maybe SaltedPass) + setPassword :: AuthId m -> SaltedPass -> GHandler Auth m () + getEmailCreds :: Email -> GHandler Auth m (Maybe (EmailCreds m)) + getEmail :: AuthEmailId m -> GHandler Auth m (Maybe Email) + + -- | Generate a random alphanumeric string. + randomKey :: m -> IO Text + randomKey _ = do + stdgen <- newStdGen + return $ TS.pack $ fst $ randomString 10 stdgen + +authEmail :: YesodAuthEmail m => AuthPlugin m +authEmail = + AuthPlugin "email" dispatch $ \tm -> + [QQ(whamlet)| + + + + + +
_{Msg.Email} + + +
_{Msg.Password} + + +
+ + I don't have an account +|] + where + dispatch "GET" ["register"] = getRegisterR >>= sendResponse + dispatch "POST" ["register"] = postRegisterR >>= sendResponse + dispatch "GET" ["verify", eid, verkey] = + case fromSinglePiece eid of + Nothing -> notFound + Just eid' -> getVerifyR eid' verkey >>= sendResponse + dispatch "POST" ["login"] = postLoginR >>= sendResponse + dispatch "GET" ["set-password"] = getPasswordR >>= sendResponse + dispatch "POST" ["set-password"] = postPasswordR >>= sendResponse + dispatch _ _ = notFound + +getRegisterR :: YesodAuthEmail master => GHandler Auth master RepHtml +getRegisterR = do + toMaster <- getRouteToMaster + defaultLayout $ do + setTitleI Msg.RegisterLong + addWidget + [QQ(whamlet)| +

_{Msg.EnterEmail} + +

_{Msg.ConfirmationEmailSent email} |] + +getVerifyR :: YesodAuthEmail m + => AuthEmailId m -> Text -> GHandler Auth m RepHtml +getVerifyR lid key = do + realKey <- getVerifyKey lid + memail <- getEmail lid + case (realKey == Just key, memail) of + (True, Just email) -> do + muid <- verifyAccount lid + case muid of + Nothing -> return () + Just _uid -> do + setCreds False $ Creds "email" email [("verifiedEmail", email)] -- FIXME uid? + toMaster <- getRouteToMaster + setMessageI Msg.AddressVerified + redirect RedirectTemporary $ toMaster setpassR + _ -> return () + defaultLayout $ do + setTitleI Msg.InvalidKey + addWidget + [QQ(whamlet)|

_{Msg.InvalidKey} |] + +postLoginR :: YesodAuthEmail master => GHandler Auth master () +postLoginR = do + (email, pass) <- runInputPost $ (,) + <$> ireq emailField "email" + <*> ireq textField "password" + mecreds <- getEmailCreds email + maid <- + case (mecreds >>= emailCredsAuthId, fmap emailCredsStatus mecreds) of + (Just aid, Just True) -> do + mrealpass <- getPassword aid + case mrealpass of + Nothing -> return Nothing + Just realpass -> return $ + if isValidPass pass realpass + then Just aid + else Nothing + _ -> return Nothing + case maid of + Just _aid -> + setCreds True $ Creds "email" email [("verifiedEmail", email)] -- FIXME aid? + Nothing -> do + setMessageI Msg.InvalidEmailPass + toMaster <- getRouteToMaster + redirect RedirectTemporary $ toMaster LoginR + +getPasswordR :: YesodAuthEmail master => GHandler Auth master RepHtml +getPasswordR = do + toMaster <- getRouteToMaster + maid <- maybeAuthId + case maid of + Just _ -> return () + Nothing -> do + setMessageI Msg.BadSetPass + redirect RedirectTemporary $ toMaster loginR + defaultLayout $ do + setTitleI Msg.SetPassTitle + addWidget + [QQ(whamlet)| +

_{Msg.SetPass} + + + + + +
_{Msg.NewPass} + + +
_{Msg.ConfirmPass} + + +
+ +|] + +postPasswordR :: YesodAuthEmail master => GHandler Auth master () +postPasswordR = do + (new, confirm) <- runInputPost $ (,) + <$> ireq textField "new" + <*> ireq textField "confirm" + toMaster <- getRouteToMaster + y <- getYesod + when (new /= confirm) $ do + setMessageI Msg.PassMismatch + redirect RedirectTemporary $ toMaster setpassR + maid <- maybeAuthId + aid <- case maid of + Nothing -> do + setMessageI Msg.BadSetPass + redirect RedirectTemporary $ toMaster loginR + Just aid -> return aid + salted <- liftIO $ saltPass new + setPassword aid salted + setMessageI Msg.PassUpdated + redirect RedirectTemporary $ loginDest y + +saltLength :: Int +saltLength = 5 + +-- | Salt a password with a randomly generated salt. +saltPass :: Text -> IO Text +saltPass = fmap DTE.decodeUtf8 + . flip PS.makePassword 12 + . DTE.encodeUtf8 + +saltPass' :: String -> String -> String +saltPass' salt pass = + salt ++ show (md5 $ fromString $ salt ++ pass) + where + fromString = encodeUtf8 . T.pack + +isValidPass :: Text -- ^ cleartext password + -> SaltedPass -- ^ salted password + -> Bool +isValidPass ct salted = + PS.verifyPassword (DTE.encodeUtf8 ct) (DTE.encodeUtf8 salted) || isValidPass' ct salted + +isValidPass' :: Text -- ^ cleartext password + -> SaltedPass -- ^ salted password + -> Bool +isValidPass' clear' salted' = + let salt = take saltLength salted + in salted == saltPass' salt clear + where + clear = TS.unpack clear' + salted = TS.unpack salted' diff --git a/yesod-auth/Yesod/Auth/Facebook.hs b/yesod-auth/Yesod/Auth/Facebook.hs new file mode 100644 index 00000000..f8715e63 --- /dev/null +++ b/yesod-auth/Yesod/Auth/Facebook.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +module Yesod.Auth.Facebook + ( authFacebook + , facebookUrl + ) where + +#include "qq.h" + +import Yesod.Auth +import qualified Web.Authenticate.Facebook as Facebook +import Data.Aeson +import Data.Aeson.Types (parseMaybe) +import Data.Maybe (fromMaybe) + +import Yesod.Form +import Yesod.Handler +import Yesod.Widget +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Data.Text (Text) +import Control.Monad (mzero) +import Data.Monoid (mappend) +import qualified Data.Aeson.Types +import qualified Yesod.Auth.Message as Msg + +facebookUrl :: AuthRoute +facebookUrl = PluginR "facebook" ["forward"] + +authFacebook :: YesodAuth m + => Text -- ^ Application ID + -> Text -- ^ Application secret + -> [Text] -- ^ Requested permissions + -> AuthPlugin m +authFacebook cid secret perms = + AuthPlugin "facebook" dispatch login + where + url = PluginR "facebook" [] + dispatch "GET" ["forward"] = do + tm <- getRouteToMaster + render <- getUrlRender + let fb = Facebook.Facebook cid secret $ render $ tm url + redirectText RedirectTemporary $ Facebook.getForwardUrl fb perms + dispatch "GET" [] = do + render <- getUrlRender + tm <- getRouteToMaster + let fb = Facebook.Facebook cid secret $ render $ tm url + code <- runInputGet $ ireq textField "code" + at <- liftIO $ Facebook.getAccessToken fb code + let Facebook.AccessToken at' = at + so <- liftIO $ Facebook.getGraphData at "me" + let c = fromMaybe (error "Invalid response from Facebook") + $ parseMaybe (parseCreds at') $ either error id so + setCreds True c + dispatch _ _ = notFound + login tm = do + render <- lift getUrlRender + let fb = Facebook.Facebook cid secret $ render $ tm url + let furl = Facebook.getForwardUrl fb $ perms + [QQ(whamlet)| +

+ _{Msg.Facebook} +|] + +parseCreds :: Text -> Value -> Data.Aeson.Types.Parser (Creds m) +parseCreds at' (Object m) = do + id' <- m .: "id" + let id'' = "http://graph.facebook.com/" `mappend` id' + name <- m .: "name" + email <- m .: "email" + return + $ Creds "facebook" id'' + $ maybe id (\x -> (:) ("verifiedEmail", x)) email + $ maybe id (\x -> (:) ("displayName ", x)) name + [ ("accessToken", at') + ] +parseCreds _ _ = mzero diff --git a/yesod-auth/Yesod/Auth/HashDB.hs b/yesod-auth/Yesod/Auth/HashDB.hs new file mode 100644 index 00000000..acc92243 --- /dev/null +++ b/yesod-auth/Yesod/Auth/HashDB.hs @@ -0,0 +1,256 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +------------------------------------------------------------------------------- +-- | +-- Module : Yesod.Auth.HashDB +-- Copyright : (c) Patrick Brisbin 2010 +-- License : as-is +-- +-- Maintainer : pbrisbin@gmail.com +-- Stability : Stable +-- Portability : Portable +-- +-- A yesod-auth AuthPlugin designed to look users up in Persist where +-- their user id's and a salted SHA1 hash of their password is stored. +-- +-- Example usage: +-- +-- > -- import the function +-- > import Auth.HashDB +-- > +-- > -- make sure you have an auth route +-- > mkYesodData "MyApp" [$parseRoutes| +-- > / RootR GET +-- > /auth AuthR Auth getAuth +-- > |] +-- > +-- > +-- > -- make your app an instance of YesodAuth using this plugin +-- > instance YesodAuth MyApp where +-- > type AuthId MyApp = UserId +-- > +-- > loginDest _ = RootR +-- > logoutDest _ = RootR +-- > getAuthId = getAuthIdHashDB AuthR (Just . UniqueUser) +-- > authPlugins = [authHashDB (Just . UniqueUser)] +-- > +-- > +-- > -- include the migration function in site startup +-- > withServer :: (Application -> IO a) -> IO a +-- > withServer f = withConnectionPool $ \p -> do +-- > runSqlPool (runMigration migrateUsers) p +-- > let h = DevSite p +-- +-- Note that function which converts username to unique identifier must be same. +-- +-- Your app must be an instance of YesodPersist. and the username, +-- salt and hashed-passwords should be added to the database. +-- +-- > echo -n 'MySaltMyPassword' | sha1sum +-- +-- can be used to get the hash from the commandline. +-- +------------------------------------------------------------------------------- +module Yesod.Auth.HashDB + ( HashDBUser(..) + , setPassword + -- * Authentification + , validateUser + , authHashDB + , getAuthIdHashDB + -- * Predefined data type + , User(..) + , UserId + , migrateUsers + ) where + +#include "qq.h" + +import Yesod.Persist +import Yesod.Handler +import Yesod.Form +import Yesod.Auth +import Yesod.Widget (addHamlet) +import Text.Hamlet (hamlet, html) + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (replicateM,liftM) +import Control.Monad.IO.Class (MonadIO, liftIO) + +import qualified Data.ByteString.Lazy.Char8 as BS (pack) +import Data.Digest.Pure.SHA (sha1, showDigest) +import Data.Text (Text, pack, unpack, append) +import Data.Maybe (fromMaybe) +import System.Random (randomRIO) + + +-- | Interface for data type which holds user info. It's just a +-- collection of getters and setters +class HashDBUser user where + -- | Retrieve password hash from user data + userPasswordHash :: user -> Maybe Text + -- | Retrieve salt for password + userPasswordSalt :: user -> Maybe Text + -- | Set hash and password + setUserHashAndSalt :: Text -- ^ Salt + -> Text -- ^ Password hash + -> user -> user + +-- | Generate random salt. Length of 8 is chosen arbitrarily +randomSalt :: MonadIO m => m Text +randomSalt = pack `liftM` liftIO (replicateM 8 (randomRIO ('0','z'))) + +-- | Calculate salted hash using SHA1. +saltedHash :: Text -- ^ Salt + -> Text -- ^ Password + -> Text +saltedHash salt = + pack . showDigest . sha1 . BS.pack . unpack . append salt + +-- | Set password for user. This function should be used for setting +-- passwords. It generates random salt and calculates proper hashes. +setPassword :: (MonadIO m, HashDBUser user) => Text -> user -> m user +setPassword pwd u = do salt <- randomSalt + return $ setUserHashAndSalt salt (saltedHash salt pwd) u + + +---------------------------------------------------------------- +-- Authentification +---------------------------------------------------------------- + +-- | Given a user ID and password in plaintext, validate them against +-- the database values. +validateUser :: ( YesodPersist yesod + , PersistBackend (YesodDB yesod (GGHandler sub yesod IO)) + , PersistEntity user + , HashDBUser user + ) => + Unique user -- ^ User unique identifier + -> Text -- ^ Password in plaint-text + -> GHandler sub yesod Bool +validateUser userID passwd = do + -- Checks that hash and password match + let validate u = do hash <- userPasswordHash u + salt <- userPasswordSalt u + return $ hash == saltedHash salt passwd + -- Get user data + user <- runDB $ getBy userID + return $ fromMaybe False $ validate . snd =<< user + + +login :: AuthRoute +login = PluginR "hashdb" ["login"] + + +-- | Handle the login form. First parameter is function which maps +-- username (whatever it might be) to unique user ID. +postLoginR :: ( YesodAuth y, YesodPersist y + , HashDBUser user, PersistEntity user + , PersistBackend (YesodDB y (GGHandler Auth y IO))) + => (Text -> Maybe (Unique user)) + -> GHandler Auth y () +postLoginR uniq = do + (mu,mp) <- runInputPost $ (,) + <$> iopt textField "username" + <*> iopt textField "password" + + isValid <- fromMaybe (return False) + (validateUser <$> (uniq =<< mu) <*> mp) + if isValid + then setCreds True $ Creds "hashdb" (fromMaybe "" mu) [] + else do setMessage [QQ(html)| Invalid username/password |] + toMaster <- getRouteToMaster + redirect RedirectTemporary $ toMaster LoginR + + +-- | A drop in for the getAuthId method of your YesodAuth instance which +-- can be used if authHashDB is the only plugin in use. +getAuthIdHashDB :: ( YesodAuth master, YesodPersist master + , HashDBUser user, PersistEntity user + , Key user ~ AuthId master + , PersistBackend (YesodDB master (GGHandler sub master IO))) + => (AuthRoute -> Route master) -- ^ your site's Auth Route + -> (Text -> Maybe (Unique user)) -- ^ gets user ID + -> Creds master -- ^ the creds argument + -> GHandler sub master (Maybe (AuthId master)) +getAuthIdHashDB authR uniq creds = do + muid <- maybeAuth + case muid of + -- user already authenticated + Just (uid, _) -> return $ Just uid + Nothing -> do + x <- case uniq (credsIdent creds) of + Nothing -> return Nothing + Just u -> runDB (getBy u) + case x of + -- user exists + Just (uid, _) -> return $ Just uid + Nothing -> do + setMessage [QQ(html)| User not found |] + redirect RedirectTemporary $ authR LoginR + +-- | Prompt for username and password, validate that against a database +-- which holds the username and a hash of the password +authHashDB :: ( YesodAuth m, YesodPersist m + , HashDBUser user + , PersistEntity user + , PersistBackend (YesodDB m (GGHandler Auth m IO))) + => (Text -> Maybe (Unique user)) -> AuthPlugin m +authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> addHamlet + [QQ(hamlet)| +