@@ -1,99 +0,0 @@
1−{-# LANGUAGE TemplateHaskell #-}
2−{-# LANGUAGE QuasiQuotes #-}
3−{-# LANGUAGE OverloadedStrings #-}
4−
5−module Obelisk.Snap where
6−
7−import Obelisk.Asset.Serve.Snap
8−import Obelisk.Snap.Extras
9−
10−import Snap
11−
12−import Control.Lens
13−import Data.ByteString (ByteString)
14−import Data.Default
15−import Data.Monoid
16−import qualified Data.Text as T
17−import Lucid
18−import System.FilePath
19−import Control.Monad.IO.Class
20−
21−-- Data type for web app configuration
22−data AppConfig m
23− = AppConfig { _appConfig_initialBody :: m ByteString
24− , _appConfig_initialHead :: ByteString
25− , _appConfig_serveJsexe :: Bool
26− , _appConfig_jsexe :: FilePath
27− }
28−
29−-- Default instance for app configuration
30−instance Monad m => Default (AppConfig m) where
31− def = AppConfig { _appConfig_initialBody = return mempty
32− , _appConfig_initialHead = mempty
33− , _appConfig_serveJsexe = True
34− , _appConfig_jsexe = "frontend.jsexe"
35− }
36−
37−{- | Takes a location, app, and an app configuration as arguements and
38− routes the request to the correct handler. If "appConfig_serveJsexe"
39− returns "True", additional js paths and asset paths will be appended to
40− handler. Otherwise, it will return "404 Not Found" -}
41−serveAppAt :: MonadSnap m => ByteString -> FilePath -> AppConfig m -> m ()
42−serveAppAt loc app cfg = do
43− route $ [ (loc, ifTop $ serveStaticIndex cfg)
44− , (loc, serveAssets (app </> "static.assets") (app </> "static"))
45− , (loc <> "/version", doNotCache >> serveFileIfExistsAs "text/plain" (app </> "version"))
46− ]
47− ++ if _appConfig_serveJsexe cfg
48− then [(loc, serveAssets (app </> frontendJsAssetsPath cfg) (app </> frontendJsPath cfg))]
49− else []
50− ++ [ (loc, doNotCache >> error404) ]
51−
52−-- Helper function used in 'serveAppAt', writes a 404 error message in ByteString
53−error404 :: MonadSnap m => m ()
54−error404 = do
55− modifyResponse $ setResponseCode 404
56− writeBS "404 Not Found"
57−
58−-- Partially applied 'serveAppAt', specialized to the root directory
59−serveApp :: MonadSnap m => FilePath -> AppConfig m -> m ()
60−serveApp = serveAppAt ""
61−
62−-- Helper function used in 'serveAppAt', returns a frontendJs/... filepath
63−frontendJsPath :: AppConfig m -> FilePath
64−frontendJsPath (AppConfig { _appConfig_jsexe = jsexe }) = "frontendJs" </> jsexe
65−
66−-- Helper function used in 'serveAppAt', returns a frontendJs.assets/... filepath
67−frontendJsAssetsPath :: AppConfig m -> FilePath
68−frontendJsAssetsPath (AppConfig { _appConfig_jsexe = jsexe }) = "frontendJs.assets" </> jsexe
69−
70−-- Helper funtion used in 'serveAppAt', writes a lazy bytestring to the body of Http response
71−serveStaticIndex :: MonadSnap m => AppConfig m -> m ()
72−serveStaticIndex cfg = do
73− -- Decode, pack, and append asset target to file path
74− appJsPath <- liftIO $ getAssetPath (frontendJsAssetsPath cfg) "/all.js"
75− initialBody <- _appConfig_initialBody cfg
76− -- Render and write html head and body to response
77− writeLBS $ renderBS $ doctypehtml_ $ do
78− head_ $ do
79− meta_ [charset_ "utf-8"] -- meta-data charset description
80− meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"] -- meta-data viewport description
81− toHtmlRaw $ _appConfig_initialHead cfg
82− body_ $ do -- <body>
83− toHtmlRaw initialBody -- HtmlT monad wrapper
84− script_ [type_ "application/javascript", src_ (maybe "/all.js" T.pack appJsPath), defer_ "defer"] ("" :: String)
85−
86−{- | Takes an AppConfig monad and uses it to generate & write Lazy ByteString
87− to the body of the https response. This one comes with hard coded values
88− for the logo -}
89−serveIndex :: MonadSnap m => AppConfig m -> m ()
90−serveIndex cfg = do
91− appJsPath <- liftIO $ getAssetPath (frontendJsAssetsPath cfg) "all.js"
92− writeLBS $ renderBS $ doctypehtml_ $ do
93− head_ $ do
94− meta_ [charset_ "utf-8"]
95− meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"]
96− body_ $ do
97− script_ [type_ "application/javascript", src_ (maybe "/all.js" T.pack appJsPath), defer_ "defer"] ("" :: String)
98−
99−makeLenses ''AppConfig