yesod-auth-bcryptdb (empty) → 0.1.0.0

raw patch · 5 files changed

+426/−0 lines, 5 filesdep +aesondep +basedep +bcryptsetup-changed

Dependencies added: aeson, base, bcrypt, bytestring, persistent, text, yesod-auth, yesod-core, yesod-form, yesod-persistent

Files

• LICENSE +21/−0
• README.md +2/−0
• Setup.hs +2/−0
• src/Yesod/Auth/BCryptDB.hs +356/−0
• yesod-auth-bcryptdb.cabal +45/−0

@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2017 Yusent Chig++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,2 @@+# yesod-auth-bcryptdb+Yesod.Auth.BcryptDB plugin

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,356 @@+{-# LANGUAGE ConstraintKinds   #-}+{-# LANGUAGE CPP               #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}+{-# LANGUAGE TypeFamilies      #-}+-------------------------------------------------------------------------------+-- |+-- Module      :  Yesod.Auth.BCryptDB+-- Copyright   :  (c) Yusent Chig 2017+-- License     :  MIT+--+-- Maintainer  :  Yusent Chig <yusent@protonmail.com>+-- Stability   :  Stable+-- Portability :  Portable+--+-- A Yesod authentication plugin designed to look users up in a Persistent+-- database where the salted hash of their password is stored. This is based+-- on Yesod.Auth.HashDB plugin, but it uses BCrypt to hash and salt the+-- passwords.+--+-- To use this in a Yesod application, the foundation data type must be an+-- instance of YesodPersist, and the username and hashed passwords should+-- be added to the database.  The following steps give an outline of what+-- is required.+--+-- You need a database table to store user records: in a scaffolded site it+-- might look like:+--+-- > User+-- >     name Text             -- user name used to uniquely identify users+-- >     password Text Maybe   -- password hash for BCryptDB+-- >     UniqueUser name+--+-- Create an instance of 'BCryptDBUser' for this data type:+--+-- > import Yesod.Auth.BcryptDB (BcryptDBUser(..))+-- > ....+-- > instance BcryptDBUser User where+-- >     userPasswordSaltedHash = userPassword+-- >     setPasswordSaltedHash h u = u { userPassword = h }+--+-- In the YesodAuth instance declaration for your app, include 'authBcryptDB'+-- like so:+--+-- > import Yesod.Auth.BcryptDB (authBcryptDB)+-- > ....+-- > instance YesodAuth App where+-- >     ....+-- >     authPlugins _ = [ authBcryptDB UniqueUser, .... ]+--+-- The argument to 'authBcryptDB' is a function which takes a 'Text' and+-- produces a 'Unique' value to look up in the User table. The example+-- @UniqueUser@ shown here works for the model outlined above.+--+-- For a real application, the developer should provide some sort of+-- of administrative interface for setting passwords; it needs to call+-- 'setPassword' and save the result in the database.  However, if you+-- need to initialise the database by hand, you can generate the correct+-- password hash as follows:+--+-- > ghci -XOverloadedStrings+-- > > import Crypto.BCrypt+-- > > hashPasswordUsingPolicy slowerBcryptHashingPolicy "mypassword"+--+-- == Custom Login Form+--+-- Instead of using the built-in HTML form, a custom one can be supplied+-- by using 'authBcryptDBWithForm' instead of 'authBcryptDB'.+--+-- The custom form needs to be given as a function returning a Widget, since+-- it has to build in the supplied "action" URL, and it must provide two text+-- fields called "username" and "password".  For example, the following+-- modification of the outline code given above would replace the default+-- form with a very minimal one which has no labels and a simple layout.+--+-- > instance YesodAuth App where+-- >     ....+-- >     authPlugins _ = [ authBcryptDBWithForm myform UniqueUser, .... ]+-- >+-- > myform :: Route App -> Widget+-- > myform action = $(whamletFile "templates/loginform.hamlet")+--+-- where templates/loginform.hamlet contains+--+-- > <form method="post" action="@{action}">+-- >     <input name="username">+-- >     <input type="password" name="password">+-- >     <input type="submit" value="Login">+--+-- If a CSRF token needs to be embedded in a custom form, code must be+-- included in the widget to add it - see @defaultForm@ in the source+-- code of this module for an example.+--+-- == JSON Interface+--+-- This plugin provides sufficient tools to build a complete JSON-based+-- authentication flow.  We assume that a design goal is to avoid URLs+-- being built into the client, so all of the URLs needed are passed in+-- JSON data.+--+-- To start the process, Yesod's defaultErrorHandler produces a JSON+-- response if the HTTP Accept header gives \"application/json\"+-- precedence over HTML.  For a NotAuthenticated error, the status is+-- 401 and the response contains the URL to use for authentication: this+-- is the route which will be handled by the loginHandler method of the+-- YesodAuth instance, which normally returns a login form.+--+-- Leaving the loginHandler aside for a moment, the final step - supported+-- by this plugin since version 1.6 - is to POST the credentials for+-- authentication in a JSON object.  This object must include the+-- properties "username" and "password".  In the HTML case this would be+-- the form submission, but here we want to use JSON instead.+--+-- In a JSON interface, the purpose of the loginHandler is to tell the+-- client the URL for submitting the credentials.  This requires a+-- custom loginHandler, since the default one generates HTML only.+-- It can find the correct URL by using the 'submitRouteBcryptDB'+-- function defined in this module.+--+-- Writing the loginHandler is made a little messy by the fact that its+-- type allows only HTML content.  A work-around is to send JSON as a+-- short-circuit response, but we still make the choice using selectRep+-- so as to get its matching of content types.  Here is an example which+-- is geared around using BcryptDB on its own, supporting both JSON and HTML+-- clients:+--+-- > instance YesodAuth App where+-- >    ....+-- >    loginHandler = do+-- >         submission <- submitRouteBcryptDB+-- >         render <- lift getUrlRender+-- >         typedContent@(TypedContent ct _) <- selectRep $ do+-- >             provideRepType typeHtml $ return emptyContent+-- >                            -- Dummy: the real Html version is at the end+-- >             provideJson $ object [("loginUrl", toJSON $ render submission)]+-- >         when (ct == typeJson) $+-- >             sendResponse typedContent   -- Short-circuit JSON response+-- >         defaultLoginHandler             -- Html response+--+-------------------------------------------------------------------------------+module Yesod.Auth.BCryptDB+  ( BCryptDBUser(..)+  , setPassword+  -- * Interface to database and Yesod.Auth+  , authBCryptDB+  , authBCryptDBWithForm+  , submitRouteBcryptDB+  , validateCreds+  ) where++#if __GLASGOW_HASKELL__ < 710+import Control.Applicative                   ((<$>), (<*>), pure)+#endif+import Crypto.BCrypt+import Data.Aeson                            ((.:?))+import qualified Data.ByteString.Char8 as BS (pack, unpack)+import Data.Text                             (Text, pack, unpack)+import Data.Maybe                            (fromMaybe)+import Yesod.Auth+import Yesod.Core+import Yesod.Form+import Yesod.Persist+import Yesod.Auth.Message                    (AuthMessage(InvalidUsernamePass))++#if !MIN_VERSION_yesod_core(1,4,14)+defaultCsrfParamName :: Text+defaultCsrfParamName = "_token"+#endif++type Password = Text++-- | The type representing user information stored in the database should+--   be an instance of this class.  It just provides the getter and setter+--   used by the functions in this module.+class BCryptDBUser user where+  -- | Setter used by 'setPassword' and 'upgradePasswordHash'.  Produces a+  --   version of the user data with the hash set to the new value.+  --+  setPasswordSaltedHash+    :: Text -- ^ Password hash+    -> user+    -> user++  -- | Getter used by 'validatePass' and 'upgradePasswordHash' to+  --   retrieve the password hash from user data+  --+  userPasswordSaltedHash :: user -> Text++  {-# MINIMAL setPasswordSaltedHash, userPasswordSaltedHash #-}++-- | Calculate salted hash using Bcrypt.+saltAndHashPassword :: Password -> HashingPolicy -> IO (Maybe Text)+saltAndHashPassword password hashingPolicy = do+   hash <- hashPasswordUsingPolicy hashingPolicy . BS.pack $ unpack password+   return $ pack . BS.unpack <$> hash++-- | Set password for user. This function should be used for setting+--   passwords. It generates random salt and calculates proper hashes.+setPassword :: BCryptDBUser user => Password -> HashingPolicy -> user -> IO user+setPassword password hashingPolicy user = do+    mHash <- saltAndHashPassword password hashingPolicy+    return $ case mHash of+                  Nothing   -> user+                  Just hash -> setPasswordSaltedHash hash user++----------------------------------------------------------------+-- Authentication+----------------------------------------------------------------++-- | Given a user ID and password in plain text, validate them against+--   the database values.+validateCreds+  :: BCryptDBPersist master user+  => Unique user                 -- ^ User unique identifier+  -> Password+  -> HandlerT master IO Bool+validateCreds userID password = do+  -- Checks that hash and password match+  mUser <- runDB $ getBy userID++  return $ case mUser of+                Nothing -> False++                Just (Entity _ user) ->+                  validatePassword+                    (BS.pack . unpack $ userPasswordSaltedHash user)+                    (BS.pack $ unpack password)++----------------------------------------------------------------+-- Interface to database and Yesod.Auth+----------------------------------------------------------------++-- | Constraint for types of interface functions in this module+--+type BCryptDBPersist master user =+  ( YesodAuthPersist master+  , PersistUnique (YesodPersistBackend master)+  , AuthEntity master ~ user+#if MIN_VERSION_persistent(2,5,0)+  , PersistEntityBackend user ~ BaseBackend (YesodPersistBackend master)+#else+  , PersistEntityBackend user ~ YesodPersistBackend master+#endif+  , BCryptDBUser user+  , PersistEntity user+  )++-- Internal data type for receiving JSON encoded username and password+data UserPass = UserPass (Maybe Text) (Maybe Text)++instance FromJSON UserPass where+  parseJSON (Object v) = UserPass <$> v .:? "username" <*> v .:? "password"+  parseJSON _          = pure $ UserPass Nothing Nothing++login :: AuthRoute+login = PluginR "bcryptdb" ["login"]++-- | Handle the login form. First parameter is function which maps+--   username (whatever it might be) to unique user ID.+postLoginR+  :: BCryptDBPersist master user+  => (Text -> Unique user)+  -> HandlerT Auth (HandlerT master IO) TypedContent+postLoginR uniq = do+  jsonContent <- fmap ((== "application/json") . simpleContentType)+             <$> lookupHeader "Content-Type"++  UserPass mUser mPass <-+      case jsonContent of+           Just True -> requireJsonBody+           _         -> lift . runInputPost $ UserPass+                          <$> iopt textField "username"+                          <*> iopt textField "password"++  isValid <- lift . fromMaybe (return False)+                  $ validateCreds <$> fmap uniq mUser <*> mPass++  if isValid+      then lift . setCredsRedirect $ Creds "bcryptdb" (fromMaybe "" mUser) []+      else loginErrorMessageI LoginR InvalidUsernamePass++-- | Prompt for username and password, validate that against a database+--   which holds the username and a salted hash of the password+authBCryptDB+  :: BCryptDBPersist master user+  => (Text -> Unique user)+  -> AuthPlugin master+authBCryptDB = authBCryptDBWithForm defaultForm++-- | Like 'authBCryptDB', but with an extra parameter to supply a custom HTML+-- form.+--+-- The custom form should be specified as a function which takes a route to+-- use as the form action, and returns a Widget containing the form.  The+-- form must use the supplied route as its action URL, and, when submitted,+-- it must send two text fields called "username" and "password".+--+-- Please see the example in the documentation at the head of this module.+--+authBCryptDBWithForm+  :: BCryptDBPersist master user+  => (Route master -> WidgetT master IO ())+  -> (Text -> Unique user)+  -> AuthPlugin master+authBCryptDBWithForm form uniq =+  AuthPlugin "bcryptdb" dispatch $ \tm -> form (tm login)+  where+    dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse+    dispatch _ _              = notFound++defaultForm :: Yesod app => Route app -> WidgetT app IO ()+defaultForm loginRoute = do+  request <- getRequest+  let mtok = reqToken request+  toWidget [hamlet|+    $newline never+    <div id="header">+      <h1>Login++    <div id="login">+      <form method="post" action="@{loginRoute}">+        $maybe tok <- mtok+          <input type=hidden name=#{defaultCsrfParamName} value=#{tok}>+        <table>+          <tr>+            <th>Username:+            <td>+              <input id="x" name="username" autofocus="" required>+          <tr>+            <th>Password:+            <td>+              <input type="password" name="password" required>+          <tr>+            <td>&nbsp;+            <td>+              <input type="submit" value="Login">++        <script>+          if (!("autofocus" in document.createElement("input"))) {+            document.getElementById("x").focus();+          }+  |]++-- | The route, in the parent site, to which the username and password+--   should be sent in order to log in.  This function is particularly+--   useful in constructing a 'loginHandler' function which provides a+--   JSON response.  See the \"JSON Interface\" section above for more+--   details.+--+submitRouteBcryptDB+  :: YesodAuth site+  => HandlerT Auth (HandlerT site IO) (Route site)+submitRouteBcryptDB = do+    toParent <- getRouteToParent+    return $ toParent login

@@ -0,0 +1,45 @@+name:                yesod-auth-bcryptdb+version:             0.1.0.0+synopsis:            Authentication plugin for Yesod.+description:+  This package provides authentication with passwords hashed and salted using+  bcrypt which are stored in a database, and works best in situations where an+  administrator is involved in setting up a user with an initial password.+  .+  The complete login process, including a default form, is implemented by+  this plugin, but the application developer must design the interfaces+  for setting up users and allowing them to change their own passwords,+  since only the low-level password-setting functions are provided by this+  package.  (Note that other authentication plugins may be more appropriate+  if you wish to use email verification to set up accounts).+homepage:            https://github.com/yusent/yesod-auth-bcryptdb+bug-reports:         https://github.com/yusent/yesod-auth-bcryptdb/issues+license:             MIT+license-file:        LICENSE+author:              Yusent Chig+maintainer:          Yusent Chig <yusent@protonmail.com>+copyright:           2017 Yusent Chig+category:            Web, Yesod+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  build-depends:       aeson+                     , base >= 4 && < 5+                     , bcrypt >= 0.0.10 && < 0.1+                     , bytestring >= 0.9.1.4+                     , persistent >= 2.1 && < 2.8+                     , text >= 0.7+                     , yesod-auth >= 1.4.18 && < 1.5+                     , yesod-core >= 1.4 && < 1.5+                     , yesod-form >= 1.4 && < 1.5+                     , yesod-persistent >= 1.2+  default-language:    Haskell2010+  exposed-modules:     Yesod.Auth.BCryptDB+  ghc-options:         -Wall+  hs-source-dirs:      src++source-repository head+  type:     git+  location: https://github.com/yusent/yesod-auth-bcryptdb