login via HashDB

Foundation.hs

@@ -4,12 +4,17 @@ import Database.Persist.Sql        (ConnectionPool, runSqlPool)
 import Import.NoFoundation
 import Text.Hamlet                 (hamletFile)
 import Yesod.Auth.BrowserId        (authBrowserId)
+import Yesod.Auth.HashDB           (HashDBUser(..),authHashDB)
 import Yesod.Auth.Message          (AuthMessage (InvalidLogin))
 import qualified Yesod.Core.Unsafe as Unsafe
 import Yesod.Core.Types            (Logger)
 import Yesod.Default.Util          (addStaticContentExternal)
 import Yesod.Fay
 
+instance HashDBUser User where
+    userPasswordHash = userPassword
+    setPasswordHash h u = u { userPassword = Just h }
+
 -- | The foundation datatype for your application. This can be a good place to
 -- keep settings and values requiring initialization before your application
 -- starts running, such as database connections. Every handler will have
@@ -195,7 +200,8 @@ instance YesodAuth App where
                     }
 
     -- You can add other plugins like BrowserID, email or OAuth here
-    authPlugins _ = [authBrowserId def]
+    authPlugins _ = [authBrowserId def,
+                     authHashDB (Just . UniqueUser)]
 
     authHttpManager = getHttpManager
 

Handler/YourAccount.hs

@@ -8,6 +8,8 @@ import Text.Regex.TDFA
 import Data.Conduit.Binary
 import qualified Data.ByteString as S
 import qualified Data.ByteString.Lazy as L
+import Crypto.PasswordStore
+import Yesod.Auth.HashDB (defaultStrength)
 
 getYourAccountR :: Handler Html
 getYourAccountR = do
@@ -26,17 +28,18 @@ postYourAccountR = do
     let accountData = case result of
             FormSuccess res -> Just res
             _ -> Nothing
-        Just (name, localId, sshPubKey, avatarFile) = accountData
+        Just (name, localId, mPassword, sshPubKey, avatarFile) = accountData
     userId <- requireAuthId
-    updateUserAccount userId name localId sshPubKey avatarFile
+    updateUserAccount userId name localId mPassword sshPubKey avatarFile
     defaultLayout $ do
         setTitle "Your account"
         $(widgetFile "your-account")
 
-yourAccountForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form (Maybe Text, Maybe Text, Maybe Text, Maybe FileInfo)
-yourAccountForm maybeName maybeLocalId maybeSshPubKey = renderBootstrap3 BootstrapBasicForm $ (,,,)
+yourAccountForm :: Maybe Text -> Maybe Text -> Maybe Text -> Form (Maybe Text, Maybe Text, Maybe Text, Maybe Text, Maybe FileInfo)
+yourAccountForm maybeName maybeLocalId maybeSshPubKey = renderBootstrap3 BootstrapBasicForm $ (,,,,)
     <$> aopt textField (bfs MsgAccountName) (Just maybeName)
     <*> aopt textField (bfs MsgId) (Just maybeLocalId)
+    <*> aopt passwordConfirmField (bfs MsgPassword) Nothing
     <*> aopt textField (bfs MsgSshPubKey) (Just maybeSshPubKey)
     <*> fileAFormOpt (bfs MsgAvatar)
 
@@ -54,12 +57,18 @@ isLocalIdAcceptable :: Text -> Bool
 isLocalIdAcceptable localId =
   match localIdRegexp (unpack localId) && not (localId `elem` unwantedLocalIds)
 
-updateUserAccount :: Key User -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe FileInfo -> Handler ()
-updateUserAccount userId name maybeLocalId maybeSshPubKey maybeAvatarFile = do
+updateUserAccount :: Key User -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe Text -> Maybe FileInfo -> Handler ()
+updateUserAccount userId name maybeLocalId maybePassword maybeSshPubKey maybeAvatarFile = do
   updateJustName userId name
   updateAvatar userId maybeAvatarFile
   updateLocalIdAndPubKey userId maybeLocalId maybeSshPubKey
+  updatePassword userId maybePassword
 
+updatePassword :: Key User -> Maybe Text -> Handler ()
+updatePassword _ Nothing = return ()
+updatePassword userId (Just password) = do
+  encodedPassword <- liftIO $ makePassword (encodeUtf8 password) defaultStrength
+  runDB $ update userId [UserPassword =. Just (decodeUtf8 encodedPassword)]
 
 updateAvatar :: Key User -> Maybe FileInfo -> Handler ()
 updateAvatar _ Nothing = return ()
@@ -114,3 +123,21 @@ getAvatarR userId = do
        sendResponse (typePng, toContent avatarBytes)
      Nothing -> do
        sendFile typeSvg "static/images/male-avatar.svg"
+
+passwordConfirmField :: Field Handler Text
+passwordConfirmField = Field
+    { fieldParse = \rawVals _fileVals ->
+        case rawVals of
+            [a, b]
+                | a == b -> return $ Right $ Just a
+                | otherwise -> return $ Left "Passwords don't match"
+            [] -> return $ Right Nothing
+            _ -> return $ Left "You must enter two values"
+    , fieldView = \idAttr nameAttr otherAttrs eResult isReq ->
+        [whamlet|
+            <input id=#{idAttr} name=#{nameAttr} *{otherAttrs} type=password>
+            <div>confirm:
+            <input id=#{idAttr}-confirm name=#{nameAttr} *{otherAttrs} type=password>
+        |]
+    , fieldEnctype = UrlEncoded
+    }

gonito.cabal

@@ -127,6 +127,8 @@ library
                  , conduit-extra
                  , resourcet
                  , yesod-newsfeed
+                 , yesod-auth-hashdb
+                 , pwstore-fast
 
 executable         gonito
     if flag(library-only)

messages/en.msg

@@ -25,3 +25,4 @@ CommentText: Write a comment
 Send: Send
 Avatar: avatar
 About: about
+Password: password

templates/your-account.hamlet

@@ -11,6 +11,7 @@
         <ul class="list-group">
             <li class="list-group-item"><b>Name</b> is your human-readable name (to be shown on the leaderboard).
             <li class="list-group-item"><b>ID</b> is used in the URLs for your repos (must be composed of lower-case letters, digits or hyphyns, must start with a lower-case letter).
+            <li class="list-group-item"><b>Password</b> is needed when Persona is closed.
             <li class="list-group-item"><b>SSH public key</b> is needed if you want to access repos hosted on Gonito.net (usually it is <tt>.ssh/id_rsa.pub</tt> in your home directory after you generated private/public key pair).
             <li class="list-group-item">ID cannot be changed once it is set up.
             <li class="list-group-item">You don't need to specify your ID and SSH public key, if you don't use private repos hosted on Gonito.net.