webapp-0.1.0: Web/App.hs

{-|
Module      : Web.App
Copyright   : (c) Nathaniel Symer, 2015
License     : MIT
Maintainer  : nate@symer.io
Stability   : experimental
Portability : POSIX

Root modules of webapp.
-}

module Web.App
(
  -- * Functions
  webappMain,
  -- * Exported Modules
  module Web.App.Assets,
  module Web.App.Cookie,
  module Web.App.Daemon,
  module Web.App.FileCache,
  module Web.App.HTTP,
  module Web.App.Password,
  module Web.App.IO,
  module Web.App.Monad
)
where

import Web.App.Assets
import Web.App.Cookie
import Web.App.Daemon
import Web.App.FileCache
import Web.App.HTTP
import Web.App.Password
import Web.App.IO
import Web.App.Monad
import Web.App.TerminalSize

import Control.Applicative
import Options.Applicative
import System.Environment (getArgs)
import Web.Scotty.Trans (ScottyT,ScottyError)
import System.IO

data Cmd
  = StartCommand {
     startCmdDaemonize :: Bool,
    _startCmdInsecure :: Bool,
    _startCmdPort :: Int,
    _startCmdHTTPSSLCert :: FilePath,
    _startCmdHTTPSSLKey :: FilePath,
    _startCmdOutputPath :: Maybe FilePath,
    _startCmdErrorPath :: Maybe FilePath,
    _startCmdPidPath :: FilePath
  }
  | StopCommand {
    _stopCmdPidPath :: FilePath
  }
  | StatusCommand {
    _statusCmdPidPath :: FilePath
  }
  | PasswordCommand {
    _passwordCmdPassword :: String
  }

-- | Read commandline arguments and start app accordingly. When passing an
-- additional CLI parser, it is made available under the @util@ subcommand.
webappMain :: (ScottyError e, WebAppState s) => ScottyT e (WebAppM s) () -- ^ app to start
                                             -> String -- ^ CLI title/description
                                             -> Maybe (Parser a) -- ^ extra CLI parser (available under @util@ subcommand)
                                             -> (a -> IO ()) -- ^ action to apply to parse result of 'utilParser'
                                             -> IO ()
webappMain app title utilParser utilf = getArgs >>= getCommandArgs utilParser title >>= processArgs
  where
    processArgs (Right cmd) = f cmd
    processArgs (Left utils) = utilf utils
    f c@(StartCommand True _ _ _ _ _ _ pidPath) = do
      daemonize pidPath $ f $ c { startCmdDaemonize = False }
    f (StartCommand False False port crt key out err _) = do
      redirectStdout out
      redirectStderr err
      startHTTPS app port crt key
    f (StartCommand False True port _ _ out err _) = do
      redirectStdout out
      redirectStderr err
      startHTTP app port
    f (StopCommand pidPath) = daemonKill 4 pidPath
    f (StatusCommand pidPath) = daemonRunning pidPath >>= putStrLn . showStatus
    f (PasswordCommand pwd) = hashPassword pwd >>= g
      where
        g (Just v) = putStrLn v
        g Nothing = hPutStrLn stderr "failed to hash password"
    showStatus True = "running"
    showStatus False = "stopped"

getCommandArgs :: Maybe (Parser a) -> String -> [String] -> IO (Either a Cmd)
getCommandArgs utilParser title args = do
  w <- maybe 80 snd <$> getTermSize
  handleParseResult $ execParserPure (pprefs w) parser args
  where
    pprefs = ParserPrefs "" False False True
    parser = info (helper <*> ((sp utilParser) <|> parseStart)) (fullDesc <> header title)
    sp Nothing = subparser subCommands
    sp (Just util) = subparser $ subCommands <> (mkcmd "util" "Utilities associated with the application" (Left <$> util))
    subCommands = (mkcmd "start" "Start the application server" parseStart) <>
                  (mkcmd "stop" "Stop the application server" parseStop) <>
                  (mkcmd "status" "Determine if the application server is running" parseStatus)
    parseStart = fmap Right $ StartCommand
      <$> (flag False True $ short 'd' <> long "daemonize" <> help "run the application server daemonized")
      <*> (flag False True $ short 'i' <> long "insecure" <> help "run the application server over insecure HTTP")
      <*> (option auto $ opt "port" 'p' "PORT" (Just 3000) "port to run the application server on")
      <*> (strOption $ opt "https-crt" 'c' "FILEPATH" (Just "server.crt") "SSL certificate file")
      <*> (strOption $ opt "https-key" 'k' "FILEPATH" (Just "server.key") "SSL private key file")
      <*> (optional $ strOption $ opt "stdout" 'o' "FILEPATH" Nothing "redirect standard output to FILEPATH")
      <*> (optional $ strOption $ opt "stderr" 'e' "FILEPATH" Nothing "redirect standard error to FILEPATH")
      <*> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "when daemonizing, write the PID to FILEPATH")
    parseStop     = Right <$> StopCommand <$> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "pid file")
    parseStatus   = Right <$> StatusCommand <$> (strOption $ opt "pid-file" 'z' "FILEPATH" (Just "/tmp/webapp.pid") "pid file")
    opt lng shrt mvar (Just defVal) hlp = (long lng <> short shrt <> metavar mvar <> value defVal <> help hlp)
    opt lng shrt mvar Nothing       hlp = (long lng <> short shrt <> metavar mvar <> help hlp)
    mkcmd cmd desc p = command cmd $ info (helper <*> p) $ progDesc desc