@@ -1,20 +1,35 @@
1+{-# LANGUAGE EmptyCase #-}
2+{-# LANGUAGE EmptyDataDecls #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GADTs #-}
6+{-# LANGUAGE KindSignatures #-}
17{-# LANGUAGE LambdaCase #-}
28{-# LANGUAGE OverloadedStrings #-}
39{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE TemplateHaskell #-}
411module Obelisk.Run where
512
13+import Obelisk.Route
14+
615import Control.Concurrent
716import Control.Exception
817import Control.Lens ((^?), _Just, _Right)
18+import Control.Monad.Except
919import qualified Data.Attoparsec.ByteString.Char8 as A
1020import Data.ByteString (ByteString)
1121import qualified Data.ByteString.Char8 as BSC
1222import qualified Data.ByteString.Lazy.Char8 as BSLC
1323import Data.List (uncons)
1424import Data.Maybe
25+import Data.GADT.Compare.TH
26+import Data.GADT.Show
1527import Data.Semigroup ((<>))
28+import Data.Some (Some)
1629import Data.Streaming.Network (bindPortTCP)
30+import Data.Text (Text)
1731import qualified Data.Text as T
32+import Data.Universe
1833import Language.Javascript.JSaddle.Run (syncPoint)
1934import Language.Javascript.JSaddle.WebSockets
2035import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)
@@ -25,7 +40,6 @@ import Network.Wai (Application)
2540import qualified Network.Wai as W
2641import Network.Wai.Handler.Warp
2742import Network.Wai.Handler.Warp.Internal (settingsHost, settingsPort)
28−import Network.Wai.Handler.WebSockets (isWebSocketsReq)
2943import Network.WebSockets (ConnectionOptions)
3044import Network.WebSockets.Connection (defaultConnectionOptions)
3145import Obelisk.ExecutableConfig (get)
@@ -77,28 +91,39 @@ runWidget conf (h, b) = do
7791 app <- obeliskApp defaultConnectionOptions h b (fallbackProxy redirectHost redirectPort man)
7892 runSettingsSocket settings skt app)
7993
94+data Void1 :: * -> * where {}
95+
96+instance Universe (Some Void1) where
97+ universe = []
98+
99+void1Encoder :: (Applicative check, MonadError Text parse) => Encoder check parse (Some Void1) a
100+void1Encoder = Encoder $ pure $ ValidEncoder
101+ { _validEncoder_encode = \case {}
102+ , _validEncoder_decode = \_ -> throwError "void1Encoder: can't decode anything"
103+ }
104+
80105obeliskApp :: ConnectionOptions -> StaticWidget () () -> Widget () () -> Application -> IO Application
81106obeliskApp opts h b backend = do
82107 html <- BSLC.fromStrict <$> indexHtml h
83108 let entryPoint = mainWidget' b >> syncPoint
84− jsaddle <- jsaddleOr opts entryPoint $ \req sendResponse -> case (W.requestMethod req, W.pathInfo req) of
85− ("GET", []) -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] html
86− ("GET", ["jsaddle.js"]) -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs False
109+ Right ve <- return $ checkEncoder $ obeliskRouteEncoder void1Encoder (\case {})
110+ Right (jsaddleWarpRouteValidEncoder :: ValidEncoder (Either Text) (R JSaddleWarpRoute) PageName) <- return $ checkEncoder jsaddleWarpRouteEncoder
111+ jsaddle <- jsaddleWithAppOr opts entryPoint $ error "obeliskApp: jsaddle got a bad URL"
112+ return $ \req sendResponse -> case _validEncoder_decode ve (W.pathInfo req, mempty) of --TODO: Query strings
113+ Right (ObeliskRoute_Resource ResourceRoute_JSaddleWarp :/ jsaddleRoute) -> case jsaddleRoute of
114+ JSaddleWarpRoute_JavaScript :/ () -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs' (Just "http://localhost:8000/jsaddle") False
115+ _ -> flip jsaddle sendResponse $ req
116+ { W.pathInfo = fst $ _validEncoder_encode jsaddleWarpRouteValidEncoder jsaddleRoute
117+ }
118+ Left _ -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] html
87119 _ -> backend req sendResponse
88− -- Workaround jsaddleOr wanting to handle all websockets requests without
89− -- having a chance for run to proxy non jsaddle websocket requests to the
90− -- backend.
91− return $ \req sendResponse -> do
92− if isWebSocketsReq req && not (null $ W.pathInfo req)
93− then backend req sendResponse
94− else jsaddle req sendResponse
95120
96121indexHtml :: StaticWidget () () -> IO ByteString
97122indexHtml h = do
98123 ((), bs) <- renderStatic $ el "html" $ do
99124 el "head" $ h
100125 el "body" $ return ()
101− elAttr "script" ("src" =: "/jsaddle.js") $ return ()
126+ elAttr "script" ("src" =: "/jsaddle/jsaddle.js") $ return ()
102127 return $ "<!DOCTYPE html>" <> bs
103128
104129-- | like 'bindPortTCP' but reconnects on exception
@@ -147,3 +172,8 @@ defRunConfig = RunConfig
147172 , _runConfig_redirectPort = 3001
148173 , _runConfig_retryTimeout = 1
149174 }
175+
176+deriveGCompare ''Void1
177+deriveGEq ''Void1
178+instance GShow Void1 where
179+ gshowsPrec _ = \case {}