@@ -4,44 +4,31 @@
44
55module Obelisk.Snap where
66
7−import Obelisk.Asset.Serve
7+import Obelisk.Asset.Serve.Snap
8+import Obelisk.Snap.Extras
89
910import Snap
1011
1112import Control.Lens
1213import Data.ByteString (ByteString)
1314import Data.Default
14−import Data.Maybe
1515import Data.Monoid
16−import Data.String
17−import Data.Text (Text)
1816import qualified Data.Text as T
19−import Diagrams.Prelude (Diagram, renderDia, mkWidth)
20−import Diagrams.Backend.SVG
21−import qualified Graphics.Svg as SVG
22−import Graphics.Svg.Attributes
2317import Lucid
2418import System.FilePath
25−import Text.RawString.QQ
2619import Control.Monad.IO.Class
2720
2821-- Data type for web app configuration
2922data AppConfig m
30− = AppConfig { _appConfig_logo :: Diagram SVG
31− , _appConfig_extraHeadMarkup :: Html ()
32− , _appConfig_initialStyles :: Maybe Text
33− , _appConfig_initialBody :: Maybe (m ByteString)
34− , _appConfig_initialHead :: Maybe ByteString
23+ = AppConfig { _appConfig_initialBody :: m ByteString
24+ , _appConfig_initialHead :: ByteString
3525 , _appConfig_serveJsexe :: Bool
3626 , _appConfig_jsexe :: FilePath
3727 }
3828
3929-- Default instance for app configuration
40−instance Default (AppConfig m) where
41− def = AppConfig { _appConfig_logo = mempty
42− , _appConfig_extraHeadMarkup = mempty
43− , _appConfig_initialStyles = mempty
44− , _appConfig_initialBody = Nothing
30+instance Monad m => Default (AppConfig m) where
31+ def = AppConfig { _appConfig_initialBody = return mempty
4532 , _appConfig_initialHead = mempty
4633 , _appConfig_serveJsexe = True
4734 , _appConfig_jsexe = "frontend.jsexe"
@@ -83,28 +70,18 @@ frontendJsAssetsPath (AppConfig { _appConfig_jsexe = jsexe }) = "frontendJs.asse
8370-- Helper funtion used in 'serveAppAt', writes a lazy bytestring to the body of Http response
8471serveStaticIndex :: MonadSnap m => AppConfig m -> m ()
8572serveStaticIndex cfg = do
86− -- Decode, pack, and append asset target to file path
73+ -- Decode, pack, and append asset target to file path
8774 appJsPath <- liftIO $ getAssetPath (frontendJsAssetsPath cfg) "/all.js"
88− -- extract initial body from 'AppConfig' or return empty string
89− initialBody <- fromMaybe (return "") $ _appConfig_initialBody cfg
90− -- extract inital head from 'AppConfig' or return empty string
91− let initialHead = fromMaybe "" $ _appConfig_initialHead cfg
92− -- extract initial styles from 'AppConfig' or return empty string
93− let initialStyles = fromMaybe "" $ _appConfig_initialStyles cfg
94−
95− -- Render and write html head and body to response
75+ initialBody <- _appConfig_initialBody cfg
76+ -- Render and write html head and body to response
9677 writeLBS $ renderBS $ doctypehtml_ $ do
9778 head_ $ do
9879 meta_ [charset_ "utf-8"] -- meta-data charset description
9980 meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"] -- meta-data viewport description
100− _appConfig_extraHeadMarkup cfg -- any additional <head> html from 'AppConfig' type
101− toHtmlRaw initialHead -- HtmlT monad wrapper
102− style_ initialStyles -- generate style element/attribute
81+ toHtmlRaw $ _appConfig_initialHead cfg
10382 body_ $ do -- <body>
10483 toHtmlRaw initialBody -- HtmlT monad wrapper
105− script_ [type_ "text/javascript", src_ (maybe "/all.js" T.pack appJsPath), defer_ "defer"] ("" :: String)
106− -- create <script> element
107− return ()
84+ script_ [type_ "application/javascript", src_ (maybe "/all.js" T.pack appJsPath), defer_ "defer"] ("" :: String)
10885
10986{- | Takes an AppConfig monad and uses it to generate & write Lazy ByteString
11087 to the body of the https response. This one comes with hard coded values
@@ -116,43 +93,7 @@ serveIndex cfg = do
11693 head_ $ do
11794 meta_ [charset_ "utf-8"]
11895 meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"]
119− _appConfig_extraHeadMarkup cfg
120− style_ [r|
121− #preload-logo {
122− position: fixed;
123− left: 25%;
124− top: 25%;
125− width: 50%;
126− height: 50%;
127− -webkit-animation: fadein 2s; /* Safari, Chrome and Opera > 12.1 */
128− -moz-animation: fadein 2s; /* Firefox < 16 */
129− -ms-animation: fadein 2s; /* Internet Explorer */
130− -o-animation: fadein 2s; /* Opera < 12.1 */
131− animation: fadein 2s;
132− }
133− @keyframes fadein {
134− from { opacity: 0; }
135− to { opacity: 1; }
136− }
137− /* Firefox < 16 */
138− @-moz-keyframes fadein {
139− from { opacity: 0; }
140− to { opacity: 1; }
141− }
142− /* Safari, Chrome and Opera > 12.1 */
143− @-webkit-keyframes fadein {
144− from { opacity: 0; }
145− to { opacity: 1; }
146− }
147− /* Internet Explorer */
148− @-ms-keyframes fadein {
149− from { opacity: 0; }
150− to { opacity: 1; }
151− }
152− |]
15396 body_ $ do
154− let svgOpts = SVGOptions (mkWidth 400) Nothing "preload-logo-" [bindAttr Id_ "preload-logo"] False
155− toHtml $ SVG.renderBS $ renderDia SVG svgOpts $ _appConfig_logo cfg
156− script_ [type_ "text/javascript", src_ (maybe "/all.js" T.pack appJsPath), defer_ "defer"] ("" :: String)
97+ script_ [type_ "application/javascript", src_ (maybe "/all.js" T.pack appJsPath), defer_ "defer"] ("" :: String)
15798
15899makeLenses ''AppConfig