ghclive-0.1.0.0: src-main/Main.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverlappingInstances #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeSynonymInstances #-}
module Main where
import Control.Monad.Trans
import qualified Data.ByteString as BS
import Data.FileEmbed
import Data.Maybe (fromMaybe, isJust, isNothing)
import Data.Monoid
import qualified Data.Text.Lazy as T
import Language.Haskell.Interpreter hiding (get)
import Network.Wai.Handler.Warp (Settings(..), defaultSettings, runSettings)
import System.Directory (createDirectoryIfMissing, getTemporaryDirectory)
import qualified Text.Blaze.Html5 as H
import Text.Blaze.Html5.Attributes (class_, href, rel, src, type_)
import Yesod
import Yesod.Static
import Control.Applicative
import Control.Concurrent
import Control.Concurrent.MVar
import Control.Monad (forM_, forever, liftM, mzero, void)
import Control.Monad.Error.Class
import Data.Aeson ((.:), (.=))
import Data.Char (isUpper)
import qualified Data.Text as ST
import qualified Data.Text.Lazy.Encoding as LTE
import Data.Typeable
import Network.Web.GHCLive.Display
import Text.Blaze
import Text.Blaze.Internal (preEscapedText, text)
import Text.Blaze.Renderer.Text (renderMarkup)
import qualified Data.Aeson as J
import qualified Data.Aeson.Types as J
import qualified Data.HashMap.Strict as HM
import Data.Map (Map)
import qualified Data.Map as M
import Data.Text (Text)
import qualified Data.Text.IO as DTI
import Data.Time.Clock (UTCTime, getCurrentTime)
import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds)
import qualified Data.Vector as V
import Network.Wai
import qualified Network.Wai.Handler.WebSockets as WS
import qualified Network.WebSockets as WS
import Prelude
import qualified SeqMap as SM
import SignalHandlers
type Hint = Run (InterpreterT IO)
data Run m = Run { vRequest :: MVar (m ()) }
-- hint gives Either InterpreterError DisplayResult
jsonerror expr err = object ["expr" .= expr, "error" .= err]
jsonresult expr res = object ["expr" .= expr, "result" .= res]
data GHCLive = GHCLive
{ ref :: MVar [J.Value] -- list of jsonerror or jsonresult Values
, hint :: Hint
, editor :: Editor
, getStatic :: Static
, tmpdir :: FilePath
}
data Editor = Editor
{ doc :: MVar (Document, Map ClientId Client)
, unique :: MVar ClientId
}
data Operation = InsertAfter AtomId AtomId Char
| Remove AtomId
deriving (Show, Eq, Ord)
data OpBlock = OpBlock [Operation] deriving (Show, Eq, Ord)
-- inefficiently, [(AtomId,TextAtom)]
type Document = SM.SeqMap AtomId TextAtom
-- Char, and whether this Char has been removed
data TextAtom = TextAtom
{ taCh :: Char
, taRemoved :: Maybe Timestamp
} deriving Show
doc2string seqmap = map taCh $ filter (isNothing . taRemoved) (map snd (SM.toList seqmap))
emptyDoc = SM.singleton (AtomId (Timestamp 0) (ClientId 0)) (TextAtom ' ' (Just (Timestamp 0)))
newtype Timestamp = Timestamp { unTimestamp :: Integer }
deriving (Eq, Ord, Show, J.ToJSON, J.FromJSON)
newtype ClientId = ClientId { unClientId :: Integer }
deriving (Eq, Ord, Show, Enum, J.ToJSON, J.FromJSON)
data Client = Client
{ clientConnected :: Timestamp -- timestamp when client connected
, clientId :: ClientId -- unique id
, clientChan :: Chan J.Value -- post outgoing messages to this chan
}
mkTa :: Char -> TextAtom
mkTa ch = TextAtom ch Nothing
-- a Client never makes two IDs with the same timestamp
data AtomId = AtomId
{ aiTime :: Timestamp
, aiClient :: ClientId
} deriving (Show, Ord, Eq)
instance J.ToJSON AtomId where
toJSON (AtomId (Timestamp t) (ClientId c)) = J.toJSON [t,c]
-- atoms encoded in json as [time,clientid]
instance J.FromJSON AtomId where
parseJSON (J.Array v) | V.length v == 2 = AtomId <$> J.parseJSON (v V.! 0) <*> J.parseJSON (v V.! 1)
parseJSON _ = mzero
staticDir = "static"
staticSiteFiles :: Static
staticSiteFiles = $(embed "static")
staticSite :: IO Static
staticSite = do
#ifdef DEVELOPMENT
putStrLn ("using web files from: " ++ staticDir ++ "/")
Static.staticDevel staticDir
#else
putStrLn "using embedded web files"
return $(embed "static")
#endif
-- switch to this when working on the javascript to prevent recompiling each time
-- staticSite :: IO Static
-- staticSite = staticDevel "static"
$(staticFiles "static")
mkYesod "GHCLive" [parseRoutes|
/ RootR GET
/eval EvalR GET
/static StaticR Static getStatic
/loader LoaderR GET
/edit EditR GET
/results ResultsR GET
|]
instance Yesod GHCLive where
makeSessionBackend _ = return Nothing
main :: IO ()
main = do
-- filesystem setup
tmp <- getTemporaryDirectory
let cachedir = (tmp ++ "/ghclive/")
createDirectoryIfMissing False cachedir
BS.writeFile (cachedir ++ "Helper.hs") helperFile
-- hint setup
r <- newMVar ([] :: [J.Value])
h <- newHint
ss <- staticSite
-- shared editor setup
d <- newMVar (emptyDoc, M.empty)
u <- newMVar (ClientId 0)
let editor = Editor d u
let master = GHCLive r h editor ss cachedir
s = defaultSettings
{ settingsPort = 3000
, settingsIntercept = WS.intercept (sockets editor)
}
putStrLn $ "To use ghcLiVE, point your web browser to http://localhost:" ++ show (settingsPort s)
runSettings s =<< (toWaiApp master :: IO Yesod.Application)
getLoaderR = do
y <- getYesod
cs <- liftIO $ readMVar (doc $ editor y)
t <- liftIO . performHint (hint y) $ moduleHint (doc2string $ fst cs) (tmpdir y)
case t of
Left error -> jsonToRepJson $ cleanShow error
Right displayres -> jsonToRepJson displayres
getRootR :: Handler RepHtml
getRootR = redirect EditR
getResultsR = do
y <- getYesod
h <- liftIO $ readMVar (ref y)
jsonToRepJson h -- send ALL the state!
getEvalR :: Handler RepJson
getEvalR = do
y <- getYesod
expr <- fromMaybe "" <$> lookupGetParam "expr"
liftIO $ putStr "expression is "
liftIO $ DTI.putStrLn expr
-- get Editor with getYesod and then document
-- get the clients from the editor document (see applyOps for an example)
(_, clients) <- liftIO $ readMVar (doc $ editor y)
-- - call pushToClients with the clients and the JSON message you want to send, for example: object [ "refresh" .= True ]
(t :: Either InterpreterError DisplayResult) <- liftIO . performHint (hint y) $ interpretHint ("displaying " ++ parens (ST.unpack expr))
pushToClients clients $ object [ "refreshoutput" .= True ]
case t of
Left error -> do
let jserr = jsonerror expr (cleanShow error)
liftIO $ modifyMVar_ (ref y) $ \x -> return (x ++ [jserr])
jsonToRepJson jserr
Right displayres -> do
let jsres = jsonresult expr displayres
liftIO $ modifyMVar_ (ref y) $ \x -> return (x ++ [jsres])
jsonToRepJson jsres
interpretHint :: (Typeable a, MonadInterpreter m) => String -> m a
interpretHint expr = set [ languageExtensions := (NoMonomorphismRestriction:ExtendedDefaultRules:glasgowExtensions) ] >> interpret expr as
moduleHint :: MonadInterpreter m => String -> FilePath -> m [ModuleName]
moduleHint ms cachedir = do
-- save the file
liftIO . putStrLn $ "calling cachedir with " ++ cachedir ++ " and " ++ (take 50 ms)
liftIO $ cacheFile cachedir ms
let allfiles = ["Helper.hs", "Main.hs"]
reset
liftIO $ putStrLn $ "will be loading " ++ (show $ map (cachedir ++) allfiles)
loadModules $ map (cachedir ++) allfiles
ms <- getLoadedModules
setTopLevelModules ms
setImports $ ["Prelude", "Network.Web.GHCLive.Display", "Text.Blaze"] ++ ms
return ms
-- eval :: String -> Interpret String
-- eval "something" ~= interpret "(show something) (as :: String)"
{-----------------------------------------------------------------------------
Interpreter abstraction
------------------------------------------------------------------------------}
newHint :: IO Hint
newHint = newRun $ \a -> void $ runInterpreter (liftIO restoreHandlers >> a)
performHint :: Hint -> InterpreterT IO a -> IO (Either InterpreterError a)
performHint hint act = perform hint $ (Right `liftM` act) `catchError` (return . Left)
{-
loadFile :: Hint -> FilePath -> IO ()
loadFile w filepath = perform w $ do
evaluate :: Hint -> String -> IO String
evaluate w expr = perform w $ do
-- stopInterpreter :: Hint -> IO ()
-}
-- | Thread responsible for "running" a monad that can do IO.
perform :: MonadIO m => Run m -> m a -> IO a
perform run act = do
ref <- newEmptyMVar
putMVar (vRequest run) $ do
a <- act
liftIO $ putMVar ref a
takeMVar ref
newRun :: MonadIO m => (m () -> IO ()) -> IO (Run m)
newRun f = do
vRequest <- newEmptyMVar
forkIO . f . forever $ do
act <- liftIO $ takeMVar vRequest
act
return Run { vRequest = vRequest }
cleanShow :: InterpreterError -> String
cleanShow ie = case ie of
UnknownError e -> "UnknownError\n" ++ e
WontCompile es -> unlines $ map errMsg es
NotAllowed e -> "NotAllowed\n" ++ e
GhcException e -> "GhcException\n" ++ e
cacheFile cachedir f = do
putStrLn $ "cachedir is " ++ cachedir
putStrLn $ "text is " ++ (take 50 f)
writeFile (cachedir ++ "Main.hs") f
return "Main.hs"
liveLayout :: Widget -> Handler RepHtml
liveLayout w = do
p <- widgetToPageContent w
hamletToRepHtml [hamlet|$newline never
$doctype 5
<html>
<head>
<title>GHCLive
^{pageHead p}
<body>
^{pageBody p}
|]
helperFile :: BS.ByteString
helperFile = $(embedFile "cache/Helper.hs")
{-- shared editor --}
getEditR :: Handler RepHtml
getEditR = liveLayout $ do
addScript (StaticR jquery_js)
addScript (StaticR codemirror_lib_codemirror_js)
addScript (StaticR codemirror_mode_haskell_haskell_js)
addScript (StaticR document_js)
addStylesheet (StaticR codemirror_lib_codemirror_css)
addStylesheet (StaticR foo_css)
addScript (StaticR jquery_ui_1_8_23_custom_min_js)
addStylesheet (StaticR jquery_ui_1_8_23_custom_css)
addScript (StaticR jquery_layout_latest_js)
addScript (StaticR jquery_scrollTo_js)
addScript (StaticR ghclive_js)
toWidget [lucius|
#editor {
width: 800px;
height: 500px;
}
|]
[whamlet|$newline never
<div id="editor-pane" class="ui-layout-north">
<div class="ui-layout-content">
<textarea #editor>
<form action="#">
<input type=submit value="Load shared document" #load>
<div class="ui-layout-center">
<div #editormessages>
<div #output class="ui-layout-content">
<div class="ui-layout-south">
<form id="evalform" action="#">
<div id="eval-panel">
<input type=text placeholder="Enter a Haskell expression" #expr>
<div class="ui-layout-west">
<div class="ui-layout-east">
|]
insertAtom :: AtomId -> AtomId -> Char -> Document -> Document
insertAtom after aid ch d = go xs
where
xs = drop 1 $ SM.toListFrom after d
go [] = d SM.|> (aid, mkTa ch)
go ((y,_):ys) | aid < y = go xs
| otherwise = SM.insertBefore y (aid, mkTa ch) d
removeAtom :: AtomId -> Timestamp -> Document -> Document
removeAtom a time = SM.adjust (\(TextAtom ch _) -> TextAtom ch (Just time)) a
-- |'getTimestamp' returns the timestamp in milliseconds
getTimestamp :: MonadIO m => m Timestamp
getTimestamp = liftIO $ liftM (Timestamp . round . (*1000) . utcTimeToPOSIXSeconds) getCurrentTime
{-
collectGarbage :: Integer -> Document -> Document
collectGarbage time d = SM.removeAll ks d
where
ks = filter ((< time) . aiTime) (SM.keys d)
-}
t :: Text -> Text
t = id
mkClientId :: MonadIO m => Editor -> m ClientId
mkClientId e = liftIO (modifyMVar (unique e) $ \u -> let u' = succ u in return (u',u'))
pushToClients :: MonadIO m => Map ClientId Client -> J.Value -> m ()
pushToClients cs msg = do
forM_ (M.elems cs) $ \c -> liftIO (writeChan (clientChan c) msg)
applyOps :: MonadIO m => Editor -> [Operation] -> m ()
applyOps e ops = do
mapM_ (applyOp e) ops
(_, clients) <- liftIO $ readMVar (doc e)
pushToClients clients $ J.toJSON (OpBlock ops)
applyOp :: MonadIO m => Editor -> Operation -> m ()
applyOp e (InsertAfter a0 ai ch) = liftIO $ modifyMVar_ (doc e) $ \(d,clients) -> do
let d' = insertAtom a0 ai ch d
return (d',clients)
applyOp e (Remove a) = liftIO $ modifyMVar_ (doc e) $ \(d,clients) -> do
time <- getTimestamp
let d' = removeAtom a time d
return (d', clients)
instance J.FromJSON OpBlock where
parseJSON (J.Object o) = OpBlock <$> o .: "actions"
parseJSON _ = mzero
instance J.ToJSON OpBlock where
toJSON (OpBlock ops) = J.object [ "actions" .= ops ]
instance J.FromJSON Operation where
parseJSON (J.Object o) = do
a <- o .: "action"
case () of
() | a == t"insert" -> InsertAfter <$> o .: "after" <*> o .: "id" <*> o .: "ch"
() | a == t"remove" -> Remove <$> o .: "atom"
() | otherwise -> mzero
parseJSON _ = mzero
instance J.ToJSON Operation where
toJSON (InsertAfter after aid ch) = J.object [ "action" .= t"insert", "after" .= after, "id" .= aid, "ch" .= ch ]
toJSON (Remove aid) = J.object [ "action" .= t"remove", "id" .= aid]
---
receiveJson :: J.FromJSON a => WS.WebSockets WS.Hybi00 a
receiveJson = do
bs <- WS.receiveData
case J.decode' bs of
Nothing -> sendJson (jsonError "invalid message") >> receiveJson
Just a -> return a
sendJson :: J.ToJSON a => a -> WS.WebSockets WS.Hybi00 ()
sendJson j = do
msg <- mkJsonMsg (J.toJSON j)
WS.sendTextData (LTE.decodeUtf8 $ J.encode msg)
sendSinkJson :: (MonadIO m, J.ToJSON a) => WS.Sink WS.Hybi00 -> a -> m ()
sendSinkJson sink j = do
msg <- mkJsonMsg (J.toJSON j)
liftIO $ WS.sendSink sink $ WS.textData (LTE.decodeUtf8 $ J.encode msg)
-- if we send an object, and it does not have a time field, inject it
mkJsonMsg :: MonadIO m => Value -> m J.Value
mkJsonMsg (J.Object o) | not (HM.member "time" o) = do
t <- getTimestamp
return $ J.Object (HM.insert "time" (J.toJSON t) o)
mkJsonMsg x = return x
jsonError :: String -> J.Value
jsonError msg = J.object [ "error" .= msg ]
sockets :: Editor -> WS.Request -> WS.WebSockets WS.Hybi00 ()
sockets y req
| WS.requestPath req == "/edit" = accept editSocket
| otherwise = WS.rejectRequest req "Not found"
where
accept a = WS.acceptRequest req >> a y
editSocket :: Editor -> WS.WebSockets WS.Hybi00 ()
editSocket e = do
client <- mkClientId e
sendInit e client
sink <- WS.getSink
ch <- liftIO newChan
t <- liftIO getTimestamp
liftIO $ addClient e (Client t client ch)
tid <- liftIO . forkIO . forever $ do
acts <- readChan ch
sendSinkJson sink acts
forever $ do
(OpBlock acts) <- receiveJson
liftIO $ applyOps e acts
return ()
liftIO $ removeClient e client
return ()
addClient :: Editor -> Client -> IO ()
addClient e c = modifyMVar_ (doc e) $ \(d, m) -> return (d, M.insert (clientId c) c m)
removeClient :: Editor -> ClientId -> IO ()
removeClient e cid = modifyMVar_ (doc e) $ \(d, m) -> return (d, M.delete cid m)
-- encode the whole document
currentVersion :: Document -> Value
currentVersion d =
let xs = SM.toList d
encodeAtom (a,v) = J.toJSON [ J.toJSON (aiTime a)
, J.toJSON (aiClient a)
, J.toJSON (taCh v)
, J.toJSON (isJust $ taRemoved v)
]
in J.toJSON $ map encodeAtom xs
sendInit :: Editor -> ClientId -> WS.WebSockets WS.Hybi00 ()
sendInit e c = do
d <- liftIO (readMVar $ doc e)
sendJson $ actions [ J.object [ "action" .= t"clientid", "clientId" .= c]
, J.object [ "action" .= t"doc", "doc" .= currentVersion (fst d) ]
]
actions :: [J.Value] -> J.Value
actions as = J.object ["actions" .= as ]