mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
fix parsing of write-repo git(...)
This commit is contained in:
Mitchell Rosen
parent
3e1cc1ee0d
commit
7473fdacc8
@ -98,8 +98,8 @@ writeRemoteNamespace =
|
||||
|
||||
writeRemoteNamespaceWith :: P a -> P (WriteRemoteNamespace a)
|
||||
writeRemoteNamespaceWith projectBranchParser =
|
||||
WriteRemoteProjectBranch <$> projectBranchParser
|
||||
<|> WriteRemoteNamespaceGit <$> writeGitRemoteNamespace
|
||||
WriteRemoteNamespaceGit <$> writeGitRemoteNamespace
|
||||
<|> WriteRemoteProjectBranch <$> projectBranchParser
|
||||
<|> WriteRemoteNamespaceShare <$> writeShareRemoteNamespace
|
||||
|
||||
-- >>> P.parseMaybe writeShareRemoteNamespace "unisonweb.base._releases.M4"
|
||||
|
||||
@ -1,126 +1,119 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
|
||||
module Unison.Test.UriParser where
|
||||
|
||||
import Data.Functor (void)
|
||||
import qualified Data.Sequence as Seq
|
||||
import Data.Text (Text)
|
||||
import qualified Data.Text as Text
|
||||
import Data.These (These (..))
|
||||
import Data.Void (Void)
|
||||
import EasyTest
|
||||
import qualified Text.Megaparsec as P
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..), ReadRemoteNamespace (..), ShareCodeserver (..), ShareUserHandle (..), pattern ReadGitRemoteNamespace, pattern ReadShareLooseCode)
|
||||
import Unison.Codebase.Editor.RemoteRepo (ReadGitRepo (..), ReadRemoteNamespace (..), ShareCodeserver (..), ShareUserHandle (..), WriteGitRemoteNamespace (..), WriteGitRepo (..), WriteRemoteNamespace (..), WriteShareRemoteNamespace (..), pattern ReadGitRemoteNamespace, pattern ReadShareLooseCode)
|
||||
import qualified Unison.Codebase.Editor.UriParser as UriParser
|
||||
import Unison.Codebase.Path (Path (..))
|
||||
import qualified Unison.Codebase.Path as Path
|
||||
import Unison.Codebase.ShortCausalHash (ShortCausalHash (..))
|
||||
import Unison.Core.Project (ProjectBranchName (..), ProjectName (..))
|
||||
import Unison.NameSegment (NameSegment (..))
|
||||
|
||||
test :: Test ()
|
||||
test = scope "uriparser" . tests $ [testShare, testGit]
|
||||
|
||||
gitHelper :: (ReadGitRepo, Maybe ShortCausalHash, Path) -> ReadRemoteNamespace void
|
||||
gitHelper (repo, sch, path) = ReadRemoteNamespaceGit (ReadGitRemoteNamespace repo sch path)
|
||||
|
||||
testShare :: Test ()
|
||||
testShare =
|
||||
scope "share" . tests $
|
||||
[ parseAugmented
|
||||
( "unisonweb.base._releases.M4",
|
||||
ReadShare'LooseCode (ReadShareLooseCode DefaultCodeserver (ShareUserHandle "unisonweb") (path ["base", "_releases", "M4"]))
|
||||
),
|
||||
parseAugmented ("project", ReadShare'ProjectBranch (This (UnsafeProjectName "project"))),
|
||||
parseAugmented ("/branch", ReadShare'ProjectBranch (That (UnsafeProjectBranchName "branch"))),
|
||||
parseAugmented
|
||||
( "project/branch",
|
||||
ReadShare'ProjectBranch (These (UnsafeProjectName "project") (UnsafeProjectBranchName "branch"))
|
||||
),
|
||||
expectParseFailure ".unisonweb.base"
|
||||
]
|
||||
|
||||
testGit :: Test ()
|
||||
testGit =
|
||||
scope "git" . tests $
|
||||
-- Local Protocol
|
||||
-- $ git clone /srv/git/project.git
|
||||
-- $ git clone /srv/git/project.git[:treeish][:[#hash][.path]]
|
||||
[ scope "local-protocol" . tests . map parseAugmented $
|
||||
[ ( "git(/srv/git/project.git)",
|
||||
gitHelper (ReadGitRepo "/srv/git/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(/srv/git/project.git:abc)#def.hij.klm",
|
||||
gitHelper (ReadGitRepo "/srv/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
|
||||
),
|
||||
( "git(srv/git/project.git)",
|
||||
gitHelper (ReadGitRepo "srv/git/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(srv/git/project.git:abc)#def.hij.klm",
|
||||
gitHelper (ReadGitRepo "srv/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
|
||||
)
|
||||
],
|
||||
-- File Protocol
|
||||
-- $ git clone file:///srv/git/project.git[:treeish][:[#hash][.path]] <- imagined
|
||||
scope "file-protocol" . tests . map parseAugmented $
|
||||
[ ( "git(file:///srv/git/project.git)",
|
||||
gitHelper (ReadGitRepo "file:///srv/git/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(file:///srv/git/project.git:abc)#def.hij.klm",
|
||||
gitHelper (ReadGitRepo "file:///srv/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
|
||||
),
|
||||
( "git(file://srv/git/project.git)",
|
||||
gitHelper (ReadGitRepo "file://srv/git/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(file://srv/git/project.git:abc)#def.hij.klm",
|
||||
gitHelper (ReadGitRepo "file://srv/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
|
||||
)
|
||||
],
|
||||
-- Smart / Dumb HTTP protocol
|
||||
-- $ git clone https://example.com/gitproject.git[:treeish][:[#hash][.path]] <- imagined
|
||||
scope "http-protocol" . tests . map parseAugmented $
|
||||
[ ( "git(https://example.com/git/project.git)",
|
||||
gitHelper (ReadGitRepo "https://example.com/git/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(https://user@example.com/git/project.git:abc)#def.hij.klm",
|
||||
gitHelper (ReadGitRepo "https://user@example.com/git/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
|
||||
)
|
||||
],
|
||||
-- SSH Protocol
|
||||
-- $ git clone ssh://[user@]server/project.git[:treeish][:[#hash][.path]]
|
||||
scope "ssh-protocol" . tests . map parseAugmented $
|
||||
[ ( "git(ssh://git@8.8.8.8:222/user/project.git)",
|
||||
gitHelper (ReadGitRepo "ssh://git@8.8.8.8:222/user/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(ssh://git@github.com/user/project.git:abc)#def.hij.klm",
|
||||
gitHelper (ReadGitRepo "ssh://git@github.com/user/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
|
||||
)
|
||||
],
|
||||
-- $ git clone [user@]server:project.git[:treeish][:[#hash][.path]]
|
||||
scope "scp-protocol" . tests . map parseAugmented $
|
||||
[ ( "git(git@github.com:user/project.git)",
|
||||
gitHelper (ReadGitRepo "git@github.com:user/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(github.com:user/project.git)",
|
||||
gitHelper (ReadGitRepo "github.com:user/project.git" Nothing, Nothing, Path.empty)
|
||||
),
|
||||
( "git(git@github.com:user/project.git:abc)#def.hij.klm",
|
||||
gitHelper (ReadGitRepo "git@github.com:user/project.git" (Just "abc"), sch "def", path ["hij", "klm"])
|
||||
)
|
||||
test =
|
||||
scope "uriparser" . tests $
|
||||
[ parserTests
|
||||
"repoPath"
|
||||
(UriParser.repoPath <* P.eof)
|
||||
[ ("unisonweb.base._releases.M4", looseR "unisonweb" ["base", "_releases", "M4"]),
|
||||
("project", branchR (This "project")),
|
||||
("/branch", branchR (That "branch")),
|
||||
("project/branch", branchR (These "project" "branch")),
|
||||
("git(/srv/git/project.git)", gitR "/srv/git/project.git" Nothing Nothing []),
|
||||
("git(/srv/git/project.git:abc)#def.hij.klm", gitR "/srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]),
|
||||
("git(srv/git/project.git)", gitR "srv/git/project.git" Nothing Nothing []),
|
||||
("git(srv/git/project.git:abc)#def.hij.klm", gitR "srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]),
|
||||
("git(file:///srv/git/project.git)", gitR "file:///srv/git/project.git" Nothing Nothing []),
|
||||
("git(file:///srv/git/project.git:abc)#def.hij.klm", gitR "file:///srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]),
|
||||
("git(file://srv/git/project.git)", gitR "file://srv/git/project.git" Nothing Nothing []),
|
||||
("git(file://srv/git/project.git:abc)#def.hij.klm", gitR "file://srv/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]),
|
||||
("git(https://example.com/git/project.git)", gitR "https://example.com/git/project.git" Nothing Nothing []),
|
||||
("git(https://user@example.com/git/project.git:abc)#def.hij.klm", gitR "https://user@example.com/git/project.git" (Just "abc") (sch "def") ["hij", "klm"]),
|
||||
("git(ssh://git@8.8.8.8:222/user/project.git)", gitR "ssh://git@8.8.8.8:222/user/project.git" Nothing Nothing []),
|
||||
("git(ssh://git@github.com/user/project.git:abc)#def.hij.klm", gitR "ssh://git@github.com/user/project.git" (Just "abc") (sch "def") ["hij", "klm"]),
|
||||
("git(git@github.com:user/project.git)", gitR "git@github.com:user/project.git" Nothing Nothing []),
|
||||
("git(github.com:user/project.git)", gitR "github.com:user/project.git" Nothing Nothing []),
|
||||
("git(git@github.com:user/project.git:abc)#def.hij.klm", gitR "git@github.com:user/project.git" (Just "abc") (sch "def") ["hij", "klm"])
|
||||
]
|
||||
[".unisonweb.base"],
|
||||
parserTests
|
||||
"writeRemoteNamespace"
|
||||
(UriParser.writeRemoteNamespace <* P.eof)
|
||||
[ ("unisonweb.base._releases.M4", looseW "unisonweb" ["base", "_releases", "M4"]),
|
||||
("project", branchW (This "project")),
|
||||
("/branch", branchW (That "branch")),
|
||||
("project/branch", branchW (These "project" "branch")),
|
||||
("git(/srv/git/project.git)", gitW "/srv/git/project.git" Nothing []),
|
||||
("git(srv/git/project.git)", gitW "srv/git/project.git" Nothing []),
|
||||
("git(file:///srv/git/project.git)", gitW "file:///srv/git/project.git" Nothing []),
|
||||
("git(file://srv/git/project.git)", gitW "file://srv/git/project.git" Nothing []),
|
||||
("git(https://example.com/git/project.git)", gitW "https://example.com/git/project.git" Nothing []),
|
||||
("git(ssh://git@8.8.8.8:222/user/project.git)", gitW "ssh://git@8.8.8.8:222/user/project.git" Nothing []),
|
||||
("git(git@github.com:user/project.git)", gitW "git@github.com:user/project.git" Nothing []),
|
||||
("git(github.com:user/project.git)", gitW "github.com:user/project.git" Nothing [])
|
||||
]
|
||||
[ ".unisonweb.base",
|
||||
"git(/srv/git/project.git:abc)#def.hij.klm",
|
||||
"git(srv/git/project.git:abc)#def.hij.klm",
|
||||
"git(file:///srv/git/project.git:abc)#def.hij.klm",
|
||||
"git(file://srv/git/project.git:abc)#def.hij.klm",
|
||||
"git(https://user@example.com/git/project.git:abc)#def.hij.klm",
|
||||
"git(ssh://git@github.com/user/project.git:abc)#def.hij.klm",
|
||||
"git(git@github.com:user/project.git:abc)#def.hij.klm"
|
||||
]
|
||||
]
|
||||
|
||||
parseAugmented :: (Text, ReadRemoteNamespace (These ProjectName ProjectBranchName)) -> Test ()
|
||||
parseAugmented (s, r) = scope (Text.unpack s) $
|
||||
case P.parse (UriParser.repoPath <* P.eof) "test case" s of
|
||||
Left x -> crash $ P.errorBundlePretty x
|
||||
Right x -> expectEqual x r
|
||||
gitR :: Text -> Maybe Text -> Maybe ShortCausalHash -> [NameSegment] -> ReadRemoteNamespace void
|
||||
gitR url ref sch path = ReadRemoteNamespaceGit (ReadGitRemoteNamespace (ReadGitRepo url ref) sch (Path.fromList path))
|
||||
|
||||
expectParseFailure :: Text -> Test ()
|
||||
expectParseFailure s = void . scope (Text.unpack s) . expectLeft . P.parse (UriParser.repoPath <* P.eof) "negative test case" $ s
|
||||
gitW :: Text -> Maybe Text -> [NameSegment] -> WriteRemoteNamespace void
|
||||
gitW url branch path = WriteRemoteNamespaceGit (WriteGitRemoteNamespace (WriteGitRepo url branch) (Path.fromList path))
|
||||
|
||||
path :: [Text] -> Path
|
||||
path = Path . Seq.fromList . fmap NameSegment
|
||||
looseR :: Text -> [NameSegment] -> ReadRemoteNamespace void
|
||||
looseR user path =
|
||||
ReadShare'LooseCode (ReadShareLooseCode DefaultCodeserver (ShareUserHandle user) (Path.fromList path))
|
||||
|
||||
looseW :: Text -> [NameSegment] -> WriteRemoteNamespace void
|
||||
looseW user path =
|
||||
WriteRemoteNamespaceShare (WriteShareRemoteNamespace DefaultCodeserver (ShareUserHandle user) (Path.fromList path))
|
||||
|
||||
branchR :: These Text Text -> ReadRemoteNamespace (These ProjectName ProjectBranchName)
|
||||
branchR =
|
||||
ReadShare'ProjectBranch . \case
|
||||
This project -> This (UnsafeProjectName project)
|
||||
That branch -> That (UnsafeProjectBranchName branch)
|
||||
These project branch -> These (UnsafeProjectName project) (UnsafeProjectBranchName branch)
|
||||
|
||||
branchW :: These Text Text -> WriteRemoteNamespace (These ProjectName ProjectBranchName)
|
||||
branchW =
|
||||
WriteRemoteProjectBranch . \case
|
||||
This project -> This (UnsafeProjectName project)
|
||||
That branch -> That (UnsafeProjectBranchName branch)
|
||||
These project branch -> These (UnsafeProjectName project) (UnsafeProjectBranchName branch)
|
||||
|
||||
sch :: Text -> Maybe ShortCausalHash
|
||||
sch = Just . ShortCausalHash
|
||||
|
||||
-- | @parserTests name parser goodCases badCases@ tests @parser@ against each case in @goodCases@ and @badCases@,
|
||||
-- expecting success or failure, respectively.
|
||||
parserTests :: (Eq a, Show a) => Text -> P.Parsec Void Text a -> [(Text, a)] -> [Text] -> Test ()
|
||||
parserTests name parser goodCases badCases =
|
||||
scope (Text.unpack name) (tests (map f goodCases ++ map g badCases))
|
||||
where
|
||||
f (input, expected) =
|
||||
scope
|
||||
(Text.unpack input)
|
||||
case P.parse parser "" input of
|
||||
Left err -> crash (P.errorBundlePretty err)
|
||||
Right actual -> expectEqual expected actual
|
||||
|
||||
g input =
|
||||
scope
|
||||
(Text.unpack input)
|
||||
case P.parse parser "" input of
|
||||
Left _err -> ok
|
||||
Right actual -> crash ("Expected parse failure, but got: " ++ show actual)
|
||||
|
||||
Loading…
Reference in New Issue
Block a user