Server.hs

{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE QuasiQuotes         #-}
{-# LANGUAGE RecordWildCards     #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell     #-}

-- | Main entry point to the server.

module FP.Server where

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

import           Control.Applicative
import           Control.Concurrent.Lifted
import           Control.Exception.Lifted   as E hiding (handle)
import           Control.Monad.Extra
import           Control.Monad.Logger
import           Control.Monad.Reader
import           Data.Aeson
import qualified Data.ByteString.Char8      as S8
import           Data.ByteString.Lazy       (fromChunks)
import qualified Data.ByteString.Lazy.Char8 as L8
import           Data.IORef
import qualified Data.Map                   as M
import           Data.Map (Map)
import           Data.Maybe
import           Data.Monoid
import           Data.Text                  (Text, pack, unpack)
import qualified Data.Text                  as T
import           Data.Text.Encoding         (decodeUtf8)
import qualified Data.Text.IO               as T
import           Data.Typeable
import           Network
import           Network.HTTP.Conduit
import           Prelude                    hiding (span)
import           System.Directory
import           System.FilePath
import           System.IO
import           Texts.English

-- | Run the given Server command with the config. Good for testing in the repl.
runWithConfig :: Server b -> Config -> IO b
runWithConfig m config = do
  manager <- newManager conduitManagerSettings
  pollers <- newMVar mempty
  jar <- newIORef mempty
  tokensVar <- newMVar mempty
  tokens <- newMVar tokensVar
  runReaderT ((if configDebug config then runStderrLoggingT else runSilentLoggingT) m)
             (ServerReader (CC (stripSlash (configUrl config))
                               (configToken config)
                               manager
                               jar
                               (configAgent config))
                           config
                           pollers
                           tokens)

  where runSilentLoggingT m' =
          runLoggingT m' (\_loc _src _lvl _str -> return ())

-- | Start the server.
startServer :: Bool -> Server ()
startServer forkOnceListening = do
  Config{..} <- asks serverConfig
  io (hSetBuffering stdout NoBuffering)
  sock <- io (listenOn (PortNumber (fromIntegral configPort)))
  $(logInfo) ("Server started on port " <> 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 -> Server ()
acceptConnection sock = do
  (handle,remote,port) <- io (accept sock)
  io (hSetBuffering handle NoBuffering)
  $(logInfo) ("Connection accepted from: " <> pack remote <>
              ":" <> pack (show port) <>
              " (" <> pack (show handle) <> ")")
  void (fork (handleLine handle))

-- | Handle a line of input.
handleLine :: Handle -> Server ()
handleLine handle = flip finally (close handle) $ do
  result <- io (try (S8.hGetLine handle))
  case result of
    Left (_ :: IOException) -> do
      $(logError) "Unable to get line from handle."
    Right line -> do
      case decode (fromChunks [line]) of
        Nothing -> do
          $(logError) ("Unable to parse JSON from line: " <> decodeUtf8 line)
        Just msg -> do
          $(logDebug) ("<- " <> pack (show msg))
          handleMessage handle msg

-- | Handle any incoming message from the client.
handleMessage :: Handle -> Msg -> Server ()
handleMessage h msg =
  case msg of
    MsgSaveModule fpid root filename ->
      saveTheModule h fpid root filename
    MsgCheckModule fpid root filename path ->
      checkModule h fpid root filename path
    MsgTypeInfo fpid filename sl sc el ec ->
      typeInfo h fpid filename sl sc el ec
    MsgGetDefinition fpid root filename sl sc el ec ->
      getDefinition h fpid root filename sl sc el ec
    MsgAutoComplete fpid filename prefix ->
      autoComplete h fpid filename prefix
    MsgHoogleIdent fpid filename name ->
      hoogleIdent h fpid filename name
    MsgHoogleDb fpid name ->
      hoogleDb h fpid name
    MsgDownloadFiles fpid fp ->
      downloadFiles h fpid fp
    MsgWriteEmacsConfig fpid fp ->
      writeEmacsConfig h fpid fp

-- Message handlers

-- | Write out the .dir-locals.el file for the project.
writeEmacsConfig :: Handle -> Either Text FayProjectId -> FilePath -> Server ()
writeEmacsConfig h pid root = do
  fpid <- getFayProjectId pid
  io (writeFile (root </> ".dir-locals.el")
                (unlines (src fpid)))
  reply h (ReplyOK ())

  where src fpid =
          ["((nil . ((fpco-pid . " ++ unpack (unFayProjectId fpid) ++ ")"
          ,"         (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 -> Either Text FayProjectId -> FilePath -> Server ()
downloadFiles h pid root = do
  fpid <- getFayProjectId pid
  ipi <- getInitialProjectInfo fpid
  forM_ (ipiFiles ipi) $ \(name,_) -> do
    FileContent text _ <- getFile name fpid
    io (writeCreateFile (root </> T.unpack (unFayFileName name))
                        (fromMaybe "" text))
  reply h (ReplyOK ())

  where writeCreateFile fp text = do
          io (createDirectoryIfMissing True (takeDirectory fp))
          T.writeFile (root </> fp) text

-- | Hoogle search whole database.
hoogleDb :: Handle -> FayProjectId -> Text -> Server ()
hoogleDb h fpid q = do
  void (ideHoogleSearch Nothing exact count offset limit q fpid)
  wait fpid
       (Callback
          (\_mid msg ->
             case msg of
               HoogleResults _ results _ ->
                   do reply h (ReplyHoogleResults results)
                      return Done
               _ -> return NotDone))

  where exact = False
        count = 10
        offset = 0
        limit = count

-- | Hoogle search for an identifier in a module.
hoogleIdent :: Handle -> FayProjectId -> String -> Text -> Server ()
hoogleIdent h fpid filename q = do
  hid <- ideHoogleSearch (Just mname) exact count offset limit q fpid
  wait fpid
       (Callback
          (\mid msg ->
             case msg of
               HoogleResults _ results _
                 | toHoogleId mid == Just hid ->
                   do case results of
                        (result:_) -> reply h (ReplyHoogleResult result)
                        _ -> return ()
                      return Done
               _ -> return NotDone))

  where mname = FayFileName (pack filename)
        exact = True
        count = 10
        offset = 0
        limit = count
        toHoogleId = fmap HoogleId

-- | Autocomplete the given prefix replying with a list of
-- completions.
autoComplete :: Handle
             -> FayProjectId
             -> FilePath
             -> Text
             -> Server ()
autoComplete h fpid filename prefix = do
  case T.strip prefix of
    "" -> reply h (ReplyCompletions [])
    _ -> do
      getAutocompletions input fpid
      wait fpid
           (Callback
              (\_ msg ->
                 case msg of
                   AutoCompleteResults input' completions
                     | Just input == input' -> do reply h (ReplyCompletions completions)
                                                  return Done
                   _ -> return NotDone))

  where input = AutoCompleteInput (FayFileName (pack filename))
                                  prefix

-- | Get the definition location of the identifier at the given span.
getDefinition :: Handle
              -> FayProjectId -> FilePath
              -> FilePath
              -> Int -> Int
              -> Int -> Int
              -> Server ()
getDefinition h fpid root filename sl sc el ec = do
  getDefinitionSource defSpan fpid
  wait fpid
       (Callback (\_ msg ->
                    case msg of
                      IdInfoResults i ->
                        case i of
                          NoIdInfo src
                            | src == defSpan -> return Done
                          IdInfo src _ info
                            | src == defSpan -> do reply h (ReplyLocation (makeDef info))
                                                   return Done
                          _ -> return NotDone
                      _ -> return NotDone))

  where defSpan =
           SourceSpan (FayFileName (pack filename))
                      sl sc
                      el ec
        makeDef (DefinitionLocal span) =
          DefinitionLoc (makeLoc root span)
        makeDef (DefinitionTextSpan t1 t2) =
          DefinitionUseless (t1 <> " " <> t2 <> " (nowhere known to go)")
        makeDef (DefinitionImported text m1 m2 es1 es2) =
          DefinitionImport text
                           (makeModuleId m1)
                           (makeModuleId m2)
                           (makeEitherLoc root es1)
                           (makeEitherLoc root es2)
        makeDef (DefinitionWiredIn text) =
          DefinitionUseless ("Wired-in: " <> text <> " (nowhere to go!)")
        makeDef (DefinitionBinder text) =
          DefinitionUseless ("Binder: " <> text <> " (you're already there!)")

-- | Print a package:module pair.
makeModuleId :: FayModuleId -> ModuleId
makeModuleId (FayModuleId _ mname pkg) =
  (ModuleId (packageName pkg) (unFayModuleName mname))

-- | Get type info of span.
typeInfo :: Handle
         -> FayProjectId -> String
         -> Int -> Int
         -> Int -> Int
         -> Server ()
typeInfo h fpid filename sl sc el ec = do
  getTypeInfo span 0 fpid
  wait fpid
       (Callback
          (\_ msg -> do
             case msg of
               SubExprsResults span' infos
                 | span' == span -> do reply h (ReplyTypeInfo (map toSpanType (concat infos)))
                                       return Done
               _ -> return NotDone))

  where span =
          SourceSpan (FayFileName (pack filename))
                     sl sc
                     el ec

-- | Save the given module.
saveTheModule :: Handle -> FayProjectId -> FilePath -> FilePath -> Server ()
saveTheModule h fpid root filename =
  withTokens (\tokensVar -> do
    let fname = FayFileName (pack filename)
    token <- getToken tokensVar fpid root filename
    text <- io (T.readFile (root </> filename))
    E.catch (do SaveFileOutput token' _ <- saveFile fname text token fpid
                updateToken tokensVar root filename token'
                reply h (ReplySaveStatus False))
            -- A command exception will be thrown when the file is out of
            -- date. So we just immediately grab the new version of the
            -- file, overwrite out local copy. Emacs will prompt the user
            -- about it at the right time.
            (\(_ :: CommandException) ->
               do updateFileContents tokensVar fpid root filename
                  reply h (ReplySaveStatus True)))

-- | Check the given module. Necessary for flycheck.
checkModule :: Handle -> FayProjectId -> FilePath -> FilePath -> FilePath -> Server ()
checkModule h fpid root filename filepath =
  withTokens (\tokensVar -> do
    let fname = FayFileName (pack filename)
    token <- getToken tokensVar fpid root filename
    text <- io (T.readFile filepath)
    result <- try (saveFile fname text token fpid)
    case result of
      -- If there's an out of date error, don't break the flychecker,
      -- just return no errors for now.
      Left (_ :: CommandException) -> reply h (ReplyCompileInfos [])
      Right (SaveFileOutput token' (CompileChanged mcid _)) -> do
        updateToken tokensVar root filename token'
        case mcid of
          Nothing -> reply h (ReplyCompileInfos [])
          Just _ -> do
            wait fpid
                 (Callback
                    (\_ msg ->
                       case msg of
                         StatusSnapshot snapshot _ ->
                           case snapCompileStatus snapshot of
                             RunnerNotCompiling  -> return NotDone
                             RunnerCompiling _ _ -> return NotDone
                             RunnerCompileDone _ infos -> do
                               reply h
                                     (ReplyCompileInfos infos)
                               return Done
                         _ -> return NotDone)))

-- The communication API

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

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

-- | Start poller if there isn't already one running for the given
-- project, and in any case add the given callback to the list. This
-- blocks on the result.
wait :: FayProjectId -- ^ The project to poll on.
     -> Callback     -- ^ Take the message or pass it back.
     -> Server ()
wait fpid (Callback callback) = do
  waiter <- newEmptyMVar
  let wcallback = waiting waiter
  psvar <- asks serverPollers
  start <- modifyMVar psvar $ \pollers ->
    case M.lookup fpid pollers of
      -- Either insert or append
      Just{}  -> return (M.insertWith (++) fpid [wcallback] pollers,False)
      Nothing -> return (M.insert fpid [wcallback] pollers,True)
  when start $
    void $ fork $ poll fpid
  takeMVar waiter

  where waiting waiter = Callback $ \mid msg ->
          do ret <- callback mid msg
             case ret of
               Done -> putMVar waiter ()
               _ -> return ()
             return ret

-- | Remove a poller from the polling list and any broadcast
-- callbacks.
removePoller :: FayProjectId -> Server ()
removePoller fpid = do
  psvar <- asks serverPollers
  modifyMVar_ psvar (return . M.delete fpid)

-- | Poll for new messages and apply any queued callbacks to them.
poll :: FayProjectId -> Server ()
poll fpid = do
  getIPI fpid
  $(logDebug) ("Polling on project " <> pack (show fpid))
  go PMRImmediateStatusNoMessages

  where go statusHash = do
          result <- try (getProjectMessages statusHash fpid)
          case result of
            Left (SomeException ge) ->
              case fmap Left (cast ge) <|> fmap Right (cast ge) of
                Nothing ->
                  do removePoller fpid
                     throw ge
                Just (e :: Either HttpException CommandException) ->
                  do $(logError) ("Error while polling for messages: " <> pack (show e))
                     $(logError) ("Waiting 10 seconds before polling again ...")
                     threadDelay (1000 * 1000 * 10)
                     go PMRImmediateStatusNoMessages
            Right (ProjectMessagesOutput nextfilt messages) ->
              do psvar <- asks serverPollers
                 modifyMVar_ psvar $ \pollers ->
                   case M.lookup fpid pollers of
                     Nothing -> return pollers
                     Just callbacks -> do
                       callbacks' <- foldM applyCallbacks callbacks messages
                       return (M.insert fpid callbacks' pollers)
                 go (newRequest nextfilt messages)
        newRequest nextfilt messages =
          fromMaybe (if null messages
                        then PMRImmediateStatusNoMessages
                        else PMRImmediateStatusWithMessages nextfilt)
                    (latestHash messages)

        latestHash = listToMaybe . mapMaybe latest . reverse where
          latest (_,StatusSnapshot _ hash) = Just (PMRNextStatusWithMessages PMFilterAll hash)
          latest _ = Nothing

-- | Get initial project information.
getIPI :: FayProjectId -> Server ()
getIPI fpid = do
  _ <- getInitialProjectInfo fpid
  return ()

-- | Applies the given callbacks to the given message. Returns a new
-- list of callbacks. If any of the callbacks are now done, they will
-- be removed from the list.
applyCallbacks :: [Callback] -> (Maybe Int, RunnerMessage) -> Server [Callback]
applyCallbacks callbacks (mtag,msg) = do
  fmap catMaybes $ forM callbacks $ \callback@(Callback call) -> do
    result <- try (call mtag msg)
    case result of
      Right Done -> return Nothing
      Right NotDone -> return (Just callback)
      -- Callbacks that throw exceptions are discarded.
      Left (e :: SomeException) -> do
        $(logError) ("Callback threw exception: " <> pack (show e))
        return Nothing

-- Misc

-- | Get the token of the given file.
getToken :: MVar (Map FilePath FayTutorialToken) -> FayProjectId -> FilePath -> FilePath -> Server FayTutorialToken
getToken tokensVar fpid root file = do
  modifyMVar tokensVar
             (\tokens ->
                case M.lookup key tokens of
                  Nothing -> do token <- getFileToken (FayFileName (T.pack file)) fpid
                                return (M.insert key token tokens,token)
                  Just token -> return (tokens,token))

  where key = root </> file

-- | Update the contents of the given file from the server.
updateFileContents :: MVar (Map FilePath FayTutorialToken) -> FayProjectId -> FilePath -> FilePath
                   -> Server ()
updateFileContents tokensVar fpid root filename = do
  FileContent text token <- getFile (FayFileName (T.pack filename)) fpid
  updateToken tokensVar root filename token
  io (T.writeFile (root </> filename)
                  (fromMaybe "" text))

-- | Update the token of the given file.
updateToken :: MVar (Map FilePath FayTutorialToken) -> FilePath -> FilePath
            -> FayTutorialToken -> Server ()
updateToken tokensVar root file token = do
  $(logDebug) ("Updating file token: " <> T.pack key <> ": " <> pack (show token))
  modifyMVar_ tokensVar
              (return . M.insert key token)

  where key = root </> file

-- | Do something exclusively with tokens. Due to the fact that
-- flychecking and buffer saving *can* occur simultaneously from
-- Emacs, we don't want those two racing save capabilities.
--
-- On the other hand it doesn't matter what order they occur because
-- they'll be saving the same content. So we simply require that any
-- command that uses module tokens needs to happen in an exclusion.
withTokens :: (MVar (Map FilePath FayTutorialToken) -> Server a) -> Server a
withTokens cont = do
  tokensVar <- asks serverTokens
  withMVar tokensVar cont

-- | Get the project ID from either a URL or a project ID.
getFayProjectId :: Either Text FayProjectId -> Server FayProjectId
getFayProjectId = either getProjectId return

-- | Strip the trailing slash.
stripSlash :: Text -> 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
                 infoMsg

  where kind =
          case infoKind of
            KindError   -> "error"
            KindWarning -> "warning"
            KindHint    -> "hint"