0a3e97a · obelisk · git.iko.soy

git.iko.soy/obelisk

Merge remote-tracking branch 'origin/master' into aa-nixpkgs1909

0a3e97aJohn Ericson7 years ago

ChangeLog.md+16−10

@@ -2,18 +2,24 @@

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

5+## v0.3.0.0 - 2019-12-20

6−

7−* Generalised pathSegmentEncoder, added pathFieldEncoder.

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

8+* Added some `Prism`s to the encoder library for manipulating `DSum`s.

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

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

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

11−* Add support in obelisk-route for single parameters in URL paths

11+* Add support in `obelisk-route` for single parameters in URL paths.

12−* Bump reflex-platform so that obelisk now uses reflex-dom 0.5.2.0

12+* Bump reflex-platform so that obelisk now uses reflex-dom 0.5.2.0.

13* Use a `--pure` nix shell in `ob run` for parity with `ob repl` and more resilience against "works on my machine".

14−* Use `--keep NIX_PATH` for all pure shells so references to `<nixpkgs>` continues to work.

14+* Pin usages of `<nixpkgs>` in obelisk thunks, etc. to the nixpkgs used by the project's obelisk impl.

15* Backport ACMEv2 support in obelisk server to regain LetsEncrypt account creation.

16−* Enable https in `ob run`

16+* Enable HTTPS in `ob run`.

17+* `ob run` now handles `ghci` errors better, and includes a custom `ghcid`

18+ version. As a result, you no longer need to have ghcid installed to

19+ use `ob run`, as we provide one for you.

20+* `ob` commands now complain less on systems with umasks other than `0022`.

21+* Ignore package environment files in `ob run` and `ob repl`.

22+* Add `Obelisk.Route.Frontend.routeLinkDynAttr`.

18## v0.2.0.0 - 2019-8-17

24## v0.2.0.0 - 2019-8-17

FAQ.md+1−1

@@ -81,7 +81,7 @@ project's dependencies and,

81Assuming we are in a project created with `ob init`, `ob run` calls (see

82`lib/command/src/Obelisk/Command.hs`):

84− nix-shell --pure --keep NIX_PATH -A shells.ghc --run 'ob --no-handoff internal run-static-io <real-run-function>'

84+ nix-shell --pure -A shells.ghc --run 'ob --no-handoff internal run-static-io <real-run-function>'

86where

default.nix+12−2

@@ -36,6 +36,8 @@ let

36 in {

37 hnix = haskellLib.dontCheck (haskellLib.doJailbreak (self.callCabal2nix "hnix" (hackGet dep/hnix) {}));

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

39+

40+ ghcid = self.callCabal2nix "ghcid" (hackGet ./dep/ghcid) {};

39 })

41 })

41 pkgs.obeliskExecutableConfig.haskellOverlay

43 pkgs.obeliskExecutableConfig.haskellOverlay

@@ -43,6 +45,7 @@ let

43 # Add obelisk packages

45 # Add obelisk packages

