handle serve correctly

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

package.yaml

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

playground/gpm-test.sh

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

src/GPM.hs

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

src/GPM/Serve.hs

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