git.iko.soy/obelisk
on ae@static-which-prefetch help sign in
obelisk/lib/run/src/Obelisk/Run.hs
268 lines 12 kB history raw
1{-# LANGUAGE CPP #-}
2#if defined(IPROUTE_SUPPORTED)
3{-# LANGUAGE TemplateHaskell #-}
4#endif
6{-# LANGUAGE ConstraintKinds #-}
7{-# LANGUAGE FlexibleContexts #-}
8{-# LANGUAGE FlexibleInstances #-}
9{-# LANGUAGE GADTs #-}
10{-# LANGUAGE LambdaCase #-}
11{-# LANGUAGE MultiParamTypeClasses #-}
12{-# LANGUAGE OverloadedStrings #-}
13{-# LANGUAGE Rank2Types #-}
14{-# LANGUAGE ScopedTypeVariables #-}
15{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE UndecidableInstances #-}
17{-# OPTIONS_GHC -fno-warn-orphans #-} -- Due to instance HasJS x (EventWriterT t w m)
18module Obelisk.Run where
20import Prelude hiding ((.), id)
22import Control.Category
23import Control.Concurrent
24import Control.Exception
25import Control.Lens ((%~), (^?), _Just, _Right)
26import qualified Data.Attoparsec.ByteString.Char8 as A
27import Data.ByteString (ByteString)
28import qualified Data.ByteString as BS
29import qualified Data.ByteString.Char8 as BSC
30import qualified Data.ByteString.Lazy.Char8 as BSLC
31import qualified Data.ByteString.UTF8 as BSUTF8
32import Data.Functor.Identity
33import Data.List (uncons)
34import Data.Map (Map)
35import qualified Data.Map as Map
36import Data.Maybe
37import Data.Semigroup ((<>))
38import Data.Streaming.Network (bindPortTCP)
39import Data.String (fromString)
40import Data.Text (Text)
41import qualified Data.Text as T
42import qualified Data.Text.Encoding as T
43import Data.Time.Clock (getCurrentTime, addUTCTime)
44import Language.Javascript.JSaddle.Run (syncPoint)
45import Language.Javascript.JSaddle.WebSockets
46import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)
47import qualified Network.HTTP.ReverseProxy as RP
48import qualified Network.HTTP.Types as H
49import Network.Socket
50import Network.Wai (Application)
51import qualified Network.Wai as W
52import Network.Wai.Handler.Warp
53import Network.Wai.Handler.WarpTLS
54import Network.Wai.Handler.Warp.Internal (settingsHost, settingsPort)
55import Network.WebSockets (ConnectionOptions)
56import Network.WebSockets.Connection (defaultConnectionOptions)
57import qualified Obelisk.Asset.Serve.Snap as Snap
58import Obelisk.Backend
59import Obelisk.Frontend
60import Obelisk.Route.Frontend
61import qualified OpenSSL.PEM as PEM
62import qualified OpenSSL.RSA as RSA
63import qualified OpenSSL.X509 as X509
64import qualified OpenSSL.X509.Request as X509Request
65import Reflex.Dom.Core
66import Snap.Core (Snap)
67import System.Environment
68import System.IO
69import System.Process
70import Text.URI (URI)
71import qualified Text.URI as URI
72import Text.URI.Lens
73import Web.Cookie
75#if defined(IPROUTE_SUPPORTED)
76import qualified System.Which
77#endif
79run
80 :: Int -- ^ Port to run the backend
81 -> ([Text] -> Snap ()) -- ^ Static asset handler
82 -> Backend backendRoute frontendRoute -- ^ Backend
83 -> Frontend (R frontendRoute) -- ^ Frontend
84 -> IO ()
85run port serveStaticAsset backend frontend = do
86 prettifyOutput
87 let handleBackendErr (e :: IOException) = hPutStrLn stderr $ "backend stopped; make a change to your code to reload - error " <> show e
88 --TODO: Use Obelisk.Backend.runBackend; this will require separating the checking and running phases
89 case checkEncoder $ _backend_routeEncoder backend of
90 Left e -> hPutStrLn stderr $ "backend error:\n" <> T.unpack e
91 Right validFullEncoder -> do
92 publicConfigs <- getPublicConfigs
93 backendTid <- forkIO $ handle handleBackendErr $ withArgs ["--quiet", "--port", show port] $
94 _backend_run backend $ \serveRoute ->
95 runSnapWithCommandLineArgs $
96 getRouteWith validFullEncoder >>= \case
97 Identity r -> case r of
98 FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a
99 FullRoute_Frontend obeliskRoute :/ a ->
100 serveDefaultObeliskApp appRouteToUrl (($ allJsUrl) <$> defaultGhcjsWidgets) serveStaticAsset frontend publicConfigs $ obeliskRoute :/ a
101 where
102 appRouteToUrl (k :/ v) = renderObeliskRoute validFullEncoder (FullRoute_Frontend (ObeliskRoute_App k) :/ v)
103 allJsUrl = renderAllJsPath validFullEncoder
105 let conf = defRunConfig { _runConfig_redirectPort = port }
106 runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid
108-- Convenience wrapper to handle path segments for 'Snap.serveAsset'
109runServeAsset :: FilePath -> [Text] -> Snap ()
110runServeAsset rootPath = Snap.serveAsset "" rootPath . T.unpack . T.intercalate "/"
112getConfigRoute :: Map Text ByteString -> Either Text URI
113getConfigRoute configs = case Map.lookup "common/route" configs of
114 Just r ->
115 let stripped = T.strip (T.decodeUtf8 r)
116 in case URI.mkURI stripped of
117 Just route -> Right route
118 Nothing -> Left $ "Couldn't parse route as URI; value read was: " <> T.pack (show stripped)
119 Nothing -> Left $ "Couldn't find config file common/route; it should contain the site's canonical root URI" <> T.pack (show $ Map.keys configs)
121runWidget
122 :: RunConfig
123 -> Map Text ByteString
124 -> Frontend (R frontendRoute)
125 -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName
126 -> IO ()
127runWidget conf configs frontend validFullEncoder = do
128 uri <- either (fail . T.unpack) pure $ getConfigRoute configs
129 let port = fromIntegral $ fromMaybe 80 $ uri ^? uriAuthority . _Right . authPort . _Just
130 redirectHost = _runConfig_redirectHost conf
131 redirectPort = _runConfig_redirectPort conf
132 beforeMainLoop = do
133 putStrLn $ "Frontend running on " <> T.unpack (URI.render uri)
134 settings = setBeforeMainLoop beforeMainLoop (setPort port (setTimeout 3600 defaultSettings))
135 -- Providing TLS here will also incidentally provide it to proxied requests to the backend.
136 prepareRunner = case uri ^? uriScheme . _Just . unRText of
137 Just "https" -> do
138 -- Generate a private key and self-signed certificate for TLS
139 privateKey <- RSA.generateRSAKey' 2048 3
141 certRequest <- X509Request.newX509Req
142 _ <- X509Request.setPublicKey certRequest privateKey
143 _ <- X509Request.signX509Req certRequest privateKey Nothing
145 cert <- X509.newX509 >>= X509Request.makeX509FromReq certRequest
146 _ <- X509.setPublicKey cert privateKey
147 now <- getCurrentTime
148 _ <- X509.setNotBefore cert $ addUTCTime (-1) now
149 _ <- X509.setNotAfter cert $ addUTCTime (365 * 24 * 60 * 60) now
150 _ <- X509.signX509 cert privateKey Nothing
152 certByteString <- BSUTF8.fromString <$> PEM.writeX509 cert
153 privateKeyByteString <- BSUTF8.fromString <$> PEM.writePKCS8PrivateKey privateKey Nothing
155 return $ runTLSSocket (tlsSettingsMemory certByteString privateKeyByteString)
156 _ -> return runSettingsSocket
157 runner <- prepareRunner
158 bracket
159 (bindPortTCPRetry settings (logPortBindErr port) (_runConfig_retryTimeout conf))
160 close
161 (\skt -> do
162 man <- newManager defaultManagerSettings
163 app <- obeliskApp configs defaultConnectionOptions frontend validFullEncoder uri $ fallbackProxy redirectHost redirectPort man
164 runner settings skt app)
166obeliskApp
167 :: forall frontendRoute backendRoute
168 . Map Text ByteString
169 -> ConnectionOptions
170 -> Frontend (R frontendRoute)
171 -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName
172 -> URI
173 -> Application
174 -> IO Application
175obeliskApp configs opts frontend validFullEncoder uri backend = do
176 let mode = FrontendMode
177 { _frontendMode_hydrate = True
178 , _frontendMode_adjustRoute = False
179 }
180 entryPoint = do
181 runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend
182 syncPoint
183 jsaddlePath <- URI.mkPathPiece "jsaddle"
184 let jsaddleUri = BSLC.fromStrict $ URI.renderBs $ uri & uriPath %~ (<>[jsaddlePath])
185 Right (jsaddleWarpRouteValidEncoder :: Encoder Identity (Either Text) (R JSaddleWarpRoute) PageName) <- return $ checkEncoder jsaddleWarpRouteEncoder
186 jsaddle <- jsaddleWithAppOr opts entryPoint $ \_ sendResponse -> sendResponse $ W.responseLBS H.status500 [("Content-Type", "text/plain")] "obeliskApp: jsaddle got a bad URL"
187 return $ \req sendResponse -> case tryDecode validFullEncoder $ byteStringsToPageName (BS.dropWhile (== (fromIntegral $ fromEnum '/')) $ W.rawPathInfo req) (BS.drop 1 $ W.rawQueryString req) of
188 Identity r -> case r of
189 FullRoute_Frontend (ObeliskRoute_Resource ResourceRoute_JSaddleWarp) :/ jsaddleRoute -> case jsaddleRoute of
190 JSaddleWarpRoute_JavaScript :/ () -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs' (Just jsaddleUri) False
191 _ -> flip jsaddle sendResponse $ req
192 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute
193 }
194 FullRoute_Frontend (ObeliskRoute_App appRouteComponent) :/ appRouteRest -> do
195 let cookies = maybe [] parseCookies $ lookup (fromString "Cookie") (W.requestHeaders req)
196 routeToUrl (k :/ v) = renderObeliskRoute validFullEncoder $ FullRoute_Frontend (ObeliskRoute_App k) :/ v
197 html <- renderJsaddleFrontend configs cookies routeToUrl (appRouteComponent :/ appRouteRest) frontend
198 sendResponse $ W.responseLBS H.status200 [("Content-Type", staticRenderContentType)] $ BSLC.fromStrict html
199 _ -> backend req sendResponse
201renderJsaddleFrontend
202 :: Map Text ByteString
203 -> Cookies
204 -> (route -> Text)
205 -> route
206 -> Frontend route
207 -> IO ByteString
208renderJsaddleFrontend configs cookies urlEnc r f =
209 let jsaddleScript = elAttr "script" ("src" =: "/jsaddle/jsaddle.js") blank
210 jsaddlePreload = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: "/jsaddle/jsaddle.js") blank
211 in renderFrontendHtml configs cookies urlEnc r f jsaddlePreload jsaddleScript
213-- | like 'bindPortTCP' but reconnects on exception
214bindPortTCPRetry :: Settings
215 -> (IOError -> IO ()) -- ^ Action to run the first time an exception is caught
216 -> Int
217 -> IO Socket
218bindPortTCPRetry settings m n = catch (bindPortTCP (settingsPort settings) (settingsHost settings)) $ \(e :: IOError) -> do
219 m e
220 threadDelay $ 1000000 * n
221 bindPortTCPRetry settings (\_ -> pure ()) n
223logPortBindErr :: Int -> IOError -> IO ()
224logPortBindErr p e = getProcessIdForPort p >>= \case
225 Nothing -> putStrLn $ "runWidget: " <> show e
226 Just pid -> putStrLn $ unwords [ "Port", show p, "is being used by process ID", show pid <> ".", "Please kill that process or change the port in config/common/route."]
228ssPath :: Maybe String
229ssPath =
230#if defined(IPROUTE_SUPPORTED)
231 Just $(System.Which.staticWhich "ss")
232#else
233 Nothing
234#endif
236getProcessIdForPort :: Int -> IO (Maybe Int)
237getProcessIdForPort port = case ssPath of
238 Just ss -> do
239 xs <- lines <$> readProcess ss ["-lptn", "sport = " <> show port] mempty
240 case uncons xs of
241 Just (_, x:_) -> return $ A.maybeResult $ A.parse parseSsPid $ BSC.pack x
242 _ -> return Nothing
243 _ -> return Nothing
245parseSsPid :: A.Parser Int
246parseSsPid = do
247 _ <- A.count 5 $ A.takeWhile (not . A.isSpace) *> A.skipSpace
248 _ <- A.skipWhile (/= ':') >> A.string ":((" >> A.skipWhile (/= ',')
249 A.string ",pid=" *> A.decimal
251fallbackProxy :: ByteString -> Int -> Manager -> Application
252fallbackProxy host port = RP.waiProxyTo handleRequest RP.defaultOnExc
253 where handleRequest _req = return $ RP.WPRProxyDest $ RP.ProxyDest host port
255data RunConfig = RunConfig
256 { _runConfig_port :: Int
257 , _runConfig_redirectHost :: ByteString
258 , _runConfig_redirectPort :: Int
259 , _runConfig_retryTimeout :: Int -- seconds
260 }
262defRunConfig :: RunConfig
263defRunConfig = RunConfig
264 { _runConfig_port = 8000
265 , _runConfig_redirectHost = "127.0.0.1"
266 , _runConfig_redirectPort = 3001
267 , _runConfig_retryTimeout = 1
268 }