haskweb/DatabaseData.hs

{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS -Wall #-}

module DatabaseData (
    connect, addUserC, validateC, Connection, Username, Password,
    isLoggedInC, getLoginStringC, isAvailableC
) where

import System.Random (newStdGen, randomRs)
import Control.Monad.Trans (liftIO)

import qualified Crypto.Hash as C (SHA3_512, Digest, hash)
import Data.ByteString.Char8 (ByteString, pack)

import Database.HDBC
import Database.HDBC.PostgreSQL

import Shared

type Username = String
type Password = String
type Salt = String

connect :: IO Connection
connect = connectPostgreSQL "user=christian dbname=haskweb"

addUserC :: Connection -> Username -> Password -> IO ()
addUserC conn username password = do
    gen <- newStdGen
    let salt = take 32 $ randomRs ('a', 'z') gen
        hashed = hash (password ++ salt)
    _ <- run conn
        "INSERT INTO webuser (name, password, salt) VALUES (?, ?, ?)"
        [toSql username, toSql hashed, toSql salt]
    commit conn

getLoginC :: Connection -> Username -> MaybeT IO (Password, Salt)
getLoginC conn username = do
    [[pwd, salt]] <- liftIO $ quickQuery' conn
        "SELECT password, salt FROM webuser WHERE name=?"
        [toSql username]
    return (fromSql pwd, fromSql salt)

validateC :: Connection -> Username -> Password -> IO Bool
validateC conn username password = defRunMaybeT False (do
    (pwd, salt) <- getLoginC conn username
    return $ pwd == hash (password ++ salt) )

isLoggedInC :: Connection -> Username -> String -> IO Bool
isLoggedInC conn username loginString = defRunMaybeT False (do
    (pwd, _) <- getLoginC conn username
    return $ hash (pwd ++ username) == loginString)

getLoginStringC :: Connection -> Username -> IO (Maybe String)
getLoginStringC conn username = runMaybeT $ do
    (pwd, _) <- getLoginC conn username
    return $ hash (pwd ++ username)

isAvailableC :: Connection -> Username -> IO Bool
isAvailableC conn username = do
    res <- quickQuery' conn "SELECT 1 FROM webuser WHERE name=?" [toSql username]
    return $ length res == 0

hash :: String -> String
hash = show . (C.hash :: ByteString -> C.Digest C.SHA3_512) . pack