master...e91171a · obelisk

git.iko.soy/obelisk

master and e91171a have 2 merge bases. This is what e91171a changed since the first, 8b83d0e, as git diff master...e91171a shows it.

ChangeLog.md+2

since splitsnapshots

unifiedsplit

@@ -9,6 +9,8 @@ This project's release branch is `master`. This log is written from the perspect

9* The backend no longer runs in BackendConfigsT.

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

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

12+* Generalised pathSegmentEncoder, added pathFieldEncoder.

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

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

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

default.nix+49−4

@@ -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 = {

@@ -233,6 +237,45 @@ in rec {

233 };

237 };

234 };

238 };

235

239

240+ dockerImage = args@{exe, name, version, extraContents ? [], extraPaths ? [], config ? {}}: let

241+ appDirSetupScript = nixpkgs.runCommand "appDirSetupScript.sh" {} ''

242+ mkdir -p $out/var/lib/backend

243+ ln -sft $out/var/lib/backend '${exe}'/*

244+ ${nixpkgs.findutils}/bin/find $out/var/lib/backend

245+

246+ # Needed for postgresql

247+ mkdir $out/bin

248+ ln -s ${nixpkgs.bash}/bin/sh $out/bin/sh

249+ mkdir $out/etc

250+ echo 'nobody:x:99:99:Nobody:/:/sbin/nologin' >> $out/etc/passwd

251+ echo 'nobody:*:17416:0:99999:7:::' >> $out/etc/shadow

252+ echo 'nobody:x:99:' >> $out/etc/group

253+ echo 'nobody:::' >> $out/etc/gshadow

254+ '';

255+

256+ in nixpkgs.dockerTools.buildImage {

257+ name = name;

258+ tag = version;

259+ contents = [ nixpkgs.iana-etc nixpkgs.cacert appDirSetupScript ] ++ extraContents;

260+ keepContentsDirlinks = true;

261+ extraCommands = ''

262+ chmod 1777 var/lib/backend

263+ '';

264+ config = {

265+ Env = [

266+ ("PATH=" + builtins.concatStringsSep(":")(extraPaths ++ [

267+ "/var/lib/backend" # put the obelisk project on the path.

268+ "/bin" # put contents on path

269+ ] ++ map (pkg: "${pkg}/bin") pkgs.stdenv.initialPath # put common tools in path so docker exec is useful

270+ ))

271+ ];

272+ Expose = 8000;

273+ Entrypoint = ["/var/lib/backend/backend"];

274+ WorkingDir = "/var/lib/backend";

275+ User = "99:99";

276+ } // config;

277+ };

278+

236 serverExe = backend: frontend: assets: optimizationLevel: version:

279 serverExe = backend: frontend: assets: optimizationLevel: version:

237 pkgs.runCommand "serverExe" {} ''

280 pkgs.runCommand "serverExe" {} ''

238 mkdir $out

281 mkdir $out

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

268 , tools ? _: []

311 , tools ? _: []

269 , shellToolOverrides ? _: _: {}

312 , shellToolOverrides ? _: _: {}

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

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

271− , __closureCompilerOptimizationLevel ? "ADVANCED"

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

272 }:

315 }:

273 let frontendName = "frontend";

316 let frontendName = "frontend";

274 backendName = "backend";

317 backendName = "backend";

@@ -349,6 +392,8 @@ in rec {

349 exe = serverOn system dummyVersion;

392 exe = serverOn system dummyVersion;

350 server = args@{ hostName, adminEmail, routeHost, enableHttps, version }:

393 server = args@{ hostName, adminEmail, routeHost, enableHttps, version }:

351 server (args // { exe = linuxExe version; });

394 server (args // { exe = linuxExe version; });

395+ dockerImage = args@{ name, version, ... }:

396+ dockerImage ({ exe = linuxExe version; } // args);

352 obelisk = import (base + "/.obelisk/impl") {};

397 obelisk = import (base + "/.obelisk/impl") {};

353 };

398 };

354 haskellPackageSets = {

399 haskellPackageSets = {

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

@@ -2,6 +2,6 @@

2 "owner": "reflex-frp",

3 "repo": "reflex-platform",

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

5− "rev": "7ecb4c255bb053a7a4796ffd6331cdbe210de91c",

5+ "rev": "b220ba089e2de2110eb22c5388e09d99e4321148",

6− "sha256": "1mngxa24cfpvxxq4hgh77nw36vny4abl5wi2xmlwpkk25wzm0h0x"

6+ "sha256": "0ds6bcw4p9q5x8h39djyqp5sp7wdzr9mmknsyjafn5l199hscppw"

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

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

31import qualified Data.ByteString.Char8 as BSC8

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

33import Data.Dependent.Sum

34−import Data.Functor.Sum

35import Data.Functor.Identity

34import Data.Functor.Identity

36import Data.Map (Map)

35import Data.Map (Map)

37import qualified Data.Map as Map

36import qualified Data.Map as Map

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

52import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)

51import System.IO (BufferMode (..), hSetBuffering, stderr, stdout)

54data Backend backendRoute frontendRoute = Backend

53data Backend backendRoute frontendRoute = Backend

55− { _backend_routeEncoder :: Encoder (Either Text) Identity (R (Sum backendRoute (ObeliskRoute frontendRoute))) PageName

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

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

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

57 }

56 }

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

114getPageName = do

113getPageName = do

115 p <- getsRequest rqPathInfo

114 p <- getsRequest rqPathInfo

116 q <- getsRequest rqQueryString

115 q <- getsRequest rqQueryString

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

116+ 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

117

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

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

124getRouteWith e = do

119getRouteWith e = do

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

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

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

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

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

176

171

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

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

178runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of

173runBackend backend frontend = case checkEncoder $ _backend_routeEncoder backend of

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

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

180 Right validFullEncoder -> do

175 Right validFullEncoder -> do

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

183 runSnapWithCommandLineArgs $ do

178 runSnapWithCommandLineArgs $ do

184 getRouteWith validFullEncoder >>= \case

179 getRouteWith validFullEncoder >>= \case

185 Identity r -> case r of

180 Identity r -> case r of

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

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

187− InR obeliskRoute :=> Identity a ->

182+ FullRoute_Frontend obeliskRoute :/ a ->

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

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

189 obeliskRoute :/ a

184 obeliskRoute :/ a

190

185

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

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

192mkRouteToUrl validFullEncoder =

187mkRouteToUrl validFullEncoder =

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

188 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

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

195

190

196renderGhcjsFrontend

191renderGhcjsFrontend

197 :: (MonadSnap m, HasCookies m)

192 :: (MonadSnap m, HasCookies m)

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/executable-config/lookup/obelisk-executable-config-lookup.cabal+3

@@ -24,7 +24,10 @@ library

24 else

25 hs-source-dirs: src-other, src

26 other-modules: Obelisk.Configs.Internal.Directory

27+ , Obelisk.Configs.Internal.Environment

27 build-depends: directory

28 build-depends: directory

29+ , attoparsec

30+ , witherable

29 build-depends:

32 build-depends:

30 base,

33 base,

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

@@ -35,7 +35,7 @@ getConfigs = do

35 where

36 collToList es = do

37 len <- getLength es

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

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

39 pure $ catMaybes list

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

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

lib/executable-config/lookup/src-other/Obelisk/Configs/Internal/Environment.hsnew file+116

@@ -0,0 +1,116 @@

1+{-# LANGUAGE TypeApplications #-}

2+{-# LANGUAGE PatternGuards #-}

3+{-# LANGUAGE OverloadedStrings #-}

5+module Obelisk.Configs.Internal.Environment where

7+import Control.Applicative

8+import Control.Monad

9+import qualified Data.Attoparsec.ByteString as P

10+import qualified Data.Attoparsec.ByteString.Char8 as P (hexadecimal)

11+import qualified Data.Attoparsec.Combinator as P

12+import Data.Bifunctor (second)

13+import Data.ByteString (ByteString)

14+import qualified Data.ByteString as BS

15+import qualified Data.ByteString.Base64 as Base64

16+import qualified Data.ByteString.Builder as Builder

17+import qualified Data.ByteString.Char8 as Char8

18+import qualified Data.ByteString.Lazy as LBS

19+import qualified Data.Char as Char

20+import Data.Map (Map)

21+import qualified Data.Map as Map

22+import Data.Text (Text)

23+import qualified Data.Text as T

24+import qualified Data.Text.Lazy as LT

25+import Data.Tuple (swap)

26+import Data.Witherable

27+import Data.Word

28+import System.Environment

29+import qualified Text.Printf as Printf

30+

31+

32+data EnvCodec

33+ = EnvCodec_Char8

34+ | EnvCodec_Base64

35+ deriving (Eq, Ord, Show)

36+

37+envVarEscapes :: [(Char, Word8)]

38+envVarEscapes = fmap (second f)

39+ [ ('-', 'h')

40+ , ('_', 'u')

41+ , ('.', 'd')

42+ ]

43+ where

44+ f :: Char -> Word8

45+ f = fromIntegral . Char.ord

46+

47+escapeVarName :: EnvCodec -> Text -> ByteString

48+escapeVarName codec x = LBS.toStrict . Builder.toLazyByteString $ T.foldr ((<>) . f) mempty x <> codec'

49+ where

50+ escapeCode = Map.fromList envVarEscapes

51+

52+ codec' = case codec of

53+ EnvCodec_Base64 -> "__base64"

54+ EnvCodec_Char8 -> ""

55+

56+ f :: Char -> Builder.Builder

57+ f c

58+ | not (Char.isAscii c) = error "bad"

59+ | c == '/' = "_"

60+ | Char.isAlphaNum c = Builder.char7 c

61+ | Just c' <- Map.lookup c escapeCode = "__" <> Builder.word8 c'

62+ | otherwise = "__x" <> (Builder.string7 $ Printf.formatInt (Char.ord c) (Printf.FieldFormat (Just 2) Nothing (Just Printf.ZeroPad) Nothing False "" 'x') "")

63+

64+unescapeVarName :: ByteString -> Either String (Text, EnvCodec)

65+unescapeVarName x = P.parseOnly ((,) <$> fileName <*> codec <* P.endOfInput) x

66+ where

67+ escapeCode = Map.fromList $ fmap swap envVarEscapes

68+

69+ codec :: P.Parser EnvCodec

70+ codec = P.option EnvCodec_Char8 $ (EnvCodec_Base64 <$ "__base64")

71+

72+ -- | parse ps. succeed only if both ps and qs succeeds

73+ guardLookahead ps qs = do

74+ p <- ps

75+ _ <- P.lookAhead qs

76+ return p

77+

78+ parseEscapeCode =

79+ ("__" *> (do

80+ c <- P.anyWord8

81+ case Map.lookup c escapeCode of

82+ Nothing -> mzero

83+ Just c' -> return c')

84+ ) <|> ( "__x" *> (Char.chr . fromIntegral <$> P.hexadecimal @Word8))

85+

86+ parseEnvChar = Char.chr . fromIntegral <$> P.satisfy (P.inClass "a-zA-Z0-9")

87+

88+ fileName = LT.toStrict . LT.pack <$> P.many' (P.choice

89+ [ parseEnvChar

90+ , parseEscapeCode

91+ , guardLookahead ('/' <$ "_") (parseEnvChar <|> parseEscapeCode)

92+ ])

93+

94+

95+getConfigsFromEnvironment :: ByteString -> Map Text ByteString -> IO (Map Text ByteString)

96+getConfigsFromEnvironment varNamePrefix dirConfigs = do

97+ let

98+ prefix needle haystack

99+ | needle `BS.isPrefixOf` haystack = Just (BS.drop (BS.length needle) haystack)

100+ | otherwise = Nothing

101+

102+ makeEnv (k0, v0) = case prefix varNamePrefix (Char8.pack k0) of

103+ Nothing -> return Nothing

104+ Just k -> case unescapeVarName k of

105+ Left bad -> error bad

106+ Right (k', codec) ->

107+ let

108+ v = case codec of

109+ EnvCodec_Char8 -> Char8.pack v0

110+ EnvCodec_Base64 -> Base64.decodeLenient (Char8.pack v0)

111+ in case Map.lookup k' dirConfigs of

112+ Just v' | v /= v' -> error $ "conflicting obelisk config: env " <> k0 <> " /= ./config/" <> (T.unpack k')

113+ _ -> return (Just (k', v))

114+

115+ env <- wither makeEnv =<< getEnvironment

116+ return $ (Map.fromList env) <> dirConfigs

lib/executable-config/lookup/src-other/Obelisk/ExecutableConfig/Lookup.hs+10−2

@@ -1,6 +1,12 @@

1{-# LANGUAGE LambdaCase #-}

2{-# LANGUAGE OverloadedStrings #-}

3−module Obelisk.ExecutableConfig.Lookup where

3+module Obelisk.ExecutableConfig.Lookup

4+ ( getConfigs

5+ , escapeVarName

6+ , EnvCodec(..)

7+ , unescapeVarName

8+ )

9+where

5import Data.Map (Map)

11import Data.Map (Map)

6import qualified Data.Map as Map

12import qualified Data.Map as Map

@@ -14,5 +20,7 @@ import Control.Monad

15import Obelisk.Configs.Internal.Directory

21import Obelisk.Configs.Internal.Directory

23+import Obelisk.Configs.Internal.Environment

24+

17getConfigs :: IO (Map Text ByteString)

25getConfigs :: IO (Map Text ByteString)

18−getConfigs = getConfigsFromDirectory "config"

26+getConfigs = getConfigsFromDirectory "config" >>= getConfigsFromEnvironment "OBELISK_CONFIG_"

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+6−5

@@ -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 =

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

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

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

138runFrontend

139runFrontend

139 :: forall backendRoute route

140 :: forall backendRoute route

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

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

141 -> Frontend (R route)

142 -> Frontend (R route)

142 -> JSM ()

143 -> JSM ()

143runFrontend validFullEncoder frontend = do

144runFrontend validFullEncoder frontend = do

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

165 runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend

166 runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend

166

167

167runFrontendWithConfigsAndCurrentRoute

168runFrontendWithConfigsAndCurrentRoute

168− :: forall backendRoute route

169+ :: forall backendRoute frontendRoute

169 . FrontendMode

170 . FrontendMode

170 -> Map Text ByteString

171 -> Map Text ByteString

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

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

172− -> Frontend (R route)

173+ -> Frontend (R frontendRoute)

173 -> JSM ()

174 -> JSM ()

174runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend = do

175runFrontendWithConfigsAndCurrentRoute mode configs validFullEncoder frontend = do

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

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

176 errorLeft = \case

177 errorLeft = \case

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

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

178 Right x -> Identity x

179 Right x -> Identity x

lib/route/src/Obelisk/Route.hs+191−21

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

@@ -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

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

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

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

664 }

727 }

665

728

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

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

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

730+-- prism combinators so far.

731+dSumPrism

732+ :: forall f f' g

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

733+ . (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)

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

735+dSumPrism p = prism'

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

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

738+

739+-- already in obelisk

740+rPrism

741+ :: forall f f'

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

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

744+rPrism p = dSumPrism p

745+

746+dSumPrism'

747+ :: forall f g a

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

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

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

751+

752+dSumGEqPrism

753+ :: GEq f

754+ => f a

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

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

757+

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

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

760+-- generalized a usual sum type.

761+--

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

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

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

765+_R

766+ :: GEq f

767+ => f a

768+ -> Prism' (R f) a

769+_R variant = dSumGEqPrism variant . iso runIdentity Identity

670

770

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

771-- | 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.

772-- if the prism doesn't match.

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

710-- Actual obelisk route info

810-- Actual obelisk route info

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

811--------------------------------------------------------------------------------

712

812

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

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

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

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

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

818+

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

820+ gshowsPrec p = \case

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

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

823+

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

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

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

827+ geq _ _ = Nothing

828+

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

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

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

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

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

834+

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

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

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

838+

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

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

841+mkFullRouteEncoder

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

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

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

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

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

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

848+ pathComponentEncoder $ \case

849+ FullRoute_Backend backendRoute -> backendSegment backendRoute

850+ FullRoute_Frontend obeliskRoute -> obeliskRouteSegment obeliskRoute frontendSegment

851+

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

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

714-- frontend.

853-- frontend.

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

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

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

839 ]

978 ]

840

979

841makePrisms ''ObeliskRoute

980makePrisms ''ObeliskRoute

842−

981+makePrisms ''FullRoute

843deriveGEq ''Void1

982deriveGEq ''Void1

844deriveGCompare ''Void1

983deriveGCompare ''Void1

845

984

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

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

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

848renderBackendRoute

987renderBackendRoute

849 :: forall br a.

988 :: forall br a.

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

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

851 -> R br

990 -> R br

852 -> Text

991 -> Text

853−renderBackendRoute enc = renderObeliskRoute enc . hoistR InL

992+renderBackendRoute enc = renderObeliskRoute enc . hoistR FullRoute_Backend

854

993

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

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

856renderFrontendRoute

995renderFrontendRoute

857 :: forall a fr.

996 :: forall a fr.

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

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

859 -> R fr

998 -> R fr

860 -> Text

999 -> Text

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

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

862

1001

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

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

864renderObeliskRoute

1003renderObeliskRoute

865 :: forall a b.

1004 :: forall a b.

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

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

867− -> R (Sum a b)

1006+ -> R (FullRoute a b)

868 -> Text

1007 -> Text

869renderObeliskRoute e r =

1008renderObeliskRoute e r =

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

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

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

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

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

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

873

1012

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

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

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

878integralEncoder = prismEncoder (Numeric.Lens.integral)

1017integralEncoder = prismEncoder (Numeric.Lens.integral)

879

1018

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

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

881− Encoder check parse (Text, PageName) PageName

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

882−pathSegmentEncoder = unsafeMkEncoder EncoderImpl

1021+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

1022

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

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

890

1024

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

938 Just (Identity v) -> return v

1072 Just (Identity v) -> return v

939 }

1073 }

940

1074

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

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

1077+

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

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

1080+

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

1082+ mappend = (<>)

1083+ mempty = Ap (pure mempty)

1084+

1085+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]

1086+pathFieldEncoder fieldEncoder = unsafeEncoder $ do

1087+ 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)

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

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

1090+ pure $ EncoderImpl

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

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

1093+ tell rest

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

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

1096+ p:ps -> do

1097+ State.put ps

1098+ lift $ tryDecode (fieldEncoderPure f) p

1099+ }

1100+

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

1101-- | 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.

1102jsonEncoder :: forall check parse r.

943 ( ToJSON r

1103 ( ToJSON r

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

954 Right x -> return x

1114 Right x -> return x

955 }

1115 }

956

1116

1117+-- Useful for app server integration.

1118+-- p must not start with slashes

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

1120+byteStringsToPageName p q =

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

1122+ pageNameEncoder' = bimap

1123+ (unpackTextEncoder . pathSegmentsTextEncoder . listToNonEmptyEncoder)

1124+ (unpackTextEncoder . queryParametersTextEncoder . toListMapEncoder)

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

1126+

957--TODO: decodeURIComponent as appropriate

1127--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

@@ -83,8 +82,8 @@ run port serveStaticAsset backend frontend = do

83 runSnapWithCommandLineArgs $ do

82 runSnapWithCommandLineArgs $ do

84 getRouteWith validFullEncoder >>= \case

83 getRouteWith validFullEncoder >>= \case

85 Identity r -> case r of

84 Identity r -> case r of

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

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

87− InR obeliskRoute :=> Identity a ->

86+ FullRoute_Frontend obeliskRoute :/ a ->

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

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

89 let conf = defRunConfig { _runConfig_redirectPort = port }

88 let conf = defRunConfig { _runConfig_redirectPort = port }

90 runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid

89 runWidget conf publicConfigs frontend validFullEncoder `finally` killThread backendTid

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

105runWidget

104runWidget

106 :: RunConfig

105 :: RunConfig

107 -> Map Text ByteString

106 -> Map Text ByteString

108− -> Frontend (R route)

107+ -> Frontend (R frontendRoute)

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

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

110 -> IO ()

109 -> IO ()

111runWidget conf configs frontend validFullEncoder = do

110runWidget conf configs frontend validFullEncoder = do

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

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

@@ -130,11 +129,11 @@ runWidget conf configs frontend validFullEncoder = do

130 runner settings skt app)

129 runner settings skt app)

131

130

132obeliskApp

131obeliskApp

133− :: forall route backendRoute

132+ :: forall frontendRoute backendRoute

134 . Map Text ByteString

133 . Map Text ByteString

135 -> ConnectionOptions

134 -> ConnectionOptions

136− -> Frontend (R route)

135+ -> Frontend (R frontendRoute)

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

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

138 -> URI

137 -> URI

139 -> Application

138 -> Application

140 -> IO Application

139 -> IO Application

@@ -150,14 +149,14 @@ obeliskApp configs opts frontend validFullEncoder uri backend = do

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

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

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

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

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

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

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

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

154 Identity r -> case r of

153 Identity r -> case r of

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

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

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

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

157 _ -> flip jsaddle sendResponse $ req

156 _ -> flip jsaddle sendResponse $ req

158 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute

157 { W.pathInfo = fst $ encode jsaddleWarpRouteValidEncoder jsaddleRoute

159 }

158 }

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

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

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

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

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

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

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

162 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