handle serve correctly
This commit is contained in:
parent
34570ee679
commit
d0da04fc15
5 changed files with 99 additions and 17 deletions
10
gpm.cabal
10
gpm.cabal
|
@ -2,7 +2,7 @@
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: 04bfdb9ffa855881f6cd6cc09bf3b494a2107ded6cc33c41699546a12526099e
|
-- hash: 5bfe1aa5fe45c81553fa282f889cbe95ef3bbfd9d254f8a67458609998b15f9a
|
||||||
|
|
||||||
name: gpm
|
name: gpm
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
|
@ -45,6 +45,10 @@ library
|
||||||
, protolude
|
, protolude
|
||||||
, text
|
, text
|
||||||
, turtle
|
, turtle
|
||||||
|
, unix
|
||||||
|
, wai
|
||||||
|
, wai-app-static
|
||||||
|
, warp
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
executable gpm
|
executable gpm
|
||||||
|
@ -66,4 +70,8 @@ executable gpm
|
||||||
, protolude
|
, protolude
|
||||||
, text
|
, text
|
||||||
, turtle
|
, turtle
|
||||||
|
, unix
|
||||||
|
, wai
|
||||||
|
, wai-app-static
|
||||||
|
, warp
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
|
@ -23,8 +23,8 @@ ghc-options:
|
||||||
- -Wredundant-constraints
|
- -Wredundant-constraints
|
||||||
- -Wnoncanonical-monad-instances
|
- -Wnoncanonical-monad-instances
|
||||||
dependencies:
|
dependencies:
|
||||||
- base >=4.8 && <5
|
|
||||||
- ansi-terminal
|
- ansi-terminal
|
||||||
|
- base >=4.8 && <5
|
||||||
- directory
|
- directory
|
||||||
- file-embed
|
- file-embed
|
||||||
- foldl
|
- foldl
|
||||||
|
@ -32,6 +32,10 @@ dependencies:
|
||||||
- protolude
|
- protolude
|
||||||
- text
|
- text
|
||||||
- turtle
|
- turtle
|
||||||
|
- unix
|
||||||
|
- wai
|
||||||
|
- wai-app-static
|
||||||
|
- warp
|
||||||
library:
|
library:
|
||||||
source-dirs: src
|
source-dirs: src
|
||||||
executables:
|
executables:
|
||||||
|
|
|
@ -1,18 +1,57 @@
|
||||||
#!/usr/bin/env zsh
|
#!/usr/bin/env zsh
|
||||||
|
|
||||||
[[ -d testproj ]] && rm -rf testproj
|
set -x
|
||||||
mkdir testproj
|
|
||||||
pushd testproj
|
title(){
|
||||||
|
set +x
|
||||||
|
echo
|
||||||
|
print -- "----------------------------------------"
|
||||||
|
print -- " $*"
|
||||||
|
print -- "----------------------------------------"
|
||||||
|
echo
|
||||||
|
set -x
|
||||||
|
}
|
||||||
|
|
||||||
|
prjname="testproj"
|
||||||
|
testproj="/tmp/$prjname"
|
||||||
|
testproj2="/tmp/testproj2"
|
||||||
|
mkdir -p $testproj
|
||||||
|
pushd $testproj
|
||||||
|
|
||||||
|
title "CLEANING UP"
|
||||||
|
[[ -d $testproj ]] && rm -rf $testproj
|
||||||
|
[[ -d $testproj2 ]] && rm -rf $testproj2
|
||||||
|
title "CREATE PROJECT $testproj"
|
||||||
|
mkdir $testproj
|
||||||
|
pushd $testproj
|
||||||
echo "README 1" > README
|
echo "README 1" > README
|
||||||
git init .
|
git init .
|
||||||
git add README
|
git add README
|
||||||
git commit -m "initial commit"
|
git commit -m "initial commit"
|
||||||
|
title "gpm init"
|
||||||
gpm init
|
gpm init
|
||||||
|
title "gpm new-issue"
|
||||||
gpm new-issue -t "issue-1" -p "A"
|
gpm new-issue -t "issue-1" -p "A"
|
||||||
|
title "HOOKS"
|
||||||
git co gpm
|
git co gpm
|
||||||
cp hooks/prepare-commit-msg{.sample,}
|
cp hooks/prepare-commit-msg{.sample,}
|
||||||
git add hooks
|
git add hooks
|
||||||
git commit -m "updated the prepare-commit-msg git hook"
|
git commit -m "updated the prepare-commit-msg git hook"
|
||||||
git co master
|
git co master
|
||||||
|
title "gpm hooks sync"
|
||||||
gpm hooks sync
|
gpm hooks sync
|
||||||
|
title "gpm serve start"
|
||||||
|
gpm serve start
|
||||||
popd
|
popd
|
||||||
|
mkdir $testproj2
|
||||||
|
pushd $testproj2
|
||||||
|
git clone http://localhost:3000/${prjname}.git $testproj2
|
||||||
|
gpm serve stop
|
||||||
|
popd
|
||||||
|
|
||||||
|
popd
|
||||||
|
|
||||||
|
echo
|
||||||
|
echo "--------"
|
||||||
|
echo "$testproj"
|
||||||
|
echo "$testproj2"
|
||||||
|
|
|
@ -27,7 +27,7 @@ gpm = do
|
||||||
Init -> Init.init
|
Init -> Init.init
|
||||||
NewIssue issueOpt -> inGPM (Issue.handleNewIssue issueOpt)
|
NewIssue issueOpt -> inGPM (Issue.handleNewIssue issueOpt)
|
||||||
Review reviewCmd -> inGPM (Review.handleReview reviewCmd)
|
Review reviewCmd -> inGPM (Review.handleReview reviewCmd)
|
||||||
Serve serveCmd -> inGPM (Serve.handleServe serveCmd)
|
Serve serveCmd -> Serve.handleServe serveCmd
|
||||||
Hooks hooksCmd -> inGPM (Hooks.handleHooks hooksCmd)
|
Hooks hooksCmd -> inGPM (Hooks.handleHooks hooksCmd)
|
||||||
|
|
||||||
data Command = Init
|
data Command = Init
|
||||||
|
|
|
@ -13,17 +13,28 @@ module GPM.Serve
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Protolude hiding (die, (%))
|
-- | Generic Import
|
||||||
|
import Protolude hiding (die, stdout, (%), (<.>))
|
||||||
import Turtle
|
import Turtle
|
||||||
|
|
||||||
import GPM.Helpers (debug, debug_, getGPMDataDir, inDir, green)
|
-- | Local Imports
|
||||||
|
import GPM.Helpers (debug, debug_, getGPMDataDir,
|
||||||
|
green, inDir, inGPM)
|
||||||
|
|
||||||
|
-- | External Lib Imports
|
||||||
|
import qualified Data.Text as Text
|
||||||
|
import qualified Network.Wai.Application.Static as WaiStatic
|
||||||
|
import qualified Network.Wai.Handler.Warp as Warp
|
||||||
|
import qualified System.Posix.Process as Process
|
||||||
|
|
||||||
|
-- | Retrieve a public dir to serve git repositories
|
||||||
getPublicDir :: IO Turtle.FilePath
|
getPublicDir :: IO Turtle.FilePath
|
||||||
getPublicDir = do
|
getPublicDir = do
|
||||||
gpmDataDir <- getGPMDataDir
|
gpmDataDir <- getGPMDataDir
|
||||||
let publicdir = gpmDataDir </> "public"
|
let publicdir = gpmDataDir </> "public"
|
||||||
return publicdir
|
return publicdir
|
||||||
|
|
||||||
|
-- | Retrieve the git project root directory
|
||||||
getProjectRoot :: IO Turtle.FilePath
|
getProjectRoot :: IO Turtle.FilePath
|
||||||
getProjectRoot = do
|
getProjectRoot = do
|
||||||
mReporoot <- debug "git rev-parse --show-toplevel"
|
mReporoot <- debug "git rev-parse --show-toplevel"
|
||||||
|
@ -31,12 +42,13 @@ getProjectRoot = do
|
||||||
Nothing -> die "You don't appear to be in a git repository."
|
Nothing -> die "You don't appear to be in a git repository."
|
||||||
Just reporoot -> return (fromString (toS reporoot))
|
Just reporoot -> return (fromString (toS reporoot))
|
||||||
|
|
||||||
|
-- | Retrieve the git public directory for the project
|
||||||
getPublicPrjDir :: IO Turtle.FilePath
|
getPublicPrjDir :: IO Turtle.FilePath
|
||||||
getPublicPrjDir = do
|
getPublicPrjDir = do
|
||||||
publicdir <- getPublicDir
|
publicdir <- getPublicDir
|
||||||
reporoot <- getProjectRoot
|
reporoot <- getProjectRoot
|
||||||
let projectName = basename reporoot
|
let projectName = basename reporoot
|
||||||
return (publicdir </> projectName)
|
return (publicdir </> (projectName <.> "git"))
|
||||||
|
|
||||||
-- | init gpm branch to handle reviews
|
-- | init gpm branch to handle reviews
|
||||||
init :: IO ()
|
init :: IO ()
|
||||||
|
@ -77,14 +89,14 @@ parseServeCommand =
|
||||||
<|> subcommand "update" "Update the served git repository" (pure ServeUpdate)
|
<|> subcommand "update" "Update the served git repository" (pure ServeUpdate)
|
||||||
<|> subcommand "path" "Show the path of the bare repository" (pure ServeUpdate)
|
<|> subcommand "path" "Show the path of the bare repository" (pure ServeUpdate)
|
||||||
|
|
||||||
handleServe :: ServeCommand -> Text -> IO ()
|
handleServe :: ServeCommand -> IO ()
|
||||||
handleServe ServeStart _ = handleServeStart
|
handleServe ServeStart = handleServeStart
|
||||||
handleServe ServeStop _ = handleServeStop
|
handleServe ServeStop = handleServeStop
|
||||||
handleServe ServeUpdate _ = handleUpdate
|
handleServe ServeUpdate = inGPM handleUpdate
|
||||||
handleServe ProjectDir _ = handleProjectDir
|
handleServe ProjectDir = handleProjectDir
|
||||||
|
|
||||||
handleUpdate :: IO ()
|
handleUpdate :: Text -> IO ()
|
||||||
handleUpdate = do
|
handleUpdate _ = do
|
||||||
pubPrjDir <- getPublicPrjDir
|
pubPrjDir <- getPublicPrjDir
|
||||||
inDir pubPrjDir $ do
|
inDir pubPrjDir $ do
|
||||||
pwd >>= putText . format fp
|
pwd >>= putText . format fp
|
||||||
|
@ -96,7 +108,7 @@ handleServeStart = do
|
||||||
inDir pubDir $ do
|
inDir pubDir $ do
|
||||||
pwd >>= putText . format fp
|
pwd >>= putText . format fp
|
||||||
debug_ "git instaweb --http=webrick start"
|
debug_ "git instaweb --http=webrick start"
|
||||||
-- TODO: Do not forget to also git serve
|
dirServe
|
||||||
|
|
||||||
handleServeStop :: IO ()
|
handleServeStop :: IO ()
|
||||||
handleServeStop = do
|
handleServeStop = do
|
||||||
|
@ -104,6 +116,25 @@ handleServeStop = do
|
||||||
inDir pubDir $ do
|
inDir pubDir $ do
|
||||||
pwd >>= putText . format fp
|
pwd >>= putText . format fp
|
||||||
debug_ "git instaweb --http=webrick stop"
|
debug_ "git instaweb --http=webrick stop"
|
||||||
|
dirStopServe
|
||||||
|
|
||||||
handleProjectDir :: IO ()
|
handleProjectDir :: IO ()
|
||||||
handleProjectDir = getPublicDir >>= putText . format fp
|
handleProjectDir = getPublicDir >>= putText . format fp
|
||||||
|
|
||||||
|
dirServe :: IO ()
|
||||||
|
dirServe = do
|
||||||
|
processId <- Process.forkProcess $ Warp.run 3000 (WaiStatic.staticApp (WaiStatic.defaultWebAppSettings "."))
|
||||||
|
gpmDataDir <- getGPMDataDir
|
||||||
|
inDir gpmDataDir $ do
|
||||||
|
mktree "procs"
|
||||||
|
writeTextFile ("procs" </> "gitServePID") (show processId)
|
||||||
|
|
||||||
|
dirStopServe :: IO ()
|
||||||
|
dirStopServe = do
|
||||||
|
gpmDataDir <- getGPMDataDir
|
||||||
|
inDir gpmDataDir $ do
|
||||||
|
pidtxt <- readTextFile ("procs" </> "gitServePID")
|
||||||
|
if Text.null pidtxt
|
||||||
|
then putErrText "The git server doesn't appear to be running"
|
||||||
|
else debug_ ("kill " <> pidtxt)
|
||||||
|
|
||||||
|
|
Loading…
Reference in a new issue