{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE QuasiQuotes                #-}
{-# LANGUAGE ConstraintKinds            #-}
{-# LANGUAGE FlexibleContexts           #-}
{-# LANGUAGE TypeFamilies               #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TemplateHaskell            #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE GADTs                      #-}
{-# LANGUAGE CPP                        #-}
-------------------------------------------------------------------------------
-- |
-- 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 Bcrypt hash + salt 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,
-- salted-and-hashed-passwords should be added to the database.
--
--
-------------------------------------------------------------------------------
module Yesod.Auth.HashDB
    ( HashDBUser(..)
    , Unique (..)
    , setPassword
      -- * Authentification
    , validateUser
    , authHashDB
    , getAuthIdHashDB
      -- * Predefined data type
    , Siteuser
    , SiteuserGeneric (..)
    , SiteuserId
    , EntityField (..)
    , migrateSiteusers
    ) where

import Yesod.Persist
import Yesod.Form
import Yesod.Auth
import Yesod.Core
import Text.Hamlet (hamlet)

import Control.Applicative         ((<$>), (<*>))
import Control.Monad               (replicateM,liftM)
import Data.Typeable

import qualified Data.ByteString.Lazy.Char8 as LBS (pack, unpack)
import qualified Data.ByteString.Char8 as BS (pack, unpack)
import Crypto.BCrypt
import Data.Text                   (Text, pack, unpack, append)
import Data.Maybe                  
import System.Random               (randomRIO)
import Prelude
-- | Interface for data type which holds user info. It's just a
--   collection of getters and setters
class HashDBUser siteuser where
  -- | Retrieve password hash from user data
  siteuserPasswordHash :: siteuser -> Maybe Text


  -- | a callback for setPassword
  setSaltAndPasswordHash :: Text    -- ^ Hash and Salt
                     -> siteuser -> siteuser

-- | Calculate salted hash using Bcrypt.
saltedHash :: Text              -- ^ Password
           -> IO (Maybe Text)
saltedHash password = do
   hash <- (hashPasswordUsingPolicy (HashingPolicy 10 "$2y") . BS.pack . unpack) password
   return $ if (isJust hash)
                then Just $ pack $ BS.unpack $ fromJust hash
                else Nothing

-- | Set password for user. This function should be used for setting
--   passwords. It generates random salt and calculates proper hashes.
setPassword :: (HashDBUser siteuser) => Text -> siteuser -> IO (siteuser)
setPassword pwd u = do 
    hash <- saltedHash pwd
    return $ setSaltAndPasswordHash (fromJust hash) u


----------------------------------------------------------------
-- Authentification
----------------------------------------------------------------

-- | Given a user ID and password in plaintext, validate them against
--   the database values.
validateUser :: ( YesodPersist yesod
                , b ~ YesodPersistBackend yesod
                , PersistMonadBackend (b (HandlerT yesod IO)) ~ PersistEntityBackend siteuser
                , PersistUnique (b (HandlerT yesod IO))
                , PersistEntity siteuser
                , HashDBUser    siteuser
                ) => 
                Unique siteuser     -- ^ User unique identifier
             -> Text            -- ^ Password in plaint-text
             -> HandlerT yesod IO Bool
validateUser siteuserID passwd = do
  -- Checks that hash and password match
  let validate u = do hash <- siteuserPasswordHash u
                      return $ validatePassword (BS.pack $ unpack hash) (BS.pack $ unpack passwd)
  -- Get user data
  siteuser <- runDB $ getBy siteuserID
  return $ fromMaybe False $ validate . entityVal =<< siteuser


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 siteuser, PersistEntity siteuser
              , b ~ YesodPersistBackend y
              , PersistMonadBackend (b (HandlerT y IO)) ~ PersistEntityBackend siteuser
              , PersistUnique (b (HandlerT y IO))
              )
           => (Text -> Maybe (Unique siteuser))
           -> HandlerT Auth (HandlerT y IO) ()
postLoginR uniq = do
    (mu,mp) <- lift $ runInputPost $ (,)
        <$> iopt textField "username"
        <*> iopt textField "password"

    isValid <- lift $ fromMaybe (return False) 
                 (validateUser <$> (uniq =<< mu) <*> mp)
    if isValid 
       then lift $ setCreds True $ Creds "hashdb" (fromMaybe "" mu) []
       else do
           tm <- getRouteToParent
           lift $ loginErrorMessage (tm LoginR) "Invalid username/password"


-- | 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 siteuser, PersistEntity siteuser
                   , Key siteuser ~ AuthId master
                   , b ~ YesodPersistBackend master
                   , PersistMonadBackend (b (HandlerT master IO)) ~ PersistEntityBackend siteuser
                   , PersistUnique (b (HandlerT master IO))
                   )
                => (AuthRoute -> Route master)   -- ^ your site's Auth Route
                -> (Text -> Maybe (Unique siteuser)) -- ^ gets user ID
                -> Creds master                  -- ^ the creds argument
                -> HandlerT master IO (Maybe (AuthId master))
getAuthIdHashDB authR uniq creds = do
    muid <- maybeAuthId
    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 (Entity uid _) -> return $ Just uid
                Nothing       -> loginErrorMessage (authR LoginR) "User not found"

-- | 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 siteuser
              , PersistEntity siteuser
              , b ~ YesodPersistBackend m
              , PersistMonadBackend (b (HandlerT m IO)) ~ PersistEntityBackend siteuser
              , PersistUnique (b (HandlerT m IO)))
           => (Text -> Maybe (Unique siteuser)) -> AuthPlugin m
authHashDB uniq = AuthPlugin "hashdb" dispatch $ \tm -> toWidget [hamlet|
$newline never
    <div id="header">
        <h1>Login

    <div id="login">
        <form method="post" action="@{tm login}">
            <fieldset>
                <label for="username">Username
                <input type="text" name="username">
                <label for="password">Password
                <input type="password" name="password">
                <br />
                <input type="submit" value="Login">


|]
    where
        dispatch "POST" ["login"] = postLoginR uniq >>= sendResponse
        dispatch _ _              = notFound


----------------------------------------------------------------
-- Predefined datatype
----------------------------------------------------------------

-- | Generate data base instances for a valid user
share [mkPersist sqlSettings, mkMigrate "migrateSiteusers"]
         [persistLowerCase|
Siteuser
    username Text Eq
    password Text
    email Text Maybe
    UniqueSiteuser username
    deriving Typeable
|]

instance HashDBUser (SiteuserGeneric backend) where
  siteuserPasswordHash = Just . siteuserPassword
  setSaltAndPasswordHash h u = u { siteuserPassword = h }