Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP

Comparing changes

Choose two branches to see what's changed or to start a new pull request. If you need to, you can also compare across forks.

Open a pull request

Create a new pull request by comparing changes across two branches. If you need to, you can also compare across forks.
base fork: jystic/gittens
base: 426659e2f1
...
head fork: jystic/gittens
compare: f7cd94791e
Checking mergeability… Don't worry, you can still create the pull request.
  • 4 commits
  • 3 files changed
  • 0 commit comments
  • 1 contributor
Showing with 85 additions and 70 deletions.
  1. +1 −1  .gitignore
  2. +12 −17 gittens.cabal
  3. +72 −52 src/Main.hs
View
2  .gitignore
@@ -1,6 +1,6 @@
/dist/
/cabal-dev/
-/logs/
+/log/
*.aux
*.hp
*.prof
View
29 gittens.cabal
@@ -15,23 +15,18 @@ executable gittens
main-is: Main.hs
build-depends:
- base == 4.6.*
- , aeson == 0.6.*
- , attoparsec == 0.10.*
- , blaze-builder == 0.3.*
- , bytestring == 0.10.*
- , conduit == 0.5.*
- , containers == 0.5.*
- , gitlib == 0.7.*
- , http-types == 0.8.*
- , network == 2.4.*
- , scotty == 0.4.*
- , text == 0.11.*
- , transformers == 0.3.*
- , wai == 1.4.*
- , wai-extra == 1.3.*
- , wai-middleware-static == 0.3.*
- , warp == 1.3.*
+ base == 4.6.*
+ , aeson == 0.6.*
+ , attoparsec == 0.10.*
+ , bytestring == 0.10.*
+ , containers == 0.5.*
+ , gitlib == 0.7.*
+ , network == 2.4.*
+ , snap-core == 0.9.*
+ , snap-server == 0.9.*
+ , text == 0.11.*
+ , transformers == 0.3.*
+ , unordered-containers == 0.2.*
, system-filepath
ghc-options:
View
124 src/Main.hs
@@ -3,48 +3,54 @@
{-# OPTIONS_GHC -fno-warn-orphans #-}
import Control.Applicative
+import Control.Arrow (first, second)
import Control.Monad
import Control.Monad.IO.Class (liftIO)
-import Data.Aeson (ToJSON(..), object, (.=))
-import Data.Attoparsec.Text.Lazy
+import Data.Aeson (ToJSON(..), object, (.=), encode)
+import Data.Attoparsec.ByteString.Char8
+import qualified Data.ByteString.Char8 as B
import Data.Git
-import Data.Maybe (catMaybes, listToMaybe)
+import Data.List ((\\))
import qualified Data.Map as M
+import Data.Maybe (catMaybes, listToMaybe)
import Data.Monoid ((<>))
-import Data.Text (Text, unpack)
+import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
-import Data.Text.Lazy (toStrict, fromStrict)
-import Filesystem.Path.CurrentOS hiding (concat)
+import Filesystem.Path.CurrentOS (FilePath, fromText)
+
import Network (withSocketsDo)
-import Network.Wai (rawPathInfo)
-import Network.Wai.Middleware.RequestLogger
-import Network.Wai.Middleware.Static hiding ((<|>))
-import Web.Scotty hiding (body, files)
+import Snap.Core hiding (path)
+import Snap.Http.Server
+import Snap.Util.FileServe (serveDirectoryWith, fancyDirectoryConfig)
import Prelude hiding (FilePath, log)
main :: IO ()
main = withSocketsDo $ do
putStrLn "Gittens v0.1"
- scotty 30090 app
-
-app :: ScottyM ()
-app = do
- middleware logStdoutDev
- middleware $ staticPolicy (noDots >-> addBase "static")
-
- get "/" $ file "static/index.html"
-
- get anyPath $ do
- path <- param "path"
- case parseOnly pGitRequest path of
- Left _ -> next
- Right req -> process req
+ cfg <- commandLineConfig config
+ putStrLn "Setting phasers to stun... (ctrl-c to quit)"
+ httpServe cfg site
+
+config :: MonadSnap m => Config m a
+config = setPort 30090
+ . setCompression False
+ $ defaultConfig
+
+site :: Snap ()
+site = serveDirectoryWith fancyDirectoryConfig "static"
+ <|> method GET gitRequest
+ where
+ gitRequest = do
+ path <- getsRequest rqPathInfo
+ case parseOnly pGitRequest path of
+ Left _ -> pass
+ Right req -> process req
------------------------------------------------------------------------
-process :: GitRequest -> ActionM ()
+process :: GitRequest -> Snap ()
process (GitRefs path) =
(json =<<) . liftIO $ do
@@ -59,11 +65,26 @@ process (GitCommits path ref limit) = do
process (GitTree path ref) = do
(json =<<) . liftIO $ do
+ repo <- openRepository path
+ hashBlobs <$> getCommitFiles repo ref
+
+process (GitDiff path refA refB) = do
+ (json =<<) . liftIO $ do
repo <- openRepository path
- commit <- getCommit repo ref
- tree <- loadObject' (commitTree commit) commit
- files <- getFiles tree
- return $ map (\(p,b) -> (p, show (getId b))) files
+ filesA <- hashBlobs <$> getCommitFiles repo refA
+ filesB <- hashBlobs <$> getCommitFiles repo refB
+ return $ map fst (filesA \\ filesB)
+
+hashBlobs :: [(Text, ObjRef Blob)] -> [(Text, Text)]
+hashBlobs = map (second $ T.pack . showId)
+ where
+ showId (IdRef oid) = show oid
+ showId (ObjRef b) = show (getId b)
+
+json :: ToJSON a => a -> Snap ()
+json obj = do
+ modifyResponse (setContentType "application/json")
+ (writeLBS . encode . toJSON) obj
------------------------------------------------------------------------
@@ -74,6 +95,7 @@ data GitRequest
= GitRefs RepoPath
| GitCommits RepoPath Revision Int
| GitTree RepoPath Revision
+ | GitDiff RepoPath Revision Revision
deriving (Eq, Show)
pGitRequest :: Parser GitRequest
@@ -81,32 +103,27 @@ pGitRequest =
GitRefs <$> pRepoPath <*. "refs"
<|> GitCommits <$> pRepoPath <*> pRevision <*> "commits/" .*> decimal
<|> GitTree <$> pRepoPath <*> pRevision <*. "tree"
+ <|> GitDiff <$> pRepoPath <*> pRevision <*> pRevision <*. "diff"
pRepoPath :: Parser RepoPath
-pRepoPath = fromText <$> (windows <|> unix)
+pRepoPath = fromText . decodeUtf8 <$> (windows <|> unix)
where
path = takeWhile1 (/= ':')
- unix = path <* char ':'
+
+ unix = do
+ p <- path
+ char ':'
+ return ("/" <> p)
+
windows = do
- char '/'
- d <- T.singleton <$> letter
+ d <- B.singleton <$> letter_ascii
char ':'
p <- path
char ':'
return (d <> ":" <> p)
pRevision :: Parser Revision
-pRevision = takeWhile1 (/= ':') <* char ':'
-
-------------------------------------------------------------------------
-
-instance Parsable Text where
- parseParam = Right . toStrict
-
-anyPath :: RoutePattern
-anyPath = function $ \rq -> Just [("path", textPath rq)]
- where
- textPath = fromStrict . decodeUtf8 . rawPathInfo
+pRevision = decodeUtf8 <$> takeWhile1 (/= ':') <* char ':'
------------------------------------------------------------------------
@@ -125,7 +142,7 @@ getCommit :: Repository -> Text -> IO Commit
getCommit repo ref = do
mOid <- resolveRef' repo ref
case mOid of
- Nothing -> error ("Cannot resolve: " ++ unpack ref)
+ Nothing -> error ("Cannot resolve: " ++ T.unpack ref)
Just oid -> do
mCommit <- lookupCommit repo oid
case mCommit of
@@ -142,19 +159,23 @@ getHistory n c = do
ps' <- getHistory (n-1) p
return (c:ps')
-getFiles :: Tree -> IO [(Text, Blob)]
+getCommitFiles :: Repository -> Text -> IO [(Text, ObjRef Blob)]
+getCommitFiles repo ref = do
+ commit <- getCommit repo ref
+ tree <- loadObject' (commitTree commit) commit
+ getFiles tree
+
+getFiles :: Tree -> IO [(Text, ObjRef Blob)]
getFiles tree =
liftM concat . mapM go $ M.toList $ treeContents tree
where
- go (name, BlobEntry ref _) = do
- blob <- loadObject' ref tree
- return [(name, blob)]
- go (name, TreeEntry ref) = do
+ go (name, BlobEntry ref _) = return [(name, ref)]
+ go (name, TreeEntry ref) = do
subTree <- loadObject' ref tree
files <- getFiles subTree
return (map prefix files)
where
- prefix (p, b) = (name `T.append` "/" `T.append` p, b)
+ prefix = first (name `T.append` "/" `T.append`)
instance ToJSON Commit where
toJSON c = object [
@@ -175,4 +196,3 @@ instance ToJSON Signature where
, "email" .= signatureEmail s
, "when" .= signatureWhen s
]
-

No commit comments for this range

Something went wrong with that request. Please try again.