diff --git a/fpco-api.cabal b/fpco-api.cabal --- a/fpco-api.cabal +++ b/fpco-api.cabal @@ -1,5 +1,5 @@ name: fpco-api -version: 1.0.5 +version: 1.1.0 synopsis: Simple interface to the FP Complete IDE API. description: A server and library for communicating with the FP Complete IDE API. homepage: https://www.fpcomplete.com/page/api @@ -22,13 +22,14 @@ FP.Server.Spans, FP.API.Convert other-modules: FP.API.TH, FFI default-language: Haskell2010 - build-depends: base >=4 && < 5, - aeson >=0.6, + build-depends: scientific >= 0.2.0.1, + base >=4 && < 5, + aeson >= 0.6.2.0, bytestring >= 0.9, - ConfigFile >=1.1, + ini >= 0.2.0, data-default >=0.5, text >=0.11, - network >=2.4, + network >=2.3, optparse-applicative >=0.5, safe >=0.3, directory >=1.1, @@ -39,7 +40,7 @@ monad-logger >=0.3, mtl >=2.1, containers >= 0.4, - http-conduit == 1.9.*, + http-conduit >= 1.9.6, texts >=0.3, ghc-prim, template-haskell >=2.7, @@ -64,16 +65,18 @@ default-extensions: CPP hs-source-dirs: src/executables default-language: Haskell2010 - build-depends: base >=4 && < 5, + build-depends: scientific >= 0.2.0.1, + base >=4 && < 5, fpco-api, optparse-applicative >= 0.5, bytestring >= 0.9, - network >=2.4, + network >=2.3, safe >=0.3, - aeson >=0.6, + aeson >=0.6.2.0, text >=0.11, directory >=1.1, filepath >=1.3, - ConfigFile >=1.1, + ini >=0.2.0, data-default >=0.5, - process >= 1.1 + process >= 1.1, + unordered-containers >= 0.2.3 diff --git a/src/executables/Main.hs b/src/executables/Main.hs --- a/src/executables/Main.hs +++ b/src/executables/Main.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoMonomorphismRestriction #-} {-# LANGUAGE OverloadedStrings #-} @@ -11,20 +12,22 @@ 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 qualified Data.HashMap.Strict as M +import Data.Ini 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 Data.Text.Read import Network import Options.Applicative import Prelude hiding (catch) @@ -248,24 +251,16 @@ return () where prompt p = do putStr ("Please enter " ++ p ++ ": ") - getLine + T.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 +writeConfig fp Config{..} = + writeIniFile + fp + (Ini (M.fromList [("SERVER",M.fromList [("port",T.pack (show configPort))]) + ,("API",M.fromList [("token",configToken) + ,("url",configUrl)])])) -- | Run a command with the configuration, if there is one and make -- one if there is not. @@ -275,8 +270,8 @@ fp <- getConfigPath mfp exists <- doesFileExist fp if exists - then do contents <- readFile fp - case readConfig agent contents of + then do ini <- readIniFile fp + case ini >>= readConfig agent of Left cperr -> error cperr Right config -> cont config else do putStrLn ("No configuration found at " ++ fp) @@ -290,17 +285,11 @@ 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) +readConfig :: Maybe Text -> Ini -> Either String Config +readConfig agent ini = do + Config <$> lookupValue "API" "token" ini + <*> lookupValue "API" "url" ini + <*> readValue "SERVER" "port" decimal ini + <*> pure (fromMaybe (configAgent def) agent) + <*> pure (configDebug def) + <*> pure (configStartServer def) diff --git a/src/library/FP/API/Convert.hs b/src/library/FP/API/Convert.hs --- a/src/library/FP/API/Convert.hs +++ b/src/library/FP/API/Convert.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} @@ -30,6 +31,9 @@ import Numeric import Safe import qualified Text.Show.Pretty as Show +#if MIN_VERSION_aeson(0,7,0) +import Data.Scientific +#endif -------------------------------------------------------------------------------- -- The conversion functions. @@ -69,8 +73,13 @@ int = convertInt value -- Number converters +#if MIN_VERSION_aeson(0,7,0) + convertDouble = fmap (Number . fromFloatDigits) . pDouble + convertInt = fmap (Number . fromInteger) . pInt +#else convertDouble = fmap (Number . D) . pDouble convertInt = fmap (Number . I) . pInt +#endif -- Number parsers pDouble :: Show.Value -> Maybe Double @@ -193,9 +202,18 @@ -- | Parse a number. parseNumber :: Value -> Maybe Number +#if MIN_VERSION_aeson(0,7,0) parseNumber value = case value of + Number n + | base10Exponent n >= 0 -> return . I . round $ n + | otherwise -> return . D . fromRational . toRational $ n + _ -> mzero +#else +parseNumber value = case value of Number n -> return n _ -> mzero +#endif + -- | Parse a bool. parseBool :: Value -> Maybe Bool diff --git a/src/library/FP/API/Run.hs b/src/library/FP/API/Run.hs --- a/src/library/FP/API/Run.hs +++ b/src/library/FP/API/Run.hs @@ -16,7 +16,7 @@ import FP.API.Convert import FP.API.Types -import Control.Exception +import Control.Exception as E import Control.Failure import Control.Monad.Extra import Control.Monad.Logger @@ -27,18 +27,17 @@ 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 Prelude import Texts.English -- | Only used internally for encoding. -data Command = IdeCommand IdeCommand +data Command = IdeCommand !IdeCommand deriving Show -- | Monad that can get info for sending commands. @@ -47,11 +46,11 @@ -- | Simple command configuration. data ClientConfig = CC - { ccUrl :: String - , ccToken :: String - , ccManager :: Manager - , ccCookie :: IORef CookieJar - , ccUserAgent :: Text + { ccUrl :: !Text + , ccToken :: !Text + , ccManager :: !Manager + , ccCookie :: !(IORef CookieJar) + , ccUserAgent :: !Text } data CommandException @@ -67,7 +66,7 @@ runCommand :: (MonadLogger m,MonadClient m,Data a,Show a) => (Returns' a -> IdeCommand) -> m a runCommand cmd = do CC{..} <- getClientConfig - request <- parseUrl (ccUrl <> "/fay-command") + request <- parseUrl (T.unpack (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))))) @@ -93,7 +92,7 @@ , requestHeaders = requestHeaders req ++ [("Accept","application/json") ,("User-Agent",encodeUtf8 ("fpco-api:" <> agent)) - ,("authorization","token " <> fromString token)] + ,("authorization",encodeUtf8 ("token " <> token))] , responseTimeout = Nothing , cookieJar = jar } diff --git a/src/library/FP/API/Types.hs b/src/library/FP/API/Types.hs --- a/src/library/FP/API/Types.hs +++ b/src/library/FP/API/Types.hs @@ -198,7 +198,7 @@ deriving (Read, Typeable, Data, Show, Eq) -- TODO: middle text should be the code that the type comes from. -data TypeInfo = TypeInfo SourceSpan Text [Text] +data TypeInfo = TypeInfo SourceSpan Text Text deriving (Read, Typeable, Data, Show, Eq) data MaybeText = NoText | JustText Text -- FAY BUG @@ -554,11 +554,7 @@ -- Isolation-runner ids data CompileId = CompileId { unCompileId :: Int } - deriving (Read, Typeable, Data, Show, Eq -#ifndef FAY - , Ord -#endif - ) + deriving (Read, Typeable, Data, Show, Eq) data ProcId = ProcId { unProcId :: Int } deriving (Read, Typeable, Data, Show, Eq) @@ -617,7 +613,7 @@ | ProcessOutputError Text | StatusSnapshot ProjectStatusSnapshot StatusHash | IdInfoResults IdInfo - | SubExprsResults SourceSpan [TypeInfo] + | SubExprsResults SourceSpan [[TypeInfo]] | AutoCompleteResults (Maybe AutoCompleteInput) [Text] | ImportedPackagesResults [PackageId] | SearchResults [SearchResult] diff --git a/src/library/FP/Server.hs b/src/library/FP/Server.hs --- a/src/library/FP/Server.hs +++ b/src/library/FP/Server.hs @@ -17,7 +17,7 @@ import Control.Applicative import Control.Concurrent.Lifted -import Control.Exception.Lifted hiding (handle) +import Control.Exception.Lifted as E hiding (handle) import Control.Monad.Extra import Control.Monad.Logger import Control.Monad.Reader @@ -37,7 +37,7 @@ import Data.Typeable import Network import Network.HTTP.Conduit -import Prelude hiding (span,catch) +import Prelude hiding (span) import System.Directory import System.FilePath import System.IO @@ -46,7 +46,7 @@ -- | 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 + manager <- newManager conduitManagerSettings pollers <- newMVar mempty jar <- newIORef mempty tokensVar <- newMVar mempty @@ -71,7 +71,7 @@ io (hSetBuffering stdout NoBuffering) sock <- io (listenOn (PortNumber (fromIntegral configPort))) $(logInfo) ("Server started on port " <> pack (show configPort) <> - ", remote URL is: " <> pack configUrl) + ", remote URL is: " <> configUrl) (if forkOnceListening then void . fork else id) (forever (acceptConnection sock)) @@ -278,7 +278,7 @@ (\_ msg -> do case msg of SubExprsResults span' infos - | span' == span -> do reply h (ReplyTypeInfo (map toSpanType infos)) + | span' == span -> do reply h (ReplyTypeInfo (map toSpanType (concat infos))) return Done _ -> return NotDone)) @@ -294,16 +294,16 @@ 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))) + E.catch (do SaveFileOutput token' _ <- saveFile fname text token fpid + updateToken tokensVar root filename token' + reply h (ReplySaveStatus False)) + -- A command exception will be thrown when the file is out of + -- date. So we just immediately grab the new version of the + -- file, overwrite out local copy. Emacs will prompt the user + -- about it at the right time. + (\(_ :: CommandException) -> + do updateFileContents tokensVar fpid root filename + reply h (ReplySaveStatus True))) -- | Check the given module. Necessary for flycheck. checkModule :: Handle -> FayProjectId -> FilePath -> FilePath -> FilePath -> Server () @@ -493,8 +493,8 @@ getFayProjectId = either getProjectId return -- | Strip the trailing slash. -stripSlash :: String -> String -stripSlash = reverse . dropWhile (=='/') . reverse +stripSlash :: Text -> Text +stripSlash = T.reverse . T.dropWhile (=='/') . T.reverse -- | Convert an API message to a more structurally convenient reply message. convertMsg :: FilePath -> SourceInfo -> CompileMessage diff --git a/src/library/FP/Server/Config.hs b/src/library/FP/Server/Config.hs --- a/src/library/FP/Server/Config.hs +++ b/src/library/FP/Server/Config.hs @@ -1,9 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} + -- | Server configuration. module FP.Server.Config where +import Data.Text (Text) + -- | Default url to accept commands on. -defaultUrl :: String +defaultUrl :: Text defaultUrl = "https://www.fpcomplete.com/" -- | Default port to accept commands on. diff --git a/src/library/FP/Server/Spans.hs b/src/library/FP/Server/Spans.hs --- a/src/library/FP/Server/Spans.hs +++ b/src/library/FP/Server/Spans.hs @@ -27,8 +27,8 @@ T.pack (show fromCol) toSpanType :: TypeInfo -> SpanType -toSpanType (TypeInfo (SourceSpan _ sl sc el ec) srcstr typs) = - SpanType sl sc el ec srcstr typs +toSpanType (TypeInfo (SourceSpan _ sl sc el ec) srcstr typ) = + SpanType sl sc el ec srcstr typ makeEitherLoc :: FilePath -> EitherSpan -> Maybe Loc makeEitherLoc _ TextSpan{} = Nothing diff --git a/src/library/FP/Server/Types.hs b/src/library/FP/Server/Types.hs --- a/src/library/FP/Server/Types.hs +++ b/src/library/FP/Server/Types.hs @@ -15,7 +15,7 @@ import FP.Server.Config import Control.Concurrent (MVar) -import Control.Monad.Logger +import Control.Monad.Logger (LoggingT) import Control.Monad.Reader import Data.Aeson import Data.Default @@ -52,8 +52,8 @@ -- | Configuration for server. data Config = Config - { configToken :: !String - , configUrl :: !String + { configToken :: !Text + , configUrl :: !Text , configPort :: !Integer , configAgent :: !Text , configDebug :: !Bool @@ -121,7 +121,7 @@ -- | A type info thing. data SpanType = SpanType Int Int Int Int -- Position Text -- Source string - [Text] -- Types + Text -- Types deriving (Generic,Show) instance ToJSON SpanType