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
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
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
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
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) ()
void $ makeRequest "restarting session"
200
(IdeAsyncCommandRoute ciProjId)
(Ping Returns)
ProjectHasClosed _sid False e -> error $ "handleMessage: Encountered ProjectHasClosed False: " ++ T.unpack e
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
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
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)
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
$(mkFayCommands
[ (''IdeCommand, 'ideCommand, id)
, (''IdeCommand, 'ideCommandFail, (++ "Fail"))
, (''FayCommand, 'fayCommand, id)
])
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
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)
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