Permalink
Browse files

Using attoparsec to process colon based url syntax

  • Loading branch information...
1 parent 73913d0 commit 347eb4216706ef18474dc040495741edaa85fe14 @jystic committed Mar 13, 2013
Showing with 81 additions and 28 deletions.
  1. +1 −0 gittens.cabal
  2. +80 −28 src/Main.hs
View
@@ -17,6 +17,7 @@ executable gittens
build-depends:
base == 4.6.*
, aeson == 0.6.*
+ , attoparsec == 0.10.*
, blaze-builder == 0.3.*
, bytestring == 0.10.*
, conduit == 0.5.*
View
@@ -2,18 +2,25 @@
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-import Control.Monad.IO.Class (liftIO)
-import Data.Aeson (ToJSON(..), object, (.=))
-import Data.Git
-import Data.Maybe (catMaybes, listToMaybe)
-import Data.Monoid ((<>))
-import Data.Text (Text, unpack)
-import Data.Text.Lazy (toStrict)
-import Filesystem.Path.CurrentOS
-import Network (withSocketsDo)
-import Network.Wai.Middleware.RequestLogger
-import Network.Wai.Middleware.Static
-import Web.Scotty
+import Control.Applicative
+import Control.Monad.IO.Class (liftIO)
+import Data.Aeson (ToJSON(..), object, (.=))
+import Data.Attoparsec.Text.Lazy
+import Data.Git
+import Data.Maybe (catMaybes, listToMaybe)
+import Data.Monoid ((<>))
+import Data.Text (Text, unpack)
+import qualified Data.Text as T
+import Data.Text.Encoding (decodeUtf8)
+import Data.Text.Lazy (toStrict, fromStrict)
+import Filesystem.Path.CurrentOS
+import Network (withSocketsDo)
+import Network.Wai (rawPathInfo)
+import Network.Wai.Middleware.RequestLogger
+import Network.Wai.Middleware.Static hiding ((<|>))
+import Web.Scotty
+
+import Prelude hiding (FilePath)
main :: IO ()
main = withSocketsDo $ do
@@ -25,21 +32,68 @@ app = do
middleware logStdoutDev
middleware $ staticPolicy (noDots >-> addBase "static")
- get "/refs" $ do
- repo <- liftIO getRepo
- refs <- liftIO (listRefNames repo allRefsFlag)
- json refs
+ get anyPath $ do
+ path <- param "path"
+ case parseOnly pGitRequest path of
+ Left _ -> next
+ Right req -> process req
+
+------------------------------------------------------------------------
+
+process :: GitRequest -> ActionM ()
+
+process (Refs path) = do
+ repo <- liftIO (openRepository path)
+ refs <- liftIO (listRefNames repo allRefsFlag)
+ json refs
- get (regex "^/commits/([^/]+)/(.*)$") $ do
- limit <- param "1"
- ref <- param "2"
- commits <- liftIO (getCommits (toStrict ref) limit)
- json commits
+process (Commits path ref limit) = do
+ repo <- liftIO (openRepository path)
+ commits <- liftIO (getCommits repo ref limit)
+ json commits
------------------------------------------------------------------------
-getRepo :: IO Repository
-getRepo = openRepository (fromText "c:/development/ng/starfix-ng")
+type RepoPath = FilePath
+type OidOrRef = Text
+
+data GitRequest
+ = Refs RepoPath
+ | Commits RepoPath OidOrRef Int
+ deriving (Eq, Show)
+
+pGitRequest :: Parser GitRequest
+pGitRequest =
+ Refs <$> pRepoPath <*. "refs"
+ <|> Commits <$> pRepoPath <*> pOidOrRef <*> "commits/" .*> decimal
+
+pRepoPath :: Parser RepoPath
+pRepoPath = fromText <$> (windows <|> unix)
+ where
+ path = takeWhile1 (/= ':')
+ unix = path <* char ':'
+ windows = do
+ char '/'
+ d <- T.singleton <$> letter
+ char ':'
+ p <- path
+ char ':'
+ return (d <> ":" <> p)
+
+pOidOrRef :: Parser OidOrRef
+pOidOrRef = takeWhile1 (/= ':') <* char ':'
+
+------------------------------------------------------------------------
+
+instance Parsable Text where
+ parseParam = Right . toStrict
+
+anyPath :: RoutePattern
+anyPath = function $ \rq -> Just [("path", textPath rq)]
+ where
+ textPath = fromStrict . decodeUtf8 . rawPathInfo
+
+------------------------------------------------------------------------
resolveRef' :: Repository -> Text -> IO (Maybe Oid)
resolveRef' repo ref = do
@@ -48,12 +102,12 @@ resolveRef' repo ref = do
, resolveRef repo ("refs/heads/" <> ref)
, resolveRef repo ("refs/tags/" <> ref)
, resolveRef repo ("refs/remotes/" <> ref)
+ , parseOid ref
]
return $ listToMaybe $ catMaybes xs
-getCommits :: Text -> Int -> IO [Commit]
-getCommits ref limit = do
- repo <- getRepo
+getCommits :: Repository -> Text -> Int -> IO [Commit]
+getCommits repo ref limit = do
moid <- resolveRef' repo ref
case moid of
Nothing -> error ("Cannot resolve: " ++ unpack ref)
@@ -87,5 +141,3 @@ instance ToJSON Signature where
, "email" .= signatureEmail s
, "when" .= signatureWhen s
]
-
-------------------------------------------------------------------------

0 comments on commit 347eb42

Please sign in to comment.