diff --git a/builder/src/Elm/Outline.hs b/builder/src/Elm/Outline.hs index 9ec4ea50f..2df455dce 100644 --- a/builder/src/Elm/Outline.hs +++ b/builder/src/Elm/Outline.hs @@ -202,7 +202,7 @@ read root shouldCheckLamdera = then Left Exit.OutlineNoPkgCore else Right outline - App (AppOutline _ srcDirs direct indirect _ _) + App (AppOutline version srcDirs@(NE.List srcHead srcTail) direct indirect testDirect testIndirect) | Map.notMember Pkg.core direct -> return $ Left Exit.OutlineNoAppCore @@ -219,8 +219,9 @@ read root shouldCheckLamdera = do maybeDups <- detectDuplicates root (NE.toList srcDirs) case maybeDups of Nothing -> + let newSrcDirs = NE.List srcHead (AbsoluteSrcDir (Lamdera.lamderaCache root) : srcTail) in Lamdera.alternativeImplementationPassthrough (Lamdera.Checks.runChecks root shouldCheckLamdera direct) $ - return $ Right outline + return $ Right (App (AppOutline version newSrcDirs direct indirect testDirect testIndirect)) Just (canonicalDir, (dir1,dir2)) -> return $ Left (Exit.OutlineHasDuplicateSrcDirs canonicalDir dir1 dir2) diff --git a/extra/Lamdera/CLI/Live.hs b/extra/Lamdera/CLI/Live.hs index 5fcc7b827..cc58bc598 100644 --- a/extra/Lamdera/CLI/Live.hs +++ b/extra/Lamdera/CLI/Live.hs @@ -11,31 +11,27 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import qualified Data.Text as T import qualified Data.Text.Lazy as TL -import qualified Data.Text.IO as T -import qualified Data.Text.Encoding as T -import qualified Data.Text.Lazy.Encoding as TL -import qualified Data.Text.Lazy.Builder as TLB +import qualified Data.Text.Encoding as TE +import qualified Data.Text.Lazy.Encoding as TLE import qualified Data.Map as Map import qualified Data.HashMap.Strict as HashMap import qualified Data.List as List +import Data.Maybe (fromMaybe) import GHC.Word (Word64) import qualified System.Directory as Dir -import System.FilePath as FP +import System.FilePath ((), takeExtension) import Control.Applicative ((<|>)) import Control.Arrow ((***)) -import Control.Concurrent.STM (atomically, newTVarIO, readTVar, writeTVar, TVar) -import Control.Exception (finally, throw) -import Language.Haskell.TH (runIO) +import Control.Concurrent.STM (atomically, newTVarIO, readTVar, readTVarIO, writeTVar, TVar) +import Control.Exception (finally) +import qualified Language.Haskell.TH as TH import Data.FileEmbed (bsToExp) import qualified Data.Aeson.Encoding as A import Snap.Core hiding (path, headers) -import qualified Data.CaseInsensitive as CI (original, mk) -import qualified Data.Bifunctor (first) +import qualified Data.CaseInsensitive as CI -import qualified Develop.Generate.Help as Generate -import qualified Develop.StaticFiles as StaticFiles import qualified Json.Decode as D import qualified Json.Encode as E import qualified Json.String @@ -45,19 +41,15 @@ import Lamdera import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID import BroadcastChan -import Control.Timeout -import Data.Time.Clock (getCurrentTime, diffUTCTime) -import qualified Network.WebSockets as WS +import Control.Timeout (timeout) import qualified Network.WebSockets.Snap as WS import SocketServer -import Data.Word (Word8) -import System.Process -import System.Entropy +import System.Entropy (getEntropy) import Snap.Util.FileServe ( - getSafePath, serveDirectoryWith, defaultDirectoryConfig, defaultMimeTypes, mimeTypes, MimeMap, DirectoryConfig + getSafePath, serveDirectoryWith, defaultDirectoryConfig, defaultMimeTypes, mimeTypes, DirectoryConfig ) -import Control.Monad (guard, void) +import Control.Monad (guard) import qualified Lamdera.CLI.Check import qualified Lamdera.Relative @@ -91,7 +83,7 @@ withEnd (mClients, mLeader, mChan, beState) io = do let end = do debug "[backendSt] 🧠" - text <- atomically $ readTVar beState + text <- readTVarIO beState bePath <- lamderaBackendDevSnapshotPath writeUtf8 bePath text @@ -133,10 +125,7 @@ serveUnmatchedUrlsToIndex root serveElm = prepareLocalDev :: FilePath -> IO FilePath prepareLocalDev root = do - overrideM <- Lamdera.Relative.readFile "extra/LocalDev/LocalDev.elm" - let - cache = lamderaCache root - harnessPath = cache "LocalDev.elm" + overrideM <- Lamdera.Relative.readDir TE.decodeUtf8 "extra/LocalDev/runtime-src" -- This needs to be moved to an on-demand action, as it has to query production and -- thus isn't appropriate to run on every single recompile @@ -145,22 +134,23 @@ prepareLocalDev root = do rpcExists <- doesFileExist $ root "src" "RPC.elm" - case overrideM of - Just override -> do - writeIfDifferent harnessPath - (override - & replaceVersionMarker - & replaceRpcMarker rpcExists - ) + let + cache = lamderaCache root + harnessPath = "LocalDev.elm" + + patchedContent path content = + if path == harnessPath + then content & replaceVersionMarker & replaceRpcMarker rpcExists + else content + + processFile (path, content) = + writeIfDifferent (cache path) $ patchedContent path content + + files = fromMaybe lamderaLocalDevDir overrideM - Nothing -> - writeIfDifferent harnessPath - (lamderaLocalDev - & replaceVersionMarker - & replaceRpcMarker rpcExists - ) + mapM_ processFile files - pure harnessPath + pure $ cache harnessPath replaceVersionMarker :: Text -> Text @@ -205,9 +195,13 @@ replaceRpcMarker shouldReplace localdev = \ {-}" -lamderaLocalDev :: Text -lamderaLocalDev = - T.decodeUtf8 $(bsToExp =<< runIO (Lamdera.Relative.readByteString "extra/LocalDev/LocalDev.elm")) +lamderaLocalDevDir :: [(FilePath, Text)] +lamderaLocalDevDir = + $(do + bsPairs <- TH.runIO (Lamdera.Relative.readDir id "extra/LocalDev/runtime-src") + let toTuple (fp, bs) = [| (fp, TE.decodeUtf8 $(bsToExp bs)) |] + TH.ListE <$> mapM toTuple (fromMaybe [] bsPairs) + ) refreshClients (mClients, mLeader, mChan, beState) = @@ -229,10 +223,10 @@ serveWebsocket root (mClients, mLeader, mChan, beState) = let cookie = Cookie "sid" newSid Nothing Nothing Nothing False False modifyResponse $ addResponseCookie cookie - pure $ T.decodeUtf8 $ newSid + pure $ TE.decodeUtf8 $ newSid Just sid_ -> - pure $ T.decodeUtf8 $ cookieValue sid_ + pure $ TE.decodeUtf8 $ cookieValue sid_ case mKey of Just key -> do @@ -252,14 +246,14 @@ serveWebsocket root (mClients, mLeader, mChan, beState) = onlyWhen leaderChanged $ do sendToLeader mClients mLeader (\leader -> do -- Tell the new leader about the backend state they need - atomically $ readTVar beState + readTVarIO beState ) -- Tell everyone about the new leader (also causes actual leader to go active as leader) broadcastLeader mClients mLeader SocketServer.broadcastImpl mClients $ "{\"t\":\"c\",\"s\":\"" <> sessionId <> "\",\"c\":\"" <> clientId <> "\"}" - leader <- atomically $ readTVar mLeader + leader <- readTVarIO mLeader case leader of Just leaderId -> pure $ Just $ "{\"t\":\"s\",\"c\":\"" <> clientId <> "\",\"l\":\"" <> leaderId <> "\"}" @@ -308,7 +302,7 @@ serveWebsocket root (mClients, mLeader, mChan, beState) = SocketServer.broadcastImpl mClients text WS.runWebSocketsSnap $ - SocketServer.socketHandler mClients mLeader beState onJoined onReceive (T.decodeUtf8 key) sessionId + SocketServer.socketHandler mClients mLeader beState onJoined onReceive (TE.decodeUtf8 key) sessionId Nothing -> error404 "missing sec-websocket-key header" @@ -399,9 +393,9 @@ serveExperimentalWrite root path = do Just "image/jpeg" -> Lamdera.writeBinary fullpath rbody _ -> - writeIfDifferent fullpath (TL.toStrict $ TL.decodeUtf8 rbody) + writeIfDifferent fullpath (TL.toStrict $ TLE.decodeUtf8 rbody) - jsonResponse $ B.byteString $ "{ written: '" <> T.encodeUtf8 (T.pack fullpath) <> "'}" + jsonResponse $ B.byteString $ "{ written: '" <> TE.encodeUtf8 (T.pack fullpath) <> "'}" serveExperimentalList :: FilePath -> Text -> Snap () @@ -543,10 +537,10 @@ serveRpc (mClients, mLeader, mChan, beState) port = do let cookie = Cookie "sid" newSid Nothing Nothing Nothing False False modifyResponse $ addResponseCookie cookie - pure $ T.decodeUtf8 $ newSid + pure $ TE.decodeUtf8 $ newSid Just sid_ -> - pure $ T.decodeUtf8 $ cookieValue sid_ + pure $ TE.decodeUtf8 $ cookieValue sid_ onlyWhen (mEndpoint == Nothing) $ error500 "no endpoint present" @@ -570,10 +564,10 @@ serveRpc (mClients, mLeader, mChan, beState) port = do -- Unfortunately the JSON string encoding logic is hidden inside Data.Aeson.Encoding.Internal -- so off we go with all the silly format hops escapeJsonString :: Text -> Text - escapeJsonString t = A.text t & A.encodingToLazyByteString & BSL.toStrict & T.decodeUtf8 + escapeJsonString t = A.text t & A.encodingToLazyByteString & BSL.toStrict & TE.decodeUtf8 escapedBody = - rbody & TL.decodeUtf8 & TL.toStrict & escapeText + rbody & TLE.decodeUtf8 & TL.toStrict & escapeText escapeText :: Text -> E.Value escapeText t = @@ -588,14 +582,14 @@ serveRpc (mClients, mLeader, mChan, beState) port = do E.object [ ("t", E.string "q") , ("s", E.text sid) - , ("e", E.text $ T.decodeUtf8 endpoint) + , ("e", E.text $ TE.decodeUtf8 endpoint) , ("r", E.text reqId) , ("h", E.String $ Ext.Common.textToBuilder $ encodeToText requestHeadersJson) , value ] & encodeToText - encodeToText encoder = encoder & E.encode & B.toLazyByteString & BSL.toStrict & T.decodeUtf8 + encodeToText encoder = encoder & E.encode & B.toLazyByteString & BSL.toStrict & TE.decodeUtf8 requestPayload = case contentType of @@ -619,14 +613,14 @@ serveRpc (mClients, mLeader, mChan, beState) port = do values = case vals of [] -> "null" - val:[] -> T.concat ["\"", (T.decodeUtf8 val & escapeJsonString), "\""] + val:[] -> T.concat ["\"", (TE.decodeUtf8 val & escapeJsonString), "\""] _ -> vals - & fmap (\v -> T.concat ["\"", (T.decodeUtf8 v & escapeJsonString), "\""]) + & fmap (\v -> T.concat ["\"", (TE.decodeUtf8 v & escapeJsonString), "\""]) & T.intercalate "," & (\v -> T.concat ["[", v, "]"]) in - T.concat ["\"", T.decodeUtf8 key, "\":", values] + T.concat ["\"", TE.decodeUtf8 key, "\":", values] ) & (\v -> T.concat ["{", (v & T.intercalate ","), "}"]) in @@ -648,7 +642,7 @@ serveRpc (mClients, mLeader, mChan, beState) port = do | otherwise -> loopRead Nothing -> loopRead - leader <- liftIO $ atomically $ readTVar mLeader + leader <- liftIO $ readTVarIO mLeader case leader of Just leaderId -> do liftIO $ sendToLeader mClients mLeader (\leader_ -> pure requestPayload) @@ -672,12 +666,12 @@ serveRpc (mClients, mLeader, mChan, beState) port = do ]) decodeResult = - D.fromByteString decoder (T.encodeUtf8 chanText) + D.fromByteString decoder (TE.encodeUtf8 chanText) case decodeResult of Right (statusCode, statusText, headers, (bodyType, bodyEncoded)) -> do - let response = TL.toStrict $ TL.decodeUtf8 $ B.toLazyByteString bodyEncoded + let response = TL.toStrict $ TLE.decodeUtf8 $ B.toLazyByteString bodyEncoded debugT $ "RPC:↙️ response:" <> response debug $ show (statusCode, statusText) onlyWhen (bodyType == "i") (modifyResponse $ setContentType "application/octet-stream") @@ -694,12 +688,12 @@ serveRpc (mClients, mLeader, mChan, beState) port = do Left jsonProblem -> do debugT $ "😢 rpc response decoding failed: " <> show_ jsonProblem <> "\n" <> chanText - writeBuilder $ B.byteString $ "rpc response decoding failed for " <> T.encodeUtf8 chanText + writeBuilder $ B.byteString $ "rpc response decoding failed for " <> TE.encodeUtf8 chanText Nothing -> do debugT $ "⏰ RPC timed out for:" <> requestPayload - writeBuilder $ B.byteString $ T.encodeUtf8 $ "error:timeout:" <> show_ seconds <> "s" + writeBuilder $ B.byteString $ TE.encodeUtf8 $ "error:timeout:" <> show_ seconds <> "s" Nothing -> do @@ -721,7 +715,7 @@ _10MB = logger :: BS.ByteString -> IO () logger = (\bs -> - atomicPutStrLn $ T.unpack $ T.decodeUtf8 bs + atomicPutStrLn $ T.unpack $ TE.decodeUtf8 bs ) jsonResponse :: B.Builder -> Snap () diff --git a/extra/Lamdera/Relative.hs b/extra/Lamdera/Relative.hs index 553a0b3d9..84b98c367 100644 --- a/extra/Lamdera/Relative.hs +++ b/extra/Lamdera/Relative.hs @@ -1,9 +1,11 @@ +{-# LANGUAGE TupleSections #-} module Lamdera.Relative where import qualified Data.ByteString as BS import qualified System.Directory as Dir import System.FilePath (()) import qualified Data.List as List +import Control.Monad (forM) import Lamdera @@ -39,6 +41,24 @@ findFile path_ = do pure Nothing +findDir :: String -> IO (Maybe FilePath) +findDir path_ = do + path <- resolveHome path_ + dirExists <- doesDirectoryExist path + if dirExists + then Just <$> Dir.makeAbsolute path + else do + -- We're likely using a GHCI build mode that's changed our currentDirectory, so now Haskell is confused. + -- Only thing we can really do now is guess from a standard-ish location relative to home + absPath <- prefixCompilerPath path + exists2 <- doesDirectoryExist absPath + if exists2 + then pure (Just absPath) + else do + debug $ "🔎 findDir: could not find a relative path, sought at:\n" <> path_ <> " -> " <> path <> "\n" <> absPath + pure Nothing + + readFile :: String -> IO (Maybe Text) readFile path = do found <- findFile path @@ -47,6 +67,28 @@ readFile path = do Nothing -> pure Nothing +readDir :: (BS.ByteString -> a) -> String -> IO (Maybe [(FilePath, a)]) +readDir bsMapper path = do + found <- findDir path + case found of + Just absPath -> Just <$> readDirHelp bsMapper absPath "" + Nothing -> pure Nothing + + +readDirHelp :: (BS.ByteString -> a) -> FilePath -> FilePath -> IO [(FilePath, a)] +readDirHelp bsMapper absPath relPath = do + contents <- Dir.listDirectory absPath + fmap concat $ forM contents $ \entry -> do + let newAbsPath = absPath entry + newRelPath = relPath entry + isDir <- Dir.doesDirectoryExist newAbsPath + if isDir + then readDirHelp bsMapper newAbsPath newRelPath + else do + content <- BS.readFile newAbsPath + pure [(newRelPath, bsMapper content)] + + readByteString :: FilePath -> IO BS.ByteString readByteString path = do fullPath <- requireFile "readByteString" path @@ -70,19 +112,11 @@ requireFile identifier path = do requireDir :: String -> IO FilePath -requireDir path_ = do - path <- resolveHome path_ - dirExists <- doesDirectoryExist path - if dirExists - then Dir.makeAbsolute path - else do - -- We're likely using a GHCI build mode that's changed our currentDirectory, so now Haskell is confused. - -- Only thing we can really do now is guess from a standard-ish location relative to home - absPath <- prefixCompilerPath path - exists2 <- doesDirectoryExist absPath - if exists2 - then pure absPath - else error $ "requireDir: could not find a relative path, seeking at:\n" <> path <> "\n" <> absPath +requireDir path = do + found <- findDir path + case found of + Just absPath -> pure absPath + Nothing -> error $ "❌ requireDir: could not find a relative path, seeking at:\n" <> path resolveHome :: String -> IO FilePath diff --git a/extra/LocalDev/Env.elm b/extra/LocalDev/Env.elm deleted file mode 100644 index 757230821..000000000 --- a/extra/LocalDev/Env.elm +++ /dev/null @@ -1,5 +0,0 @@ -module Env exposing (..) - - -empty = - "" diff --git a/extra/LocalDev/elm.json b/extra/LocalDev/elm.json index 6d3762349..ff6a5b07b 100644 --- a/extra/LocalDev/elm.json +++ b/extra/LocalDev/elm.json @@ -1,25 +1,26 @@ { "type": "application", "source-directories": [ - "" + "runtime-src", + "tooling-src" ], "elm-version": "0.19.1", "dependencies": { "direct": { "elm/browser": "1.0.2", + "elm/bytes": "1.0.8", "elm/core": "1.0.5", "elm/html": "1.0.0", - "elm/http": "2.0.0", - "elm/json": "1.1.3", - "elm/time": "1.0.0", "elm/url": "1.0.0", "lamdera/codecs": "1.0.0", "lamdera/core": "1.0.0" }, "indirect": { - "elm/bytes": "1.0.8", "elm/file": "1.0.5", - "elm/virtual-dom": "1.0.2" + "elm/http": "2.0.0", + "elm/json": "1.1.3", + "elm/time": "1.0.0", + "elm/virtual-dom": "1.0.3" } }, "test-dependencies": { diff --git a/extra/LocalDev/elmjutsu-config.json b/extra/LocalDev/elmjutsu-config.json index fba567a6e..611deb994 100644 --- a/extra/LocalDev/elmjutsu-config.json +++ b/extra/LocalDev/elmjutsu-config.json @@ -1 +1 @@ -{"mainPaths":["LocalDev.elm"]} +{"mainPaths":["runtime-src/LocalDev.elm"]} diff --git a/extra/LocalDev/readme.md b/extra/LocalDev/readme.md index c3b82cc01..0d76b0b9d 100644 --- a/extra/LocalDev/readme.md +++ b/extra/LocalDev/readme.md @@ -1,5 +1,6 @@ -The LocalDev.elm file here is what gets paged in as the entry point for `lamdera live`. +The runtime-src/LocalDev.elm file is what gets paged in as the entry point for `lamdera live`. +It may import other files from the runtime-src directory. -No other files in this folder are used in the final compiler build, they are only here -to assist editor tooling when developing LocalDev.elm. +The files in tooling-src are not used in the final compiler build, they are only here +to assist editor tooling when developing runtime-src/LocalDev.elm. diff --git a/extra/LocalDev/LocalDev.elm b/extra/LocalDev/runtime-src/LocalDev.elm similarity index 100% rename from extra/LocalDev/LocalDev.elm rename to extra/LocalDev/runtime-src/LocalDev.elm diff --git a/extra/LocalDev/Backend.elm b/extra/LocalDev/tooling-src/Backend.elm similarity index 100% rename from extra/LocalDev/Backend.elm rename to extra/LocalDev/tooling-src/Backend.elm diff --git a/extra/LocalDev/tooling-src/Env.elm b/extra/LocalDev/tooling-src/Env.elm new file mode 100644 index 000000000..ecd798171 --- /dev/null +++ b/extra/LocalDev/tooling-src/Env.elm @@ -0,0 +1,10 @@ +module Env exposing (..) + + +mode = + Development + + +type Mode + = Development + | Production diff --git a/extra/LocalDev/Frontend.elm b/extra/LocalDev/tooling-src/Frontend.elm similarity index 100% rename from extra/LocalDev/Frontend.elm rename to extra/LocalDev/tooling-src/Frontend.elm diff --git a/extra/LocalDev/Types.elm b/extra/LocalDev/tooling-src/Types.elm similarity index 100% rename from extra/LocalDev/Types.elm rename to extra/LocalDev/tooling-src/Types.elm diff --git a/extra/SocketServer.hs b/extra/SocketServer.hs index ba9458484..62d0bcf57 100644 --- a/extra/SocketServer.hs +++ b/extra/SocketServer.hs @@ -66,7 +66,7 @@ socketHandler mClients mLeader beState onJoined onReceive clientId sessionId pen onlyWhen leaderChanged $ do sendToLeader mClients mLeader (\leader -> do -- Tell the new leader about the backend state they need - atomically $ readTVar beState + readTVarIO beState ) -- Tell everyone about the new leader (also causes actual leader to go active as leader) broadcastLeader mClients mLeader @@ -105,7 +105,7 @@ getNextLeader clients = broadcastLeader :: TVar [Client] -> TVar (Maybe ClientId) -> IO () broadcastLeader mClients mLeader = do - leader <- atomically $ readTVar mLeader + leader <- readTVarIO mLeader case leader of Just leaderId -> broadcastImpl mClients $ "{\"t\":\"e\",\"l\":\"" <> leaderId <> "\"}" @@ -116,7 +116,7 @@ broadcastLeader mClients mLeader = do sendToLeader :: TVar [Client] -> TVar (Maybe ClientId) -> (ClientId -> IO Text) -> IO () sendToLeader mClients mLeader fn = do - leader <- atomically $ readTVar mLeader + leader <- readTVarIO mLeader case leader of Just leaderId -> do text <- fn leaderId @@ -147,13 +147,13 @@ type Client = (ClientId, WS.Connection) sendImpl :: TVar [Client] -> ClientId -> T.Text -> IO () sendImpl mClients clientId message = do - clients <- atomically $ readTVar mClients + clients <- readTVarIO mClients send_ clients clientId message broadcastImpl :: TVar [Client] -> T.Text -> IO () broadcastImpl mClients message = do - clients <- atomically $ readTVar mClients + clients <- readTVarIO mClients broadcast_ clients message diff --git a/terminal/src/Develop.hs b/terminal/src/Develop.hs index d4f2217ba..6afc9ae52 100644 --- a/terminal/src/Develop.hs +++ b/terminal/src/Develop.hs @@ -113,10 +113,10 @@ runWithRoot root (Flags maybePort) = Filewatch.watch root recompile whenDebug $ do - -- Watch LocalDev.elm changes when in Debug mode to assist with development + -- Watch LocalDev changes when in Debug mode to assist with development home <- Dir.getHomeDirectory - let override = home <> "/dev/projects/lamdera-compiler/extra/LocalDev/LocalDev.elm" - onlyWhen_ (doesFileExist override) $ do + let override = home <> "/dev/projects/lamdera-compiler/extra/LocalDev" + onlyWhen_ (doesDirectoryExist override) $ do Filewatch.watchFile override recompile Lamdera.ReverseProxy.start