b2aed54 · obelisk · git.iko.soy

git.iko.soy/obelisk

Merge branch 'develop' into readme-install-source

b2aed54Ali Abrar7 years ago

ChangeLog.md+9

@@ -3,12 +3,21 @@

3This project's release branch is `master`. This log is written from the perspective of the release branch: when changes hit `master`, they are considered released, and the date should reflect that release.

5## Unreleased

7+* Generalised pathSegmentEncoder, added pathFieldEncoder.

8+* Added some Prisms to the encoder library for manipulating DSums (perhaps they should get moved to dependent-sum before release?)

9+* Add "ob doc" command, which lists paths to haddock documentation for specified packages

10+* Bump reflex-platform so that obelisk now uses GHC 8.6.5 and the nixos-19.03 nixpkgs set

11+

12+## v0.2.0.0 - 2019-8-17

13+

6* Configs become ByteStrings.

14* Configs become ByteStrings.

7* FrontendConfigsT has been changed into ConfigsT and configs are made available via getConfig/getConfigs

15* FrontendConfigsT has been changed into ConfigsT and configs are made available via getConfig/getConfigs

8 * The frontend will still only have access to configs that are placed in config/frontend and config/common, while the backend has access to the entire contents of the config directory via `Obelisk.ExecutableConfig.Lookup.getConfigs`.

16 * The frontend will still only have access to configs that are placed in config/frontend and config/common, while the backend has access to the entire contents of the config directory via `Obelisk.ExecutableConfig.Lookup.getConfigs`.

9* The backend no longer runs in BackendConfigsT.

17* The backend no longer runs in BackendConfigsT.

10* Add tabulation package. See Data.Tabulation for details.

18* Add tabulation package. See Data.Tabulation for details.

11* Add encoders for `DMap`, `HasFields` (cf. Data.Tabulation), and JSON.

19* Add encoders for `DMap`, `HasFields` (cf. Data.Tabulation), and JSON.

20+* Use IP address for nginx proxy pass instead of localhost

13## v0.1.1.0 - 2019-05-17

22## v0.1.1.0 - 2019-05-17

default.nix+17−12

@@ -32,13 +32,13 @@ let

32 # Fix misc upstream packages

