module FP.Server
( runWithConfig
, startServer
, convertMsg
) where
import FP.API
import FP.API.Common
import FP.API.Convert
import FP.API.Signal
import FP.Server.Spans
import FP.Server.Types
import Control.Concurrent.Async.Lifted (race, concurrently)
import Control.Concurrent.Lifted
import Control.Concurrent.STM
import Control.Exception.Lifted hiding (handle)
import Control.Monad.Extra
import Control.Monad.Logger
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.Maybe
import Data.Monoid
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 Language.Fay.Yesod (Returns(..))
import Network
import Network.HTTP.Conduit
import Network.HTTP.Types.Status
import Prelude hiding (span,catch)
import System.Directory
import System.FilePath
import System.IO
runWithConfig :: ServerM () b -> Config -> IO b
runWithConfig m config = do
manager <- newManager conduitManagerSettings
projects <- newTVarIO mempty
jar <- newIORef mempty
(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 ())
startServer :: Bool -> ServerM () ()
startServer forkOnceListening = do
Config {..} <- asks (serverConfig . fst)
io (hSetBuffering stdout NoBuffering)
sock <- io (listenOn (PortNumber (fromIntegral configPort)))
$(logInfo) ("Server started on port " <> T.pack (show configPort) <>
", remote URL is: " <> configUrl)
(if forkOnceListening then void . fork else id)
(forever (acceptConnection sock))
acceptConnection :: Socket -> ServerM () ()
acceptConnection sock = do
(handle,remote,port) <- io (accept sock)
io (hSetBuffering handle NoBuffering)
$(logInfo) ("Connection accepted from: " <> T.pack remote <>
":" <> T.pack (show port) <>
" (" <> T.pack (show handle) <> ")")
void (fork (handleLine handle))
handleLine :: Handle -> ServerM () ()
handleLine handle =
finally (getJsonLine handle >>= flip forM_ (handleClientMessage handle))
(close handle)
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 (LBS.fromChunks [line]) of
Nothing -> do
$(logError) ("Unable to parse JSON from line! " <> decodeUtf8 line)
return Nothing
Just msg -> do
$(logDebug) ("<- " <> T.pack (show msg))
return (Just msg)
handleClientMessage :: Handle -> Msg -> ServerM () ()
handleClientMessage h msg =
case msg of
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
runCurrentTarget :: Handle -> Server ()
runCurrentTarget h = do
ClientInfo {..} <- clientInfo
pidVar <- io newEmptyTMVarIO
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) $
(`concurrently` (runTarget False >>= io . atomically . putTMVar pidVar)) $
(`race` (io (atomically (readTMVar pidVar)) >>= getStdin)) $
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
writeEmacsConfig :: Handle -> FilePath -> Server ()
writeEmacsConfig h root = do
(_, pid) <- ask
io (writeFile (root </> ".dir-locals.el")
(unlines (src pid)))
reply h (ReplyOK ())
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\")))))))))"]
downloadFiles :: Handle -> FilePath -> Server ()
downloadFiles h root = do
ipi <- getInitialProjectInfo "emacs"
forM_ (ipiFiles ipi) (updateFileContents root . fdEncFileName)
reply h (ReplyOK ())
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
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
autoComplete :: Handle
-> FilePath
-> T.Text
-> Server ()
autoComplete h filename prefix = do
case T.strip prefix of
"" -> reply h (ReplyCompletions [])
_ -> do
let input = AutoCompleteInput (encFileNameFromString filename) prefix
completions <- getAutocompletions input
reply h (ReplyCompletions completions)
getDefinition :: Handle
-> FilePath
-> FilePath
-> Int -> Int
-> Int -> Int
-> Server ()
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 (encFileNameFromString filename)
sl sc
el ec
makeDef (DefinitionLocal _name span) =
DefinitionLoc (makeLoc root span)
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 name) =
DefinitionUseless ("Wired-in: " <> name <> " (nowhere to go!)")
makeDef (DefinitionBinder name) =
DefinitionUseless ("Binder: " <> name <> " (you're already there!)")
makePackageModule :: ModuleId -> PackageModule
makePackageModule (ModuleId _ mname pkg) =
PackageModule (packageName pkg) (unModuleName mname)
typeInfo :: Handle
-> String
-> Int -> Int
-> Int -> Int
-> Server ()
typeInfo h filename sl sc el ec = do
infos <- getTypeInfoDominators span
reply h (ReplyTypeInfo (map toSpanType infos))
where span =
SourceSpan (encFileNameFromString filename)
sl sc
el ec
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)
checkModule :: Handle -> FilePath -> FilePath -> FilePath -> Server ()
checkModule h root filename bufferfile = do
$(logDebug) "Check module"
res <- saveFileInternal bufferfile filename
case res of
SaveFailed -> reply h (ReplyCompileInfos [])
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
reply :: (ToJSON a,Show a) => Handle -> a -> Server ()
reply h r = do
$(logDebug) ("-> " <> T.take 140 (T.pack (show r)))
io (L8.hPutStrLn h (encode r))
close :: Handle -> ServerM () ()
close h = do
$(logDebug) ("Connection closed to " <> T.pack (show h))
io (hClose h)
updateFileContents :: FilePath -> EncFileName -> Server ()
updateFileContents root name = do
mtext <- getFile' name
let fp = root </> unEncFileNameString name
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
stripSlash :: T.Text -> T.Text
stripSlash = T.reverse . T.dropWhile (=='/') . T.reverse
convertMsg :: FilePath -> SourceInfo -> CompileMessage
convertMsg root SourceInfo{..} =
CompileMessage (printEitherSpan root infoSpan)
kind
msg
where kind =
case infoKind of
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
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
instance FpClient (ServerM ProjectId) (ServerM ProjectId) where
runCallback = id
clientInfo = do
(state, pid) <- ask
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 (encodeFpco cmd)
, checkStatus = \_ _ _ -> Nothing
}
$(logDebug) ("=> " <> T.take 140 (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)
errPrefix :: Show cmd => T.Text -> cmd -> T.Text
errPrefix msg cmd = "Error from request, while " <> msg <> ": " <> T.pack (show cmd) <> "\n"