Main.hs

{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}

-- | Main fpco-api executable.

module Main where

import           FP.API.Types
import           FP.Server
import           FP.Server.Types
import           FP.Server.Spans



import           Control.Exception
import           Control.Monad
import           Data.Aeson
import qualified Data.ByteString.Lazy as L
import           Data.ConfigFile
import           Data.Default
import           Data.List
import           Data.Maybe
import           Data.Monoid
import           Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import           Network
import           Options.Applicative
import           Prelude hiding (catch)
import           Safe
import           System.Directory
import           System.Environment
import           System.FilePath
import           System.IO

--------------------------------------------------------------------------------
-- Main

-- | Main program entry point.
main :: IO ()
main = do
  join (execParser opts)

   where opts =
           info (helper <*> config)
                (mconcat [fullDesc
                         ,header "fpco-api"
                         ,progDesc "A program for easily talking to the FP Complete API"])
         config =
           subparser
             (mconcat [cmd startCommand "start" "Start a session server"
                      ,cmd configureCommand "config" "Generate a configuration"
                      ,cmd checkCommand "check" "Type check the given file"
                      ,cmd downloadCommand "download" "Download a project and write Emacs config"
                      ,cmd emacsConfigCommand "emacs-config" "Write Emacs config"])
         cmd run name desc = command name (info run (progDesc desc))

--------------------------------------------------------------------------------
-- Commands

-- | Start the server.
startCommand :: Parser (IO ())
startCommand =
  pure (\agent -> withConfig agent (runWithConfig (startServer False))) <*>
  agentOpt <*>
  configFileOpt

-- | Make a configuration.
configureCommand :: Parser (IO ())
configureCommand =
  pure configure <*>
  configFileOpt

-- | Check the given module.
checkCommand :: Parser (IO ())
checkCommand =
  pure (\pid root name path ->
          withConfig Nothing (check pid root name path)) <*>
  fayPidOpt <*>
  rootOpt <*>
  filepathOpt <*>
  tmppathOpt <*>
  configFileOpt

  where check pid root name path config =
          sendCommand config root (MsgCheckModule pid root name path)

-- | Download the given module.
downloadCommand :: Parser (IO ())
downloadCommand =
  pure (\pid -> withConfig Nothing (\c -> download pid c { configStartServer = True })) <*>
  fayProjectOpt <*>
  configFileOpt

 where download pid config = do
         root <- getCurrentDirectory
         putStrLn "Downloading project files ..."
         sendCommand config root (MsgDownloadFiles pid root)
         putStrLn "Downloaded project files."
         sendCommand config root (MsgWriteEmacsConfig pid root)
         putStrLn "Wrote Emacs configuration."

-- | EmacsConfig the given module.
emacsConfigCommand :: Parser (IO ())
emacsConfigCommand =
  pure (\pid -> withConfig Nothing (\c -> emacsConfig pid c { configStartServer = True })) <*>
  fayProjectOpt <*>
  configFileOpt

 where emacsConfig pid config = do
         root <- getCurrentDirectory
         sendCommand config root (MsgWriteEmacsConfig pid root)
         putStrLn "Wrote Emacs configuration."

--------------------------------------------------------------------------------
-- Options

-- | -agent option.
agentOpt :: Parser (Maybe Text)
agentOpt =
  fmap (fmap T.pack)
       (optional (strOption (metavar "AGENT" <> long "agent" <> short 'a' <>
                             help "User agent (IDE of choice)")))

-- | -config option.
configFileOpt :: Parser (Maybe String)
configFileOpt =
  optional (strOption (metavar "CONFIG" <> long "config" <> short 'c' <>
                       help "Config file"))

-- | PID option.
fayPidOpt :: Parser FayProjectId
fayPidOpt =
  argument (return . toFay)
   (metavar "PID")

-- | PROJECT option.
fayProjectOpt :: Parser (Either Text FayProjectId)
fayProjectOpt =
  argument (return . toFayPid)
           (metavar "PROJECT" <>
            help "Either a project URL or a project ID")

-- | ROOT option.
rootOpt :: Parser FilePath
rootOpt =
  argument return
           (metavar "ROOT" <>
            help "Project root directory")

-- | FILEPATH option.
filepathOpt :: Parser FilePath
filepathOpt =
  argument return
           (metavar "FILEPATH" <>
            help "The file path")

-- | TMPPATH option.
tmppathOpt :: Parser FilePath
tmppathOpt =
  argument return
           (metavar "TMPPATH" <>
            help "The temporary file path containing the actual contents of the module")

--------------------------------------------------------------------------------
-- Project ID

-- | Convert to project ID.
toFay :: String -> FayProjectId
toFay i = FayProjectId (T.pack (show (read i :: Int)))

