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   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,catch)
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 def
  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: " <> pack 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 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))
    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 :: String -> String
stripSlash = reverse . dropWhile (=='/') . 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"