upgrade.hs

module Main where

import Database.HDBC
import Database.HDBC.Sqlite3
import Control.Exception

data Ctx = Ctx Connection

type DBResult = Either String ()

success :: Monad m => m DBResult
success = return $ Right ()

failure :: (Monad m, Exception e) => e -> m DBResult
failure e = return $ Left $ "Upgrade aborted: " ++ show e

newtype SQLUpgrade a = SQLUpgrade { runSQLUpgrade :: Ctx -> IO a }

instance Monad SQLUpgrade where
    u >>= f = SQLUpgrade $ \ ctx -> do a <- runSQLUpgrade u ctx
                                       runSQLUpgrade (f a) ctx

    return x = SQLUpgrade $ \ _ -> return x

sql :: String -> SQLUpgrade DBResult
sql q = SQLUpgrade $ \ (Ctx c) -> (run c q [] >> success) `catchSql` failure

(∧) :: SQLUpgrade DBResult -> SQLUpgrade DBResult -> SQLUpgrade DBResult
u ∧ v = SQLUpgrade $ \ ctx -> do a <- runSQLUpgrade u ctx
                                 case a of
                                   Left msg -> return $ Left msg
                                   Right () -> runSQLUpgrade v ctx

(∨) :: SQLUpgrade DBResult -> SQLUpgrade DBResult -> SQLUpgrade DBResult
u ∨ v = SQLUpgrade $ \ ctx -> do a <- runSQLUpgrade u ctx
                                 case a of
                                   Left _ -> runSQLUpgrade v ctx
                                   Right () -> success

upgrade :: SQLUpgrade DBResult
upgrade =
    sql "CREATE TABLE Doc (id INTEGER NOT NULL, title VARCHAR(75), data BLOB)" ∧
    sql "ALTER TABLE Doc ADD COLUMN fileName VARCHAR(75)" ∧
    sql "UPDATE Doc SET fileName = title"

main :: IO ()
main = do
  c <- connectSqlite3 "upgrade.db"
  r <- runSQLUpgrade upgrade (Ctx c)
  putStrLn $ show r
  commit c
  disconnect c