{-# 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 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 ]