Server.hs

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings    #-}
{-# LANGUAGE RecordWildCards      #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TemplateHaskell      #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# OPTIONS -fno-warn-orphans     #-}

-- | Main entry point to the server.

module FP.Server
  ( runWithConfig
  , startServer
  , convertMsg
  ) where

import           FP.API
import           FP.API.Common
import           FP.API.Convert
import           FP.API.Signal
import           FP.Server.Spans
import           FP.Server.Types

import           Control.Concurrent.Async.Lifted (race, concurrently)
import           Control.Concurrent.Lifted
import           Control.Concurrent.STM
import           Control.Exception.Lifted hiding (handle)
import           Control.Monad.Extra
import           Control.Monad.Logger
import           Control.Monad.Reader hiding (forM_)
import           Control.Monad.Trans.Resource
import           Data.Aeson (FromJSON, ToJSON, decode, encode)
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy.Char8 as L8
import           Data.Data
import           Data.Foldable (forM_)
import           Data.IORef
import qualified Data.Map as M
import           Data.Maybe
import           Data.Monoid
import qualified Data.Text as T
import           Data.Text.Encoding (decodeUtf8, encodeUtf8, decodeUtf8With)
import           Data.Text.Encoding.Error (lenientDecode)
import qualified Data.Text.IO as T
import           Language.Fay.Yesod (Returns(..))
import           Network
import           Network.HTTP.Conduit
import           Network.HTTP.Types.Status
import           Prelude hiding (span,catch)
import           System.Directory
import           System.FilePath
import           System.IO

-- | Run the given Server command with the config. Good for testing in the repl.
runWithConfig :: ServerM () b -> Config -> IO b
runWithConfig m config = do
  manager <- newManager conduitManagerSettings
  projects <- newTVarIO mempty
  jar <- newIORef mempty
  (if configDebug config then runStderrLoggingT else runSilentLoggingT) $
    runReaderT m
               (ServerState (CC (stripSlash (configUrl config))
                                (configToken config)
                                manager
                                jar
                                (configAgent config))
                            config
                            projects
               , ())
  where runSilentLoggingT m' =
          runLoggingT m' (\_loc _src _lvl _str -> return ())

-- | Start the server.
startServer :: Bool -> ServerM () ()
startServer forkOnceListening = do
  Config {..} <- asks (serverConfig . fst)
  io (hSetBuffering stdout NoBuffering)
  sock <- io (listenOn (PortNumber (fromIntegral configPort)))
  $(logInfo) ("Server started on port " <> T.pack (show configPort) <>
              ", remote URL is: " <> configUrl)
  (if forkOnceListening then void . fork else id)
    (forever (acceptConnection sock))

-- | Accept a connection on the given socket.
acceptConnection :: Socket -> ServerM () ()
acceptConnection sock = do
  (handle,remote,port) <- io (accept sock)
  io (hSetBuffering handle NoBuffering)
  $(logInfo) ("Connection accepted from: " <> T.pack remote <>
              ":" <> T.pack (show port) <>
              " (" <> T.pack (show handle) <> ")")
  void (fork (handleLine handle))

-- | Handle a single line of input.
handleLine :: Handle -> ServerM () ()
handleLine handle =
  finally (getJsonLine handle >>= flip forM_ (handleClientMessage handle))
          (close handle)

-- | Get a JSON line if possible and pass it to the continuation.
getJsonLine :: (Show a,FromJSON a) => Handle -> ServerM s (Maybe a)
getJsonLine handle = do
  result <- io (try (S8.hGetLine handle))
  case result of
    Left (_ :: IOException) -> do
      $(logError) "Unable to get line from handle."
      return Nothing
    Right line -> do
      case decode (LBS.fromChunks [line]) of
        Nothing -> do
          $(logError) ("Unable to parse JSON from line! " <> decodeUtf8 line)
          return Nothing
        Just msg -> do
          $(logDebug) ("<- " <> T.pack (show msg))
          return (Just msg)

-- | Handle any incoming message from the client.
handleClientMessage :: Handle -> Msg -> ServerM () ()
handleClientMessage h msg =
  case msg of
    MsgSaveModule pid root filename ->
      withProjectId pid $ saveTheFile h root filename
    MsgCheckModule pid root filename path ->
      withProjectId pid $ checkModule h root filename path
    MsgTypeInfo pid filename sl sc el ec ->
      withProjectId pid $ typeInfo h filename sl sc el ec
    MsgGetDefinition pid root filename sl sc el ec ->
      withProjectId pid $ getDefinition h root filename sl sc el ec
    MsgAutoComplete pid filename prefix ->
      withProjectId pid $ autoComplete h filename prefix
    MsgHoogleIdent pid filename name ->
      withProjectId pid $ hoogleIdent h filename name
    MsgHoogleDb pid name ->
      withProjectId pid $ hoogleDb h name
    MsgDownloadFiles epid fp ->
      withEProjectId epid $ downloadFiles h fp
    MsgWriteEmacsConfig epid fp ->
      withEProjectId epid $ writeEmacsConfig h fp
    MsgRunTarget pid ->
      withProjectId pid $ runCurrentTarget h

-- Message handlers

-- | Run the current target.
runCurrentTarget :: Handle -> Server ()
runCurrentTarget h = do
  ClientInfo {..} <- clientInfo
  pidVar <- io newEmptyTMVarIO
  -- Watch for web process urls.
  unsub <- io $ subscribeSignal (pcNewStatus ciCallbacks) $ \unsub snap -> do
    mpid <- io $ atomically $ tryReadTMVar pidVar
    case (mpid, snapProcessStatus snap) of
      (Just pid, SnapshotProcessRunning pid' (Just url))
        | pid' == pid -> do reply h (ReplyWebUrl (Approot url))
                            io unsub
      _ -> return ()
  void $ (`finally` io unsub) $
    -- Start the process.  This is done asynchronously with output
    -- collection because output can be yielded concurrently with the
    -- ProcId.
    (`concurrently` (runTarget False >>= io . atomically . putTMVar pidVar)) $
    -- Fetch process input from the client.
    (`race` (io (atomically (readTMVar pidVar)) >>= getStdin)) $
    -- Send process output to the client.
    io $ blockOnSignal Nothing (pcProcessOutput ciCallbacks) $ \(k, v) -> do
      pid <- io $ atomically $ readTMVar pidVar
      if k /= pid
         then return Nothing
         else do
           case v of
             SRSuccess x -> do
               reply h (ReplyStdout x)
               return Nothing
             SRTerminated PRExitSuccess ->
               return (Just ())
             SRTerminated err -> do
               reply h (ReplyStderr (T.pack (show err)))
               return (Just ())
  where
    getStdin pid = do
      msg <- getJsonLine h
      case msg of
        Just (MsgStdin text) -> do
          success <- putStdin pid text
          when (not success) $ $(logError) "Failed to send stdin."
          getStdin pid
        Just (MsgKill _) ->
          stopRunningCode
        _ -> do
          $(logError) $
            "Didn't expect to recieve the following message when running a process:\n" <>
            T.pack (show msg)
          getStdin pid

-- | Write out the .dir-locals.el file for the project.
writeEmacsConfig :: Handle -> FilePath -> Server ()
writeEmacsConfig h root = do
  (_, pid) <- ask
  io (writeFile (root </> ".dir-locals.el")
                (unlines (src pid)))
  reply h (ReplyOK ())
  where src pid =
          ["((nil . ((fpco-pid . " ++ unProjectIdString pid ++ ")"
          ,"         (eval . (set (make-local-variable 'fpco-root)"
          ,"                       (expand-file-name"
          ,"                         (locate-dominating-file buffer-file-name \".dir-locals.el\")))))))))"]

-- | Download all files in the project, overwriting any local copies.
downloadFiles :: Handle -> FilePath -> Server ()
downloadFiles h root = do
  ipi <- getInitialProjectInfo "emacs"
  forM_ (ipiFiles ipi) (updateFileContents root . fdEncFileName)
  reply h (ReplyOK ())

-- | Hoogle search whole database.
hoogleDb :: Handle -> T.Text -> Server ()
hoogleDb h q = do
  (_, results, _) <- ideHoogleSearch Nothing exact count offset limit q
  reply h (ReplyHoogleResults results)
  where exact = False
        count = 10
        offset = 0
        limit = count

-- | Hoogle search for an identifier in a module.
hoogleIdent :: Handle -> String -> T.Text -> Server ()
hoogleIdent h filename q = do
  (_, results, _) <- ideHoogleSearch (Just mname) exact count offset limit q
  case results of
    (result:_) -> reply h (ReplyHoogleResult result)
    _ -> return ()
  where mname = encFileNameFromString filename
        exact = True
        count = 10
        offset = 0
        limit = count

-- | Autocomplete the given prefix replying with a list of
-- completions.
autoComplete :: Handle
             -> FilePath
             -> T.Text
             -> Server ()
autoComplete h filename prefix = do
  case T.strip prefix of
    "" -> reply h (ReplyCompletions [])
    _ -> do
      let input = AutoCompleteInput (encFileNameFromString filename) prefix
      completions <- getAutocompletions input
      reply h (ReplyCompletions completions)

-- | Get the definition location of the identifier at the given span.
getDefinition :: Handle
              -> FilePath
              -> FilePath
              -> Int -> Int
              -> Int -> Int
              -> Server ()
getDefinition h root filename sl sc el ec = do
  midinfo <- getDefinitionSource defSpan
  case midinfo of
    NoIdInfo -> return ()
    IdInfo _ info -> reply h (ReplyLocation (makeDef info))
  where defSpan =
           SourceSpan (encFileNameFromString filename)
                      sl sc
                      el ec
        makeDef (DefinitionLocal _name span) =
          DefinitionLoc (makeLoc root span)
        makeDef (DefinitionTextSpan name loc) =
          DefinitionUseless (name <> " " <> loc <> " (nowhere known to go)")
        makeDef (DefinitionImported name m1 m2 es1 es2) =
          DefinitionImport name
                           (makePackageModule m1)
                           (makePackageModule m2)
                           (makeEitherLoc root es1)
                           (makeEitherLoc root es2)
        makeDef (DefinitionWiredIn name) =
          DefinitionUseless ("Wired-in: " <> name <> " (nowhere to go!)")
        makeDef (DefinitionBinder name) =
          DefinitionUseless ("Binder: " <> name <> " (you're already there!)")

-- | Print a package:module pair.
makePackageModule :: ModuleId -> PackageModule
makePackageModule (ModuleId _ mname pkg) =
  PackageModule (packageName pkg) (unModuleName mname)

-- | Get type info of span.
typeInfo :: Handle
         -> String
         -> Int -> Int
         -> Int -> Int
         -> Server ()
typeInfo h filename sl sc el ec = do
  infos <- getTypeInfoDominators span
  reply h (ReplyTypeInfo (map toSpanType infos))
  where span =
          SourceSpan (encFileNameFromString filename)
                     sl sc
                     el ec

-- | Save the given file.
saveTheFile :: Handle -> FilePath -> FilePath -> Server ()
saveTheFile h root filename = do
  res <- saveFileInternal (root </> filename) filename
  case res of
    SaveSucceeded _ -> reply h (ReplySaveStatus False)
    SaveFailed -> do
      updateFileContents root (encFileNameFromString filename)
      reply h (ReplySaveStatus True)

-- | Check the given module. Necessary for flycheck.
checkModule :: Handle -> FilePath -> FilePath -> FilePath -> Server ()
checkModule h root filename bufferfile = do
  $(logDebug) "Check module"
  res <- saveFileInternal bufferfile filename
  case res of
    -- If there's an out of date error, don't break the flychecker,
    -- just return no errors for now.
    -- TODO: Should do something better than this, like what
    -- saveTheFile does.
    SaveFailed -> reply h (ReplyCompileInfos [])
    -- Similarly, if this didn't enque a compile, pretend like there
    -- are no errors...
    SaveSucceeded Nothing -> reply h (ReplyCompileInfos [])
    SaveSucceeded (Just desc) -> do
      infos <- watchStatusOneShot "checkModule" Nothing $ \status ->
        case snapCompileStatus status of
          RunnerCompileDone cid infos | cid == cdCompileIdent desc -> return (Just infos)
          _ -> return Nothing
      reply h (ReplyCompileInfos infos)

data SaveFileResult
  = SaveSucceeded (Maybe CompileDesc)
  | SaveFailed

saveFileInternal :: FilePath -> FilePath -> Server SaveFileResult
saveFileInternal localPath serverPath = do
  text <- io (T.readFile localPath)
  let fname = encFileNameFromString serverPath
  eres <- try $ saveFile' fname text
  case eres of
    Right res -> return (SaveSucceeded res)
    Left (_ :: ClientException) -> return SaveFailed

-- The communication API

-- | Reply with the given value.
reply :: (ToJSON a,Show a) => Handle -> a -> Server ()
reply h r = do
  $(logDebug) ("-> " <> T.take 140 (T.pack (show r)))
  io (L8.hPutStrLn h (encode r))

-- | Close the given handle.
close :: Handle -> ServerM () ()
close h = do
  $(logDebug) ("Connection closed to " <> T.pack (show h))
  io (hClose h)

--- | Update the contents of the given file from the server.
updateFileContents :: FilePath -> EncFileName -> Server ()
updateFileContents root name = do
  mtext <- getFile' name
  let fp = root </> unEncFileNameString name
  --FIXME: Better handling of binary files?
  case mtext of
    Nothing -> $(logDebug) (T.pack fp <> " not written because it's a binary file.  This will be fixed in the future.")
    Just text -> io $ do
      createDirectoryIfMissing True (takeDirectory fp)
      T.writeFile (root </> fp) text

-- | Strip the trailing slash.
stripSlash :: T.Text -> T.Text
stripSlash = T.reverse . T.dropWhile (=='/') . T.reverse

-- | Convert an API message to a more structurally convenient reply message.
convertMsg :: FilePath -> SourceInfo -> CompileMessage
convertMsg root SourceInfo{..} =
  CompileMessage (printEitherSpan root infoSpan)
                 kind
                 msg
  where kind =
          case infoKind of
            SIKError    -> "error"
            SIKWarning  -> "warning"
            SIKMismatch -> "warning"
            SIKHint     -> "hint"
        msg = T.concat $ map snd (filter ((/= ICTOriginal) . fst) infoMsg)

withProjectId :: ProjectId -> Server a -> ServerM () a
withProjectId pid m = withReaderT (\(x, ()) -> (x, pid)) m

ideCommandTimeout :: Int
ideCommandTimeout = 1000 * 1000 * 60 * 5

-- | Get the project ID from either a URL or a project ID.
withEProjectId :: Either T.Text ProjectId -> Server a -> ServerM () a
withEProjectId epid f = do
  case epid of
    Left url -> do
      let cmd = GetProjectId url Returns
          shownCmd = show cmd
      bs <- runCommand "getting project id" 200 "/misc-command" cmd
      mpid <- handleServerResponse shownCmd (Just bs)
      case mpid of
        Failure err -> clientFail $ "Failed to get project-id for URL: " <> err
        Success pid -> withProjectId pid f
    Right pid -> withProjectId pid f

-- Send commands to the server

instance FpClient (ServerM ProjectId) (ServerM ProjectId) where
  runCallback = id
  clientInfo = do
    (state, pid) <- ask
    -- If the project hasn't been started, then fork off a messages
    -- poller, and add it to the list of projects.
    projects <- io $ readTVarIO $ serverProjects state
    case M.lookup pid projects  of
      Nothing -> do
        prj <- io $ newClientInfo ideCommandTimeout pid
        io $ atomically $ writeTVar (serverProjects state) (M.insert pid prj projects)
        void $ fork pollProjectMessages
        return prj
      Just prj -> return prj
  makeRequest msg status r cmd = do
    let url = case r of
                MiscCommandRoute -> "/misc-command"
                IdeMessagesRoute pid -> "/ide-messages/" <> unProjectIdText pid
                IdeAsyncCommandRoute pid -> "/ide-async-command/" <> unProjectIdText pid
    fmap Just $ runCommand msg status url cmd

runCommand :: (Show cmd, Data cmd) => T.Text -> Int -> T.Text -> cmd -> ServerM r LBS.ByteString
runCommand msg expected url cmd = do
  CC{..} <- asks (serverCC . fst)
  request <- parseUrl (T.unpack (ccUrl <> url))
  jar <- io $ readIORef ccCookie
  let req = request
          { method = "POST"
          , requestHeaders = requestHeaders request ++
                             [("Accept","application/json")
                             ,("User-Agent",encodeUtf8 ("fpco-api:" <> ccUserAgent))
                             ,("authorization",encodeUtf8 ("token " <> ccToken))]
          , responseTimeout = Nothing
          , cookieJar = Just jar
          , requestBody = RequestBodyLBS $ encode (encodeFpco cmd)
          , checkStatus = \_ _ _ -> Nothing
          }
  $(logDebug) ("=> " <> T.take 140 (T.pack (show cmd)))
  resp <- io (runResourceT (httpLbs req ccManager))
  io $ writeIORef ccCookie (responseCookieJar resp)
  let code = statusCode (responseStatus resp)
  if expected /= code
     then clientFail $
         "Bad status code returned from client command: " <> T.pack (show code) <>
         if code == 404
            then mempty
            else "\nResponse: " <> decodeUtf8With lenientDecode (S8.concat (LBS.toChunks (responseBody resp)))
     else return (responseBody resp)

errPrefix :: Show cmd => T.Text -> cmd -> T.Text
errPrefix msg cmd = "Error from request, while " <> msg <> ": " <> T.pack (show cmd) <> "\n"