database.hs

{-# LANGUAGE MultiParamTypeClasses #-}
module Main where

import           Control.Monad
import           System.IO
import           System.IO.Temp

import           Database.HDBC
import           Database.HDBC.Sqlite3

import           Data.Convertible
import           Data.Time

import           Text.Show

main = withSystemTempFile "dbprimer" dbDemo

dbDemo :: FilePath -> Handle -> IO ()
dbDemo tmpName tmpHandle = do
  putStrLn ("temporary sqlite db at " ++ tmpName)
  c <- connectSqlite3 tmpName
  forM_ [createTablePerson, insertPersons, updatePersons, alterPersons, selectPersons, disconnect] (\f -> f c) where
    createTablePerson :: IConnection conn => conn -> IO ()
    createTablePerson c = do
      let createTablePerson = "CREATE TABLE person ( \
                  \\n\t\tid INTEGER PRIMARY KEY, \
                  \\n\t\tname VARCHAR(255), \
                  \\n\t\tbirthDate NUMERIC \
          \\n\t)"
      run c createTablePerson []
      putStrLn ("Run:\t" ++ createTablePerson)

    insertPersons :: IConnection conn => conn -> IO ()
    insertPersons c = do
      st <- prepare c "INSERT INTO person VALUES (?,?,?)"
      let persons :: [(Int, String, Day)]
          persons = zip3 [1..] names birthDates where
                names :: [String]
                names = ["Pierre", "Paul", "Jaques", "John", "John"]
                birthDates :: [Day]
                birthDates = map convert [(2009,1,1), (2008,12,3), (1997,11,2), (1987,6,6), (1980,2,29)] where
                  convert (y,m,d) = fromGregorian y m d
      forM_ persons $
        \(pid, name, birthDate) -> do
            execute st [toSql pid, toSql name, toSql birthDate]
            putStrLn ("Insert:\t" ++ show pid ++ "\t"++name ++ "\t"++ show birthDate)
      commit c
      putStrLn "INSERT Commit."

    updatePersons :: IConnection conn => conn -> IO ()
    updatePersons c = do
      let updatePerson = "UPDATE person \
                            \ SET id = ?, name = ?, birthDate = ? \
                            \ WHERE id = ?"
      st <- prepare c updatePerson
      let pid = iToSql 5
      let pname = toSql "Jim"
      let pbirthday = toSql $ fromGregorian 1980 2 29
      execute st [pid, pname, pbirthday, pid]
      commit c
      putStrLn "UPDATE Commit"

    alterPersons :: IConnection conn => conn -> IO ()
    alterPersons c = do
      alterPerson c 4 (const Nothing)
      alterPerson c 5 (\p -> Just $ Person (pid p) "Jimmy" (birthday p))
      commit c
      putStrLn "ALTER Commit"


    selectPersons :: IConnection conn => conn -> IO ()
    selectPersons c = do
      let selectPersons = "SELECT * \
                            \ FROM person"
      putStrLn ("Query: " ++ selectPersons)
      rows <- quickQuery' c selectPersons []
      ct <- getCurrentTime

      forM_ (map ((\p -> show p ++ " " ++ show (ageInYears ct p)).asPerson) rows) putStrLn

-- DAO LAYER

getPerson :: IConnection conn => conn -> Int -> IO Person
getPerson c pid = do
   res <- quickQuery' c "SELECT * FROM person WHERE id = ?" [iToSql pid]
   let p = asPerson $ head res
   return p

updatePerson :: IConnection conn => conn -> Person -> IO Integer
updatePerson c p =
  run c "UPDATE person \
                        \ SET id = ?, name = ?, birthDate = ? \
                        \ WHERE id = ?" [iToSql $ pid p, toSql $ name p, toSql $ birthday p, iToSql $ pid p]

alterPerson :: IConnection conn => conn -> Int -> (Person -> Maybe Person) -> IO Integer
alterPerson c pid f = do
  p <- getPerson c pid
  case f p of
    Just p  -> updatePerson c p
    Nothing -> return 0

-- PURE FUNCTIONAL

data Person = Person  { pid      :: Int
                      , name     :: String
                      , birthday :: Day
                      } deriving Show
asPerson :: [SqlValue] -> Person
asPerson [pid, pname, pbirthday] = Person  (fromSql pid) (fromSql pname) (fromSql pbirthday)

ageInDays :: UTCTime -> Person -> Integer
ageInDays ct p = diffDays today (birthday p) where
  today = utctDay ct

ageInYears :: UTCTime -> Person -> Integer
ageInYears cd p = diffYears cy by where
  cy = toGregorian $ utctDay cd
  by = toGregorian $ birthday p
  diffYears (y2, m2, d2) (y1, m1, d1)
    | y1 > y2 = error "Person not yet born."
    | m2 > m1 || (m2 == m1 && d2 > d1) = y2 - y1
    | otherwise = y2 - y1 - 1