-- | Convert to a project ID or project URL.
toFayPid :: String -> Either Text FayProjectId
toFayPid i
  | isPrefixOf "http" i = Left (T.pack i)
  | otherwise = Right (toFay i)

--------------------------------------------------------------------------------
-- Client

-- | Send a command to the fpco-server and output the response to stdout.
sendCommand :: ToJSON a => Config -> FilePath -> a -> IO ()
sendCommand config root msg = do
  env <- getEnvironment
  let host = fromMaybe "localhost" (lookup "FPCO_HOST" env)
      port = fromMaybe (configPort config) (lookup "FPCO_PORT" env >>= readMay)
  h <- connectOrStartServer config host port
  hSetBuffering h NoBuffering
  L.hPutStr h (encode msg)
  hPutStrLn h ""
  bytes <- L.hGetContents h
  case decode bytes of
    Just (ReplyCompileInfos infos) ->
      mapM_ (T.putStrLn . printSourceInfo root)
            infos
    Just (ReplyOK ()) ->
      return ()
    _ ->
      if L.null bytes
         then error ("Connection to listener was closed.")
         else error ("Unexpected reply from fpco-server: " ++
                     show bytes)

-- | Connect to the local server, if it can't connect, start the
-- server temporarily.
connectOrStartServer :: Config -> HostName -> Integer -> IO Handle
connectOrStartServer config host port = do
  catch (connect False)
        (\(e :: IOException) ->
           if configStartServer config
              then do putStrLn "Couldn't connect to local listener (probably not started yet). Running a temporary server instead."
                      runWithConfig (startServer True) config { configDebug = False }
                      connect True
              else throw e)

  where connect mention =
          do h <- connectTo host (PortNumber (fromInteger port))
             when mention
                  (putStrLn "Connected to temporary local listener ...")
             return h

-- | Print a flycheck-readable error/warning/hint.
printSourceInfo :: FilePath -> SourceInfo -> Text
printSourceInfo root (SourceInfo _ thespan msg) =
  printedSpan <> ":\n   " <>
  T.unlines (map pad (T.lines msg)) <> "\n"

  where pad x | T.isPrefixOf " " x = x
              | otherwise = " " <> x
        printedSpan =
          case thespan of
            TextSpan span' -> "<" <> T.pack span' <> ">"
            ProperSpan span' -> printSourceSpan root span'

--------------------------------------------------------------------------------
-- Configuration

-- | Make a configuration. Optionally a path to write to can be
-- passed.
configure :: Maybe FilePath -> IO ()
configure mfp = do
  fp <- getConfigPath mfp
  hSetBuffering stdout NoBuffering
  token <- prompt "your token"
  writeConfig fp def { configToken = token }
  putStrLn ("Wrote configuration to " ++ fp)
  return ()

  where prompt p = do putStr ("Please enter " ++ p ++ ": ")
                      getLine

-- | Write out a configuration.
writeConfig :: FilePath -> Config -> IO ()
writeConfig fp config =
  either (error . show)
         (writeFile fp)
         cp

  where cp = fmap (to_string :: ConfigParser -> String)
                  (write emptyCP)
        write = addSection "API" >=>
                addSection "SERVER" >=>
                setValue "API" "token" (configToken config) >=>
                setValue "API" "url" (configUrl config) >=>
                setValue "SERVER" "port" (show (configPort config))
        addSection = flip add_section
        setValue spec key v c = set c spec key v

-- | Run a command with the configuration, if there is one and make
-- one if there is not.
withConfig :: Maybe Text -> (Config -> IO a) -> Maybe FilePath -> IO a
withConfig agent cont mfp = go where
  go = do
    fp <- getConfigPath mfp
    exists <- doesFileExist fp
    if exists
       then do contents <- readFile fp
               case readConfig agent contents of
                 Left cperr -> error cperr
                 Right config -> cont config
       else do putStrLn ("No configuration found at " ++ fp)
               configure (Just fp)
               go

-- | Get the configuration path.
getConfigPath :: Maybe FilePath -> IO FilePath
getConfigPath mfp = do
  defp <- fmap (</> ".fpco-api.conf") getHomeDirectory
  return (fromMaybe defp mfp)

-- | Read the configuration file.
readConfig :: Monad m => Maybe Text -> String -> m Config
readConfig agent contents = do
  case config of
    Left cperr   -> error $ show cperr
    Right config' -> return config'

  where config = do
          c <- readstring emptyCP contents
          Config <$> get c "API" "token"
                 <*> get c "API" "url"
                 <*> get c "SERVER" "port"
                 <*> pure (fromMaybe (configAgent def) agent)
                 <*> pure (configDebug def)
                 <*> pure (configStartServer def)