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
|
||||
--
|
||||
-- hash: 04bfdb9ffa855881f6cd6cc09bf3b494a2107ded6cc33c41699546a12526099e
|
||||
-- hash: 5bfe1aa5fe45c81553fa282f889cbe95ef3bbfd9d254f8a67458609998b15f9a
|
||||
|
||||
name: gpm
|
||||
version: 0.1.0.0
|
||||
|
@ -45,6 +45,10 @@ library
|
|||
, protolude
|
||||
, text
|
||||
, turtle
|
||||
, unix
|
||||
, wai
|
||||
, wai-app-static
|
||||
, warp
|
||||
default-language: Haskell2010
|
||||
|
||||
executable gpm
|
||||
|
@ -66,4 +70,8 @@ executable gpm
|
|||
, protolude
|
||||
, text
|
||||
, turtle
|
||||
, unix
|
||||
, wai
|
||||
, wai-app-static
|
||||
, warp
|
||||
default-language: Haskell2010
|
||||
|
|
|
@ -23,8 +23,8 @@ ghc-options:
|
|||
- -Wredundant-constraints
|
||||
- -Wnoncanonical-monad-instances
|
||||
dependencies:
|
||||
- base >=4.8 && <5
|
||||
- ansi-terminal
|
||||
- base >=4.8 && <5
|
||||
- directory
|
||||
- file-embed
|
||||
- foldl
|
||||
|
@ -32,6 +32,10 @@ dependencies:
|
|||
- protolude
|
||||
- text
|
||||
- turtle
|
||||
- unix
|
||||
- wai
|
||||
- wai-app-static
|
||||
- warp
|
||||
library:
|
||||
source-dirs: src
|
||||
executables:
|
||||
|
|
|
@ -1,18 +1,57 @@
|
|||
#!/usr/bin/env zsh
|
||||
|
||||
[[ -d testproj ]] && rm -rf testproj
|
||||
mkdir testproj
|
||||
pushd testproj
|
||||
set -x
|
||||
|
||||
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
|
||||
git init .
|
||||
git add README
|
||||
git commit -m "initial commit"
|
||||
title "gpm init"
|
||||
gpm init
|
||||
title "gpm new-issue"
|
||||
gpm new-issue -t "issue-1" -p "A"
|
||||
title "HOOKS"
|
||||
git co gpm
|
||||
cp hooks/prepare-commit-msg{.sample,}
|
||||
git add hooks
|
||||
git commit -m "updated the prepare-commit-msg git hook"
|
||||
git co master
|
||||
title "gpm hooks sync"
|
||||
gpm hooks sync
|
||||
title "gpm serve start"
|
||||
gpm serve start
|
||||
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
|
||||
NewIssue issueOpt -> inGPM (Issue.handleNewIssue issueOpt)
|
||||
Review reviewCmd -> inGPM (Review.handleReview reviewCmd)
|
||||
Serve serveCmd -> inGPM (Serve.handleServe serveCmd)
|
||||
Serve serveCmd -> Serve.handleServe serveCmd
|
||||
Hooks hooksCmd -> inGPM (Hooks.handleHooks hooksCmd)
|
||||
|
||||
data Command = Init
|
||||
|
|
|
@ -13,17 +13,28 @@ module GPM.Serve
|
|||
)
|
||||
where
|
||||
|
||||
import Protolude hiding (die, (%))
|
||||
-- | Generic Import
|
||||
import Protolude hiding (die, stdout, (%), (<.>))
|
||||
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 = do
|
||||
gpmDataDir <- getGPMDataDir
|
||||
let publicdir = gpmDataDir </> "public"
|
||||
return publicdir
|
||||
|
||||
-- | Retrieve the git project root directory
|
||||
getProjectRoot :: IO Turtle.FilePath
|
||||
getProjectRoot = do
|
||||
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."
|
||||
Just reporoot -> return (fromString (toS reporoot))
|
||||
|
||||
-- | Retrieve the git public directory for the project
|
||||
getPublicPrjDir :: IO Turtle.FilePath
|
||||
getPublicPrjDir = do
|
||||
publicdir <- getPublicDir
|
||||
reporoot <- getProjectRoot
|
||||
let projectName = basename reporoot
|
||||
return (publicdir </> projectName)
|
||||
return (publicdir </> (projectName <.> "git"))
|
||||
|
||||
-- | init gpm branch to handle reviews
|
||||
init :: IO ()
|
||||
|
@ -77,14 +89,14 @@ parseServeCommand =
|
|||
<|> subcommand "update" "Update the served git repository" (pure ServeUpdate)
|
||||
<|> subcommand "path" "Show the path of the bare repository" (pure ServeUpdate)
|
||||
|
||||
handleServe :: ServeCommand -> Text -> IO ()
|
||||
handleServe ServeStart _ = handleServeStart
|
||||
handleServe ServeStop _ = handleServeStop
|
||||
handleServe ServeUpdate _ = handleUpdate
|
||||
handleServe ProjectDir _ = handleProjectDir
|
||||
handleServe :: ServeCommand -> IO ()
|
||||
handleServe ServeStart = handleServeStart
|
||||
handleServe ServeStop = handleServeStop
|
||||
handleServe ServeUpdate = inGPM handleUpdate
|
||||
handleServe ProjectDir = handleProjectDir
|
||||
|
||||
handleUpdate :: IO ()
|
||||
handleUpdate = do
|
||||
handleUpdate :: Text -> IO ()
|
||||
handleUpdate _ = do
|
||||
pubPrjDir <- getPublicPrjDir
|
||||
inDir pubPrjDir $ do
|
||||
pwd >>= putText . format fp
|
||||
|
@ -96,7 +108,7 @@ handleServeStart = do
|
|||
inDir pubDir $ do
|
||||
pwd >>= putText . format fp
|
||||
debug_ "git instaweb --http=webrick start"
|
||||
-- TODO: Do not forget to also git serve
|
||||
dirServe
|
||||
|
||||
handleServeStop :: IO ()
|
||||
handleServeStop = do
|
||||
|
@ -104,6 +116,25 @@ handleServeStop = do
|
|||
inDir pubDir $ do
|
||||
pwd >>= putText . format fp
|
||||
debug_ "git instaweb --http=webrick stop"
|
||||
dirStopServe
|
||||
|
||||
handleProjectDir :: IO ()
|
||||
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