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

{-# 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
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.Functor.Identity   (Identity (..))
import Data.Text               (Text)

import Network.AWS

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

import System.IO

import qualified Control.Applicative as App
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
    (defaultOptions -> opt, m) <-
        customExecParser (prefs (showHelpOnError <> columns 90)) options

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

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

program :: Options Identity -> Mode -> App ()
program Options{ store  = Identity store@(Table _ table)
               , region = Identity region
               , ..}    = \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 Maybe, 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 <$> contextOption <*> nameOption <*> optional revisionOption)
            "Fetch and decrypt a specific credential revision."
            "Defaults to the latest available revision, if --revision is not specified."

        , mode "insert"
            (Insert <$> keyOption <*> contextOption <*> nameOption <*> inputOption)
            "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 <$> nameOption <*> require revisionOption <*> forceFlag)
            "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 <$> nameOption <*> forceFlag)
            "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 <$> forceFlag)
            "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 Maybe, a)
mode name p desc foot =
    command name $ info ((,) <$> commonOptions <*> p)
        ( fullDesc <> progDescDoc (Just $ wrap desc)
                   <> footerDoc   (Just $ indent 2 (wrap foot) <> line)
        )

commonOptions :: Parser (Options Maybe)
commonOptions = Options
    <$> App.optional (textOption
         ( short 'r'
        <> long "region"
        <> metavar "REGION"
        <> completes "The AWS region in which to operate."
             "The following regions are supported:"
                 (map (,mempty) unsafeEnum)
             Nothing
             (Just "Note: this corresponds to both the KMS key region and the \
                   \DynamoDB table region.")
         ))

    <*> App.optional (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", "")
                 , (show (defaultStore defaultRegion),   "")

                 ]
             Nothing
             (Just "If no host is specified (ie. dynamo:/table-name), \
                   \the default AWS endpoint for the given --region will be used. \
                   \If an AWS endpoint is specified the endpoint region MUST \
                   \correspond with --region, or a signature error will occur.")
         ))

    <*> 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.")
                 ]
             (Just 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.")
                 ]
             (Just Info) Nothing
         )

keyOption :: Parser KeyId
keyOption = 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",                            "")
           ]
       (Just defaultKeyId)
       (Just "It's recommended to setup a new key using the default alias.")
    )

contextOption :: Parser Context
contextOption = fromPairs $ 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
    )

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

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

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

inputOption :: Parser Input
inputOption = 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"
             )