:wip: Serve git on the web support
This commit is contained in:
parent
f22c7e0e67
commit
857324468f
3 changed files with 93 additions and 25 deletions
|
@ -10,7 +10,7 @@ module GPM.Helpers
|
||||||
( debug
|
( debug
|
||||||
, debug_
|
, debug_
|
||||||
, getCurrentGitBranch
|
, getCurrentGitBranch
|
||||||
, getGPMCacheDir
|
, getGPMDataDir
|
||||||
, getGitUser
|
, getGitUser
|
||||||
, inGPM
|
, inGPM
|
||||||
)
|
)
|
||||||
|
@ -56,6 +56,6 @@ inGPM = bracket safeChangeBranch safeReturnBranch
|
||||||
debug_ "git stash pop"
|
debug_ "git stash pop"
|
||||||
|
|
||||||
-- | Retrieve the cache directory to save temporary files in gpm
|
-- | Retrieve the cache directory to save temporary files in gpm
|
||||||
getGPMCacheDir :: IO Turtle.FilePath
|
getGPMDataDir :: IO Turtle.FilePath
|
||||||
getGPMCacheDir = fromString <$> Directory.getXdgDirectory Directory.XdgCache "gpm"
|
getGPMDataDir = fromString <$> Directory.getXdgDirectory Directory.XdgData "gpm"
|
||||||
|
|
||||||
|
|
|
@ -22,7 +22,7 @@ import Protolude hiding (ask, die, (%),stdout)
|
||||||
import Turtle
|
import Turtle
|
||||||
|
|
||||||
import Data.FileEmbed (embedStringFile)
|
import Data.FileEmbed (embedStringFile)
|
||||||
import GPM.Helpers (getGPMCacheDir, debug_, getGitUser)
|
import GPM.Helpers (getGPMDataDir, debug_, getGitUser)
|
||||||
import Text.Mustache
|
import Text.Mustache
|
||||||
import qualified Data.Text as Text
|
import qualified Data.Text as Text
|
||||||
import qualified Data.Char as Char
|
import qualified Data.Char as Char
|
||||||
|
@ -52,11 +52,31 @@ init = do
|
||||||
debug_ "git add templates"
|
debug_ "git add templates"
|
||||||
|
|
||||||
|
|
||||||
|
-- | Command Line Options
|
||||||
data ReviewOptions = ReviewOptions
|
data ReviewOptions = ReviewOptions
|
||||||
{ interactive :: Bool
|
{ interactive :: Bool
|
||||||
, newReview :: NewReview
|
, newReview :: NewReview
|
||||||
} deriving (Eq)
|
} deriving (Eq)
|
||||||
|
|
||||||
|
data NewReview =
|
||||||
|
NewReview { status :: Text
|
||||||
|
, title :: Text
|
||||||
|
, user :: Maybe User
|
||||||
|
, branch :: Maybe Text
|
||||||
|
, description :: Maybe Text
|
||||||
|
} deriving (Eq)
|
||||||
|
|
||||||
|
type User = Text
|
||||||
|
|
||||||
|
instance ToMustache NewReview where
|
||||||
|
toMustache NewReview{..} = object
|
||||||
|
[ "status" ~> status
|
||||||
|
, "title" ~> title
|
||||||
|
, "user" ~> user
|
||||||
|
, "branch" ~> branch
|
||||||
|
, "description" ~> description
|
||||||
|
]
|
||||||
|
|
||||||
parseFullReviewOptions :: Parser ReviewOptions
|
parseFullReviewOptions :: Parser ReviewOptions
|
||||||
parseFullReviewOptions =
|
parseFullReviewOptions =
|
||||||
ReviewOptions
|
ReviewOptions
|
||||||
|
@ -194,30 +214,11 @@ validTmpNewReview br = do
|
||||||
debug_ $ "git add " <> toS (format fp dstReview)
|
debug_ $ "git add " <> toS (format fp dstReview)
|
||||||
debug_ $ "git commit -m \"review for " <> br <> "\""
|
debug_ $ "git commit -m \"review for " <> br <> "\""
|
||||||
|
|
||||||
data NewReview =
|
|
||||||
NewReview { status :: Text
|
|
||||||
, title :: Text
|
|
||||||
, user :: Maybe User
|
|
||||||
, branch :: Maybe Text
|
|
||||||
, description :: Maybe Text
|
|
||||||
} deriving (Eq)
|
|
||||||
|
|
||||||
type User = Text
|
|
||||||
|
|
||||||
instance ToMustache NewReview where
|
|
||||||
toMustache NewReview{..} = object
|
|
||||||
[ "status" ~> status
|
|
||||||
, "title" ~> title
|
|
||||||
, "user" ~> user
|
|
||||||
, "branch" ~> branch
|
|
||||||
, "description" ~> description
|
|
||||||
]
|
|
||||||
|
|
||||||
getTmpReviewFile :: Text -> IO Turtle.FilePath
|
getTmpReviewFile :: Text -> IO Turtle.FilePath
|
||||||
getTmpReviewFile br = do
|
getTmpReviewFile br = do
|
||||||
cacheDir <- getGPMCacheDir
|
gpmDataDir <- getGPMDataDir
|
||||||
let reviewFilename = "review-" <> protectStr br <> ".org"
|
let reviewFilename = "review-" <> protectStr br <> ".org"
|
||||||
return $ cacheDir </> fromString (toS reviewFilename)
|
return $ gpmDataDir </> fromString (toS reviewFilename)
|
||||||
|
|
||||||
createTmpNewReview :: NewReview -> IO ()
|
createTmpNewReview :: NewReview -> IO ()
|
||||||
createTmpNewReview nr = do
|
createTmpNewReview nr = do
|
||||||
|
|
67
src/GPM/Serve.hs
Normal file
67
src/GPM/Serve.hs
Normal file
|
@ -0,0 +1,67 @@
|
||||||
|
{-# LANGUAGE NoImplicitPrelude #-}
|
||||||
|
{-|
|
||||||
|
module : GPM.Serve
|
||||||
|
Description : GPM review related commands
|
||||||
|
License : Public Domain
|
||||||
|
Maintainer : yann.esposito@gmail.com
|
||||||
|
-}
|
||||||
|
module GPM.Serve
|
||||||
|
( init
|
||||||
|
)
|
||||||
|
where
|
||||||
|
|
||||||
|
import Protolude hiding (ask, die, (%),stdout)
|
||||||
|
import Turtle
|
||||||
|
|
||||||
|
import GPM.Helpers (getGPMDataDir, debug, debug_)
|
||||||
|
|
||||||
|
getPublicDir :: IO Turtle.FilePath
|
||||||
|
getPublicDir = do
|
||||||
|
gpmDataDir <- getGPMDataDir
|
||||||
|
let publicdir = gpmDataDir </> "public"
|
||||||
|
return publicdir
|
||||||
|
|
||||||
|
getPublicPrjDir :: IO Turtle.FilePath
|
||||||
|
getPublicPrjDir = do
|
||||||
|
publicdir <- getPublicDir
|
||||||
|
mReporoot <- debug "git rev-parse --show-toplevel"
|
||||||
|
case mReporoot of
|
||||||
|
Just reporoot -> do
|
||||||
|
let projectName = dirname (fromString (toS reporoot))
|
||||||
|
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 :: IO ()
|
||||||
|
init = do
|
||||||
|
echo "* server init"
|
||||||
|
publicdir <- getPublicDir
|
||||||
|
mktree publicdir
|
||||||
|
debug_ "git init ."
|
||||||
|
output (publicdir </> ".git" </> "description") "Main repositories"
|
||||||
|
publicProjectDir <- getPublicPrjDir
|
||||||
|
inDir publicProjectDir $ do
|
||||||
|
mv ("hooks" </> "post-update.sample") ("hooks" </> "post-update")
|
||||||
|
_ <- chmod executable ("hooks" </> "post-update")
|
||||||
|
debug_ "git update-server-info"
|
||||||
|
|
||||||
|
handleUpdate :: IO ()
|
||||||
|
handleUpdate = do
|
||||||
|
pubPrjDir <- getPublicPrjDir
|
||||||
|
inDir pubPrjDir $
|
||||||
|
debug_ "git pull"
|
||||||
|
|
||||||
|
handleServe :: IO ()
|
||||||
|
handleServe = do
|
||||||
|
pubDir <- getPublicDir
|
||||||
|
inDir pubDir $
|
||||||
|
debug_ "git instaweb --http=webrick"
|
Loading…
Reference in a new issue