serve basics
This commit is contained in:
parent
857324468f
commit
10b29065d2
5 changed files with 70 additions and 21 deletions
|
@ -2,7 +2,7 @@
|
||||||
--
|
--
|
||||||
-- see: https://github.com/sol/hpack
|
-- see: https://github.com/sol/hpack
|
||||||
--
|
--
|
||||||
-- hash: a6d129913c89afe00223987f8c28215c0300bbe090e95b121fe66e3c4005a9b1
|
-- hash: 1cf72e2df7c9707db3de5badabd66d0a2123d9260d2eff8bfa4e32ef4c449cfd
|
||||||
|
|
||||||
name: gpm
|
name: gpm
|
||||||
version: 0.1.0.0
|
version: 0.1.0.0
|
||||||
|
@ -27,6 +27,7 @@ library
|
||||||
GPM.Init
|
GPM.Init
|
||||||
GPM.Issue
|
GPM.Issue
|
||||||
GPM.Review
|
GPM.Review
|
||||||
|
GPM.Serve
|
||||||
other-modules:
|
other-modules:
|
||||||
Paths_gpm
|
Paths_gpm
|
||||||
hs-source-dirs:
|
hs-source-dirs:
|
||||||
|
|
|
@ -17,6 +17,7 @@ import GPM.Helpers (inGPM)
|
||||||
import qualified GPM.Init as Init
|
import qualified GPM.Init as Init
|
||||||
import qualified GPM.Issue as Issue
|
import qualified GPM.Issue as Issue
|
||||||
import qualified GPM.Review as Review
|
import qualified GPM.Review as Review
|
||||||
|
import qualified GPM.Serve as Serve
|
||||||
|
|
||||||
gpm :: IO ()
|
gpm :: IO ()
|
||||||
gpm = do
|
gpm = do
|
||||||
|
@ -25,10 +26,12 @@ 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)
|
||||||
|
|
||||||
data Command = Init
|
data Command = Init
|
||||||
| NewIssue Issue.IssueOptions
|
| NewIssue Issue.IssueOptions
|
||||||
| Review Review.ReviewCommand
|
| Review Review.ReviewCommand
|
||||||
|
| Serve Serve.ServeCommand
|
||||||
|
|
||||||
parser :: Parser Command
|
parser :: Parser Command
|
||||||
parser = subcommand "init" "Initialize gpm" (pure Init)
|
parser = subcommand "init" "Initialize gpm" (pure Init)
|
||||||
|
@ -38,6 +41,9 @@ parser = subcommand "init" "Initialize gpm" (pure Init)
|
||||||
<|> Review <$> subcommand "review"
|
<|> Review <$> subcommand "review"
|
||||||
"Review (use current branch by default)"
|
"Review (use current branch by default)"
|
||||||
Review.parseReviewCmd
|
Review.parseReviewCmd
|
||||||
|
<|> Serve <$> subcommand "serve"
|
||||||
|
"Serve the git to the web"
|
||||||
|
Serve.parseServeCommand
|
||||||
|
|
||||||
debug :: Text -> IO ()
|
debug :: Text -> IO ()
|
||||||
debug cmd = do
|
debug cmd = do
|
||||||
|
|
|
@ -13,6 +13,7 @@ module GPM.Helpers
|
||||||
, getGPMDataDir
|
, getGPMDataDir
|
||||||
, getGitUser
|
, getGitUser
|
||||||
, inGPM
|
, inGPM
|
||||||
|
, inDir
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
|
@ -59,3 +60,12 @@ inGPM = bracket safeChangeBranch safeReturnBranch
|
||||||
getGPMDataDir :: IO Turtle.FilePath
|
getGPMDataDir :: IO Turtle.FilePath
|
||||||
getGPMDataDir = fromString <$> Directory.getXdgDirectory Directory.XdgData "gpm"
|
getGPMDataDir = fromString <$> Directory.getXdgDirectory Directory.XdgData "gpm"
|
||||||
|
|
||||||
|
-- | Perform some actions in some directory.
|
||||||
|
-- Take care of returning the the previous directory after the action are finished
|
||||||
|
inDir :: MonadIO m => Turtle.FilePath -> m a -> m a
|
||||||
|
inDir workDir action = do
|
||||||
|
currPwd <- pwd
|
||||||
|
cd workDir
|
||||||
|
res <- action
|
||||||
|
cd currPwd
|
||||||
|
return res
|
||||||
|
|
|
@ -20,6 +20,7 @@ import qualified GPM.Docs as Docs
|
||||||
import GPM.Helpers (debug_)
|
import GPM.Helpers (debug_)
|
||||||
import qualified GPM.Issue as Issue
|
import qualified GPM.Issue as Issue
|
||||||
import qualified GPM.Review as Review
|
import qualified GPM.Review as Review
|
||||||
|
import qualified GPM.Serve as Serve
|
||||||
|
|
||||||
-- | Init a repository with a new empty branch named @gpm@
|
-- | Init a repository with a new empty branch named @gpm@
|
||||||
init :: IO ()
|
init :: IO ()
|
||||||
|
@ -29,6 +30,7 @@ init = do
|
||||||
Issue.init
|
Issue.init
|
||||||
Docs.init
|
Docs.init
|
||||||
Review.init
|
Review.init
|
||||||
|
Serve.init
|
||||||
debug_ "git commit -m 'gpm initialized'"
|
debug_ "git commit -m 'gpm initialized'"
|
||||||
debug_ "git checkout master"
|
debug_ "git checkout master"
|
||||||
|
|
||||||
|
|
|
@ -7,13 +7,16 @@ Maintainer : yann.esposito@gmail.com
|
||||||
-}
|
-}
|
||||||
module GPM.Serve
|
module GPM.Serve
|
||||||
( init
|
( init
|
||||||
|
, handleServe
|
||||||
|
, parseServeCommand
|
||||||
|
, ServeCommand
|
||||||
)
|
)
|
||||||
where
|
where
|
||||||
|
|
||||||
import Protolude hiding (ask, die, (%),stdout)
|
import Protolude hiding (ask, die, (%),stdout)
|
||||||
import Turtle
|
import Turtle
|
||||||
|
|
||||||
import GPM.Helpers (getGPMDataDir, debug, debug_)
|
import GPM.Helpers (getGPMDataDir, debug, debug_, inDir)
|
||||||
|
|
||||||
getPublicDir :: IO Turtle.FilePath
|
getPublicDir :: IO Turtle.FilePath
|
||||||
getPublicDir = do
|
getPublicDir = do
|
||||||
|
@ -21,23 +24,19 @@ getPublicDir = do
|
||||||
let publicdir = gpmDataDir </> "public"
|
let publicdir = gpmDataDir </> "public"
|
||||||
return publicdir
|
return publicdir
|
||||||
|
|
||||||
|
getProjectRoot :: IO Turtle.FilePath
|
||||||
|
getProjectRoot = do
|
||||||
|
mReporoot <- debug "git rev-parse --show-toplevel"
|
||||||
|
case mReporoot of
|
||||||
|
Nothing -> die "You don't appear to be in a git repository."
|
||||||
|
Just reporoot -> return (fromString (toS reporoot))
|
||||||
|
|
||||||
getPublicPrjDir :: IO Turtle.FilePath
|
getPublicPrjDir :: IO Turtle.FilePath
|
||||||
getPublicPrjDir = do
|
getPublicPrjDir = do
|
||||||
publicdir <- getPublicDir
|
publicdir <- getPublicDir
|
||||||
mReporoot <- debug "git rev-parse --show-toplevel"
|
reporoot <- getProjectRoot
|
||||||
case mReporoot of
|
let projectName = basename reporoot
|
||||||
Just reporoot -> do
|
|
||||||
let projectName = dirname (fromString (toS reporoot))
|
|
||||||
return (publicdir </> projectName)
|
return (publicdir </> projectName)
|
||||||
Nothing -> die "You don't appear to be in a git repository."
|
|
||||||
|
|
||||||
inDir :: MonadIO m => Turtle.FilePath -> m a -> m a
|
|
||||||
inDir workDir action = do
|
|
||||||
currPwd <- pwd
|
|
||||||
cd workDir
|
|
||||||
res <- action
|
|
||||||
cd currPwd
|
|
||||||
return res
|
|
||||||
|
|
||||||
|
|
||||||
-- | init gpm branch to handle reviews
|
-- | init gpm branch to handle reviews
|
||||||
|
@ -45,23 +44,54 @@ init :: IO ()
|
||||||
init = do
|
init = do
|
||||||
echo "* server init"
|
echo "* server init"
|
||||||
publicdir <- getPublicDir
|
publicdir <- getPublicDir
|
||||||
|
putText (format ("create dir: "%fp) publicdir)
|
||||||
mktree publicdir
|
mktree publicdir
|
||||||
|
inDir publicdir $ do
|
||||||
debug_ "git init ."
|
debug_ "git init ."
|
||||||
output (publicdir </> ".git" </> "description") "Main repositories"
|
let descriptionFile = publicdir </> ".git" </> "description"
|
||||||
|
output descriptionFile "Main repositories"
|
||||||
|
repoRoot <- getProjectRoot
|
||||||
publicProjectDir <- getPublicPrjDir
|
publicProjectDir <- getPublicPrjDir
|
||||||
|
debug_ (format ("git clone --bare "%fp%" "%fp)
|
||||||
|
repoRoot
|
||||||
|
publicProjectDir)
|
||||||
inDir publicProjectDir $ do
|
inDir publicProjectDir $ do
|
||||||
mv ("hooks" </> "post-update.sample") ("hooks" </> "post-update")
|
mv ("hooks" </> "post-update.sample") ("hooks" </> "post-update")
|
||||||
_ <- chmod executable ("hooks" </> "post-update")
|
_ <- chmod executable ("hooks" </> "post-update")
|
||||||
debug_ "git update-server-info"
|
debug_ "git update-server-info"
|
||||||
|
|
||||||
|
-- | Serve command
|
||||||
|
|
||||||
|
data ServeCommand = ServeStart
|
||||||
|
| ServeStop
|
||||||
|
| ServeUpdate
|
||||||
|
deriving (Eq)
|
||||||
|
|
||||||
|
parseServeCommand :: Parser ServeCommand
|
||||||
|
parseServeCommand =
|
||||||
|
subcommand "start" "Start to serve all gpm tracked repositories" (pure ServeStart)
|
||||||
|
<|> subcommand "stop" "Stop to serve all gpm tracked repositories" (pure ServeStop)
|
||||||
|
<|> subcommand "update" "Update the served git repository" (pure ServeUpdate)
|
||||||
|
|
||||||
|
handleServe :: ServeCommand -> Text -> IO ()
|
||||||
|
handleServe ServeStart _ = handleServeStart
|
||||||
|
handleServe ServeStop _ = handleServeStop
|
||||||
|
handleServe ServeUpdate _ = handleUpdate
|
||||||
|
|
||||||
handleUpdate :: IO ()
|
handleUpdate :: IO ()
|
||||||
handleUpdate = do
|
handleUpdate = do
|
||||||
pubPrjDir <- getPublicPrjDir
|
pubPrjDir <- getPublicPrjDir
|
||||||
inDir pubPrjDir $
|
inDir pubPrjDir $
|
||||||
debug_ "git pull"
|
debug_ "git pull"
|
||||||
|
|
||||||
handleServe :: IO ()
|
handleServeStart :: IO ()
|
||||||
handleServe = do
|
handleServeStart = do
|
||||||
pubDir <- getPublicDir
|
pubDir <- getPublicDir
|
||||||
inDir pubDir $
|
inDir pubDir $
|
||||||
debug_ "git instaweb --http=webrick"
|
debug_ "git instaweb --http=webrick start"
|
||||||
|
|
||||||
|
handleServeStop :: IO ()
|
||||||
|
handleServeStop = do
|
||||||
|
pubDir <- getPublicDir
|
||||||
|
inDir pubDir $
|
||||||
|
debug_ "git instaweb --http=webrick stop"
|
||||||
|
|
Loading…
Reference in a new issue