4bfbce3 · obelisk · git.iko.soy

git.iko.soy/obelisk

Merge remote-tracking branch 'origin/master' into aa-deploy-mkserver

* origin/master: (41 commits) ob run: display error when backend throws obelisk-run-frontend: fix build ob run: Handle port in use Update gitignore ob deploy push: Ensure configuration directory is clean before proceeding ob deploy init: Initialize a git repo Update gitignore Add utils for git Support packed thunk ob deploy init: Initialize a deployment configuration directory Revert "ob init: Initialize a git repo" ob init: Initialize a git repo ob init: Create config dirs Show backend and frontend ports in ob run output Disable hoogle Support user overrides of haskell packages Fix ob init for nix 2.0 Fix warnings Move run to it's own module Switch from cloud haskell to StaticPointers extension ...

commit4bfbce32600f5b4e2b472654c63688cff846c288 authorAli Abrar <aliabrar@gmail.com> dateWed 9 May 2018, 15:29 (8 years ago) parent374f328 8b8cd91

22 files changed+565−91

compare with master

unifiedsplit

.gitignore+4

@@ -2,8 +2,12 @@

22**/.cabal-sandbox

33**/cabal.sandbox.config

44result

5+*.o

6+*.hi

68TAGS

79tags

810ctags

911dist-newstyle

12+cabal.project.local

13+.ghc.environment.*

default.nix+30−14

@@ -55,16 +55,24 @@ let #TODO: Upstream

5555

5656 fixUpstreamPkgs = self: super: {

5757 heist = doJailbreak super.heist; #TODO: Move up to reflex-platform; create tests for r-p supported packages

58+ network-transport = self.callHackage "network-transport" "0.5.2" {};

59+ network-transport-tcp = self.callHackage "network-transport-tcp" "0.6.0" {};

5860 };

5961

62+ cleanSource = builtins.filterSource (name: _: let baseName = builtins.baseNameOf name; in !(

63+ builtins.match "^\\.ghc\\.environment.*" baseName != null ||

64+ baseName == "cabal.project.local"

65+ ));

66+

6067 addLibs = self: super: {

6168 obelisk-asset-manifest = self.callCabal2nix "obelisk-asset-manifest" (hackGet ./lib/asset + "/manifest") {};

6269 obelisk-asset-serve-snap = self.callCabal2nix "obelisk-asset-serve-snap" (hackGet ./lib/asset + "/serve-snap") {};

63− obelisk-backend = self.callCabal2nix "obelisk-backend" ./lib/backend {};

64− obelisk-command = self.callCabal2nix "obelisk-command" ./lib/command {};

65− obelisk-selftest = self.callCabal2nix "obelisk-selftest" ./lib/selftest {};

66− obelisk-snap = self.callCabal2nix "obelisk-snap" ./lib/snap {};

67− obelisk-snap-extras = self.callCabal2nix "obelisk-snap-extras" ./lib/snap-extras {};

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

71+ obelisk-command = (self.callCabal2nix "obelisk-command" (cleanSource ./lib/command) {}).override { Cabal = super.Cabal_2_0_0_2; };

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

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

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

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

6876 };

6977

7078 defaultHaskellOverrides = composeExtensions fixUpstreamPkgs addLibs;

@@ -72,6 +80,8 @@ in

7280with pkgs.lib;

7381rec {

7482 inherit reflex-platform;

83+ inherit (reflex-platform) nixpkgs;

84+ path = reflex-platform.filterGit ./.;

7585 command = ghcObelisk.obelisk-command;

7686 selftest = pkgs.writeScript "selftest" ''

7787 #!/usr/bin/env bash

@@ -150,21 +160,24 @@ rec {

150160 ec2.hvm = true;

151161 };

152162 };

163+

164+

153165 # An Obelisk project is a reflex-platform project with a predefined layout and role for each component

154166 project = base: projectDefinition:

155167 let assets = processAssets { src = base + "/static"; };

156168 configPath = base + "/config";

