fpco-api 1.1.1.4 → 1.2.0
raw patch · 16 files changed
+3591/−1773 lines, 16 filesdep +base64-bytestringdep +blaze-htmldep +cerealdep −scientificdep −taggeddep ~aesondep ~http-conduitdep ~network
Dependencies added: base64-bytestring, blaze-html, cereal, deepseq, deepseq-generics, hashable, lifted-async, monad-control, semigroups, shakespeare, shakespeare-i18n, stm, time, transformers, transformers-base, yesod-core
Dependencies removed: scientific, tagged
Dependency ranges changed: aeson, http-conduit, network, syb
Files
- fpco-api.cabal +108/−77
- src/executables/Main.hs +10/−13
- src/library/FP/API.hs +116/−22
- src/library/FP/API/Common.hs +439/−0
- src/library/FP/API/Convert.hs +0/−252
- src/library/FP/API/Dispatch.hs +49/−0
- src/library/FP/API/ModuleName.hs +65/−0
- src/library/FP/API/Run.hs +0/−101
- src/library/FP/API/Runner.hs +1453/−0
- src/library/FP/API/Signal.hs +51/−0
- src/library/FP/API/TH.hs +0/−41
- src/library/FP/API/Types.hs +901/−783
- src/library/FP/Server.hs +331/−374
- src/library/FP/Server/Config.hs +1/−0
- src/library/FP/Server/Spans.hs +6/−6
- src/library/FP/Server/Types.hs +61/−104
fpco-api.cabal view
@@ -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
src/executables/Main.hs view
@@ -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
src/library/FP/API.hs view
@@ -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"
+ src/library/FP/API/Common.hs view
@@ -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
− src/library/FP/API/Convert.hs
@@ -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
+ src/library/FP/API/Dispatch.hs view
@@ -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]
+ src/library/FP/API/ModuleName.hs view
@@ -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'
− src/library/FP/API/Run.hs
@@ -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"
+ src/library/FP/API/Runner.hs view
@@ -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
+ src/library/FP/API/Signal.hs view
@@ -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
− src/library/FP/API/TH.hs
@@ -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
src/library/FP/API/Types.hs view
@@ -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)
src/library/FP/Server.hs view
@@ -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"
src/library/FP/Server/Config.hs view
@@ -4,6 +4,7 @@ module FP.Server.Config where +import Prelude (Integer) import Data.Text (Text) -- | Default url to accept commands on.
src/library/FP/Server/Spans.hs view
@@ -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
src/library/FP/Server/Types.hs view
@@ -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