8b69a0b · obelisk · git.iko.soy

lib/asset/serve-snap/obelisk-asset-serve.cabal → lib/asset/serve-snap/obelisk-asset-serve-snap.cabalrenamed

compare with master

unifiedsplit

The content is the same.

lib/backend/obelisk-backend.cabal+6−3

@@ -6,9 +6,12 @@ build-type: Simple

6library

7 hs-source-dirs: src

8 build-depends: base,

9− snap,

9+ bytestring,

10− snap-server,

11 data-default,

10 data-default,

11+ lens,

12 obelisk-asset-serve-snap,

13− bytestring

13+ obelisk-snap,

14+ reflex-dom,

15+ snap,

16+ snap-server

14 exposed-modules: Obelisk.Backend

17 exposed-modules: Obelisk.Backend

lib/backend/src/Obelisk/Backend.hs+12−4

@@ -1,14 +1,17 @@

1{-# LANGUAGE OverloadedStrings #-}

2module Obelisk.Backend

3 ( backend

4− , BackendConfig

4+ , BackendConfig (..)

5 -- * Re-exports

6 , Default (def)

7 ) where

8

9+import Control.Lens

9import qualified Data.ByteString.Char8 as BSC8

10import qualified Data.ByteString.Char8 as BSC8

10import Data.Default (Default (..))

11import Data.Default (Default (..))

11import Obelisk.Asset.Serve.Snap (serveAssets)

12import Obelisk.Asset.Serve.Snap (serveAssets)

13+import Obelisk.Snap

14+import Reflex.Dom

12import System.IO (hSetBuffering, stderr, BufferMode (..))

15import System.IO (hSetBuffering, stderr, BufferMode (..))

13import Snap (httpServe, defaultConfig, commandLineConfig, route)

16import Snap (httpServe, defaultConfig, commandLineConfig, route)

14import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog (ConfigIoLog))

17import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog (ConfigIoLog))

@@ -17,25 +20,30 @@ import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog

17-- | Configure the operation of the Obelisk backend. For reasonable defaults,

20-- | Configure the operation of the Obelisk backend. For reasonable defaults,

18-- use 'def'.

21-- use 'def'.

19data BackendConfig = BackendConfig

22data BackendConfig = BackendConfig

23+ { _backendConfig_head :: StaticWidget () ()

24+ }

20

25

21instance Default BackendConfig where

26instance Default BackendConfig where

22− def = BackendConfig

27+ def = BackendConfig (return ())

23

28

24-- | Start an Obelisk backend

29-- | Start an Obelisk backend

25backend :: BackendConfig -> IO ()

30backend :: BackendConfig -> IO ()

26−backend _ = do

31+backend cfg = do

27 -- Make output more legible by decreasing the likelihood of output from

32 -- Make output more legible by decreasing the likelihood of output from

28 -- multiple threads being interleaved

33 -- multiple threads being interleaved

29 hSetBuffering stderr LineBuffering

34 hSetBuffering stderr LineBuffering

30

35

31 -- Get the web server configuration from the command line

36 -- Get the web server configuration from the command line

32 cmdLineConf <- commandLineConfig defaultConfig

37 cmdLineConf <- commandLineConfig defaultConfig

38+ headHtml <- fmap snd $ renderStatic $ _backendConfig_head cfg

33 let httpConf = cmdLineConf

39 let httpConf = cmdLineConf

34 { accessLog = Just $ ConfigIoLog BSC8.putStrLn

40 { accessLog = Just $ ConfigIoLog BSC8.putStrLn

35 , errorLog = Just $ ConfigIoLog BSC8.putStrLn

41 , errorLog = Just $ ConfigIoLog BSC8.putStrLn

36 }

42 }

43+ appCfg = def & appConfig_initialHead .~ headHtml

37 -- Start the web server

44 -- Start the web server

38 httpServe httpConf $ route

45 httpServe httpConf $ route