157− p = reflex-platform.project (args@{ nixpkgs, ... }:

169+ projectOut = reflex-platform.project (args@{ nixpkgs, ... }:

158170 let mkProject = { android ? null #TODO: Better error when missing

159171 , ios ? null #TODO: Better error when missing

160172 , packages ? {}

173+ , overrides ? _: _: {}

161174 }:

162175 let frontendName = "frontend";

163176 backendName = "backend";

164177 commonName = "common";

165178 staticName = "static";

166179 staticPath = base + "/static";

167−

180+ assets = processAssets { src = base + "/static"; };

168181 # The packages whose names and roles are defined by this package

169182 predefinedPackages = filterAttrs (_: x: x != null) {

170183 ${frontendName} = nullIfAbsent (base + "/frontend");

@@ -175,21 +188,23 @@ rec {

175188 projectOverrides = self: super: {

176189 ${staticName} = dontHaddock (self.callCabal2nix "static" assets.haskellManifest {});

177190 };

178− overrides = composeExtensions defaultHaskellOverrides projectOverrides;

191+ totalOverrides = composeExtensions (composeExtensions defaultHaskellOverrides projectOverrides) overrides;

192+ ghcDevPackages = ["obelisk-run-frontend"];

179193 in {

180− inherit overrides;

194+ overrides = totalOverrides;

181195 packages = combinedPackages;

182196 shells = {

183− ghc = filter (x: hasAttr x combinedPackages) [

197+ ghc = (filter (x: hasAttr x combinedPackages) [

184198 backendName

185199 commonName

186200 frontendName

187− ];

201+ ]);

188202 ghcjs = filter (x: hasAttr x combinedPackages) [

189203 frontendName

190204 commonName

191205 ];

192206 };

207+ withHoogle = false; # Setting this to `true` makes shell reloading far slower

193208 android = {

194209 ${if android == null then null else frontendName} = {

195210 executableName = "frontend";

@@ -202,11 +217,12 @@ rec {

202217 ${if builtins.pathExists staticPath then "staticSrc" else null} = assets.symlinked;

203218 } // ios;

204219 };

205−

206220 };

207221 in mkProject (projectDefinition args));

208− in p // { server = { hostName }: server (serverExe p.all assets.symlinked configPath) hostName;

209− };

222+ in projectOut //

223+ { server = { hostName }:

224+ server (serverExe projectOut.all assets.symlinked configPath) hostName;

225+ };

210226 haskellPackageSets = {

211227 ghc = reflex-platform.ghc.override {

212228 overrides = defaultHaskellOverrides;

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

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

22 "owner": "reflex-frp",

33 "repo": "reflex-platform",

44 "branch": "sensible-logging",

5− "rev": "f53eebfcc31c261f889c54e5866fd8bb0b613a15",

6− "sha256": "0zzzb3m68gqb129cirgxnncd0jilgi97qqw92bfvlx8is50b8an1"

5+ "rev": "df3c35e1f36e08486046b6d7a9ac997cdf7f332c",

6+ "sha256": "1wfl4xccxyfy9szvsn6p7g4868h9cc44c3z24vw3bgqxffsgdn53"

77}

lib/command/obelisk-command.cabal+10−2

@@ -7,8 +7,11 @@ library

77 hs-source-dirs: src

88 build-depends:

99 aeson

10+ , Cabal

1011 , aeson-pretty

1112 , base

13+ , base16-bytestring

14+ , binary

1215 , bytestring

1316 , containers

1417 , data-default

@@ -17,8 +20,10 @@ library

1720 , github

1821 , hit

1922 , mtl

23+ , network

2024 , network-uri

2125 , optparse-applicative

26+ , placeholders

2227 , process

2328 , temporary

2429 , text

@@ -26,14 +31,17 @@ library

2631 , transformers

2732 , unix

2833 , yaml

29− , placeholders

3034 exposed-modules:

3135 Obelisk.Command

36+ Obelisk.Command.Deploy

3237 Obelisk.Command.Nix

3338 Obelisk.Command.Project

3439 Obelisk.Command.Repl

40+ Obelisk.Command.Run

3541 Obelisk.Command.Thunk

36− ghc-options: -Wall

42+ Obelisk.Command.Utils

43+ -- -fobject-code is so that the StaticPointers extension can work in ghci

44+ ghc-options: -Wall -fobject-code

3745

3846executable ob

3947 main-is: src-bin/ob.hs

lib/command/src/Obelisk/Command.hs+104−9

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

11{-# LANGUAGE LambdaCase #-}

22{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE StaticPointers #-}

4+{-# LANGUAGE TemplateHaskell #-}

5+{-# LANGUAGE TypeApplications #-}

36module Obelisk.Command where

8+import System.Process ()

59import Control.Monad

10+import qualified Data.Binary as Binary

11+import qualified Data.ByteString.Base16 as Base16

12+import qualified Data.ByteString.Lazy as LBS

613import Data.List

714import Data.Monoid

15+import qualified Data.Text as T

16+import Data.Text.Encoding

17+import GHC.StaticPtr

818import Options.Applicative

919import System.Environment

1020import System.FilePath

@@ -12,8 +22,11 @@ import System.IO

1222import System.Posix.Process

1323

1424import Obelisk.Command.Project

25+import Obelisk.Command.Deploy

1526import Obelisk.Command.Thunk

1627import Obelisk.Command.Repl

28+import Obelisk.Command.Run

29+import Obelisk.Command.Utils

1730

1831data Args = Args

1932 { _args_noHandOffPassed :: Bool

@@ -48,18 +61,69 @@ initSource = foldl1 (<|>)

4861

4962data ObCommand

5063 = ObCommand_Init InitSource

51− | ObCommand_Dev

64+ | ObCommand_Deploy DeployCommand

65+ | ObCommand_Run

5266 | ObCommand_Thunk ThunkCommand

5367 | ObCommand_Repl FilePath

5468 | ObCommand_Watch FilePath

69+ | ObCommand_Internal ObInternal

70+

71+data ObInternal

72+ = ObInternal_RunStaticIO StaticKey

73+

74+inNixShell' :: StaticPtr (IO ()) -> IO ()

75+inNixShell' p = withProjectRoot "." $ \root -> do

76+ progName <- getExecutablePath

77+ projectShell root False "ghc" $ unwords --TODO: shell escape

78+ [ progName

79+ , "internal"

80+ , "run-static-io"

81+ , encodeStaticKey $ staticKey p

82+ ]

5583

5684obCommand :: Parser ObCommand

57−obCommand = hsubparser $ mconcat

58− [ command "init" $ info (ObCommand_Init <$> initSource) $ progDesc "Initialize an Obelisk project"

59− , command "dev" $ info (pure ObCommand_Dev) $ progDesc "Run current project in development mode"

60− , command "thunk" $ info (ObCommand_Thunk <$> thunkCommand) $ progDesc "Manipulate thunk directories"

61− , command "repl" $ info (ObCommand_Repl <$> (strArgument (action "directory"))) $ progDesc "Open an interactive interpreter"

62− , command "watch" $ info (ObCommand_Watch <$> (strArgument (action "directory")))$ progDesc "Watch directory for changes and update interactive interpreter"

85+obCommand = hsubparser

86+ (mconcat

87+ [ command "init" $ info (ObCommand_Init <$> initSource) $ progDesc "Initialize an Obelisk project"

88+ , command "deploy" $ info (ObCommand_Deploy <$> deployCommand) $ progDesc "Prepare a deployment for an Obelisk project"

89+ , command "run" $ info (pure ObCommand_Run) $ progDesc "Run current project in development mode"

90+ , command "thunk" $ info (ObCommand_Thunk <$> thunkCommand) $ progDesc "Manipulate thunk directories"

91+ , command "repl" $ info (ObCommand_Repl <$> (strArgument (action "directory"))) $ progDesc "Open an interactive interpreter"

92+ , command "watch" $ info (ObCommand_Watch <$> (strArgument (action "directory")))$ progDesc "Watch directory for changes and update interactive interpreter"

93+ ])

94+ <|> subparser

95+ (mconcat

96+ [ internal

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

98+ ])

99+

100+deployCommand :: Parser DeployCommand

101+deployCommand = hsubparser $ mconcat

102+ [ command "init" $ info deployInitCommand $ progDesc "Initialize a deployment configuration directory"

103+ , command "push" $ info (pure DeployCommand_Push) mempty

104+ ]

105+

106+deployInitCommand :: Parser DeployCommand

107+deployInitCommand = fmap DeployCommand_Init $ DeployInitOpts

108+ <$> strArgument (action "deploy-dir" <> metavar "DEPLOYDIR" <> help "Path to a directory that it will create")

109+ <*> strOption (long "ssh-key" <> metavar "SSHKEY" <> help "Path to an ssh key that it will symlink to")

110+ <*> some (strOption (long "hostname" <> metavar "HOSTNAME" <> help "hostname of the deployment target"))

111+ <*> strOption (long "remote" <> metavar "REMOTE" <> help "git remote to use for the src thunk")

112+

113+data DeployCommand

114+ = DeployCommand_Init DeployInitOpts

115+ | DeployCommand_Push

116+

117+data DeployInitOpts = DeployInitOpts

118+ { _deployInitOpts_ouputDir :: FilePath

119+ , _deployInitOpts_sshKey :: FilePath

120+ , _deployInitOpts_hostname :: [String]

121+ , _deployInitOpts_remote :: String

122+ }

123+

124+internalCommand :: Parser ObInternal

125+internalCommand = subparser $ mconcat

126+ [ command "run-static-io" $ info (ObInternal_RunStaticIO <$> argument (eitherReader decodeStaticKey) (action "static-key")) mempty

63127 ]

64128

65129--TODO: Result should provide normalised path and also original user input for error reporting.

@@ -131,12 +195,43 @@ main = do

131195ob :: ObCommand -> IO ()

132196ob = \case

133197 ObCommand_Init source -> initProject source

134− ObCommand_Dev -> putStrLn "Dev!"

198+ ObCommand_Deploy dc -> case dc of

199+ DeployCommand_Init deployOpts -> withProjectRoot "." $ \root -> do

200+ thunkPtr <- readThunk root >>= \case

201+ Left err -> fail $ "thunk pack: " <> show err

202+ Right (ThunkData_Packed ptr) -> return ptr

203+ Right (ThunkData_Checkout (Just ptr)) -> return ptr

204+ Right (ThunkData_Checkout Nothing) ->

205+ getThunkPtr root (_deployInitOpts_remote deployOpts)

206+ let deployDir = _deployInitOpts_ouputDir deployOpts

207+ sshKeyPath = _deployInitOpts_sshKey deployOpts

208+ hostname = _deployInitOpts_hostname deployOpts

209+ deployInit thunkPtr (root </> "config") deployDir sshKeyPath hostname

210+ DeployCommand_Push -> do

211+ checkGitCleanStatus "." >>= \case

212+ True -> return ()

213+ False -> fail "ob push: Commit any changes to the deployment configuration before proceeding"

214+ ObCommand_Run -> inNixShell' $ static run

215+ -- inNixShell ($(mkClosure 'ghcidAction) ())

135216 ObCommand_Thunk tc -> case tc of

136217 ThunkCommand_Update thunks -> mapM_ updateThunkToLatest thunks

137218 ThunkCommand_Unpack thunks -> mapM_ unpackThunk thunks

138219 ThunkCommand_Pack thunks -> forM_ thunks $ \(ThunkPackOpts dir upstream) -> packThunk dir upstream

139220 ObCommand_Repl component -> runRepl component

140221 ObCommand_Watch component -> watch component

141−

222+ ObCommand_Internal icmd -> case icmd of

223+ ObInternal_RunStaticIO k -> unsafeLookupStaticPtr @(IO ()) k >>= \case

224+ Nothing -> fail $ "ObInternal_RunStaticIO: no such StaticKey: " <> show k

225+ Just p -> deRefStaticPtr p

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

227+

228+encodeStaticKey :: StaticKey -> String

229+encodeStaticKey = T.unpack . decodeUtf8 . Base16.encode . LBS.toStrict . Binary.encode

230+

231+decodeStaticKey :: String -> Either String StaticKey

232+decodeStaticKey s = case Base16.decode $ encodeUtf8 $ T.pack s of

233+ (b, "") -> case Binary.decodeOrFail $ LBS.fromStrict b of

234+ Right ("", _, a) -> pure a

235+ Right _ -> fail $ "decodeStaticKey: Binary.decodeOrFail didn't consume all input"

236+ Left (_, _, e) -> fail $ "decodeStaticKey: Binary.decodeOrFail failed: " <> show e

237+ _ -> fail $ "decodeStaticKey: could not decode hex string: " <> show s

lib/command/src/Obelisk/Command/Deploy.hsnew file+31

@@ -0,0 +1,31 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Obelisk.Command.Deploy where

4+import Control.Monad

5+import System.Directory

6+import System.FilePath

7+import System.Posix.Files

8+import System.Process

10+import Obelisk.Command.Utils

11+import Obelisk.Command.Thunk

12+

13+deployInit :: ThunkPtr -> FilePath -> FilePath -> FilePath -> [String] -> IO ()

14+deployInit thunkPtr configDir deployDir sshKeyPath hostnames = do

15+ createDirectoryIfMissing True deployDir

16+ hasConfigDir <- doesDirectoryExist configDir

17+ when hasConfigDir $ do

18+ callProcess "cp"

19+ [ "-r"

20+ , "-T"

21+ , configDir

22+ , deployDir </> "config"

23+ ]

24+ keyExists <- doesFileExist sshKeyPath

25+ when keyExists $ do

26+ target <- makeAbsolute sshKeyPath

27+ createSymbolicLink target (deployDir </> "ssh_key")

28+ createThunk (deployDir </> "src") thunkPtr

29+ writeFile (deployDir </> "backend_hosts") $ unlines hostnames

30+ initGit deployDir

31+

lib/command/src/Obelisk/Command/Nix.hs+6−2

@@ -52,12 +52,16 @@ nixBuild cfg = do

5252 , case _nixBuildConfig_outLink cfg of

5353 OutLink_Default -> []

5454 OutLink_None -> ["--no-out-link"]

55− OutLink_IndirectRoot outLink -> ["--indirect", "--add-root", outLink]

55+ OutLink_IndirectRoot outLink -> ["--out-link", outLink]

5656 ]

57− (_, out, err, p) <- runInteractiveProcess "nix-build" args Nothing Nothing

57+ (_, Just out, Just err, p) <- createProcess (proc "nix-build" args)

58+ { std_out = CreatePipe

59+ , std_err = CreatePipe

60+ }

5861 waitForProcess p >>= \case

5962 ExitSuccess -> return ()

6063 _ -> do

64+ -- FIXME: We should interleave `out` and `err` in their original order?

6165 LBS.putStr =<< LBS.hGetContents out

6266 LBS.putStr =<< LBS.hGetContents err

6367 fail "nix-build failed"

lib/command/src/Obelisk/Command/Project.hs+32−18

@@ -5,7 +5,10 @@ module Obelisk.Command.Project

55 , initProject

66 , findProjectObeliskCommand

77 , findProjectRoot

8+ , withProjectRoot

89 , inProjectShell

10+ , inImpureProjectShell

11+ , projectShell

912 ) where

1013

1114import Control.Monad

@@ -17,15 +20,14 @@ import Data.Monoid

1720import qualified Data.Text as T

1821import qualified Data.Text.IO as T

1922import System.Directory

20−import System.Exit

2123import System.FilePath

2224import System.IO

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

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

2426import System.Posix.Files

2527import System.Process

2628

27−import GitHub.Data.Name (Name)

2829import GitHub.Data.GitData (Branch)

30+import GitHub.Data.Name (Name)

2931

3032import Obelisk.Command.Thunk

3133

@@ -67,15 +69,16 @@ initProject source = do

6769 _ <- nixBuildAttrWithCache implDir "command"

6870 --TODO: We should probably handoff to the impl here

6971 skeleton <- nixBuildAttrWithCache implDir "skeleton" --TODO: I don't think there's actually any reason to cache this

70− (_, _, _, p) <- runInteractiveProcess "cp" --TODO: Make this package depend on nix-prefetch-url properly

72+ callProcess "cp" --TODO: Make this package depend on nix-prefetch-url properly

7173 [ "-r"

7274 , "--no-preserve=mode"

7375 , "-T"

7476 , skeleton </> "."

7577 , "."

76− ] Nothing Nothing

77− ExitSuccess <- waitForProcess p

78− return ()

78+ ]

79+ let configDir = "config"

80+ createDirectory configDir

81+ mapM_ (createDirectory . (configDir </>)) ["backend", "common", "frontend"]

7982

8083--TODO: Handle errors

8184--TODO: Allow the user to ignore our security concerns

@@ -111,6 +114,11 @@ findProjectRoot target = do

111114 (result, _) <- runStateT (walkToProjectRoot target targetStat myUid) []

112115 return result

113116

117+withProjectRoot :: FilePath -> (FilePath -> IO ()) -> IO ()

118+withProjectRoot target f = findProjectRoot target >>= \case

119+ Nothing -> fail "Must be used inside of an Obelisk project"

120+ Just root -> f root

121+

114122-- | Walk from the current directory to the containing project's root directory,

115123-- if there is one, accumulating potentially insecure directories that were

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

@@ -154,17 +162,23 @@ isWritableOnlyBy s uid = fileOwner s == uid && fileMode s .&. 0o22 == 0

154162

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

156164inProjectShell :: String -> String -> IO ()

157−inProjectShell shellName command = do

158− findProjectRoot "." >>= \case

159− Nothing -> putStrLn "Must be used inside of an Obelisk project"

160− Just root -> do

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

162− [ "-A"

163− , "shells." <> shellName

164− , "--run", command

165− ]

166− _ <- waitForProcess ph

167− return ()

165+inProjectShell shellName command = withProjectRoot "." $ \root ->

166+ projectShell root True shellName command

167+

168+inImpureProjectShell :: String -> String -> IO ()

169+inImpureProjectShell shellName command = withProjectRoot "." $ \root ->

170+ projectShell root False shellName command

171+

172+projectShell :: FilePath -> Bool -> String -> String -> IO ()

173+projectShell root isPure shellName command = do

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

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

176+ [ "-A"

177+ , "shells." <> shellName

178+ , "--run", command

179+ ]

180+ _ <- waitForProcess ph

181+ return ()

168182

169183setCwd :: Maybe FilePath -> CreateProcess -> CreateProcess

170184setCwd fp cp = cp { cwd = fp }

lib/command/src/Obelisk/Command/Repl.hs+3−2

@@ -10,8 +10,9 @@ import Obelisk.Command.Project

1010

1111-- | Run an interactive repl within a given path

1212runRepl :: FilePath -> IO ()

13−runRepl dir = inProjectShell "ghc" $ "cd " <> dir <> "; cabal new-repl " <> dir

13+runRepl dir = inProjectShell "ghc" $ "cd " <> dir <> "; cabal new-repl"

1414

1515-- | Watch the given directory for errors and warnings

1616watch :: FilePath -> IO ()

17−watch dir = inProjectShell "ghc" $ "cd " <> dir <> "; ghcid -W -c'cabal new-repl " <> dir <> "'"

17+watch dir = inProjectShell "ghc" $ "cd " <> dir <> "; ghcid -W --command='cabal new-repl'"

18+

lib/command/src/Obelisk/Command/Run.hsnew file+94

@@ -0,0 +1,94 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+module Obelisk.Command.Run where

4+import qualified Control.Exception as E

5+import Control.Monad

6+import Data.Either

7+import Data.List

8+import Data.Maybe

9+import Data.Monoid

10+import Data.List.NonEmpty as NE

11+import Distribution.Utils.Generic (withUTF8FileContents)

12+import Distribution.PackageDescription.Parse (parseGenericPackageDescription, ParseResult(..))

13+import Distribution.Types.BuildInfo

14+import Distribution.Types.CondTree

15+import Distribution.Types.Library

16+import Distribution.Types.GenericPackageDescription

17+import Network.Socket

18+import System.Directory

19+import System.FilePath

20+import System.IO.Temp (withSystemTempDirectory)

21+import System.Process (callCommand)

22+

23+run :: IO ()

24+run = do

25+ freePort <- getFreePort

26+ pkgs <- getLocalPkgs

27+ (pkgDirErrs, hsSrcDirs) <- fmap partitionEithers $ forM pkgs $ \pkg -> do

28+ let cabalFp = pkg </> pkg <.> "cabal"

29+ xs <- parseHsSrcDir cabalFp

30+ return $ case xs of

31+ Nothing -> Left pkg

32+ Just hsSrcDirs -> Right $ toList $ fmap (pkg </>) hsSrcDirs

33+ when (null hsSrcDirs) $

34+ fail $ "No valid pkgs found in " <> intercalate ", " pkgs

35+ when (not (null pkgDirErrs)) $

36+ putStrLn $ "Failed to find pkgs in " <> intercalate ", " pkgDirErrs

37+ let dotGhci = unlines

38+ [ ":set args --quiet --port " <> show freePort

39+ , ":set -i" <> intercalate ":" (mconcat hsSrcDirs)

40+ , ":set -XScopedTypeVariables"

41+ , ":add Backend Frontend"

42+ , ":module + System.IO Control.Exception Control.Concurrent Obelisk.Widget.Run Frontend Backend"

43+ ]

44+ testCmd = unlines

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

46+ , "backendTid <- forkIO $ handle handleBackendErr backend"

47+ , "let conf = defRunConfig { _runConfig_redirectPort = " <> show freePort <> "}"

48+ , "runWidget conf frontend"

49+ , "killThread backendTid"

50+ ]

51+ withSystemTempDirectory "ob-ghci" $ \fp -> do

52+ let dotGhciPath = fp </> ".ghci"

53+ writeFile dotGhciPath dotGhci

54+ runDev dotGhciPath $ Just testCmd

55+

56+-- | Relative paths to local packages of an obelisk project

57+-- TODO a way to query this

58+getLocalPkgs :: IO [FilePath]

59+getLocalPkgs = return ["backend", "common", "frontend"]

60+

61+parseHsSrcDir :: FilePath -- ^ package cabal file path

62+ -> IO (Maybe (NE.NonEmpty FilePath)) -- ^ List of hs src dirs of the library component

63+parseHsSrcDir cabalFp = do

64+ exists <- doesFileExist cabalFp

65+ if exists

66+ then do

67+ withUTF8FileContents cabalFp $ \cabal -> do

68+ case parseGenericPackageDescription cabal of

69+ ParseOk warnings gpkg -> do

70+ mapM_ print warnings

71+ return $ do

72+ (_, lib) <- simplifyCondTree (const $ pure True) <$> condLibrary gpkg

73+ pure $ fromMaybe (pure ".") $ NE.nonEmpty $ hsSourceDirs $ libBuildInfo lib

74+ ParseFailed _ -> return Nothing

75+ else return Nothing

76+

77+-- | Dev

78+runDev :: FilePath -> Maybe String -> IO ()

79+runDev dotGhci mcmd = callCommand $ unwords $ "ghcid" : ghcidOpts

80+ where

81+ ghcidOpts =

82+ [ "-W"

83+ , "--command='ghci -ghci-script " <> dotGhci <> "' "

84+ ] <> maybeToList (flip fmap mcmd $ \cmd -> " --test=$'" <> cmd <> "'")

85+

86+getFreePort :: IO PortNumber

87+getFreePort = withSocketsDo $ do

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

89+ E.bracket (open addr) close socketPort

90+ where

91+ open addr = do

92+ sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)

93+ bind sock (addrAddress addr)

94+ return sock

lib/command/src/Obelisk/Command/Thunk.hs+24−21

@@ -13,12 +13,14 @@ module Obelisk.Command.Thunk

1313 , GitHubSource (..)

1414 , getLatestRev

1515 , updateThunkToLatest

16+ , createThunk

1617 , createThunkWithLatest

1718 , nixBuildAttrWithCache

1819 , nixBuildThunkAttrWithCache

1920 , unpackThunk

2021 , packThunk

2122 , readThunk

23+ , getThunkPtr

2224 ) where

2325

2426import Control.Applicative

@@ -42,14 +44,14 @@ import Data.Set (Set)

4244import qualified Data.Set as Set

4345import Data.Text (Text)

4446import qualified Data.Text as T

45−import qualified Data.Text.IO as T

4647import Data.Text.Encoding

48+import qualified Data.Text.IO as T

4749import Data.Time.Clock.POSIX (posixSecondsToUTCTime)

4850import Data.Yaml (parseMaybe, (.:))

4951import qualified Data.Yaml as Yaml

5052import GitHub

51−import GitHub.Endpoints.Repos.Contents (archiveForR)

5253import GitHub.Data.Name

54+import GitHub.Endpoints.Repos.Contents (archiveForR)

5355import Network.URI

5456import Obelisk.Command.Nix

5557import System.Directory

@@ -58,10 +60,11 @@ import System.FilePath

5860import System.IO

5961import System.IO.Error

6062import System.IO.Temp

61−import System.Posix (modificationTime, getSymbolicLinkStatus)

63+import System.Posix (getSymbolicLinkStatus, modificationTime)

6264import System.Process

6365

6466import Development.Placeholders

67+import Obelisk.Command.Utils

6568

6669--TODO: Support symlinked thunk data

6770data ThunkData

@@ -116,12 +119,12 @@ commitNameToRef (N c) = Ref.fromHex $ encodeUtf8 c

116119

117120getNixSha256ForUriUnpacked :: URI -> IO NixSha256

118121getNixSha256ForUriUnpacked uri = do

119− (_, out, err, p) <- runInteractiveProcess "nix-prefetch-url" --TODO: Make this package depend on nix-prefetch-url properly

120− [ "--unpack"

121− , "--type"

122− , "sha256"

123− , show uri

124− ] Nothing Nothing

122+ --TODO: Make this package depend on nix-prefetch-url properly

123+ let cmd = proc "nix-prefetch-url" ["--unpack" , "--type" , "sha256" , show uri]

124+ (_, Just out, Just err, p) <- createProcess cmd

125+ { std_out = CreatePipe

126+ , std_err = CreatePipe

127+ }

125128 --TODO: Deal with errors here; usually they're HTTP errors

126129 waitForProcess p >>= \case

127130 ExitSuccess -> return ()

@@ -498,12 +501,17 @@ packThunk thunkDir upstream = readThunk thunkDir >>= \case

498501 Left err -> fail $ "thunk pack: " <> show err

499502 Right (ThunkData_Packed _) -> fail "pack: thunk is already packed"

500503 Right (ThunkData_Checkout _) -> do

501− --Check whether the working directory is clean

502− statusOutput <- readProcess "hub"

503− [ "-C", thunkDir

504− , "status", "--porcelain", "--ignored" ] ""

505− diffOutput <- readProcess "hub" [ "-C", thunkDir , "diff" ] ""

506− case null statusOutput && null diffOutput of

504+ thunkPtr <- getThunkPtr thunkDir upstream

505+ callProcess "rm"

506+ [ "-rf"

507+ , thunkDir

508+ ]

509+ createThunk thunkDir thunkPtr

510+ return ()

511+

512+getThunkPtr :: FilePath -> String -> IO ThunkPtr

513+getThunkPtr thunkDir upstream = do

514+ checkGitCleanStatus thunkDir >>= \case

507515 False -> do

508516 statusDebug <- readProcess "hub"

509517 [ "-C", thunkDir, "status", "--ignored" ] ""

@@ -578,12 +586,7 @@ packThunk thunkDir upstream = readThunk thunkDir >>= \case

578586 if

579587 | isGithubThunk remoteUri -> githubThunkPtr remoteUri currentHead currentUpstreamBranch

580588 | otherwise -> gitThunkPtr remoteUri currentHead currentUpstreamBranch

581− callProcess "rm"

582− [ "-rf"

583− , thunkDir

584− ]

585− createThunk thunkDir thunkPtr

586− return ()

589+ return thunkPtr

587590 where

588591 refsToTuples [x, y] = (x, y)

589592 refsToTuples x = error $ "thunk pack: cannot parse ref " <> show x

lib/command/src/Obelisk/Command/Utils.hsnew file+19

@@ -0,0 +1,19 @@

1+module Obelisk.Command.Utils where

3+import System.Process

5+-- Check whether the working directory is clean

6+checkGitCleanStatus :: FilePath -> IO Bool

7+checkGitCleanStatus fp = do

8+ statusOutput <- readProcess "hub"

9+ [ "-C", fp

10+ , "status", "--porcelain", "--ignored" ] ""

11+ diffOutput <- readProcess "hub" [ "-C", fp , "diff" ] ""

12+ return $ null statusOutput && null diffOutput

13+

14+initGit :: FilePath -> IO ()

15+initGit dir = do

16+ let git args = callProcess "git" $ "-C" : dir : args

17+ git ["init"]

18+ git ["add", "."]

19+ git ["commit", "-m", "Initial commit."]

lib/run-frontend/obelisk-run-frontend.cabalnew file+28

@@ -0,0 +1,28 @@

1+name: obelisk-run-frontend

2+version: 0.1

3+license: BSD3

4+build-type: Simple

5+cabal-version: >=1.2

7+library

8+ hs-source-dirs: src

9+ build-depends:

10+ attoparsec

11+ , base

12+ , bytestring

13+ , http-client

14+ , http-reverse-proxy

15+ , jsaddle

16+ , jsaddle-warp

17+ , network

18+ , network-uri

19+ , process

20+ , reflex-dom

21+ , streaming-commons

22+ , text

23+ , wai

24+ , warp

25+ , websockets

26+ exposed-modules:

27+ Obelisk.Widget.Run

28+ ghc-options: -Wall

lib/run-frontend/src/Obelisk/Widget/Run.hsnew file+96

@@ -0,0 +1,96 @@

1+{-# LANGUAGE LambdaCase #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE ScopedTypeVariables #-}

4+module Obelisk.Widget.Run where

6+import Control.Concurrent

7+import Control.Exception

8+import qualified Data.Attoparsec.ByteString.Char8 as A

9+import Data.ByteString (ByteString)

10+import qualified Data.ByteString.Char8 as BSC

11+import Data.List (uncons)

12+import Data.Semigroup ((<>))

13+import Data.Streaming.Network (bindPortTCP)

14+import Language.Javascript.JSaddle.WebSockets

15+import Language.Javascript.JSaddle.Run (syncPoint)

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

17+import qualified Network.HTTP.ReverseProxy as RP

18+import Network.Socket

19+import Network.URI

20+import Network.Wai (Application)

21+import Network.Wai.Handler.Warp

22+import Network.WebSockets.Connection (defaultConnectionOptions)

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

24+import System.Process

25+import Reflex.Dom.Core

26+

27+runWidget :: RunConfig -> Widget () () -> IO ()

28+runWidget conf w = do

29+ let redirectHost = _runConfig_redirectHost conf

30+ redirectPort = _runConfig_redirectPort conf

31+ beforeMainLoop = do

32+ putStrLn $ "Backend running on " <> showUrl (BSC.unpack redirectHost) redirectPort

33+ putStrLn $ "Frontend running on " <> showUrl "127.0.0.1" (_runConfig_port conf)

34+ settings = setBeforeMainLoop beforeMainLoop (setPort (_runConfig_port conf) (setTimeout 3600 defaultSettings))

35+ logErr p = putStrLn $ unwords [ "Port", show p, "is in use."]

36+ bracket

37+ (bindPortTCPRetry settings (logErr (_runConfig_port conf)) (_runConfig_retryTimeout conf))

38+ close

39+ (\skt -> do

40+ man <- newManager defaultManagerSettings

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

42+ runSettingsSocket settings skt app)

43+

44+-- | like 'bindPortTCP' but reconnects on exception

45+bindPortTCPRetry :: Settings

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

47+ -> Int

48+ -> IO Socket

49+bindPortTCPRetry settings m n = catch (bindPortTCP (settingsPort settings) (settingsHost settings)) $ \(_ :: IOError) -> do

50+ m

51+ threadDelay $ 1000000 * n

52+ bindPortTCPRetry settings (return ()) n

53+

54+-- TODO

55+logPortBindErr :: Int -> IO ()

56+logPortBindErr p = getProcessIdForPort p >>= \case

57+ Nothing -> return ()

58+ Just _ -> return ()

59+

60+getProcessIdForPort :: Int -> IO (Maybe Int)

61+getProcessIdForPort port = do

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

63+ case uncons xs of

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

65+ _ -> return Nothing

66+

67+parseSsPid :: A.Parser Int

68+parseSsPid = do

69+ _ <- A.count 5 $ A.takeWhile (not . A.isSpace) *> A.skipSpace

70+ _ <- A.skipWhile (/= ':') >> A.string ":((" >> A.skipWhile (/= ',')

71+ A.string ",pid=" *> A.decimal

72+

73+showUrl :: String -> Int -> String

74+showUrl host port = show nullURI

75+ { uriScheme = "http:"

76+ , uriAuthority = Just $ URIAuth "" host $ ":" ++ show port

77+ }

78+

79+fallbackProxy :: ByteString -> Int -> Manager -> Application

80+fallbackProxy host port = RP.waiProxyTo handleRequest RP.defaultOnExc

81+ where handleRequest _req = return $ RP.WPRProxyDest $ RP.ProxyDest host port

82+

83+data RunConfig = RunConfig

84+ { _runConfig_port :: Int

85+ , _runConfig_redirectHost :: ByteString

86+ , _runConfig_redirectPort :: Int

87+ , _runConfig_retryTimeout :: Int -- seconds

88+ }

89+

90+defRunConfig :: RunConfig

91+defRunConfig = RunConfig

92+ { _runConfig_port = 8000

93+ , _runConfig_redirectHost = "127.0.0.1"

94+ , _runConfig_redirectPort = 3001

95+ , _runConfig_retryTimeout = 1

96+ }

release.nixnew file+21

@@ -0,0 +1,21 @@

1+{ self ? import ./. {}

2+, pkgs ? self.nixpkgs

3+}:

5+with pkgs;

7+{

8+ tests = {

9+ #TODO: Doesn't work; see discussion in https://www.pivotaltracker.com/story/show/157265140

10+ ob-init = runCommand "ob-init" {

11+ nativeBuildInputs = [

12+ self.command

13+ nix

14+ ];

15+ } ''

16+ mkdir $out

17+ cd $out

18+ ob init --symlink=${self.path}

19+ '';

20+ };

21+}

skeleton/backend/backend.cabal+14−5

@@ -1,12 +1,21 @@

11name: backend

22version: 0.1

3−cabal-version: >= 1.2

3+cabal-version: >= 1.8

44build-type: Simple

6+library

7+ hs-source-dirs: src

8+ build-depends: base

9+ , common

10+ , obelisk-backend

11+ exposed-modules:

12+ Backend

13+ ghc-options: -Wall

14+

615executable backend

716 main-is: main.hs

817 hs-source-dirs: src

9− build-depends:

10− base,

11− common,

12− obelisk-backend

18+ build-depends: base

19+ , backend

20+ , common

21+ , obelisk-backend

skeleton/backend/src/Backend.hsnew file+7

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

1+module Backend where

3+import Common.Api

4+import qualified Obelisk.Backend as Ob

6+backend :: IO ()

7+backend = Ob.backend Ob.def

skeleton/backend/src/main.hs+3−3

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

1−import Obelisk.Backend

2−import Common.Api

1+import Backend

43main :: IO ()

5−main = backend def

4+main = backend

skeleton/common/src/Common/Api.hs+1−1

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

11module Common.Api where

33commonStuff :: String

4−commonStuff = undefined

4+commonStuff = "here is a comon string"

skeleton/frontend/frontend.cabal+16−5

@@ -1,14 +1,25 @@

11name: frontend

22version: 0.1

3−cabal-version: >= 1.2

3+cabal-version: >= 1.8

44build-type: Simple

6+library

7+ hs-source-dirs: src

8+ build-depends: base

9+ , reflex-dom

10+ , static

11+ , obelisk-run-frontend

12+ , text

13+ exposed-modules:

14+ Frontend

15+ ghc-options: -Wall

16+

617executable frontend

718 main-is: main.hs

819 hs-source-dirs: src

9− build-depends: base,

10− reflex-dom,

11− text,

12− static

20+ build-depends: base

21+ , reflex-dom

22+ , static

23+ , frontend

1324 --TODO: Make these ghc-options optional

1425 ghc-options: -threaded

skeleton/frontend/src/Frontend.hsnew file+18

@@ -0,0 +1,18 @@

1+{-# LANGUAGE OverloadedStrings #-}

2+{-# LANGUAGE TypeApplications #-}

3+{-# LANGUAGE DataKinds #-}

4+module Frontend where

6+import Reflex.Dom

8+import qualified Data.Text as T

10+import Static

11+import Common.Api

12+

13+frontend :: Widget x ()

14+frontend = do

15+ text "Welcome to Obelisk!"

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

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

18+

skeleton/frontend/src/main.hs+2−7

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

1−{-# LANGUAGE OverloadedStrings #-}

2−{-# LANGUAGE TypeApplications #-}

3−{-# LANGUAGE DataKinds #-}

41import Reflex.Dom

5−import Static

2+import Frontend

74main :: IO ()

8−main = mainWidget $ do

9− text "Welcome to Obelisk!"

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

5+main = mainWidget frontend