Login.hs

{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE ScopedTypeVariables        #-}
module Login where

import DatabaseSupport
import qualified Database.Persist as DB
import qualified Database.Persist.Sqlite as DB

import Grocery.Types
import Grocery.Database

import Crypto.BCrypt
import Control.Lens
import Network.HTTP.Types.Status

import Control.Monad.Trans (liftIO)

import qualified Data.ByteString as BS
import Web.Spock.Simple
import Data.Text.Encoding
import Data.Time
import qualified Data.Text as T

routes :: DB.ConnectionPool -> SpockM conn sess () ()
routes pool = do
  post "/login" $ do
    u <- jsonBody'
    p <- liftIO $ lookupPasswordHashByEmail pool (u ^. userEmail)
    case p of
      Just storedPass ->
        if validatePassword storedPass (passwordFromUser u)
        then setStatus ok200
        else setStatus forbidden403
      Nothing -> setStatus forbidden403

  post "/register" $ do
    u <- jsonBody'
    let p = passwordFromUser u
    hashResult <- liftIO $ hashPasswordUsingPolicy slowerBcryptHashingPolicy p
    case hashResult of
      Nothing -> do
        setStatus status500
        text "Failed Registration"
      Just hash -> do
        now <- liftIO getCurrentTime
        liftIO $ runDB pool $ DB.insert_ $ DbUser (u ^. userEmail) hash now
        text "Succeeded at Registration"


passwordFromUser :: User -> BS.ByteString
passwordFromUser u =
  case (u ^. userPassword) of
    UnhashedPassword p -> encodeUtf8 p
    _                  -> encodeUtf8 ""

lookupPasswordHashByEmail :: DB.ConnectionPool -> T.Text -> IO (Maybe BS.ByteString)
lookupPasswordHashByEmail pool email = do
  results <- liftIO $ runDB pool $ DB.selectList [DbUserEmail DB.==. email] [DB.LimitTo 1]
  case results of
    []                     -> return Nothing
    [(DB.Entity _ dbuser)] -> return $ Just (dbuser ^. dbUserPasswordHash)
    _                      -> error "Wait what. I only asked for one."