46+ [ ("", serveApp "" appCfg)

39− [ ("", serveAssets "frontend.jsexe.assets" "frontend.jsexe") --TODO: Can we prevent naming conflicts between frontend.jsexe and static?

47+ , ("", serveAssets "frontend.jsexe.assets" "frontend.jsexe") --TODO: Can we prevent naming conflicts between frontend.jsexe and static?

40 , ("", serveAssets "static.assets" "static")

48 , ("", serveAssets "static.assets" "static")

41 ]

49 ]

lib/run/obelisk-run.cabal+1

@@ -12,6 +12,7 @@ library

12 , bytestring

13 , http-client

14 , http-reverse-proxy

15+ , http-types

15 , jsaddle

16 , jsaddle

16 , jsaddle-warp

17 , jsaddle-warp

17 , lens

18 , lens

lib/run/src/Obelisk/Run.hs+29−8

@@ -5,24 +5,28 @@ module Obelisk.Run where

5

6import Control.Concurrent

7import Control.Exception

8−import Control.Lens ((^?), _Right, _Just)

8+import Control.Lens ((^?), _Just, _Right)

9import qualified Data.Attoparsec.ByteString.Char8 as A

10import Data.ByteString (ByteString)

11import qualified Data.ByteString.Char8 as BSC

12+import qualified Data.ByteString.Lazy.Char8 as BSLC

12import Data.List (uncons)

13import Data.List (uncons)

13import Data.Maybe

14import Data.Maybe

14import Data.Semigroup ((<>))

15import Data.Semigroup ((<>))

15import Data.Streaming.Network (bindPortTCP)

16import Data.Streaming.Network (bindPortTCP)

16import qualified Data.Text as T

17import qualified Data.Text as T

17−import Language.Javascript.JSaddle.WebSockets

18import Language.Javascript.JSaddle.Run (syncPoint)

19+import Language.Javascript.JSaddle.WebSockets

19−import Network.HTTP.Client (defaultManagerSettings, newManager, Manager)

20+import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)

20import qualified Network.HTTP.ReverseProxy as RP

21import qualified Network.HTTP.ReverseProxy as RP

22+import qualified Network.HTTP.Types as H

21import Network.Socket

23import Network.Socket

22import Network.Wai (Application)

24import Network.Wai (Application)

25+import qualified Network.Wai as W

23import Network.Wai.Handler.Warp

26import Network.Wai.Handler.Warp

27+import Network.Wai.Handler.Warp.Internal (settingsHost, settingsPort)

28+import Network.WebSockets (ConnectionOptions)

24import Network.WebSockets.Connection (defaultConnectionOptions)

29import Network.WebSockets.Connection (defaultConnectionOptions)

25−import Network.Wai.Handler.Warp.Internal (settingsPort, settingsHost)

26import Obelisk.ExecutableConfig (get)

30import Obelisk.ExecutableConfig (get)

27import Reflex.Dom.Core

31import Reflex.Dom.Core

28import System.Environment

32import System.Environment

@@ -34,7 +38,7 @@ import Text.URI.Lens

34

38

35run :: Int -- ^ Port to run the backend

39run :: Int -- ^ Port to run the backend

36 -> IO () -- ^ Backend

40 -> IO () -- ^ Backend

37− -> Widget () () -- ^ Frontend widget

41+ -> (StaticWidget () (), Widget () ()) -- ^ Frontend widget (head, body)

38 -> IO ()

42 -> IO ()

39run port backend frontend = do

43run port backend frontend = do

40 let handleBackendErr (_ :: SomeException) = hPutStrLn stderr "backend stopped; make a change to your code to reload"

44 let handleBackendErr (_ :: SomeException) = hPutStrLn stderr "backend stopped; make a change to your code to reload"

@@ -52,8 +56,8 @@ getConfigRoute = do

52defAppUri :: URI

56defAppUri :: URI

53defAppUri = fromMaybe (error "defAppUri") $ URI.mkURI "http://127.0.0.1:8000"

57defAppUri = fromMaybe (error "defAppUri") $ URI.mkURI "http://127.0.0.1:8000"

