module FP.Server where
import FP.API
import FP.API.Run
import FP.API.Types
import FP.Server.Spans
import FP.Server.Types
import Control.Applicative
import Control.Concurrent.Lifted
import Control.Exception.Lifted as E hiding (handle)
import Control.Monad.Extra
import Control.Monad.Logger
import Control.Monad.Reader
import Data.Aeson
import qualified Data.ByteString.Char8 as S8
import Data.ByteString.Lazy (fromChunks)
import qualified Data.ByteString.Lazy.Char8 as L8
import Data.IORef
import qualified Data.Map as M
import Data.Map (Map)
import Data.Maybe
import Data.Monoid
import Data.Text (Text, pack, unpack)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import qualified Data.Text.IO as T
import Data.Typeable
import Network
import Network.HTTP.Conduit
import Prelude hiding (span)
import System.Directory
import System.FilePath
import System.IO
import Texts.English
runWithConfig :: Server b -> Config -> IO b
runWithConfig m config = do
manager <- newManager conduitManagerSettings
pollers <- newMVar mempty
jar <- newIORef mempty
tokensVar <- newMVar mempty
tokens <- newMVar tokensVar
runReaderT ((if configDebug config then runStderrLoggingT else runSilentLoggingT) m)
(ServerReader (CC (stripSlash (configUrl config))
(configToken config)
manager
jar
(configAgent config))
config
pollers
tokens)
where runSilentLoggingT m' =
runLoggingT m' (\_loc _src _lvl _str -> return ())
startServer :: Bool -> Server ()
startServer forkOnceListening = do
Config{..} <- asks serverConfig
io (hSetBuffering stdout NoBuffering)
sock <- io (listenOn (PortNumber (fromIntegral configPort)))
$(logInfo) ("Server started on port " <> pack (show configPort) <>
", remote URL is: " <> configUrl)
(if forkOnceListening then void . fork else id)
(forever (acceptConnection sock))
acceptConnection :: Socket -> Server ()
acceptConnection sock = do
(handle,remote,port) <- io (accept sock)
io (hSetBuffering handle NoBuffering)
$(logInfo) ("Connection accepted from: " <> pack remote <>
":" <> pack (show port) <>
" (" <> pack (show handle) <> ")")
void (fork (handleLine handle))
handleLine :: Handle -> Server ()
handleLine handle = flip finally (close handle) $ do
result <- io (try (S8.hGetLine handle))
case result of
Left (_ :: IOException) -> do
$(logError) "Unable to get line from handle."
Right line -> do
case decode (fromChunks [line]) of
Nothing -> do
$(logError) ("Unable to parse JSON from line: " <> decodeUtf8 line)
Just msg -> do
$(logDebug) ("<- " <> pack (show msg))
handleMessage handle msg
handleMessage :: Handle -> Msg -> Server ()
handleMessage h msg =
case msg of
MsgSaveModule fpid root filename ->
saveTheModule h fpid root filename
MsgCheckModule fpid root filename path ->
checkModule h fpid root filename path
MsgTypeInfo fpid filename sl sc el ec ->
typeInfo h fpid filename sl sc el ec
MsgGetDefinition fpid root filename sl sc el ec ->
getDefinition h fpid root filename sl sc el ec
MsgAutoComplete fpid filename prefix ->
autoComplete h fpid filename prefix
MsgHoogleIdent fpid filename name ->
hoogleIdent h fpid filename name
MsgHoogleDb fpid name ->
hoogleDb h fpid name
MsgDownloadFiles fpid fp ->
downloadFiles h fpid fp
MsgWriteEmacsConfig fpid fp ->
writeEmacsConfig h fpid fp
writeEmacsConfig :: Handle -> Either Text FayProjectId -> FilePath -> Server ()
writeEmacsConfig h pid root = do
fpid <- getFayProjectId pid
io (writeFile (root </> ".dir-locals.el")
(unlines (src fpid)))
reply h (ReplyOK ())
where src fpid =
["((nil . ((fpco-pid . " ++ unpack (unFayProjectId fpid) ++ ")"
," (eval . (set (make-local-variable 'fpco-root)"
," (expand-file-name"
," (locate-dominating-file buffer-file-name \".dir-locals.el\")))))))))"]
downloadFiles :: Handle -> Either Text FayProjectId -> FilePath -> Server ()
downloadFiles h pid root = do
fpid <- getFayProjectId pid
ipi <- getInitialProjectInfo fpid
forM_ (ipiFiles ipi) $ \(name,_) -> do
FileContent text _ <- getFile name fpid
io (writeCreateFile (root </> T.unpack (unFayFileName name))
(fromMaybe "" text))
reply h (ReplyOK ())
where writeCreateFile fp text = do
io (createDirectoryIfMissing True (takeDirectory fp))
T.writeFile (root </> fp) text
hoogleDb :: Handle -> FayProjectId -> Text -> Server ()
hoogleDb h fpid q = do
void (ideHoogleSearch Nothing exact count offset limit q fpid)
wait fpid
(Callback
(\_mid msg ->
case msg of
HoogleResults _ results _ ->
do reply h (ReplyHoogleResults results)
return Done
_ -> return NotDone))
where exact = False
count = 10
offset = 0
limit = count
hoogleIdent :: Handle -> FayProjectId -> String -> Text -> Server ()
hoogleIdent h fpid filename q = do
hid <- ideHoogleSearch (Just mname) exact count offset limit q fpid
wait fpid
(Callback
(\mid msg ->
case msg of
HoogleResults _ results _
| toHoogleId mid == Just hid ->
do case results of
(result:_) -> reply h (ReplyHoogleResult result)
_ -> return ()
return Done
_ -> return NotDone))
where mname = FayFileName (pack filename)
exact = True
count = 10
offset = 0
limit = count
toHoogleId = fmap HoogleId
autoComplete :: Handle
-> FayProjectId
-> FilePath
-> Text
-> Server ()
autoComplete h fpid filename prefix = do
case T.strip prefix of
"" -> reply h (ReplyCompletions [])
_ -> do
getAutocompletions input fpid
wait fpid
(Callback
(\_ msg ->
case msg of
AutoCompleteResults input' completions
| Just input == input' -> do reply h (ReplyCompletions completions)
return Done
_ -> return NotDone))
where input = AutoCompleteInput (FayFileName (pack filename))
prefix
getDefinition :: Handle
-> FayProjectId -> FilePath
-> FilePath
-> Int -> Int
-> Int -> Int
-> Server ()
getDefinition h fpid root filename sl sc el ec = do
getDefinitionSource defSpan fpid
wait fpid
(Callback (\_ msg ->
case msg of
IdInfoResults i ->
case i of
NoIdInfo src
| src == defSpan -> return Done
IdInfo src _ info
| src == defSpan -> do reply h (ReplyLocation (makeDef info))
return Done
_ -> return NotDone
_ -> return NotDone))
where defSpan =
SourceSpan (FayFileName (pack filename))
sl sc
el ec
makeDef (DefinitionLocal span) =
DefinitionLoc (makeLoc root span)
makeDef (DefinitionTextSpan t1 t2) =
DefinitionUseless (t1 <> " " <> t2 <> " (nowhere known to go)")
makeDef (DefinitionImported text m1 m2 es1 es2) =
DefinitionImport text
(makeModuleId m1)
(makeModuleId m2)
(makeEitherLoc root es1)
(makeEitherLoc root es2)
makeDef (DefinitionWiredIn text) =
DefinitionUseless ("Wired-in: " <> text <> " (nowhere to go!)")
makeDef (DefinitionBinder text) =
DefinitionUseless ("Binder: " <> text <> " (you're already there!)")
makeModuleId :: FayModuleId -> ModuleId
makeModuleId (FayModuleId _ mname pkg) =
(ModuleId (packageName pkg) (unFayModuleName mname))
typeInfo :: Handle
-> FayProjectId -> String
-> Int -> Int
-> Int -> Int
-> Server ()
typeInfo h fpid filename sl sc el ec = do
getTypeInfo span 0 fpid
wait fpid
(Callback
(\_ msg -> do
case msg of
SubExprsResults span' infos
| span' == span -> do reply h (ReplyTypeInfo (map toSpanType (concat infos)))
return Done
_ -> return NotDone))
where span =
SourceSpan (FayFileName (pack filename))
sl sc
el ec
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))
(\(_ :: CommandException) ->
do updateFileContents tokensVar fpid root filename
reply h (ReplySaveStatus True)))
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
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)))
reply :: (ToJSON a,Show a) => Handle -> a -> Server ()
reply h r = do
$(logDebug) ("-> " <> ellipsize 140 (pack (show r)))
io (L8.hPutStrLn h (encode r))
close :: Handle -> Server ()
close h = do
$(logDebug) ("Connection closed to " <> pack (show h))
io (hClose h)
wait :: FayProjectId
-> Callback
-> 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
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
removePoller :: FayProjectId -> Server ()
removePoller fpid = do
psvar <- asks serverPollers
modifyMVar_ psvar (return . M.delete fpid)
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
getIPI :: FayProjectId -> Server ()
getIPI fpid = do
_ <- getInitialProjectInfo fpid
return ()
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)
Left (e :: SomeException) -> do
$(logError) ("Callback threw exception: " <> pack (show e))
return Nothing
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
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))
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
withTokens :: (MVar (Map FilePath FayTutorialToken) -> Server a) -> Server a
withTokens cont = do
tokensVar <- asks serverTokens
withMVar tokensVar cont
getFayProjectId :: Either Text FayProjectId -> Server FayProjectId
getFayProjectId = either getProjectId return
stripSlash :: Text -> Text
stripSlash = T.reverse . T.dropWhile (=='/') . T.reverse
convertMsg :: FilePath -> SourceInfo -> CompileMessage
convertMsg root SourceInfo{..} =
CompileMessage (printEitherSpan root infoSpan)
kind
infoMsg
where kind =
case infoKind of
KindError -> "error"
KindWarning -> "warning"
KindHint -> "hint"