git.iko.soy/obelisk
on decrease-android-validity help sign in
obelisk/lib/backend/src/Obelisk/Backend.hs
217 lines 9.0 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE KindSignatures #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE OverloadedStrings #-}
8{-# LANGUAGE ScopedTypeVariables #-}
9{-# OPTIONS_GHC -fno-warn-orphans #-}
10module Obelisk.Backend
11 ( Backend (..)
12 -- * Re-exports
13 , Default (def)
14 , getPageName
15 , getRouteWith
16 , runSnapWithCommandLineArgs
17 , serveDefaultObeliskApp
18 , prettifyOutput
19 , runBackend
20 , staticRenderContentType
21 , mkRouteToUrl
22 , getPublicConfigs
23 ) where
25import Prelude hiding (id, (.))
26import Control.Category
27import Control.Monad
28import Control.Monad.Except
29import Control.Categorical.Bifunctor
30import Data.ByteString (ByteString)
31import qualified Data.ByteString.Char8 as BSC8
32import Data.Default (Default (..))
33import Data.Dependent.Sum
34import Data.Functor.Sum
35import Data.Functor.Identity
36import Data.Map (Map)
37import qualified Data.Map as Map
38import Data.Monoid ((<>))
39import Data.Text (Text)
40import qualified Data.Text as T
41import Data.Text.Encoding
42import Obelisk.Asset.Serve.Snap (serveAsset)
43import qualified Obelisk.ExecutableConfig.Lookup as Lookup
44import Obelisk.Frontend
45import Obelisk.Route
46import Obelisk.Snap.Extras (doNotCache, serveFileIfExistsAs)
47import Reflex.Dom
48import Snap (MonadSnap, Snap, commandLineConfig, defaultConfig, getsRequest, httpServe, modifyResponse
49 , rqPathInfo, rqQueryString, setContentType, writeBS, writeText
50 , rqCookies, Cookie(..))
51import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog (ConfigIoLog))
52import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)
54data Backend backendRoute frontendRoute = Backend
55 { _backend_routeEncoder :: Encoder (Either Text) Identity (R (Sum backendRoute (ObeliskRoute frontendRoute))) PageName
56 , _backend_run :: ((R backendRoute -> Snap ()) -> IO ()) -> IO ()
57 }
59-- | The static assets provided must contain a compiled GHCJS app that corresponds exactly to the Frontend provided
60data GhcjsApp route = GhcjsApp
61 { _ghcjsApp_compiled :: !StaticAssets
62 , _ghcjsApp_value :: !(Frontend route)
63 }
65-- | Serve a frontend, which must be the same frontend that Obelisk has built and placed in the default location
66--TODO: The frontend should be provided together with the asset paths so that this isn't so easily breakable; that will probably make this function obsolete
67serveDefaultObeliskApp
68 :: (MonadSnap m, HasCookies m)
69 => (R appRoute
70 -> Text)
71 -> ([Text]
72 -> m ())
73 -> Frontend (R appRoute)
74 -> Map Text ByteString
75 -> R (ObeliskRoute appRoute)
76 -> m ()
77serveDefaultObeliskApp urlEnc serveStaticAsset frontend configs = serveObeliskApp urlEnc serveStaticAsset frontendApp configs
78 where frontendApp = GhcjsApp
79 { _ghcjsApp_compiled = defaultFrontendGhcjsAssets
80 , _ghcjsApp_value = frontend
81 }
83prettifyOutput :: IO ()
84prettifyOutput = do
85 -- Make output more legible by decreasing the likelihood of output from
86 -- multiple threads being interleaved
87 hSetBuffering stdout LineBuffering
88 hSetBuffering stderr LineBuffering
90defaultStaticAssets :: StaticAssets
91defaultStaticAssets = StaticAssets
92 { _staticAssets_processed = "static.assets"
93 , _staticAssets_unprocessed = "static"
94 }
96defaultFrontendGhcjsAssets :: StaticAssets
97defaultFrontendGhcjsAssets = StaticAssets
98 { _staticAssets_processed = "frontend.jsexe.assets"
99 , _staticAssets_unprocessed = "frontend.jsexe"
100 }
102runSnapWithCommandLineArgs :: MonadIO m => Snap () -> m ()
103runSnapWithCommandLineArgs a = do
104 -- Get the web server configuration from the command line
105 cmdLineConf <- liftIO $ commandLineConfig defaultConfig
106 let httpConf = cmdLineConf
107 { accessLog = Just $ ConfigIoLog BSC8.putStrLn
108 , errorLog = Just $ ConfigIoLog BSC8.putStrLn
109 }
110 -- Start the web server
111 liftIO $ httpServe httpConf a
113getPageName :: (MonadSnap m) => m PageName
114getPageName = do
115 p <- getsRequest rqPathInfo
116 q <- getsRequest rqQueryString
117 let pageNameEncoder' :: Encoder Identity Identity PageName (String, String)
118 pageNameEncoder' = bimap
119 (unpackTextEncoder . pathSegmentsTextEncoder . listToNonEmptyEncoder)
120 (unpackTextEncoder . queryParametersTextEncoder . toListMapEncoder)
121 return $ decode pageNameEncoder' (T.unpack (decodeUtf8 p), T.unpack (decodeUtf8 q))
123getRouteWith :: (MonadSnap m) => Encoder Identity parse route PageName -> m (parse route)
124getRouteWith e = do
125 pageName <- getPageName
126 return $ tryDecode e pageName
128serveObeliskApp
129 :: (MonadSnap m, HasCookies m)
130 => (R appRoute -> Text)
131 -> ([Text] -> m ())
132 -> GhcjsApp (R appRoute)
133 -> Map Text ByteString
134 -> R (ObeliskRoute appRoute)
135 -> m ()
136serveObeliskApp urlEnc serveStaticAsset frontendApp config = \case
137 ObeliskRoute_App appRouteComponent :=> Identity appRouteRest -> serveGhcjsApp urlEnc frontendApp config $ GhcjsAppRoute_App appRouteComponent :/ appRouteRest
138 ObeliskRoute_Resource resComponent :=> Identity resRest -> case resComponent :=> Identity resRest of
139 ResourceRoute_Static :=> Identity pathSegments -> serveStaticAsset pathSegments
140 ResourceRoute_Ghcjs :=> Identity pathSegments -> serveGhcjsApp urlEnc frontendApp config $ GhcjsAppRoute_Resource :/ pathSegments
141 ResourceRoute_JSaddleWarp :=> Identity _ -> do
142 let msg = "Error: Obelisk.Backend received jsaddle request"
143 liftIO $ putStrLn $ T.unpack msg
144 writeText msg
145 ResourceRoute_Version :=> Identity () -> doNotCache >> serveFileIfExistsAs "text/plain" "version"
147serveStaticAssets :: MonadSnap m => StaticAssets -> [Text] -> m ()
148serveStaticAssets assets pathSegments = serveAsset (_staticAssets_processed assets) (_staticAssets_unprocessed assets) $ T.unpack $ T.intercalate "/" pathSegments
150data StaticAssets = StaticAssets
151 { _staticAssets_processed :: !FilePath
152 , _staticAssets_unprocessed :: !FilePath
153 }
154 deriving (Show, Read, Eq, Ord)
156data GhcjsAppRoute :: (* -> *) -> * -> * where
157 GhcjsAppRoute_App :: appRouteComponent a -> GhcjsAppRoute appRouteComponent a
158 GhcjsAppRoute_Resource :: GhcjsAppRoute appRouteComponent [Text]
160staticRenderContentType :: ByteString
161staticRenderContentType = "text/html; charset=utf-8"
163--TODO: Don't assume we're being served at "/"
164serveGhcjsApp
165 :: (MonadSnap m, HasCookies m)
166 => (R appRouteComponent -> Text)
167 -> GhcjsApp (R appRouteComponent)
168 -> Map Text ByteString
169 -> R (GhcjsAppRoute appRouteComponent)
170 -> m ()
171serveGhcjsApp urlEnc app config = \case
172 GhcjsAppRoute_App appRouteComponent :=> Identity appRouteRest -> do
173 modifyResponse $ setContentType staticRenderContentType
174 writeBS <=< renderGhcjsFrontend urlEnc (appRouteComponent :/ appRouteRest) config $ _ghcjsApp_value app
175 GhcjsAppRoute_Resource :=> Identity pathSegments -> serveStaticAssets (_ghcjsApp_compiled app) pathSegments
177runBackend :: Backend fullRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()
178runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of
179 Left e -> fail $ "backend error:\n" <> T.unpack e
180 Right validFullEncoder -> do
181 publicConfigs <- getPublicConfigs
182 _backend_run backend $ \serveRoute -> do
183 runSnapWithCommandLineArgs $ do
184 getRouteWith validFullEncoder >>= \case
185 Identity r -> case r of
186 InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a
187 InR obeliskRoute :=> Identity a ->
188 serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) (serveStaticAssets defaultStaticAssets) frontend publicConfigs $
189 obeliskRoute :/ a
191mkRouteToUrl :: Encoder Identity parse (R (Sum f (ObeliskRoute r))) PageName -> R r -> Text
192mkRouteToUrl validFullEncoder =
193 let pageNameEncoder' :: Encoder Identity (Either Text) PageName PathQuery = pageNameEncoder
194 in \(k :/ v) -> T.pack . uncurry (<>) . encode pageNameEncoder' . encode validFullEncoder $ (InR $ ObeliskRoute_App k) :/ v
196renderGhcjsFrontend
197 :: (MonadSnap m, HasCookies m)
198 => (route -> Text)
199 -> route
200 -> Map Text ByteString
201 -> Frontend route
202 -> m ByteString
203renderGhcjsFrontend urlEnc route configs f = do
204 let ghcjsPreload = elAttr "link" ("rel" =: "preload" <> "as" =: "script" <> "href" =: "ghcjs/all.js") blank
205 ghcjsScript = elAttr "script" ("language" =: "javascript" <> "src" =: "ghcjs/all.js" <> "defer" =: "defer") blank
206 cookies <- askCookies
207 renderFrontendHtml configs cookies urlEnc route f ghcjsPreload ghcjsScript
209instance HasCookies Snap where
210 askCookies = map (\c -> (cookieName c, cookieValue c)) <$> getsRequest rqCookies
212-- | Get configs from the canonical "public" locations (i.e., locations that obelisk expects to make available
213-- to frontend applications, and hence visible to end users).
214getPublicConfigs :: IO (Map Text ByteString)
215getPublicConfigs = Map.filterWithKey (\k _ -> isMemberOf k ["common", "frontend"]) <$> Lookup.getConfigs
216 where
217 isMemberOf k = any (`T.isPrefixOf` k)