git.iko.soy/obelisk
on decrease-android-validity help sign in
obelisk/lib/run/src/Obelisk/Run.hs
221 lines 9.8 kB history raw
1{-# LANGUAGE ConstraintKinds #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE Rank2Types #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE TypeFamilies #-}
11{-# LANGUAGE UndecidableInstances #-}
12{-# OPTIONS_GHC -fno-warn-orphans #-} -- Due to instance HasJS x (EventWriterT t w m)
13module Obelisk.Run where
15import Prelude hiding ((.), id)
17import Control.Category
18import Control.Concurrent
19import Control.Exception
20import Control.Lens ((%~), (^?), _Just, _Right)
21import qualified Data.Attoparsec.ByteString.Char8 as A
22import Data.ByteString (ByteString)
23import qualified Data.ByteString.Char8 as BSC
24import qualified Data.ByteString.Lazy.Char8 as BSLC
25import Data.Dependent.Sum (DSum (..))
26import Data.Functor.Identity
27import Data.Functor.Sum
28import Data.List (uncons)
29import Data.Map (Map)
30import qualified Data.Map as Map
31import Data.Maybe
32import Data.Semigroup ((<>))
33import Data.Streaming.Network (bindPortTCP)
34import Data.String (fromString)
35import Data.Text (Text)
36import qualified Data.Text as T
37import qualified Data.Text.Encoding as T
38import Language.Javascript.JSaddle.Run (syncPoint)
39import Language.Javascript.JSaddle.WebSockets
40import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)
41import qualified Network.HTTP.ReverseProxy as RP
42import qualified Network.HTTP.Types as H
43import Network.Socket
44import Network.Wai (Application)
45import qualified Network.Wai as W
46import Network.Wai.Handler.Warp
47import Network.Wai.Handler.Warp.Internal (settingsHost, settingsPort)
48import Network.WebSockets (ConnectionOptions)
49import Network.WebSockets.Connection (defaultConnectionOptions)
50import qualified Obelisk.Asset.Serve.Snap as Snap
51import Obelisk.Backend
52import Obelisk.Frontend
53import Obelisk.Route.Frontend
54import Reflex.Dom.Core
55import Snap.Core (Snap)
56import System.Environment
57import System.IO
58import System.Process
59import System.Exit (ExitCode(..))
60import Text.URI (URI)
61import qualified Text.URI as URI
62import Text.URI.Lens
63import Web.Cookie
65run
66 :: Int -- ^ Port to run the backend
67 -> ([Text] -> Snap ()) -- ^ Static asset handler
68 -> Backend fullRoute frontendRoute -- ^ Backend
69 -> Frontend (R frontendRoute) -- ^ Frontend
70 -> IO ()
71run port serveStaticAsset backend frontend = do
72 prettifyOutput
73 let handleBackendErr (e :: IOException) = hPutStrLn stderr $ "backend stopped; make a change to your code to reload - error " <> show e
74 --TODO: Use Obelisk.Backend.runBackend; this will require separating the checking and running phases
75 case checkEncoder $ _backend_routeEncoder backend of
76 Left e -> hPutStrLn stderr $ "backend error:\n" <> T.unpack e
77 Right validFullEncoder -> do
78 publicConfigs <- getPublicConfigs
79 backendTid <- forkIO $ handle handleBackendErr $ withArgs ["--quiet", "--port", show port] $ do
80 _backend_run backend $ \serveRoute -> do
81 runSnapWithCommandLineArgs $ do
82 getRouteWith validFullEncoder >>= \case
83 Identity r -> case r of
84 InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a
85 InR obeliskRoute :=> Identity a ->
86 serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) serveStaticAsset frontend publicConfigs $ obeliskRoute :/ a
87 let conf = defRunConfig { _runConfig_redirectPort = port }
88 runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid
90-- Convenience wrapper to handle path segments for 'Snap.serveAsset'
91runServeAsset :: FilePath -> [Text] -> Snap ()
92runServeAsset rootPath = Snap.serveAsset "" rootPath . T.unpack . T.intercalate "/"
94getConfigRoute :: Map Text ByteString -> Either Text URI
95getConfigRoute configs = case Map.lookup "common/route" configs of
96 Just r ->
97 let stripped = T.strip (T.decodeUtf8 r)
98 in case URI.mkURI stripped of
99 Just route -> Right route
100 Nothing -> Left $ "Couldn't parse route as URI; value read was: " <> T.pack (show stripped)
101 Nothing -> Left $ "Couldn't find config file common/route; it should contain the site's canonical root URI" <> T.pack (show $ Map.keys configs)
103runWidget
104 :: RunConfig
105 -> Map Text ByteString
106 -> Frontend (R route)
107 -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
108 -> IO ()
109runWidget conf configs frontend validFullEncoder = do
110 uri <- either (fail . T.unpack) pure $ getConfigRoute configs
111 let port = fromIntegral $ fromMaybe 80 $ uri ^? uriAuthority . _Right . authPort . _Just
112 redirectHost = _runConfig_redirectHost conf
113 redirectPort = _runConfig_redirectPort conf
114 beforeMainLoop = do
115 putStrLn $ "Frontend running on " <> T.unpack (URI.render uri)
116 settings = setBeforeMainLoop beforeMainLoop (setPort port (setTimeout 3600 defaultSettings))
117 bracket
118 (bindPortTCPRetry settings (logPortBindErr port) (_runConfig_retryTimeout conf))
119 close
120 (\skt -> do
121 man <- newManager defaultManagerSettings
122 app <- obeliskApp configs defaultConnectionOptions frontend validFullEncoder uri $ fallbackProxy redirectHost redirectPort man
123 runSettingsSocket settings skt app)
125obeliskApp
126 :: forall route backendRoute
127 . Map Text ByteString
128 -> ConnectionOptions
129 -> Frontend (R route)
130 -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName
131 -> URI
132 -> Application
133 -> IO Application
134obeliskApp configs opts frontend validFullEncoder uri backend = do
135 let mode = FrontendMode
136 { _frontendMode_hydrate = True
137 , _frontendMode_adjustRoute = False
138 }
139 entryPoint = do
140 runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend
141 syncPoint
142 jsaddlePath <- URI.mkPathPiece "jsaddle"
143 let jsaddleUri = BSLC.fromStrict $ URI.renderBs $ uri & uriPath %~ (<>[jsaddlePath])
144 Right (jsaddleWarpRouteValidEncoder :: Encoder Identity (Either Text) (R JSaddleWarpRoute) PageName) <- return $ checkEncoder jsaddleWarpRouteEncoder
145 jsaddle <- jsaddleWithAppOr opts entryPoint $ \_ sendResponse -> sendResponse $ W.responseLBS H.status500 [("Content-Type", "text/plain")] "obeliskApp: jsaddle got a bad URL"
146 return $ \req sendResponse -> case tryDecode validFullEncoder (W.pathInfo req, mempty) of --TODO: Query strings
147 Identity r -> case r of
148 InR (ObeliskRoute_Resource ResourceRoute_JSaddleWarp) :=> Identity jsaddleRoute -> case jsaddleRoute of
149 JSaddleWarpRoute_JavaScript :/ () -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs' (Just jsaddleUri) False
150 _ -> flip jsaddle sendResponse $ req
151 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute
152 }
153 InR (ObeliskRoute_App appRouteComponent) :=> Identity appRouteRest -> do
154 let cookies = maybe [] parseCookies $ lookup (fromString "Cookie") (W.requestHeaders req)
155 html <- renderJsaddleFrontend configs cookies (mkRouteToUrl validFullEncoder) (appRouteComponent :/ appRouteRest) frontend
156 sendResponse $ W.responseLBS H.status200 [("Content-Type", staticRenderContentType)] $ BSLC.fromStrict html
157 _ -> backend req sendResponse
159renderJsaddleFrontend
160 :: Map Text ByteString
161 -> Cookies
162 -> (route -> Text)
163 -> route
164 -> Frontend route
165 -> IO ByteString
166renderJsaddleFrontend configs cookies urlEnc r f =
167 let jsaddleScript = elAttr "script" ("src" =: "/jsaddle/jsaddle.js") blank
168 jsaddlePreload = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: "/jsaddle/jsaddle.js") blank
169 in renderFrontendHtml configs cookies urlEnc r f jsaddlePreload jsaddleScript
171-- | like 'bindPortTCP' but reconnects on exception
172bindPortTCPRetry :: Settings
173 -> (IOError -> IO ()) -- ^ Action to run the first time an exception is caught
174 -> Int
175 -> IO Socket
176bindPortTCPRetry settings m n = catch (bindPortTCP (settingsPort settings) (settingsHost settings)) $ \(e :: IOError) -> do
177 m e
178 threadDelay $ 1000000 * n
179 bindPortTCPRetry settings (\_ -> pure ()) n
181logPortBindErr :: Int -> IOError -> IO ()
182logPortBindErr p e = getProcessIdForPort p >>= \case
183 Nothing -> putStrLn $ "runWidget: " <> show e
184 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."]
186getProcessIdForPort :: Int -> IO (Maybe Int)
187getProcessIdForPort port = do
188 -- First check if 'ss' is available
189 (c, _, _) <- readProcessWithExitCode "which" ["ss"] mempty
190 case c of
191 ExitSuccess -> do
192 xs <- lines <$> readProcess "ss" ["-lptn", "sport = " <> show port] mempty
193 case uncons xs of
194 Just (_, x:_) -> return $ A.maybeResult $ A.parse parseSsPid $ BSC.pack x
195 _ -> return Nothing
196 _ -> return Nothing
198parseSsPid :: A.Parser Int
199parseSsPid = do
200 _ <- A.count 5 $ A.takeWhile (not . A.isSpace) *> A.skipSpace
201 _ <- A.skipWhile (/= ':') >> A.string ":((" >> A.skipWhile (/= ',')
202 A.string ",pid=" *> A.decimal
204fallbackProxy :: ByteString -> Int -> Manager -> Application
205fallbackProxy host port = RP.waiProxyTo handleRequest RP.defaultOnExc
206 where handleRequest _req = return $ RP.WPRProxyDest $ RP.ProxyDest host port
208data RunConfig = RunConfig
209 { _runConfig_port :: Int
210 , _runConfig_redirectHost :: ByteString
211 , _runConfig_redirectPort :: Int
212 , _runConfig_retryTimeout :: Int -- seconds
213 }
215defRunConfig :: RunConfig
216defRunConfig = RunConfig
217 { _runConfig_port = 8000
218 , _runConfig_redirectHost = "127.0.0.1"
219 , _runConfig_redirectPort = 3001
220 , _runConfig_retryTimeout = 1
221 }