diff --git a/fpco-api.cabal b/fpco-api.cabal --- a/fpco-api.cabal +++ b/fpco-api.cabal @@ -1,83 +1,114 @@ -name: fpco-api -version: 1.1.1.4 -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 -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 +name: fpco-api +version: 1.2.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 +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 + default: False +flag dev + default: False + library - ghc-options: -Wall -O2 - 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: scientific >= 0.2.0.1, - base >=4 && < 5, - aeson >= 0.6.2.0, - bytestring >= 0.9, - ini >= 0.2.0, - data-default >=0.5, - text >=0.11, - network >=2.3, - 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.6, - texts >=0.3, - ghc-prim, - template-haskell >=2.7, - attoparsec >=0.10, - syb >=0.3.7, - 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, - tagged, - random >=1.0 + ghc-options: -Wall -fwarn-incomplete-record-updates + if flag(dev) + ghc-options: -O0 + else + ghc-options: -O2 + default-language: Haskell2010 + hs-source-dirs: src/library + exposed-modules: + FP.API + , FP.API.Common + , FP.API.ModuleName + , FP.API.Runner + , FP.API.Signal + , FP.API.Types + , FP.Server + , FP.Server.Config + , FP.Server.Spans + , FP.Server.Types + other-modules: + FFI + , FP.API.Dispatch + build-depends: + base >=4 && < 5 + , aeson >= 0.6 + , attoparsec >= 0.10 + , base64-bytestring >= 1.0.0.1 + , blaze-html >= 0.6 + , bytestring >= 0.9 + , cereal >= 0.4.0.1 + , containers >= 0.4 + , data-default >= 0.5 + , deepseq >= 1.1 + , deepseq-generics >= 0.1 + , directory >= 1.1 + , failure >= 0.2 + , fay >= 0.18 + , filepath >= 1.3 + , ghc-prim + , hashable + , http-conduit == 2.1.* + , http-types >= 0.8 + , lifted-async >= 0.1 + , lifted-base >= 0.2 + , monad-control >= 0.3.2 + , monad-extras >= 0.5 + , monad-logger >= 0.3 + , mtl >= 2.1 + , network >= 2.4 + , persistent >= 1.2 + , persistent-template >= 1.2 + , pretty-show >= 1.6 + , random >= 1.0 + , resourcet >= 0.4 + , safe >= 0.3 + , semigroups >= 0.12.2 + , shakespeare + , shakespeare-i18n + , stm >= 2.4 + , syb >= 0.4 + , template-haskell >= 2.7 + , text >= 0.11 + , texts >= 0.3 + , time >= 1.4 + , transformers >= 0.3 + , transformers-base >= 0.4 + , unordered-containers >= 0.2 + , vector >= 0.10 + , yesod-core >= 1.2 + , yesod-fay >= 0.4 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: scientific >= 0.2.0.1, - base >=4 && < 5, - fpco-api, - optparse-applicative >= 0.5, - bytestring >= 0.9, - network >=2.3, - safe >=0.3, - aeson >=0.6.2.0, - text >=0.11, - directory >=1.1, - filepath >=1.3, - ini >=0.2.0, - data-default >=0.5, - process >= 1.1, - unordered-containers >= 0.2.3 + if flag(jenkins-build) + buildable: False + ghc-options: -Wall -fwarn-incomplete-record-updates -threaded -O2 + main-is: Main.hs + default-extensions: CPP + hs-source-dirs: src/executables + default-language: Haskell2010 + build-depends: + base >=4 && < 5 + , aeson >= 0.6 + , bytestring >= 0.9 + , data-default >= 0.5 + , directory >= 1.1 + , filepath >= 1.3 + , fpco-api + , ini >= 0.2.0 + , network >= 2.4 + , optparse-applicative >= 0.5 + , process >= 1.1 + , safe >= 0.3 + , text >= 0.11 + , 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 @@ -10,7 +10,6 @@ import FP.API.Types import FP.Server import FP.Server.Types -import FP.Server.Spans import Control.Exception import Control.Monad @@ -133,13 +132,13 @@ help "Config file")) -- | PID option. -fayPidOpt :: Parser FayProjectId +fayPidOpt :: Parser ProjectId fayPidOpt = argument (return . toFay) (metavar "PID") -- | PROJECT option. -fayProjectOpt :: Parser (Either Text FayProjectId) +fayProjectOpt :: Parser (Either Text ProjectId) fayProjectOpt = argument (return . toFayPid) (metavar "PROJECT" <> @@ -170,11 +169,11 @@ -- Project ID -- | Convert to project ID. -toFay :: String -> FayProjectId -toFay i = FayProjectId (T.pack (show (read i :: Int))) +toFay :: String -> ProjectId +toFay x = ProjectId $ fromMaybe (error $ "toFay could not read " ++ x) $ readMay x -- | Convert to a project ID or project URL. -toFayPid :: String -> Either Text FayProjectId +toFayPid :: String -> Either Text ProjectId toFayPid i | isPrefixOf "http" i = Left (T.pack i) | otherwise = Right (toFay i) @@ -225,16 +224,14 @@ -- | 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" +printSourceInfo root si = + case convertMsg root si of + CompileMessage sp _ msg -> + sp <> ":\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 diff --git a/src/library/FP/API.hs b/src/library/FP/API.hs --- a/src/library/FP/API.hs +++ b/src/library/FP/API.hs @@ -1,34 +1,128 @@ -{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# OPTIONS -fno-warn-orphans #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE CPP #-} {-# LANGUAGE TemplateHaskell #-} -{-# OPTIONS -fno-warn-missing-signatures #-} --- | Commands for the IDE API. - -module FP.API where +module FP.API + ( module FP.API + , module FP.API.Types + ) where +import Data.Text import FP.API.Types -import FP.API.TH +import Prelude --- General project operations +#ifndef FAY +import Data.Serialize +import GHC.Generics (Generic) +#endif -cmd 'GetInitialProjectInfo -cmd 'GetProjectId +-- | Convert a theme to a string. +themeToString :: Theme -> String +themeToString Zenburn = "zenburn" +themeToString Panda = "panda" +themeToString Monokai = "monokai" --- Polling +-- | Get a human-readable name for a theme. +themeName :: Theme -> String +themeName Zenburn = "Zenburn" +themeName Panda = "Panda" +themeName Monokai = "Monokai" -cmd 'GetProjectMessages +-- | Get a human-readable description of a string. +themeDescription :: Theme -> String +themeDescription Zenburn = "A theme based on the popular Zenburn theme" +themeDescription Panda = "The default FP Development Environment theme" +themeDescription Monokai = "A Sublime inspired theme based on Monokai" --- Module manipulation +-- | Similar to [minBound..maxBound], with our own custom ordering. +enumerateThemes :: [Theme] +enumerateThemes = [Panda,Zenburn,Monokai] -cmd 'GetFile -cmd 'GetFileToken -cmd 'SaveFile -cmd 'AddFile -cmd 'DeleteFile +-- | The default theme to use when there is no existing theme. +defaultTheme :: Theme +defaultTheme = Panda --- Query features +-- | The default font size to use. +defaultFontSize :: Int +defaultFontSize = 14 -cmd 'GetTypeInfo -cmd 'GetDefinitionSource -cmd 'GetAutocompletions -cmd 'IdeHoogleSearch +defaultSearchStyle :: Bool +defaultSearchStyle = False + +-- | Default license to use upon initialization. +defaultLicense :: IdeLicense +defaultLicense = ILCommunity + +-- | Error that can be returned by some commands, which indicates that the +-- command requires that the settings file be valid. +invalidSettingsError :: Text +invalidSettingsError = fromString "Invalid settings file" + +-- | Error that can be returned by 'GetProjectMessages', which +-- indicates that the backend server hasn't started yet. In order to +-- cause the server to run, some normal command needs to be executed +-- (not a project messages poll, though). +serverSessionNotReadyError :: Text +serverSessionNotReadyError = fromString "Server session not yet ready" + +-- | The filepath used for the settings file. +projectSettingsPath :: Text +projectSettingsPath = fromString ".project-settings.yml" + +-- | Determine whether a git branch name is valid. +-- +-- TODO: This could be better. See, e.g. the regexes here: +-- http://stackoverflow.com/a/12093994/1164871 +validGitBranch :: String -> Bool +validGitBranch = Prelude.all ok where + ok c = elem c "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789-_." + +-------------------------------------------------------------------------------- +-- Access control + +-- | Action that roles can perform. +data Action + = DoBuildExecutables + | DoDeployment + | DoPrivateProjects + | DoMakeCommercialProducts + | DoGitStuff + | DoExternalEditor + deriving (Show, Eq +#ifndef FAY + , Generic +#endif + ) + +#ifndef FAY +instance Serialize Action +#endif + +-- | Give a human readable description for actions that could be used +-- in a sentence. +describeAction :: Action -> Text +describeAction = fromString . describe where + describe x = + case x of + DoBuildExecutables -> "build executables" + DoDeployment -> "make deployments" + DoPrivateProjects -> "have private projects" + DoGitStuff -> "perform Git actions" + DoMakeCommercialProducts -> "use the IDE for commercial work" + DoExternalEditor -> "use an external editor" + +-- | Can the given role do the given action? +canDo :: IdeLicense -> Action -> Bool +canDo ILProfessional = const True +canDo ILPersonal = flip elem [DoBuildExecutables,DoDeployment,DoMakeCommercialProducts,DoGitStuff,DoExternalEditor] +canDo ILCommunity = flip elem [DoBuildExecutables,DoDeployment,DoMakeCommercialProducts,DoGitStuff,DoExternalEditor] + +-- | Get the name of the license, for use in code IDs and such. +licenseName :: IdeLicense -> Text +licenseName ILPersonal = fromString "personal" +licenseName ILCommunity = fromString "community" +licenseName ILProfessional = fromString "professional" diff --git a/src/library/FP/API/Common.hs b/src/library/FP/API/Common.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/API/Common.hs @@ -0,0 +1,439 @@ +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoMonomorphismRestriction #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE ViewPatterns #-} + +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} + +module FP.API.Common where + +import Control.Applicative +import Control.Concurrent (threadDelay) +import Control.Concurrent.STM +import Control.Exception (Exception) +import Control.Exception.Lifted (SomeException, try, throw) +import Control.Monad +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.Trans.Control (MonadBaseControl) +import Data.Aeson (Value, decode) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import Data.Data (Data) +import Data.Generics.Schemes (listify) +import Data.IORef +import Data.List (isInfixOf) +import qualified Data.Map as M +import Data.Maybe +import Data.Monoid +import Data.Text (Text) +import qualified Data.Text as T +import Data.Text.Encoding (encodeUtf8, decodeUtf8) +import Data.Typeable +import FP.API as API +import FP.API.Dispatch +import FP.API.Signal +import Fay.Convert + +import Language.Fay.Yesod (Returns(..)) +import Prelude hiding (FilePath) +import System.Timeout + +data ClientRoute = MiscCommandRoute + | IdeMessagesRoute API.ProjectId + | IdeAsyncCommandRoute API.ProjectId + deriving (Eq, Ord, Show) + +class ( Applicative m, MonadIO m, MonadBaseControl IO m + , Applicative m', MonadIO m', MonadBaseControl IO m') + => FpClient m m' | m -> m' where + runCallback :: m' a -> m a + clientInfo :: m (ClientInfo m') + makeRequest :: (Data command, Show command) + => Text + -> Int + -> ClientRoute + -> command + -> m (Maybe LBS.ByteString) + +data ClientInfo m' = ClientInfo + { ciProjId :: API.ProjectId + , ciCallbacks :: ProjectCallbacks m' + , ciTokens :: IORef (M.Map EncFileName FayTutorialToken) + , ciCompileId :: TVar (Maybe CompileId) + , ciSessionId :: TVar (Maybe SessionId) + , ciLastStatus :: TVar (Maybe ProjectStatusSnapshot) + , ciTimeout :: Int + } + +newClientInfo :: Int -> ProjectId -> IO (ClientInfo m') +newClientInfo ciTimeout ciProjId = do + ciCallbacks <- liftIO defaultProjectCallbacks + ciTokens <- liftIO $ newIORef mempty + ciLastStatus <- liftIO $ newTVarIO Nothing + ciSessionId <- liftIO $ newTVarIO Nothing + ciCompileId <- liftIO $ newTVarIO Nothing + return $ ClientInfo {..} + +data ProjectCallbacks m' = ProjectCallbacks + { pcJobs :: IORef (Join API.JobId (Either Text Value -> m' ()) (Either Text Value)) + , pcMessage :: Signal m' (LogLevel, Text) + , pcProcessOutput :: Signal m' (ProcId, StdoutResult) + , pcNewStatus :: Signal m' ProjectStatusSnapshot + , pcProjectClosed :: Signal m' () + } + +defaultProjectCallbacks :: IO (ProjectCallbacks m') +defaultProjectCallbacks = ProjectCallbacks + <$> newIORef emptyJoin + <*> newSignal + <*> newSignal + <*> newSignal + <*> newSignal + +data ClientException = ClientException Text + deriving (Typeable) + +instance Exception ClientException + +instance Show ClientException where + show (ClientException msg) = "ClientException: " ++ T.unpack msg + +clientFail :: Text -> a +clientFail = throw . ClientException + +-- Messages polling. + +data Join k a b = Join (M.Map k a) (M.Map k b) + +emptyJoin :: Ord k => Join k a b +emptyJoin = Join mempty mempty + +joinAInput :: Ord k => Join k a b -> k -> a -> (Join k a b, Maybe b) +joinAInput (Join as bs) k a = + case M.lookup k bs of + Nothing -> (Join (M.insert k a as) bs, Nothing) + Just b -> (Join as (M.delete k bs), Just b) + +joinBInput :: Ord k => Join k a b -> k -> b -> (Join k a b, Maybe a) +joinBInput (Join as bs) k b = + case M.lookup k as of + Nothing -> (Join as (M.insert k b bs), Nothing) + Just a -> (Join (M.delete k as) bs, Just a) + +pollProjectMessages :: FpClient m m' => m () +pollProjectMessages = do + ClientInfo {..} <- clientInfo + let loop req = do + res <- makeFayCall (IdeMessagesRoute ciProjId) (GetProjectMessages req) + case res of + -- FIXME mgs: This probably needs the same pause/resume logic as + -- in the Fay code. + Failure e | "Server session not yet ready" `isInfixOf` show e -> do + liftIO $ threadDelay 100000 + loop req + Failure e -> do + liftIO $ putStrLn "Failure in pollProjectMessages" + clientFail e + Success (ProjectMessagesOutput msnap hash highestMsg xs mbid) -> do + -- NOTE: it might be advantageous to instead have + -- another thread, fed by a channel, to handle the + -- callbacks. This way, they won't block subsequent + -- requests. + mapM_ handleMessage xs + case msnap of + Nothing -> return () + Just snap -> do + liftIO $ atomically $ writeTVar ciLastStatus (Just snap) + runCallback $ sendSignal (pcNewStatus ciCallbacks) snap + loop $ PMRLaterRequest highestMsg hash mbid + -- Make sure the project is actually started + void $ makeRequest "polling messages" + 200 + (IdeAsyncCommandRoute ciProjId) + (GetInitialProjectInfo "handleMessage" Returns) + loop PMRFirstRequest + +handleMessage :: FpClient m m' => RunnerMessage -> m () +handleMessage inp = do + ClientInfo {..} <- clientInfo + let pc = ciCallbacks + case inp of + IdeCommandOutput jid txt -> + case decode (LBS.fromChunks [encodeUtf8 txt]) of + Nothing -> clientFail $ "Failed to json decode " <> txt + Just v -> runCallback $ jobResult ciCallbacks jid (Right v) + JobException jid e -> runCallback $ jobResult ciCallbacks jid (Left e) + ProcessOutput procid v -> runCallback $ sendSignal (pcProcessOutput pc) (procid, SRSuccess v) + ProcessStopped procid pr -> runCallback $ sendSignal (pcProcessOutput pc) (procid, SRTerminated pr) + ProjectMessage level msg -> runCallback $ sendSignal (pcMessage pc) (level, msg) + ProjectHasClosed sid True _ -> do + liftIO $ atomically $ do + mcurrSid <- readTVar ciSessionId + when (mcurrSid == Just sid) $ do + writeTVar ciCompileId Nothing + writeTVar ciSessionId Nothing + runCallback $ sendSignal (pcProjectClosed pc) () + + -- Emulate the Fay client code which sends a command to + -- force the project to restart on the server. + void $ makeRequest "restarting session" + 200 + (IdeAsyncCommandRoute ciProjId) + (Ping Returns) + ProjectHasClosed _sid False e -> error $ "handleMessage: Encountered ProjectHasClosed False: " ++ T.unpack e + --TODO: use this (probably only relevant to the emacs client) + JobStillRunning _ -> return () + CompileComplete{} -> return () + ProjectHasOpened sid -> liftIO $ atomically $ do + oldSid <- readTVar ciSessionId + when (oldSid /= Just sid) $ do + writeTVar ciCompileId Nothing + writeTVar ciSessionId $ Just sid + GitShellOutput _ _ -> return () + +jobResult :: MonadIO m' + => ProjectCallbacks m' + -> JobId -> Either Text Value -> m' () +jobResult pc jid x = do + mf <- liftIO $ atomicModifyIORef (pcJobs pc) $ \jobs -> + joinBInput jobs jid x + case mf of + Nothing -> return () + Just f -> f x + +jobCallback :: MonadIO m' + => ProjectCallbacks m' + -> JobId + -> (Either Text Value -> m' ()) + -> m' () +jobCallback pc jid f = do + mx <- liftIO $ atomicModifyIORef (pcJobs pc) $ \jobs -> + joinAInput jobs jid f + case mx of + Nothing -> return () + Just x -> f x + +-- Convenient wrappers over ide commands. + +ideCommand :: (Data command, Show command, Data a, Show a, FpClient m m') + => (Returns' a -> command) + -> m a +ideCommand cmd = do + let shownCmd = show (cmd Returns) + eres <- makeFayAsyncCall cmd + case eres of + Left e -> clientFail (T.pack shownCmd <> " failed with: " <> e) + Right x -> return x + +-- | (for testing purposes) +ideCommandFail :: forall command a m m'. (Data command, Show command, Data a, Show a, FpClient m m') + => (Returns' a -> command) + -> m () +ideCommandFail cmd = do + let shownCmd = show (cmd Returns) + eeres <- try $ makeFayAsyncCall cmd + case (eeres :: Either SomeException (Either Text a)) of + Right (Right x) -> clientFail (T.pack shownCmd <> " expected to fail, but it succeeded with " <> T.pack (show x)) + _ -> return () + +makeFayAsyncCall :: forall command a m m'. (Data command, Show command, Data a, Show a, FpClient m m') + => (Returns' a -> command) -> m (Either Text a) +makeFayAsyncCall cmd = do + ClientInfo {..} <- clientInfo + let shownCmd = show (cmd Returns) + jid <- makeFayCall' + (IdeAsyncCommandRoute ciProjId) + (cmd Returns) + var <- liftIO newEmptyTMVarIO + runCallback $ jobCallback ciCallbacks jid (liftIO . atomically . putTMVar var) + mres <- liftIO $ timeout ciTimeout $ atomically $ takeTMVar var + case mres of + Nothing -> clientFail $ "Call timed out: " <> T.pack shownCmd + Just (Left err) -> return $ Left err + Just (Right val) -> + case readFromFay' val of + Left err -> clientFail $ "Failed to parse response to " <> T.pack shownCmd <> ": " <> T.pack err + Right (Success x) -> do + didRestart <- liftIO $ atomically $ updateSessionCompileId ciCompileId ciSessionId x + when didRestart $ + void $ makeRequest "restarting session" + 200 + (IdeAsyncCommandRoute ciProjId) + (Ping Returns) + return $ Right x + Right (Failure e) -> return $ Left e + +updateSessionCompileId :: (Show a, Data a) + => TVar (Maybe CompileId) + -> TVar (Maybe SessionId) + -> a + -> STM Bool +updateSessionCompileId cidVar sidVar a = + case listify (const True) a of + [RunnerProjectClosed (Just sid)] -> do + mcurrSid <- readTVar sidVar + when (mcurrSid == Just sid) $ do + writeTVar cidVar Nothing + writeTVar sidVar Nothing + return True + [RunnerProjectClosed Nothing] -> error "updateSessionCompileId: RunnerProjectClosed Nothing" + [] -> do + go $ writeTVar cidVar . Just + go $ writeTVar sidVar . Just + return False + x@(_:_) -> error $ "updateSessionCompileId: multiple RunnerProjectClosed: " ++ show x + where + go :: (Show b, Monad m, Typeable b) => (b -> m ()) -> m () + go f = + case listify (const True) a of + [] -> return () + [b] -> f b + bs -> error $ "updateSessionCompileId: multiple values returned in: " ++ show (a, bs) + +fayCommand :: (Data command, Show command, Data a, FpClient m m') + => (Returns' a -> command) + -> m a +fayCommand = callFay MiscCommandRoute + +callFay :: (Data command, Show command, Data a, FpClient m m') + => ClientRoute + -> (Returns' a -> command) + -> m a +callFay r cmd = do + res <- makeFayCall r cmd + case res of + Failure e -> clientFail ("Due to call of " <> T.pack (show (cmd Returns)) <> ": " <> T.pack (show e)) + Success s -> return s + +makeFayCall :: (Data command, Show command, Data a, FpClient m m') + => ClientRoute + -> (Returns a -> command) + -> m a +makeFayCall r cmd = makeFayCall' r (cmd Returns) + +-- | This is the same thing as 'makeFayCall', but with a less +-- restrictive type that doens't enforce that the return type of the +-- command is correct. +makeFayCall' :: (Data command, Show command, Data a, FpClient m m') + => ClientRoute + -> command + -> m a +makeFayCall' r cmd = do + handleServerResponse (show cmd) =<< makeRequest "running a command" 200 r cmd + +handleServerResponse :: (Data a, Monad m) => String -> Maybe LBS.ByteString -> m a +handleServerResponse (T.pack -> shownCmd) mres = + case mres of + Nothing -> clientFail $ "No response to " <> shownCmd + Just body -> + case decode body of + Nothing -> clientFail $ + "Could not parse JSON of response to " <> shownCmd <> + ". Here's the response: " <> decodeUtf8 (BS.concat (LBS.toChunks body)) + Just json -> + case readFromFay' json of + Left err -> clientFail $ + "Error interpreting response from " <> shownCmd <> + ". Here's the error: " <> T.pack err + Right x -> return x + +-- Generate function equivalents for all of the fay command constructors. +$(mkFayCommands + [ (''IdeCommand, 'ideCommand, id) + , (''IdeCommand, 'ideCommandFail, (++ "Fail")) + , (''FayCommand, 'fayCommand, id) + ]) + +-- Wrappers around commands that yield / consume FayTutorialTokens, +-- automatically managing the map of tokens. + +addFile' :: FpClient m m' => NewFileInfo -> m (Maybe CompileDesc) +addFile' nfi = do + SaveFileOutput tok mdesc <- addFile nfi + updateToken (encFileNameFromText (fiPath nfi)) tok + return mdesc + +saveFile' :: FpClient m m' => EncFileName -> Text -> m (Maybe CompileDesc) +saveFile' efn content = do + ClientInfo {..} <- clientInfo + mtok <- liftIO $ M.lookup efn <$> readIORef ciTokens + case mtok of + Nothing -> do + liftIO $ do + putStrLn $ "Attempted to save to a non-existent file: " ++ unEncFileNameString efn + putStrLn "Updating its token..." + tok <- updateFileToken efn + doSave tok + Just tok -> doSave tok + where + doSave tok = do + SaveFileOutput tok' mdesc <- saveFile efn content tok + updateToken efn tok' + return mdesc + + +deleteFile' :: FpClient m m' => EncFileName -> m (Maybe CompileDesc) +deleteFile' efn = do + mdesc <- deleteFile efn + modifyTokens (M.delete efn) + return mdesc + +renameFile' :: FpClient m m' => EncFileName -> NewFileInfo -> RenameType -> m RenameFileOutput +renameFile' efn nfi rtyp = do + output <- renameFile efn nfi rtyp + case output of + RenameFileOutput (Just tok) _ _ -> + modifyTokens (M.insert (encFileNameFromText (fiPath nfi)) tok . M.delete efn) + _ -> return () + return output + +updateFileToken :: FpClient m m' => EncFileName -> m FayTutorialToken +updateFileToken efn = do + tok <- getFileToken efn + updateToken efn tok + return tok + +getFile' :: FpClient m m' => EncFileName -> m (Maybe Text) +getFile' efn = do + FayFileContent mcontent tok <- getFile efn + updateToken efn tok + return mcontent + +-- Utilities for token handling. + +updateToken :: FpClient m m' => EncFileName -> FayTutorialToken -> m () +updateToken efn tok = modifyTokens (M.insert efn tok) + +modifyTokens :: FpClient m m' => (M.Map EncFileName FayTutorialToken -> M.Map EncFileName FayTutorialToken) -> m () +modifyTokens f = do + ClientInfo {..} <- clientInfo + liftIO $ atomicModifyIORef ciTokens ((,()) . f) + +-- Utility for waiting for a particular status. + +watchStatusOneShot :: FpClient m m' + => String + -> Maybe Int + -> (ProjectStatusSnapshot -> m' (Maybe a)) + -> m a +watchStatusOneShot msg mmicros f = do + ClientInfo {..} <- clientInfo + mlastStatus <- liftIO $ readTVarIO ciLastStatus + mres <- case mlastStatus of + Nothing -> return Nothing + Just lastStatus -> runCallback $ f lastStatus + case mres of + Just res -> return res + Nothing -> do + mres' <- liftIO $ + blockOnSignal mmicros (pcNewStatus ciCallbacks) f + case mres' of + Nothing -> fail $ msg ++ " timed out while blocking on status." + Just res -> return res diff --git a/src/library/FP/API/Convert.hs b/src/library/FP/API/Convert.hs deleted file mode 100644 --- a/src/library/FP/API/Convert.hs +++ /dev/null @@ -1,252 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# 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 -#if MIN_VERSION_aeson(0,7,0) -import Data.Scientific -#endif - --------------------------------------------------------------------------------- --- 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 -#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 - 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 -#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 -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/Dispatch.hs b/src/library/FP/API/Dispatch.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/API/Dispatch.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE StandaloneDeriving #-} + +module FP.API.Dispatch where + +import Data.Char (toLower) +import Data.Maybe (mapMaybe) +import Data.Traversable (forM) +import Language.Haskell.TH +import Language.Fay.Yesod (Returns) +import FP.API.Types (Returns') +import Prelude + +mkFayCommands :: [(Name, Name, String -> String)] -> Q [Dec] +mkFayCommands cmdTypes = + fmap concat $ forM cmdTypes $ \(datatype, runName, changeName) -> do + (TyConI (DataD _ _ _ cs _)) <- reify datatype + sequence [ mkFayCommand runName name changeName (map snd fs) + | NormalC name fs <- cs + ] + +mkFayCommand :: Name -> Name -> (String -> String) -> [Type] -> Q Dec +mkFayCommand runName conName nameModifier fields = do + args <- forM fields $ \ty -> case unAppsT ty of + -- Don't include the "Returns" field of the command + (ConT n:_) | n == ''Returns || n == ''Returns' + -> return (Nothing, Nothing) + -- Otherwise, have an argument and use it in the command + _ -> do + n <- newName "x" + return (Just $ VarP n, Just $ VarE n) + let funcName = mkName $ nameModifier $ decapitalize $ nameBase conName + expr = AppE (VarE runName) $ + foldl AppE (ConE conName) $ mapMaybe snd args + return $ FunD funcName [Clause (mapMaybe fst args) (NormalB expr) []] + +decapitalize :: String -> String +decapitalize [] = [] +decapitalize (x:xs) = toLower x : xs + +appsE' :: [Exp] -> Exp +appsE' = foldl1 AppE + +unAppsT :: Type -> [Type] +unAppsT = reverse . helper + where + helper (AppT l r) = r : helper l + helper x = [x] diff --git a/src/library/FP/API/ModuleName.hs b/src/library/FP/API/ModuleName.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/API/ModuleName.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE FlexibleInstances #-} +-- | Valid Haskell qualified module names. +module FP.API.ModuleName + ( ModuleName(..) + , toModulePath + , mainModule + , checkModuleName + , fromModuleName + , isModulePath + , fromModulePath + ) where + +import Prelude +import Control.Monad (mplus, guard) +import qualified Data.Char as Char (isAlphaNum, isUpper) +import Data.Maybe (isJust) +import Data.Text (Text) +import Data.Text (splitOn) +import qualified Data.Text as T +import Data.Monoid ((<>)) +import FP.API.Types + +toModulePath :: ModuleName -> Text +toModulePath (ModuleName n) = T.intercalate "/" (splitOn "." n) <> ".hs" + +mainModule :: ModuleName +mainModule = ModuleName "Main" + +checkModuleName :: ModuleName -> Either Text ModuleName +checkModuleName (ModuleName mn) = maybe (Left ("Invalid module name: " <> mn)) Right $ fromModuleName mn + +-- | Parses normal modules, or main modules with an additional filepath. +fromModuleName :: Text -> Maybe ModuleName +fromModuleName string + | all validModuleComponent components && not (null components) = Just $ ModuleName string + | otherwise = Nothing + where + components = splitOn "." string + +-- | Determine if the given textual @FilePath@ might be a valid module path. +isModulePath :: Text -> Bool +isModulePath t = isJust $ T.stripSuffix ".hs" t `mplus` T.stripSuffix ".lhs" t + +-- | Guesses a module name from a path, assuming that it ends in ".hs", and +-- every path component is a component of the name. Should be the inverse +-- of 'toModulePath' (other than the 'Just'). +fromModulePath :: Text -> Maybe ModuleName +fromModulePath s1 = do + s2 <- T.stripSuffix ".hs" s1 + let components = splitOn "/" s2 + guard $ all validModuleComponent components + guard $ not (null components) + return $ ModuleName $ T.intercalate "." components + +validModuleChar :: Char -> Bool +validModuleChar c = Char.isAlphaNum c || c == '_' || c == '\'' + +validModuleComponent :: Text -> Bool +validModuleComponent t = + case T.uncons t of + Nothing -> False + Just (c, t') -> Char.isUpper c && T.all validModuleChar t' diff --git a/src/library/FP/API/Run.hs b/src/library/FP/API/Run.hs deleted file mode 100644 --- a/src/library/FP/API/Run.hs +++ /dev/null @@ -1,101 +0,0 @@ -{-# 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 as E -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.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 -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 :: !Text - , ccToken :: !Text - , 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 <- io $ 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))))) - resp <- io (runResourceT (httpLbs req ccManager)) - 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" - , requestHeaders = requestHeaders req ++ - [("Accept","application/json") - ,("User-Agent",encodeUtf8 ("fpco-api:" <> agent)) - ,("authorization",encodeUtf8 ("token " <> token))] - , responseTimeout = Nothing - , cookieJar = jar - } - trunc :: Text -> Text - trunc = ellipsize 140 - errprefix = "Error from request: " <> T.pack (show (cmd Returns)) <> "\n" diff --git a/src/library/FP/API/Runner.hs b/src/library/FP/API/Runner.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/API/Runner.hs @@ -0,0 +1,1453 @@ +{-# LANGUAGE CPP #-} +#ifdef FAY +{-# LANGUAGE NoImplicitPrelude #-} +#endif +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module FP.API.Runner where + +#ifdef FAY + +import Data.Data +import Data.Text +import FFI +import Prelude + +#else + +import Control.Applicative +import Control.DeepSeq (NFData(..)) +import Control.DeepSeq.Generics (genericRnf) +import Control.Exception.Lifted +import Control.Monad +import Data.Aeson +import Data.ByteString hiding (map) +import qualified Data.ByteString.Base64 as B64 +import Data.Data +import Data.Default +import Data.Hashable +import qualified Data.Map as M +import Data.Ratio +import Data.Semigroup +import Data.Serialize +import Data.Text (Text) +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Text.Encoding.Error (lenientDecode) +import Data.Time +import Database.Persist.Sql (PersistField, PersistFieldSql, sqlType) +import Database.Persist.TH (derivePersistField) +import FFI +import GHC.Generics (Generic) +import Prelude +import System.Random (Random) +import Text.Blaze.Html (ToMarkup) +import Text.Shakespeare.I18N (ToMessage) +import Yesod.Core.Dispatch (PathPiece) + +data RunnerException = RunnerException Text + deriving (Eq, Typeable) + +instance Show RunnerException where +#ifndef FAY + show (RunnerException err) = T.unpack err +#endif + +instance Exception RunnerException + +fromString :: String -> Text +fromString = T.pack + +toString :: Text -> String +toString = T.unpack + +decodeBytes :: ByteString -> Text +decodeBytes = T.decodeUtf8With lenientDecode + +encodeBytes :: Text -> ByteString +encodeBytes = T.encodeUtf8 + +#endif + +data Filters = Filters + { filtersRoot :: Text + , filtersBlacklist :: [Text] + } +#ifndef FAY + deriving (Eq,Read,Show,Typeable,Data,Ord,Generic) +#else + deriving (Eq,Read,Show,Typeable,Data) +#endif + +#ifndef FAY +instance ToJSON Filters +instance FromJSON Filters +instance Serialize Filters +instance Hashable Filters +#endif + +#ifndef FAY + +-- | The standard ByteString instances in aeson are broken: they assume UTF8 +-- encoding. This type instead uses base64 for proper round-tripping. +newtype ByteString64 = ByteString64 { unByteString64 :: ByteString } + deriving (Eq, Read, Show, Data, Typeable, Ord, + Serialize, Generic, Hashable) +instance ToJSON ByteString64 where + toJSON (ByteString64 bs) = toJSON (T.decodeUtf8 $ B64.encode bs) +instance FromJSON ByteString64 where + parseJSON o = + parseJSON o >>= either fail (return . ByteString64) . B64.decode . T.encodeUtf8 + +newtype WrappedUTCTime = WrappedUTCTime { unWrappedUTCTime :: UTCTime } + deriving (Eq, Read, Show, Data, Typeable, Ord, + Serialize, Generic, Hashable) + +toPicoSeconds :: UTCTime -> Integer +toPicoSeconds t = numerator x + where + x = toRational day * 86400 * pico + psecs * pico + day = toModifiedJulianDay (utctDay t) + psecs = toRational (utctDayTime t) + pico = 10^(12 :: Integer) + +fromPicoSeconds :: Integer -> UTCTime +fromPicoSeconds x = UTCTime (ModifiedJulianDay dayPart) (fromRational psecs) + where + dayPart = x `div` day + day = 86400 * pico + psecs = (x - dayPart * day) % pico + pico = 10^(12 :: Integer) + +instance Serialize UTCTime where + put = put . toPicoSeconds + get = fmap fromPicoSeconds get + +instance Hashable UTCTime where + hash t = hash (toPicoSeconds t) + hashWithSalt x t = hashWithSalt x (toPicoSeconds t) + +instance ToJSON WrappedUTCTime where + toJSON (WrappedUTCTime t) = toJSON (toPicoSeconds t) +instance FromJSON WrappedUTCTime where + parseJSON o = WrappedUTCTime . fromPicoSeconds <$> parseJSON o + +#endif + +newtype ProjectId = ProjectId { unProjectId :: Int } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Num, Enum, Bounded, Real, Integral, Ord, + PathPiece, ToJSON, FromJSON, + Serialize, Generic, Hashable +#endif + ) + +unProjectIdString :: ProjectId -> String +unProjectIdString = show . unProjectId + +unProjectIdText :: ProjectId -> Text +unProjectIdText = fromString . unProjectIdString + +newtype RunConfigId = RunConfigId { unRunConfigId :: Int } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Num, Enum, Bounded, Real, Integral, Ord, + PathPiece, ToJSON, FromJSON, + Serialize, Generic, Hashable, NFData +#endif + ) + +newtype JobId = JobId { unJobId :: Int } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Num, Enum, Bounded, Real, Integral, Ord, + PathPiece, ToJSON, FromJSON, + Serialize, Generic, Hashable, NFData +#endif + ) + +newtype CompileId = CompileId { unCompileId :: Int } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Num, Enum, Bounded, Real, Integral, Ord, + PathPiece, ToJSON, FromJSON, + Serialize, Generic, Hashable, NFData +#endif + ) + +newtype ProcId = ProcId { unProcId :: Int } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Num, Enum, Bounded, Real, Integral, Ord, + PathPiece, ToJSON, FromJSON, + Serialize, Generic, Hashable, NFData +#endif + ) + +newtype GitShellId = GitShellId { unGitShellId :: Int } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Num, Enum, Bounded, Real, Integral, Ord, + PathPiece, ToJSON, FromJSON, + Serialize, Generic, Hashable, NFData +#endif + ) + +#ifndef FAY +instance Serialize Text where + put = put . T.encodeUtf8 + get = fmap T.decodeUtf8 get +#endif + +newtype FormattedTime = FormattedTime { unFormattedTime :: Text } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, PathPiece, ToJSON, FromJSON, + Serialize, Generic, Hashable, NFData +#endif + ) + +newtype ModuleName = ModuleName { unModuleName :: Text } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, PathPiece, ToJSON, FromJSON, + Serialize, Generic, Hashable, NFData +#endif + ) + +moduleNameString :: ModuleName -> String +moduleNameString = toString . unModuleName + +data ModuleStatus + = WrongExtension + | NotTextual + | CFile + | BootFile ModuleName + | HeaderFilenameMismatch ModuleName + | ModuleOk ModuleName + -- ^ This can also be valid for data files, if the user has manually + -- excluded them. + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) +#ifndef FAY +instance ToJSON ModuleStatus +instance FromJSON ModuleStatus +instance Serialize ModuleStatus +instance Hashable ModuleStatus +#endif + +#ifndef FAY +newtype FileName + = FileName { unFileName :: ByteString } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic, Serialize, Hashable +#endif + ) + +instance ToJSON FileName where + toJSON (FileName bs) = toJSON (T.decodeUtf8 $ B64.encode bs) +instance FromJSON FileName where + parseJSON o = + parseJSON o >>= either fail (return . FileName) . B64.decode . T.encodeUtf8 + +unFileNameText :: FileName -> Text +unFileNameText = decodeBytes . unFileName + +unFileNameString :: FileName -> String +unFileNameString = toString . unFileNameText + +fileNameFromText :: Text -> FileName +fileNameFromText = FileName . encodeBytes + +fileNameFromString :: String -> FileName +fileNameFromString = FileName . encodeBytes . fromString +#endif + +data EncFileName + = EncFileNameText { unEncFileNameText :: Text } + | EncFileNameBase64 { unEncFileNameText :: Text, encFileNameBase64 :: Text } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON EncFileName +instance FromJSON EncFileName +instance Serialize EncFileName +instance Hashable EncFileName +instance NFData EncFileName where rnf = genericRnf + +encodeBase64FileName :: FileName -> Text +encodeBase64FileName (FileName bs) = T.decodeUtf8 $ B64.encode bs + +decodeBase64FileName :: Text -> FileName +decodeBase64FileName = FileName . B64.decodeLenient . T.encodeUtf8 + +encFileName :: FileName -> EncFileName +encFileName = encFileNameFromByteString . unFileName + +unEncFileName :: EncFileName -> FileName +unEncFileName (EncFileNameBase64 _ bs64) = decodeBase64FileName bs64 +unEncFileName (EncFileNameText txt) = FileName (T.encodeUtf8 txt) + +encFileNameFromByteString :: ByteString -> EncFileName +encFileNameFromByteString bs = + case T.decodeUtf8' bs of + Left _ -> EncFileNameBase64 (decodeBytes bs) (decodeBytes (B64.encode bs)) + Right txt -> EncFileNameText txt +#endif + +encFileNameFromText :: Text -> EncFileName +encFileNameFromText = EncFileNameText + +encFileNameFromString :: String -> EncFileName +encFileNameFromString = encFileNameFromText . fromString + +unEncFileNameString :: EncFileName -> String +unEncFileNameString = toString . unEncFileNameText + +data FileType = SourceFile | DataFile + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Enum, Bounded, Ord, Generic +#endif + ) +#ifndef FAY +instance ToJSON FileType +instance FromJSON FileType +instance Serialize FileType +instance Hashable FileType +#endif + +data FileDesc = FileDesc + { fdEncFileName :: EncFileName + , fdModuleStatus :: ModuleStatus + , fdUserExcluded :: Bool + , fdFileType :: FileType + } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON FileDesc +instance FromJSON FileDesc +instance Serialize FileDesc +instance Hashable FileDesc +#endif + +-- | When a file in the project representation is changed by a 'ProjectUpdate' +-- request, it often results in a change reflected in what we know about the +-- file. This change is reported in the 'UpdateActions' structure using +-- this 'FileUpdate' type. +data FileUpdate = FileUpdated FileDesc | FileRemoved Bool + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) +#ifndef FAY +instance ToJSON FileUpdate +instance FromJSON FileUpdate +instance Serialize FileUpdate +instance Hashable FileUpdate +#endif + +-- | A project's target is a single module containing a function named 'main'. +-- This type reflects if any change in the current target has been made. +data TargetUpdate = TargetSet EncFileName | TargetCleared + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) +#ifndef FAY +instance ToJSON TargetUpdate +instance FromJSON TargetUpdate +instance Serialize TargetUpdate +instance Hashable TargetUpdate +#endif + +-- | After a 'ProjectUpdate' request is processed, a set of 'UpdateActions' +-- will result to reflect what changes have been made to the project +-- representation (and subsequently, what changes may need to be reflected +-- in the ide-backend, the database, and other caches). +data UpdateActions = UpdateActions + { _uaUpdates :: [(EncFileName, FileUpdate)] + , _uaNewTarget :: Maybe TargetUpdate + } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON UpdateActions where + toJSON (UpdateActions upds newt) = + object [ "_uaUpdates" .= toJSON upds + , "_uaNewTarget" .= toJSON newt + ] +instance FromJSON UpdateActions where + parseJSON (Object v) = UpdateActions + <$> v .: "_uaUpdates" + <*> v .: "_uaNewTarget" + parseJSON _ = error "Failed to read UpdateActions from JSON" + +instance Serialize UpdateActions + +instance Hashable UpdateActions where + hash (UpdateActions upds newt) = hash upds `hashWithSalt` newt + hashWithSalt x (UpdateActions upds newt) = + hashWithSalt x upds `hashWithSalt` newt + +instance Semigroup UpdateActions where + UpdateActions bus1 fus1 <> UpdateActions bus2 fus2 = + UpdateActions (M.toList (M.fromList bus2 <> M.fromList bus1)) + (fus2 `mplus` fus1) + +instance Monoid UpdateActions where + mempty = UpdateActions mempty Nothing + mappend = (<>) +#endif + +-- | Describe a compilation which has been accepted by the isolation-runner. +-- This includes sufficient information to tell what is "in" the +-- compilation, and to distinguish it from any other compilation. +data CompileDesc = CompileDesc + { cdCompileIdent :: CompileIdent + , cdUpdateActions :: UpdateActions + , cdFilters :: Maybe Filters + } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Generic +#endif + ) + +#ifndef FAY +instance ToJSON CompileDesc +instance FromJSON CompileDesc +instance Serialize CompileDesc +instance Hashable CompileDesc + +instance Semigroup CompileDesc where + CompileDesc _ upds1 root1 <> CompileDesc cid2 upds2 root2 = + CompileDesc cid2 (upds1 <> upds2) (root1 <|> root2) +#endif + +-- | Identifies a compilation, by combining a 'SessionId' with a 'CompileId'. +data CompileIdent = CompileIdent + { ciSession :: SessionId + , ciCompile :: CompileId + } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Generic +#endif + ) + +#ifndef FAY +instance ToJSON CompileIdent +instance FromJSON CompileIdent +instance Serialize CompileIdent +instance Hashable CompileIdent +instance NFData CompileIdent where rnf = genericRnf +#endif + +-- | Backend session ID. +newtype SessionId = SessionId Text + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Generic, NFData +#endif + ) + +#ifndef FAY +instance ToJSON SessionId +instance FromJSON SessionId +instance Serialize SessionId +instance Hashable SessionId +#endif + +newtype MailboxId = MailboxId Text + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Generic, NFData +#endif + ) + +#ifndef FAY +instance ToJSON MailboxId +instance FromJSON MailboxId +instance Serialize MailboxId +instance Hashable MailboxId +#endif + +-------------------------------------------------------------------------------- +-- Files / Modules + +data NewFileInfo = NewFileInfo + { fiPath :: Text + , fiModule :: Maybe ModuleName + } + deriving (Read, Typeable, Data, Show, Eq) + +data RenameType = RenamePlain + | RenameHeader + | RenameHeaderAndImports + | RenameHeaderAndImportsForce + deriving (Read, Typeable, Data, Show, Eq) + +data RenameFileOutput + = RenameFileOutput (Maybe FayTutorialToken) (Maybe Text) (Maybe CompileDesc) + | WarnImportRenaming [EncFileName] + deriving (Read, Typeable, Data, Show, Eq) + +data SaveFileOutput = SaveFileOutput FayTutorialToken (Maybe CompileDesc) + deriving (Read, Typeable, Data, Show, Eq) + +data FayFileContent = FayFileContent + { 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, Num, Ord, Generic, + ToJSON, FromJSON, Serialize, Hashable, + PersistField, Random) + +instance Default TutorialConcurrentToken where + def = TutorialConcurrentToken' 1 + +instance PersistFieldSql TutorialConcurrentToken where + sqlType = sqlType . liftM unTutorialConcurrentToken + +incrToken :: TutorialConcurrentToken -> TutorialConcurrentToken +incrToken (TutorialConcurrentToken' x) = TutorialConcurrentToken' (x + 1) +#endif + +-------------------------------------------------------------------------------- +-- Isolation-runner ids + +data TypeInfo = TypeInfo SourceSpan Text [Text] + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON TypeInfo +instance FromJSON TypeInfo +instance Serialize TypeInfo +instance Hashable TypeInfo +instance NFData TypeInfo where rnf = genericRnf +#endif + +-- Copied from ide-backend/Common.hs +-- + Different deriving list +-- + 'Show' instances made into functions + +data SourceSpan = SourceSpan + { spanFilePath :: EncFileName + , spanFromLine :: Int + , spanFromColumn :: Int + , spanToLine :: Int + , spanToColumn :: Int } + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON SourceSpan +instance FromJSON SourceSpan +instance Serialize SourceSpan +instance Hashable SourceSpan +instance NFData SourceSpan where rnf = genericRnf +#endif + +data EitherSpan = + ProperSpan SourceSpan + | TextSpan Text + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON EitherSpan +instance FromJSON EitherSpan +instance Serialize EitherSpan +instance Hashable EitherSpan +instance NFData EitherSpan where rnf = genericRnf +#endif + +-------------------------------------------------------------------------------- +-- Isolation-runner messages + +-- | The timing separation between 'JobStillRunning' messages. Note +-- that the actual interval will always be larger than this due to +-- network overhead, etc. +jobStillRunningTimeoutSeconds :: Int +jobStillRunningTimeoutSeconds = 50 + +data ProjectMessagesOutput = ProjectMessagesOutput + { pmoStatusSnap :: Maybe ProjectStatusSnapshot + -- ^ Note: The usage of @Maybe@ here is purely a bandwidth optimization. + -- Semantically, it is more correct to simply include the snapshot each + -- time. To avoid passing back the same information, however, the + -- snapshot is only transferred when the current hash does not match the + -- hash provided in the request. + , pmoStatusHash :: StatusHash + -- ^ The current hash at the time messages were returned. + , pmoLastMessage :: Integer + -- ^ The highest message ID we've yet seen, used as next argument in + -- @ProjectMessagesInput@ to avoid looking at the same messages again. + , pmoMessages :: [RunnerMessage] + , pmoMailboxId :: MailboxId + } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Generic +#endif + ) + +#ifndef FAY +instance ToJSON ProjectMessagesOutput +instance FromJSON ProjectMessagesOutput +instance Serialize ProjectMessagesOutput +instance Hashable ProjectMessagesOutput +instance NFData ProjectMessagesOutput where rnf = genericRnf +#endif + +newtype StatusHash = StatusHash { unStatusHash :: Text } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, PathPiece, ToJSON, FromJSON, + Serialize, Generic, Hashable, NFData +#endif + ) + +data CompileResult + = CRCanceled + | CRSuccess + | CRFailure + | CRException Text + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON CompileResult +instance FromJSON CompileResult +instance Serialize CompileResult +instance Hashable CompileResult +instance NFData CompileResult where rnf = genericRnf +#endif + +data ProcessResult + = PRExitSuccess + | PRUserException Text + | PRRunningFailed Text + | PRGHCException Text + | PRForceCanceled + | PRBackendError Text + | PRCouldNotLoadModule Text + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +displayProcessResult :: ProcessResult -> Text +displayProcessResult PRExitSuccess = fromString "" +displayProcessResult (PRRunningFailed e) = fromString "Code run failed: " <> e +displayProcessResult (PRUserException e) = fromString "The code threw an exception : " <> e +displayProcessResult (PRGHCException e) = fromString "GHC threw an exception : " <> e +displayProcessResult PRForceCanceled = fromString "The session was restarted" +displayProcessResult (PRBackendError e) = fromString "Process runner caught an exception: " <> e +displayProcessResult (PRCouldNotLoadModule e) = fromString "Could not load module: " <> e + +#ifndef FAY +instance ToJSON ProcessResult +instance FromJSON ProcessResult +instance Serialize ProcessResult +instance Hashable ProcessResult +instance NFData ProcessResult where rnf = genericRnf +#endif + +data GitShellOutput + = GSOutput Text + | GSSuccess + | GSFailure Int + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Generic +#endif + ) + +#ifndef FAY +instance ToJSON GitShellOutput +instance FromJSON GitShellOutput +instance Serialize GitShellOutput +instance Hashable GitShellOutput +instance NFData GitShellOutput where rnf = genericRnf +#endif + +data RunnerMessage + = ProjectMessage LogLevel Text + | ProcessOutput ProcId Text + | ProcessStopped ProcId ProcessResult + + | GitShellOutput GitShellId GitShellOutput + + | CompileComplete CompileId CompileResult + + | ProjectHasOpened SessionId + | ProjectHasClosed SessionId Bool Text + -- ^ If the Bool is True, it indicates that the client should resume + -- polling for project messages from a newly created project. If False, + -- there is some more severe problem initiating the project, and the client + -- should let the user know that the project may require manual recovery. + + | IdeCommandOutput JobId Text + -- ^ FIXME At some point in the future, it would be nice to replace the + -- second Text with a Value, to make it clear that we're encoding arbitrary + -- JSON values. This is semantically more correct, and more efficient, but + -- requires changes to the Fay encode/decode code, and therefore is not + -- trivial to implement. + | JobException JobId Text + | JobStillRunning JobId + -- ^ Indicates to the client that a job is still being actively worked on. + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Generic +#endif + ) + +#ifndef FAY +instance ToJSON RunnerMessage +instance FromJSON RunnerMessage +instance Serialize RunnerMessage +instance Hashable RunnerMessage +instance NFData RunnerMessage where rnf = genericRnf +#endif + +data LogLevel + = LevelDebug + | LevelInfo + | LevelWarn + | LevelError + | LevelOther Text + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON LogLevel +instance FromJSON LogLevel +instance Serialize LogLevel +instance Hashable LogLevel +instance NFData LogLevel where rnf = genericRnf +#endif + +data SdistTarballInfo = SdistTarballInfo + { stiPackageName :: !Text + , stiVersion :: !Text + } + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON SdistTarballInfo +instance FromJSON SdistTarballInfo +instance Serialize SdistTarballInfo +instance Hashable SdistTarballInfo +instance NFData SdistTarballInfo where rnf = genericRnf +#endif + +data GitHistoryItem = GitHistoryItem + { ghiDate :: Text + , ghiAuthor :: Text + , ghiLog :: Text + , ghiHash :: CommitSHA + } + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Ord, Generic +#endif + ) +#ifndef FAY +instance ToJSON GitHistoryItem +instance FromJSON GitHistoryItem +instance Serialize GitHistoryItem +instance Hashable GitHistoryItem +instance NFData GitHistoryItem where rnf = genericRnf +#endif + +data GitRepositoryStatus + = GitRepositoryPending + | GitRepositoryReady + | GitRepositoryInvalid Text + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON GitRepositoryStatus +instance FromJSON GitRepositoryStatus +instance Serialize GitRepositoryStatus +instance Hashable GitRepositoryStatus +instance NFData GitRepositoryStatus where rnf = genericRnf +#endif + +data ProjectStatusSnapshot = ProjectStatusSnapshot + { snapOpeningStatus :: RunnerOpeningStatus + , snapCompileStatus :: RunnerCompileStatus + , snapProcessStatus :: ProcessStatusSnapshot + , snapBuildStatus :: RunnerBuildStatus + , snapGitStatus :: GitRepositoryStatus + , snapGitCommand :: Maybe Text + , snapPictureStatus :: RunnerPictureStatus + , snapAnyLocalChanges :: Bool + } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Generic +#endif + ) + +#ifndef FAY +instance ToJSON ProjectStatusSnapshot +instance FromJSON ProjectStatusSnapshot +instance Serialize ProjectStatusSnapshot +instance Hashable ProjectStatusSnapshot +instance NFData ProjectStatusSnapshot where rnf = genericRnf +#endif + +data IdInfo + = NoIdInfo + | IdInfo + { iiResultSpan :: SourceSpan + , iiSourceInfo :: DefinitionSource + } + -- ^ query span, result span, source info + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON IdInfo +instance FromJSON IdInfo +instance Serialize IdInfo +instance Hashable IdInfo +instance NFData IdInfo where rnf = genericRnf +#endif + +data DefinitionSource + = DefinitionLocal Text SourceSpan + | DefinitionTextSpan Text Text + | DefinitionImported Text ModuleId ModuleId EitherSpan EitherSpan + | DefinitionWiredIn Text + | DefinitionBinder Text + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +definitionIdName :: DefinitionSource -> Text +definitionIdName (DefinitionLocal name _) = name +definitionIdName (DefinitionTextSpan name _) = name +definitionIdName (DefinitionImported name _ _ _ _) = name +definitionIdName (DefinitionWiredIn name) = name +definitionIdName (DefinitionBinder name) = name + +#ifndef FAY +instance ToJSON DefinitionSource +instance FromJSON DefinitionSource +instance Serialize DefinitionSource +instance Hashable DefinitionSource +instance NFData DefinitionSource where rnf = genericRnf +#endif + +data ModuleId = ModuleId (Maybe EncFileName) ModuleName PackageId + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON ModuleId +instance FromJSON ModuleId +instance Serialize ModuleId +instance Hashable ModuleId +instance NFData ModuleId where rnf = genericRnf +#endif + +data AutoCompleteInput = AutoCompleteInput + { aciFileName :: EncFileName + , aciPrefix :: Text + } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON AutoCompleteInput +instance FromJSON AutoCompleteInput +instance Serialize AutoCompleteInput +instance Hashable AutoCompleteInput +instance NFData AutoCompleteInput where rnf = genericRnf +#endif + +data PackageId = PackageId + { packageName :: Text + , packageVersion :: Maybe Text + } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON PackageId +instance FromJSON PackageId +instance Serialize PackageId +instance Hashable PackageId +instance NFData PackageId where rnf = genericRnf +#endif + +data SearchResult = SearchResult SourceSpan [Either Text Text] + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON SearchResult +instance FromJSON SearchResult +instance Serialize SearchResult +instance Hashable SearchResult +instance NFData SearchResult where rnf = genericRnf +#endif + +data HoogleResult = HoogleResult + { hrURL :: String + , hrSources :: [(PackageLink, [ModuleLink])] + , hrTitle :: String -- ^ HTML + , hrBody :: String -- ^ plain text + } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON HoogleResult +instance FromJSON HoogleResult +instance Serialize HoogleResult +instance Hashable HoogleResult +instance NFData HoogleResult where rnf = genericRnf +#endif + +data PackageLink = PackageLink + { plName :: String + , plURL :: String + } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON PackageLink +instance FromJSON PackageLink +instance Serialize PackageLink +instance Hashable PackageLink +instance NFData PackageLink where rnf = genericRnf +#endif + +data ModuleLink = ModuleLink + { mlName :: String + , mlURL :: String + } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON ModuleLink +instance FromJSON ModuleLink +instance Serialize ModuleLink +instance Hashable ModuleLink +instance NFData ModuleLink where rnf = genericRnf +#endif + +data RunnerOpeningStatus + = RunnerProjectOpening Text + | RunnerProjectOpen + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance Serialize RunnerOpeningStatus +instance Hashable RunnerOpeningStatus +instance NFData RunnerOpeningStatus where rnf = genericRnf + +instance Monoid RunnerOpeningStatus where + mempty = RunnerProjectOpening "Project opening..." + mappend _ y = y + +instance ToJSON RunnerOpeningStatus +instance FromJSON RunnerOpeningStatus +#endif + +data RunnerCompileStatus + = RunnerNotCompiling + | RunnerCompiling CompileIdent Progress + | RunnerCompileDone CompileIdent [SourceInfo] + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Generic +#endif + ) + +#ifndef FAY +instance ToJSON RunnerCompileStatus +instance FromJSON RunnerCompileStatus +instance Serialize RunnerCompileStatus +instance Hashable RunnerCompileStatus +instance NFData RunnerCompileStatus where rnf = genericRnf + +instance Monoid RunnerCompileStatus where + mempty = RunnerNotCompiling + mappend _ y = y +#endif + +-- | 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 :: [(InfoChunkTag, Text)] + } + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON SourceInfo +instance FromJSON SourceInfo +instance Serialize SourceInfo +instance Hashable SourceInfo +instance NFData SourceInfo where rnf = genericRnf +#endif + +-- | Severity of a piece of info. +data SourceInfoKind = SIKError | SIKWarning | SIKMismatch | SIKHint + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON SourceInfoKind +instance FromJSON SourceInfoKind +instance Serialize SourceInfoKind +instance Hashable SourceInfoKind +instance NFData SourceInfoKind where rnf = genericRnf +#endif + +data InfoChunkTag + = ICTPlain + | ICTModule + | ICTCode -- ^ Note: Ideally we'd distinguish identifiers, types, exprs, etc + | ICTRefactor Text [(SourceSpan, Text)] + -- ^ The 'Text' is a description of the action (for use in hovertext), + -- and the list stores the replacements that should be performed. + | ICTCollapse + | ICTOriginal + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON InfoChunkTag +instance FromJSON InfoChunkTag +instance Serialize InfoChunkTag +instance Hashable InfoChunkTag +instance NFData InfoChunkTag where rnf = genericRnf +#endif + +data ProcessStatusSnapshot + = SnapshotNoProcess + | SnapshotProcessRunning ProcId (Maybe Text) -- ^ URL to visit project + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON ProcessStatusSnapshot +instance FromJSON ProcessStatusSnapshot +instance Serialize ProcessStatusSnapshot +instance Hashable ProcessStatusSnapshot +instance NFData ProcessStatusSnapshot where rnf = genericRnf +#endif + +-- | Status for the pictures directory. +data RunnerPictureStatus + = RunnerPictureStatus [PictureStatus] +#ifndef FAY + deriving (Eq, Read, Show, Data, Typeable, Generic, Ord) +#else + deriving (Show,Eq,Read,Data,Typeable) +#endif + +#ifndef FAY +instance ToJSON RunnerPictureStatus +instance FromJSON RunnerPictureStatus +instance Serialize RunnerPictureStatus +instance Hashable RunnerPictureStatus +instance NFData RunnerPictureStatus where rnf = genericRnf + +instance Monoid RunnerPictureStatus where + mempty = RunnerPictureStatus [] + mappend (RunnerPictureStatus x) (RunnerPictureStatus y) = RunnerPictureStatus (x <> y) +#endif + +-- | Status of a picture. +data PictureStatus = PictureStatus + { pictureName :: Text -- ^ The title to use in the IDE UI. + , pictureUrl :: Text -- ^ URL of the actual image. + , pictureHash :: Text -- ^ Hash of the file contents, whenever the + -- picture changes this is updated. + } +#ifndef FAY + deriving (Eq,Show,Generic,Typeable,Data,Ord,Read) +#else + deriving (Show,Eq,Read,Data,Typeable) +#endif + +#ifndef FAY +instance ToJSON PictureStatus +instance FromJSON PictureStatus +instance Serialize PictureStatus +instance Hashable PictureStatus +instance NFData PictureStatus where rnf = genericRnf +#endif + +data RunnerBuildStatus + = RunnerNotBuilding + | RunnerBuilding Progress + | RunnerUploading + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance Serialize RunnerBuildStatus +instance Hashable RunnerBuildStatus +instance NFData RunnerBuildStatus where rnf = genericRnf + +instance ToJSON RunnerBuildStatus +instance FromJSON RunnerBuildStatus + +instance Monoid RunnerBuildStatus where + mempty = RunnerNotBuilding + mappend _ y = y +#endif + +data UploadedBuild = UploadedBuild + { ubUrl :: Text + , ubExe :: Text + } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON UploadedBuild +instance FromJSON UploadedBuild +instance Serialize UploadedBuild +instance Hashable UploadedBuild +instance NFData UploadedBuild where rnf = genericRnf +#endif + +-- | 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 (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON Progress +instance FromJSON Progress +instance Serialize Progress +instance Hashable Progress +instance NFData Progress where rnf = genericRnf +#endif + +newtype Approot = Approot { unApproot :: Text } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, PathPiece, ToJSON, FromJSON, + Serialize, Generic, Hashable, NFData +#endif + ) + +newtype VirtualHost = VirtualHost { unVirtualHost :: Text } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, PathPiece, ToJSON, FromJSON, + Serialize, Generic, Hashable +#endif + ) + +#ifndef FAY +approotString :: Approot -> String +approotString (Approot txt) = toString txt +#endif + +data ApprootPid = ApprootPid Approot ProcId + deriving (Read, Typeable, Data, Show, Eq) + +newtype Port = Port { getPort :: Int } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Num, Enum, Bounded, Real, Integral, Ord, + PathPiece, ToJSON, FromJSON, + Serialize, Generic, Hashable, NFData +#endif + ) + +data ErrorsAnd x = ErrorsAnd [String] (Maybe (Automatic x)) + deriving (Read, Typeable, Data, Show, Eq) + +data ModuleIncluded + = ModuleExcluded + | ModuleWrongExtension + | ModuleNotTextual + | ModuleIsCFile + | ModuleIsBootFile ModuleName + | ModuleHeaderFilenameMismatch ModuleName + | ModuleNameAmbiguous ModuleName + | ModuleIncluded ModuleName + deriving (Read, Typeable, Data, Show, Eq) + +fileDescToModuleIncluded :: FileDesc -> ModuleIncluded +fileDescToModuleIncluded fd = + if fdUserExcluded fd + then ModuleExcluded + else case (fdModuleStatus fd, fdFileType fd) of + (WrongExtension, _ ) -> ModuleWrongExtension + (NotTextual, _ ) -> ModuleNotTextual + (CFile, _ ) -> ModuleIsCFile + (BootFile mn, _ ) -> ModuleIsBootFile mn + (HeaderFilenameMismatch mn, _ ) -> ModuleHeaderFilenameMismatch mn + (ModuleOk mn, DataFile ) -> ModuleNameAmbiguous mn + (ModuleOk mn, SourceFile) -> ModuleIncluded mn + +data MergeModifyKind = Modified | Added | Deleted | TypeChanged + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON MergeModifyKind +instance FromJSON MergeModifyKind +instance Serialize MergeModifyKind +instance Hashable MergeModifyKind +#endif + +data MergeModifyPair = MergeModifyPair MergeModifyKind MergeModifyKind + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance ToJSON MergeModifyPair +instance FromJSON MergeModifyPair +instance Serialize MergeModifyPair +instance Hashable MergeModifyPair +#endif + +-- | A Git blob SHA in textual form. +newtype BlobSHA = BlobSHA { unBlobSHA :: Text } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Serialize, Generic, Hashable + , ToJSON, FromJSON, PathPiece + , PersistField + , ToMarkup, ToMessage +#endif + ) +#ifndef FAY +instance PersistFieldSql BlobSHA where + sqlType = sqlType . liftM unBlobSHA +#endif + +-- | A Git commit SHA in textual form. +newtype CommitSHA = CommitSHA { unCommitSHA :: Text } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Serialize, Generic, Hashable, NFData + , ToJSON, FromJSON, PathPiece + , PersistField + , ToMarkup, ToMessage +#endif + ) +#ifndef FAY +instance PersistFieldSql CommitSHA where + sqlType = sqlType . liftM unCommitSHA +#endif + +-- | A Git branch name, such as "master", or "merge/master". +newtype BranchName = BranchName { unBranchName :: Text } + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Serialize, Generic, Hashable + , ToJSON, FromJSON, PathPiece +#endif + ) + +#ifndef FAY +branchToRef :: BranchName -> Text +branchToRef (BranchName name) = "refs/heads/" <> name + +branchFromRef :: Text -> BranchName +branchFromRef name = + BranchName (T.reverse . T.takeWhile (/='/') . T.reverse $ name) + +isMergeBranch :: BranchName -> Bool +isMergeBranch (BranchName name) = "merge/" `T.isPrefixOf` name + +mergeBranch :: BranchName -> BranchName +mergeBranch b@(BranchName name) + | isMergeBranch b = b + | otherwise = BranchName ("merge/" <> name) + +mergeBranchOrigin :: BranchName -> Maybe BranchName +mergeBranchOrigin name = + BranchName <$> T.stripPrefix "merge/" (unBranchName name) +#endif + +-- | A reference to a specific commit, which can be done by several different +-- means. +data CommitName = CommitByBranch BranchName + | CommitBySHA CommitSHA + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) + +#ifndef FAY +instance Serialize CommitName +instance Hashable CommitName +instance ToJSON CommitName +instance FromJSON CommitName +#endif + +-- These go at the end to avoid splitting up the module +#ifndef FAY +derivePersistField "MergeModifyKind" +derivePersistField "MergeModifyPair" +#endif diff --git a/src/library/FP/API/Signal.hs b/src/library/FP/API/Signal.hs new file mode 100644 --- /dev/null +++ b/src/library/FP/API/Signal.hs @@ -0,0 +1,51 @@ +-- | A very minimal library for broadcasting events to listeners. + +module FP.API.Signal where + +import Control.Applicative +import Control.Concurrent.MVar +import Control.Monad.IO.Class +import Data.Foldable +import Data.IORef +import qualified Data.IntMap as IM +import Prelude +import System.Timeout + +data Signal m a = Signal (IORef (IM.IntMap (a -> m ()))) + +newSignal :: IO (Signal m a) +newSignal = Signal <$> newIORef IM.empty + +sendSignal :: MonadIO m => Signal m a -> a -> m () +sendSignal (Signal ref) x = do + m <- liftIO $ readIORef ref + forM_ m $ \f -> f x + +subscribeSignal :: Signal m a -> (IO () -> a -> m ()) -> IO (IO ()) +subscribeSignal (Signal ref) f = + atomicModifyIORef ref $ \m -> + let m' = IM.insert key (f unsub) m + unsub = unsubscriber key + key = if IM.null m + then 0 + else 1 + fst (IM.findMax m) + in (m', unsub) + where + unsubscriber key = + atomicModifyIORef ref $ \m -> (IM.delete key m, ()) + +-- | Block, watching for a particular value (indicated by 'Just'). +-- Once a 'Just' value is seen, stop subscribing, and return the +-- value. The @Maybe Int@ argument specifies an optional timeout in +-- microseconds. If the function instead times out, then 'Nothing' is +-- yielded. +blockOnSignal :: MonadIO m => Maybe Int -> Signal m a -> (a -> m (Maybe b)) -> IO (Maybe b) +blockOnSignal mmicros sig f = do + resultVar <- newEmptyMVar + unsub <- subscribeSignal sig $ \_ x -> do + mres <- f x + liftIO $ forM_ mres $ putMVar resultVar + result <- maybe (fmap Just) timeout mmicros $ + takeMVar resultVar + unsub + return result diff --git a/src/library/FP/API/TH.hs b/src/library/FP/API/TH.hs deleted file mode 100644 --- a/src/library/FP/API/TH.hs +++ /dev/null @@ -1,41 +0,0 @@ -{-# 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 --- a/src/library/FP/API/Types.hs +++ b/src/library/FP/API/Types.hs @@ -1,783 +1,901 @@ -{-# 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 -import Data.Proxy - -#ifndef FAY -import Data.Default (Default(..)) -import Database.Persist.Sql (PersistField, PersistFieldSql, sqlType) -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, Random, Num) - -instance PersistFieldSql TutorialConcurrentToken where - sqlType _ = sqlType (Proxy :: Proxy Int) - -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) +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ViewPatterns #-} + +module FP.API.Types (module FP.API.Types, module FP.API.Runner) where + +import Data.Data +import Data.Text +import FFI +import FP.API.Runner +import Language.Fay.Yesod hiding (Text) +import Prelude + +#ifndef FAY +import Control.Applicative +import Control.Exception.Lifted +import Control.Monad +import Control.Monad.Base +import Control.Monad.Logger +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Control +import Control.Monad.Trans.Resource +import Data.Aeson hiding (Result(..)) +import Data.Foldable +import Data.Hashable +import Data.Serialize +import Data.Traversable +import Database.Persist.TH (derivePersistField) +import GHC.Generics (Generic) +#endif + +data ProjectState = Workspaces | UserState +#ifdef FAY + deriving (Read, Typeable, Data, Show, Eq) +#else + deriving (Show, Eq, Read, Data, Typeable, Enum, Bounded, Ord, Generic) + +instance ToJSON ProjectState +instance FromJSON ProjectState +instance Serialize ProjectState +instance Hashable ProjectState + +derivePersistField "ProjectState" +#endif + +type Returns' a = Returns (CanFail a) + +data CanFail a = Success (Automatic a) | Failure Text + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Foldable, Traversable, Generic +#endif + ) + +#ifndef FAY +instance ToJSON a => ToJSON (CanFail a) +instance FromJSON a => FromJSON (CanFail a) + +deriving instance Functor CanFail + +instance Monad CanFail where + return = Success + Failure e >>= _ = Failure e + Success m >>= f = f m + +newtype CanFailT m a = CanFailT { runCanFailT :: m (CanFail a) } + +type MonadFail m = MonadIO m + +failure :: MonadFail m => Text -> m a +failure = liftIO . throwIO . RunnerException + +mapCanFailT :: (m (CanFail a) -> n (CanFail b)) -> CanFailT m a -> CanFailT n b +mapCanFailT f = CanFailT . f . runCanFailT + +eitherFail :: MonadFail m => m (Either Text a) -> m a +eitherFail = (either failure return =<<) + +eitherToCanFail :: Show e => Either e a -> CanFail a +eitherToCanFail (Left e) = Failure (pack (show e)) +eitherToCanFail (Right a) = Success a + +-- | Try the given action, returning a Failure if it throw a RunnerException, +-- otherwise returning Success or propagation any exceptions. +tryOrFail :: (MonadBaseControl IO m, MonadFail m) => m a -> m (CanFail a) +tryOrFail f = do + eres <- try f + case eres of + Left (fromException -> Just (RunnerException e)) -> return $ Failure e + Left e -> liftIO $ throwIO e + Right x -> return $ Success x + +maybeFail :: MonadFail m => Text -> m (Maybe a) -> m a +maybeFail e act = do + mx <- act + case mx of + Nothing -> failure e + Just x -> return x + +instance Functor m => Functor (CanFailT m) where + fmap f = mapCanFailT (fmap (fmap f)) + +instance Foldable f => Foldable (CanFailT f) where + foldMap f (CanFailT a) = foldMap (foldMap f) a + +instance Traversable f => Traversable (CanFailT f) where + traverse f (CanFailT a) = CanFailT <$> traverse (traverse f) a + +instance (Functor m, Monad m) => Applicative (CanFailT m) where + pure = return + (<*>) = ap + +instance (Functor m, Monad m) => Alternative (CanFailT m) where + empty = mzero + (<|>) = mplus + +instance Monad m => Monad (CanFailT m) where + fail e = CanFailT (return (Failure (pack e))) + return = lift . return + x >>= f = CanFailT $ do + v <- runCanFailT x + case v of + Failure e -> return $ Failure e + Success y -> runCanFailT (f y) + +instance Monad m => MonadPlus (CanFailT m) where + mzero = CanFailT (return (Failure (pack "mzero"))) + mplus x y = CanFailT $ do + v <- runCanFailT x + case v of + Failure _ -> runCanFailT y + Success _ -> return v + +-- instance MonadFix m => MonadFix (CanFailT m) where +-- mfix f = CanFailT (mfix (runCanFailT . f . unSuccess)) +-- where unSuccess = fromCanFail (error "mfix CanFailT: Failure") + +instance MonadTrans CanFailT where + lift = CanFailT . liftM Success + +instance MonadIO m => MonadIO (CanFailT m) where + liftIO = lift . liftIO + +instance MonadBase IO m => MonadBase IO (CanFailT m) where + liftBase = lift . liftBase + +instance MonadThrow m => MonadThrow (CanFailT m) where + throwM = lift . throwM + +instance MonadBaseControl IO m => MonadBaseControl IO (CanFailT m) where + data StM (CanFailT m) a = + StCFR { unStCFR :: StM m (CanFail a) } + liftBaseWith f = CanFailT $ fmap Success $ + liftBaseWith $ \runInBase -> + f (\(CanFailT sT) -> liftM StCFR . runInBase $ sT) + restoreM = CanFailT . restoreM . unStCFR + +instance MonadResource m => MonadResource (CanFailT m) where + liftResourceT = lift . liftResourceT + +instance MonadLogger m => MonadLogger (CanFailT m) where + monadLoggerLog a b c d = lift $ monadLoggerLog a b c d +#endif + +data RunnerProjectClosed = RunnerProjectClosed (Maybe SessionId) + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize RunnerProjectClosed +instance ToJSON RunnerProjectClosed +instance FromJSON RunnerProjectClosed +#endif + +data GetProjectMessages + = GetProjectMessages ProjectMessagesRequest + (Returns' ProjectMessagesOutput) + deriving (Read, Typeable, Data, Show, Eq) + +data ProjectMessagesRequest + = PMRFirstRequest + | PMRLaterRequest Integer StatusHash MailboxId + -- ^ The message sequence number and status hash we last got back. + deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Generic +#endif + ) + +#ifndef FAY +instance ToJSON ProjectMessagesRequest +instance FromJSON ProjectMessagesRequest +instance Serialize ProjectMessagesRequest +instance Hashable ProjectMessagesRequest +#endif + +data IdeCommand + -- Project global + = GetInitialProjectInfo Text + (Returns' InitialProjectInfo) + | ReparseProjectSettings + (Returns' (Maybe RunnerProjectClosed)) + | SetSettings SetSettingsInput + (Returns' (Either CompileIdent RunnerProjectClosed)) + | SetPublic Bool + (Returns' ()) + | GetPublic + (Returns' Bool) + | SetProjectMetadata Text Text + (Returns' ()) + | SaveProjectState ProjectState Text + (Returns' ()) + | DeleteProject Text + (Returns' ()) + | ResetProjectSettings Text + (Returns' RunnerProjectClosed) + | SdistTarball + (Returns' (Either Text SdistTarballInfo)) + | RestartBackend Text + (Returns' RunnerProjectClosed) + | GenerateHaddocks + (Returns' Text) + | Ping + (Returns' ()) + + -- Files + | AddFile NewFileInfo + (Returns' SaveFileOutput) + | SaveFile EncFileName Text FayTutorialToken + (Returns' SaveFileOutput) + | DeleteFile EncFileName + (Returns' (Maybe CompileDesc)) + | RenameFile EncFileName NewFileInfo RenameType + (Returns' RenameFileOutput) + | GetFile EncFileName + (Returns' FayFileContent) + | GetFileToken EncFileName + (Returns' FayTutorialToken) + | GetAllFiles + (Returns' [FileDesc]) + | SetModuleExclusion EncFileName Bool + (Returns' (Maybe CompileDesc)) + | ReformatModule EncFileName + (Returns' (Maybe CompileDesc)) + | RenderFileMarkdown EncFileName + (Returns' HtmlReply) + + -- Info + | GetTypeInfo SourceSpan + (Returns' (Maybe TypeInfo)) + | GetTypeInfoDominators SourceSpan + (Returns' [TypeInfo]) + | GetFindUsages SourceSpan + (Returns' [SearchResult]) + | GetDefinitionSource SourceSpan + (Returns' IdInfo) + | GetAutocompletions AutoCompleteInput + (Returns' [Text]) + | IdeHoogleSearch (Maybe EncFileName) Bool Int Int Int Text + (Returns' (Text, [HoogleResult], Maybe Int)) + -- ^ module context, is it exact?, number to query, offset in result, + -- number to yield, query contents + | SearchProject SearchQuery Int Int Bool + (Returns' [SearchResult]) + -- ^ query, offset, limit, case sensitive? + + -- Compilation + | SetTarget (Maybe (Either EncFileName RunConfigId)) + (Returns' (Maybe CompileDesc)) + | GetTarget + (Returns' (Maybe (Either EncFileName RunConfigId))) + | RunTarget Bool + (Returns' ProcId) + -- ^ True == run compiled code, False == run bytecode + -- jww (2014-02-04): Make these use the current target. + | CompileBinary EncFileName [(Text, Text)] + (Returns' UploadedBuild) + -- ^ module to compile and extra files to include in tarball + + -- Git + | GetGitHistory Int Int + (Returns' [GitHistoryItem]) + | IsProjectDirty + (Returns' Bool) + | SetRoot Text Text + (Returns' CompileDesc) + | SetRemotes RemotesList + (Returns' ()) + + | GetGitConfig Text + (Returns' Text) + | SetGitConfig Text Text + (Returns' ()) + | GitCommit Text + (Returns' CommitSHA) -- ^ Text == Log message + | GitReset + (Returns' RunnerProjectClosed) + | GitPush Text + (Returns' GitPushResult) -- ^ Text == URL + | GitPushIgnoreDirty Text + (Returns' ()) -- ^ Text == URL + | GitPull Text + (Returns' GitPullResult) -- ^ Text == URL + | GitMergeAbort + (Returns' RunnerProjectClosed) -- ^ Text == URL + | GitMergeDone MaybeText + (Returns' GitResolvedResult) -- ^ Text == URL, Msg + | GitResolveFile EncFileName + (Returns' ()) + | GitDiff + (Returns' Text) + + -- Git Bash + | StartGitShell + (Returns' GitShellId) + | GitShellInput GitShellId Text + (Returns' ()) + | ApplyGitShell GitShellId + (Returns' RunnerProjectClosed) + | CancelGitShell GitShellId + (Returns' ()) + + | CreateBranch BranchName CommitName + (Returns' ()) + | DeleteBranch BranchName + (Returns' ()) + | CheckoutBranch BranchName + (Returns' GitCheckoutResult) + + -- Refactorings + | RenameRefactoring SourceSpan Text RefactoringContext + (Returns' RefactoringOutput) + | ExtractRefactoring SourceSpan Text RefactoringContext + (Returns' RefactoringOutput) + + -- Deployment + | GetKeterYaml FayDeploymentId ModuleName + (Returns' KeterYaml) + | SetRunConfigs [(RunConfigId, RunConfig)] + (Returns' ()) + | SetDeployments [(FayDeploymentId, Deployment)] + (Returns' ()) + | GetNewRunConfig + (Returns' NewRunConfig) + | GetNewDeployment + (Returns' NewDeployment) + | GetNewWebApp FayDeploymentId + (Returns' NewWebApp) + | GetNewBgJob FayDeploymentId + (Returns' NewBgJob) + + | CheckHostName Text + (Returns' UseHostName) + | GetRandomHostName + (Returns' RandomHostName) + | GetDeploymentManagerInfo + (Returns' DeploymentManagerInfo) + + -- Processes (shared by the IDE and School of Haskell) + | PutStdin ProcId Text + (Returns' Bool) -- ^ Bool == whether the stdin was successfully delivered + | StopRunningCode + (Returns' ()) + + -- School of Haskell commands (using project id 0) + | StartInteractive [FileToRun] + (Returns' (ErrorsAnd ProcId)) + -- ^ Text == GHC environment, Just result gives a failure + | StartInteractiveWeb [FileToRun] + (Returns' (ErrorsAnd ApprootPid)) + | HoogleSearch Bool Text Text + (Returns' FayHoogleResults) + -- ^ Bool == is it an exact search?, module source code for import + -- statement, query + | GetConflictingPackages + (Returns' [[(Bool,Text)]]) + deriving (Read, Typeable, Data, Show, Eq) + +data FayCommand + -- Github + = UserAuthedGithub + (Returns' Bool) + | RevokeGithub + (Returns' ()) + | GetGithubUrl Text + (Returns' Text) + | SshPublicKey + (Returns' Text) + + -- Configuration + | GenerateConfiguration + (Returns' ()) + + -- Soh + | GetIFilesFromCode Text Text (Maybe Text) + (Returns' IFiles) -- ^ title, code, environment + | GetIFilesFromURL Text + (Returns' IFiles) + + -- Misc + | SaveProfile Theme Int Bool + (Returns' ()) + | GetProjectId Text + (Returns' ProjectId) + | CloseAllProjects + (Returns' ()) + | SetSettingsSubstitutions Text + (Returns' ()) + | GetSettingsSubstitutions + (Returns' Text) + + -- Announcements + | SeenAnnouncement Text + (Returns' ()) + | GetAnnouncements + (Returns' [(Text,Text,Text)]) + + deriving (Read, Typeable, Data, Show) + +-- | 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] + , ipiState :: [(ProjectState, Text)] + , ipiFiles :: [FileDesc] + , ipiTarget :: Maybe (Either EncFileName RunConfigId) + , ipiPublished :: Bool + , ipiBranches :: BranchesList + , ipiRemotes :: RemotesList + , ipiRunConfigs :: [(RunConfigId, RunConfig)] + , ipiDeployments :: [(FayDeploymentId, Deployment)] + , ipiTheme :: Theme + , ipiFontSize :: Int + , ipiSearchWithRegex :: Bool + , ipiLicense :: IdeLicense + , ipiCanPublish :: Bool + , ipiSettings :: Maybe ProjectSettings + } + deriving (Read, Typeable, Data, Show, Eq) + +data IFiles = IFiles + { ifilesFiles :: [IFile] + , ifilesCloneUrl :: Text + } + deriving (Read, Typeable, Data, Show, Eq) + +data IFile = IFile + { ifileName :: Text + , ifileContent :: IFileContents + } + deriving (Read, Typeable, Data, Show, Eq) + +data Base64 = Base64 Text + deriving (Read, Typeable, Data, Show, Eq) + +data IFileContents = IFCText [IFileContent] | IFCBase64 Base64 + deriving (Read, Typeable, Data, Show, Eq) + +data IFileContent = IFCStatic Text + | IFCEditable Editable + deriving (Read, Typeable, Data, Show, Eq) + + +data Editable = Editable + { editableTitle :: Maybe Text + , editableContent :: Text + , editableMarks :: [SrcSpan] + } + deriving (Read, Typeable, Data, Show, Eq) + +data SrcSpan = SrcSpan SrcLoc SrcLoc + deriving (Read, Typeable, Data, Show, Eq) + +data SrcLoc = SrcLoc + { srcLocLine :: Int + , srcLocColumn :: Int + } + deriving (Read, Typeable, Data, Show, Eq) + +data StdoutResult = SRSuccess Text + | SRTerminated ProcessResult + deriving (Read, Typeable, Data, Show, Eq) + +data FileToRun = FileToRun + { ftrName :: Text + , ftrContent :: FTRContent + } + deriving (Read, Typeable, Data, Show, Eq) + +data FTRContent = FTRCText Text | FTRCBinary Base64 + deriving (Read, Typeable, Data, Show, Eq) + +data FayHoogleResults = FayHoogleBadQuery Text + | FayHoogleResults Text [HoogleResult] (Maybe Int) -- ^ Text == HTML version of query, Int == total count + deriving (Read, Typeable, Data, Show, Eq) + +data IdeLicense = ILCommunity | ILPersonal | ILProfessional + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize IdeLicense +instance ToJSON IdeLicense +instance FromJSON IdeLicense +#endif + +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 RunnerProjectClosed) + deriving (Read, Typeable, Data, Show, Eq) + +data GitPullResult = GPRSuccess RunnerProjectClosed + | GPRDirtyTree + | GPRManualMerge Text RunnerProjectClosed + deriving (Read, Typeable, Data, Show, Eq) + +data GitPushResult = GURSuccess | GURDirtyTree + deriving (Read, Typeable, Data, Show, Eq) + +data GitResolvedResult = GRRSuccess + | GRRStillUnresolved [MergeConflict] + deriving (Read, Typeable, Data, Show, Eq) + +data MergeConflict = MergeConflict + { mergeFile :: EncFileName + , mergeState :: MergeModifyPair + } + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize MergeConflict +instance ToJSON MergeConflict +instance FromJSON MergeConflict +#endif + +data RemotesList = RemotesList [(Text, Text)] + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize RemotesList +instance ToJSON RemotesList +instance FromJSON RemotesList +#endif + +data BranchesList = BranchesList BranchName [BranchName] + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize BranchesList +instance ToJSON BranchesList +instance FromJSON BranchesList +#endif + +data ProjectSettings = ProjectSettings + { psModuleTemplate :: Text + , psExtensions :: [(Text, Maybe Bool)] -- ^ three states: on, off, or default (== Nothing) + , psEnvironment :: Environment + , psEnvironments :: [Environment] + , psGhcArgs :: [Text] + , psBinaryGhcArgs :: [Text] + , psExtraPackages :: Text + , psAutoHidden :: [[(Bool,Text)]] + , psCabalName :: Text + , psCabalVersion :: Text + , psRoot :: Text + , psFilters :: Text + } + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize ProjectSettings +instance ToJSON ProjectSettings +instance FromJSON ProjectSettings +#endif + +data SetExtension = SetExtension Text Bool + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize SetExtension +instance ToJSON SetExtension +instance FromJSON SetExtension +#endif + +data SetSettingsInput = SetSettingsInput + { ssiModuleTemplate :: Text + , ssiExtensions :: [SetExtension] + , ssiEnvironment :: Text + , ssiGhcArgs :: [Text] + , ssiBinaryGhcArgs :: [Text] + , ssiExtraPackages :: Text + , ssiAutohidden :: [[(Bool,Text)]] + , ssiCabalName :: Text + , ssiCabalVersion :: Text + } + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize SetSettingsInput +instance ToJSON SetSettingsInput +instance FromJSON SetSettingsInput +#endif + +-- | A GHC environment. +data Environment = Environment + { envName :: Text + , envTitle :: Text + , envURL :: Text + , envDetailedId :: Text + } + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize Environment +instance ToJSON Environment +instance FromJSON Environment +#endif + +data RunGhciOutput = RunGhciOutput ProcId ProjectId + 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) + +data RefactoringContext + = PortionContext SourceSpan Text + | ModuleContext ModuleName + deriving (Read, Typeable, Data, Show, Eq) + +data RefactoringOutput + = PortionOutput Text + | ModuleOutput Text + 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) + +-- | A run configuration for a project. +data RunConfig = RunConfig + { rcTitle :: Text + , rcMainFile :: Maybe EncFileName + , rcArgs :: [Text] + , rcEnv :: [(Text, Text)] + } deriving (Eq, Read, Show, Data, Typeable +#ifndef FAY + , Ord, Generic +#endif + ) +#ifndef FAY +instance ToJSON RunConfig +instance FromJSON RunConfig +instance Serialize RunConfig +instance Hashable RunConfig +#endif + +-- | Make a new run configuration. +data NewRunConfig = NewRunConfig (RunConfigId, RunConfig) + deriving (Read, Typeable, Data, Show, Eq) + +-- | A deployment configuration. +data Deployment = Deployment + { depTitle :: Text + , depStanzas :: [Stanza] + } deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize Deployment +instance ToJSON Deployment +instance FromJSON Deployment +#endif + +-- | Possible stanza types. +data Stanza = WebAppStanza FayWebAppId WebApp + | BgJobStanza FayBgJobId BgJob + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize Stanza +instance ToJSON Stanza +instance FromJSON Stanza +#endif + +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 EncFileName + , wapArgs :: [Text] + , wapEnv :: [(Text, Text)] + , wapSsl :: Bool + } deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize WebApp +instance ToJSON WebApp +instance FromJSON WebApp +#endif + +data NewWebApp = NewWebApp (FayWebAppId, WebApp) + deriving (Read, Typeable, Data, Show, Eq) + +-- | A background job stanza. +data BgJob = BgJob + { bgTitle :: Text + , bgFileName :: Maybe EncFileName + , bgArgs :: [Text] + , bgEnv :: [(Text, Text)] + , bgRestartLimit :: Maybe Int + , bgRestartDelay :: Int + } deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize BgJob +instance ToJSON BgJob +instance FromJSON BgJob +#endif + +-- | 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 +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize UseHostName +instance ToJSON UseHostName +instance FromJSON UseHostName +#endif + +-- | Yaml text for a Keter config. +data KeterYaml = KeterYaml + { keterYaml :: Text + , deployYaml :: Text + } + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize KeterYaml +instance ToJSON KeterYaml +instance FromJSON KeterYaml +#endif + +-- | A randomly generated host name. +data RandomHostName = RandomHostName { unRandomHostname :: Text } + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize RandomHostName +instance ToJSON RandomHostName +instance FromJSON RandomHostName +#endif + +-- | 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 +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize DeploymentManagerInfo +instance ToJSON DeploymentManagerInfo +instance FromJSON DeploymentManagerInfo +#endif + +data FayDeploymentId = FayDeploymentId { unFayDeploymentId :: Text } + deriving (Read, Typeable, Data, Show, Eq) + +data FayBgJobId = FayBgJobId { unFayBgJobId :: Text } + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize FayBgJobId +instance ToJSON FayBgJobId +instance FromJSON FayBgJobId +#endif + +data FayWebAppId = FayWebAppId { unFayWebAppId :: Text } + deriving (Read, Typeable, Data, Show, Eq +#ifndef FAY + , Generic +#endif + ) +#ifndef FAY +instance Serialize FayWebAppId +instance ToJSON FayWebAppId +instance FromJSON FayWebAppId +#endif + +-------------------------------------------------------------------------------- +-- 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) 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 @@ -1,499 +1,378 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS -fno-warn-orphans #-} -- | Main entry point to the server. -module FP.Server where +module FP.Server + ( runWithConfig + , startServer + , convertMsg + ) where import FP.API -import FP.API.Run -import FP.API.Types +import FP.API.Common +import FP.API.Signal import FP.Server.Spans import FP.Server.Types -import Control.Applicative +import Control.Concurrent.Async.Lifted (race, concurrently) import Control.Concurrent.Lifted -import Control.Exception.Lifted as E hiding (handle) +import Control.Concurrent.STM +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 Control.Monad.Reader hiding (forM_) +import Control.Monad.Trans.Resource +import Data.Aeson (FromJSON, ToJSON, decode, encode) +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as L8 +import Data.Data +import Data.Foldable (forM_) import Data.IORef -import qualified Data.Map as M -import Data.Map (Map) +import qualified Data.Map as M 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 qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8, encodeUtf8, decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.IO as T +import Fay.Convert +import Language.Fay.Yesod (Returns(..)) import Network import Network.HTTP.Conduit -import Prelude hiding (span) +import Network.HTTP.Types.Status +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 :: ServerM () b -> Config -> IO b runWithConfig m config = do manager <- newManager conduitManagerSettings - pollers <- newMVar mempty + projects <- newTVarIO 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) - + (if configDebug config then runStderrLoggingT else runSilentLoggingT) $ + runReaderT m + (ServerState (CC (stripSlash (configUrl config)) + (configToken config) + manager + jar + (configAgent config)) + config + projects + , ()) where runSilentLoggingT m' = runLoggingT m' (\_loc _src _lvl _str -> return ()) -- | Start the server. -startServer :: Bool -> Server () +startServer :: Bool -> ServerM () () startServer forkOnceListening = do - Config{..} <- asks serverConfig + Config {..} <- asks (serverConfig . fst) io (hSetBuffering stdout NoBuffering) sock <- io (listenOn (PortNumber (fromIntegral configPort))) - $(logInfo) ("Server started on port " <> pack (show configPort) <> + $(logInfo) ("Server started on port " <> T.pack (show configPort) <> ", remote URL is: " <> configUrl) (if forkOnceListening then void . fork else id) (forever (acceptConnection sock)) -- | Accept a connection on the given socket. -acceptConnection :: Socket -> Server () +acceptConnection :: Socket -> ServerM () () 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) <> ")") + $(logInfo) ("Connection accepted from: " <> T.pack remote <> + ":" <> T.pack (show port) <> + " (" <> T.pack (show handle) <> ")") void (fork (handleLine handle)) --- | Handle a line of input. -handleLine :: Handle -> Server () -handleLine handle = flip finally (close handle) $ do +-- | Handle a single line of input. +handleLine :: Handle -> ServerM () () +handleLine handle = + finally (getJsonLine handle >>= flip forM_ (handleClientMessage handle)) + (close handle) + +-- | Get a JSON line if possible and pass it to the continuation. +getJsonLine :: (Show a,FromJSON a) => Handle -> ServerM s (Maybe a) +getJsonLine handle = do result <- io (try (S8.hGetLine handle)) case result of Left (_ :: IOException) -> do $(logError) "Unable to get line from handle." + return Nothing Right line -> do - case decode (fromChunks [line]) of + case decode (LBS.fromChunks [line]) of Nothing -> do - $(logError) ("Unable to parse JSON from line: " <> decodeUtf8 line) + $(logError) ("Unable to parse JSON from line! " <> decodeUtf8 line) + return Nothing Just msg -> do - $(logDebug) ("<- " <> pack (show msg)) - handleMessage handle msg + $(logDebug) ("<- " <> T.pack (show msg)) + return (Just msg) -- | Handle any incoming message from the client. -handleMessage :: Handle -> Msg -> Server () -handleMessage h msg = +handleClientMessage :: Handle -> Msg -> ServerM () () +handleClientMessage 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 + MsgSaveModule pid root filename -> + withProjectId pid $ saveTheFile h root filename + MsgCheckModule pid root filename path -> + withProjectId pid $ checkModule h root filename path + MsgTypeInfo pid filename sl sc el ec -> + withProjectId pid $ typeInfo h filename sl sc el ec + MsgGetDefinition pid root filename sl sc el ec -> + withProjectId pid $ getDefinition h root filename sl sc el ec + MsgAutoComplete pid filename prefix -> + withProjectId pid $ autoComplete h filename prefix + MsgHoogleIdent pid filename name -> + withProjectId pid $ hoogleIdent h filename name + MsgHoogleDb pid name -> + withProjectId pid $ hoogleDb h name + MsgDownloadFiles epid fp -> + withEProjectId epid $ downloadFiles h fp + MsgWriteEmacsConfig epid fp -> + withEProjectId epid $ writeEmacsConfig h fp + MsgRunTarget pid -> + withProjectId pid $ runCurrentTarget h -- Message handlers +-- | Run the current target. +runCurrentTarget :: Handle -> Server () +runCurrentTarget h = do + ClientInfo {..} <- clientInfo + pidVar <- io newEmptyTMVarIO + -- Watch for web process urls. + unsub <- io $ subscribeSignal (pcNewStatus ciCallbacks) $ \unsub snap -> do + mpid <- io $ atomically $ tryReadTMVar pidVar + case (mpid, snapProcessStatus snap) of + (Just pid, SnapshotProcessRunning pid' (Just url)) + | pid' == pid -> do reply h (ReplyWebUrl (Approot url)) + io unsub + _ -> return () + void $ (`finally` io unsub) $ + -- Start the process. This is done asynchronously with output + -- collection because output can be yielded concurrently with the + -- ProcId. + (`concurrently` (runTarget False >>= io . atomically . putTMVar pidVar)) $ + -- Fetch process input from the client. + (`race` (io (atomically (readTMVar pidVar)) >>= getStdin)) $ + -- Send process output to the client. + io $ blockOnSignal Nothing (pcProcessOutput ciCallbacks) $ \(k, v) -> do + pid <- io $ atomically $ readTMVar pidVar + if k /= pid + then return Nothing + else do + case v of + SRSuccess x -> do + reply h (ReplyStdout x) + return Nothing + SRTerminated PRExitSuccess -> + return (Just ()) + SRTerminated err -> do + reply h (ReplyStderr (T.pack (show err))) + return (Just ()) + where + getStdin pid = do + msg <- getJsonLine h + case msg of + Just (MsgStdin text) -> do + success <- putStdin pid text + when (not success) $ $(logError) "Failed to send stdin." + getStdin pid + Just (MsgKill _) -> + stopRunningCode + _ -> do + $(logError) $ + "Didn't expect to recieve the following message when running a process:\n" <> + T.pack (show msg) + getStdin pid + -- | 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 +writeEmacsConfig :: Handle -> FilePath -> Server () +writeEmacsConfig h root = do + (_, pid) <- ask io (writeFile (root ".dir-locals.el") - (unlines (src fpid))) + (unlines (src pid))) reply h (ReplyOK ()) - - where src fpid = - ["((nil . ((fpco-pid . " ++ unpack (unFayProjectId fpid) ++ ")" + where src pid = + ["((nil . ((fpco-pid . " ++ unProjectIdString pid ++ ")" ," (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)) +downloadFiles :: Handle -> FilePath -> Server () +downloadFiles h root = do + ipi <- getInitialProjectInfo "emacs" + forM_ (ipiFiles ipi) (updateFileContents root . fdEncFileName) 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)) - +hoogleDb :: Handle -> T.Text -> Server () +hoogleDb h q = do + (_, results, _) <- ideHoogleSearch Nothing exact count offset limit q + reply h (ReplyHoogleResults results) 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) +hoogleIdent :: Handle -> String -> T.Text -> Server () +hoogleIdent h filename q = do + (_, results, _) <- ideHoogleSearch (Just mname) exact count offset limit q + case results of + (result:_) -> reply h (ReplyHoogleResult result) + _ -> return () + where mname = encFileNameFromString 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 + -> T.Text -> Server () -autoComplete h fpid filename prefix = do +autoComplete h 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 + let input = AutoCompleteInput (encFileNameFromString filename) prefix + completions <- getAutocompletions input + reply h (ReplyCompletions completions) -- | Get the definition location of the identifier at the given span. getDefinition :: Handle - -> FayProjectId -> FilePath -> 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)) - +getDefinition h root filename sl sc el ec = do + midinfo <- getDefinitionSource defSpan + case midinfo of + NoIdInfo -> return () + IdInfo _ info -> reply h (ReplyLocation (makeDef info)) where defSpan = - SourceSpan (FayFileName (pack filename)) + SourceSpan (encFileNameFromString filename) sl sc el ec - makeDef (DefinitionLocal span) = + makeDef (DefinitionLocal _name 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) + makeDef (DefinitionTextSpan name loc) = + DefinitionUseless (name <> " " <> loc <> " (nowhere known to go)") + makeDef (DefinitionImported name m1 m2 es1 es2) = + DefinitionImport name + (makePackageModule m1) + (makePackageModule 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!)") + makeDef (DefinitionWiredIn name) = + DefinitionUseless ("Wired-in: " <> name <> " (nowhere to go!)") + makeDef (DefinitionBinder name) = + DefinitionUseless ("Binder: " <> name <> " (you're already there!)") -- | Print a package:module pair. -makeModuleId :: FayModuleId -> ModuleId -makeModuleId (FayModuleId _ mname pkg) = - (ModuleId (packageName pkg) (unFayModuleName mname)) +makePackageModule :: ModuleId -> PackageModule +makePackageModule (ModuleId _ mname pkg) = + PackageModule (packageName pkg) (unModuleName mname) -- | Get type info of span. typeInfo :: Handle - -> FayProjectId -> String + -> 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)) - +typeInfo h filename sl sc el ec = do + infos <- getTypeInfoDominators span + reply h (ReplyTypeInfo (map toSpanType infos)) where span = - SourceSpan (FayFileName (pack filename)) + SourceSpan (encFileNameFromString filename) sl sc el ec --- | Save the given module. -saveTheModule :: Handle -> FayProjectId -> FilePath -> FilePath -> Server () -saveTheModule h fpid root filename = - withTokens (\tokensVar -> do - let fname = FayFileName (pack filename) - token <- getToken tokensVar fpid root filename - text <- io (T.readFile (root filename)) - E.catch (do SaveFileOutput token' _ <- saveFile fname text token fpid - updateToken tokensVar root filename token' - reply h (ReplySaveStatus False)) - -- A command exception will be thrown when the file is out of - -- date. So we just immediately grab the new version of the - -- file, overwrite out local copy. Emacs will prompt the user - -- about it at the right time. - (\(_ :: CommandException) -> - do updateFileContents tokensVar fpid root filename - reply h (ReplySaveStatus True))) +-- | Save the given file. +saveTheFile :: Handle -> FilePath -> FilePath -> Server () +saveTheFile h root filename = do + res <- saveFileInternal (root filename) filename + case res of + SaveSucceeded _ -> reply h (ReplySaveStatus False) + SaveFailed -> do + updateFileContents root (encFileNameFromString 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))) +checkModule :: Handle -> FilePath -> FilePath -> FilePath -> Server () +checkModule h root filename bufferfile = do + $(logDebug) "Check module" + res <- saveFileInternal bufferfile filename + case res of + -- If there's an out of date error, don't break the flychecker, + -- just return no errors for now. + -- TODO: Should do something better than this, like what + -- saveTheFile does. + SaveFailed -> reply h (ReplyCompileInfos []) + -- Similarly, if this didn't enque a compile, pretend like there + -- are no errors... + SaveSucceeded Nothing -> reply h (ReplyCompileInfos []) + SaveSucceeded (Just desc) -> do + infos <- watchStatusOneShot "checkModule" Nothing $ \status -> + case snapCompileStatus status of + RunnerCompileDone cid infos | cid == cdCompileIdent desc -> return (Just infos) + _ -> return Nothing + reply h (ReplyCompileInfos infos) +data SaveFileResult + = SaveSucceeded (Maybe CompileDesc) + | SaveFailed + +saveFileInternal :: FilePath -> FilePath -> Server SaveFileResult +saveFileInternal localPath serverPath = do + text <- io (T.readFile localPath) + let fname = encFileNameFromString serverPath + eres <- try $ saveFile' fname text + case eres of + Right res -> return (SaveSucceeded res) + Left (_ :: ClientException) -> return SaveFailed + -- 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))) + $(logDebug) ("-> " <> ellipsize 140 (T.pack (show r))) io (L8.hPutStrLn h (encode r)) -- | Close the given handle. -close :: Handle -> Server () +close :: Handle -> ServerM () () close h = do - $(logDebug) ("Connection closed to " <> pack (show h)) + $(logDebug) ("Connection closed to " <> T.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 +--- | Update the contents of the given file from the server. +updateFileContents :: FilePath -> EncFileName -> Server () +updateFileContents root name = do + mtext <- getFile' name + let fp = root unEncFileNameString name + --FIXME: Better handling of binary files? + case mtext of + Nothing -> $(logDebug) (T.pack fp <> " not written because it's a binary file. This will be fixed in the future.") + Just text -> io $ do + createDirectoryIfMissing True (takeDirectory fp) + T.writeFile (root fp) text -- | Strip the trailing slash. -stripSlash :: Text -> Text +stripSlash :: T.Text -> T.Text stripSlash = T.reverse . T.dropWhile (=='/') . T.reverse -- | Convert an API message to a more structurally convenient reply message. @@ -501,10 +380,88 @@ convertMsg root SourceInfo{..} = CompileMessage (printEitherSpan root infoSpan) kind - infoMsg - + msg where kind = case infoKind of - KindError -> "error" - KindWarning -> "warning" - KindHint -> "hint" + SIKError -> "error" + SIKWarning -> "warning" + SIKMismatch -> "warning" + SIKHint -> "hint" + msg = T.concat $ map snd (filter ((/= ICTOriginal) . fst) infoMsg) + +withProjectId :: ProjectId -> Server a -> ServerM () a +withProjectId pid m = withReaderT (\(x, ()) -> (x, pid)) m + +ideCommandTimeout :: Int +ideCommandTimeout = 1000 * 1000 * 60 * 5 + +-- | Get the project ID from either a URL or a project ID. +withEProjectId :: Either T.Text ProjectId -> Server a -> ServerM () a +withEProjectId epid f = do + case epid of + Left url -> do + let cmd = GetProjectId url Returns + shownCmd = show cmd + bs <- runCommand "getting project id" 200 "/misc-command" cmd + mpid <- handleServerResponse shownCmd (Just bs) + case mpid of + Failure err -> clientFail $ "Failed to get project-id for URL: " <> err + Success pid -> withProjectId pid f + Right pid -> withProjectId pid f + +-- Send commands to the server + +instance FpClient (ServerM ProjectId) (ServerM ProjectId) where + runCallback = id + clientInfo = do + (state, pid) <- ask + -- If the project hasn't been started, then fork off a messages + -- poller, and add it to the list of projects. + projects <- io $ readTVarIO $ serverProjects state + case M.lookup pid projects of + Nothing -> do + prj <- io $ newClientInfo ideCommandTimeout pid + io $ atomically $ writeTVar (serverProjects state) (M.insert pid prj projects) + void $ fork pollProjectMessages + return prj + Just prj -> return prj + makeRequest msg status r cmd = do + let url = case r of + MiscCommandRoute -> "/misc-command" + IdeMessagesRoute pid -> "/ide-messages/" <> unProjectIdText pid + IdeAsyncCommandRoute pid -> "/ide-async-command/" <> unProjectIdText pid + fmap Just $ runCommand msg status url cmd + +runCommand :: (Show cmd, Data cmd) => T.Text -> Int -> T.Text -> cmd -> ServerM r LBS.ByteString +runCommand msg expected url cmd = do + CC{..} <- asks (serverCC . fst) + request <- parseUrl (T.unpack (ccUrl <> url)) + jar <- io $ readIORef ccCookie + let req = request + { method = "POST" + , requestHeaders = requestHeaders request ++ + [("Accept","application/json") + ,("User-Agent",encodeUtf8 ("fpco-api:" <> ccUserAgent)) + ,("authorization",encodeUtf8 ("token " <> ccToken))] + , responseTimeout = Nothing + , cookieJar = Just jar + , requestBody = RequestBodyLBS $ encode (showToFay cmd) + , checkStatus = \_ _ _ -> Nothing + } + $(logDebug) ("=> " <> trunc (T.pack (show cmd))) + resp <- io (runResourceT (httpLbs req ccManager)) + io $ writeIORef ccCookie (responseCookieJar resp) + let code = statusCode (responseStatus resp) + if expected /= code + then clientFail $ + "Bad status code returned from client command: " <> T.pack (show code) <> + if code == 404 + then mempty + else "\nResponse: " <> decodeUtf8With lenientDecode (S8.concat (LBS.toChunks (responseBody resp))) + else return (responseBody resp) + +trunc :: T.Text -> T.Text +trunc = ellipsize 140 + +errPrefix :: Show cmd => T.Text -> cmd -> T.Text +errPrefix msg cmd = "Error from request, while " <> msg <> ": " <> T.pack (show cmd) <> "\n" 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 @@ -4,6 +4,7 @@ module FP.Server.Config where +import Prelude (Integer) import Data.Text (Text) -- | Default url 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 @@ -9,26 +9,26 @@ import Data.Maybe import Data.Monoid -import Data.Text (Text,unpack) +import Data.Text (Text) 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 _ (TextSpan s) = 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 (root unEncFileNameString 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 +toSpanType (TypeInfo (SourceSpan _ sl sc el ec) srcstr typs) = + SpanType sl sc el ec srcstr typs makeEitherLoc :: FilePath -> EitherSpan -> Maybe Loc makeEitherLoc _ TextSpan{} = Nothing @@ -36,6 +36,6 @@ makeLoc :: FilePath -> SourceSpan -> Loc makeLoc root (SourceSpan source fl fc tl tc) = - Loc (root unpack (unFayFileName source)) + Loc (root unEncFileNameString source) fl fc tl tc 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 @@ -1,54 +1,48 @@ -{-# 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 FP.Server.Config +import FP.API.Types +import FP.Server.Config -import Control.Concurrent (MVar) -import Control.Monad.Logger (LoggingT) -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 +import Control.Concurrent.STM +import Control.Monad.Logger hiding (Loc) +import Control.Monad.Reader +import Data.Aeson +import Data.Default +import Data.Map (Map) +import Data.Text +import FP.API.Common +import GHC.Generics +import Data.IORef +import Network.HTTP.Conduit +import Prelude -- | Server monad. -type Server = LoggingT (ReaderT ServerReader IO) +type ServerM r = ReaderT (ServerState, r) (LoggingT IO) + +type Server = ServerM ProjectId + -- | The configuration for the server and some state. -data ServerReader = ServerReader +data ServerState = ServerState { serverCC :: ClientConfig , serverConfig :: Config - , serverPollers :: MVar (Map FayProjectId [Callback]) - , serverTokens :: MVar (MVar (Map FilePath FayTutorialToken)) + , serverProjects :: TVar (Map ProjectId (ClientInfo Server)) } --- | 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 +-- | Simple command configuration. +data ClientConfig = CC + { ccUrl :: !Text + , ccToken :: !Text + , ccManager :: !Manager + , ccCookie :: !(IORef CookieJar) + , ccUserAgent :: !Text + } -- | Configuration for server. data Config = Config @@ -64,20 +58,30 @@ def = Config "" defaultUrl defaultPort "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 +data Msg = MsgSaveModule ProjectId FilePath FilePath + | MsgCheckModule ProjectId FilePath FilePath FilePath + | MsgTypeInfo ProjectId FilePath Int Int Int Int + | MsgGetDefinition ProjectId FilePath FilePath Int Int Int Int + | MsgAutoComplete ProjectId FilePath Text + | MsgHoogleIdent ProjectId FilePath Text + | MsgHoogleDb ProjectId Text + | MsgDownloadFiles (Either Text ProjectId) FilePath + | MsgWriteEmacsConfig (Either Text ProjectId) FilePath + | MsgRunTarget ProjectId deriving (Generic,Show) instance FromJSON Msg instance ToJSON Msg +-- | A message sent when running a process. +data ProcessMsg + = MsgStdin Text + | MsgKill (Maybe ()) -- Because Lisp is stupid. + deriving (Generic,Show) + +instance FromJSON ProcessMsg +instance ToJSON ProcessMsg + -- | Reply to the client. data Reply = ReplyPong () | ReplyOK () @@ -89,6 +93,9 @@ | ReplyHoogleResults [HoogleResult] | ReplyHoogleResult HoogleResult | ReplySaveStatus Bool + | ReplyStdout Text + | ReplyStderr Text + | ReplyWebUrl Approot deriving (Generic,Show) instance ToJSON Reply @@ -96,21 +103,22 @@ data DefinitionLoc = DefinitionLoc Loc | DefinitionUseless Text - | DefinitionImport Text -- Dunno - ModuleId -- Package - ModuleId -- Package 2.0 (?) - (Maybe Loc) -- Span - (Maybe Loc) -- Span 2.0 + | DefinitionImport Text -- Identifier name + PackageModule -- Module it's defined in + PackageModule -- Module it's imported from + (Maybe Loc) -- Definition span + (Maybe Loc) -- Import span deriving (Generic,Show) instance ToJSON DefinitionLoc instance FromJSON DefinitionLoc -data ModuleId = ModuleId Text Text +data PackageModule = PackageModule Text -- Package name + Text -- Module name deriving (Generic,Show) -instance ToJSON ModuleId -instance FromJSON ModuleId +instance ToJSON PackageModule +instance FromJSON PackageModule data Loc = Loc FilePath Int Int Int Int deriving (Generic,Show) @@ -121,66 +129,15 @@ -- | 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 instance FromJSON SpanType -- | A message from the compiler about code. -data CompileMessage - = CompileMessage Text Text Text +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