learning-haskell/31-final-project/fingerd/lib/UserDB.hs

{-# LANGUAGE OverloadedStrings #-}
-- {-# LANGUAGE QuasiQuotes #-}

module UserDB
    ( User(..), getSingleUser, getAllUsers, addUser, updateUser)
    where

import Control.Exception
import Data.Text (Text)
-- import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Database.SQLite.Simple hiding (close)
import Database.SQLite.Simple as SQLite
-- import Database.SQLite.Simple.Types
import Data.Typeable
-- import Text.RawString.QQ
import Data.Maybe (catMaybes)
import Data.List (intersperse)
import Data.String (fromString)
import Data.Aeson

data User =
    User {
        userId :: Integer
        , username :: Text
        , shell :: Text
        , homeDirectory :: Text
        , realName :: Text
        , phone :: Text
    } deriving (Eq, Show)

instance FromRow User where
    fromRow = User <$> field
                   <*> field
                   <*> field
                   <*> field
                   <*> field
                   <*> field

instance ToRow User where
    toRow (User id_ uname sh hDir rName ph) =
        toRow (id_, uname, sh, hDir, rName, ph)

instance FromJSON User where
    parseJSON = withObject "User" $ \v -> User 0
        <$> v .: "username"
        <*> v .: "shell"
        <*> v .: "homeDirectory"
        <*> v .: "realName"
        <*> v .: "phone"

-- createUsers :: Query
-- createUsers = [r|
-- CREATE TABLE IF NOT EXISTS users
--     (id INTEGER PRIMARY KEY AUTOINCREMENT,
--     username TEXT UNIQUE,
--     shell TEXT, homeDirectory TEXT,
--     realName TEXT, phone TEXT)
-- |]

insertUser :: Query
insertUser = "INSERT INTO users VALUES (?, ?, ?, ?, ?, ?)"

allUsers :: Query
allUsers = "SELECT * from users"

getUserQuery :: Query
getUserQuery = "SELECT * from users where username = ?"

data DuplicateData = DuplicateData deriving (Eq, Show, Typeable)

instance Exception DuplicateData

-- type UserRow = (Null, Text, Text, Text, Text, Text)

getUser :: Connection -> Text -> IO (Maybe User)
getUser conn uname = do
    results <- query conn getUserQuery (Only uname)
    case results of
        [] -> return $ Nothing
        [user] -> return $ Just user
        _ -> throwIO DuplicateData

addUser :: User -> IO Bool
addUser u = do
    conn <- getConnection
    n <- query conn hasUser (Only $ username u) :: IO [Only Integer]
    b <- case n of
        [] -> (execute conn insertUser $ toRow u) >> return True
        _ -> return False
    rows <- query_ conn allUsers
    mapM_ print (rows :: [User])
    SQLite.close conn
    return b

-- createDatabase :: IO ()
-- createDatabase = do
--     conn <- getConnection
--     execute_ conn createUsers
--     SQLite.close conn

getConnection :: IO Connection
getConnection = open "finger.db"

getSingleUser :: Text -> IO (Maybe User)
getSingleUser name = do
    conn <- getConnection
    result <- getUser conn name
    SQLite.close conn
    return result

getAllUsers :: IO [User]
getAllUsers = do
    conn <- getConnection
    rows <- query_ conn allUsers
    SQLite.close conn
    return rows

hasUser :: Query
hasUser = "SELECT 1 FROM users where username = ?"

updateUser :: String
           -> Maybe String
           -> Maybe String
           -> Maybe String
           -> Maybe String
           -> IO Bool
updateUser name sh hDir rName ph = do
    let xs = [sh, hDir, rName, ph]
        columns = zip ["shell", "homeDirectory", "realName", "phone"] xs
        newData = catMaybes $ fmap sequenceA columns
    case newData of
        [] -> return True
        ys -> do
            let pairs = fmap (\(a,b) -> a ++ "=\"" ++ b ++ "\"" ) ys
                part = concat $ intersperse "," pairs
                full = "update users set " ++ part
                        ++ " where username = \"" ++ name ++ "\""
            conn <- getConnection
            n <- query conn hasUser (Only name) :: IO [Only Integer]
            b <- case n of
                [] -> return False
                _ ->  execute conn (fromString full) (Only name) >> return True
            SQLite.close conn
            return b

-- updateU :: User -> IO ()
-- update