Sync Helper for Shore DBs

shore

#!/usr/bin/env runhaskell

--
-- ## Prerequisites
--
-- ```shell
-- $ brew install ghc
-- $ brew install cabal-install
-- $ cabal install shelly
-- ```
--
-- # Configuration
--
-- Set the environment variable `SHORE_DUMPFILE_DIR` to the directory on your
-- system where you want the downloaded dump files to be stored. Defaults to
-- `/Users/cs/Code/shore`.
--

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
{-# OPTIONS -Wall #-}

module Main (main) where

import Control.Monad ((>>=), liftM, sequence_, return)
import Data.Eq ((==))
import Data.Function (($), (.), (&), const)
import Data.List ((++), lookup)
import Data.Maybe (Maybe(..))
import Data.Monoid ((<>))
import Data.Tuple (fst)
import System.Environment (getArgs, getProgName, lookupEnv)
import System.IO (IO)

import Shelly
import qualified Data.Text as T
default (T.Text)

data Service = Service { name :: T.Text
                       , database :: T.Text
                       , dumpFile :: FilePath }

core :: Service
core = Service { name      = "termine24-production"
               , database  = "shore-core-production"
               , dumpFile  = "shore-core-production.dump" }

rss :: Service
rss  = Service { name      = "shore-rss-production"
               , database  = "shore-rss-production"
               , dumpFile  = "shore-rss-production.dump" }

services :: [(T.Text, Service)]
services = [ ("core", core), ("rss", rss) ]

main :: IO ()
main = getArgs >>= sequence_ . dispatch . (T.pack <$>)
  where dispatch :: [T.Text] -> [IO ()]
        dispatch [serviceName, actionName] =
          case lookup serviceName services of
            Just service -> (service &) <$> stepsFor actionName
            Nothing      -> [stepUsage]
        dispatch _      = [stepUsage]
        stepsFor :: T.Text -> [Service -> IO ()]
        stepsFor "capture"  = [stepCapture]
        stepsFor "download" = [stepDownload]
        stepsFor "recreate" = [stepDrop, stepCreate]
        stepsFor "restore"  = stepsFor "recreate" ++ [stepRestore]
        stepsFor "sync"     = stepDownload : stepsFor "restore"
        stepsFor _          = [const stepUsage]

stepCapture :: Service -> IO ()
stepCapture Service{name = n} = shelly $ do
  echo $ "Capturing new backup for app " <> n <> " ..."
  run_ "heroku" ["pg:backups", "capture", "DATABASE_URL", "-q", "--app", n]
  echo "Done."

stepDownload :: Service -> IO ()
stepDownload Service{name = n, dumpFile = dF} = shelly $ do
  aDF <- liftIO . absDumpFile $ dF
  echo $ "Downloading " <> toTextIgnore dF <> " ..."
  echo "  This might take a few minutes! Go and get a coffee!"
  dumpURL <- run "heroku" ["pg:backups", "public-url", "--app", n]
  run_ "curl" ["-s", "-o",  toTextIgnore aDF, dumpURL]
  echo "Done."

stepDrop :: Service -> IO ()
stepDrop Service{database = db} = shelly $ do
  echo $ "Dropping existing " <> db <> " DB (if exists) ..."
  run_ "dropdb" ["--if-exists", db]
  echo "Done."

stepCreate :: Service -> IO ()
stepCreate Service{database = db} = shelly $ do
  echo $ "Creating " <> db <> " DB ..."
  run_ "createdb" [db]
  echo "Done."

stepRestore :: Service -> IO ()
stepRestore Service{database = db, dumpFile = dF} = shelly $ do
  aDF <- liftIO . absDumpFile $ dF
  echo $ "Restoring " <> db <> " from " <> toTextIgnore dF <> " ..."
  echo "  This might take a few minutes! Go and get a coffee!"
  run_ "pg_restore" ["--no-owner", "--jobs=8", "-d", db, toTextIgnore aDF]
  echo "Done."

stepUsage :: IO ()
stepUsage = shelly $ do
  prog <- T.pack <$> liftIO getProgName

  let serviceNames  = fst <$> services
  let servicesUsage = "{" <> T.intercalate "|" serviceNames <> "}"
  let actionNames   = ["capture", "download", "recreate", "restore", "sync"]
  let actionsUsage  = "{" <> T.intercalate "|" actionNames <> "}"

  echo $ "Usage: " <> prog <> " " <> servicesUsage <> " " <> actionsUsage

absDumpFile :: FilePath -> IO FilePath
absDumpFile file = liftM (</> file) dumpDirectory
                   -- TODO@cs: why is this broken with liftIO?

dumpDirectory :: IO FilePath
dumpDirectory = do
  env <- lookupEnv "SHORE_DUMPFILE_DIR"
  let directory = case env of
        (Just configDirectory) -> fromText . T.pack $ configDirectory
        _                      -> defaultDumpDirectory
  return $ if directory == "" then defaultDumpDirectory else directory
  where defaultDumpDirectory = fromText "/Users/cs/Code/shore"