restman-0.7.1.1: app/Main.hs

module Main (main) where

-- base
import Control.Applicative (many, optional, (<|>))
import Data.Bits (Bits, unsafeShiftL)
import System.IO (IOMode(ReadMode), withFile)

-- bytestring
import Data.ByteString (ByteString, hGetSome)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as CS
import Data.ByteString.Lazy (fromChunks, fromStrict)
import qualified Data.ByteString.Lazy as Lazy (ByteString)

-- case-insensitive
import qualified Data.CaseInsensitive as CI

-- microlens
import Lens.Micro.Extras (view)

-- optparse-applicatve
import Options.Applicative
  ( ParseError(ShowHelpText)
  , Parser
  , ParserInfo
  , abortOption
  , completeWith
  , execParser
  , flag'
  , footer
  , fullDesc
  , header
  , help
  , info
  , long
  , metavar
  , progDesc
  , short
  , showDefault
  , strArgument
  , strOption
  )
import qualified Options.Applicative as OptParse

-- text
import Data.Text (Text)

-- utf8-string
import qualified Data.ByteString.UTF8 as UTF8

-- local imports
import HTTP.Client
import UI


-- | Handles @-m@ / @--method@
methodParser :: Parser Method
methodParser = strOption
  (  short 'm'
  <> long "method"
  <> help "HTTP(S) Method (or \"Verb\")"
  <> OptParse.value "GET"
  <> showDefault
  <> metavar "METHOD"
  <> completeWith knownMethods
  )

-- | handles @--[no-]default-headers@
useDefaultParser :: Parser UseDefaultHeaders
useDefaultParser = noDefaultHeaders <|> defaultHeaders <|> pure AppendCustomToDefaultHeaders
 where
  noDefaultHeaders = flag' ReplaceDefaultHeaders
    (  long "no-default-headers"
    <> help "Send ONLY the custom headers specified."
    )
  defaultHeaders = flag' AppendCustomToDefaultHeaders
    (  long "default-headers"
    <> help "Send custom headers after default headers.  This is the default behavior."
    )

{-|
Handles the option-argument for @-h@ / @--custom-header@.

Unicode value is split on the first colon.  Anything before the colon must truncate to ISO-8859-1,
and is treated as the header name.  Anything after the colon is treated as the header value, and
full Unicode is accepted and encoded as UTF-8.

No validation is done on the header name.  No allowance is made for specifying an (invalid) header
name that contains a colon.
-}
optArgToHeader :: String -> Header
optArgToHeader arg = (CI.mk $ CS.pack name, UTF8.fromString value)
 where
  (name, colonValue) = break (':' ==) arg
  value = drop 1 colonValue

-- | handles @-h@ / @--custom-header@
customHeadersParser :: Parser [Header]
customHeadersParser = many . fmap optArgToHeader $ strOption
  (  short 'h'
  <> long "custom-header"
  <> help "Add a custom header, argument is name:value (colon separates name from value)."
  <> metavar "NAME_VALUE"
  )

-- | Specification of the payload from the user
data Payload
  = Literal ByteString -- ^ argument converted to bytes
  | File FilePath -- ^ argument converts to file path

-- | Handles @--payload@ and @--payload-file@
payloadParser :: Parser (Maybe Payload)
payloadParser = optional ((Literal <$> literalParser) <|> (File <$> fileParser))
 where
  literalParser = UTF8.fromString <$> strOption
    (  long "payload"
    <> help "Specify (in UTF-8) payload directly on command-line"
    <> metavar "PAYLOAD"
    )
  fileParser = strOption
    (  long "payload-file"
    <> help "Load payload from file on startup"
    <> metavar "PATHNAME"
    )

-- | Handle optional positional parameter for URI
uriPositionalParser :: Parser (Maybe Text)
uriPositionalParser = optional $ strArgument (metavar "URI")

-- | Options from the command-line
data Options = MkOptions
  { method :: Method
  , useDefaultHeaders :: UseDefaultHeaders
  , customHeaders :: [Header]
  , payload :: Maybe Payload
  , uri :: Maybe Text
  }

helpParser :: Parser (a -> a)
helpParser = abortOption (ShowHelpText mempty)
  (  long "help"
  <> help "Show command-line help and abort normal operation."
  )

-- | Handles full command-line, generating help, and completions
appParser :: ParserInfo Options
appParser = info (helpParser <*> optionsParser)
  (  fullDesc
  <> header "RESTman, an HTTP(S) application"
  <> footer "https://gitlab.com/krakrjak/restman"
  <> progDesc "A TUI application for interactively using the full range of HTTP(S) directly"
  )
 where
  optionsParser =
    MkOptions <$> methodParser <*> useDefaultParser <*> customHeadersParser <*> payloadParser <*> uriPositionalParser

-- | Lens for the method in the options.
optMethod :: Functor f => (Method -> f Method) -> Options -> f Options
optMethod embed opts = fmap (\m -> opts{ method = m}) . embed $ method opts

-- | 'unsafeShilfL'
(.<<.) :: Bits b => b -> Int -> b
(.<<.) = unsafeShiftL

-- | Go from payload specification to a payload ready for library.
loadPayload :: Payload -> IO Lazy.ByteString
loadPayload (Literal bs) = pure $ fromStrict bs
loadPayload (File fp) = fromChunks <$> withFile fp ReadMode readChunks
 where
  readChunks hdl = go
   where
    go = do
      chunk <- hGetSome hdl (1 .<<. 15 {- 32k -})
      if BS.null chunk
       then return []
       else do
        chunks <- go
        return $ chunk:chunks

-- | Application entry point.
main :: IO ()
main = do
  options <- execParser appParser
  payloadLbs <- traverse loadPayload $ payload options
  startUI (view optMethod options) (useDefaultHeaders options) (customHeaders options) payloadLbs (uri options)