Merge pull request #8 from Shimuuar/master

HashDB improvements and refactorings

Yesod/Auth.hs

@@ -22,19 +22,27 @@ module Yesod.Auth
     , 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 (hamlet)
+
 import Yesod.Core
 import Yesod.Persist
 import Yesod.Json
-import Language.Haskell.TH.Syntax hiding (lift)
-import qualified Network.Wai as W
-import Text.Hamlet (hamlet)
-import qualified Data.Map as Map
-import Control.Monad.Trans.Class (lift)
-import Data.Aeson
-import Data.Text (Text)
-import qualified Data.Text as T
-import Data.Text.Encoding (decodeUtf8With)
-import Data.Text.Encoding.Error (lenientDecode)
 import Yesod.Auth.Message (AuthMessage, defaultMessage)
 import qualified Yesod.Auth.Message as Msg
 import Yesod.Form (FormMessage)
@@ -91,11 +99,7 @@ mkYesodSub "Auth"
     [ ClassP ''YesodAuth [VarT $ mkName "master"]
     ]
 #define STRINGS *Texts
-#if GHC7
+    [QQ(parseRoutes)|
-    [parseRoutes|
-#else
-    [$parseRoutes|
-#endif
 /check                 CheckR      GET
 /login                 LoginR      GET
 /logout                LogoutR     GET POST
@@ -108,34 +112,21 @@ credsKey = "_ID"
 -- | FIXME: won't show up till redirect
 setCreds :: YesodAuth m => Bool -> Creds m -> GHandler s m ()
 setCreds doRedirects creds = do
-    y <- getYesod
+    y    <- getYesod
     maid <- getAuthId creds
     case maid of
         Nothing ->
-            if doRedirects
+          when doRedirects $ do
-                then do
+            case authRoute y of
-                    case authRoute y of
+              Nothing -> do rh <- defaultLayout [QQ(hamlet)| <h1>Invalid login |]
-                        Nothing -> do
-                            rh <- defaultLayout
-#if GHC7
-                                [hamlet|
-#else
-                                [$hamlet|
-#endif
-                                <h1>Invalid login
-|]
                             sendResponse rh
-                        Just ar -> do
+              Just ar -> do setMessageI Msg.InvalidLogin
-                            setMessageI Msg.InvalidLogin
                             redirect RedirectTemporary ar
-                else return ()
         Just aid -> do
             setSession credsKey $ toSinglePiece aid
-            if doRedirects
+            when doRedirects $ do
-                then do
+              setMessageI Msg.NowLoggedIn
-                    setMessageI Msg.NowLoggedIn
+              redirectUltDest RedirectTemporary $ loginDest y
-                    redirectUltDest RedirectTemporary $ loginDest y
-                else return ()
 
 getCheckR :: YesodAuth m => GHandler Auth m RepHtmlJson
 getCheckR = do
@@ -145,11 +136,7 @@ getCheckR = do
         addHtml $ html creds) (json' creds)
   where
     html creds =
-#if GHC7
+        [QQ(hamlet)|
-        [hamlet|
-#else
-        [$hamlet|
-#endif
 <h1>Authentication Status
 $maybe _ <- creds
     <p>Logged in.
@@ -195,15 +182,10 @@ maybeAuth :: ( YesodAuth m
              , PersistEntity val
              , YesodPersist m
              ) => GHandler s m (Maybe (Key val, val))
-maybeAuth = do
+maybeAuth = runMaybeT $ do
-    maid <- maybeAuthId
+    aid <- MaybeT $ maybeAuthId
-    case maid of
+    a   <- MaybeT $ runDB $ get aid
-        Nothing -> return Nothing
+    return (aid, a)
-        Just aid -> do
-            ma <- runDB $ get aid
-            case ma of
-                Nothing -> return Nothing
-                Just a -> return $ Just (aid, a)
 
 requireAuthId :: YesodAuth m => GHandler s m (AuthId m)
 requireAuthId = maybeAuthId >>= maybe redirectLogin return

Yesod/Auth/Dummy.hs

@@ -8,6 +8,8 @@ module Yesod.Auth.Dummy
     ( authDummy
     ) where
 
+#include "qq.h"
+
 import Yesod.Auth
 import Yesod.Form (runInputPost, textField, ireq)
 import Yesod.Handler (notFound)
@@ -23,11 +25,7 @@ authDummy =
     dispatch _ _ = notFound
     url = PluginR "dummy" []
     login authToMaster =
-#if GHC7
+        [QQ(hamlet)|
-        [hamlet|
-#else
-        [$hamlet|
-#endif
 <form method="post" action="@{authToMaster url}">
     \Your new identifier is: 
     <input type="text" name="ident">

Yesod/Auth/Email.hs

@@ -14,6 +14,8 @@ module Yesod.Auth.Email
     , setpassR
     ) where
 
+#include "qq.h"
+
 import Network.Mail.Mime (randomString)
 import Yesod.Auth
 import System.Random
@@ -81,11 +83,7 @@ authEmail =
     AuthPlugin "email" dispatch $ \tm -> do
         y <- lift getYesod
         l <- lift languages
-#if GHC7
+        [QQ(whamlet)|
-        [whamlet|
-#else
-        [$whamlet|
-#endif
 <form method="post" action="@{tm loginR}">
     <table>
         <tr>
@@ -119,11 +117,7 @@ getRegisterR = do
     defaultLayout $ do
         setTitleI Msg.RegisterLong
         addWidget
-#if GHC7
+            [QQ(whamlet)|
-            [whamlet|
-#else
-            [$whamlet|
-#endif
 <p>_{Msg.EnterEmail}
 <form method="post" action="@{toMaster registerR}">
     <label for="email">_{Msg.Email}
@@ -154,13 +148,7 @@ postRegisterR = do
     defaultLayout $ do
         setTitleI Msg.ConfirmationEmailSentTitle
         addWidget
-#if GHC7
+            [QQ(whamlet)| <p>_{Msg.ConfirmationEmailSent email} |]
-            [whamlet|
-#else
-            [$whamlet|
-#endif
-<p>_{Msg.ConfirmationEmailSent email}
-|]
 
 getVerifyR :: YesodAuthEmail m
            => AuthEmailId m -> Text -> GHandler Auth m RepHtml
@@ -181,13 +169,7 @@ getVerifyR lid key = do
     defaultLayout $ do
         setTitleI Msg.InvalidKey
         addWidget
-#if GHC7
+            [QQ(whamlet)| <p>_{Msg.InvalidKey} |]
-            [whamlet|
-#else
-            [$whamlet|
-#endif
-<p>_{Msg.InvalidKey}
-|]
 
 postLoginR :: YesodAuthEmail master => GHandler Auth master ()
 postLoginR = do
@@ -226,11 +208,7 @@ getPasswordR = do
     defaultLayout $ do
         setTitleI Msg.SetPassTitle
         addWidget
-#if GHC7
+            [QQ(whamlet)|
-            [whamlet|
-#else
-            [$whamlet|
-#endif
 <h3>_{Msg.SetPass}
 <form method="post" action="@{toMaster setpassR}">
     <table>

Yesod/Auth/Facebook.hs

@@ -6,6 +6,8 @@ module Yesod.Auth.Facebook
     , facebookUrl
     ) where
 
+#include "qq.h"
+
 import Yesod.Auth
 import qualified Web.Authenticate.Facebook as Facebook
 import Data.Aeson
@@ -56,11 +58,7 @@ authFacebook cid secret perms =
         render <- lift getUrlRender
         let fb = Facebook.Facebook cid secret $ render $ tm url
         let furl = Facebook.getForwardUrl fb $ perms
-#if GHC7
+        [QQ(whamlet)|
-        [whamlet|
-#else
-        [$whamlet|
-#endif
 <p>
     <a href="#{furl}">_{Msg.Facebook}
 |]

Yesod/Auth/HashDB.hs

@@ -16,8 +16,7 @@
 -- 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
+-- their user id's and a salted SHA1 hash of their password is stored.
--- stored.
 --
 -- Example usage:
 --
@@ -37,10 +36,8 @@
 -- >
 -- >    loginDest _  = RootR
 -- >    logoutDest _ = RootR
--- >    getAuthId    = getAuthIdHashDB AuthR 
+-- >    getAuthId    = getAuthIdHashDB AuthR (Just . UniqueUser)
--- >    showAuthId _ = showIntegral
+-- >    authPlugins  = [authHashDB (Just . UniqueUser)]
--- >    readAuthId _ = readIntegral
--- >    authPlugins  = [authHashDB]
 -- >
 -- >
 -- > -- include the migration function in site startup
@@ -49,21 +46,31 @@
 -- >     runSqlPool (runMigration migrateUsers) p
 -- >     let h = DevSite p
 --
--- Your app must be an instance of YesodPersist and the username and
+-- Note that function which converts username to unique identifier must be same.
--- hashed-passwords must be added manually to the database.
 --
--- > echo -n 'MyPassword' | sha1sum
+-- 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
-    ( authHashDB
+    ( 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
@@ -71,115 +78,130 @@ import Yesod.Auth
 import Text.Hamlet (hamlet)
 
 import Control.Applicative         ((<$>), (<*>))
-import Data.ByteString.Lazy.Char8  (pack)
+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, unpack)
+import Data.Text                   (Text, pack, unpack, append)
 import Data.Maybe                  (fromMaybe)
+import System.Random               (randomRIO)
 
--- | 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
+-- | Interface for data type which holds user info. It's just a
-share2 mkPersist (mkMigrate "migrateUsers")
+--   collection of getters and setters
-#if GHC7
+class HashDBUser user where
-            [persist|
+  -- | Retrieve password hash from user data
-#else
+  userPasswordHash :: user -> Maybe Text
-            [$persist|
+  -- | Retrieve salt for password
-#endif
+  userPasswordSalt :: user -> Maybe Text
-User
+  -- | Set hash and password
-    username Text Eq
+  setUserHashAndSalt :: Text    -- ^ Salt
-    password Text
+                     -> Text    -- ^ Password hash
-    UniqueUser username
+                     -> 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
 
--- | Given a (user,password) in plaintext, validate them against the
---   database values
-validateUser :: (YesodPersist y, 
-                 PersistBackend (YesodDB y (GGHandler sub y IO))) 
-             => (Text, Text) 
-             -> 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 (unpack password) == unpack (userPassword sqlUser)
 
 login :: AuthRoute
 login = PluginR "hashdb" ["login"]
 
--- | Handle the login form
+
-postLoginR :: (YesodAuth y,
+-- | Handle the login form. First parameter is function which maps
-               YesodPersist y, 
+--   username (whatever it might be) to unique user ID.
-               PersistBackend (YesodDB y (GGHandler Auth y IO)))
+postLoginR :: ( YesodAuth y, YesodPersist y
-           => GHandler Auth y ()
+              , HashDBUser user, PersistEntity user
-postLoginR = do
+              , 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 <- case (mu,mp) of
+    isValid <- fromMaybe (return False) 
-        (Nothing, _      ) -> return False
+                 (validateUser <$> (uniq =<< mu) <*> mp)
-        (_      , Nothing) -> return False
+    if isValid 
-        (Just u , Just p ) -> validateUser (u,p)
+       then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
+       else do setMessage [QQ(hamlet)| Invalid username/password |]
+               toMaster <- getRouteToMaster
+               redirect RedirectTemporary $ toMaster LoginR
 
-    if isValid
-        then setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
-        else do
-            setMessage
-#if GHC7
-                [hamlet|
-#else
-                [$hamlet|
-#endif
-    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,
+getAuthIdHashDB :: ( YesodAuth master, YesodPersist master
-                    PersistBackend (YesodDB master (GGHandler sub master IO)),
+                   , HashDBUser user, PersistEntity user
-                    YesodPersist master,
+                   , Key user ~ AuthId master
-                    YesodAuth master)
+                   , PersistBackend (YesodDB master (GGHandler sub master IO)))
-                => (AuthRoute -> Route master) -- ^ your site's Auth Route
+                => (AuthRoute -> Route master)   -- ^ your site's Auth Route
-                -> Creds m                     -- ^ the creds argument
+                -> (Text -> Maybe (Unique user)) -- ^ gets user ID
-                -> GHandler sub master (Maybe UserId)
+                -> Creds master                  -- ^ the creds argument
-getAuthIdHashDB authR creds = do
+                -> 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 <- runDB $ getBy $ UniqueUser (credsIdent creds)
+            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
+                    setMessage [QQ(hamlet)| User not found |]
-#if GHC7
-                        [hamlet|
-#else
-                        [$hamlet|
-#endif
-    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,
+authHashDB :: ( YesodAuth m, YesodPersist m
-               YesodPersist y, 
+              , HashDBUser user
-               PersistBackend (YesodDB y (GGHandler Auth y IO)))
+              , PersistEntity user
-           => AuthPlugin y
+              , PersistBackend (YesodDB m (GGHandler Auth m IO))) 
-authHashDB = AuthPlugin "hashdb" dispatch $ \tm ->
+           => (Text -> Maybe (Unique user)) -> AuthPlugin m
-#if GHC7
+authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm ->
-    [hamlet|
+    [QQ(hamlet)|
-#else
-    [$hamlet|
-#endif
     <div id="header">
         <h1>Login
 
@@ -206,5 +228,27 @@ authHashDB = AuthPlugin "hashdb" dispatch $ \tm ->
 
 |]
     where
-        dispatch "POST" ["login"] = postLoginR >>= sendResponse
+        dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse
         dispatch _ _              = notFound
+
+
+----------------------------------------------------------------
+-- Predefined datatype
+----------------------------------------------------------------
+
+-- | Generate data base instances for a valid user
+share2 mkPersist (mkMigrate "migrateUsers")
+         [QQ(persist)|
+User
+    username Text Eq
+    password Text
+    salt     Text
+    UniqueUser username
+|]
+
+instance HashDBUser User where
+  userPasswordHash = Just . userPassword
+  userPasswordSalt = Just . userSalt
+  setUserHashAndSalt s h u = u { userSalt     = s
+                               , userPassword = h
+                               }

Yesod/Auth/OAuth.hs

@@ -6,6 +6,9 @@ module Yesod.Auth.OAuth
     , authTwitter
     , twitterUrl
     ) where
+
+#include "qq.h"
+
 import Yesod.Auth
 import Yesod.Form
 import Yesod.Handler
@@ -66,13 +69,7 @@ authOAuth name ident reqUrl accUrl authUrl key sec = AuthPlugin name dispatch lo
         render <- lift getUrlRender
         let oaUrl = render $ tm $ oauthUrl name
         addHtml
-#if GHC7
+          [QQ(hamlet)| <a href=#{oaUrl}>Login with #{name} |]
-          [hamlet|
-#else
-          [$hamlet|
-#endif
-             <a href=#{oaUrl}>Login with #{name}
-          |]
 
 authTwitter :: YesodAuth m =>
                String -- ^ Consumer Key

Yesod/Auth/OpenId.hs

@@ -6,6 +6,8 @@ module Yesod.Auth.OpenId
     , forwardUrl
     ) where
 
+#include "qq.h"
+
 import Yesod.Auth
 import qualified Web.Authenticate.OpenId as OpenId
 import Control.Monad.Attempt
@@ -34,20 +36,12 @@ authOpenId =
         ident <- lift newIdent
         y <- lift getYesod
         addCassius
-#if GHC7
+            [QQ(cassius)|##{ident}
-            [cassius|##{ident}
-#else
-            [$cassius|##{ident}
-#endif
     background: #fff url(http://www.myopenid.com/static/openid-icon-small.gif) no-repeat scroll 0pt 50%;
     padding-left: 18px;
 |]
         l <- lift languages
-#if GHC7
+        [QQ(whamlet)|
-        [whamlet|
-#else
-        [$whamlet|
-#endif
 <form method="get" action="@{tm forwardUrl}">
     <label for="#{ident}">OpenID: #
     <input id="#{ident}" type="text" name="#{name}" value="http://">

Yesod/Auth/Rpxnow.hs

@@ -5,6 +5,8 @@ module Yesod.Auth.Rpxnow
     ( authRpxnow
     ) where
 
+#include "qq.h"
+
 import Yesod.Auth
 import qualified Web.Authenticate.Rpxnow as Rpxnow
 import Control.Monad (mplus)
@@ -27,11 +29,7 @@ authRpxnow app apiKey =
     login tm = do
         let url = {- FIXME urlEncode $ -} tm $ PluginR "rpxnow" []
         addHamlet
-#if GHC7
+            [QQ(hamlet)|
-            [hamlet|
-#else
-            [$hamlet|
-#endif
 <iframe src="http://#{app}.rpxnow.com/openid/embed?token_url=@{url}" scrolling="no" frameBorder="no" allowtransparency="true" style="width:400px;height:240px">
 |]
     dispatch _ [] = do

include/qq.h

@@ -0,0 +1,10 @@
+
+-- CPP macro which choses which quasyquotes syntax to use depending
+-- on GHC version.
+--
+-- QQ stands for quasyquote.
+#if GHC7
+# define QQ(x) x
+#else
+# define QQ(x) $x
+#endif

yesod-auth.cabal

@@ -53,6 +53,8 @@ library
                      Yesod.Auth.HashDB
                      Yesod.Auth.Message
     ghc-options:     -Wall
+    include-dirs:
+                     include
 
 source-repository head
   type:     git