gistfile1.hs

{-# LANGUAGE OverloadedStrings #-}
module Main where

import           Control.Monad
import           Data.Monoid
import           Data.Text                                                  (Text)
import qualified Data.Text                                                  as T
import qualified Data.Text.IO                                               as T
import           Database.Rivet
import           Database.Rivet.Adaptor.PostgreSQL
import           System.Environment

import qualified M20140920001929_base
import qualified M20140925150255_add_email_change
import qualified M20140925170335_add_admin_to_users
import qualified M20140925202932_eliminate_name_address_migration_cruft
import qualified M20141009210950_update_orders
import qualified M20141009230947_add_name_email_address_to_orders
import qualified M20141010154918_add_notes_to_subscriber
import qualified M20141018161346_add_individual_prices_to_issues
import qualified M20141028160810_add_lifetime_subscription_to_subscribers
import qualified M20141104203500_add_archived_at_to_products
import qualified M20141107184032_add_order_search_index
import qualified M20141201175928_add_list_tags
import qualified M20141201213956_add_subscriber_list_tag
import qualified M20141207043046_lowercase_list_members_emails
import qualified M20141207044608_add_list_members_tags_indexes
import qualified M20141207050756_add_legacy_list_member_tag
import qualified M20141208173438_add_donations
import qualified M20141208195120_add_cancel_token_and_last_run_to_donations
import qualified M20141209221817_add_failing_to_donations
import qualified M20141209223205_add_skipped_payments_to_donations
import qualified M20141210154745_add_processing_at_to_donations
import qualified M20141210193630_add_gift_subscriptions_table
import qualified M20141211212630_add_type_to_gift_subscriptions
import qualified M20150222182753_add_coupons
import qualified M20150813_add_archive_defaults

data Mode = MigrateUp | MigrateDown | MigrateStatus

migrations :: [(Text, Migration IO ())]
migrations =
  [("M20140920001929_base"
   ,M20140920001929_base.migrate)
  ,("M20140925150255_add_email_change"
   , M20140925150255_add_email_change.migrate)
  ,("M20140925170335_add_admin_to_users"
   , M20140925170335_add_admin_to_users.migrate)
  ,("M20140925202932_eliminate_name_address_migration_cruft"
   , M20140925202932_eliminate_name_address_migration_cruft.migrate)
  ,("M20141009210950_update_orders"
   , M20141009210950_update_orders.migrate)
  ,("M20141009230947_add_name_email_address_to_orders"
   , M20141009230947_add_name_email_address_to_orders.migrate)
  ,("M20141010154918_add_notes_to_subscriber"
   , M20141010154918_add_notes_to_subscriber.migrate)
  ,("M20141018161346_add_individual_prices_to_issues"
   , M20141018161346_add_individual_prices_to_issues.migrate)
  ,("M20141028160810_add_lifetime_subscription_to_subscribers"
   , M20141028160810_add_lifetime_subscription_to_subscribers.migrate)
  ,("M20141104203500_add_archived_at_to_products"
   , M20141104203500_add_archived_at_to_products.migrate)
  ,("M20141107184032_add_order_search_index"
   , M20141107184032_add_order_search_index.migrate)
  ,("M20141201175928_add_list_tags"
   , M20141201175928_add_list_tags.migrate)
  ,("M20141201213956_add_subscriber_list_tag"
   , M20141201213956_add_subscriber_list_tag.migrate)
  ,("M20141207043046_lowercase_list_members_emails"
   , M20141207043046_lowercase_list_members_emails.migrate)
  ,("M20141207044608_add_list_members_tags_indexes"
   , M20141207044608_add_list_members_tags_indexes.migrate)
  ,("M20141207050756_add_legacy_list_member_tag"
   , M20141207050756_add_legacy_list_member_tag.migrate)
  ,("M20141208173438_add_donations"
   , M20141208173438_add_donations.migrate)
  ,("M20141208195120_add_cancel_token_and_last_run_to_donations"
   , M20141208195120_add_cancel_token_and_last_run_to_donations.migrate)
  ,("M20141209221817_add_failing_to_donations"
   , M20141209221817_add_failing_to_donations.migrate)
  ,("M20141209223205_add_skipped_payments_to_donations"
   , M20141209223205_add_skipped_payments_to_donations.migrate)
  ,("M20141210154745_add_processing_at_to_donations"
   , M20141210154745_add_processing_at_to_donations.migrate)
  ,("M20141210193630_add_gift_subscriptions_table"
   , M20141210193630_add_gift_subscriptions_table.migrate)
  ,("M20141211212630_add_type_to_gift_subscriptions"
   , M20141211212630_add_type_to_gift_subscriptions.migrate)
  ,("M20150222182753_add_coupons"
   , M20150222182753_add_coupons.migrate)
  ,("M20150813_add_archive_defaults"
   , M20150813_add_archive_defaults.migrate)
  ]

main :: IO ()
main = do
  args <- getArgs
  let (env, mode) =
       case args of
         (env:"up":[]) -> (env, MigrateUp)
         (env:"down":[]) -> (env, MigrateDown)
         (env:"status":[]) -> (env, MigrateStatus)
         _ -> error "Usage: [executable] [devel|prod|...] [up|down|status]"
  adaptor <- setup id (ConnectInfo "127.0.0.1"
                                   5432
                                   "project_user"
                                   "111"
                                   ("project_" <> env))
  let notRun m = fmap not $ checkMigration adaptor m
  case mode of
    MigrateUp ->
      do toRun <- filterM (notRun . fst) migrations
         mapM_ (\(name, m) -> do runMigration Up adaptor name m
                                 T.putStrLn ("Ran " <> name))
               toRun
    MigrateDown ->
      do toDown <- dropWhileM (notRun . fst)
                              (reverse migrations)
         case toDown of
           ((name, m) :_) -> do runMigration Down adaptor name m
                                T.putStrLn ("Reverted " <> name)
           [] -> putStrLn "No migrations remaining."
    MigrateStatus ->
      mapM_ (\(m,_) ->
        do r <- checkMigration adaptor m
           if r
             then T.putStrLn $ " APPLIED " <> m <> " in " <> T.pack env
             else T.putStrLn $ m <> " in " <> T.pack env)
        migrations
  where dropWhileM f [] = return []
        dropWhileM f (x:xs) = do x' <- f x
                                 if x'
                                    then dropWhileM f xs
                                    else return (x:xs)