dbmigrations-0.1.2: src/StoreManager.hs

{-# OPTIONS_GHC -fno-warn-orphans #-}
module Main where

import Control.Applicative ( (<$>) )
import Control.Monad.State
import Data.Maybe ( catMaybes )
import Data.List ( intercalate )
import qualified Data.Map as Map
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)

import Graphics.Vty
import Graphics.Vty.Widgets.All
import Database.Schema.Migrations.Filesystem
import Database.Schema.Migrations.Migration ( Migration(..) )
import Database.Schema.Migrations.Store

data MMState = MMState
    { mmStoreData :: StoreData
    , mmStorePath :: FilePath
    , mmMigrationList :: SimpleList
    }

type MM = StateT MMState IO

titleAttr :: Attr
titleAttr = def_attr
            `with_back_color` blue
            `with_fore_color` bright_white

bodyAttr :: Attr
bodyAttr = def_attr
           `with_back_color` black
           `with_fore_color` bright_white

fieldAttr :: Attr
fieldAttr = def_attr
            `with_back_color` black
            `with_fore_color` bright_green

selAttr :: Attr
selAttr = def_attr
           `with_back_color` yellow
           `with_fore_color` black

scrollListUp :: MMState -> MMState
scrollListUp appst =
    appst { mmMigrationList = scrollUp $ mmMigrationList appst }

scrollListDown :: MMState -> MMState
scrollListDown appst =
    appst { mmMigrationList = scrollDown $ mmMigrationList appst }

eventloop :: (Widget a) => Vty -> MM a -> (Event -> MM Bool) -> MM ()
eventloop vty uiBuilder handle = do
  w <- uiBuilder
  evt <- liftIO $ do
           (img, _) <- mkImage vty w
           update vty $ pic_for_image img
           next_event vty
  next <- handle evt
  if next then
      eventloop vty uiBuilder handle else
      return ()

continue :: MM Bool
continue = return True

stop :: MM Bool
stop = return False

handleEvent :: Event -> MM Bool
handleEvent (EvKey KUp []) = modify scrollListUp >> continue
handleEvent (EvKey KDown []) = modify scrollListDown >> continue
handleEvent (EvKey (KASCII 'q') []) = stop
handleEvent _ = continue

instance Widget Migration where
    growHorizontal _ = False
    growVertical _ = False
    primaryAttribute _ = bodyAttr
    withAttribute w _ = w

    render sz m =
        renderMany Vertical $ map (render sz) ws
            where
              ws = catMaybes fieldWidgets
              fieldWidgets = map mkWidget [ ("Timestamp", Just . show . mTimestamp)
                                          , ("Description", mDesc)
                                          , ("Dependencies", Just . (intercalate "\n  ") . mDeps)
                                          , ("Apply", Just . mApply)
                                          , ("Revert", mRevert)
                                          ]
              mkWidget (label, f) = do
                            val <- f m
                            return $ (text fieldAttr $ label ++ ":")
                                       <++> (text bodyAttr " ")
                                       <++> (wrappedText bodyAttr val)

buildUi :: MMState -> Box
buildUi appst =
  let Just selectedMigration = Map.lookup (fst $ getSelected list) mMap
      mMap = storeDataMapping $ mmStoreData appst
      currentItem = selectedIndex list + 1
      borderWithCounter = (text titleAttr $ " " ++ (show currentItem) ++ "/" ++
                                    (show $ length $ listItems list) ++ " ")
                          <++> hFill titleAttr '-' 1
      list = mmMigrationList appst
      header = text titleAttr (" " ++ (mmStorePath appst) ++ " ")
               <++> hFill titleAttr '-' 1
               <++> text titleAttr " Store Manager "
      status = text bodyAttr "Status."
      helpBar = text titleAttr "q:quit up/down:show migration "
                <++> hFill titleAttr '-' 1
  in header
      <--> list
      <--> borderWithCounter
      <--> (bottomPadded selectedMigration)
      <--> helpBar
      <--> status

uiFromState :: MM Box
uiFromState = buildUi <$> get

mkState :: FilePath -> StoreData -> MMState
mkState sp storeData =
    MMState { mmStoreData = storeData
            , mmStorePath = sp
            , mmMigrationList = migrationList
            }
        where
          migrationList = mkSimpleList bodyAttr selAttr 5 migrationNames
          migrationNames = Map.keys $ storeDataMapping storeData

main :: IO ()
main = do
  args <- getArgs
  let theStorePath = args !! 0
  storeData <-
      if length args /= 1
      then do p <- getProgName
              putStrLn ("Usage: " ++ p ++ " <store-path>")
              exitFailure
      else do
        let store = FSStore { storePath = theStorePath }
        result <- loadMigrations store
        case result of
          Left es -> do
                      putStrLn "There were errors in the migration store:"
                      forM_ es $ \err -> do
                        putStrLn $ "  " ++ show err
                      exitFailure
          Right theStoreData -> return theStoreData

  vty <- mkVty
  evalStateT
       (eventloop vty uiFromState handleEvent)
       (mkState theStorePath storeData)

  -- Clear the screen.
  reserve_display $ terminal vty
  shutdown vty