33 (self: super: let

34 pkgs = self.callPackage ({ pkgs }: pkgs) {};

35+ haskellLib = pkgs.haskell.lib;

35 in {

36 in {

36− hnix = pkgs.haskell.lib.dontCheck (self.callCabal2nix "hnix" (pkgs.fetchFromGitHub {

37+ hnix = haskellLib.overrideCabal (self.callHackage "hnix" "0.6.1" { these = self.these_0_8; }) (_: {

37− owner = "haskell-nix";

38+ jailbreak = true;

38− repo = "hnix";

39+ doCheck = false;

39− rev = "42afdc21da5d9e076eab57eaa42bfdde938192b8";

40+ });

40− sha256 = "0psw384dx9bw2dp93xrzw8rd9amvcwgzn64jzzwby7sfspj6k349";

41+ hnix-store-core = self.callHackage "hnix-store-core" "0.1.0.0" {};

41− }) {});

42 })

44 pkgs.obeliskExecutableConfig.haskellOverlay

@@ -157,12 +157,16 @@ in rec {

157 obelisk-asset-manifest-generate "$src" "$haskellManifest" ${packageName} ${moduleName} "$symlinked"

158 '';

159

160− compressedJs = frontend: optimizationLevel: pkgs.runCommand "compressedJs" { buildInputs = [ pkgs.closurecompiler ]; } ''

160+ compressedJs = frontend: optimizationLevel: pkgs.runCommand "compressedJs" {} ''

161 mkdir $out

162 cd $out

163 ln -s "${haskellLib.justStaticExecutables frontend}/bin/frontend.jsexe/all.js" all.unminified.js

164+ ${if optimizationLevel == null then ''

165+ ln -s all.unminified.js all.js

166+ '' else ''

164− closure-compiler --externs "${reflex-platform.ghcjsExternsJs}" -O ${optimizationLevel} --jscomp_warning=checkVars --create_source_map="all.js.map" --source_map_format=V3 --js_output_file="all.js" all.unminified.js

167+ ${pkgs.closurecompiler}/bin/closure-compiler --externs "${reflex-platform.ghcjsExternsJs}" -O ${optimizationLevel} --jscomp_warning=checkVars --create_source_map="all.js.map" --source_map_format=V3 --js_output_file="all.js" all.unminified.js

165− echo "//# sourceMappingURL=all.js.map" >> all.js

168+ echo "//# sourceMappingURL=all.js.map" >> all.js

169+ ''}

166 '';

170 '';

167

171

168 serverModules = {

172 serverModules = {

@@ -198,7 +202,7 @@ in rec {

198 enableACME = enableHttps;

202 enableACME = enableHttps;

199 forceSSL = enableHttps;

203 forceSSL = enableHttps;

200 locations.${baseUrl} = {

204 locations.${baseUrl} = {

201− proxyPass = "http://localhost:" + toString internalPort;

205+ proxyPass = "http://127.0.0.1:" + toString internalPort;

202 proxyWebsockets = true;

206 proxyWebsockets = true;

203 };

207 };

204 };

208 };

@@ -207,10 +211,11 @@ in rec {

207 wantedBy = [ "multi-user.target" ];

211 wantedBy = [ "multi-user.target" ];

208 after = [ "network.target" ];

212 after = [ "network.target" ];

209 restartIfChanged = true;

213 restartIfChanged = true;

214+ path = [ pkgs.gnutar ];

210 script = ''

215 script = ''

211 ln -sft . '${exe}'/*

216 ln -sft . '${exe}'/*

212 mkdir -p log

217 mkdir -p log

213− exec ./backend ${backendArgs} >>backend.out 2>>backend.err </dev/null

218+ exec ./backend ${backendArgs} </dev/null

214 '';

219 '';

215 serviceConfig = {

220 serviceConfig = {

216 User = user;

221 User = user;

@@ -268,7 +273,7 @@ in rec {

268 , tools ? _: []

273 , tools ? _: []

269 , shellToolOverrides ? _: _: {}

274 , shellToolOverrides ? _: _: {}

270 , withHoogle ? false # Setting this to `true` makes shell reloading far slower

275 , withHoogle ? false # Setting this to `true` makes shell reloading far slower

271− , __closureCompilerOptimizationLevel ? "ADVANCED"

276+ , __closureCompilerOptimizationLevel ? "ADVANCED" # Set this to `null` to skip the closure-compiler step

272 }:

277 }:

273 let frontendName = "frontend";

278 let frontendName = "frontend";

274 backendName = "backend";

279 backendName = "backend";

dep/reflex-platform/github.json+3−3

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

2 "owner": "reflex-frp",

3 "repo": "reflex-platform",

4− "branch": "cg-bump-reflex-dom",

4+ "branch": "aa-split-these",

5− "rev": "7ecb4c255bb053a7a4796ffd6331cdbe210de91c",

5+ "rev": "4b4a2c8679d6f3042180d2974b31c43bfc506b91",

6− "sha256": "1mngxa24cfpvxxq4hgh77nw36vny4abl5wi2xmlwpkk25wzm0h0x"

6+ "sha256": "185i8ccqk0xc05ckd921fs7nnaj88gihmlazny1dk004hxq78cj2"

lib/asset/serve-snap/src/Obelisk/Asset/Serve/Snap.hs+7−6

@@ -19,6 +19,7 @@ import Control.Applicative ((<|>))

19import Control.Exception (handleJust, try, throwIO)

20import Control.Monad (forM, liftM)

21import Control.Monad.IO.Class (liftIO)

22+import Control.Monad.Fail (MonadFail)

22import Data.Attoparsec.ByteString (parseOnly, endOfInput)

23import Data.Attoparsec.ByteString (parseOnly, endOfInput)

23import Data.ByteString (ByteString)

24import Data.ByteString (ByteString)

24import qualified Data.ByteString as BS

25import qualified Data.ByteString as BS

@@ -38,7 +39,7 @@ import System.Posix (getFileStatus, fileSize)

38-- current version of the asset

39-- current version of the asset

39-- (e.g. @0rx5yvkkgkig2pcqf4ngi1l7vh89qqajdzc6aiayaibyhvj0d853-test.png@). Hashed

40-- (e.g. @0rx5yvkkgkig2pcqf4ngi1l7vh89qqajdzc6aiayaibyhvj0d853-test.png@). Hashed

40-- asset names will be sent with permanent caching headers.

41-- asset names will be sent with permanent caching headers.

41−serveAssets :: MonadSnap m => FilePath -> FilePath -> m ()

42+serveAssets :: (MonadSnap m, MonadFail m) => FilePath -> FilePath -> m ()

42serveAssets = serveAssets' True

43serveAssets = serveAssets' True

44-- | Serve static assets from an asset directory generated via @assets.nix@ or, failing that, from a regular directory.

45-- | Serve static assets from an asset directory generated via @assets.nix@ or, failing that, from a regular directory.

@@ -47,15 +48,15 @@ serveAssets = serveAssets' True

47-- browser for the logical asset name (e.g. @test.png@) but instead the current

48-- browser for the logical asset name (e.g. @test.png@) but instead the current

48-- version of the asset with to point the browser at the unique filename for the

49-- version of the asset with to point the browser at the unique filename for the

49-- current version of the asset.

50-- current version of the asset.

50−serveAssetsInPlace :: MonadSnap m => FilePath -> FilePath -> m ()

51+serveAssetsInPlace :: (MonadSnap m, MonadFail m) => FilePath -> FilePath -> m ()

51serveAssetsInPlace = serveAssets' False

52serveAssetsInPlace = serveAssets' False

53-- | Like 'serveAssets', but only serves a single specified asset

54-- | Like 'serveAssets', but only serves a single specified asset

54−serveAsset :: MonadSnap m => FilePath -> FilePath -> FilePath -> m ()

55+serveAsset :: (MonadSnap m, MonadFail m) => FilePath -> FilePath -> FilePath -> m ()

55serveAsset = serveAsset' True

56serveAsset = serveAsset' True

57-- | Like 'serveAssetsInPlace', but only serves a single specified asset

58-- | Like 'serveAssetsInPlace', but only serves a single specified asset

58−serveAssetInPlace :: MonadSnap m => FilePath -> FilePath -> FilePath -> m ()

59+serveAssetInPlace :: (MonadSnap m, MonadFail m) => FilePath -> FilePath -> FilePath -> m ()

59serveAssetInPlace = serveAsset' False

60serveAssetInPlace = serveAsset' False

61-- | Serve static assets from an asset directory generated via @assets.nix@ or, failing that, from a regular directory.

62-- | Serve static assets from an asset directory generated via @assets.nix@ or, failing that, from a regular directory.

@@ -63,13 +64,13 @@ serveAssetInPlace = serveAsset' False

63-- For assets generated from @assets.nix@, the @Bool@ argument @doRedirect@ controls whether redirects will be sent to the browser if a request is made for

64-- For assets generated from @assets.nix@, the @Bool@ argument @doRedirect@ controls whether redirects will be sent to the browser if a request is made for

64-- an unhashed asset name, e.g. @test.png@. For @True@, a redirect will be sent, yielding more round trips to the server but better caching behavior if the

65-- an unhashed asset name, e.g. @test.png@. For @True@, a redirect will be sent, yielding more round trips to the server but better caching behavior if the

65-- asset doesn't change often. Conversely for @False@, the asset will be served "in place" but made uncacheable.

66-- asset doesn't change often. Conversely for @False@, the asset will be served "in place" but made uncacheable.

66−serveAssets' :: MonadSnap m => Bool -> FilePath -> FilePath -> m ()

67+serveAssets' :: (MonadSnap m, MonadFail m) => Bool -> FilePath -> FilePath -> m ()

67serveAssets' doRedirect base fallback = do

68serveAssets' doRedirect base fallback = do

68 pRaw <- getSafePath

69 pRaw <- getSafePath

69 serveAsset' doRedirect base fallback $ if "/" `isSuffixOf` pRaw || pRaw == "" then pRaw <> "index.html" else pRaw

70 serveAsset' doRedirect base fallback $ if "/" `isSuffixOf` pRaw || pRaw == "" then pRaw <> "index.html" else pRaw

71-- | Serve a single static asset from an asset directory generated via @assets.nix@ or, failing that, from a regular directory.

72-- | Serve a single static asset from an asset directory generated via @assets.nix@ or, failing that, from a regular directory.

72−serveAsset' :: MonadSnap m => Bool -> FilePath -> FilePath -> FilePath -> m ()

73+serveAsset' :: (MonadFail m, MonadSnap m) => Bool -> FilePath -> FilePath -> FilePath -> m ()

73serveAsset' doRedirect base fallback p = do

74serveAsset' doRedirect base fallback p = do

74 assetType <- liftIO $ try $ BS.readFile $ base </> p </> "type"

75 assetType <- liftIO $ try $ BS.readFile $ base </> p </> "type"

75 case assetType of

76 case assetType of

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

@@ -26,12 +26,12 @@ import Prelude hiding (id, (.))

26import Control.Category

27import Control.Monad

28import Control.Monad.Except

29+import Control.Monad.Fail (MonadFail)

29import Control.Categorical.Bifunctor

30import Control.Categorical.Bifunctor

30import Data.ByteString (ByteString)

31import Data.ByteString (ByteString)

31import qualified Data.ByteString.Char8 as BSC8

32import qualified Data.ByteString.Char8 as BSC8

32import Data.Default (Default (..))

33import Data.Default (Default (..))

33import Data.Dependent.Sum

34import Data.Dependent.Sum

34−import Data.Functor.Sum

35import Data.Functor.Identity

36import Data.Map (Map)

37import qualified Data.Map as Map

@@ -52,7 +52,7 @@ import Snap.Internal.Http.Server.Config (Config (accessLog, errorLog), ConfigLog

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

55+ { _backend_routeEncoder :: Encoder (Either Text) Identity (R (FullRoute backendRoute frontendRoute)) PageName

56 , _backend_run :: ((R backendRoute -> Snap ()) -> IO ()) -> IO ()

57 }

@@ -65,7 +65,7 @@ data GhcjsApp route = GhcjsApp

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)

68+ :: (MonadSnap m, HasCookies m, MonadFail m)

69 => (R appRoute

70 -> Text)

71 -> ([Text]

@@ -114,11 +114,7 @@ getPageName :: (MonadSnap m) => m PageName

114getPageName = do

115 p <- getsRequest rqPathInfo

116 q <- getsRequest rqQueryString

117− let pageNameEncoder' :: Encoder Identity Identity PageName (String, String)

117+ return $ byteStringsToPageName p q

118− pageNameEncoder' = bimap

119− (unpackTextEncoder . pathSegmentsTextEncoder . listToNonEmptyEncoder)

120− (unpackTextEncoder . queryParametersTextEncoder . toListMapEncoder)

121− return $ decode pageNameEncoder' (T.unpack (decodeUtf8 p), T.unpack (decodeUtf8 q))

122

118

123getRouteWith :: (MonadSnap m) => Encoder Identity parse route PageName -> m (parse route)

119getRouteWith :: (MonadSnap m) => Encoder Identity parse route PageName -> m (parse route)

124getRouteWith e = do

120getRouteWith e = do

@@ -126,7 +122,7 @@ getRouteWith e = do

126 return $ tryDecode e pageName

122 return $ tryDecode e pageName

127

123

128serveObeliskApp

124serveObeliskApp

129− :: (MonadSnap m, HasCookies m)

125+ :: (MonadSnap m, HasCookies m, MonadFail m)

130 => (R appRoute -> Text)

126 => (R appRoute -> Text)

131 -> ([Text] -> m ())

127 -> ([Text] -> m ())

132 -> GhcjsApp (R appRoute)

128 -> GhcjsApp (R appRoute)

@@ -144,7 +140,7 @@ serveObeliskApp urlEnc serveStaticAsset frontendApp config = \case

144 writeText msg

140 writeText msg

145 ResourceRoute_Version :=> Identity () -> doNotCache >> serveFileIfExistsAs "text/plain" "version"

141 ResourceRoute_Version :=> Identity () -> doNotCache >> serveFileIfExistsAs "text/plain" "version"

146

142

147−serveStaticAssets :: MonadSnap m => StaticAssets -> [Text] -> m ()

143+serveStaticAssets :: (MonadSnap m, MonadFail m) => StaticAssets -> [Text] -> m ()

148serveStaticAssets assets pathSegments = serveAsset (_staticAssets_processed assets) (_staticAssets_unprocessed assets) $ T.unpack $ T.intercalate "/" pathSegments

144serveStaticAssets assets pathSegments = serveAsset (_staticAssets_processed assets) (_staticAssets_unprocessed assets) $ T.unpack $ T.intercalate "/" pathSegments

149

145

150data StaticAssets = StaticAssets

146data StaticAssets = StaticAssets

@@ -162,7 +158,7 @@ staticRenderContentType = "text/html; charset=utf-8"

162

158

163--TODO: Don't assume we're being served at "/"

159--TODO: Don't assume we're being served at "/"

164serveGhcjsApp

160serveGhcjsApp

165− :: (MonadSnap m, HasCookies m)

161+ :: (MonadSnap m, HasCookies m, MonadFail m)

166 => (R appRouteComponent -> Text)

162 => (R appRouteComponent -> Text)

167 -> GhcjsApp (R appRouteComponent)

163 -> GhcjsApp (R appRouteComponent)

168 -> Map Text ByteString

164 -> Map Text ByteString

@@ -174,7 +170,7 @@ serveGhcjsApp urlEnc app config = \case

174 writeBS <=< renderGhcjsFrontend urlEnc (appRouteComponent :/ appRouteRest) config $ _ghcjsApp_value app

170 writeBS <=< renderGhcjsFrontend urlEnc (appRouteComponent :/ appRouteRest) config $ _ghcjsApp_value app

175 GhcjsAppRoute_Resource :=> Identity pathSegments -> serveStaticAssets (_ghcjsApp_compiled app) pathSegments

171 GhcjsAppRoute_Resource :=> Identity pathSegments -> serveStaticAssets (_ghcjsApp_compiled app) pathSegments

176

172

177−runBackend :: Backend fullRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()

173+runBackend :: Backend backendRoute frontendRoute -> Frontend (R frontendRoute) -> IO ()

178runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of

174runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of

179 Left e -> fail $ "backend error:\n" <> T.unpack e

175 Left e -> fail $ "backend error:\n" <> T.unpack e

180 Right validFullEncoder -> do

176 Right validFullEncoder -> do

@@ -183,15 +179,15 @@ runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend

183 runSnapWithCommandLineArgs $ do

179 runSnapWithCommandLineArgs $ do

184 getRouteWith validFullEncoder >>= \case

180 getRouteWith validFullEncoder >>= \case

185 Identity r -> case r of

181 Identity r -> case r of

186− InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a

182+ FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a

187− InR obeliskRoute :=> Identity a ->

183+ FullRoute_Frontend obeliskRoute :/ a ->

188 serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) (serveStaticAssets defaultStaticAssets) frontend publicConfigs $

184 serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) (serveStaticAssets defaultStaticAssets) frontend publicConfigs $

189 obeliskRoute :/ a

185 obeliskRoute :/ a

190

186

191−mkRouteToUrl :: Encoder Identity parse (R (Sum f (ObeliskRoute r))) PageName -> R r -> Text

187+mkRouteToUrl :: Encoder Identity parse (R (FullRoute br fr)) PageName -> R fr -> Text

192mkRouteToUrl validFullEncoder =

188mkRouteToUrl validFullEncoder =

193 let pageNameEncoder' :: Encoder Identity (Either Text) PageName PathQuery = pageNameEncoder

189 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

190+ in \(k :/ v) -> T.pack . uncurry (<>) . encode pageNameEncoder' . encode validFullEncoder $ (FullRoute_Frontend $ ObeliskRoute_App k) :/ v

195

191

196renderGhcjsFrontend

192renderGhcjsFrontend

197 :: (MonadSnap m, HasCookies m)

193 :: (MonadSnap m, HasCookies m)

lib/cliapp/src/Obelisk/CliApp/Demo.hs+2−1

@@ -4,6 +4,7 @@

4module Obelisk.CliApp.Demo where

6import Control.Concurrent (threadDelay)

7+import Control.Monad.Fail

7import Control.Monad.IO.Class

8import Control.Monad.IO.Class

8import Data.Semigroup ((<>))

9import Data.Semigroup ((<>))

9import qualified Data.Text as T

10import qualified Data.Text as T

@@ -14,7 +15,7 @@ import Control.Monad.Catch (MonadMask)

14import Obelisk.CliApp

15import Obelisk.CliApp

16cliDemo

17cliDemo

17− :: ( MonadIO m, MonadMask m

18+ :: ( MonadIO m, MonadMask m, MonadFail m

18 , CliLog m, HasCliConfig e m, CliThrow e m, AsProcessFailure e, AsUnstructuredError e)

19 , CliLog m, HasCliConfig e m, CliThrow e m, AsProcessFailure e, AsUnstructuredError e)

19 => m ()

20 => m ()

20cliDemo = withSpinner "CLI Demo" $ do

21cliDemo = withSpinner "CLI Demo" $ do

lib/cliapp/src/Obelisk/CliApp/Process.hs+5−4

@@ -24,6 +24,7 @@ module Obelisk.CliApp.Process

25import Control.Monad ((<=<), join, void)

26import Control.Monad.Except (throwError)

27+import Control.Monad.Fail

27import Control.Monad.IO.Class (MonadIO, liftIO)

28import Control.Monad.IO.Class (MonadIO, liftIO)

28import Control.Lens (Prism', review)

29import Control.Lens (Prism', review)

29import qualified Data.ByteString as BS

30import qualified Data.ByteString as BS

@@ -60,7 +61,7 @@ instance AsProcessFailure ProcessFailure where

60 asProcessFailure = id

61 asProcessFailure = id

62readProcessAndLogStderr

63readProcessAndLogStderr

63− :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)

64+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

64 => Severity -> CreateProcess -> m Text

65 => Severity -> CreateProcess -> m Text

65readProcessAndLogStderr sev process = do

66readProcessAndLogStderr sev process = do

66 (out, _err) <- withProcess process $ \_out err -> do

67 (out, _err) <- withProcess process $ \_out err -> do

@@ -82,7 +83,7 @@ readCreateProcessWithExitCode process = do

82-- which case it is advisable to call it with a non-Error severity for stderr, like

83-- which case it is advisable to call it with a non-Error severity for stderr, like

83-- `callProcessAndLogOutput (Debug, Debug)`.

84-- `callProcessAndLogOutput (Debug, Debug)`.

84readProcessAndLogOutput

85readProcessAndLogOutput

85− :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)

86+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

86 => (Severity, Severity) -> CreateProcess -> m Text

87 => (Severity, Severity) -> CreateProcess -> m Text

87readProcessAndLogOutput (sev_out, sev_err) process = do

88readProcessAndLogOutput (sev_out, sev_err) process = do

88 (_, Just out, Just err, p) <- createProcess $ process

89 (_, Just out, Just err, p) <- createProcess $ process

@@ -106,7 +107,7 @@ readProcessAndLogOutput (sev_out, sev_err) process = do

106-- `callProcessAndLogOutput (Debug, Debug)`.

107-- `callProcessAndLogOutput (Debug, Debug)`.

107callProcessAndLogOutput

108callProcessAndLogOutput

108

109

109− :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)

110+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

110 => (Severity, Severity) -> CreateProcess -> m ()

111 => (Severity, Severity) -> CreateProcess -> m ()

111callProcessAndLogOutput (sev_out, sev_err) process =

112callProcessAndLogOutput (sev_out, sev_err) process =

112 void $ withProcess process $ \out err -> do

113 void $ withProcess process $ \out err -> do

@@ -150,7 +151,7 @@ callCommand cmd = do

150 liftIO $ Process.callCommand cmd

151 liftIO $ Process.callCommand cmd

151

152

152withProcess

153withProcess

153− :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e)

154+ :: (MonadIO m, CliLog m, CliThrow e m, AsProcessFailure e, MonadFail m)

154 => CreateProcess -> (Handle -> Handle -> m ()) -> m (Handle, Handle)

155 => CreateProcess -> (Handle -> Handle -> m ()) -> m (Handle, Handle)

155withProcess process f = do -- TODO: Use bracket.

156withProcess process f = do -- TODO: Use bracket.

156 -- FIXME: Using `withCreateProcess` here leads to something operating illegally on closed handles.

157 -- FIXME: Using `withCreateProcess` here leads to something operating illegally on closed handles.

lib/cliapp/src/Obelisk/CliApp/Types.hs+7−3

@@ -6,12 +6,14 @@

6{-# LANGUAGE GeneralizedNewtypeDeriving #-}

7{-# LANGUAGE MultiParamTypeClasses #-}

8{-# LANGUAGE OverloadedStrings #-}

9+{-# LANGUAGE StandaloneDeriving #-}

9{-# LANGUAGE UndecidableInstances #-}

10{-# LANGUAGE UndecidableInstances #-}

10module Obelisk.CliApp.Types where

11module Obelisk.CliApp.Types where

12import Control.Concurrent.MVar (MVar)

13import Control.Concurrent.MVar (MVar)

13import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)

14import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)

15+import Control.Monad.Fail (MonadFail)

14−import Control.Monad.Log (LoggingT, MonadLog, Severity (..), WithSeverity (..), logMessage)

16+import Control.Monad.Log (LoggingT(..), MonadLog, Severity (..), WithSeverity (..), logMessage)

15import Control.Monad.Reader (MonadIO, ReaderT (..), MonadReader (..), ask, mapReaderT)

17import Control.Monad.Reader (MonadIO, ReaderT (..), MonadReader (..), ask, mapReaderT)

16import Control.Monad.Writer (WriterT)

18import Control.Monad.Writer (WriterT)

17import Control.Monad.State (StateT)

19import Control.Monad.State (StateT)

@@ -45,9 +47,11 @@ type CliThrow e m = MonadError e m

45putLog :: CliLog m => Severity -> Text -> m ()

47putLog :: CliLog m => Severity -> Text -> m ()

46putLog sev = logMessage . Output_Log . WithSeverity sev

48putLog sev = logMessage . Output_Log . WithSeverity sev

50+deriving instance MonadFail m => MonadFail (LoggingT Output m)

51+

48newtype DieT e m a = DieT { unDieT :: ReaderT (e -> (Text, Int)) (LoggingT Output m) a }

52newtype DieT e m a = DieT { unDieT :: ReaderT (e -> (Text, Int)) (LoggingT Output m) a }

49 deriving

53 deriving

50− ( Functor, Applicative, Monad, MonadIO

54+ ( Functor, Applicative, Monad, MonadIO, MonadFail

51 , MonadThrow, MonadCatch, MonadMask

55 , MonadThrow, MonadCatch, MonadMask

52 , MonadLog Output

56 , MonadLog Output

53 )

57 )

@@ -114,7 +118,7 @@ newtype CliT e m a = CliT

114 { unCliT :: ReaderT (CliConfig e) (DieT e m) a

118 { unCliT :: ReaderT (CliConfig e) (DieT e m) a

115 }

119 }

116 deriving

120 deriving

117− ( Functor, Applicative, Monad, MonadIO

121+ ( Functor, Applicative, Monad, MonadIO, MonadFail

118 , MonadThrow, MonadCatch, MonadMask

122 , MonadThrow, MonadCatch, MonadMask

119 , MonadLog Output -- CliLog

123 , MonadLog Output -- CliLog

120 , MonadError e -- CliThrow

124 , MonadError e -- CliThrow

lib/command/obelisk-command.cabal+1−1

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

23 , filepath

24 , github

25 , here

26− , hit

26+ , git

27 , hnix

28 , hpack

29 , io-streams

lib/command/src/Obelisk/App.hs+5−2

@@ -12,6 +12,7 @@ module Obelisk.App where

13import Control.Lens

14import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)

15+import Control.Monad.Fail (MonadFail)

15import Control.Monad.Reader (MonadIO, ReaderT (..), ask, runReaderT)

16import Control.Monad.Reader (MonadIO, ReaderT (..), ask, runReaderT)

16import Control.Monad.Writer (WriterT)

17import Control.Monad.Writer (WriterT)

17import Control.Monad.State (StateT)

18import Control.Monad.State (StateT)

@@ -61,10 +62,11 @@ newtype ObeliskT m a = ObeliskT

61 { unObeliskT :: ReaderT Obelisk (CliT ObeliskError m) a

62 { unObeliskT :: ReaderT Obelisk (CliT ObeliskError m) a

62 }

63 }

63 deriving

64 deriving

64− ( Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask

65+ ( Functor, Applicative, Monad, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadFail

65 , MonadLog Output -- CliLog

66 , MonadLog Output -- CliLog

66 , MonadError ObeliskError -- CliThrow ObeliskError

67 , MonadError ObeliskError -- CliThrow ObeliskError

67− , HasCliConfig ObeliskError)

68+ , HasCliConfig ObeliskError

69+ )

69instance MonadTrans ObeliskT where

71instance MonadTrans ObeliskT where

70 lift = ObeliskT . lift . lift

72 lift = ObeliskT . lift . lift

@@ -104,6 +106,7 @@ type MonadInfallibleObelisk m =

104type MonadObelisk m =

106type MonadObelisk m =

105 ( MonadInfallibleObelisk m

107 ( MonadInfallibleObelisk m

106 , CliThrow ObeliskError m

108 , CliThrow ObeliskError m

109+ , MonadFail m

107 )

110 )

108

111

109getObeliskUserStateDir :: IO FilePath

112getObeliskUserStateDir :: IO FilePath

lib/command/src/Obelisk/Command.hs+27−4

@@ -20,6 +20,7 @@ import Data.Text.Encoding

20import Data.Text.Encoding.Error (lenientDecode)

21import GHC.StaticPtr

22import Options.Applicative

23+import Options.Applicative.Help.Pretty (text, (<$$>))

23import System.Directory

24import System.Directory

24import System.Environment

25import System.Environment

25import System.FilePath

26import System.FilePath

@@ -93,6 +94,7 @@ data ObCommand

93 | ObCommand_Repl

94 | ObCommand_Repl

94 | ObCommand_Watch

95 | ObCommand_Watch

95 | ObCommand_Shell ShellOpts

96 | ObCommand_Shell ShellOpts

97+ | ObCommand_Doc String [String] -- shell and list of packages

96 | ObCommand_Internal ObInternal

98 | ObCommand_Internal ObInternal

97 deriving Show

99 deriving Show

100

@@ -129,6 +131,11 @@ obCommand cfg = hsubparser

129 , command "repl" $ info (pure ObCommand_Repl) $ progDesc "Open an interactive interpreter"

131 , command "repl" $ info (pure ObCommand_Repl) $ progDesc "Open an interactive interpreter"

130 , command "watch" $ info (pure ObCommand_Watch) $ progDesc "Watch current project for errors and warnings"

132 , command "watch" $ info (pure ObCommand_Watch) $ progDesc "Watch current project for errors and warnings"

131 , command "shell" $ info (ObCommand_Shell <$> shellOpts) $ progDesc "Enter a shell with project dependencies"

133 , command "shell" $ info (ObCommand_Shell <$> shellOpts) $ progDesc "Enter a shell with project dependencies"

134+ , command "doc" $ info (ObCommand_Doc <$> shellFlags <*> packageNames) $

135+ progDesc "List paths to haddock documentation for specified packages"

136+ <> footerDoc (Just $

137+ text "Hint: To open the documentation you can pipe the output of this command like"

138+ <$$> text "ob doc reflex reflex-dom-core | xargs -n1 xdg-open")

132 ])

139 ])

133 <|> subparser

140 <|> subparser

134 (mconcat

141 (mconcat

@@ -136,6 +143,9 @@ obCommand cfg = hsubparser

136 , command "internal" (info (ObCommand_Internal <$> internalCommand) mempty)

143 , command "internal" (info (ObCommand_Internal <$> internalCommand) mempty)

137 ])

144 ])

138

145

146+packageNames :: Parser [String]

147+packageNames = some (strArgument (metavar "PACKAGE-NAME..."))

148+

139deployCommand :: ArgsConfig -> Parser DeployCommand

149deployCommand :: ArgsConfig -> Parser DeployCommand

140deployCommand cfg = hsubparser $ mconcat

150deployCommand cfg = hsubparser $ mconcat

141 [ command "init" $ info (DeployCommand_Init <$> deployInitOpts) $ progDesc "Initialize a deployment configuration directory"

151 [ command "init" $ info (DeployCommand_Init <$> deployInitOpts) $ progDesc "Initialize a deployment configuration directory"

@@ -233,12 +243,15 @@ data ShellOpts

233 }

243 }

234 deriving Show

244 deriving Show

235

245

246+shellFlags :: Parser String

247+shellFlags =

248+ flag' "ghc" (long "ghc" <> help "Enter a shell environment having ghc (default)")

249+ <|> flag "ghc" "ghcjs" (long "ghcjs" <> help "Enter a shell having ghcjs rather than ghc")

250+ <|> strOption (short 'A' <> long "argument" <> metavar "NIXARG" <> help "Use the environment specified by the given nix argument of `shells'")

251+

236shellOpts :: Parser ShellOpts

252shellOpts :: Parser ShellOpts

237shellOpts = ShellOpts

253shellOpts = ShellOpts

238− <$> ( flag' "ghc" (long "ghc" <> help "Enter a shell environment having ghc (default)")

254+ <$> shellFlags

239− <|> flag "ghc" "ghcjs" (long "ghcjs" <> help "Enter a shell having ghcjs rather than ghc")

240− <|> strOption (short 'A' <> long "argument" <> metavar "NIXARG" <> help "Use the environment specified by the given nix argument of `shells'")

241− )

242 <*> optional (strArgument (metavar "COMMAND"))

255 <*> optional (strArgument (metavar "COMMAND"))

243

256

244parserPrefs :: ParserPrefs

257parserPrefs :: ParserPrefs

@@ -369,6 +382,8 @@ ob = \case

369 ObCommand_Watch -> inNixShell' $ static runWatch

382 ObCommand_Watch -> inNixShell' $ static runWatch

370 ObCommand_Shell so -> withProjectRoot "." $ \root ->

383 ObCommand_Shell so -> withProjectRoot "." $ \root ->

371 projectShell root False (_shellOpts_shell so) (_shellOpts_command so)

384 projectShell root False (_shellOpts_shell so) (_shellOpts_command so)

385+ ObCommand_Doc shell pkgs -> withProjectRoot "." $ \root ->

386+ projectShell root False shell (Just $ haddockCommand pkgs)

372 ObCommand_Internal icmd -> case icmd of

387 ObCommand_Internal icmd -> case icmd of

373 ObInternal_RunStaticIO k -> liftIO (unsafeLookupStaticPtr @(ObeliskT IO ()) k) >>= \case

388 ObInternal_RunStaticIO k -> liftIO (unsafeLookupStaticPtr @(ObeliskT IO ()) k) >>= \case

374 Nothing -> failWith $ "ObInternal_RunStaticIO: no such StaticKey: " <> T.pack (show k)

389 Nothing -> failWith $ "ObInternal_RunStaticIO: no such StaticKey: " <> T.pack (show k)

@@ -377,6 +392,14 @@ ob = \case

377 liftIO $ runObelisk c $ deRefStaticPtr p

392 liftIO $ runObelisk c $ deRefStaticPtr p

378 ObInternal_CLIDemo -> cliDemo

393 ObInternal_CLIDemo -> cliDemo

379

394

395+haddockCommand :: [String] -> String

396+haddockCommand pkgs = unwords

397+ [ "for p in"

398+ , unwords [getHaddockPath p ++ "/index.html" | p <- pkgs]

399+ , "; do echo $p; done"

400+ ]

401+ where getHaddockPath p = "$(ghc-pkg field " ++ p ++ " haddock-html --simple-output)"

402+

380--TODO: Clean up all the magic strings throughout this codebase

403--TODO: Clean up all the magic strings throughout this codebase

381

404

382getArgsConfig :: IO ArgsConfig

405getArgsConfig :: IO ArgsConfig

lib/command/src/Obelisk/Command/Deploy.hs+16−16

@@ -4,7 +4,6 @@

4{-# LANGUAGE ScopedTypeVariables #-}

5{-# LANGUAGE ViewPatterns #-}

6{-# LANGUAGE DeriveGeneric #-}

7−{-# LANGUAGE TypeApplications #-}

8module Obelisk.Command.Deploy where

7module Obelisk.Command.Deploy where

10import Control.Lens

9import Control.Lens

@@ -22,8 +21,8 @@ import qualified Data.Set as Set

22import qualified Data.Text as T

21import qualified Data.Text as T

23import qualified Data.Text.IO as T

22import qualified Data.Text.IO as T

24import GHC.Generics

23import GHC.Generics

25−import Nix.Convert

26import Nix.Pretty

24import Nix.Pretty

25+import Nix.String (principledMakeNixStringWithoutContext)

27import Nix.Value

26import Nix.Value

28import System.Directory

27import System.Directory

29import System.Environment (getEnvironment)

28import System.Environment (getEnvironment)

@@ -173,13 +172,14 @@ deployPush deployPath getNixBuilders = do

173deployUpdate :: MonadObelisk m => FilePath -> m ()

172deployUpdate :: MonadObelisk m => FilePath -> m ()

174deployUpdate deployPath = updateThunkToLatest (deployPath </> "src") Nothing

173deployUpdate deployPath = updateThunkToLatest (deployPath </> "src") Nothing

175

174

176−keytoolToAndroidConfig :: KeytoolConfig -> HM.HashMap Text (NValueNF Identity)

175+keytoolToAndroidConfig :: KeytoolConfig -> HM.HashMap Text (NValue t Identity m)

177−keytoolToAndroidConfig conf = runIdentity $ do

176+keytoolToAndroidConfig conf =

178− path <- toValue $ Path $ _keytoolConfig_keystore conf

177+ let path = nvPath $ _keytoolConfig_keystore conf

178+ fromStr = nvStr . principledMakeNixStringWithoutContext . T.pack

179− storepass <- toValue $ T.pack $ _keytoolConfig_storepass conf

179+ storepass = fromStr $ _keytoolConfig_storepass conf

180− alias <- toValue $ T.pack $ _keytoolConfig_alias conf

180+ alias = fromStr $ _keytoolConfig_alias conf

181− keypass <- toValue $ T.pack $ _keytoolConfig_keypass conf

181+ keypass = fromStr $ _keytoolConfig_keypass conf

182− return $ HM.fromList

182+ in HM.fromList

183 [ ("storeFile", path)

184 , ("storePassword", storepass)

185 , ("keyAlias", alias)

@@ -194,7 +194,7 @@ renderPlatformDeployment = \case

194 Android -> "android"

195 IOS -> "ios"

196

197−deployMobile :: MonadObelisk m => PlatformDeployment -> [String] -> m ()

197+deployMobile :: forall m. MonadObelisk m => PlatformDeployment -> [String] -> m ()

198deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do

199 let srcDir = root </> "src"

200 configDir = root </> "config"

@@ -224,12 +224,12 @@ deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do

224 checkKeytoolConfExist <- liftIO $ doesFileExist keytoolConfPath

225 unless checkKeytoolConfExist $ failWith "Missing android KeytoolConfig"

226 keytoolConfContents <- liftIO $ BSL.readFile keytoolConfPath

227− liftIO $ putStrLn $ show keytoolConfContents

227+ liftIO $ print keytoolConfContents

228− releaseKey <- case eitherDecode keytoolConfContents of

228+ releaseKey :: String <- case eitherDecode keytoolConfContents :: Either String KeytoolConfig of

229 Left err -> failWith $ T.pack err

230− Right conf -> do

230+ Right conf -> return $

231− let nvset = toValue @(HM.HashMap Text (NValueNF Identity)) @Identity @(NValueNF Identity) $ keytoolToAndroidConfig conf

231+ (printNix :: MonadObelisk m => NValue t Identity m -> String) $

232− return $ printNix $ runIdentity nvset

232+ nvSet (keytoolToAndroidConfig conf) HM.empty

233 let expr = mconcat

234 [ "with (import ", srcDir, " {});"

235 , "android.frontend.override (drv: { "

@@ -255,7 +255,7 @@ deployMobile platform mobileArgs = withProjectRoot "." $ \root -> do

255 result <- nixCmd $ NixCmd_Build $ def

256 & nixBuildConfig_outLink .~ OutLink_None

257 & nixCmdConfig_target .~ nixBuildTarget

258− putLog Notice $ T.pack $ "Your recently built android apk can be found at the following path: " <> (show result)

258+ putLog Notice $ T.pack $ "Your recently built android apk can be found at the following path: " <> show result

259 callProcessAndLogOutput (Notice, Error) $ proc (result </> "bin" </> "deploy") mobileArgs

260 where

261 withEcho showEcho f = do

lib/command/src/Obelisk/Command/Run.hs+2−2

@@ -118,12 +118,12 @@ parseCabalPackage dir = do

118 then Just <$> liftIO (readUTF8File cabalFp)

119 else if hasHpack

120 then do

121− let decodeOptions = DecodeOptions hpackFp Nothing decodeYaml

121+ let decodeOptions = DecodeOptions (ProgramName "ob") hpackFp Nothing decodeYaml

122 liftIO (readPackageConfig decodeOptions) >>= \case

123 Left err -> do

124 putLog Error $ T.pack $ "Failed to parse " <> hpackFp <> ": " <> err

125 return Nothing

126− Right (DecodeResult hpackPackage _ _) -> do

126+ Right (DecodeResult hpackPackage _ _ _) -> do

127 return $ Just $ renderPackage [] hpackPackage

128 else return Nothing

129

lib/command/src/Obelisk/Command/Thunk.hs+2−2

@@ -94,7 +94,7 @@ type NixSha256 = Text --TODO: Use a smart constructor and make this actually ver

95-- | A specific revision of data; it may be available from multiple sources

96data ThunkRev = ThunkRev

97− { _thunkRev_commit :: Ref

97+ { _thunkRev_commit :: Ref Ref.SHA1

98 , _thunkRev_nixSha256 :: NixSha256

99 }

100 deriving (Show, Eq, Ord)

@@ -149,7 +149,7 @@ getThunkGitBranch (ThunkPtr _ src) = fmap untagName $ case src of

149 ThunkSource_GitHub s -> _gitHubSource_branch s

150 ThunkSource_Git s -> _gitSource_branch s

151

152−commitNameToRef :: Name Commit -> Ref

152+commitNameToRef :: Name Commit -> Ref Ref.SHA1

153commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c

154

155-- TODO: Use spinner here.

lib/command/src/Obelisk/Command/Utils.hs+1−1

@@ -134,7 +134,7 @@ gitLsRemote repository mRef mBranch = do

134 ["ls-remote", "--exit-code", repository, branchName]

135 let t = T.pack out

136 maps <- case MP.runParser parseLsRemote "" t of

137− Left err -> failWith $ T.pack $ MP.parseErrorPretty' t err

137+ Left err -> failWith $ T.pack $ MP.errorBundlePretty err

138 Right table -> pure $ bimap M.fromList M.fromList $ partitionEithers $ table

139 putLog Debug $ "git ls-remote maps: " <> T.pack (show maps)

140 pure (exitCode, maps)

lib/executable-config/lookup/src-ghcjs/Obelisk/ExecutableConfig/Lookup.hs+17−8

@@ -15,28 +15,37 @@ import GHCJS.DOM.Document (getHead)

15import GHCJS.DOM.DOMStringMap (get)

16import GHCJS.DOM.Element (getInnerHTML)

17import GHCJS.DOM.HTMLElement (HTMLElement(HTMLElement), getDataset)

18−import GHCJS.DOM.NodeList (item, getLength)

18+import GHCJS.DOM.NodeList (IsNodeList, item, getLength)

19import GHCJS.DOM.ParentNode (querySelectorAll)

20−import GHCJS.DOM.Types (Node(Node), castTo)

20+import GHCJS.DOM.Types (MonadJSM, Node(Node), castTo)

22getConfigs :: IO (Map Text ByteString)

23getConfigs = do

24 Just doc <- currentDocument

25 Just hd <- getHead doc

26− nodes <- collToList =<< querySelectorAll hd ("[data-obelisk-executable-config-inject-key]" :: Text)

26+ nodes <- nodeListNodes =<< querySelectorAll hd ("[data-obelisk-executable-config-inject-key]" :: Text)

27 fmap Map.fromList $ for nodes $ \node -> do

28 e <- castTo HTMLElement node >>= \case

29 Nothing -> error "Found node with data attribute obelisk-executable-config-inject-key that is not an HTMLElement."

30 Just htmlE -> return htmlE

31 dataset <- getDataset e

32 (,)

33− <$> get dataset ("obelisk-executable-config-inject-key" :: Text)

33+ -- the key is camelCased: https://html.spec.whatwg.org/multipage/dom.html#dom-dataset

34+ <$> get dataset ("obeliskExecutableConfigInjectKey" :: Text)

34 <*> (fmap decodeOrFail (getInnerHTML e))

35 <*> (fmap decodeOrFail (getInnerHTML e))

35 where

36 where

36− collToList es = do

37− len <- getLength es

38− list <- traverse (item es) [0..len-1]

39− pure $ catMaybes list

40 decodeOrFail x = case B64.decode (T.encodeUtf8 x) of

37 decodeOrFail x = case B64.decode (T.encodeUtf8 x) of

41 Left e -> error ("Obelisk.ExecutableConfig.Lookup.getConfigs: error when decoding base64: " ++ e)

38 Left e -> error ("Obelisk.ExecutableConfig.Lookup.getConfigs: error when decoding base64: " ++ e)

42 Right x' -> x'

39 Right x' -> x'

40+

41+-- | Collect all nodes in the node list.

42+--

43+-- TODO: this and the version in obelisk-frontend should be

44+-- upstreamed to jsaddle.

45+nodeListNodes :: (IsNodeList l, MonadJSM m) => l -> m [Node]

46+nodeListNodes es = do

47+ len <- getLength es

48+ -- Warning! len is unsigned. If the NodeList is empty, we must avoid

49+ -- accidentally traversing over [0..maxBound::Word]

50+ nodes <- traverse (item es) $ if len == 0 then [] else [0..len-1]

51+ pure $ catMaybes nodes

lib/executable-config/lookup/src/Obelisk/Configs.hs+4

@@ -31,6 +31,7 @@ import Data.ByteString (ByteString)

31import Data.Map (Map)

32import qualified Data.Map as Map

33import Data.Text (Text)

34+import qualified Data.Text.Encoding as T

34import Reflex

35import Reflex

35import Reflex.Host.Class

36import Reflex.Host.Class

36import Reflex.Dom

37import Reflex.Dom

@@ -50,6 +51,9 @@ class Monad m => HasConfigs m where

50instance Monad m => HasConfigs (ConfigsT m) where

51instance Monad m => HasConfigs (ConfigsT m) where

51 getConfigs = ConfigsT ask

52 getConfigs = ConfigsT ask

54+getTextConfig :: HasConfigs m => Text -> m (Maybe Text)

55+getTextConfig k = fmap T.decodeUtf8 <$> getConfig k

56+

53instance HasConfigs m => HasConfigs (BehaviorWriterT t w m)

57instance HasConfigs m => HasConfigs (BehaviorWriterT t w m)

54instance HasConfigs m => HasConfigs (DynamicWriterT t w m)

58instance HasConfigs m => HasConfigs (DynamicWriterT t w m)

55instance HasConfigs m => HasConfigs (EventWriterT t w m)

59instance HasConfigs m => HasConfigs (EventWriterT t w m)

lib/frontend/src/Obelisk/Frontend.hs+22−14

@@ -43,11 +43,11 @@ import qualified GHCJS.DOM as DOM

43import qualified GHCJS.DOM.Types as DOM

44import qualified GHCJS.DOM.History as DOM

45import qualified GHCJS.DOM.Window as DOM

46−import Language.Javascript.JSaddle (JSM, jsNull)

46+import Language.Javascript.JSaddle (MonadJSM, JSM, jsNull)

47import GHCJS.DOM (currentDocument)

48import GHCJS.DOM.Document (getHead)

49−import GHCJS.DOM.Node (removeChild_)

49+import GHCJS.DOM.Node (Node, removeChild_)

50−import GHCJS.DOM.NodeList (item, getLength)

50+import GHCJS.DOM.NodeList (IsNodeList, item, getLength)

51import GHCJS.DOM.ParentNode (querySelectorAll)

52import Obelisk.Frontend.Cookie

53import Obelisk.Route.Frontend

@@ -83,6 +83,7 @@ type ObeliskWidget js t route m =

83 , PrebuildAgnostic t route (Client m)

84 , HasConfigs m

85 , HasCookies m

86+ , MonadIO (Performable m)

86 )

87 )

88type PrebuildAgnostic t route m =

89type PrebuildAgnostic t route m =

@@ -105,13 +106,20 @@ removeHTMLConfigs :: JSM ()

105removeHTMLConfigs = void $ runMaybeT $ do

106removeHTMLConfigs = void $ runMaybeT $ do

106 doc <- MaybeT currentDocument

107 doc <- MaybeT currentDocument

107 hd <- MaybeT $ getHead doc

108 hd <- MaybeT $ getHead doc

108− es <- collToList =<< querySelectorAll hd ("[data-obelisk-executable-config-inject-key]" :: Text)

109+ es <- nodeListNodes =<< querySelectorAll hd ("[data-obelisk-executable-config-inject-key]" :: Text)

109 for_ es $ removeChild_ hd

110 for_ es $ removeChild_ hd

110− where

111+

111− collToList es = do

112+-- | Collect all nodes in the node list.

113+--

114+-- TODO: this and the version in exe-config/ghcjs/lookup should be

115+-- upstreamed to jsaddle.

116+nodeListNodes :: (IsNodeList l, MonadJSM m) => l -> m [Node]

117+nodeListNodes es = do

112− len <- getLength es

118+ len <- getLength es

113− lst <- traverse (item es) $ take (fromIntegral len) $ [0..] -- fun with unsigned types ...

119+ -- Warning! len is unsigned. If the NodeList is empty, we must avoid

120+ -- accidentally traversing over [0..maxBound::Word]

121+ nodes <- traverse (item es) $ if len == 0 then [] else [0..len-1]

114− pure $ catMaybes lst

122+ pure $ catMaybes nodes

115

123

116setInitialRoute :: Bool -> JSM ()

124setInitialRoute :: Bool -> JSM ()

117setInitialRoute useHash = do

125setInitialRoute useHash = do

@@ -137,7 +145,7 @@ data FrontendMode = FrontendMode

137-- Selects FrontendMode based on platform; this doesn't work for jsaddle-warp

145-- Selects FrontendMode based on platform; this doesn't work for jsaddle-warp

138runFrontend

146runFrontend

139 :: forall backendRoute route

147 :: forall backendRoute route

140− . Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName

148+ . Encoder Identity Identity (R (FullRoute backendRoute route)) PageName

141 -> Frontend (R route)

149 -> Frontend (R route)

142 -> JSM ()

150 -> JSM ()

143runFrontend validFullEncoder frontend = do

151runFrontend validFullEncoder frontend = do

@@ -165,14 +173,14 @@ runFrontend validFullEncoder frontend = do

165 runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend

173 runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend

166

174

167runFrontendWithConfigsAndCurrentRoute

175runFrontendWithConfigsAndCurrentRoute

168− :: forall backendRoute route

176+ :: forall backendRoute frontendRoute

169 . FrontendMode

177 . FrontendMode

170 -> Map Text ByteString

178 -> Map Text ByteString

171− -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName

179+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName

172− -> Frontend (R route)

180+ -> Frontend (R frontendRoute)

173 -> JSM ()

181 -> JSM ()

174runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend = do

182runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend = do

175− let ve = validFullEncoder . hoistParse errorLeft (prismEncoder (rPrism $ _InR . _ObeliskRoute_App))

183+ let ve = validFullEncoder . hoistParse errorLeft (prismEncoder (rPrism $ _FullRoute_Frontend . _ObeliskRoute_App))

176 errorLeft = \case

184 errorLeft = \case

177 Left _ -> error "runFrontend: Unexpected non-app ObeliskRoute reached the frontend. This shouldn't happen."

185 Left _ -> error "runFrontend: Unexpected non-app ObeliskRoute reached the frontend. This shouldn't happen."

178 Right x -> Identity x

186 Right x -> Identity x

lib/route/src/Obelisk/Route.hs+201−30

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

12{-# LANGUAGE PatternSynonyms #-}

13{-# LANGUAGE RankNTypes #-}

14{-# LANGUAGE ScopedTypeVariables #-}

15+{-# LANGUAGE StandaloneDeriving #-}

15{-# LANGUAGE TemplateHaskell #-}

16{-# LANGUAGE TemplateHaskell #-}

16{-# LANGUAGE TypeApplications #-}

17{-# LANGUAGE TypeApplications #-}

17{-# LANGUAGE TypeFamilies #-}

18{-# LANGUAGE TypeFamilies #-}

@@ -62,10 +63,15 @@ module Obelisk.Route

62 , shadowEncoder

63 , shadowEncoder

63 , prismEncoder

64 , prismEncoder

64 , rPrism

65 , rPrism

66+ , _R

65 , obeliskRouteEncoder

67 , obeliskRouteEncoder

66 , obeliskRouteSegment

68 , obeliskRouteSegment

67 , pageNameEncoder

69 , pageNameEncoder

68 , handleEncoder

70 , handleEncoder

71+ , FullRoute (..)

72+ , _FullRoute_Frontend

73+ , _FullRoute_Backend

74+ , mkFullRouteEncoder

69 , ObeliskRoute (..)

75 , ObeliskRoute (..)

70 , _ObeliskRoute_App

76 , _ObeliskRoute_App

71 , _ObeliskRoute_Resource

77 , _ObeliskRoute_Resource

@@ -90,7 +96,9 @@ module Obelisk.Route

90 , Decoder(..)

96 , Decoder(..)

91 , dmapEncoder

97 , dmapEncoder

92 , fieldMapEncoder

98 , fieldMapEncoder

99+ , pathFieldEncoder

93 , jsonEncoder

100 , jsonEncoder

101+ , byteStringsToPageName

94 ) where

102 ) where

103

96import Prelude hiding ((.), id)

104import Prelude hiding ((.), id)

@@ -101,8 +109,31 @@ import qualified Control.Categorical.Functor as Cat

101import Control.Categorical.Bifunctor

109import Control.Categorical.Bifunctor

102import Control.Category.Associative

110import Control.Category.Associative

103import Control.Category.Monoidal

111import Control.Category.Monoidal

104−import Control.Lens (Identity (..), Prism', makePrisms, itraverse, imap, prism, (^.), re, matching, (^?), _Just, _Nothing, Iso', from, view, Wrapped (..))

112+import Control.Category.Braided

113+import Control.Lens

114+ ( Identity (..)

115+ , (^.)

116+ , (^?)

117+ , _Just

118+ , _Nothing

119+ , Cons(..)

120+ , from

121+ , imap

122+ , iso

123+ , Iso'

124+ , itraverse

125+ , makePrisms

126+ , Prism'

127+ , prism'

128+ , re

129+ , view

130+ , Wrapped (..)

131+ )

105import Control.Monad.Except

132import Control.Monad.Except

133+import Control.Monad.Writer (execWriter, tell)

134+import qualified Control.Monad.State.Strict as State

135+import Control.Monad.Trans (lift)

136+import qualified Data.ByteString as BS

106import qualified Data.ByteString.Lazy as BSL

137import qualified Data.ByteString.Lazy as BSL

107import Data.Dependent.Sum (DSum (..))

138import Data.Dependent.Sum (DSum (..))

108import Data.Dependent.Map (DMap)

139import Data.Dependent.Map (DMap)

@@ -202,7 +233,7 @@ decode e x = runIdentity (tryDecode e x)

202tryDecode :: Encoder Identity parse decoded encoded -> encoded -> parse decoded

233tryDecode :: Encoder Identity parse decoded encoded -> encoded -> parse decoded

203tryDecode (Encoder (Identity impl)) x = _encoderImpl_decode impl x

234tryDecode (Encoder (Identity impl)) x = _encoderImpl_decode impl x

204

235

205−-- | Similar to 'decode' above, once an encoder has been checked so that its check monad is Identity, it

236+-- | Similar to 'decode', once an encoder has been checked so that its check monad is Identity, it

206-- can be used to actually encode by using this. Note that while there's no constraint on the parse monad here,

237-- can be used to actually encode by using this. Note that while there's no constraint on the parse monad here,

207-- one should usually be applying decode and encode to the same 'Encoder'

238-- one should usually be applying decode and encode to the same 'Encoder'

208encode :: Encoder Identity parse decoded encoded -> decoded -> encoded

239encode :: Encoder Identity parse decoded encoded -> decoded -> encoded

@@ -252,6 +283,10 @@ instance Monad parse => Bifunctor (,) (EncoderImpl parse) (EncoderImpl parse) (E

252 , _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)

283 , _encoderImpl_decode = \(a, b) -> liftA2 (,) (_encoderImpl_decode f a) (_encoderImpl_decode g b)

253 }

284 }

254

285

286+instance (Monad parse, Applicative check) => Braided (Encoder check parse) (,) where

287+ braid = isoEncoder (iso swap swap)

288+

289+

255instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where

290instance (Applicative check, Monad parse) => PFunctor (,) (Encoder check parse) (Encoder check parse) where

256 first f = bimap f id

291 first f = bimap f id

257instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where

292instance (Applicative check, Monad parse) => QFunctor (,) (Encoder check parse) (Encoder check parse) where

@@ -265,6 +300,34 @@ instance (Traversable f, Monad parse) => Cat.Functor f (EncoderImpl parse) (Enco

265 , _encoderImpl_decode = traverse $ _encoderImpl_decode ve

300 , _encoderImpl_decode = traverse $ _encoderImpl_decode ve

266 }

301 }

267

302

303+instance Monad parse => PFunctor Either (EncoderImpl parse) (EncoderImpl parse) where

304+ first f = bimap f id

305+instance Monad parse => QFunctor Either (EncoderImpl parse) (EncoderImpl parse) where

306+ second g = bimap id g

307+instance Monad parse => Bifunctor Either (EncoderImpl parse) (EncoderImpl parse) (EncoderImpl parse) where

308+ bimap f g = EncoderImpl

309+ { _encoderImpl_encode = bimap (_encoderImpl_encode f) (_encoderImpl_encode g)

310+ , _encoderImpl_decode = \case

311+ Left a -> Left <$> _encoderImpl_decode f a

312+ Right b -> Right <$> _encoderImpl_decode g b

313+ }

314+

315+instance (Monad parse, Applicative check) => QFunctor Either (Encoder check parse) (Encoder check parse) where

316+ second g = bimap id g

317+instance (Monad parse, Applicative check) => PFunctor Either (Encoder check parse) (Encoder check parse) where

318+ first f = bimap f id

319+instance (Monad parse, Applicative check) => Bifunctor Either (Encoder check parse) (Encoder check parse) (Encoder check parse) where

320+ bimap f g = Encoder $ liftA2 bimap (unEncoder f) (unEncoder g)

321+

322+instance (Applicative check, Monad parse) => Associative (Encoder check parse) Either where

323+ associate = isoEncoder (iso (associate @(->) @Either) disassociate)

324+ disassociate = isoEncoder (iso disassociate associate)

325+

326+instance (Monad parse, Applicative check) => Braided (Encoder check parse) Either where

327+ braid = isoEncoder (iso swap swap)

328+

329+

330+

268instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where

331instance (Traversable f, Monad check, Monad parse) => Cat.Functor f (Encoder check parse) (Encoder check parse) where

269 fmap e = Encoder $ do

332 fmap e = Encoder $ do

270 ve <- unEncoder e

333 ve <- unEncoder e

@@ -442,8 +505,9 @@ chainEncoder cons this rest = Encoder $ do

442 pure $ EncoderImpl

505 pure $ EncoderImpl

443 { _encoderImpl_decode = \v -> do

506 { _encoderImpl_decode = \v -> do

444 (here, following) <- _encoderImpl_decode consValid v

507 (here, following) <- _encoderImpl_decode consValid v

445− Some r <- _encoderImpl_decode thisValid here

508+ _encoderImpl_decode thisValid here >>= \case

509+ Some r ->

446− (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following

510+ (r :/) <$> _encoderImpl_decode (runIdentity . unEncoder $ rest r) following

447 , _encoderImpl_encode = \(r :/ s) ->

511 , _encoderImpl_encode = \(r :/ s) ->

448 _encoderImpl_encode consValid

512 _encoderImpl_encode consValid

449 ( _encoderImpl_encode thisValid $ Some r

513 ( _encoderImpl_encode thisValid $ Some r

@@ -663,10 +727,47 @@ joinPairTextEncoder = Encoder . \case

663 _ -> return (kt, T.drop (T.length separator) vt)

727 _ -> return (kt, T.drop (T.length separator) vt)

664 }

728 }

665

729

666−--TODO: Rewrite this by composing the given prism with a lens on the first element of the DSum

730+-- This slight generalization of 'rPrism' happens to be enough to write all our

667−-- Or, more likely, the user can compose it themselves

731+-- prism combinators so far.

732+dSumPrism

733+ :: forall f f' g

668−rPrism :: forall f g. (forall a. Prism' (f a) (g a)) -> Prism' (R f) (R g)

734+ . (forall a. Prism' (f a) (f' a))

669−rPrism p = prism (\(g :/ x) -> g ^. re p :/ x) (\(f :/ x) -> bimap (:/ x) (:/ x) $ matching p f)

735+ -> Prism' (DSum f g) (DSum f' g)

736+dSumPrism p = prism'

737+ (\(f' :=> x) -> f' ^. re p :=> x)

738+ (\(f :=> x) -> (:=> x) <$> (f ^? p))

739+

740+-- already in obelisk

741+rPrism

742+ :: forall f f'

743+ . (forall a. Prism' (f a) (f' a))

744+ -> Prism' (R f) (R f')

745+rPrism p = dSumPrism p

746+

747+dSumPrism'

748+ :: forall f g a

749+ . (forall b. Prism' (f b) (a :~: b))

750+ -> Prism' (DSum f g) (g a)

751+dSumPrism' p = dSumPrism p . iso (\(Refl :=> b) -> b) (Refl :=>)

752+

753+dSumGEqPrism

754+ :: GEq f

755+ => f a

756+ -> Prism' (DSum f g) (g a)

757+dSumGEqPrism variant = dSumPrism' $ prism' (\Refl -> variant) (\x -> geq variant x)

758+

759+-- | Given a 'tag :: f a', make a prism for 'R f'. This generalizes the usual

760+-- prisms for a sum type (the ones that 'mkPrisms' would make), just as 'R'

761+-- generalized a usual sum type.

762+--

763+-- [This is given the '_R' name of the "cannonical" prism not because it is the

764+-- most general, but because it seems the most useful for routes, and 'R' itself

765+-- trades generality for route-specificity.]

766+_R

767+ :: GEq f

768+ => f a

769+ -> Prism' (R f) a

770+_R variant = dSumGEqPrism variant . iso runIdentity Identity

670

771

671-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad

772-- | An encoder that only works on the items available via the prism. An error will be thrown in the parse monad

672-- if the prism doesn't match.

773-- if the prism doesn't match.

@@ -710,6 +811,45 @@ handleEncoder recover e = Encoder $ do

710-- Actual obelisk route info

811-- Actual obelisk route info

711--------------------------------------------------------------------------------

812--------------------------------------------------------------------------------

712

813

814+-- | The typical full route type comprising all of an Obelisk application's routes.

815+-- Parameterised by the top level GADTs that define backend and frontend routes, respectively.

816+data FullRoute :: (* -> *) -> (* -> *) -> * -> * where

817+ FullRoute_Backend :: br a -> FullRoute br fr a

818+ FullRoute_Frontend :: ObeliskRoute fr a -> FullRoute br fr a

819+

820+instance (GShow br, GShow fr) => GShow (FullRoute br fr) where

821+ gshowsPrec p = \case

822+ FullRoute_Backend x -> showParen (p > 10) (showString "FullRoute_Backend " . gshowsPrec 11 x)

823+ FullRoute_Frontend x -> showParen (p > 10) (showString "FullRoute_Frontend " . gshowsPrec 11 x)

824+

825+instance (GEq br, GEq fr) => GEq (FullRoute br fr) where

826+ geq (FullRoute_Backend x) (FullRoute_Backend y) = geq x y

827+ geq (FullRoute_Frontend x) (FullRoute_Frontend y) = geq x y

828+ geq _ _ = Nothing

829+

830+instance (GCompare br, GCompare fr) => GCompare (FullRoute br fr) where

831+ gcompare (FullRoute_Backend _) (FullRoute_Frontend _) = GLT

832+ gcompare (FullRoute_Frontend _) (FullRoute_Backend _) = GGT

833+ gcompare (FullRoute_Backend x) (FullRoute_Backend y) = gcompare x y

834+ gcompare (FullRoute_Frontend x) (FullRoute_Frontend y) = gcompare x y

835+

836+instance (UniverseSome br, UniverseSome fr) => UniverseSome (FullRoute br fr) where

837+ universeSome = [Some (FullRoute_Backend x) | Some x <- universeSome]

838+ ++ [Some (FullRoute_Frontend x) | Some x <- universeSome]

839+

840+-- | Build the typical top level application route encoder from a route for handling 404's,

841+-- and segment encoders for backend and frontend routes.

842+mkFullRouteEncoder

843+ :: (GCompare br, GCompare fr, GShow br, GShow fr, UniverseSome br, UniverseSome fr)

844+ => R (FullRoute br fr) -- ^ 404 handler

845+ -> (forall a. br a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single backend route segment

846+ -> (forall a. fr a -> SegmentResult (Either Text) (Either Text) a) -- ^ How to encode a single frontend route segment

847+ -> Encoder (Either Text) Identity (R (FullRoute br fr)) PageName

848+mkFullRouteEncoder missing backendSegment frontendSegment = handleEncoder (const missing) $

849+ pathComponentEncoder $ \case

850+ FullRoute_Backend backendRoute -> backendSegment backendRoute

851+ FullRoute_Frontend obeliskRoute -> obeliskRouteSegment obeliskRoute frontendSegment

852+

713-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your

853-- | A type which can represent Obelisk-specific resource routes, in addition to application specific routes which serve your

714-- frontend.

854-- frontend.

715data ObeliskRoute :: (* -> *) -> * -> * where

855data ObeliskRoute :: (* -> *) -> * -> * where

@@ -839,7 +979,7 @@ concat <$> mapM deriveRouteComponent

839 ]

979 ]

840

980

841makePrisms ''ObeliskRoute

981makePrisms ''ObeliskRoute

842−

982+makePrisms ''FullRoute

843deriveGEq ''Void1

983deriveGEq ''Void1

844deriveGCompare ''Void1

984deriveGCompare ''Void1

845

985

@@ -847,27 +987,27 @@ deriveGCompare ''Void1

847-- and query string). See 'checkEncoder' for how to produce a checked encoder.

987-- and query string). See 'checkEncoder' for how to produce a checked encoder.

848renderBackendRoute

988renderBackendRoute

849 :: forall br a.

989 :: forall br a.

850− Encoder Identity Identity (R (Sum br a)) PageName

990+ Encoder Identity Identity (R (FullRoute br a)) PageName

851 -> R br

991 -> R br

852 -> Text

992 -> Text

853−renderBackendRoute enc = renderObeliskRoute enc . hoistR InL

993+renderBackendRoute enc = renderObeliskRoute enc . hoistR FullRoute_Backend

854

994

855-- | Renders a frontend route with the supplied checked encoder

995-- | Renders a frontend route with the supplied checked encoder

856renderFrontendRoute

996renderFrontendRoute

857 :: forall a fr.

997 :: forall a fr.

858− Encoder Identity Identity (R (Sum a (ObeliskRoute fr))) PageName

998+ Encoder Identity Identity (R (FullRoute a fr)) PageName

859 -> R fr

999 -> R fr

860 -> Text

1000 -> Text

861−renderFrontendRoute enc = renderObeliskRoute enc . hoistR (InR . ObeliskRoute_App)

1001+renderFrontendRoute enc = renderObeliskRoute enc . hoistR (FullRoute_Frontend . ObeliskRoute_App)

862

1002

863-- | Renders a route of the form typically found in an Obelisk project

1003-- | Renders a route of the form typically found in an Obelisk project

864renderObeliskRoute

1004renderObeliskRoute

865 :: forall a b.

1005 :: forall a b.

866− Encoder Identity Identity (R (Sum a b)) PageName

1006+ Encoder Identity Identity (R (FullRoute a b)) PageName

867− -> R (Sum a b)

1007+ -> R (FullRoute a b)

868 -> Text

1008 -> Text

869renderObeliskRoute e r =

1009renderObeliskRoute e r =

870− let enc :: Encoder Identity (Either Text) (R (Sum a b)) PathQuery

1010+ let enc :: Encoder Identity (Either Text) (R (FullRoute a b)) PathQuery

871 enc = (pageNameEncoder . hoistParse (pure . runIdentity) e)

1011 enc = (pageNameEncoder . hoistParse (pure . runIdentity) e)

872 in (T.pack . uncurry (<>)) $ encode enc r

1012 in (T.pack . uncurry (<>)) $ encode enc r

873

1013

@@ -877,14 +1017,9 @@ readShowEncoder = singlePathSegmentEncoder . unsafeTshowEncoder

877integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer

1017integralEncoder :: (MonadError Text parse, Applicative check, Integral a) => Encoder check parse a Integer

878integralEncoder = prismEncoder (Numeric.Lens.integral)

1018integralEncoder = prismEncoder (Numeric.Lens.integral)

879

1019

880−pathSegmentEncoder :: (MonadError Text parse, Applicative check) =>

1020+pathSegmentEncoder :: (MonadError Text parse, Applicative check, Cons as as a a) =>

881− Encoder check parse (Text, PageName) PageName

1021+ Encoder check parse (a, (as, b)) (as, b)

882−pathSegmentEncoder = unsafeMkEncoder EncoderImpl

1022+pathSegmentEncoder = first (prismEncoder _Cons) . disassociate

883− { _encoderImpl_encode = \(x, (y, z)) -> (x:y, z)

884− , _encoderImpl_decode = \(xss, y) -> case xss of

885− [] -> throwError "not enough path segments"

886− (x:xs) -> pure (x, (xs, y))

887− }

888

1023

889newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }

1024newtype Decoder check parse b a = Decoder { toEncoder :: Encoder check parse a b }

890

1025

@@ -912,12 +1047,12 @@ dmapEncoder keyEncoder' valueEncoderFor = unsafeEncoder $ do

912 , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'

1047 , encode (toEncoder (DMap.findWithDefault (error . keyError $ gshow k') k' valueDecoders)) v'

913 )

1048 )

914 , _encoderImpl_decode = \m -> fmap DMap.fromList . forM (Map.toList m) $ \(k,v) -> do

1049 , _encoderImpl_decode = \m -> fmap DMap.fromList . forM (Map.toList m) $ \(k,v) -> do

915− Some (k' :: k' t) <- tryDecode keyEncoder k

1050+ tryDecode keyEncoder k >>= \case

916− case DMap.lookup k' valueDecoders of

1051+ Some (k' :: k' t) -> case DMap.lookup k' valueDecoders of

917− Nothing -> throwError . T.pack . keyError $ gshow k'

1052+ Nothing -> throwError . T.pack . keyError $ gshow k'

918− Just (Decoder e) -> do

1053+ Just (Decoder e) -> do

919− v' <- tryDecode e v

1054+ v' <- tryDecode e v

920− return (k' :=> Identity v')

1055+ return (k' :=> Identity v')

921 }

1056 }

922

1057

923fieldMapEncoder :: forall check parse r.

1058fieldMapEncoder :: forall check parse r.

@@ -938,6 +1073,32 @@ fieldMapEncoder = unsafeEncoder $ do

938 Just (Identity v) -> return v

1073 Just (Identity v) -> return v

939 }

1074 }

940

1075

1076+-- this is in base 4.12 (GHC 8.6);

1077+newtype Ap f a = Ap {getAp :: f a}

1078+

1079+instance (Applicative f, Semigroup a) => Semigroup (Ap f a) where

1080+ Ap x <> Ap y = Ap (liftA2 (<>) x y)

1081+

1082+instance (Applicative f, Monoid a) => Monoid (Ap f a) where

1083+ mappend = (<>)

1084+ mempty = Ap (pure mempty)

1085+

1086+pathFieldEncoder :: forall a p check parse . (HasFields a, Monad check, MonadError Text parse, GCompare (Field a)) => (forall x. Field a x -> Encoder check parse x p) -> Encoder check parse (a, [p]) [p]

1087+pathFieldEncoder fieldEncoder = unsafeEncoder $ do

1088+ fieldEncoderPureMap :: DMap.DMap (Field a) (Decoder Identity parse p) <- getAp $ getConst $ tabulateFieldsA @a $ \f -> Const (Ap $ fmap (DMap.singleton f . Decoder) $ (checkEncoder @Identity) $ fieldEncoder f)

1089+ let fieldEncoderPure :: forall x. Field a x -> Encoder Identity parse x p

1090+ fieldEncoderPure f = toEncoder (DMap.findWithDefault (error "bad") f fieldEncoderPureMap)

1091+ pure $ EncoderImpl

1092+ { _encoderImpl_encode = \(x, rest) -> execWriter $ do

1093+ _ <- traverseWithField (\f x_i -> tell (pure $ encode (fieldEncoderPure f) x_i) *> pure x_i) x

1094+ tell rest

1095+ , _encoderImpl_decode = State.runStateT $ tabulateFieldsA $ \f -> State.get >>= \case

1096+ [] -> throwError $ T.pack "not enough path components"

1097+ p:ps -> do

1098+ State.put ps

1099+ lift $ tryDecode (fieldEncoderPure f) p

1100+ }

1101+

941-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.

1102-- | Use ToJSON/FromJSON to encode to Text. The correctness of this encoder is dependent on the encoding being injective and round-tripping correctly.

942jsonEncoder :: forall check parse r.

1103jsonEncoder :: forall check parse r.

943 ( ToJSON r

1104 ( ToJSON r

@@ -954,4 +1115,14 @@ jsonEncoder = unsafeEncoder $ do

954 Right x -> return x

1115 Right x -> return x

955 }

1116 }

956

1117

1118+-- Useful for app server integration.

1119+-- p must not start with slashes

1120+byteStringsToPageName :: BS.ByteString -> BS.ByteString -> PageName

1121+byteStringsToPageName p q =

1122+ let pageNameEncoder' :: Encoder Identity Identity PageName (String, String)

1123+ pageNameEncoder' = bimap

1124+ (unpackTextEncoder . pathSegmentsTextEncoder . listToNonEmptyEncoder)

1125+ (unpackTextEncoder . queryParametersTextEncoder . toListMapEncoder)

1126+ in decode pageNameEncoder' (T.unpack (T.decodeUtf8 p), T.unpack (T.decodeUtf8 q))

1127+

957--TODO: decodeURIComponent as appropriate

1128--TODO: decodeURIComponent as appropriate

lib/run/src/Obelisk/Run.hs+11−12

@@ -20,11 +20,10 @@ import Control.Exception

20import Control.Lens ((%~), (^?), _Just, _Right)

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

22import Data.ByteString (ByteString)

23+import qualified Data.ByteString as BS

23import qualified Data.ByteString.Char8 as BSC

24import qualified Data.ByteString.Char8 as BSC

24import qualified Data.ByteString.Lazy.Char8 as BSLC

25import qualified Data.ByteString.Lazy.Char8 as BSLC

25−import Data.Dependent.Sum (DSum (..))

26import Data.Functor.Identity

27−import Data.Functor.Sum

28import Data.List (uncons)

27import Data.List (uncons)

29import Data.Map (Map)

28import Data.Map (Map)

30import qualified Data.Map as Map

29import qualified Data.Map as Map

@@ -81,8 +80,8 @@ run port serveStaticAsset backend frontend = do

81 runSnapWithCommandLineArgs $ do

80 runSnapWithCommandLineArgs $ do

82 getRouteWith validFullEncoder >>= \case

81 getRouteWith validFullEncoder >>= \case

83 Identity r -> case r of

82 Identity r -> case r of

84− InL backendRoute :=> Identity a -> serveRoute $ backendRoute :/ a

83+ FullRoute_Backend backendRoute :/ a -> serveRoute $ backendRoute :/ a

85− InR obeliskRoute :=> Identity a ->

84+ FullRoute_Frontend obeliskRoute :/ a ->

86 serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) serveStaticAsset frontend publicConfigs $ obeliskRoute :/ a

85 serveDefaultObeliskApp (mkRouteToUrl validFullEncoder) serveStaticAsset frontend publicConfigs $ obeliskRoute :/ a

87 let conf = defRunConfig { _runConfig_redirectPort = port }

86 let conf = defRunConfig { _runConfig_redirectPort = port }

88 runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid

87 runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid

@@ -103,8 +102,8 @@ getConfigRoute configs = case Map.lookup "common/route" configs of

103runWidget

102runWidget

104 :: RunConfig

103 :: RunConfig

105 -> Map Text ByteString

104 -> Map Text ByteString

106− -> Frontend (R route)

105+ -> Frontend (R frontendRoute)

107− -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName

106+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName

108 -> IO ()

107 -> IO ()

109runWidget conf configs frontend validFullEncoder = do

108runWidget conf configs frontend validFullEncoder = do

110 uri <- either (fail . T.unpack) pure $ getConfigRoute configs

109 uri <- either (fail . T.unpack) pure $ getConfigRoute configs

@@ -123,11 +122,11 @@ runWidget conf configs frontend validFullEncoder = do

123 runSettingsSocket settings skt app)

122 runSettingsSocket settings skt app)

124

123

125obeliskApp

124obeliskApp

126− :: forall route backendRoute

125+ :: forall frontendRoute backendRoute

127 . Map Text ByteString

126 . Map Text ByteString

128 -> ConnectionOptions

127 -> ConnectionOptions

129− -> Frontend (R route)

128+ -> Frontend (R frontendRoute)

130− -> Encoder Identity Identity (R (Sum backendRoute (ObeliskRoute route))) PageName

129+ -> Encoder Identity Identity (R (FullRoute backendRoute frontendRoute)) PageName

131 -> URI

130 -> URI

132 -> Application

131 -> Application

133 -> IO Application

132 -> IO Application

@@ -143,14 +142,14 @@ obeliskApp configs opts frontend validFullEncoder uri backend = do

143 let jsaddleUri = BSLC.fromStrict $ URI.renderBs $ uri & uriPath %~ (<>[jsaddlePath])

142 let jsaddleUri = BSLC.fromStrict $ URI.renderBs $ uri & uriPath %~ (<>[jsaddlePath])

144 Right (jsaddleWarpRouteValidEncoder :: Encoder Identity (Either Text) (R JSaddleWarpRoute) PageName) <- return $ checkEncoder jsaddleWarpRouteEncoder

143 Right (jsaddleWarpRouteValidEncoder :: Encoder Identity (Either Text) (R JSaddleWarpRoute) PageName) <- return $ checkEncoder jsaddleWarpRouteEncoder

145 jsaddle <- jsaddleWithAppOr opts entryPoint $ \_ sendResponse -> sendResponse $ W.responseLBS H.status500 [("Content-Type", "text/plain")] "obeliskApp: jsaddle got a bad URL"

144 jsaddle <- jsaddleWithAppOr opts entryPoint $ \_ sendResponse -> sendResponse $ W.responseLBS H.status500 [("Content-Type", "text/plain")] "obeliskApp: jsaddle got a bad URL"

146− return $ \req sendResponse -> case tryDecode validFullEncoder (W.pathInfo req, mempty) of --TODO: Query strings

145+ return $ \req sendResponse -> case tryDecode validFullEncoder $ byteStringsToPageName (BS.dropWhile (== (fromIntegral $ fromEnum '/')) $ W.rawPathInfo req) (BS.drop 1 $ W.rawQueryString req) of

147 Identity r -> case r of

146 Identity r -> case r of

148− InR (ObeliskRoute_Resource ResourceRoute_JSaddleWarp) :=> Identity jsaddleRoute -> case jsaddleRoute of

147+ FullRoute_Frontend (ObeliskRoute_Resource ResourceRoute_JSaddleWarp) :/ jsaddleRoute -> case jsaddleRoute of

149 JSaddleWarpRoute_JavaScript :/ () -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs' (Just jsaddleUri) False

148 JSaddleWarpRoute_JavaScript :/ () -> sendResponse $ W.responseLBS H.status200 [("Content-Type", "application/javascript")] $ jsaddleJs' (Just jsaddleUri) False

150 _ -> flip jsaddle sendResponse $ req

149 _ -> flip jsaddle sendResponse $ req

151 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute

150 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute

152 }

151 }

153− InR (ObeliskRoute_App appRouteComponent) :=> Identity appRouteRest -> do

152+ FullRoute_Frontend (ObeliskRoute_App appRouteComponent) :/ appRouteRest -> do

154 let cookies = maybe [] parseCookies $ lookup (fromString "Cookie") (W.requestHeaders req)

153 let cookies = maybe [] parseCookies $ lookup (fromString "Cookie") (W.requestHeaders req)

155 html <- renderJsaddleFrontend configs cookies (mkRouteToUrl validFullEncoder) (appRouteComponent :/ appRouteRest) frontend

154 html <- renderJsaddleFrontend configs cookies (mkRouteToUrl validFullEncoder) (appRouteComponent :/ appRouteRest) frontend

156 sendResponse $ W.responseLBS H.status200 [("Content-Type", staticRenderContentType)] $ BSLC.fromStrict html

155 sendResponse $ W.responseLBS H.status200 [("Content-Type", staticRenderContentType)] $ BSLC.fromStrict html

skeleton/backend/src/Backend.hs+1−1

@@ -11,5 +11,5 @@ import Obelisk.Backend

11backend :: Backend BackendRoute FrontendRoute

12backend = Backend

13 { _backend_run = \serve -> serve $ const $ return ()

14− , _backend_routeEncoder = backendRouteEncoder

14+ , _backend_routeEncoder = fullRouteEncoder

15 }

skeleton/common/src/Common/Route.hs+8−12

@@ -19,7 +19,6 @@ import Control.Category

20import Data.Text (Text)

21import Data.Functor.Identity

22−import Data.Functor.Sum

24import Obelisk.Route

23import Obelisk.Route

25import Obelisk.Route.TH

24import Obelisk.Route.TH

@@ -34,17 +33,14 @@ data FrontendRoute :: * -> * where

34 FrontendRoute_Main :: FrontendRoute ()

33 FrontendRoute_Main :: FrontendRoute ()

35 -- This type is used to define frontend routes, i.e. ones for which the backend will serve the frontend.

34 -- This type is used to define frontend routes, i.e. ones for which the backend will serve the frontend.

37−backendRouteEncoder

36+fullRouteEncoder

38− :: Encoder (Either Text) Identity (R (Sum BackendRoute (ObeliskRoute FrontendRoute))) PageName

37+ :: Encoder (Either Text) Identity (R (FullRoute BackendRoute FrontendRoute)) PageName

38+fullRouteEncoder = mkFullRouteEncoder

39−backendRouteEncoder = handleEncoder (const (InL BackendRoute_Missing :/ ())) $

39+ (FullRoute_Backend BackendRoute_Missing :/ ())

40− pathComponentEncoder $ \case

40+ (\case

41− InL backendRoute -> case backendRoute of

42− BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty

41+ BackendRoute_Missing -> PathSegment "missing" $ unitEncoder mempty)

43− InR obeliskRoute -> obeliskRouteSegment obeliskRoute $ \case

42+ (\case

44− -- The encoder given to PathEnd determines how to parse query parameters,

45− -- in this example, we have none, so we insist on it.

46− FrontendRoute_Main -> PathEnd $ unitEncoder mempty

43+ FrontendRoute_Main -> PathEnd $ unitEncoder mempty)

47−

49concat <$> mapM deriveRouteComponent

45concat <$> mapM deriveRouteComponent

50 [ ''BackendRoute

46 [ ''BackendRoute

skeleton/default.nix+6−6

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

1{ obelisk ? import ./.obelisk/impl {

2− system = builtins.currentSystem;

2+ system = builtins.currentSystem;

3− iosSdkVersion = "10.2";

3+ iosSdkVersion = "10.2";

4− # You must accept the Android Software Development Kit License Agreement at

4+ # You must accept the Android Software Development Kit License Agreement at

5− # https://developer.android.com/studio/terms in order to build Android apps.

5+ # https://developer.android.com/studio/terms in order to build Android apps.

6− # Uncomment and set this to `true` to indicate your acceptance:

6+ # Uncomment and set this to `true` to indicate your acceptance:

7− # config.android_sdk.accept_license = false;

7+ # config.android_sdk.accept_license = false;

8 }

9}:

10with obelisk;

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

@@ -6,5 +6,5 @@ import Reflex.Dom

7main :: IO ()

8main = do

9− let Right validFullEncoder = checkEncoder backendRouteEncoder

9+ let Right validFullEncoder = checkEncoder fullRouteEncoder

10 run $ runFrontend validFullEncoder frontend