diff --git a/Yesod/Helpers/Auth/HashDB.hs b/Yesod/Helpers/Auth/HashDB.hs new file mode 100644 index 00000000..86673107 --- /dev/null +++ b/Yesod/Helpers/Auth/HashDB.hs @@ -0,0 +1,177 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +------------------------------------------------------------------------------- +-- | +-- Module : Yesod.Helpers.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 sha1 hash of their password will already be +-- stored. +-- +-- Example usage: +-- +-- > -- import the function +-- > import Helpers.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 +-- > showAuthId _ = showIntegral +-- > readAuthId _ = readIntegral +-- > authPlugins = [authHashDB] +-- > +-- > +-- > -- 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 +-- +-- Your app must be an instance of YesodPersist and the username and +-- hashed-passwords must be added manually to the database. +-- +-- > echo -n 'MyPassword' | sha1sum +-- +-- can be used to get the hash from the commandline. +-- +------------------------------------------------------------------------------- +module Helpers.Auth.HashDB + ( authHashDB + , getAuthIdHashDB + , UserId + , migrateUsers + ) where + +import Yesod +import Yesod.Helpers.Auth + +import Control.Applicative ((<$>), (<*>)) +import Data.ByteString.Lazy.Char8 (pack) +import Data.Digest.Pure.SHA (sha1, showDigest) +import Database.Persist.TH (share2) +import Database.Persist.GenericSql (mkMigrate) + +-- | Computer the sha1 of a string and return it as a string +sha1String :: String -> String +sha1String = showDigest . sha1 . pack + +-- | Generate data base instances for a valid user +share2 mkPersist (mkMigrate "migrateUsers") [$persist| +User + username String Eq + password String + UniqueUser username +|] + +-- | Given a (user,password) in plaintext, validate them against the +-- database values +validateUser :: (YesodPersist y, + PersistBackend (YesodDB y (GHandler sub y))) + => (String, String) + -> GHandler sub y Bool +validateUser (user,password) = runDB (getBy $ UniqueUser user) >>= \dbUser -> + case dbUser of + -- user not found + Nothing -> return False + -- validate password + Just (_, sqlUser) -> return $ sha1String password == userPassword sqlUser + +login :: AuthRoute +login = PluginR "hashdb" ["login"] + +-- | Handle the login form +postLoginR :: (YesodAuth y, + YesodPersist y, + PersistBackend (YesodDB y (GHandler Auth y))) + => GHandler Auth y () +postLoginR = do + (user, password) <- runFormPost' $ (,) + <$> stringInput "username" + <*> stringInput "password" + + isValid <- validateUser (user,password) + + if isValid + then setCreds True $ Creds "hashdb" user [] + else do + setMessage $ [$hamlet| %em 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 :: (Key User ~ AuthId master, + PersistBackend (YesodDB master (GHandler sub master)), + YesodPersist master, + YesodAuth master) + => (AuthRoute -> Route master) -- ^ your site's Auth Route + -> Creds m -- ^ the creds argument + -> GHandler sub master (Maybe UserId) +getAuthIdHashDB authR creds = do + muid <- maybeAuth + case muid of + -- user already authenticated + Just (uid, _) -> return $ Just uid + Nothing -> do + x <- runDB $ getBy $ UniqueUser (credsIdent creds) + case x of + -- user exists + Just (uid, _) -> return $ Just uid + Nothing -> do + setMessage $ [$hamlet| %em 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 y, + YesodPersist y, + PersistBackend (YesodDB y (GHandler Auth y))) + => AuthPlugin y +authHashDB = AuthPlugin "hashdb" dispatch $ \tm -> + [$hamlet| + #header + %h1 Login + + #login + %form!method=post!action=@tm.login@ + %table + %tr + %th Username: + %td + %input#x!name=username!autofocus + %tr + %th Password: + %td + %input!type=password!name=password + %tr + %td   + %td + %input!type=submit!value="Login" + + %script + if (!("autofocus" in document.createElement("input"))) { + document.getElementById("x").focus(); + } + |] + where + dispatch "POST" ["login"] = postLoginR >>= sendResponse + dispatch _ _ = notFound