diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/fpco-api.cabal b/fpco-api.cabal new file mode 100644 --- /dev/null +++ b/fpco-api.cabal @@ -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.* diff --git a/src/executables/Main.hs b/src/executables/Main.hs new file mode 100644 --- /dev/null +++ b/src/executables/Main.hs @@ -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) diff --git a/src/library/FFI.hs b/src/library/FFI.hs new file mode 100644 --- /dev/null +++ b/src/library/FFI.hs @@ -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 diff --git a/src/library/FP/API.hs b/src/library/FP/API.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/API.hs @@ -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 diff --git a/src/library/FP/API/Convert.hs b/src/library/FP/API/Convert.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/API/Convert.hs @@ -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 diff --git a/src/library/FP/API/Run.hs b/src/library/FP/API/Run.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/API/Run.hs @@ -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 diff --git a/src/library/FP/API/TH.hs b/src/library/FP/API/TH.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/API/TH.hs @@ -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 diff --git a/src/library/FP/API/Types.hs b/src/library/FP/API/Types.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/API/Types.hs @@ -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) diff --git a/src/library/FP/Server.hs b/src/library/FP/Server.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/Server.hs @@ -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" diff --git a/src/library/FP/Server/Config.hs b/src/library/FP/Server/Config.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/Server/Config.hs @@ -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 diff --git a/src/library/FP/Server/Spans.hs b/src/library/FP/Server/Spans.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/Server/Spans.hs @@ -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 diff --git a/src/library/FP/Server/Types.hs b/src/library/FP/Server/Types.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/Server/Types.hs @@ -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