Cli.hs

{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE OverloadedLists #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StrictData #-}
{-# OPTIONS_HADDOCK hide #-}

module Moto.Internal.Cli
 ( RegistryConf(..)
 , Opts
 , getOpts
 , run
 ) where

import qualified Control.Exception.Safe as Ex
import qualified Data.ByteString.Builder as BB
import Data.Foldable (for_, toList)
import qualified Data.Char as Char
import qualified Data.List as List
import qualified Data.Map.Strict as Map
import qualified Data.Set as Set
import Data.String (fromString)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Df1
import qualified Di.Df1 as Di
import qualified Options.Applicative as OA
import qualified System.Exit as IO
import qualified System.IO as IO

import qualified Moto.Internal as I

--------------------------------------------------------------------------------

-- | Configuration for the 'I.Registry' that we'll use to keep track of the
-- migrations we've run so far.
data RegistryConf = forall r. RegistryConf
  { registryConf_help :: String
    -- ^ Help message for the @--registry@ command line option.
  , registryConf_parse :: String -> Either String r
    -- ^ Parse the string obtained from the @--registry@ command line option,
    -- refining it into some @r@ of our choosing acceptable as an input to
    -- 'registryConf_with'.
    --
    -- Ideally, this 'String' should be an URI
    -- (e.g., @file:\/\/\/var\/db\/migrations@,
    -- or @postgres:\/\/user:password\@host:port\/database@).
  , registryConf_with :: forall a. r -> (I.Registry -> IO a) -> IO a
    -- ^ Given the @r@ obtained from 'registryConf_parse', get a 'I.Registry'
    -- that can be used within the given scope.
  }

--------------------------------------------------------------------------------

-- | Run the command-line arguments parser, obtaining the 'Opts' necessary for
-- calling 'run' afterwards.
--
-- Notice that we can run the executable that calls 'getOpts' with a @--help@
-- command line switch for extensive documentation on how to interact with
-- @moto@.
getOpts
  :: RegistryConf
  -- ^ Configuration for the 'I.Registry' to use.
  --
  -- Among other things, this will dictate how we interpret the @--registry@
  -- command-line option.
  --
  -- Examples: @Moto.PostgreSQL.registryConf@ from
  -- the [moto-postgresql](https://hackage.haskell.org/package/moto-library),
  -- or @Moto.File.@'Moto.File.registryConf' from this library.
  -> OA.Parser a
  -- ^ This extra parser can be used to read some extra configuration
  -- values from the command-line arguments, besides @moto@'s own.
  --
  -- For example, we can obtain things such as the name of a configuration
  -- file or a database connection string we might want to use in our
  -- migrations.
  --
  -- If no such extra data is required, then @'pure' ()@ can be used.
  --
  -- Notice that @moto@'s own command-line argument's parser has precedence
  -- over this parser. Yet, in the command-line, the argument's for the parser
  -- for @a@ should come before @moto@'s own subcommand arguments, otherwise the
  -- command line program will complain about a malformed command-line.
  -> IO (Opts, a)
getOpts rc p_a = OA.customExecParser
   (OA.prefs (OA.showHelpOnEmpty <> OA.noBacktrack))
   (let pi0 = oa_pi_Opts rc
    in pi0 { OA.infoParser = (,) <$> OA.infoParser pi0 <*> p_a })

-- | Run @moto@ on the given migrations graph 'I.Migs', according to the
-- instructions in 'Opts'.
run
  :: Di.Df1
  -- ^ Root logger. If you don't have a 'Di.Df1' for your program yet, you can
  -- obtain one using @Di.new@ from the
  -- [di](https://hackage.haskell.org/package/di) library.
  -> I.Migs graph
  -- ^ Avaliable migrations graph.
  -> Opts
  -- ^ Instructions on how to interact with our migrations.
  -- Obtain with 'getOpts'.
  -> IO ()
run di0 migs opts = do
  case opts_sub opts of
     Sub_Run x -> run_Run di0 migs x
     Sub_ShowMigrations x -> run_ShowMigrations migs x
     Sub_CheckMigrations x -> run_CheckMigrations di0 migs x
     Sub_ShowRegistry x -> run_ShowRegistry di0 x
     Sub_CleanRegistry x -> run_CleanRegistry di0 migs x
     Sub_DeleteRecoveryData x -> run_DeleteRecoveryData di0 migs x

run_Run :: Di.Df1 -> I.Migs graph -> Opts_Run -> IO ()
run_Run di0 migs x = do
  runWithRegistry (opts_run_withRegistry x) $ \reg -> do
     I.getPlan di0 migs reg (opts_run_target x) >>= \case
        Left e -> Ex.throwM e
        Right p -> case opts_run_dryRun x of
           False -> I.run di0 reg p
           True -> BB.hPutBuilder IO.stdout (renderPlan p)

run_ShowMigrations :: I.Migs graph -> Opts_ShowMigrations -> IO ()
run_ShowMigrations migs x = do
  let gf = opts_showMigrations_graphFormat x
  BB.hPutBuilder IO.stdout (renderMigs gf migs)

run_CheckMigrations :: Di.Df1 -> I.Migs graph -> Opts_CheckMigrations -> IO ()
run_CheckMigrations di0 migs x = do
  runWithRegistry (opts_checkMigrations_withRegistry x) $ \reg -> do
    -- The 'I.Target' here is an unused dummy value.
    I.getPlan di0 migs reg (I.Target I.Forwards Set.empty) >>= \case
      Left _ -> IO.exitFailure
      Right _ -> IO.exitSuccess

run_ShowRegistry :: Di.Df1 -> Opts_ShowRegistry -> IO ()
run_ShowRegistry di0 x = do
  runWithRegistry (opts_showRegistry_withRegistry x) $ \reg -> do
    state <- I.registry_state reg di0
    BB.hPutBuilder IO.stdout (renderState state)

run_CleanRegistry :: Di.Df1 -> I.Migs graph -> Opts_CleanRegistry -> IO ()
run_CleanRegistry di0 migs x = do
  runWithRegistry (opts_cleanRegistry_withRegistry x) $ \reg -> do
    case opts_cleanRegistry_dryRun x of
      False -> I.cleanRegistry di0 migs reg
      True -> fmap I.state_status (I.registry_state reg di0) >>= \case
        I.Dirty _ _ -> IO.exitFailure
        I.Clean -> pure ()

run_DeleteRecoveryData
  :: Di.Df1 -> I.Migs graph -> Opts_DeleteRecoveryData -> IO ()
run_DeleteRecoveryData di0 migs x = do
  for_ (Set.toList (opts_store_migIds x)) $ \mId -> do
    let di1 = Di.attr "mig" (Df1.value mId) di0
    case I.lookupMigs mId migs of
      Just (_, I.UMig store _ _) -> I.store_delete store di1 mId
      Just (_, I.UGone) -> do
        Di.error di1 "Migration code is gone."
        IO.exitFailure
      Nothing -> do
        Di.error di1 "Migration not unknown."
        IO.exitFailure

--------------------------------------------------------------------------------

oa_pi_Opts :: RegistryConf -> OA.ParserInfo Opts
oa_pi_Opts rc = OA.info
  (oa_p_Opts rc OA.<**> OA.helper)
  (OA.fullDesc <> OA.progDesc "Command line interface to migrations.")

oa_p_Opts :: RegistryConf -> OA.Parser Opts
oa_p_Opts rc = Opts <$> oa_p_Sub rc

-- | This is the input required by 'run', obtained from the command line
-- arguments by using 'getOpts'.
data Opts = Opts
  { opts_sub :: Sub
    -- ^ Subcommand to run.
  }

--------------------------------------------------------------------------------

oa_p_Sub :: RegistryConf -> OA.Parser Sub
oa_p_Sub rc = OA.hsubparser $ mconcat
  [ OA.command "run"
      (fmap Sub_Run (oa_pi_Run rc))
  , OA.command "show-migrations"
      (fmap Sub_ShowMigrations oa_pi_ShowMigrations)
  , OA.command "check-migrations"
      (fmap Sub_CheckMigrations (oa_pi_CheckMigrations rc))
  , OA.command "show-registry"
      (fmap Sub_ShowRegistry (oa_pi_ShowRegistry rc))
  , OA.command "clean-registry"
      (fmap Sub_CleanRegistry (oa_pi_CleanRegistry rc))
  , OA.command "delete-recovery-data"
      (fmap Sub_DeleteRecoveryData oa_pi_DeleteRecoveryData)
  ]

data Sub
  = Sub_Run Opts_Run
  -- ^ Run migrations.
  | Sub_ShowMigrations Opts_ShowMigrations
  -- ^ Show available migrations.
  | Sub_CheckMigrations Opts_CheckMigrations
  -- ^ Check that the available migrations are compatible with the registry.
  | Sub_ShowRegistry Opts_ShowRegistry
  -- ^ Show migrations registry.
  | Sub_CleanRegistry Opts_CleanRegistry
  -- ^ I.Clean the registry if dirty.
  | Sub_DeleteRecoveryData Opts_DeleteRecoveryData
  -- ^ Delete content from the store.

--------------------------------------------------------------------------------

oa_pi_Run :: RegistryConf -> OA.ParserInfo Opts_Run
oa_pi_Run rc = OA.info (oa_p_Run rc) (OA.progDesc "Run migrations.")

oa_p_Run :: RegistryConf -> OA.Parser Opts_Run
oa_p_Run rc = Opts_Run
  <$> oa_p_WithRegistry rc
  <*> oa_p_Target
  <*> OA.flag True False
        (OA.long "no-dry-run" <>
         OA.help "Don't just show the execution plan, run it!")

data Opts_Run = Opts_Run
  { opts_run_withRegistry :: WithRegistry
  -- ^ Acquire a 'I.Registry' to use within a limited scope..
  , opts_run_target :: I.Target
  -- ^ Migration target.
  , opts_run_dryRun :: Bool
  -- ^ Don't run migrations, just show the execution plan.
  }

--------------------------------------------------------------------------------

oa_pi_ShowMigrations :: OA.ParserInfo Opts_ShowMigrations
oa_pi_ShowMigrations = OA.info oa_p_ShowMigrations
  (OA.progDesc "Show available migrations.")

oa_p_ShowMigrations :: OA.Parser Opts_ShowMigrations
oa_p_ShowMigrations = Opts_ShowMigrations <$> oa_p_GraphFormat

data Opts_ShowMigrations = Opts_ShowMigrations
  { opts_showMigrations_graphFormat :: GraphFormat
  -- ^ Format in which to render the migrations graph.
  }

--------------------------------------------------------------------------------

oa_pi_CheckMigrations :: RegistryConf -> OA.ParserInfo Opts_CheckMigrations
oa_pi_CheckMigrations rc = OA.info (oa_p_CheckMigrations rc)
  (OA.progDesc "Exit immediately with status 0 if the available \
               \migrations are compatible with the registry. \
               \Otherwise, exit with status 1.")

oa_p_CheckMigrations :: RegistryConf -> OA.Parser Opts_CheckMigrations
oa_p_CheckMigrations rc = Opts_CheckMigrations <$> oa_p_WithRegistry rc

data Opts_CheckMigrations = Opts_CheckMigrations
  { opts_checkMigrations_withRegistry :: WithRegistry
  -- ^ Acquire a 'I.Registry' to use within a limited scope..
  }

--------------------------------------------------------------------------------

oa_pi_ShowRegistry :: RegistryConf -> OA.ParserInfo Opts_ShowRegistry
oa_pi_ShowRegistry rc = OA.info
  (oa_p_ShowRegistry rc)
  (OA.progDesc "Show migrations registry.")

oa_p_ShowRegistry :: RegistryConf -> OA.Parser Opts_ShowRegistry
oa_p_ShowRegistry rc = Opts_ShowRegistry <$> oa_p_WithRegistry rc

data Opts_ShowRegistry = Opts_ShowRegistry
  { opts_showRegistry_withRegistry :: WithRegistry
  -- ^ Acquire a 'I.Registry' to use within a limited scope..
  }

--------------------------------------------------------------------------------

oa_pi_CleanRegistry :: RegistryConf -> OA.ParserInfo Opts_CleanRegistry
oa_pi_CleanRegistry rc = OA.info
  (oa_p_CleanRegistry rc)
  (OA.progDesc "Clean a dirty migrations registry.")

oa_p_CleanRegistry :: RegistryConf -> OA.Parser Opts_CleanRegistry
oa_p_CleanRegistry rc = Opts_CleanRegistry
  <$> oa_p_WithRegistry rc
  <*> OA.switch (OA.long "dry-run" <>
                 OA.help "Don't clean registry, just show whether it is \
                         \clean and exit immediately with status 0 if so, \
                         \otherwise exit with status 1.")

data Opts_CleanRegistry = Opts_CleanRegistry
  { opts_cleanRegistry_withRegistry :: WithRegistry
  -- ^ Acquire a 'I.Registry' to use within a limited scope..
  , opts_cleanRegistry_dryRun :: Bool
  -- ^ Whether to just show whether the registry is clean
  -- and exit immediately with status 0 if the so,
  -- otherwise exit with status 1.
  }

--------------------------------------------------------------------------------

oa_pi_DeleteRecoveryData :: OA.ParserInfo Opts_DeleteRecoveryData
oa_pi_DeleteRecoveryData = OA.info oa_p_DeleteRecoveryData
  (OA.progDesc "Delete contents from the migrations data store.")

oa_p_DeleteRecoveryData :: OA.Parser Opts_DeleteRecoveryData
oa_p_DeleteRecoveryData = Opts_DeleteRecoveryData
  <$> fmap Set.fromList (OA.some (OA.option OA.str (OA.long "mig")))

data Opts_DeleteRecoveryData = Opts_DeleteRecoveryData
  { opts_store_migIds :: Set.Set I.MigId
  -- ^ 'I.MigId's for which to remove contents from the data store.
  }

--------------------------------------------------------------------------------

data WithRegistry = WithRegistry
  { runWithRegistry :: forall a. (I.Registry -> IO a) -> IO a }

oa_p_WithRegistry :: RegistryConf -> OA.Parser WithRegistry
oa_p_WithRegistry (RegistryConf rh rp rw) = OA.option
  (OA.eitherReader $ \s -> do
     case List.dropWhileEnd Char.isSpace (List.dropWhile Char.isSpace s) of
       "" -> Left "Empty registry URI"
       s' -> case rp s' of
          Left e -> Left e
          Right r -> Right (WithRegistry (rw r)))
  (OA.long "registry" <> OA.metavar "URI" <> OA.help rh)

--------------------------------------------------------------------------------

oa_p_Target :: OA.Parser I.Target
oa_p_Target = I.Target
  <$> OA.flag I.Forwards I.Backwards (OA.long "backwards")
  <*> fmap Set.fromList (OA.many (OA.option OA.str
        (OA.long "mig" <> OA.metavar "ID" <>
         OA.help "If specified, only consider running the migration identified \
                 \by this ID. Use multiple times for multiple migrations.")))

--------------------------------------------------------------------------------

oa_p_GraphFormat :: OA.Parser GraphFormat
oa_p_GraphFormat =
  OA.flag GraphFormatText GraphFormatDot
    (OA.long "dot" <> OA.help "Render graph in DOT (Graphviz) format.")

data GraphFormat
  = GraphFormatText -- ^ Render as plain text.
  | GraphFormatDot -- ^ Render as DOT (Graphviz).

renderMigs :: GraphFormat -> I.Migs graph -> BB.Builder
renderMigs = \case
  GraphFormatText -> renderMigs_Text
  GraphFormatDot -> renderMigs_Dot

renderMigs_Text :: I.Migs graph -> BB.Builder
renderMigs_Text (I.Migs m0) = mconcat $ do
   (here, deps) <- Map.toList (fmap (toList . fst) m0)
   case deps of
     [] -> [ f here <> " has no dependencies.\n" ]
     _  -> [ f here <> " depends on:\n" <>
             mconcat (map (\mId -> "  * " <> f mId <> "\n") deps) ]
 where
   f :: I.MigId -> BB.Builder
   f (I.MigId x) = T.encodeUtf8Builder (T.pack (show x))

renderMigs_Dot :: I.Migs graph -> BB.Builder
renderMigs_Dot (I.Migs m0) = mconcat
   [ "digraph G {\n"
   , mconcat $ do
       (here, deps) <- Map.toList (fmap (toList . fst) m0)
       dep <- deps
       [ "  " <> f dep <> " -> " <> f here <> ";\n" ]
   , "}\n"
   ]
 where
   f :: I.MigId -> BB.Builder
   f (I.MigId x) = T.encodeUtf8Builder (T.pack (show x))

--------------------------------------------------------------------------------

renderState :: I.State -> BB.Builder
renderState s =
  "Status: " <> fromString (show (I.state_status s)) <>
  "\nCommitted migrations: " <>
  fromString (show (length (I.state_committed s))) <> "\n" <>
  mconcat (map (\x -> "  " <> fromString (show x) <> "\n")
               (I.state_committed s))

--------------------------------------------------------------------------------

-- | Renders each 'MigId' in the 'Plan' preceded by its direction, and followed
-- by a trailing newline.
renderPlan :: I.Plan -> BB.Builder
renderPlan (I.Plan _ []) = "Execution plan is empty. Nothing to do.\n"
renderPlan (I.Plan d s) = mconcat
    [ "Execution plan:\n"
    , mconcat (map (\(mId,_) -> "  Run " <> d' <> f mId <> "\n") (toList s))
    , "\nTo actually run the migrations, add --no-dry-run to "
    , "the command-line arguments.\n" ]
  where
    d' :: BB.Builder
    d' = I.direction "backwards " "forwards " d
    f :: I.MigId -> BB.Builder
    f (I.MigId x) = T.encodeUtf8Builder (T.pack (show x))