44 (self: super: let

46 (self: super: let

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

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

48+ onLinux = pkg: f: if pkgs.stdenv.isLinux then f pkg else pkg;

46 in {

49 in {

47 obelisk-executable-config-inject = pkgs.obeliskExecutableConfig.platforms.web.inject self;

50 obelisk-executable-config-inject = pkgs.obeliskExecutableConfig.platforms.web.inject self;

@@ -50,9 +53,16 @@ let

50 obelisk-asset-serve-snap = self.callCabal2nix "obelisk-asset-serve-snap" (cleanSource ./lib/asset/serve-snap) {};

53 obelisk-asset-serve-snap = self.callCabal2nix "obelisk-asset-serve-snap" (cleanSource ./lib/asset/serve-snap) {};

51 obelisk-backend = self.callCabal2nix "obelisk-backend" (cleanSource ./lib/backend) {};

54 obelisk-backend = self.callCabal2nix "obelisk-backend" (cleanSource ./lib/backend) {};

52 obelisk-cliapp = self.callCabal2nix "obelisk-cliapp" (cleanSource ./lib/cliapp) {};

55 obelisk-cliapp = self.callCabal2nix "obelisk-cliapp" (cleanSource ./lib/cliapp) {};

53− obelisk-command = haskellLib.overrideCabal (self.callCabal2nix "obelisk-command" (cleanSource ./lib/command) {}) { librarySystemDepends = [ pkgs.nix ]; };

56+ obelisk-command = haskellLib.overrideCabal (self.callCabal2nix "obelisk-command" (cleanSource ./lib/command) {}) {

57+ librarySystemDepends = [

58+ pkgs.nix

59+ (haskellLib.justStaticExecutables self.ghcid)

60+ ];

61+ };

54 obelisk-frontend = self.callCabal2nix "obelisk-frontend" (cleanSource ./lib/frontend) {};

62 obelisk-frontend = self.callCabal2nix "obelisk-frontend" (cleanSource ./lib/frontend) {};

55− obelisk-run = self.callCabal2nix "obelisk-run" (cleanSource ./lib/run) {};

63+ obelisk-run = onLinux (self.callCabal2nix "obelisk-run" (cleanSource ./lib/run) {}) (pkg:

64+ haskellLib.overrideCabal pkg (drv: { librarySystemDepends = [ pkgs.iproute ]; })

65+ );

56 obelisk-route = self.callCabal2nix "obelisk-route" (cleanSource ./lib/route) {};

66 obelisk-route = self.callCabal2nix "obelisk-route" (cleanSource ./lib/route) {};

57 obelisk-selftest = self.callCabal2nix "obelisk-selftest" (cleanSource ./lib/selftest) {};

67 obelisk-selftest = self.callCabal2nix "obelisk-selftest" (cleanSource ./lib/selftest) {};

58 obelisk-snap-extras = self.callCabal2nix "obelisk-snap-extras" (cleanSource ./lib/snap-extras) {};

68 obelisk-snap-extras = self.callCabal2nix "obelisk-snap-extras" (cleanSource ./lib/snap-extras) {};

dep/.gitignore+1

@@ -1,4 +1,5 @@

2+!*/

2!.gitignore

3!.gitignore

3!*/*.json

4!*/*.json

4!*/default.nix

5!*/default.nix

dep/ghcid/default.nixnew file+7

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

1+# DO NOT HAND-EDIT THIS FILE

2+import ((import <nixpkgs> {}).fetchFromGitHub (

3+ let json = builtins.fromJSON (builtins.readFile ./github.json);

4+ in { inherit (json) owner repo rev sha256;

5+ private = json.private or false;

6+ }

7+))

dep/ghcid/github.jsonnew file+7

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

1+{

2+ "owner": "ndmitchell",

3+ "repo": "ghcid",

4+ "branch": "master",

5+ "rev": "f572318f32b1617f6054248e5888af68222f8e50",

6+ "sha256": "1icg3r70lg2kmd9gdc024ih1n9nrja98yav74z9nvykqygvv5w0n"

7+}

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

@@ -1,5 +1,5 @@

1name: obelisk-command

2−version: 0.1

2+version: 0.3

3cabal-version: >= 1.8

4build-type: Simple

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

@@ -267,7 +267,8 @@ mkObeliskConfig :: IO Obelisk

267mkObeliskConfig = do

268 cliArgs <- getArgs

269 -- This function should not use argument parser (full argument parsing happens post handoff)

270+ -- TODO: See if we can use the argument parser with a subset of the parsers to get logging level out.

270− let logLevel = toLogLevel $ "-v" `elem` cliArgs

271+ let logLevel = toLogLevel $ any (`elem` ["-v", "--verbose"]) cliArgs

271 notInteractive <- not <$> isInteractiveTerm

272 notInteractive <- not <$> isInteractiveTerm

272 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case

273 cliConf <- newCliConfig logLevel notInteractive notInteractive $ \case

273 ObeliskError_ProcessError (ProcessFailure p code) ann ->

274 ObeliskError_ProcessError (ProcessFailure p code) ann ->

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

@@ -281,7 +281,7 @@ createKeystore root config = do

281 [ "-genkeypair", "-noprompt"

282 , "-keystore", _keytoolConfig_keystore config

283 , "-keyalg", "RSA", "-keysize", "2048"

284− , "-validity", "1000000000"

284+ , "-validity", "1000000"

285 , "-storepass", _keytoolConfig_storepass config

286 , "-alias", _keytoolConfig_alias config

287 , "-keypass", _keytoolConfig_keypass config

lib/command/src/Obelisk/Command/Project.hs+74−27

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

1{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE LambdaCase #-}

3{-# LANGUAGE OverloadedStrings #-}

4+{-# LANGUAGE TemplateHaskell #-}

4module Obelisk.Command.Project

5module Obelisk.Command.Project

5 ( InitSource (..)

6 ( InitSource (..)

6 , initProject

7 , initProject

@@ -15,6 +16,7 @@ module Obelisk.Command.Project

15 , toImplDir

16 , toImplDir

16 ) where

17 ) where

19+import Control.Concurrent.MVar (MVar, newMVar, withMVarMasked)

18import Control.Monad

20import Control.Monad

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

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

20import Control.Monad.State

22import Control.Monad.State

@@ -22,11 +24,14 @@ import Data.Bits

22import Data.Function (on)

24import Data.Function (on)

23import qualified Data.Text as T

25import qualified Data.Text as T

24import System.Directory

26import System.Directory

27+import System.Environment (lookupEnv)

25import System.FilePath

28import System.FilePath

26import System.IO.Temp

29import System.IO.Temp

30+import System.IO.Unsafe (unsafePerformIO)

27−import System.Posix (FileStatus, UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)

31+import System.Posix (FileStatus, FileMode, CMode (..), UserID, deviceID, fileID, fileMode, fileOwner, getFileStatus, getRealUserID)

28import System.Posix.Files

32import System.Posix.Files

29import System.Process (CreateProcess, cwd, proc, waitForProcess, delegate_ctlc)

33import System.Process (CreateProcess, cwd, proc, waitForProcess, delegate_ctlc)

34+import System.Which (staticWhich)

31import GitHub.Data.GitData (Branch)

36import GitHub.Data.GitData (Branch)

32import GitHub.Data.Name (Name)

37import GitHub.Data.Name (Name)

@@ -34,6 +39,7 @@ import GitHub.Data.Name (Name)

34import Obelisk.App (MonadObelisk)

39import Obelisk.App (MonadObelisk)

35import Obelisk.CliApp

40import Obelisk.CliApp

36import Obelisk.Command.Thunk

41import Obelisk.Command.Thunk

42+

37--TODO: Make this module resilient to random exceptions

43--TODO: Make this module resilient to random exceptions

39--TODO: Don't hardcode this

45--TODO: Don't hardcode this

@@ -50,10 +56,10 @@ obeliskSourceWithBranch branch = ThunkSource_GitHub $ GitHubSource

50 }

56 }

52data InitSource

58data InitSource

53− = InitSource_Default

59+ = InitSource_Default

54− | InitSource_Branch (Name Branch)

60+ | InitSource_Branch (Name Branch)

55− | InitSource_Symlink FilePath

61+ | InitSource_Symlink FilePath

56− deriving Show

62+ deriving Show

58-- | Path to obelisk directory in given path

64-- | Path to obelisk directory in given path

59toObeliskDir :: FilePath -> FilePath

65toObeliskDir :: FilePath -> FilePath

@@ -114,15 +120,16 @@ initProject source force = withSystemTempDirectory "ob-init" $ \tmpDir -> do

114findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)

120findProjectObeliskCommand :: MonadObelisk m => FilePath -> m (Maybe FilePath)

115findProjectObeliskCommand target = do

121findProjectObeliskCommand target = do

116 myUid <- liftIO getRealUserID

122 myUid <- liftIO getRealUserID

123+ processUmask <- liftIO getUmask

117 targetStat <- liftIO $ getFileStatus target

124 targetStat <- liftIO $ getFileStatus target

118− (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat myUid >>= \case

125+ (result, insecurePaths) <- flip runStateT [] $ walkToProjectRoot target targetStat processUmask myUid >>= \case

119 Nothing -> pure Nothing

126 Nothing -> pure Nothing

120 Just projectRoot -> liftIO (doesDirectoryExist $ toImplDir projectRoot) >>= \case

127 Just projectRoot -> liftIO (doesDirectoryExist $ toImplDir projectRoot) >>= \case

121 False -> do

128 False -> do

122 putLog Warning $ "Found obelisk directory in " <> T.pack projectRoot <> " but the implementation (impl) file is missing"

129 putLog Warning $ "Found obelisk directory in " <> T.pack projectRoot <> " but the implementation (impl) file is missing"

123 pure Nothing

130 pure Nothing

124 True -> do

131 True -> do

125− walkToImplDir projectRoot myUid -- For security check

132+ walkToImplDir projectRoot myUid processUmask -- For security check

126 return $ Just projectRoot

133 return $ Just projectRoot

127 case (result, insecurePaths) of

134 case (result, insecurePaths) of

128 (Just projDir, []) -> do

135 (Just projDir, []) -> do

@@ -133,16 +140,36 @@ findProjectObeliskCommand target = do

133 putLog Error $ T.unlines

140 putLog Error $ T.unlines

134 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"

141 [ "Error: Found a project at " <> T.pack (normalise projDir) <> ", but had to traverse one or more insecure directories to get there:"

135 , T.unlines $ fmap (T.pack . normalise) insecurePaths

142 , T.unlines $ fmap (T.pack . normalise) insecurePaths

136− , "Please ensure that all of these directories are owned by you and are not writable by anyone else."

143+ , "Please ensure that all of these directories are owned by you, not world-writable, and no more group-writable than permitted by your umask."

137 ]

144 ]

138 return Nothing

145 return Nothing

139

146

147+-- | Get the umask for the Obelisk process.

148+--

149+-- Because of

150+-- http://man7.org/linux/man-pages/man2/umask.2.html#NOTES we have to set the

151+-- umask to read it. We are using 'withMVarMasked' to guarantee that setting and

152+-- reading isn't interrupted by any exception or interleaved with another thread.

153+getUmask :: IO FileMode

154+getUmask = withMVarMasked globalUmaskLock $ \() -> do

155+ initialMask <- setFileCreationMask safeUmask

156+ void (setFileCreationMask initialMask)

157+ pure initialMask

158+ where

159+ safeUmask :: FileMode

160+ safeUmask = CMode 0o22

161+

162+{-# NOINLINE globalUmaskLock #-}

163+globalUmaskLock :: MVar ()

164+globalUmaskLock = unsafePerformIO (newMVar ())

165+

140-- | Get the FilePath to the containing project directory, if there is one

166-- | Get the FilePath to the containing project directory, if there is one

141findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)

167findProjectRoot :: MonadObelisk m => FilePath -> m (Maybe FilePath)

142findProjectRoot target = do

168findProjectRoot target = do

143 myUid <- liftIO getRealUserID

169 myUid <- liftIO getRealUserID

144 targetStat <- liftIO $ getFileStatus target

170 targetStat <- liftIO $ getFileStatus target

171+ umask <- liftIO $ getUmask

145− (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat myUid) []

172+ (result, _) <- liftIO $ runStateT (walkToProjectRoot target targetStat umask myUid) []

146 return result

173 return result

147

174

148withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a

175withProjectRoot :: MonadObelisk m => FilePath -> (FilePath -> m a) -> m a

@@ -155,15 +182,15 @@ withProjectRoot target f = findProjectRoot target >>= \case

155-- traversed in the process. Return the project root directory, if found.

182-- traversed in the process. Return the project root directory, if found.

156walkToProjectRoot

183walkToProjectRoot

157 :: (MonadState [FilePath] m, MonadIO m)

184 :: (MonadState [FilePath] m, MonadIO m)

158− => FilePath -> FileStatus -> UserID -> m (Maybe FilePath)

185+ => FilePath -> FileStatus -> FileMode -> UserID -> m (Maybe FilePath)

159−walkToProjectRoot this thisStat myUid = liftIO (doesDirectoryExist this) >>= \case

186+walkToProjectRoot this thisStat desiredUmask myUid = liftIO (doesDirectoryExist this) >>= \case

160 -- It's not a directory, so it can't be a project

187 -- It's not a directory, so it can't be a project

161 False -> do

188 False -> do

162 let dir = takeDirectory this

189 let dir = takeDirectory this

163 dirStat <- liftIO $ getFileStatus dir

190 dirStat <- liftIO $ getFileStatus dir

164− walkToProjectRoot dir dirStat myUid

191+ walkToProjectRoot dir dirStat desiredUmask myUid

165 True -> do

192 True -> do

166− when (not $ isWritableOnlyBy thisStat myUid) $ modify (this:)

193+ when (not $ isWellOwnedAndWellPermissioned thisStat myUid desiredUmask) $ modify (this:)

167 liftIO (doesDirectoryExist $ toObeliskDir this) >>= \case

194 liftIO (doesDirectoryExist $ toObeliskDir this) >>= \case

168 True -> return $ Just this

195 True -> return $ Just this

169 False -> do

196 False -> do

@@ -173,25 +200,38 @@ walkToProjectRoot this thisStat myUid = liftIO (doesDirectoryExist this) >>= \ca

173 isSameFileAs = (==) `on` fileIdentity

200 isSameFileAs = (==) `on` fileIdentity

174 if thisStat `isSameFileAs` nextStat

201 if thisStat `isSameFileAs` nextStat

175 then return Nothing -- Found a cycle; probably hit root directory

202 then return Nothing -- Found a cycle; probably hit root directory

176− else walkToProjectRoot next nextStat myUid

203+ else walkToProjectRoot next nextStat desiredUmask myUid

177

204

178-- | Walk from the given project root directory to its Obelisk implementation

205-- | Walk from the given project root directory to its Obelisk implementation

179-- directory, accumulating potentially insecure directories that were traversed

206-- directory, accumulating potentially insecure directories that were traversed

180-- in the process.

207-- in the process.

181−walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> m ()

208+walkToImplDir :: (MonadState [FilePath] m, MonadIO m) => FilePath -> UserID -> FileMode -> m ()

182−walkToImplDir projectRoot myUid = do

209+walkToImplDir projectRoot myUid umask = do

183 let obDir = toObeliskDir projectRoot

210 let obDir = toObeliskDir projectRoot

184 obDirStat <- liftIO $ getFileStatus obDir

211 obDirStat <- liftIO $ getFileStatus obDir

185− when (not $ isWritableOnlyBy obDirStat myUid) $ modify (obDir:)

212+ when (not $ isWellOwnedAndWellPermissioned obDirStat myUid umask) $ modify (obDir:)

186 let implThunk = obDir </> "impl"

213 let implThunk = obDir </> "impl"

187 implThunkStat <- liftIO $ getFileStatus implThunk

214 implThunkStat <- liftIO $ getFileStatus implThunk

188− when (not $ isWritableOnlyBy implThunkStat myUid) $ modify (implThunk:)

215+ when (not $ isWellOwnedAndWellPermissioned implThunkStat myUid umask) $ modify (implThunk:)

189

216

190−--TODO: Is there a better way to ask if anyone else can write things?

191−--E.g. what about ACLs?

192−-- | Check to see if directory is only writable by a user whose User ID matches the second argument provided

217+-- | Check to see if directory is writable by a user whose User ID matches the

218+-- second argument provided, and if the fact that other people can write to that

219+-- directory is in accordance with the umask of the system, passed as the third

220+-- argument.

193−isWritableOnlyBy :: FileStatus -> UserID -> Bool

221+isWellOwnedAndWellPermissioned :: FileStatus -> UserID -> FileMode -> Bool

222+isWellOwnedAndWellPermissioned s uid umask = isOwnedBy s uid && filePermissionIsSafe s umask

223+

224+isOwnedBy :: FileStatus -> UserID -> Bool

194−isWritableOnlyBy s uid = fileOwner s == uid && fileMode s .&. 0o22 == 0

225+isOwnedBy s uid = fileOwner s == uid

226+

227+-- | Check to see if a directory respect the umask, but check explicitly that

228+-- it's not world writable in any case.

229+filePermissionIsSafe :: FileStatus -> FileMode -> Bool

230+filePermissionIsSafe s umask = not fileWorldWritable && fileGroupWritable <= umaskGroupWritable

231+ where

232+ fileWorldWritable = fileMode s .&. 0o002 == 0o002

233+ fileGroupWritable = fileMode s .&. 0o020 == 0o020

234+ umaskGroupWritable = umask .&. 0o020 == 0

195

235

196-- | Run a command in the given shell for the current project

236-- | Run a command in the given shell for the current project

197inProjectShell :: MonadObelisk m => String -> String -> m ()

237inProjectShell :: MonadObelisk m => String -> String -> m ()

@@ -204,16 +244,23 @@ inImpureProjectShell shellName command = withProjectRoot "." $ \root ->

204

244

205projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()

245projectShell :: MonadObelisk m => FilePath -> Bool -> String -> Maybe String -> m ()

206projectShell root isPure shellName command = do

246projectShell root isPure shellName command = do

247+ let nixPath = $(staticWhich "nix")

248+ nixpkgsPath <- fmap T.strip $ readProcessAndLogStderr Debug $ proc nixPath ["eval", "(import .obelisk/impl {}).nixpkgs.path"]

249+ nixRemote <- liftIO $ lookupEnv "NIX_REMOTE"

207 (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCtlc $ setCwd (Just root) $ proc "nix-shell" $

250 (_, _, _, ph) <- createProcess_ "runNixShellAttr" $ setCtlc $ setCwd (Just root) $ proc "nix-shell" $

208 [ "default.nix"] <>

251 [ "default.nix"] <>

209− -- Keep $NIX_PATH in the env for --pure shells so '<nixpkgs>' works in sub-commands

252+ ["--pure" | isPure] <>

210− -- TODO: Don't use <nixpkgs> for anything!

211− (if isPure then [ "--pure", "--keep", "NIX_PATH" ] else []) <>

212 [ "-A"

253 [ "-A"

213 , "shells." <> shellName

254 , "shells." <> shellName

214 ] <> case command of

255 ] <> case command of

215 Nothing -> []

256 Nothing -> []

216− Just c -> ["--run", c]

257+ Just c ->

258+ -- TODO: Escape nixpkgsPath and nixRemote

259+ [ "--run"

260+ , "export NIX_PATH=nixpkgs=" <> T.unpack nixpkgsPath <> "; " <>

261+ maybe "" (\v -> "export NIX_REMOTE=" <> v <> "; ") nixRemote <>

262+ c

263+ ]

217 void $ liftIO $ waitForProcess ph

264 void $ liftIO $ waitForProcess ph

218

265

219setCtlc :: CreateProcess -> CreateProcess

266setCtlc :: CreateProcess -> CreateProcess

lib/command/src/Obelisk/Command/Run.hs+12−4

@@ -219,7 +219,7 @@ runGhciRepl

219 :: MonadObelisk m

220 => FilePath -- ^ Path to .ghci

221 -> m ()

222−runGhciRepl dotGhci = inProjectShell "ghc" $ unwords $ "ghci" : ["-no-user-package-db", "-ghci-script", dotGhci]

222+runGhciRepl dotGhci = inProjectShell "ghc" $ "ghci " <> makeBaseGhciOptions dotGhci

223

224-- | Run ghcid

225runGhcid

@@ -227,17 +227,25 @@ runGhcid

227 => FilePath -- ^ Path to .ghci

228 -> Maybe String -- ^ Optional command to run at every reload

229 -> m ()

230−runGhcid dotGhci mcmd = callCommand $ unwords $ "ghcid" : opts

230+runGhcid dotGhci mcmd = callCommand $ unwords $ $(staticWhich "ghcid") : opts

231 where

232 opts =

233 [ "-W"

234 --TODO: The decision of whether to use -fwarn-redundant-constraints should probably be made by the user

235− , "--command='ghci -Wall -ignore-dot-ghci -fwarn-redundant-constraints -no-user-package-db -ghci-script " <> dotGhci <> "' "

235+ , "--command='ghci -Wall -ignore-dot-ghci -fwarn-redundant-constraints " <> makeBaseGhciOptions dotGhci <> "' "

236 , "--reload=config"

237 , "--outputfile=ghcid-output.txt"

238 ] <> testCmd

239 testCmd = maybeToList (flip fmap mcmd $ \cmd -> "--test='" <> cmd <> "'")

240

241+makeBaseGhciOptions :: FilePath -> String

242+makeBaseGhciOptions dotGhci =

243+ unwords

244+ [ "-no-user-package-db"

245+ , "-package-env -"

246+ , "-ghci-script " <> dotGhci

247+ ]

248+

241getFreePort :: MonadIO m => m PortNumber

249getFreePort :: MonadIO m => m PortNumber

242getFreePort = liftIO $ withSocketsDo $ do

250getFreePort = liftIO $ withSocketsDo $ do

243 addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")

251 addr:_ <- getAddrInfo (Just defaultHints) (Just "127.0.0.1") (Just "0")

@@ -246,4 +254,4 @@ getFreePort = liftIO $ withSocketsDo $ do

246 open addr = do

254 open addr = do

247 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)

255 sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)

248 bind sock (addrAddress addr)

256 bind sock (addrAddress addr)

249− return sock

257+ return sock

lib/route/src/Obelisk/Route/Frontend.hs+22−6

@@ -53,6 +53,7 @@ module Obelisk.Route.Frontend

53 , runRouteToUrlT

54 , mapRouteToUrlT

55 , routeLink

56+ , routeLinkDynAttr

56 , dynRouteLink

57 , dynRouteLink

57 , adaptedUriPath

58 , adaptedUriPath

58 , setAdaptedUriPath

59 , setAdaptedUriPath

@@ -74,6 +75,7 @@ import Control.Monad.Trans.Control

74import Data.Coerce

75import Data.Coerce

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

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

76import Data.GADT.Compare

77import Data.GADT.Compare

78+import Data.Map (Map)

77import Data.Monoid

79import Data.Monoid

78import Data.Proxy

80import Data.Proxy

79import Data.Text (Text)

81import Data.Text (Text)

@@ -526,9 +528,7 @@ routeLink r w = do

526 setRoute $ r <$ domEvent Click e

528 setRoute $ r <$ domEvent Click e

527 return a

529 return a

528

530

529−-- | A link widget that, when clicked, sets the route to current value of the

531+-- | Like 'routeLinkDynAttr' but without custom attributes.

530−-- provided dynamic route. In non-javascript contexts the value of the dynamic post

531−-- build is used so the link still works like 'routeLink'.

532dynRouteLink

533 :: forall t m a route.

534 ( DomBuilder t m

@@ -537,11 +537,27 @@ dynRouteLink

537 , SetRoute t (R route) m

538 )

539 => Dynamic t (R route) -- ^ Target route

540− -> m a -- ^ Child widget

540+ -> m a -- ^ Child widget of the @a@ element

541+ -> m a

542+dynRouteLink = routeLinkDynAttr mempty

543+

544+-- | An @a@-tag link widget that, when clicked, sets the route to current value of the

545+-- provided dynamic route. In non-JavaScript contexts the value of the dynamic post

546+-- build is used so the link still works like 'routeLink'.

547+routeLinkDynAttr

548+ :: forall t m a route.

549+ ( DomBuilder t m

550+ , PostBuild t m

551+ , RouteToUrl (R route) m

552+ , SetRoute t (R route) m

553+ )

554+ => Dynamic t (Map AttributeName Text) -- ^ Attributes for @a@ element. Note that if @href@ is present it will be ignored

555+ -> Dynamic t (R route) -- ^ Target route

556+ -> m a -- ^ Child widget of the @a@ element

541 -> m a

557 -> m a

542−dynRouteLink dr w = do

558+routeLinkDynAttr dAttr dr w = do

543 enc <- askRouteToUrl

559 enc <- askRouteToUrl

544− er <- dynamicAttributesToModifyAttributes $ ("href" =:) . enc <$> dr

560+ er <- dynamicAttributesToModifyAttributes $ zipDynWith (<>) (("href" =:) . enc <$> dr) dAttr

545 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))

561 let cfg = (def :: ElementConfig EventResult t (DomBuilderSpace m))

546 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)

562 & elementConfig_eventSpec %~ addEventSpecFlags (Proxy :: Proxy (DomBuilderSpace m)) Click (\_ -> preventDefault)

547 & elementConfig_modifyAttributes .~ er

563 & elementConfig_modifyAttributes .~ er

lib/run/obelisk-run.cabal+3

@@ -48,3 +48,6 @@ library

48 exposed-modules:

49 Obelisk.Run

50 ghc-options: -Wall -fwarn-redundant-constraints

51+ if os(linux)

52+ cpp-options: -DIPROUTE_SUPPORTED

53+ build-depends: which

lib/run/src/Obelisk/Run.hs+28−15

@@ -1,3 +1,8 @@

1+{-# LANGUAGE CPP #-}

2+#if defined(IPROUTE_SUPPORTED)

3+{-# LANGUAGE TemplateHaskell #-}

4+#endif

1{-# LANGUAGE ConstraintKinds #-}

6{-# LANGUAGE ConstraintKinds #-}

2{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleContexts #-}

3{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FlexibleInstances #-}

@@ -62,12 +67,15 @@ import Snap.Core (Snap)

62import System.Environment

67import System.Environment

63import System.IO

68import System.IO

64import System.Process

69import System.Process

65−import System.Exit (ExitCode(..))

66import Text.URI (URI)

70import Text.URI (URI)

67import qualified Text.URI as URI

71import qualified Text.URI as URI

68import Text.URI.Lens

72import Text.URI.Lens

69import Web.Cookie

73import Web.Cookie

75+#if defined(IPROUTE_SUPPORTED)

76+import qualified System.Which

77+#endif

78+

71run

79run

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

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

73 -> ([Text] -> Snap ()) -- ^ Static asset handler

81 -> ([Text] -> Snap ()) -- ^ Static asset handler

@@ -99,7 +107,7 @@ runServeAsset rootPath = Snap.serveAsset "" rootPath . T.unpack . T.intercalate

107

100getConfigRoute :: Map Text ByteString -> Either Text URI

108getConfigRoute :: Map Text ByteString -> Either Text URI

101getConfigRoute configs = case Map.lookup "common/route" configs of

109getConfigRoute configs = case Map.lookup "common/route" configs of

102− Just r ->

110+ Just r ->

103 let stripped = T.strip (T.decodeUtf8 r)

111 let stripped = T.strip (T.decodeUtf8 r)

104 in case URI.mkURI stripped of

112 in case URI.mkURI stripped of

105 Just route -> Right route

113 Just route -> Right route

@@ -122,20 +130,20 @@ runWidget conf configs frontend validFullEncoder = do

122 settings = setBeforeMainLoop beforeMainLoop (setPort port (setTimeout 3600 defaultSettings))

130 settings = setBeforeMainLoop beforeMainLoop (setPort port (setTimeout 3600 defaultSettings))

123 -- Providing TLS here will also incidentally provide it to proxied requests to the backend.

131 -- Providing TLS here will also incidentally provide it to proxied requests to the backend.

124 prepareRunner = case (uri ^? uriScheme . _Just . unRText) of

132 prepareRunner = case (uri ^? uriScheme . _Just . unRText) of

125− Just "https" -> do

133+ Just "https" -> do

126 -- Generate a private key and self-signed certificate for TLS

134 -- Generate a private key and self-signed certificate for TLS

127 privateKey <- RSA.generateRSAKey' 2048 3

135 privateKey <- RSA.generateRSAKey' 2048 3

128

136

129 certRequest <- X509Request.newX509Req

137 certRequest <- X509Request.newX509Req

130 _ <- X509Request.setPublicKey certRequest privateKey

138 _ <- X509Request.setPublicKey certRequest privateKey

131− _ <- X509Request.signX509Req certRequest privateKey Nothing

139+ _ <- X509Request.signX509Req certRequest privateKey Nothing

132

140

133 cert <- X509.newX509 >>= X509Request.makeX509FromReq certRequest

141 cert <- X509.newX509 >>= X509Request.makeX509FromReq certRequest

134 _ <- X509.setPublicKey cert privateKey

142 _ <- X509.setPublicKey cert privateKey

135 now <- getCurrentTime

143 now <- getCurrentTime

136 _ <- X509.setNotBefore cert $ addUTCTime (-1) now

144 _ <- X509.setNotBefore cert $ addUTCTime (-1) now

137 _ <- X509.setNotAfter cert $ addUTCTime (365 * 24 * 60 * 60) now

145 _ <- X509.setNotAfter cert $ addUTCTime (365 * 24 * 60 * 60) now

138− _ <- X509.signX509 cert privateKey Nothing

146+ _ <- X509.signX509 cert privateKey Nothing

139

147

140 certByteString <- BSUTF8.fromString <$> PEM.writeX509 cert

148 certByteString <- BSUTF8.fromString <$> PEM.writeX509 cert

141 privateKeyByteString <- BSUTF8.fromString <$> PEM.writePKCS8PrivateKey privateKey Nothing

149 privateKeyByteString <- BSUTF8.fromString <$> PEM.writePKCS8PrivateKey privateKey Nothing

@@ -212,17 +220,22 @@ logPortBindErr p e = getProcessIdForPort p >>= \case

212 Nothing -> putStrLn $ "runWidget: " <> show e

220 Nothing -> putStrLn $ "runWidget: " <> show e

213 Just pid -> putStrLn $ unwords [ "Port", show p, "is being used by process ID", show pid <> ".", "Please kill that process or change the port in config/common/route."]

221 Just pid -> putStrLn $ unwords [ "Port", show p, "is being used by process ID", show pid <> ".", "Please kill that process or change the port in config/common/route."]

214

222

223+ssPath :: Maybe String

224+ssPath =

225+#if defined(IPROUTE_SUPPORTED)

226+ Just $(System.Which.staticWhich "ss")

227+#else

228+ Nothing

229+#endif

230+

215getProcessIdForPort :: Int -> IO (Maybe Int)

231getProcessIdForPort :: Int -> IO (Maybe Int)

216−getProcessIdForPort port = do

232+getProcessIdForPort port = case ssPath of

217− -- First check if 'ss' is available

233+ Just ss -> do

218− (c, _, _) <- readProcessWithExitCode "which" ["ss"] mempty

219− case c of

220− ExitSuccess -> do

221− xs <- lines <$> readProcess "ss" ["-lptn", "sport = " <> show port] mempty

234+ xs <- lines <$> readProcess ss ["-lptn", "sport = " <> show port] mempty

222− case uncons xs of

235+ case uncons xs of

223− Just (_, x:_) -> return $ A.maybeResult $ A.parse parseSsPid $ BSC.pack x

236+ Just (_, x:_) -> return $ A.maybeResult $ A.parse parseSsPid $ BSC.pack x

224− _ -> return Nothing

237+ _ -> return Nothing

225− _ -> return Nothing

238+ _ -> return Nothing

226

239

227parseSsPid :: A.Parser Int

240parseSsPid :: A.Parser Int

228parseSsPid = do

241parseSsPid = do

lib/selftest/src/Obelisk/SelfTest.hs+19−17

@@ -3,7 +3,6 @@

3{-# LANGUAGE OverloadedStrings #-}

4{-# LANGUAGE PatternGuards #-}

5{-# LANGUAGE ScopedTypeVariables #-}

6−{-# LANGUAGE TypeApplications #-}

7module Obelisk.SelfTest where

6module Obelisk.SelfTest where

9import Control.Exception (bracket, throw)

8import Control.Exception (bracket, throw)

@@ -71,7 +70,7 @@ shellyOb f obTest = shelly $ f obTest

71main :: IO ()

70main :: IO ()

72main = do

71main = do

73 -- Note: you can pass hspec arguments as well, eg: `-m <pattern>`

72 -- Note: you can pass hspec arguments as well, eg: `-m <pattern>`

74− isVerbose <- (elem "-v") <$> getArgs

73+ isVerbose <- elem "-v" <$> getArgs

75 unless isVerbose $

74 unless isVerbose $

76 putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output"

75 putStrLn "Tests may take longer to run if there are unbuilt derivations: use -v for verbose output"

77 let verbosity = bool silently verbosely isVerbose

76 let verbosity = bool silently verbosely isVerbose

@@ -118,7 +117,7 @@ main = do

118 it "works with master branch impl" $ inTmp $ \_ -> run "ob" ["init", "--branch", "master"]

117 it "works with master branch impl" $ inTmp $ \_ -> run "ob" ["init", "--branch", "master"]

119 it "works with symlink" $ inTmp $ \_ -> run "ob" ["init", "--symlink", obeliskImpl]

118 it "works with symlink" $ inTmp $ \_ -> run "ob" ["init", "--symlink", obeliskImpl]

120 it "doesn't silently overwrite existing files" $ withSystemTempDirectory "ob-init" $ \dir -> do

119 it "doesn't silently overwrite existing files" $ withSystemTempDirectory "ob-init" $ \dir -> do

121− let p force = (proc "ob" $ "--no-handoff" : "init" : if force then ["--force"] else []) { cwd = Just dir }

120+ let p force = (proc "ob" $ "--no-handoff" : "init" : ["--force"|force]) { cwd = Just dir }

122 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p False) ""

121 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p False) ""

123 (ExitFailure _, _, _) <- readCreateProcessWithExitCode (p False) ""

122 (ExitFailure _, _, _) <- readCreateProcessWithExitCode (p False) ""

124 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p True) ""

123 (ExitSuccess, _, _) <- readCreateProcessWithExitCode (p True) ""

@@ -128,7 +127,7 @@ main = do

128 void $ errExit False $ run "ob" ["init", "--symlink", "/dev/null"]

127 void $ errExit False $ run "ob" ["init", "--symlink", "/dev/null"]

129 ls tmp >>= liftIO . assertEqual "" []

128 ls tmp >>= liftIO . assertEqual "" []

130

129

131− it "produces a valid route config" $ inTmpObInit $ \tmp -> liftIO $ do

130+ it "produces a valid route config" $ inTmpObInit $ \tmp -> liftIO $

132 withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ do

131 withCurrentDirectory (T.unpack $ toTextIgnore tmp) $ do

133 configs <- getConfigs

132 configs <- getConfigs

134 return (either (const Nothing) Just $ getConfigRoute configs) `shouldNotReturn` Nothing

133 return (either (const Nothing) Just $ getConfigRoute configs) `shouldNotReturn` Nothing

@@ -136,10 +135,8 @@ main = do

136 -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"

135 -- These tests fail with "Could not find module 'Obelisk.Generated.Static'"

137 -- when not run by 'nix-build --attr selftest'

136 -- when not run by 'nix-build --attr selftest'

138 describe "ob run" $ parallel $ do

137 describe "ob run" $ parallel $ do

139− it "works in root directory" $ inTmpObInit $ \_ -> do

140− testObRunInDir p0 p1 Nothing httpManager

138+ it "works in root directory" $ inTmpObInit $ \_ -> testObRunInDir p0 p1 Nothing httpManager

141− it "works in sub directory" $ inTmpObInit $ \_ -> do

142− testObRunInDir p2 p3 (Just "frontend") httpManager

139+ it "works in sub directory" $ inTmpObInit $ \_ -> testObRunInDir p2 p3 (Just "frontend") httpManager

143

140

144 describe "obelisk project" $ parallel $ do

141 describe "obelisk project" $ parallel $ do

145 it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , obeliskImpl]

142 it "can build obelisk command" $ inTmpObInit $ \_ -> nixBuild ["-A", "command" , obeliskImpl]

@@ -149,14 +146,19 @@ main = do

149

146

150 describe "blank initialized project" $ parallel $ do

147 describe "blank initialized project" $ parallel $ do

151

148

152− it "can build ghc.backend" $ inTmpObInit $ \_ -> do

149+ it "can build ghc.backend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghc.backend"]

153− nixBuild ["-A", "ghc.backend"]

154− it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> do

150+ it "can build ghcjs.frontend" $ inTmpObInit $ \_ -> nixBuild ["-A", "ghcjs.frontend"]

155− nixBuild ["-A", "ghcjs.frontend"]

156

151

157 if os == "darwin"

152 if os == "darwin"

158− then it "can build ios" $ inTmpObInit $ \_ -> nixBuild ["-A", "ios.frontend"]

153+ then it "can build ios" $ inTmpObInit $ \_ -> nixBuild ["-A", "ios.frontend"]

154+ else it "can build android after accepting license" $ inTmpObInit $ \dir -> do

155+ let defaultNixPath = dir </> ("default.nix" :: Shelly.FilePath)

156+ writefile defaultNixPath

157+ =<< T.replace

158+ "# config.android_sdk.accept_license = false;"

159+ "config.android_sdk.accept_license = true;"

160+ <$> readfile defaultNixPath

159− else it "can build android" $ inTmpObInit $ \_ -> nixBuild ["-A", "android.frontend"]

161+ nixBuild ["-A", "android.frontend"]

160

162

161 forM_ ["ghc", "ghcjs"] $ \compiler -> do

163 forM_ ["ghc", "ghcjs"] $ \compiler -> do

162 let

164 let

@@ -191,7 +193,7 @@ main = do

191 branch' <- chdir dir $ run "git" ["rev-parse", "--abbrev-ref", "HEAD"]

193 branch' <- chdir dir $ run "git" ["rev-parse", "--abbrev-ref", "HEAD"]

192 liftIO $ assertEqual "" branch (T.strip branch')

194 liftIO $ assertEqual "" branch (T.strip branch')

193

195

194− it "can pack and unpack plain git repos" $ do

196+ it "can pack and unpack plain git repos" $

195 shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do

197 shelly_ $ withSystemTempDirectory "git-repo" $ \dir -> do

196 let repo = toTextIgnore $ dir </> ("repo" :: String)

198 let repo = toTextIgnore $ dir </> ("repo" :: String)

197 run_ "git" ["clone", "https://github.com/haskell/process.git", repo]

199 run_ "git" ["clone", "https://github.com/haskell/process.git", repo]

@@ -210,7 +212,7 @@ main = do

210 testThunkPack $ fromText repo

212 testThunkPack $ fromText repo

211

213

212 it "aborts thunk pack when there are uncommitted files" $ inTmpObInit $ \dir -> do

214 it "aborts thunk pack when there are uncommitted files" $ inTmpObInit $ \dir -> do

213− void $ unpack

215+ void unpack

214 testThunkPack (dir </> thunk)

216 testThunkPack (dir </> thunk)

215

217

216 describe "ob thunk update --branch" $ parallel $ do

218 describe "ob thunk update --branch" $ parallel $ do

@@ -289,7 +291,7 @@ alterRouteTo uri stdout = do

289

291

290-- | Handle stdout of `ob run`: check that the frontend and backend servers are started correctly

292-- | Handle stdout of `ob run`: check that the frontend and backend servers are started correctly

291handleObRunStdout :: HTTP.Manager -> Handle -> Sh Text

293handleObRunStdout :: HTTP.Manager -> Handle -> Sh Text

292−handleObRunStdout httpManager stdout = flip fix (ObRunState_Init, []) $ \loop (state, msgs) -> do

294+handleObRunStdout httpManager stdout = flip fix (ObRunState_Init, []) $ \loop (state, msgs) ->

293 liftIO (T.hGetLine stdout) >>= \t -> case state of

295 liftIO (T.hGetLine stdout) >>= \t -> case state of

294 ObRunState_Init

296 ObRunState_Init

295 | "Running test..." `T.isPrefixOf` t -> loop (ObRunState_BackendStarted, msgs)

297 | "Running test..." `T.isPrefixOf` t -> loop (ObRunState_BackendStarted, msgs)