fpco-api (empty) → 1.0.0

raw patch · 14 files changed

+2366/−0 lines, 14 filesdep +ConfigFiledep +aesondep +attoparsecsetup-changed

Dependencies added: ConfigFile, aeson, attoparsec, base, bytestring, containers, data-default, directory, failure, fay, filepath, fpco-api, ghc-prim, http-conduit, http-types, lifted-base, monad-extras, monad-logger, mtl, network, optparse-applicative, persistent, persistent-template, pretty-show, process, random, resourcet, safe, syb, template-haskell, text, texts, unordered-containers, vector, yesod-fay

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• fpco-api.cabal +79/−0
• src/executables/Main.hs +306/−0
• src/library/FFI.hs +5/−0
• src/library/FP/API.hs +34/−0
• src/library/FP/API/Convert.hs +234/−0
• src/library/FP/API/Run.hs +109/−0
• src/library/FP/API/TH.hs +41/−0
• src/library/FP/API/Types.hs +779/−0
• src/library/FP/Server.hs +510/−0
• src/library/FP/Server/Config.hs +11/−0
• src/library/FP/Server/Spans.hs +41/−0
• src/library/FP/Server/Types.hs +185/−0

@@ -0,0 +1,30 @@+Copyright (c) 2013, FP Complete++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of FP Complete nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,79 @@+name:                 fpco-api+version:              1.0.0+synopsis:             API interface for the FP Complete API.+description:          Data types and serialization for communicating with the FP Complete IDE API.+homepage:             https://www.fpcomplete.com/page/api+license:              BSD3+license-file:         LICENSE+author:               FP Complete+maintainer:           dev@fpcomplete.com+copyright:            2013 FP Complete+category:             Development+build-type:           Simple+cabal-version:        >=1.10++flag jenkins-build+  default: False++library+  ghc-options:       -Wall -O2 -threaded+  hs-source-dirs:     src/library+  exposed-modules:    FP.API, FP.API.Run, FP.API.Types, FP.Server, FP.Server.Types, FP.Server.Config,+                      FP.Server.Spans, FP.API.Convert+  other-modules:      FP.API.TH, FFI+  default-language:   Haskell2010+  build-depends:      base >=4 && < 5,+                      aeson ==0.6.*,+                      bytestring ==0.9.*,+                      ConfigFile ==1.1.*,+                      data-default ==0.5.*,+                      text ==0.11.*,+                      network ==2.4.*,+                      optparse-applicative ==0.5.*,+                      safe ==0.3.*,+                      directory ==1.1.*,+                      filepath ==1.3.*,+                      fay ==0.18.*,+                      lifted-base ==0.2.*,+                      monad-extras ==0.5.*,+                      monad-logger ==0.3.*,+                      mtl ==2.1.*,+                      containers ==0.4.*,+                      http-conduit ==1.9.*,+                      texts ==0.3.*,+                      ghc-prim ==0.2.*,+                      template-haskell ==2.7.*,+                      attoparsec ==0.10.*,+                      syb ==0.4.*,+                      unordered-containers ==0.2.*,+                      vector ==0.10.*,+                      pretty-show ==1.6.*,+                      failure ==0.2.*,+                      resourcet ==0.4.*,+                      yesod-fay ==0.4.*,+                      http-types ==0.8.*,+                      persistent ==1.2.*,+                      persistent-template ==1.2.*,+                      random ==1.0.*++executable fpco-api+  if flag(jenkins-build)+    buildable: False+  ghc-options:        -Wall -threaded -O2+  main-is:            Main.hs+  default-extensions: CPP+  hs-source-dirs:     src/executables+  default-language:   Haskell2010+  build-depends:      base >=4 && < 5,+                      fpco-api,+                      optparse-applicative == 0.5.*,+                      bytestring == 0.9.*,+                      network ==2.4.*,+                      safe ==0.3.*,+                      aeson ==0.6.*,+                      text ==0.11.*,+                      directory ==1.1.*,+                      filepath ==1.3.*,+                      ConfigFile ==1.1.*,+                      data-default ==0.5.*,+                      process == 1.1.*

