{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE TupleSections        #-}
{-# LANGUAGE TypeFamilies         #-}

{-# OPTIONS_GHC -fno-warn-type-defaults #-}

-- |
-- Module      : Main
-- Copyright   : (c) 2015-2016 Brendan Hay
-- License     : Mozilla Public License, v. 2.0.
-- Maintainer  : Brendan Hay <brendan.g.hay@gmail.com>
-- Stability   : provisional
-- Portability : non-portable (GHC extensions)
--
module Main (main) where

import Prelude hiding (truncate)

import Control.Exception.Lens
import Control.Lens                 ((.~), (<&>))
import Control.Monad.Catch
import Control.Monad.Reader
import Control.Monad.Trans.Resource

import Credentials             hiding (context)
import Credentials.CLI.Format
import Credentials.CLI.IO
import Credentials.CLI.Options
import Credentials.CLI.Types

import Data.ByteString.Builder (Builder)
import Data.Conduit
import Data.Conduit.Lazy
import Data.List.NonEmpty      (NonEmpty)
import Data.Text               (Text)

import Network.AWS

import Options.Applicative             hiding (optional)
import Options.Applicative.Help.Pretty

import System.IO

import qualified Data.ByteString.Lazy as LBS
import qualified Data.Conduit.Binary  as CB
import qualified Data.Conduit.List    as CL

default (Builder, Text)

main :: IO ()
main = do
    (opt, mode) <- customExecParser (prefs (showHelpOnError <> columns 90)) options

    lgr <- newLogger (level opt) stderr
    env <- newEnv (region opt) Discover <&> (envLogger .~ lgr) . setStore opt

    catches (runApp env opt (program opt mode))
        [ handler _CredentialError (quit 1 . show)
        ]

program :: Options -> Mode -> App ()
program Options{store = store@(Table _ table), ..} = \case
    List -> do
        says ("Listing contents of " % store % " in " % region % "...")
        runLazy (revisions table) >>=
            emit . ListR

    Insert key ctx name input -> do
        says ("Writing new revision of " %
              name % " to " % store % " in " % region % "...")
        rev <- case input of
            Value val  -> insert key ctx name val table
            Path  path -> do
                sz <- getFileSize path
                if sz > 190 * 1024
                    then throwM $ StorageFailure
                        "Secret file is larger than allowable storage size."
                    else do
                        cs <- liftIO . runResourceT $
                            CB.sourceFile path $$ CL.consume
                        let val = LBS.toStrict (LBS.fromChunks cs)
                        insert key ctx name val table
        emit (InsertR name rev)

    Select ctx name rev -> do
        say "Retrieving"
        case rev of
            Nothing -> pure ()
            Just r  -> say (" revision " % r % " of")
        says (" " % name % " from " % store % " in " % region % "...")
        (val, rev') <- select ctx name rev table
        emit (SelectR name rev' val)

    Delete name rev force -> do
        says ("This will delete revision " %
              rev % " of " % name % " from " % store % " in " % region % "!")
        prompt force $ do
            delete name rev table
            emit (DeleteR name rev)

    Truncate name force -> do
        says ("This will delete all but the latest revision of " %
              name % " from " % store % " in " % region % "!")
        prompt force $ do
            truncate name table
            emit (TruncateR name)

    Setup -> do
        says ("Setting up " % store % " in " % region % ".")
        says "Running ..."
        setup table >>= emit . SetupR

    Teardown force -> do
        says ("This will delete " % store % " from " % region % "!")
        prompt force $ do
            teardown table
            emit TeardownR

options :: ParserInfo (Options, Mode)
options = info (helper <*> modes) (fullDesc <> headerDoc (Just desc))
  where
    desc = bold "credentials"
        <+> "- Administration tool for managing secure, shared credentials."

    modes = hsubparser $ mconcat
        [ mode "list"
            (pure List)
            "List credential names and their respective revisions."
            "This does not perform decryption of any credentials, and can be used \
            \to obtain an overview of the credential names and revisions that \
            \are stored."

        , mode "select"
            (Select <$> context <*> name <*> optional revision)
            "Fetch and decrypt a specific credential revision."
            "Defaults to the latest available revision, if --revision is not specified."

        , mode "insert"
            (Insert <$> key <*> context <*> name <*> input)
            "Write and encrypt a new credential revision."
            "You can supply the secret value as a string with --secret, or as \
            \a file path which contents' will be read by using --path."

        , mode "delete"
            (Delete <$> name <*> require revision <*> force)
            "Remove a specific credential revision."
            "Please note that if an application is pinned to the revision specified \
            \by --revision, it will no longer be able to decrypt the credential."

        , mode "truncate"
            (Truncate <$> name <*> force)
            "Truncate a specific credential's revisions."
            "This will remove all but the most recent credential revision. \
            \That is, after running this command you will have exactly _one_ \
            \revision for the given credential name."

        , mode "setup"
            (pure Setup)
            "Setup a new credential store."
            "This will run the necessary actions to create a new credential store. \
            \This action is idempotent and if the store already exists, \
            \the operation will succeed with exit status 0."

        , mode "teardown"
            (Teardown <$> force)
            "Remove an entire credential store."
            "Warning: This will completely remove the credential store. For some \
            \storage engines this action is irrevocable unless you specifically \
            \perform backups for your data."
        ]

mode :: String -> Parser a -> Text -> Text -> Mod CommandFields (Options, a)
mode n p h f = command n (info ((,) <$> common <*> p) (fullDesc <> desc <> foot))
  where
    desc = progDescDoc (Just $ wrap h)
    foot = footerDoc   (Just $ indent 2 (wrap f) <> line)

common :: Parser Options
common = Options
    <$> textOption
         ( short 'r'
        <> long "region"
        <> metavar "REGION"
        <> completes "The AWS region in which to operate."
             "The following regions are supported:"
                 (map (,mempty) unsafeEnum)
             defaultRegion Nothing
         )

    <*> textOption
         ( short 'u'
        <> long "uri"
        <> metavar "URI"
        <> defaults "URI specifying the storage system to use."
             "The URI format must follow the following protocol:"
                 [ ("dynamo:/[/host[:port]]/table-name", "")
                 ]
             (defaultStore defaultRegion)
             (Just "If no host is specified for AWS services (ie. dynamo:/table-name), \
                   \the default AWS endpoints will be used.")
         )

    <*> textOption
         ( short 'o'
        <> long "output"
        <> metavar "FORMAT"
        <> completes "Output format for displaying retrieved credentials."
             "The following formats are supported:"
                 [ (Pretty, "Pretty printed JSON.")
                 , (JSON,   "Single-line JSON output.")
                 , (Echo,   "Untitled textual output with no trailing newline.")
                 , (Print,  "Print multi-line user output.")
                 ]
             Print Nothing
         )

    <*> textOption
         ( short 'l'
        <> long "level"
        <> metavar "LEVEL"
        <> completes "Log level of AWS messages to emit."
             "The following log levels are supported:"
                 [ (Error, "Service errors and exceptions.")
                 , (Debug, "Requests and responses.")
                 , (Trace, "Sensitive signing metadata.")
                 , (Info,  "No logging of library routines.")
                 ]
             Info Nothing
         )

key :: Parser KeyId
key = textOption
    ( short 'k'
   <> long "key"
   <> metavar "ARN"
   <> defaults "The KMS Master Key Id to use."
       "Examples of KMS aliases or ARNs are:"
           [ ("arn:aws:kms:us-east-1:1234:key/12345678-1234", "")
           , ("arn:aws:kms:us-east-1:1234:alias/MyAliasName", "")
           , ("12345678-1234-1234-12345",                     "")
           , ("alias/MyAliasName",                            "")
           ]
       defaultKeyId
       (Just "It's recommended to setup a new key using the default alias.")
    )

context :: Parser Context
context = ctx $ textOption
    ( short 'c'
   <> long "context"
   <> metavar "KEY=VALUE"
   <> describe "A key/value pair to add to the encryption context. \
               \The same context must be provided during encryption and decryption."
        (Just $ "You can enter multiple key/value pairs. For example:"
      </> indent 2 "-c foo=bar -c something=\"containing spaces\" ..."
        ) Optional
    )

name :: Parser Name
name = textOption
     ( short 'n'
    <> long "name"
    <> metavar "STRING"
    <> describe "The unique name of the credential." Nothing Required
     )

revision :: Fact -> Parser Revision
revision r = textOption
     ( short 'v'
    <> long "revision"
    <> metavar "STRING"
    <> describe "The revision of the credential." Nothing r
     )

force :: Parser Force
force = flag Prompt NoPrompt
     ( short 'f'
    <> long "force"
    <> help "Always overwrite or remove, without an interactive prompt."
     )

input :: Parser Input
input = textual <|> filepath
  where
    textual = Value
        <$> textOption
             ( short 's'
            <> long "secret"
            <> metavar "STRING"
            <> help "The unencrypted secret value of the credential."
             )

    filepath = Path
        <$> option str
             ( short 'p'
            <> long "path"
            <> metavar "PATH"
            <> help "A file to read as the contents of the unencrypted credential."
            <> action "file"
             )