54

58

55−runWidget :: RunConfig -> Widget () () -> IO ()

59+runWidget :: RunConfig -> (StaticWidget () (), Widget () ()) -> IO ()

56−runWidget conf w = do

60+runWidget conf (h, b) = do

57 uri <- fromMaybe defAppUri <$> getConfigRoute

61 uri <- fromMaybe defAppUri <$> getConfigRoute

58 let port = fromIntegral $ fromMaybe 80 $ uri ^? uriAuthority . _Right . authPort . _Just

62 let port = fromIntegral $ fromMaybe 80 $ uri ^? uriAuthority . _Right . authPort . _Just

59 redirectHost = _runConfig_redirectHost conf

63 redirectHost = _runConfig_redirectHost conf

@@ -66,9 +70,26 @@ runWidget conf w = do

66 close

70 close

67 (\skt -> do

71 (\skt -> do

68 man <- newManager defaultManagerSettings

72 man <- newManager defaultManagerSettings

69− app <- jsaddleWithAppOr defaultConnectionOptions (mainWidget' w >> syncPoint) (fallbackProxy redirectHost redirectPort man)

73+ app <- obeliskApp defaultConnectionOptions h b (fallbackProxy redirectHost redirectPort man)

70 runSettingsSocket settings skt app)

74 runSettingsSocket settings skt app)

71

75

76+obeliskApp :: ConnectionOptions -> StaticWidget () () -> Widget () () -> Application -> IO Application

77+obeliskApp opts h b backend = do

78+ html <- BSLC.fromStrict <$> indexHtml h

79+ let entryPoint = mainWidget' b >> syncPoint

80+ jsaddleOr opts entryPoint $ \req sendResponse -> case (W.requestMethod req, W.pathInfo req) of

81+ ("GET", []) -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "text/html")] html

82+ ("GET", ["jsaddle.js"]) -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs False

83+ _ -> backend req sendResponse

84+

85+indexHtml :: StaticWidget () () -> IO ByteString

86+indexHtml h = do

87+ ((), bs) <- renderStatic $ el "html" $ do

88+ el "head" $ h

89+ el "body" $ return ()

90+ elAttr "script" ("src" =: "/jsaddle.js") $ return ()

91+ return $ "<!DOCTYPE html>" <> bs

92+

72-- | like 'bindPortTCP' but reconnects on exception

93-- | like 'bindPortTCP' but reconnects on exception

73bindPortTCPRetry :: Settings

94bindPortTCPRetry :: Settings

74 -> (IOError -> IO ()) -- ^ Action to run the first time an exception is caught

95 -> (IOError -> IO ()) -- ^ Action to run the first time an exception is caught

lib/snap/default.nixdeleted−17

@@ -1,17 +0,0 @@

1−{ mkDerivation, base, bytestring, data-default, diagrams-lib

2−, diagrams-svg, filepath, lens, lucid, monad-control

3−, obelisk-asset-serve, raw-strings-qq, semigroups, snap, snap-core

4−, stdenv, svg-builder, text, transformers-base

5−}:

6−mkDerivation {

7− pname = "obelisk-snap";

8− version = "0.1";

9− src = ./.;

10− libraryHaskellDepends = [

11− base bytestring data-default diagrams-lib diagrams-svg filepath

12− lens lucid monad-control obelisk-asset-serve raw-strings-qq

13− semigroups snap snap-core svg-builder text transformers-base

14− ];

15− description = "Project Synopsis Here";

16− license = stdenv.lib.licenses.bsd3;

17−}

lib/snap/obelisk-snap.cabal+2−1

@@ -23,7 +23,8 @@ library

23 lens,

24 lucid,

25 monad-control,

26− obelisk-asset-serve,

26+ obelisk-asset-serve-snap,

27+ obelisk-snap-extras,

27 semigroups,

28 semigroups,

28 raw-strings-qq,

29 raw-strings-qq,

29 snap,

30 snap,

lib/snap/src/Obelisk/Snap.hs+12−71