@@ -0,0 +1,306 @@+{-# 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)

@@ -0,0 +1,5 @@+-- | A helper module which can be compiled for Haskell and ignored for Fay.++module FFI (module Fay.FFI) where++import Fay.FFI

@@ -0,0 +1,34 @@+{-# LANGUAGE NoMonomorphismRestriction #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS -fno-warn-missing-signatures #-}++-- | Commands for the IDE API.++module FP.API where++import FP.API.Types+import FP.API.TH++-- General project operations++cmd 'GetInitialProjectInfo+cmd 'GetProjectId++-- Polling++cmd 'GetProjectMessages++-- Module manipulation++cmd 'GetFile+cmd 'GetFileToken+cmd 'SaveFile+cmd 'AddFile+cmd 'DeleteFile++-- Query features++cmd 'GetTypeInfo+cmd 'GetDefinitionSource+cmd 'GetAutocompletions+cmd 'IdeHoogleSearch

@@ -0,0 +1,234 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings  #-}+{-# LANGUAGE PatternGuards      #-}+{-# LANGUAGE TupleSections      #-}+{-# OPTIONS -fno-warn-type-defaults #-}++-- | Convert a Haskell value to a (JSON representation of a) Fay value.++module FP.API.Convert+  (showToFay'+  ,readFromFay')+  where++import           Control.Applicative+import           Control.Monad+import           Control.Monad.State+import           Data.Aeson+import           Data.Attoparsec.Number+import           Data.Char+import           Data.Data+import           Data.Function+import           Data.Generics.Aliases+import           Data.HashMap.Strict    (HashMap)+import qualified Data.HashMap.Strict    as Map+import           Data.Maybe+import           Data.Text              (Text)+import qualified Data.Text              as Text+import           Data.Vector            (Vector)+import qualified Data.Vector            as Vector+import           Numeric+import           Safe+import qualified Text.Show.Pretty       as Show++--------------------------------------------------------------------------------+-- The conversion functions.++-- | Convert a Haskell value to a value representing a Fay value.+showToFay' :: Show a => a -> Maybe Value+showToFay' = Show.reify >=> convert where+  convert value = case value of+    -- Special cases+    Show.Con "True" _    -> return (Bool True)+    Show.Con "False" _   -> return (Bool False)++    -- Objects/records+    Show.Con name values -> fmap (Object . Map.fromList . (("instance",string name) :))+                                 (slots values)+    Show.Rec name fields -> fmap (Object . Map.fromList . (("instance",string name) :))+                                 (mapM (uncurry keyval) fields)+    Show.InfixCons _ _ -> Nothing -- TODO https://github.com/faylang/fay/issues/316++    -- ()+    Show.Tuple [] -> return Null++    -- List types+    Show.Tuple values -> fmap (Array . Vector.fromList) (mapM convert values)+    Show.List values  -> fmap (Array . Vector.fromList) (mapM convert values)++    -- Text types+    Show.String chars -> fmap string (readMay chars)+    Show.Char char    -> fmap (string.return) (readMay char)++    -- Numeric types (everything treated as a double)+    Show.Neg{}     -> double <|> int+    Show.Integer{} -> int+    Show.Float{}   -> double+    Show.Ratio{}   -> double+    where double = convertDouble value+          int = convertInt value++  -- Number converters+  convertDouble = fmap (Number . D) . pDouble+  convertInt = fmap (Number . I) . pInt++  -- Number parsers+  pDouble :: Show.Value -> Maybe Double+  pDouble value = case value of+    Show.Float str   -> getDouble str+    Show.Ratio x y   -> liftM2 (on (/) fromIntegral) (pInt x) (pInt y)+    Show.Neg str     -> fmap (* (-1)) (pDouble str)+    _ -> Nothing+  pInt value = case value of+    Show.Integer str -> getInt str+    Show.Neg str     -> fmap (* (-1)) (pInt str)+    _ -> Nothing++  -- Number readers+  getDouble :: String -> Maybe Double+  getDouble = fmap fst . listToMaybe . readFloat+  getInt :: String -> Maybe Integer+  getInt = fmap fst . listToMaybe . readInt 10 isDigit charToInt+    where charToInt c = fromEnum c - fromEnum '0'++  -- Utilities+  string = String . Text.pack+  slots = zipWithM keyval (map (("slot"++).show) [1::Int ..])+  keyval key val = fmap (Text.pack key,) (convert val)++-- | Convert a value representing a Fay value to a Haskell value.+readFromFay' :: Data a => Value -> Maybe a+readFromFay' value =+  parseDataOrTuple value+  `ext1R` parseArray value+  `extR` parseDouble value+  `extR` parseInt value+  `extR` parseInteger value+  `extR` parseBool value+  `extR` parseString value+  `extR` parseChar value+  `extR` parseText value+  `extR` parseUnit value++-- | Parse a data type or record or tuple.+parseDataOrTuple :: Data a => Value -> Maybe a+parseDataOrTuple value = result where+  result = getAndParse value+  typ = dataTypeOf (fromJust result)+  getAndParse x =+    case x of+      Object obj -> parseObject typ obj+      Array tuple -> parseTuple typ tuple+      _ -> mzero++-- | Parse a tuple.+parseTuple :: Data a => DataType -> Vector Value -> Maybe a+parseTuple typ arr =+  case dataTypeConstrs typ of+    [cons] -> evalStateT (fromConstrM (do i:next <- get+                                          put next+                                          value <- lift (Vector.indexM arr i)+                                          lift (readFromFay' value))+                                      cons)+                         [0..]+    _ -> Nothing++-- | Parse a data constructor from an object.+parseObject :: Data a => DataType -> HashMap Text Value -> Maybe a+parseObject typ obj = listToMaybe (catMaybes choices) where+  choices = map makeConstructor constructors+  constructors = dataTypeConstrs typ+  makeConstructor cons = do+    name <- Map.lookup (Text.pack "instance") obj >>= parseString+    guard (showConstr cons == name)+    if null fields+      then makeSimple obj cons+      else makeRecord obj cons fields++      where fields = constrFields cons++-- | Make a simple ADT constructor from an object: { "slot1": 1, "slot2": 2} -> Foo 1 2+makeSimple :: Data a => HashMap Text Value -> Constr -> Maybe a+makeSimple obj cons =+  evalStateT (fromConstrM (do i:next <- get+                              put next+                              value <- lift (Map.lookup (Text.pack ("slot" ++ show i)) obj)+                              lift (readFromFay' value))+                          cons)+             [1..]++-- | Make a record from a key-value: { "x": 1 } -> Foo { x = 1 }+makeRecord :: Data a => HashMap Text Value -> Constr -> [String] -> Maybe a+makeRecord obj cons fields =+  evalStateT (fromConstrM (do key:next <- get+                              put next+                              value <- lift (Map.lookup (Text.pack key) obj)+                              lift (readFromFay' value))+                          cons)+             fields++-- | Parse a double.+parseDouble :: Value -> Maybe Double+parseDouble value = do+  number <- parseNumber value+  case number of+    I n -> return (fromIntegral n)+    D n -> return n++-- | Parse an int.+parseInt :: Value -> Maybe Int+parseInt value = do+  number <- parseNumber value+  case number of+    I n -> return (fromIntegral n)+    _ -> mzero++-- | Parse an integer.+parseInteger :: Value -> Maybe Integer+parseInteger value = do+  number <- parseNumber value+  case number of+    I n -> return n+    _ -> mzero++-- | Parse a number.+parseNumber :: Value -> Maybe Number+parseNumber value = case value of+  Number n -> return n+  _ -> mzero++-- | Parse a bool.+parseBool :: Value -> Maybe Bool+parseBool value = case value of+  Bool n -> return n+  _ -> mzero++-- | Parse a string.+parseString :: Value -> Maybe String+parseString value = case value of+  String s -> return (Text.unpack s)+  _ -> mzero++-- | Parse a char.+parseChar :: Value -> Maybe Char+parseChar value = case value of+  String s | Just (c,_) <- Text.uncons s -> return c+  _ -> mzero++-- | Parse a Text.+parseText :: Value -> Maybe Text+parseText value = case value of+  String s -> return s+  _ -> mzero++-- | Parse an array.+parseArray :: Data a => Value -> Maybe [a]+parseArray value = case value of+  Array xs -> mapM readFromFay' (Vector.toList xs)+  _ -> mzero++-- | Parse unit.+parseUnit :: Value -> Maybe ()+parseUnit value = case value of+  Null -> return ()+  _ -> mzero

@@ -0,0 +1,109 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable    #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE QuasiQuotes           #-}+{-# LANGUAGE RecordWildCards       #-}+{-# LANGUAGE TemplateHaskell       #-}++-- | Function for running arbitrary IDE API commands.++module FP.API.Run+  where++import           FP.API.Convert+import           FP.API.Types++import           Control.Exception+import           Control.Failure+import           Control.Monad.Extra+import           Control.Monad.Logger+import           Control.Monad.Reader+import           Control.Monad.Trans.Resource+import           Data.Aeson                   (decode, encode)+import           Data.ByteString.Lazy         (toChunks)+import           Data.Data+import           Data.IORef+import           Data.Monoid+import           Data.String+import           Data.Text                    (Text)+import qualified Data.Text                    as T+import           Data.Text.Encoding           (encodeUtf8)+import           Language.Fay.Yesod           (Returns (..))+import           Network.HTTP.Conduit+import           Network.HTTP.Types.Status+import           Prelude hiding (catch)+import           Texts.English++-- | Only used internally for encoding.+data Command = IdeCommand IdeCommand+  deriving Show++-- | Monad that can get info for sending commands.+class (Failure HttpException m,MonadIO m,Functor m) => MonadClient m where+  getClientConfig :: m ClientConfig++-- | Simple command configuration.+data ClientConfig = CC+  { ccUrl       :: String+  , ccToken     :: String+  , ccManager   :: Manager+  , ccCookie    :: IORef CookieJar+  , ccUserAgent :: Text+  }++data CommandException+  = CommandException Text+   deriving (Show,Typeable)+instance Exception CommandException++-- | Helpful simple client instance.+instance (Failure HttpException m,MonadIO m,Functor m) => MonadClient (ReaderT ClientConfig m) where+  getClientConfig = ask++-- | Run the given command.+runCommand :: (MonadLogger m,MonadClient m,Data a,Show a) => (Returns' a -> IdeCommand) -> m a+runCommand cmd = do+  CC{..} <- getClientConfig+  request <- parseUrl (ccUrl <> "/fay-command")+  jar <- io $ readIORef ccCookie+  let req = urlEncodedBody params $ setup ccToken request (Just jar) ccUserAgent+  $(logDebug) ("=> " <> trunc (T.pack (show (IdeCommand (cmd Returns)))))+  resp <- io (catch (runResourceT (httpLbs req ccManager))+                    handle301)+  io $ writeIORef ccCookie (responseCookieJar resp)+  case statusCode (responseStatus resp) of+    200 -> do+      case decode (responseBody resp) >>= readFromFay' of+        Nothing -> do $(logDebug) (errprefix <> "<= [unable to decode] " <> T.pack (show (responseBody resp)))+                      error $ "Unable to decode response: " ++ show (responseBody resp)+        Just result ->+          case result of+            Failure e -> do $(logDebug) (errprefix <> "<= " <> trunc e)+                            throw (CommandException e)+            Success a -> do $(logDebug) ("<= " <> trunc (T.pack (show a)))+                            return a+    code -> throw (CommandException ("Bad status code returned from client command: " <> T.pack (show code)))++  where params =+          [("json",mconcat (toChunks (encode (showToFay' (IdeCommand (cmd Returns))))))]+        setup token req jar agent =+          req { method = "POST"+              , redirectCount = 0+              , requestHeaders = requestHeaders req +++                                 [("Accept","application/json")+                                 ,("User-Agent",encodeUtf8 ("fpco-api:" <> agent))+                                 ,("authorization","token " <> fromString token)]+              , responseTimeout = Nothing+              , cookieJar = jar+              }+        trunc :: Text -> Text+        trunc = ellipsize 140+        errprefix = "Error from request: " <> T.pack (show (cmd Returns)) <> "\n"+        handle301 e =+          case e of+            StatusCodeException status _ _ | statusCode status == 301 ->+              throw (CommandException "Got a redirect. Probably an invalid authorization token.")+            _ -> throw e

@@ -0,0 +1,41 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TemplateHaskell #-}+{-# OPTIONS -fno-warn-orphans #-}++-- | Macro for generating a function out of a command+-- constructor. Only a subset of the IDE commands are of interest for+-- editors and general public use, so we use this command, and we can+-- also write haddock documentation.++module FP.API.TH+  (cmd+  ) where++import FP.API.Run+import FP.API.Types++import Data.Char+import Language.Haskell.TH++cmd :: Name -> Q [Dec]+cmd name = do+  DataConI _name typ _ptyp _fixity <- reify name+  return [FunD funName+               [Clause [] (NormalB (stripIdeCommand typ)) []]]++  where funName = mkName (decapitalize (nameBase name))+        stripIdeCommand = go (1 :: Int) where+          go i (AppT (AppT ArrowT _x) (ConT t))+            | t == ''IdeCommand =+              (AppE (VarE 'runCommand)+                    (foldl (\inner i' -> AppE inner (VarE (gensym i')))+                           (ConE name)+                           [1..i-1]))+          go i (AppT _x y) = LamE [VarP (gensym i)] (go (i+1) y)+          go _ _          = error "invalid IdeCommand constructor type"+        gensym i = mkName ("x" ++ show i)++decapitalize :: String -> String+decapitalize [] = []+decapitalize (x:xs) = toLower x : xs

@@ -0,0 +1,779 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}++module FP.API.Types where++import Data.Data+import Language.Fay.Yesod+import Prelude+import FFI++#ifndef FAY+import Data.Default (Default(..))+import Database.Persist.Sql (PersistField, PersistFieldSql)+import Database.Persist.TH (derivePersistField)+import System.Random (Random)+#endif++data FayProjectId = FayProjectId { unFayProjectId :: Text }+    deriving (Read, Typeable, Data, Show, Eq)++data ProjectState = Workspaces | UserState+#ifdef FAY+    deriving (Read, Typeable, Data, Show, Eq)+#else+    deriving (Show, Eq, Read, Data, Typeable, Enum, Bounded, Ord)+derivePersistField "ProjectState"+#endif++data MergeModifyKind = Modified | Added | Deleted | TypeChanged+#ifdef FAY+    deriving (Read, Typeable, Data, Show, Eq)+#else+    deriving (Show, Eq, Read, Data, Typeable, Enum, Bounded, Ord)+derivePersistField "MergeModifyKind"+#endif++data MergeModifyPair = MergeModifyPair MergeModifyKind MergeModifyKind+#ifdef FAY+    deriving (Read, Typeable, Data, Show, Eq)+#else+    deriving (Show, Eq, Read, Data, Typeable, Bounded)+derivePersistField "MergeModifyPair"+#endif++data FayModuleId = FayModuleId (Maybe FayFileName)+                               FayModuleName+                               PackageId+    deriving (Read, Typeable, Data, Show, Eq)++data FayRunConfigId = FayRunConfigId { unFayRunConfigId :: Text }+    deriving (Read, Typeable, Data, Show, Eq)++data CanFail a = Success (Automatic a) | Failure Text+    deriving (Read, Typeable, Data, Show, Eq)+#ifndef FAY+deriving instance Functor CanFail+#endif++type Returns' a = Returns (CanFail a)++data IdeCommand+    -- User profile+    = SaveProfile            Theme Int Bool                                    (Returns' ())++    -- Project global+    | GetInitialProjectInfo                                                    FayProjectId (Returns' InitialProjectInfo)+    | ReparseProjectSettings                                                   FayProjectId (Returns' ReparseSettingsOutput)+    | GetSettings                                                              FayProjectId (Returns' GetSettingsOutput)+    | SetSettings            SetSettingsInput                                  FayProjectId (Returns' (Maybe CompileId))++    | GetKeterYaml           FayDeploymentId FayModuleName                     FayProjectId (Returns' KeterYaml)+    | SetRunConfigs          [(FayRunConfigId,RunConfig)]                      FayProjectId (Returns' ())+    | SetDeployments         [(FayDeploymentId,Deployment)]                    FayProjectId (Returns' ())+    | GetNewRunConfig                                                          FayProjectId (Returns' NewRunConfig)+    | GetNewDeployment                                                         FayProjectId (Returns' NewDeployment)++    | GetNewWebApp           FayDeploymentId                                   FayProjectId (Returns' NewWebApp)+    | GetNewBgJob            FayDeploymentId                                   FayProjectId (Returns' NewBgJob)+    | SetPublic              Publicize                                         FayProjectId (Returns' (Maybe GitHistoryItem))+    | SetProjectMetadata     Text Text                                         FayProjectId (Returns' ())+    | DeleteProject          Text                                              FayProjectId (Returns' ())++    -- Host names+    | CheckHostName          Text                                              FayProjectId (Returns' UseHostName)+    | GetRandomHostName                                                        FayProjectId (Returns' RandomHostName)+    | GetDeploymentManagerInfo                                                 FayProjectId (Returns' DeploymentManagerInfo)++    -- User State+    | SaveProjectState       ProjectState Text                                 FayProjectId (Returns' ())+    | LoadProjectState       ProjectState                                      FayProjectId (Returns' MaybeText)++    -- Files+    | AddFile                FileInfo                                          FayProjectId (Returns' SaveFileOutput)+    | SaveFile               FayFileName Text FayTutorialToken                 FayProjectId (Returns' SaveFileOutput)+    | DeleteFile             FayFileName                                       FayProjectId (Returns' CompileChanged)+    | RenameFile             FayFileName FileInfo RenameType                   FayProjectId (Returns' RenameFileOutput)+    | GetFile                FayFileName                                       FayProjectId (Returns' FileContent)+    | GetFileToken           FayFileName                                       FayProjectId (Returns' FayTutorialToken)+    | GetAllFiles                                                              FayProjectId (Returns' [(FayFileName, ModuleIncluded)])+    | SetModuleExclusion     FayFileName Bool                                  FayProjectId (Returns' CompileChanged)++    -- Info+    | GetTypeInfo            SourceSpan Int                                    FayProjectId (Returns' ())+    | GetDefinitionSource    SourceSpan                                        FayProjectId (Returns' ())+    | GetAutocompletions     AutoCompleteInput                                 FayProjectId (Returns' ())+--    | GetTopLevelIdentifiers FayFileName                                     FayProjectId (Returns' TopLevelIdentifiers)+    | IdeHoogleSearch        (Maybe FayFileName) Bool Int Int Int Text         FayProjectId (Returns' HoogleId)+        -- ^ module context, is it exact?, number to query, offset in result, number to yield, query contents+    | GetProjectMessages     ProjectMessagesRequest                            FayProjectId (Returns' ProjectMessagesOutput)++    -- Compilation+    | SetTarget              (Maybe (Either FayFileName FayRunConfigId))       FayProjectId (Returns' CompileChanged)+    | GetTarget                                                                FayProjectId (Returns' (Maybe (Either FayFileName FayRunConfigId)))+    | RunTarget                                                                FayProjectId (Returns' ProcId)+    --TODO: Make these use the current target.+    | CompileBinary          FayFileName [(Text, Text)]                        FayProjectId (Returns' BuildId)+    | UploadBuild            BuildResult                                       FayProjectId (Returns' UploadedBuild)++    -- Git+    | CommitToGit            Text                                              FayProjectId (Returns' ())+    | GetGitHistory          Int Int                                           FayProjectId (Returns' GitHistory)+    | IsProjectDirty                                                           FayProjectId (Returns' Bool)+    | ResetProject                                                             FayProjectId (Returns' InitialProjectInfo)+    | SetRoot                Text Text                                         FayProjectId (Returns' InitialProjectInfo)++    | GitPush                Text                                              FayProjectId (Returns' ()) -- ^ Text == URL+    | GitPull                Text                                              FayProjectId (Returns' GitPullResult) -- ^ Text == URL+    | GitMergeAbort          Text                                              FayProjectId (Returns' InitialProjectInfo) -- ^ Text == URL+    | GitMergeDone           Text MaybeText                                    FayProjectId (Returns' GitResolvedResult) -- ^ Text == URL, Msg+    | GitResolveFile         FayFileName                                       FayProjectId (Returns' ())++    | GitDiff                                                                  FayProjectId (Returns' Text)++    -- Git Remotes+    | SetRemotes             RemotesList                                       FayProjectId (Returns' ())++    -- Git Branches+    | CheckoutBranch         Text                                              FayProjectId (Returns' GitCheckoutResult)+    | CreateBranch           Text Text                                         FayProjectId (Returns' ())+    | DeleteBranch           Text                                              FayProjectId (Returns' ())+    | BranchFromCommit       Text Text                                         FayProjectId (Returns' ())++    -- Github+    | UserAuthedGithub (Returns (CanFail Bool))+    | RevokeGithub (Returns (CanFail ()))+    | GetGithubUrl Text (Returns (CanFail Text))+    | SshPublicKey (Returns (CanFail Text))++    -- Module manipulation+    | ReformatModule         FayFileName                                       FayProjectId (Returns' CompileChanged)++    -- Configuration+    | GetConfigurationProject                                                               (Returns' Text)+    | GenerateConfiguration                                                                 (Returns' ())+    | SetConfigurationJavascript Text                                                       (Returns' ())++    -- Misc+    | RenderFileMarkdown     FayFileName                                       FayProjectId (Returns' HtmlReply)+    | GetTrialExpiry                                                                        (Returns' ExpiryTime)+    | ShowTrialSignup                                                                       (Returns' Bool)+    | RestartBackend                                                           FayProjectId (Returns' ())+--    | RunGhci Bool                                                             FayProjectId (Returns' RunGhciOutput)+    | SearchProject          SearchQuery Int Int Bool                          FayProjectId (Returns' ())+    | CloseAllProjects                                                                      (Returns' ())+    | SdistTarball                                                             FayProjectId (Returns' ())+    | GetProjectId           Text                                                           (Returns' FayProjectId)+    deriving (Read, Typeable, Data, Show, Eq)+++-- | Values passed to the client when initially loading the IDE.+data InitialProjectInfo = InitialProjectInfo+    { ipiTitle :: Text+    , ipiDesc :: Text+    , ipiGitUrl :: Maybe Text -- ^ URL originally cloned from+    , ipiMergeConflicts :: Maybe [MergeConflict]+    , ipiInvalidSettings :: Bool+    , ipiState :: [(ProjectState, Text)]+    , ipiFiles :: [(FayFileName, ModuleIncluded)]+    , ipiTarget :: Maybe (Either FayFileName FayRunConfigId)+    , ipiPublished :: Maybe GitHistoryItem+    , ipiBranches :: BranchesList+    , ipiRemotes :: RemotesList+    , ipiRunConfigs :: [(FayRunConfigId,RunConfig)]+    , ipiDeployments :: [(FayDeploymentId,Deployment)]+    , ipiTheme :: Theme+    , ipiFontSize :: Int+    , ipiSearchWithRegex :: Bool+    , ipiLicense :: IdeLicense+    , ipiCanPublish :: Bool+    }+    deriving (Read, Typeable, Data, Show, Eq)++data IdeLicense = ILCommunity | ILPersonal | ILProfessional+    deriving (Read, Typeable, Data, Show, Eq)++-- TODO: middle text should be the code that the type comes from.+data TypeInfo = TypeInfo SourceSpan Text Text+    deriving (Read, Typeable, Data, Show, Eq)++data MaybeText = NoText | JustText Text -- FAY BUG+    deriving (Read, Typeable, Data, Show, Eq)++-- | Result of checking out a branch (or ref, in future).+data GitCheckoutResult+  = GCRDirty+  | GCROk (Maybe InitialProjectInfo)+    deriving (Read, Typeable, Data, Show, Eq)++data GitPullResult = GPRSuccess InitialProjectInfo+                   | GPRDirtyTree+                   | GPRManualMerge Text InitialProjectInfo+    deriving (Read, Typeable, Data, Show, Eq)++data GitResolvedResult = GRRSuccess+                       | GRRStillUnresolved [MergeConflict]+    deriving (Read, Typeable, Data, Show, Eq)++data GitMergeConflictsResult = GitMergeConflictsResult [MergeConflict]+    deriving (Read, Typeable, Data, Show, Eq)++data MergeConflict = MergeConflict+    { mergeFile :: FayFileName+    , mergeState :: MergeModifyPair+    }+    deriving (Read, Typeable, Data, Show, Eq)++data GitHistory = GitHistory [GitHistoryItem] -- FAY BUG+    deriving (Read, Typeable, Data, Show, Eq)++data GitHistoryItem = GitHistoryItem+    { ghiDate :: Text+    , ghiAuthor :: Text+    , ghiLog :: Text+    , ghiHash :: Text+    }+    deriving (Read, Typeable, Data, Show, Eq)++data RemotesList = RemotesList [(Text,Text)]+  deriving (Read, Typeable, Data, Show, Eq)++data BranchesList = BranchesList Text [Text]+  deriving (Read, Typeable, Data, Show, Eq)++data ReparseSettingsOutput+    = SettingsAlreadyValid+    | ReparseSuccessful InitialProjectInfo+    deriving (Read, Typeable, Data, Show, Eq)++data GetSettingsOutput = GetSettingsOutput+    { gsoModuleTemplate :: Text+    , gsoExtensions     :: [(Text, Maybe Bool)] -- ^ three states: on, off, or default (== Nothing)+    , gsoEnvironment    :: Environment+    , gsoEnvironments   :: [Environment]+    , gsoGhcArgs        :: [Text]+    , gsoExtraPackages  :: Text+    , gsoHiddenPackages :: Text+    , gsoCabalName      :: Text+    , gsoCabalVersion   :: Text+    , gsoRoot           :: Text+    , gsoFilters        :: Text+    }+    deriving (Read, Typeable, Data, Show, Eq)++data SetExtension = SetExtension Text Bool+    deriving (Read, Typeable, Data, Show, Eq)++data SetSettingsInput = SetSettingsInput+    { ssiModuleTemplate :: Text+    , ssiExtensions     :: [SetExtension]+    , ssiEnvironment    :: Text+    , ssiGhcArgs        :: [Text]+    , ssiExtraPackages  :: Text+    , ssiHiddenPackages :: Text+    , ssiCabalName      :: Text+    , ssiCabalVersion   :: Text+    }+    deriving (Read, Typeable, Data, Show, Eq)++-- | A GHC environment.+data Environment = Environment+  { envName :: Text+  , envTitle :: Text+  , envURL :: Text+  }+  deriving (Read, Typeable, Data, Show, Eq)++data RunGhciOutput = RunGhciOutput ProcId FayProjectId+    deriving (Read, Typeable, Data, Show, Eq)++data TopLevelIdentifiers = TopLevelIdentifiers [TopLevelIdentifier]+    deriving (Read, Typeable, Data, Show, Eq)++data TopLevelIdentifier = TopLevelIdentifier+    { tliLine :: Int+    , tliColumn :: Int+    , tliName :: Text+    }+    deriving (Read, Typeable, Data, Show, Eq)++-- Copied from ide-backend/Common.hs+--  + Different deriving list+--  + 'Show' instances made into functions++data SourceSpan = SourceSpan+  { spanFilePath   :: FayFileName+  , spanFromLine   :: Int+  , spanFromColumn :: Int+  , spanToLine     :: Int+  , spanToColumn   :: Int }+  deriving (Read, Typeable, Data, Show, Eq)++data EitherSpan =+    ProperSpan SourceSpan+  | TextSpan String+  deriving (Read, Typeable, Data, Show, Eq)++-- | An error or warning in a source module.+--+-- Most errors are associated with a span of text, but some have only a+-- location point.+--+data SourceInfo = SourceInfo+  { infoKind :: SourceInfoKind+  , infoSpan :: EitherSpan+  , infoMsg  :: Text+  }+  deriving (Read, Typeable, Data, Show, Eq)++-- | Severity of a piece of info.+data SourceInfoKind = KindError | KindWarning | KindHint+  deriving (Read, Typeable, Data, Show, Eq)++-- | Is a target that we're running a web service? We're not sure that+-- it's not, but if the port is open, we're confident that it is.+data IsWebResult+  = IsWeb+  | NotSureIfWeb+  deriving (Read, Typeable, Data, Show, Eq)++-- | A simple text reply.+data TextReply+  = TextReply { unTextReply :: Text }+  deriving (Read, Typeable, Data, Show, Eq)++-- | An html reply.+data HtmlReply+  = HtmlReply { unHtmlReply :: Text }+  deriving (Read, Typeable, Data, Show, Eq)++-- | Indicates the state of a starting project. Each request can either+-- indicate that there is more data coming, or that this is the final status.+data ProjectStartStatus = PSSUpdate Text Int | PSSFinal Text+  deriving (Read, Typeable, Data, Show, Eq)++data MaybeStartToken = NoStartToken | StartToken Int+  deriving (Read, Typeable, Data, Show, Eq)++-- | A run configuration for a project.+data RunConfig = RunConfig+  { rcTitle :: Text+  , rcMainFile :: Maybe FayFileName+  , rcArgs :: [Text]+  , rcEnv :: [(Text,Text)]+  } deriving (Read, Typeable, Data, Show, Eq)++-- | Make a new run configuration.+data NewRunConfig = NewRunConfig (FayRunConfigId,RunConfig)+  deriving (Read, Typeable, Data, Show, Eq)++-- | A deployment configuration.+data Deployment = Deployment+  { depTitle :: Text+  , depStanzas :: [Stanza]+  } deriving (Read, Typeable, Data, Show, Eq)++-- | Possible stanza types.+data Stanza = WebAppStanza FayWebAppId WebApp+            | BgJobStanza FayBgJobId BgJob+  deriving (Read, Typeable, Data, Show, Eq)++data NewDeployment = NewDeployment (FayDeploymentId,Deployment)+  deriving (Read, Typeable, Data, Show, Eq)++-- | A web app stanza.+data WebApp = WebApp+  { wapTitle    :: Text+  , wapHostname :: Maybe Text+  , wapFileName :: Maybe FayFileName+  , wapArgs     :: [Text]+  , wapEnv      :: [(Text,Text)]+  , wapSsl      :: Bool+  } deriving (Read, Typeable, Data, Show, Eq)++data NewWebApp = NewWebApp (FayWebAppId,WebApp)+  deriving (Read, Typeable, Data, Show, Eq)++-- | A background job stanza.+data BgJob = BgJob+  { bgTitle        :: Text+  , bgFileName     :: Maybe FayFileName+  , bgArgs         :: [Text]+  , bgEnv          :: [(Text,Text)]+  , bgRestartLimit :: Maybe Int+  , bgRestartDelay :: Int+  } deriving (Read, Typeable, Data, Show, Eq)++-- | Make a new background job.+data NewBgJob = NewBgJob (FayBgJobId,BgJob)+  deriving (Read, Typeable, Data, Show, Eq)++-- | Result of trying to use a hostname.+data UseHostName = HostnameInUse         -- ^ Host name is in use by someone else, can't be used.+                 | HostnameOK            -- ^ Host name was already or has now been registered and is now in use.+                 | HostnameQuotaExcess   -- ^ Couldn't register the hostname due to quota.+                 | HostnameInvalid       -- ^ Invalid hostname.+  deriving (Read, Typeable, Data, Show, Eq)++-- | Yaml text for a Keter config.+data KeterYaml = KeterYaml+    { keterYaml :: Text+    , deployYaml :: Text+    }+  deriving (Read,Typeable,Data,Show,Eq)++-- | A randomly generated host name.+data RandomHostName = RandomHostName { unRandomHostname :: Text }+  deriving (Read,Typeable,Data,Show,Eq)++-- | A date of expiration, if any.+data ExpiryTime = ExpiryTime (Maybe Integer)+  deriving (Read,Typeable,Data,Show,Eq)++data DeploymentManagerInfo = DeploymentManagerInfo+  { dmiHostname :: Text }+  deriving (Read,Typeable,Data,Show,Eq)++data FayManualMergeId = FayManualMergeId { unFayManualMergeId :: Text }+    deriving (Read, Typeable, Data, Show, Eq)++data FayDeploymentId = FayDeploymentId { unFayDeploymentId :: Text }+    deriving (Read, Typeable, Data, Show, Eq)++data FayBgJobId = FayBgJobId { unFayBgJobId :: Text }+    deriving (Read, Typeable, Data, Show, Eq)++data FayWebAppId = FayWebAppId { unFayWebAppId :: Text }+    deriving (Read, Typeable, Data, Show, Eq)++--------------------------------------------------------------------------------+-- Themes++-- | Themes supported by the IDE.+data Theme = Panda | Zenburn | Monokai+#ifdef FAY+  deriving (Read,Typeable,Data,Show,Eq)+#else+  deriving (Show, Eq, Read, Data, Typeable, Bounded, Enum)+#endif++--------------------------------------------------------------------------------+-- Search++data SearchQuery+  = SearchQueryRegex Text+  | SearchQueryPlain Text+  deriving (Read,Typeable,Data,Show,Eq)++--------------------------------------------------------------------------------+-- Publication++data Publicize = NotPublic+               | Publicize Text+  deriving (Read,Typeable,Data,Show,Eq)++--------------------------------------------------------------------------------+-- Files / Modules++data FayFileName = FayFileName { unFayFileName :: Text }+    deriving (Read, Typeable, Data, Show, Eq)++data FayModuleName = FayModuleName { unFayModuleName :: Text }+    deriving (Read, Typeable, Data, Show, Eq)++data FileInfo = FileInfo+    { fiPath :: FayFileName+    , fiModule :: Maybe FayModuleName+    }+    deriving (Read, Typeable, Data, Show, Eq)++data FileChanged = FileChanged+    { fcPath :: FayFileName+    , fcModule :: Maybe ModuleIncluded+    }+    deriving (Read, Typeable, Data, Show, Eq)++data ModuleIncluded+    = ModuleExcluded+    | ModuleWrongExtension+    | ModuleNotTextual+    | ModuleHeaderFilenameMismatch FayModuleName+    | ModuleNameAmbiguous FayModuleName+    | ModuleIncluded FayModuleName+    deriving (Read, Typeable, Data, Show, Eq)++data RenameType = RenamePlain | RenameHeader | RenameHeaderAndImports | RenameHeaderAndImportsForce+    deriving (Read, Typeable, Data, Show, Eq)++data CompileChanged = CompileChanged+    { ccCompileId :: Maybe CompileId+    , ccFiles :: [FileChanged] -- ^ All of the 'FileChanged's that have a+                                 -- 'fiModule' that's changed.+    }+    deriving (Read, Typeable, Data, Show, Eq)++data RenameFileOutput+    = RenameFileOutput (Maybe Text) CompileChanged+    | WarnImportRenaming [FayFileName]+    deriving (Read, Typeable, Data, Show, Eq)++data SaveFileOutput = SaveFileOutput FayTutorialToken CompileChanged+    deriving (Read, Typeable, Data, Show, Eq)++data FileContent = FileContent+    { dfcContent :: Maybe Text+    , dfcToken :: FayTutorialToken+    }+    deriving (Read, Typeable, Data, Show, Eq)++--------------------------------------------------------------------------------+-- Version token++-- | A token for the tutorial.+type FayTutorialToken = TutorialConcurrentToken++#ifdef FAY+data TutorialConcurrentToken = TutorialConcurrentToken'+    { unTutorialConcurrentToken :: Int }+    deriving (Eq, Show, Data, Read, Typeable)+#else+-- | Token for a tutorial.+newtype TutorialConcurrentToken = TutorialConcurrentToken'+    { unTutorialConcurrentToken :: Int }+    deriving (Eq, Show, Data, Read, Typeable, PersistField, PersistFieldSql, Random, Num)++instance Default TutorialConcurrentToken where+    def = TutorialConcurrentToken' 1+#endif++--------------------------------------------------------------------------------+-- Isolation-runner ids++data CompileId = CompileId { unCompileId :: Int }+    deriving (Read, Typeable, Data, Show, Eq)++data ProcId = ProcId { unProcId :: Int }+    deriving (Read, Typeable, Data, Show, Eq)++data BuildId = BuildId { unBuildId :: Int }+    deriving (Read, Typeable, Data, Show, Eq)++data HoogleId = HoogleId { unHoogleId :: Int }+    deriving (Read, Typeable, Data, Show, Eq)++data SearchId = SearchId { unSearchId :: Int }+    deriving (Read, Typeable, Data, Show, Eq)++--------------------------------------------------------------------------------+-- Isolation-runner messages++data ProjectMessagesRequest+    = PMRImmediateStatusNoMessages+    | PMRImmediateStatusWithMessages ProjectMessagesFilter+    | PMRNextStatusWithMessages ProjectMessagesFilter StatusHash+    deriving (Read, Typeable, Data, Show, Eq)++data ProjectMessagesOutput+    = ProjectMessagesOutput ProjectMessagesFilter [(Maybe Int, RunnerMessage)]+    deriving (Read, Typeable, Data, Show, Eq)++data StatusHash = StatusHash Text+    deriving (Read, Typeable, Data, Show, Eq)++data ProjectMessagesFilter+    = PMFilterNone+    | PMFilterAll+    | PMFilterOnOrBefore Integer+    deriving (Read, Typeable, Data, Show, Eq)++data MessageTag = MessageTag+    { mtProjectId :: Maybe FayProjectId+    --TODO: use a better type than Int.+    , mtJobId     :: Maybe Int+    }+    deriving (Read, Typeable, Data, Show, Eq)++data RunnerMessageEnvelope = RunnerMessageEnvelope+    { rmeSeqNumber  :: Integer+    , rmeMessageTag :: MessageTag+    , rmeMessage    :: RunnerMessage+    }+    deriving (Read, Typeable, Data, Show, Eq)++data RunnerMessage+    = ProjectMessage+        { rmPsLevel   :: LogLevel+        , rmPsMessage :: Text+        }+    | ProcessOutput Text+    | ProcessOutputError Text+    | StatusSnapshot ProjectStatusSnapshot StatusHash+    | IdInfoResults IdInfo+    | SubExprsResults SourceSpan [[TypeInfo]]+    | AutoCompleteResults (Maybe AutoCompleteInput) [Text]+    | ImportedPackagesResults [PackageId]+    | SearchResults [SearchResult]+    | HoogleResults Text [HoogleResult] (Maybe Int)+    | ProjectHasClosed+    | FayCompileResults Text+    deriving (Read, Typeable, Data, Show, Eq)++data LogLevel+    = LevelDebug+    | LevelInfo+    | LevelWarn+    | LevelError+    | LevelOther Text+    deriving (Read, Typeable, Data, Show, Eq)++data ProjectStatusSnapshot = ProjectStatusSnapshot+    { snapOpeningStatus :: RunnerOpeningStatus+    , snapCompileStatus :: RunnerCompileStatus+    , snapProcessStatus :: ProcessStatusSnapshot+    , snapBuildStatus   :: RunnerBuildStatus+    }+    deriving (Read, Typeable, Data, Show, Eq)++data IdInfo+    = NoIdInfo SourceSpan -- ^ query span+    | IdInfo SourceSpan SourceSpan DefinitionSource -- ^ query span, result span, source info+    deriving (Read, Typeable, Data, Show, Eq)++data DefinitionSource = DefinitionLocal SourceSpan+                      | DefinitionTextSpan Text Text+                      | DefinitionImported Text FayModuleId FayModuleId EitherSpan EitherSpan+                      | DefinitionWiredIn Text+                      | DefinitionBinder Text+    deriving (Read, Typeable, Data, Show, Eq)++data AutoCompleteInput = AutoCompleteInput+    { aciModuleName :: FayFileName+    , aciPrefix     :: Text+    }+    deriving (Read, Typeable, Data, Show, Eq)++data PackageId = PackageId+    { packageName    :: Text+    , packageVersion :: Maybe Text+    }+    deriving (Read, Typeable, Data, Show, Eq)++data SearchResult = SearchResult SourceSpan [Either Text Text]+    deriving (Read, Typeable, Data, Show, Eq)++data HoogleResult = HoogleResult+    { hrURL     :: String+    , hrSources :: [(PackageLink, [ModuleLink])]+    , hrTitle   :: String -- ^ HTML+    , hrBody    :: String -- ^ plain text+    }+    deriving (Read, Typeable, Data, Show, Eq)++data PackageLink = PackageLink+    { plName :: String+    , plURL :: String+    }+    deriving (Read, Typeable, Data, Show, Eq)++data ModuleLink = ModuleLink+    { mlName :: String+    , mlURL :: String+    }+    deriving (Read, Typeable, Data, Show, Eq)++data RunnerOpeningStatus+    = RunnerProjectOpening Text+    | RunnerProjectOpen+    deriving (Read, Typeable, Data, Show, Eq)++data RunnerCompileStatus+    = RunnerNotCompiling+    | RunnerCompiling CompileId Progress+    | RunnerCompileDone CompileId [SourceInfo]+    deriving (Read, Typeable, Data, Show, Eq)++data ProcessStatusSnapshot+    = SnapshotNoProcess+    | SnapshotProcessQueued ProcId+    | SnapshotProcessRunning ProcId LaunchInfoSnapshot PortListeningResult+    | SnapshotProcessExited ProcId LaunchInfoSnapshot+    | SnapshotProcessLoadFailed ProcId Text+    | SnapshotProcessRunFailed ProcId Text+    | SnapshotProcessUserException ProcId Text+    | SnapshotProcessGhcException ProcId Text+    | SnapshotProcessForceCanceled ProcId+    deriving (Read, Typeable, Data, Show, Eq)++data RunnerBuildStatus+    = RunnerNotBuilding+    | RunnerBuildQueued+        { rbsId :: BuildId+        }+    | RunnerBuilding+        { rbsId :: BuildId+        , rbsProgress :: Progress+        }+    | RunnerBuildFailed+        { rbsId :: BuildId+        , rbsMsg :: Text+        }+    | RunnerBuildDone+        { rbsId :: BuildId+        , rbsResult :: BuildResult+        }+    deriving (Read, Typeable, Data, Show, Eq)++data BuildResult = BuildResult+    { brPathName   :: Text+    , brMainModule :: Text+    , brFileSize   :: Int+    }+    deriving (Read, Typeable, Data, Show, Eq)++data UploadedBuild = UploadedBuild+    { ubUrl :: Text+    , ubExe :: Text+    }+    deriving (Read, Typeable, Data, Show, Eq)++-- | This type represents intermediate progress information during compilation.+data Progress = Progress+    {+      -- | The current step number+      --+      -- When these Progress messages are generated from progress updates from+      -- ghc, it is entirely possible that we might get step 4/26, 16/26, 3/26;+      -- the steps may not be continuous, might even be out of order, and may+      -- not finish at X/X.+      progressStep :: Int++      -- | The total number of steps+    , progressNumSteps :: Int++      -- | The parsed message. For instance, in the case of progress messages+      -- during compilation, 'progressOrigMsg' might be+      --+      -- > [1 of 2] Compiling M (some/path/to/file.hs, some/other/path/to/file.o)+      --+      -- while 'progressMsg' will just be 'Compiling M'+    , progressMsg :: Text+    }+    deriving (Read, Typeable, Data, Show, Eq)++data LaunchInfoSnapshot = LaunchInfoSnapshot+    { liSnapApproot  :: Maybe Text+    , liSnapPort     :: Maybe Int+    , liSnapLaunched :: Text -- ^ Timestamp+    }+    deriving (Read, Typeable, Data, Show, Eq)++data PortListeningResult+    = ProcessNotRunning+    | PortNotListening+    | PortIsListening+    | PortNotAllocated+    deriving (Read, Typeable, Data, Show, Eq)

@@ -0,0 +1,510 @@+{-# 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 (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))+    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"

@@ -0,0 +1,11 @@+-- | Server configuration.++module FP.Server.Config where++-- | Default url to accept commands on.+defaultUrl :: String+defaultUrl = "https://www.fpcomplete.com/"++-- | Default port to accept commands on.+defaultPort :: Integer+defaultPort = 1990

@@ -0,0 +1,41 @@+{-# LANGUAGE OverloadedStrings   #-}++-- | Source spans and locations.++module FP.Server.Spans where++import           FP.API.Types+import           FP.Server.Types++import           Data.Maybe+import           Data.Monoid+import           Data.Text                  (Text,unpack)+import qualified Data.Text                  as T+import           Prelude                    hiding (span)+import           System.FilePath++-- | Print either a useful span or a useless one.+printEitherSpan :: FilePath -> EitherSpan -> Text+printEitherSpan _ (TextSpan s) = T.pack $ s+printEitherSpan root (ProperSpan span') = printSourceSpan root span'++-- | Print a span as Main.hs:1:23+printSourceSpan :: FilePath -> SourceSpan -> Text+printSourceSpan root (SourceSpan source fromLine fromCol _toLine _toCol) =+  T.pack (root </> T.unpack (unFayFileName source)) <> ":" <>+  T.pack (show fromLine) <> ":" <>+  T.pack (show fromCol)++toSpanType :: TypeInfo -> SpanType+toSpanType (TypeInfo (SourceSpan _ sl sc el ec) srcstr typ) =+  SpanType sl sc el ec srcstr typ++makeEitherLoc :: FilePath -> EitherSpan -> Maybe Loc+makeEitherLoc _ TextSpan{} = Nothing+makeEitherLoc root (ProperSpan span) = Just (makeLoc root span)++makeLoc :: FilePath -> SourceSpan -> Loc+makeLoc root (SourceSpan source fl fc tl tc) =+  Loc (root </> unpack (unFayFileName source))+      fl fc+      tl tc

@@ -0,0 +1,185 @@+{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}++-- | Server types.++module FP.Server.Types where++import FP.API.Run+import FP.API.Types++import Control.Concurrent (MVar)+import Control.Monad.Logger+import Control.Monad.Reader+import Data.Aeson+import Data.Default+import Data.Map (Map)+import Data.Maybe+import Data.Text as T+import GHC.Generics++-- | Server monad.+type Server = LoggingT (ReaderT ServerReader IO)++-- | The configuration for the server and some state.+data ServerReader = ServerReader+  { serverCC :: ClientConfig+  , serverConfig :: Config+  , serverPollers :: MVar (Map FayProjectId [Callback])+  , serverTokens :: MVar (MVar (Map FilePath FayTutorialToken))+  }++-- | A callback that will look at incoming messages and determine+-- whether it's what it wants.+newtype Callback = Callback (Maybe Int -> RunnerMessage -> Server Done)++-- | Is the callback done looking for what it wants?+data Done = NotDone | Done+  deriving Eq++-- | Necessary for the pollers map.+deriving instance Ord FayProjectId++-- | Necessary for calling Fay API functions.+instance MonadClient Server where+  getClientConfig = asks serverCC++-- | Configuration for server.+data Config = Config+  { configToken :: !String+  , configUrl   :: !String+  , configPort  :: !Integer+  , configAgent :: !Text+  , configDebug :: !Bool+  , configStartServer :: !Bool+  } deriving (Show)++instance Default Config where+  def = Config "" "https://fpcomplete.com" 1990 "fpco-api" True False++-- | Message from the client.+data Msg = MsgSaveModule FayProjectId FilePath FilePath+         | MsgCheckModule FayProjectId FilePath FilePath FilePath+         | MsgTypeInfo FayProjectId FilePath Int Int Int Int+         | MsgGetDefinition FayProjectId FilePath FilePath Int Int Int Int+         | MsgAutoComplete FayProjectId FilePath Text+         | MsgHoogleIdent FayProjectId FilePath Text+         | MsgHoogleDb FayProjectId Text+         | MsgDownloadFiles (Either Text FayProjectId) FilePath+         | MsgWriteEmacsConfig (Either Text FayProjectId) FilePath+  deriving (Generic,Show)++instance FromJSON Msg+instance ToJSON Msg++-- | Reply to the client.+data Reply = ReplyPong ()+           | ReplyOK ()+           | ReplyCompileMessages [CompileMessage]+           | ReplyCompileInfos [SourceInfo]+           | ReplyTypeInfo [SpanType]+           | ReplyLocation DefinitionLoc+           | ReplyCompletions [Text]+           | ReplyHoogleResults [HoogleResult]+           | ReplyHoogleResult HoogleResult+           | ReplySaveStatus Bool+ deriving (Generic,Show)++instance ToJSON Reply+instance FromJSON Reply++data DefinitionLoc = DefinitionLoc Loc+                   | DefinitionUseless Text+                   | DefinitionImport Text        -- Dunno+                                      ModuleId    -- Package+                                      ModuleId    -- Package 2.0 (?)+                                      (Maybe Loc) -- Span+                                      (Maybe Loc) -- Span 2.0+  deriving (Generic,Show)++instance ToJSON DefinitionLoc+instance FromJSON DefinitionLoc++data ModuleId = ModuleId Text Text+  deriving (Generic,Show)++instance ToJSON ModuleId+instance FromJSON ModuleId++data Loc = Loc FilePath Int Int Int Int+  deriving (Generic,Show)++instance ToJSON Loc+instance FromJSON Loc++-- | A type info thing.+data SpanType = SpanType Int Int Int Int -- Position+                         Text            -- Source string+                         Text            -- Type+  deriving (Generic,Show)++instance ToJSON SpanType+instance FromJSON SpanType++-- | A message from the compiler about code.+data CompileMessage+  = CompileMessage Text Text Text+   deriving (Show,Generic)++instance ToJSON CompileMessage+instance FromJSON CompileMessage++instance FromJSON FayProjectId where+  parseJSON v = fmap (FayProjectId . T.pack . (show :: Int -> String))+                     (parseJSON v)++instance ToJSON FayProjectId where+  toJSON (FayProjectId i) =+    toJSON ((fromMaybe (error ("Unable to read: " ++ show i)) .+             fmap fst .+             listToMaybe)+              (reads (T.unpack i) :: [(Int,String)]))++-- Only for communication between fpco-client and fpco-server. These+-- types would not be nice to handle outside of Haskell.++deriving instance Generic SourceInfo+instance ToJSON SourceInfo+instance FromJSON SourceInfo++deriving instance Generic SourceInfoKind+instance ToJSON SourceInfoKind+instance FromJSON SourceInfoKind++deriving instance Generic EitherSpan+instance ToJSON EitherSpan+instance FromJSON EitherSpan++deriving instance Generic SourceSpan+instance ToJSON SourceSpan+instance FromJSON SourceSpan++deriving instance Generic FayFileName+instance ToJSON FayFileName+instance FromJSON FayFileName++deriving instance Generic FayModuleName+instance ToJSON FayModuleName+instance FromJSON FayModuleName++deriving instance Generic HoogleResult+instance ToJSON HoogleResult+instance FromJSON HoogleResult++deriving instance Generic PackageLink+instance ToJSON PackageLink+instance FromJSON PackageLink++deriving instance Generic ModuleLink+instance ToJSON ModuleLink+instance FromJSON ModuleLink