26a195b8c7
* Support GHC 9.4 * tidy it on up * ok tests pass again * weird * woo * Changelog, cabal files * fix for older cabal * Drop MacOS from older resolvers https://github.com/bravit/hid-examples/issues/7#issuecomment-781308838 * oops
534 lines
22 KiB
Haskell
534 lines
22 KiB
Haskell
{-# LANGUAGE ScopedTypeVariables #-}
|
|
{-# LANGUAGE CPP #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
module Devel
|
|
( devel
|
|
, develSignal
|
|
, DevelOpts(..)
|
|
) where
|
|
|
|
import Control.Applicative ((<|>))
|
|
import UnliftIO (race_)
|
|
import Control.Concurrent (threadDelay)
|
|
import Control.Concurrent.STM
|
|
import qualified UnliftIO.Exception as Ex
|
|
import Control.Monad (forever, unless, void,
|
|
when)
|
|
import Data.ByteString (ByteString, isInfixOf)
|
|
import qualified Data.ByteString.Lazy as LB
|
|
import Conduit
|
|
import Data.FileEmbed (embedFile)
|
|
import qualified Data.Map as Map
|
|
import Data.Maybe (isJust)
|
|
import qualified Data.Set as Set
|
|
import Data.Streaming.Network (bindPortTCP,
|
|
bindRandomPortTCP)
|
|
import Data.String (fromString)
|
|
import Data.Time (getCurrentTime)
|
|
import qualified Distribution.Package as D
|
|
import qualified Distribution.PackageDescription as D
|
|
#if MIN_VERSION_Cabal(3,8,0)
|
|
import qualified Distribution.Simple.PackageDescription as D
|
|
#endif
|
|
#if MIN_VERSION_Cabal(2, 2, 0)
|
|
import qualified Distribution.PackageDescription.Parsec as D
|
|
#else
|
|
import qualified Distribution.PackageDescription.Parse as D
|
|
#endif
|
|
import qualified Distribution.Simple.Utils as D
|
|
import qualified Distribution.Verbosity as D
|
|
import Network.HTTP.Client (newManager)
|
|
import Network.HTTP.Client (managerSetProxy,
|
|
noProxy)
|
|
import Network.HTTP.Client.TLS (tlsManagerSettings)
|
|
import Network.HTTP.ReverseProxy (ProxyDest (ProxyDest),
|
|
waiProxyToSettings,
|
|
wpsOnExc, wpsTimeout,
|
|
#if MIN_VERSION_http_reverse_proxy(0, 6, 0)
|
|
defaultWaiProxySettings
|
|
#else
|
|
def
|
|
#endif
|
|
)
|
|
import qualified Network.HTTP.ReverseProxy as ReverseProxy
|
|
import Network.HTTP.Types (status200, status503)
|
|
import qualified Network.Socket
|
|
import Network.Wai (requestHeaderHost,
|
|
requestHeaders,
|
|
responseLBS)
|
|
import Network.Wai.Handler.Warp (defaultSettings, runSettings,
|
|
setPort, setHost)
|
|
import Network.Wai.Handler.WarpTLS (runTLS, tlsSettings,
|
|
tlsSettingsMemory)
|
|
import Network.Wai.Parse (parseHttpAccept)
|
|
import Say
|
|
import System.Directory
|
|
import System.Environment (getEnvironment,
|
|
getExecutablePath)
|
|
import System.FilePath (takeDirectory,
|
|
takeFileName, (</>))
|
|
import System.FSNotify
|
|
import System.IO (stdout, stderr)
|
|
import System.IO.Error (isDoesNotExistError)
|
|
import Data.Conduit.Process.Typed
|
|
|
|
-- We have two special files:
|
|
--
|
|
-- * The terminate file tells the child process to die simply by being
|
|
-- present. Ideally we'd handle this via killing the process
|
|
-- directly, but that's historically never worked reliably.
|
|
--
|
|
-- * The signal file, which tells us that "stack build" has succeeded
|
|
-- yet again.
|
|
data SpecialFile = TermFile | SignalFile
|
|
|
|
specialFilePath :: SpecialFile -> FilePath
|
|
|
|
-- used by scaffolded app, cannot change
|
|
specialFilePath TermFile = "yesod-devel/devel-terminate"
|
|
|
|
-- only used internally, can change
|
|
specialFilePath SignalFile = "yesod-devel/rebuild"
|
|
|
|
-- | Write a special file
|
|
writeSpecialFile :: SpecialFile -> IO ()
|
|
writeSpecialFile sp = do
|
|
let fp = specialFilePath sp
|
|
createDirectoryIfMissing True $ takeDirectory fp
|
|
now <- getCurrentTime
|
|
writeFile fp $ show now
|
|
|
|
-- | Remove a special file
|
|
removeSpecialFile :: SpecialFile -> IO ()
|
|
removeSpecialFile sp = removeFile (specialFilePath sp) `Ex.catch` \e ->
|
|
if isDoesNotExistError e
|
|
then return ()
|
|
else Ex.throwIO e
|
|
|
|
-- | Get an absolute path to the special file
|
|
canonicalizeSpecialFile :: SpecialFile -> IO FilePath
|
|
canonicalizeSpecialFile sp = do
|
|
let fp = specialFilePath sp
|
|
dir = takeDirectory fp
|
|
file = takeFileName fp
|
|
createDirectoryIfMissing True dir
|
|
dir' <- canonicalizePath dir
|
|
return $ dir' </> file
|
|
|
|
-- | Used as a callback from "stack build --exec" to write the signal file
|
|
develSignal :: IO ()
|
|
develSignal = writeSpecialFile SignalFile
|
|
|
|
-- | Options to be provided on the command line
|
|
data DevelOpts = DevelOpts
|
|
{ verbose :: Bool
|
|
, successHook :: Maybe String
|
|
, develPort :: Int
|
|
, develTlsPort :: Int
|
|
, proxyTimeout :: Int
|
|
, useReverseProxy :: Bool
|
|
, develHost :: Maybe String
|
|
, cert :: Maybe (FilePath, FilePath)
|
|
} deriving (Show, Eq)
|
|
|
|
-- | Run a reverse proxy from the develPort and develTlsPort ports to
|
|
-- the app running in appPortVar. If there is no response on the
|
|
-- application port, give an appropriate message to the user.
|
|
reverseProxy :: DevelOpts -> TVar Int -> IO ()
|
|
reverseProxy opts appPortVar = do
|
|
manager <- newManager $ managerSetProxy noProxy tlsManagerSettings
|
|
let refreshHtml = LB.fromChunks [$(embedFile "refreshing.html")]
|
|
sayV = when (verbose opts) . sayString
|
|
let onExc _ req
|
|
| maybe False (("application/json" `elem`) . parseHttpAccept)
|
|
(lookup "accept" $ requestHeaders req) =
|
|
return $ responseLBS status503
|
|
[ ("Retry-After", "1")
|
|
]
|
|
"{\"message\":\"Recompiling\"}"
|
|
| otherwise = return $ responseLBS status200
|
|
[ ("content-type", "text/html")
|
|
, ("Refresh", "1")
|
|
]
|
|
refreshHtml
|
|
|
|
let proxyApp = waiProxyToSettings
|
|
(const $ do
|
|
appPort <- atomically $ readTVar appPortVar
|
|
sayV $ "revProxy: appPort " ++ (show appPort)
|
|
return $
|
|
ReverseProxy.WPRProxyDest
|
|
$ ProxyDest "127.0.0.1" appPort)
|
|
#if MIN_VERSION_http_reverse_proxy(0, 6, 0)
|
|
defaultWaiProxySettings
|
|
#else
|
|
def
|
|
#endif
|
|
{ wpsOnExc = \e req f -> onExc e req >>= f
|
|
, wpsTimeout =
|
|
if proxyTimeout opts == 0
|
|
then Nothing
|
|
else Just (1000000 * proxyTimeout opts)
|
|
}
|
|
manager
|
|
defaultSettings' = maybe id (setHost . fromString) (develHost opts) defaultSettings
|
|
runProxyTls port app = do
|
|
let certDef = $(embedFile "certificate.pem")
|
|
keyDef = $(embedFile "key.pem")
|
|
theSettings = case cert opts of
|
|
Nothing -> tlsSettingsMemory certDef keyDef
|
|
Just (c,k) -> tlsSettings c k
|
|
runTLS theSettings (setPort port defaultSettings') $ \req send -> do
|
|
let req' = req
|
|
{ requestHeaders
|
|
= ("X-Forwarded-Proto", "https")
|
|
-- Workaround for
|
|
-- https://github.com/yesodweb/wai/issues/478, where
|
|
-- the Host headers aren't set. Without this, generated
|
|
-- URLs from guestApproot are incorrect, see:
|
|
-- https://github.com/yesodweb/yesod-scaffold/issues/114
|
|
: (case lookup "host" (requestHeaders req) of
|
|
Nothing ->
|
|
case requestHeaderHost req of
|
|
Just host -> (("Host", host):)
|
|
Nothing -> id
|
|
Just _ -> id)
|
|
(requestHeaders req)
|
|
}
|
|
app req' send
|
|
httpProxy = runSettings (setPort (develPort opts) defaultSettings') proxyApp
|
|
httpsProxy = runProxyTls (develTlsPort opts) proxyApp
|
|
say "Application can be accessed at:\n"
|
|
sayString $ "http://localhost:" ++ show (develPort opts)
|
|
sayString $ "https://localhost:" ++ show (develTlsPort opts)
|
|
say $ "If you wish to test https capabilities, you should set the following variable:"
|
|
sayString $ " export APPROOT=https://localhost:" ++ show (develTlsPort opts)
|
|
say ""
|
|
race_ httpProxy httpsProxy
|
|
|
|
-- | Check if the given port is available.
|
|
checkPort :: Int -> IO Bool
|
|
checkPort p = do
|
|
es <- Ex.tryIO $ bindPortTCP p "*4"
|
|
case es of
|
|
Left _ -> return False
|
|
Right s -> do
|
|
Network.Socket.close s
|
|
return True
|
|
|
|
-- | Get a random, unused port.
|
|
getNewPort :: DevelOpts -> IO Int
|
|
getNewPort opts = do
|
|
(port, socket) <- bindRandomPortTCP "*"
|
|
when (verbose opts) $ sayString $ "Got new port: " ++ show port
|
|
Network.Socket.close socket
|
|
return port
|
|
|
|
-- | Utility function
|
|
unlessM :: Monad m => m Bool -> m () -> m ()
|
|
unlessM c a = c >>= \res -> unless res a
|
|
|
|
-- | Find the file containing the devel code to be run.
|
|
checkDevelFile :: IO FilePath
|
|
checkDevelFile =
|
|
loop paths
|
|
where
|
|
paths = ["app/devel.hs", "devel.hs", "src/devel.hs"]
|
|
|
|
loop [] = error $ "file devel.hs not found, checked: " ++ show paths
|
|
loop (x:xs) = do
|
|
e <- doesFileExist x
|
|
if e
|
|
then return x
|
|
else loop xs
|
|
|
|
stackSuccessString :: ByteString
|
|
stackSuccessString = "ExitSuccess"
|
|
|
|
stackFailureString :: ByteString
|
|
stackFailureString = "ExitFailure"
|
|
|
|
-- We need updateAppPort logic to prevent a race condition.
|
|
-- See https://github.com/yesodweb/yesod/issues/1380
|
|
updateAppPort :: ByteString -> TVar Bool -- ^ Bool to indicate if the
|
|
-- output from stack has
|
|
-- started. False indicate
|
|
-- that it hasn't started
|
|
-- yet.
|
|
-> TVar Int -> STM ()
|
|
updateAppPort bs buildStarted appPortVar = do
|
|
hasStarted <- readTVar buildStarted
|
|
let buildEnd = isInfixOf stackFailureString bs || isInfixOf stackSuccessString bs
|
|
case (hasStarted, buildEnd) of
|
|
(False, False) -> do
|
|
writeTVar appPortVar (-1 :: Int)
|
|
writeTVar buildStarted True
|
|
(True, False) -> return ()
|
|
(_, True) -> writeTVar buildStarted False
|
|
|
|
-- | Get the set of all flags available in the given cabal file
|
|
getAvailableFlags :: D.GenericPackageDescription -> Set.Set String
|
|
getAvailableFlags =
|
|
Set.fromList . map (unFlagName . D.flagName) . D.genPackageFlags
|
|
where
|
|
#if MIN_VERSION_Cabal(2, 0, 0)
|
|
unFlagName = D.unFlagName
|
|
#else
|
|
unFlagName (D.FlagName fn) = fn
|
|
#endif
|
|
|
|
-- | This is the main entry point. Run the devel server.
|
|
devel :: DevelOpts -- ^ command line options
|
|
-> [String] -- ^ extra options to pass to Stack
|
|
-> IO ()
|
|
devel opts passThroughArgs = do
|
|
-- Check that the listening ports are available
|
|
unlessM (checkPort $ develPort opts) $ error "devel port unavailable"
|
|
unlessM (checkPort $ develTlsPort opts) $ error "devel TLS port unavailable"
|
|
|
|
-- Friendly message to the user
|
|
say "Yesod devel server. Enter 'quit' or hit Ctrl-C to quit."
|
|
|
|
-- Find out the name of our package, needed for the upcoming Stack
|
|
-- commands
|
|
#if MIN_VERSION_Cabal(3, 0, 0)
|
|
cabal <- D.tryFindPackageDesc D.silent "."
|
|
#elif MIN_VERSION_Cabal(1, 20, 0)
|
|
cabal <- D.tryFindPackageDesc "."
|
|
#else
|
|
cabal <- D.findPackageDesc "."
|
|
#endif
|
|
|
|
#if MIN_VERSION_Cabal(2, 0, 0)
|
|
gpd <- D.readGenericPackageDescription D.normal cabal
|
|
#else
|
|
gpd <- D.readPackageDescription D.normal cabal
|
|
#endif
|
|
|
|
let pd = D.packageDescription gpd
|
|
D.PackageIdentifier packageNameWrapped _version = D.package pd
|
|
#if MIN_VERSION_Cabal(2, 0, 0)
|
|
packageName = D.unPackageName packageNameWrapped
|
|
#else
|
|
D.PackageName packageName = packageNameWrapped
|
|
#endif
|
|
|
|
-- Which file contains the code to run
|
|
develHsPath <- checkDevelFile
|
|
|
|
-- The port that we're currently listening on, and that the
|
|
-- reverse proxy should point to
|
|
appPortVar <- newTVarIO (-1)
|
|
|
|
-- If we're actually using reverse proxying, spawn off a reverse
|
|
-- proxy thread
|
|
let withRevProxy =
|
|
if useReverseProxy opts
|
|
then race_ (reverseProxy opts appPortVar)
|
|
else id
|
|
|
|
-- Run the following concurrently. If any of them exit, take the
|
|
-- whole thing down.
|
|
--
|
|
-- We need to put withChangedVar outside of all this, since we
|
|
-- need to ensure we start watching files before the stack build
|
|
-- loop starts.
|
|
withChangedVar $ \changedVar -> withRevProxy $ race_
|
|
-- Start the build loop
|
|
(runStackBuild appPortVar packageName (getAvailableFlags gpd))
|
|
|
|
-- Run the app itself, restarting when a build succeeds
|
|
(runApp appPortVar changedVar develHsPath)
|
|
where
|
|
-- say, but only when verbose is on
|
|
sayV = when (verbose opts) . sayString
|
|
|
|
-- Leverage "stack build --file-watch" to do the build
|
|
runStackBuild :: TVar Int -> [Char] -> Set.Set [Char] -> IO ()
|
|
runStackBuild appPortVar packageName availableFlags = do
|
|
-- We call into this app for the devel-signal command
|
|
myPath <- getExecutablePath
|
|
let procConfig = setStdout createSource
|
|
$ setStderr createSource
|
|
$ setCreateGroup True -- because need when yesod-bin killed and kill child ghc
|
|
$ proc "stack" $
|
|
[ "build"
|
|
, "--fast"
|
|
, "--file-watch"
|
|
|
|
-- Indicate the component we want
|
|
, packageName ++ ":lib"
|
|
|
|
-- signal the watcher that a build has succeeded
|
|
, "--exec", myPath ++ " devel-signal"
|
|
] ++
|
|
|
|
-- Turn on relevant flags
|
|
concatMap
|
|
(\flagName -> [ "--flag", packageName ++ ":" ++ flagName])
|
|
(Set.toList $ Set.intersection
|
|
availableFlags
|
|
(Set.fromList ["dev", "library-only"])) ++
|
|
|
|
-- Add the success hook
|
|
(case successHook opts of
|
|
Nothing -> []
|
|
Just h -> ["--exec", h]) ++
|
|
|
|
-- Any extra args passed on the command line
|
|
passThroughArgs
|
|
|
|
sayV $ show procConfig
|
|
buildStarted <- newTVarIO False
|
|
-- Monitor the stdout and stderr content from the build process. Any
|
|
-- time some output comes, we invalidate the currently running app by
|
|
-- changing the destination port for reverse proxying to -1. We also
|
|
-- make sure that all content to stdout or stderr from the build
|
|
-- process is piped to the actual stdout and stderr handles.
|
|
withProcess_ procConfig $ \p -> do
|
|
let helper getter h =
|
|
runConduit
|
|
$ getter p
|
|
.| iterMC (\(str :: ByteString) -> atomically (updateAppPort str buildStarted appPortVar))
|
|
.| sinkHandle h
|
|
race_ (helper getStdout stdout) (helper getStderr stderr)
|
|
|
|
-- Run the inner action with a TVar which will be set to True
|
|
-- whenever the signal file is modified.
|
|
withChangedVar :: (TVar Bool -> IO a) -> IO a
|
|
withChangedVar inner = withManager $ \manager -> do
|
|
-- Variable indicating that the signal file has been changed. We
|
|
-- reset it each time we handle the signal.
|
|
changedVar <- newTVarIO False
|
|
|
|
-- Get the absolute path of the signal file, needed for the
|
|
-- file watching
|
|
develSignalFile' <- canonicalizeSpecialFile SignalFile
|
|
|
|
-- Start watching the signal file, and set changedVar to
|
|
-- True each time it's changed.
|
|
void $ watchDir manager
|
|
-- Using fromString to work with older versions of fsnotify
|
|
-- that use system-filepath
|
|
(fromString (takeDirectory develSignalFile'))
|
|
(\e -> eventPath e == fromString develSignalFile')
|
|
(const $ atomically $ writeTVar changedVar True)
|
|
|
|
-- Run the inner action
|
|
inner changedVar
|
|
|
|
-- Each time the library builds successfully, run the application
|
|
runApp :: TVar Int -> TVar Bool -> String -> IO b
|
|
runApp appPortVar changedVar develHsPath = do
|
|
-- Wait for the first change, indicating that the library
|
|
-- has been built
|
|
atomically $ do
|
|
changed <- readTVar changedVar
|
|
check changed
|
|
writeTVar changedVar False
|
|
|
|
sayV "First successful build complete, running app"
|
|
|
|
-- We're going to set the PORT and DISPLAY_PORT variables for
|
|
-- the child below. Also need to know if the env program
|
|
-- exists.
|
|
env <- fmap Map.fromList getEnvironment
|
|
hasEnv <- fmap isJust $ findExecutable "env"
|
|
|
|
-- Keep looping forever, print any synchronous exceptions,
|
|
-- and eventually die from an async exception from one of
|
|
-- the other threads (via race_ above).
|
|
forever $ Ex.handleAny (\e -> sayErrString $ "Exception in runApp: " ++ show e) $ do
|
|
-- Get the port the child should listen on, and tell
|
|
-- the reverse proxy about it
|
|
newPort <-
|
|
if useReverseProxy opts
|
|
then getNewPort opts
|
|
-- no reverse proxy, so use the develPort directly
|
|
else return (develPort opts)
|
|
atomically $ writeTVar appPortVar newPort
|
|
|
|
-- Modified environment
|
|
let env' = Map.toList
|
|
$ Map.insert "PORT" (show newPort)
|
|
$ Map.insert "DISPLAY_PORT" (show $ develPort opts)
|
|
env
|
|
|
|
-- Remove the terminate file so we don't immediately exit
|
|
removeSpecialFile TermFile
|
|
|
|
-- Launch the main function in the Main module defined
|
|
-- in the file develHsPath. We use ghc instead of
|
|
-- runghc to avoid the extra (confusing) resident
|
|
-- runghc process. Starting with GHC 8.0.2, that will
|
|
-- not be necessary.
|
|
|
|
{- Hmm, unknown errors trying to get this to work. Just doing the
|
|
- runghc thing instead.
|
|
|
|
let procDef = setStdin closed $ setEnv env' $ proc "stack"
|
|
[ "ghc"
|
|
, "--"
|
|
, develHsPath
|
|
, "-e"
|
|
, "Main.main"
|
|
]
|
|
-}
|
|
|
|
-- Nix support in Stack doesn't pass along env vars by
|
|
-- default, so we use the env command. But if the command
|
|
-- isn't available, just set the env var. I'm sure this
|
|
-- will break _some_ combination of systems, but we'll
|
|
-- deal with that later. Previous issues:
|
|
--
|
|
-- https://github.com/yesodweb/yesod/issues/1357
|
|
-- https://github.com/yesodweb/yesod/issues/1359
|
|
let procDef
|
|
| hasEnv = setStdin closed $ proc "stack"
|
|
[ "exec"
|
|
, "--"
|
|
, "env"
|
|
, "PORT=" ++ show newPort
|
|
, "DISPLAY_PORT=" ++ show (develPort opts)
|
|
, "runghc"
|
|
, develHsPath
|
|
]
|
|
| otherwise = setStdin closed $ setEnv env' $ proc "stack"
|
|
[ "runghc"
|
|
, "--"
|
|
, develHsPath
|
|
]
|
|
|
|
sayV $ "Running child process: " ++ show procDef
|
|
|
|
-- Start running the child process with GHC
|
|
withProcess procDef $ \p -> do
|
|
-- Wait for either the process to exit, or for a new build to come through
|
|
eres <- atomically (fmap Left (waitExitCodeSTM p) <|> fmap Right
|
|
(do changed <- readTVar changedVar
|
|
check changed
|
|
writeTVar changedVar False))
|
|
-- on an async exception, make sure the child dies
|
|
`Ex.onException` writeSpecialFile TermFile
|
|
case eres of
|
|
-- Child exited, which indicates some
|
|
-- error. Let the user know, sleep for a bit
|
|
-- to avoid busy-looping, and then we'll try
|
|
-- again.
|
|
Left ec -> do
|
|
sayErrString $ "Unexpected: child process exited with " ++ show ec
|
|
threadDelay 1000000
|
|
sayErrString "Trying again"
|
|
-- New build succeeded
|
|
Right () -> do
|
|
-- Kill the child process, both with the
|
|
-- TermFile, and by signaling the process
|
|
-- directly.
|
|
writeSpecialFile TermFile
|
|
stopProcess p
|
|
|
|
-- Wait until the child properly exits, then we'll try again
|
|
ec <- waitExitCode p
|
|
sayV $ "Expected: child process exited with " ++ show ec
|