@@ -4,44 +4,31 @@

4

5module Obelisk.Snap where

6

7−import Obelisk.Asset.Serve

7+import Obelisk.Asset.Serve.Snap

8+import Obelisk.Snap.Extras

8

9

9import Snap

10import Snap

10

11

11import Control.Lens

12import Control.Lens

12import Data.ByteString (ByteString)

13import Data.ByteString (ByteString)

13import Data.Default

14import Data.Default

14−import Data.Maybe

15import Data.Monoid

16−import Data.String

17−import Data.Text (Text)

18import qualified Data.Text as T

16import 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

23import Lucid

17import Lucid

24import System.FilePath

18import System.FilePath

25−import Text.RawString.QQ

26import Control.Monad.IO.Class

19import Control.Monad.IO.Class

27

20

28-- Data type for web app configuration

21-- Data type for web app configuration

29data AppConfig m

22data AppConfig m

30− = AppConfig { _appConfig_logo :: Diagram SVG

31− , _appConfig_extraHeadMarkup :: Html ()

32− , _appConfig_initialStyles :: Maybe Text

33− , _appConfig_initialBody :: Maybe (m ByteString)

23+ = AppConfig { _appConfig_initialBody :: m ByteString

34− , _appConfig_initialHead :: Maybe ByteString

24+ , _appConfig_initialHead :: ByteString

35 , _appConfig_serveJsexe :: Bool

25 , _appConfig_serveJsexe :: Bool

36 , _appConfig_jsexe :: FilePath

26 , _appConfig_jsexe :: FilePath

37 }

27 }

38

28

39-- Default instance for app configuration

29-- Default instance for app configuration

40−instance Default (AppConfig m) where

30+instance Monad m => Default (AppConfig m) where

41− def = AppConfig { _appConfig_logo = mempty

42− , _appConfig_extraHeadMarkup = mempty

43− , _appConfig_initialStyles = mempty

44− , _appConfig_initialBody = Nothing

31+ def = AppConfig { _appConfig_initialBody = return mempty

45 , _appConfig_initialHead = mempty

32 , _appConfig_initialHead = mempty

46 , _appConfig_serveJsexe = True

33 , _appConfig_serveJsexe = True

47 , _appConfig_jsexe = "frontend.jsexe"

34 , _appConfig_jsexe = "frontend.jsexe"

@@ -83,28 +70,18 @@ frontendJsAssetsPath (AppConfig { _appConfig_jsexe = jsexe }) = "frontendJs.asse

83-- Helper funtion used in 'serveAppAt', writes a lazy bytestring to the body of Http response

70-- Helper funtion used in 'serveAppAt', writes a lazy bytestring to the body of Http response

84serveStaticIndex :: MonadSnap m => AppConfig m -> m ()

71serveStaticIndex :: MonadSnap m => AppConfig m -> m ()

85serveStaticIndex cfg = do

72serveStaticIndex cfg = do

86− -- Decode, pack, and append asset target to file path

73+ -- Decode, pack, and append asset target to file path

87 appJsPath <- liftIO $ getAssetPath (frontendJsAssetsPath cfg) "/all.js"

74 appJsPath <- liftIO $ getAssetPath (frontendJsAssetsPath cfg) "/all.js"

88− -- extract initial body from 'AppConfig' or return empty string

89− initialBody <- fromMaybe (return "") $ _appConfig_initialBody cfg

75+ initialBody <- _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

76+ -- Render and write html head and body to response

96 writeLBS $ renderBS $ doctypehtml_ $ do

77 writeLBS $ renderBS $ doctypehtml_ $ do

97 head_ $ do

78 head_ $ do

98 meta_ [charset_ "utf-8"] -- meta-data charset description

79 meta_ [charset_ "utf-8"] -- meta-data charset description

99 meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"] -- meta-data viewport description

80 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

81+ toHtmlRaw $ _appConfig_initialHead cfg

101− toHtmlRaw initialHead -- HtmlT monad wrapper

102− style_ initialStyles -- generate style element/attribute

103 body_ $ do -- <body>

82 body_ $ do -- <body>

104 toHtmlRaw initialBody -- HtmlT monad wrapper

83 toHtmlRaw initialBody -- HtmlT monad wrapper

105− script_ [type_ "text/javascript", src_ (maybe "/all.js" T.pack appJsPath), defer_ "defer"] ("" :: String)

84+ script_ [type_ "application/javascript", src_ (maybe "/all.js" T.pack appJsPath), defer_ "defer"] ("" :: String)

106− -- create <script> element

107− return ()

108

85

109{- | Takes an AppConfig monad and uses it to generate & write Lazy ByteString

86{- | Takes an AppConfig monad and uses it to generate & write Lazy ByteString

110 to the body of the https response. This one comes with hard coded values

87 to the body of the https response. This one comes with hard coded values

@@ -116,43 +93,7 @@ serveIndex cfg = do

116 head_ $ do

93 head_ $ do

117 meta_ [charset_ "utf-8"]

94 meta_ [charset_ "utf-8"]

118 meta_ [name_ "viewport", content_ "width=device-width, initial-scale=1.0"]

95 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− |]

153 body_ $ do

96 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)

157

98

158makeLenses ''AppConfig

99makeLenses ''AppConfig

skeleton/backend/backend.cabal+2

@@ -9,6 +9,7 @@ library

9 buildable: False

10 build-depends: base

11 , common

12+ , frontend

12 , obelisk-backend

13 , obelisk-backend

13 exposed-modules:

14 exposed-modules:

14 Backend

15 Backend

@@ -22,6 +23,7 @@ executable backend

22 build-depends: base

23 build-depends: base

23 , backend

24 , backend

24 , common

25 , common

26+ , frontend

25 , lens

27 , lens

26 , modern-uri

28 , modern-uri

27 , obelisk-backend

29 , obelisk-backend

skeleton/backend/frontendJs/frontend.jsexenew file+1

@@ -0,0 +1 @@

1+../../frontend-js/bin/frontend.jsexe

skeleton/backend/src/Backend.hs+3

@@ -1,7 +1,10 @@

1module Backend where

2

3import Common.Api

4+import Frontend

4import qualified Obelisk.Backend as Ob

5import qualified Obelisk.Backend as Ob

5

6

6backend :: IO ()

7backend :: IO ()

7backend = Ob.backend Ob.def

8backend = Ob.backend Ob.def

9+ { Ob._backendConfig_head = fst frontend

10+ }

skeleton/frontend/src/Frontend.hs+11−10

@@ -1,18 +1,19 @@

1+{-# LANGUAGE DataKinds #-}

1{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE OverloadedStrings #-}

2{-# LANGUAGE TypeApplications #-}

3{-# LANGUAGE TypeApplications #-}

3−{-# LANGUAGE DataKinds #-}

4module Frontend where

5

6−import Reflex.Dom

7−

8import qualified Data.Text as T

6import qualified Data.Text as T

7+import Reflex.Dom.Core

9

8

10−import Static

11import Common.Api

9import Common.Api

10+import Static

12

11

13−frontend :: Widget x ()

12+frontend :: (StaticWidget x (), Widget x ())

14−frontend = do

13+frontend = (head', body)

14+ where

15+ head' = el "title" $ text "Obelisk Minimal Example"

16+ body = do

15− text "Welcome to Obelisk!"

17+ text "Welcome to Obelisk!"

16− el "p" $ text $ T.pack commonStuff

18+ el "p" $ text $ T.pack commonStuff

17− elAttr "img" ("src" =: static @"obelisk.jpg") blank

19+ elAttr "img" ("src" =: static @"obelisk.jpg") blank

18−

skeleton/frontend/src/main.hs+1−1

@@ -2,4 +2,4 @@ import Reflex.Dom

2import Frontend

3

4main :: IO ()

5−main = mainWidget frontend

5+main = mainWidget $ snd frontend