diff --git a/changelog.md b/changelog.md new file mode 100644 --- /dev/null +++ b/changelog.md @@ -0,0 +1,8 @@ +## 0.2.0.0 + + - Change data representation to associate `macdef` entries with + their respective `machine`/`default` entry + +## 0.1.0.0 + + - Initial version diff --git a/netrc.cabal b/netrc.cabal --- a/netrc.cabal +++ b/netrc.cabal @@ -1,7 +1,8 @@ name: netrc -version: 0.1.0.0 +version: 0.2.0.0 synopsis: Parser for .netrc files homepage: https://github.com/hvr/netrc +bug-reports: https://github.com/hvr/netrc/issues license: GPL-3 license-file: LICENSE author: Herbert Valerio Riedel @@ -12,10 +13,13 @@ cabal-version: >=1.10 tested-with: GHC ==7.10.1, GHC ==7.8.4, GHC ==7.6.3, GHC ==7.4.2 description: + This package provides a parser and a printer for so-called @.netrc@ files. + . See manual page for more information about @.netrc@ files. extra-source-files: + changelog.md src-tests/data/*.netrc src-tests/data/*.netrc.out diff --git a/src-tests/data/test0a.netrc.out b/src-tests/data/test0a.netrc.out --- a/src-tests/data/test0a.netrc.out +++ b/src-tests/data/test0a.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [] []) +Right (NetRc {nrHosts = [], nrMacros = []}) diff --git a/src-tests/data/test0b.netrc.out b/src-tests/data/test0b.netrc.out --- a/src-tests/data/test0b.netrc.out +++ b/src-tests/data/test0b.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [] []) +Right (NetRc {nrHosts = [], nrMacros = []}) diff --git a/src-tests/data/test0c.netrc.out b/src-tests/data/test0c.netrc.out --- a/src-tests/data/test0c.netrc.out +++ b/src-tests/data/test0c.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [] []) +Right (NetRc {nrHosts = [], nrMacros = []}) diff --git a/src-tests/data/test0d.netrc.out b/src-tests/data/test0d.netrc.out --- a/src-tests/data/test0d.netrc.out +++ b/src-tests/data/test0d.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [] []) +Right (NetRc {nrHosts = [], nrMacros = []}) diff --git a/src-tests/data/test0e.netrc.out b/src-tests/data/test0e.netrc.out --- a/src-tests/data/test0e.netrc.out +++ b/src-tests/data/test0e.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [] []) +Right (NetRc {nrHosts = [], nrMacros = []}) diff --git a/src-tests/data/test1a.netrc.out b/src-tests/data/test1a.netrc.out --- a/src-tests/data/test1a.netrc.out +++ b/src-tests/data/test1a.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [NetRcHost {nrhName = "host1.domain.com", nrhLogin = "log1", nrhPassword = "pass1", nrhAccount = "acct1"},NetRcHost {nrhName = "", nrhLogin = "log2", nrhPassword = "pass2", nrhAccount = ""}] []) +Right (NetRc {nrHosts = [NetRcHost {nrhName = "host1.domain.com", nrhLogin = "log1", nrhPassword = "pass1", nrhAccount = "acct1", nrhMacros = []},NetRcHost {nrhName = "", nrhLogin = "log2", nrhPassword = "pass2", nrhAccount = "", nrhMacros = []}], nrMacros = []}) diff --git a/src-tests/data/test2a.netrc.out b/src-tests/data/test2a.netrc.out --- a/src-tests/data/test2a.netrc.out +++ b/src-tests/data/test2a.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [NetRcHost {nrhName = "host.domain.com", nrhLogin = "log", nrhPassword = "#pass", nrhAccount = "acct"}] []) +Right (NetRc {nrHosts = [NetRcHost {nrhName = "host.domain.com", nrhLogin = "log", nrhPassword = "#pass", nrhAccount = "acct", nrhMacros = []}], nrMacros = []}) diff --git a/src-tests/data/test2b.netrc.out b/src-tests/data/test2b.netrc.out --- a/src-tests/data/test2b.netrc.out +++ b/src-tests/data/test2b.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [NetRcHost {nrhName = "host.domain.com", nrhLogin = "log", nrhPassword = "pass#", nrhAccount = "acct"}] []) +Right (NetRc {nrHosts = [NetRcHost {nrhName = "host.domain.com", nrhLogin = "log", nrhPassword = "pass#", nrhAccount = "acct", nrhMacros = []}], nrMacros = []}) diff --git a/src-tests/data/test2c.netrc.out b/src-tests/data/test2c.netrc.out --- a/src-tests/data/test2c.netrc.out +++ b/src-tests/data/test2c.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [NetRcHost {nrhName = "host.domain.com", nrhLogin = "log", nrhPassword = "pa#ss", nrhAccount = "acct"}] []) +Right (NetRc {nrHosts = [NetRcHost {nrhName = "host.domain.com", nrhLogin = "log", nrhPassword = "pa#ss", nrhAccount = "acct", nrhMacros = []}], nrMacros = []}) diff --git a/src-tests/data/test3a.netrc.out b/src-tests/data/test3a.netrc.out --- a/src-tests/data/test3a.netrc.out +++ b/src-tests/data/test3a.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [NetRcHost {nrhName = "foo.domain.com", nrhLogin = "bar", nrhPassword = "pass", nrhAccount = ""},NetRcHost {nrhName = "bar.domain.com", nrhLogin = "foo", nrhPassword = "pass", nrhAccount = ""}] []) +Right (NetRc {nrHosts = [NetRcHost {nrhName = "foo.domain.com", nrhLogin = "bar", nrhPassword = "pass", nrhAccount = "", nrhMacros = []},NetRcHost {nrhName = "bar.domain.com", nrhLogin = "foo", nrhPassword = "pass", nrhAccount = "", nrhMacros = []}], nrMacros = []}) diff --git a/src-tests/data/test3b.netrc.out b/src-tests/data/test3b.netrc.out --- a/src-tests/data/test3b.netrc.out +++ b/src-tests/data/test3b.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [NetRcHost {nrhName = "foo.domain.com", nrhLogin = "bar", nrhPassword = "pass", nrhAccount = ""},NetRcHost {nrhName = "bar.domain.com", nrhLogin = "foo", nrhPassword = "pass", nrhAccount = ""}] []) +Right (NetRc {nrHosts = [NetRcHost {nrhName = "foo.domain.com", nrhLogin = "bar", nrhPassword = "pass", nrhAccount = "", nrhMacros = []},NetRcHost {nrhName = "bar.domain.com", nrhLogin = "foo", nrhPassword = "pass", nrhAccount = "", nrhMacros = []}], nrMacros = []}) diff --git a/src-tests/data/test3c.netrc.out b/src-tests/data/test3c.netrc.out --- a/src-tests/data/test3c.netrc.out +++ b/src-tests/data/test3c.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [NetRcHost {nrhName = "foo.domain.com", nrhLogin = "bar", nrhPassword = "pass", nrhAccount = ""},NetRcHost {nrhName = "bar.domain.com", nrhLogin = "foo", nrhPassword = "pass", nrhAccount = ""}] []) +Right (NetRc {nrHosts = [NetRcHost {nrhName = "foo.domain.com", nrhLogin = "bar", nrhPassword = "pass", nrhAccount = "", nrhMacros = []},NetRcHost {nrhName = "bar.domain.com", nrhLogin = "foo", nrhPassword = "pass", nrhAccount = "", nrhMacros = []}], nrMacros = []}) diff --git a/src-tests/data/test3e.netrc.out b/src-tests/data/test3e.netrc.out --- a/src-tests/data/test3e.netrc.out +++ b/src-tests/data/test3e.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [NetRcHost {nrhName = "foo.domain.com", nrhLogin = "bar", nrhPassword = "pass", nrhAccount = ""},NetRcHost {nrhName = "bar.domain.com", nrhLogin = "foo", nrhPassword = "pass", nrhAccount = ""}] []) +Right (NetRc {nrHosts = [NetRcHost {nrhName = "foo.domain.com", nrhLogin = "bar", nrhPassword = "pass", nrhAccount = "", nrhMacros = []},NetRcHost {nrhName = "bar.domain.com", nrhLogin = "foo", nrhPassword = "pass", nrhAccount = "", nrhMacros = []}], nrMacros = []}) diff --git a/src-tests/data/test3f.netrc.out b/src-tests/data/test3f.netrc.out --- a/src-tests/data/test3f.netrc.out +++ b/src-tests/data/test3f.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [NetRcHost {nrhName = "foo.domain.com", nrhLogin = "bar", nrhPassword = "pass", nrhAccount = ""},NetRcHost {nrhName = "bar.domain.com", nrhLogin = "foo", nrhPassword = "pass", nrhAccount = ""}] []) +Right (NetRc {nrHosts = [NetRcHost {nrhName = "foo.domain.com", nrhLogin = "bar", nrhPassword = "pass", nrhAccount = "", nrhMacros = []},NetRcHost {nrhName = "bar.domain.com", nrhLogin = "foo", nrhPassword = "pass", nrhAccount = "", nrhMacros = []}], nrMacros = []}) diff --git a/src-tests/data/test3g.netrc.out b/src-tests/data/test3g.netrc.out --- a/src-tests/data/test3g.netrc.out +++ b/src-tests/data/test3g.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [NetRcHost {nrhName = "foo.domain.com", nrhLogin = "bar", nrhPassword = "#pass", nrhAccount = ""},NetRcHost {nrhName = "bar.domain.com", nrhLogin = "foo", nrhPassword = "pass", nrhAccount = ""}] []) +Right (NetRc {nrHosts = [NetRcHost {nrhName = "foo.domain.com", nrhLogin = "bar", nrhPassword = "#pass", nrhAccount = "", nrhMacros = []},NetRcHost {nrhName = "bar.domain.com", nrhLogin = "foo", nrhPassword = "pass", nrhAccount = "", nrhMacros = []}], nrMacros = []}) diff --git a/src-tests/data/test4a.netrc.out b/src-tests/data/test4a.netrc.out --- a/src-tests/data/test4a.netrc.out +++ b/src-tests/data/test4a.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [] [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\nmacdef macro2\nline3\nline4\n"}]) +Right (NetRc {nrHosts = [], nrMacros = [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\nmacdef macro2\nline3\nline4\n"}]}) diff --git a/src-tests/data/test4b.netrc.out b/src-tests/data/test4b.netrc.out --- a/src-tests/data/test4b.netrc.out +++ b/src-tests/data/test4b.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [] [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\n#\nmacdef macro2\nline3\nline4\n"}]) +Right (NetRc {nrHosts = [], nrMacros = [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\n#\nmacdef macro2\nline3\nline4\n"}]}) diff --git a/src-tests/data/test4c.netrc.out b/src-tests/data/test4c.netrc.out --- a/src-tests/data/test4c.netrc.out +++ b/src-tests/data/test4c.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [] [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\n"},NetRcMacDef {nrmName = "macro2", nrmBody = "line3\nline4\n"}]) +Right (NetRc {nrHosts = [], nrMacros = [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\n"},NetRcMacDef {nrmName = "macro2", nrmBody = "line3\nline4\n"}]}) diff --git a/src-tests/data/test4d.netrc.out b/src-tests/data/test4d.netrc.out --- a/src-tests/data/test4d.netrc.out +++ b/src-tests/data/test4d.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [] [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\n"},NetRcMacDef {nrmName = "macro2", nrmBody = "line3\nline4\n"}]) +Right (NetRc {nrHosts = [], nrMacros = [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\n"},NetRcMacDef {nrmName = "macro2", nrmBody = "line3\nline4\n"}]}) diff --git a/src-tests/data/test4e.netrc.out b/src-tests/data/test4e.netrc.out --- a/src-tests/data/test4e.netrc.out +++ b/src-tests/data/test4e.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [] [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\n \nline3\nline4\n"}]) +Right (NetRc {nrHosts = [], nrMacros = [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\n \nline3\nline4\n"}]}) diff --git a/src-tests/data/test4f.netrc.out b/src-tests/data/test4f.netrc.out --- a/src-tests/data/test4f.netrc.out +++ b/src-tests/data/test4f.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [] [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\n#\nline3\nline4\n"}]) +Right (NetRc {nrHosts = [], nrMacros = [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\n#\nline3\nline4\n"}]}) diff --git a/src-tests/data/test5a.netrc.out b/src-tests/data/test5a.netrc.out --- a/src-tests/data/test5a.netrc.out +++ b/src-tests/data/test5a.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [NetRcHost {nrhName = "", nrhLogin = "anon", nrhPassword = "blah", nrhAccount = ""}] [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\n"},NetRcMacDef {nrmName = "macro2", nrmBody = "line3\nline4\n"}]) +Right (NetRc {nrHosts = [NetRcHost {nrhName = "", nrhLogin = "anon", nrhPassword = "blah", nrhAccount = "", nrhMacros = [NetRcMacDef {nrmName = "macro2", nrmBody = "line3\nline4\n"}]}], nrMacros = [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\n"}]}) diff --git a/src-tests/data/test5b.netrc.out b/src-tests/data/test5b.netrc.out --- a/src-tests/data/test5b.netrc.out +++ b/src-tests/data/test5b.netrc.out @@ -1,1 +1,1 @@ -Right (NetRc [] [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\n \ndefault login anon password blah # comment\n# \n"},NetRcMacDef {nrmName = "macro2", nrmBody = "line3\nline4\n"}]) +Right (NetRc {nrHosts = [], nrMacros = [NetRcMacDef {nrmName = "macro1", nrmBody = "line1\nline2\n \ndefault login anon password blah # comment\n# \n"},NetRcMacDef {nrmName = "macro2", nrmBody = "line3\nline4\n"}]}) diff --git a/src-tests/test-netrc.hs b/src-tests/test-netrc.hs --- a/src-tests/test-netrc.hs +++ b/src-tests/test-netrc.hs @@ -24,18 +24,32 @@ let !retval = IUT.parseNetRc fp raw return (LBC.pack $ show retval) +doGoTest2 :: FilePath -> IO LB.ByteString +doGoTest2 fp = do + raw <- B.readFile fp + let !retval = IUT.parseNetRc fp raw + case retval of + Left e -> return "# netrc parsing failed #" + Right v -> return (LB.pack $ B.unpack $ IUT.netRcToByteString v) + main :: IO () main = do netrcFiles <- findByExtension [".netrc"] "src-tests/data" - let goTests = testGroup "golden" + let goTests = testGroup "ref-samples" [ goldenVsString tn (fp++".out") (doGoTest fp) | fp <- sort netrcFiles , let Just tn = stripPrefix "src-tests/data/" fp ] - defaultMain $ testGroup "Tests" [goTests, qcTests] + let goTests2 = testGroup "ref-samples2" + [ goldenVsString tn (fp++".out2") (doGoTest2 fp) + | fp <- sort netrcFiles + , let Just tn = stripPrefix "src-tests/data/" fp + ] + defaultMain $ testGroup "Tests" [goTests, goTests2, qcTests] + where qcTests = testGroup "QC" [testProperty "roundtrip" propRoundtrip] @@ -65,7 +79,7 @@ c = choose (1,127) `suchThat` (/= 10) instance Arbitrary IUT.NetRc where - arbitrary = IUT.NetRc <$> arbitrary <*> arbitrary + arbitrary = IUT.NetRc <$> listOfArbs 10 <*> listOfArbs 16 instance Arbitrary IUT.NetRcMacDef where arbitrary = IUT.NetRcMacDef <$> (tok `suchThat` (/= "")) <*> body @@ -74,6 +88,11 @@ body = BC.unlines <$> (listOf (fromLine <$> arbitrary)) instance Arbitrary IUT.NetRcHost where - arbitrary = IUT.NetRcHost <$> tok <*> tok <*> tok <*> tok + arbitrary = IUT.NetRcHost <$> tok <*> tok <*> tok <*> tok <*> listOfArbs 3 where tok = fromToken <$> arbitrary + +listOfArbs :: Arbitrary a => Int -> Gen [a] +listOfArbs lim = sized $ \n -> do + n' <- choose (0,n `min` lim) + vectorOf n' arbitrary diff --git a/src/Network/NetRc.hs b/src/Network/NetRc.hs --- a/src/Network/NetRc.hs +++ b/src/Network/NetRc.hs @@ -23,9 +23,10 @@ -- -- As an extension to the @.netrc@-format as described in .e.g. -- , @#@-style comments are --- supported. For simplicity, such comments are only allowed between --- entries. --- +-- tolerated. Comments are currently only allowed before, between, +-- and after @machine@\/@default@\/@macdef@ entries. Be aware though +-- that such @#@-comment are not supported by all @.netrc@-aware +-- applications, including @ftp(1)@. module Network.NetRc ( -- * Types NetRc(..) @@ -53,7 +54,7 @@ import qualified Data.ByteString.Char8 as BC import qualified Data.ByteString.Lazy as LB import Data.Data -import Data.Either (partitionEithers) +import Data.Either (rights, lefts) import Data.List (intersperse, foldl') import Data.Monoid import GHC.Generics @@ -66,42 +67,62 @@ -- -- __Invariant__: fields must not contain any @TAB@s, @SPACE@, or @LF@s. data NetRcHost = NetRcHost - { nrhName :: !ByteString -- ^ Remote machine name (@""@ for @default@-entries) - , nrhLogin :: !ByteString -- ^ @login@ property (@""@ if missing) - , nrhPassword :: !ByteString -- ^ @password@ property (@""@ if missing) - , nrhAccount :: !ByteString -- ^ @account@ property (@""@ if missing) + { nrhName :: !ByteString -- ^ Remote machine name (@""@ for @default@-entries) + , nrhLogin :: !ByteString -- ^ @login@ property (@""@ if missing) + , nrhPassword :: !ByteString -- ^ @password@ property (@""@ if missing) + , nrhAccount :: !ByteString -- ^ @account@ property (@""@ if missing) + , nrhMacros :: [NetRcMacDef] -- ^ associated @macdef@ entries } deriving (Eq,Ord,Show,Typeable,Data,Generic) instance NFData NetRcHost where rnf !_ = () -- | @macdef@ entries defining @ftp@ macros data NetRcMacDef = NetRcMacDef - { nrmName :: !ByteString -- ^ Name of @macdef@ entry (__Invariant__: must not contain any @TAB@s, @SPACE@, or @LF@s) - , nrmBody :: !ByteString -- ^ Raw @macdef@ body (__Invariant__: must not contain null-lines) + { nrmName :: !ByteString -- ^ Name of @macdef@ entry + -- + -- __Invariant__: must not contain any @TAB@s, @SPACE@, or @LF@s + , nrmBody :: !ByteString -- ^ Raw @macdef@ body + -- + -- __Invariant__: must not contain null-lines, i.e. consecutive @LF@s } deriving (Eq,Ord,Show,Typeable,Data,Generic) instance NFData NetRcMacDef where rnf !_ = () -- | Represents (semantic) contents of a @.netrc@ file -data NetRc = NetRc [NetRcHost] [NetRcMacDef] - deriving (Eq,Ord,Show,Typeable,Data,Generic) +data NetRc = NetRc + { nrHosts :: [NetRcHost] -- ^ @machine@\/@default@ entries + -- + -- __Note__: If it exists, the + -- @default@ entry ought to be the + -- last entry, otherwise it can cause + -- later entries to become invisible + -- for some implementations + -- (e.g. @ftp(1)@) + , nrMacros :: [NetRcMacDef] -- ^ Non-associated @macdef@ entries + -- + -- __Note__: @macdef@ entries not + -- associated with host-entries are + -- invisible to some applications + -- (e.g. @ftp(1)@). + } deriving (Eq,Ord,Show,Typeable,Data,Generic) + instance NFData NetRc where rnf (NetRc ms ds) = ms `deepseq` ds `deepseq` () -- | Construct a 'ByteString' 'BB.Builder' netRcToBuilder :: NetRc -> BB.Builder netRcToBuilder (NetRc ms ds) = - mconcat . intersperse nl $ map netRcHostToBuilder ms <> map netRcMacDefToBuilder ds + mconcat . intersperse nl $ map netRcMacDefToBuilder ds <> map netRcHostToBuilder ms where netRcHostToBuilder (NetRcHost {..}) - = mconcat + = mconcat $ [ mline , prop "login" nrhLogin , prop "password" nrhPassword , prop "account" nrhAccount , nl - ] + ] <> (intersperse nl $ map netRcMacDefToBuilder nrhMacros) where mline | B.null nrhName = BB.byteString "default" | otherwise = BB.byteString "machine" <> spc <> BB.byteString nrhName @@ -170,13 +191,25 @@ -- | "Text.Parsec.ByteString" 'P.Parser' for @.netrc@ grammar netRcParsec :: P.Parser NetRc -netRcParsec = (uncurry NetRc . partitionEithers) <$> (wsOrComments0 *> P.sepEndBy netrcEnt wsOrComments1) +netRcParsec = do + entries <- uncurry NetRc . normEnts . splitEithers <$> (wsOrComments0 *> P.sepEndBy netrcEnt wsOrComments1) + + return entries where wsOrComments0 = P.skipMany comment >> P.skipMany (wsChars1 >> P.skipMany comment) wsOrComments1 = P.skipMany1 (wsChars1 >> P.skipMany comment) netrcEnt = (Left <$> hostEnt) <|> (Right <$> macDefEnt) + normEnts [] = ([], []) + normEnts (([], ms):es) = (normEnts' es, ms) + normEnts es = (normEnts' es, []) + + normEnts' :: [([NetRcHost],[NetRcMacDef])] -> [NetRcHost] + normEnts' [] = [] + normEnts' (([], _):_) = error "netRcParsec internal error" + normEnts' ((hs, ms):es) = init hs ++ ((last hs) { nrhMacros = ms } : normEnts' es) + macDefEnt :: P.Parser NetRcMacDef macDefEnt = do void $ P.try (P.string "macdef") @@ -193,7 +226,7 @@ hostEnt = do nam <- mac <|> def ps <- P.many (P.try (wsChars1 *> pval)) - return $! foldl' setFld (NetRcHost nam "" "" "") ps + return $! foldl' setFld (NetRcHost nam "" "" "" []) ps where def = P.try (P.string "default") *> pure "" @@ -203,11 +236,12 @@ tok P. "hostname" -- pval := ((account|username|password) WS+ ) - pval = hlp "login" "loginname" PValLogin <|> - hlp "account" "accountname" PValAccount <|> - hlp "password" "password" PValPassword + pval = hlp "login" PValLogin <|> + hlp "account" PValAccount <|> + hlp "password" PValPassword where - hlp tnam vnam cons = P.try (P.string tnam) *> wsChars1 *> (cons <$> tok P. vnam) + hlp tnam cons = P.try (P.string tnam) *> wsChars1 *> + (cons <$> tok P. (tnam ++ "-value")) setFld n (PValLogin v) = n { nrhLogin = v } setFld n (PValAccount v) = n { nrhAccount = v } @@ -239,3 +273,18 @@ skipToEol = P.skipMany notlf <* (lf <|> P.eof) where notlf = P.noneOf "\n" + +-- | Regroup lst of 'Either's into pair of lists +splitEithers :: [Either l r] -> [([l], [r])] +splitEithers = goL + where + goL [] = [] + goL es = let (pfx,es') = span isLeft es in goR es' (lefts pfx) + + goR [] ls = [(ls,[])] + goR es ls = let (pfx,es') = span isRight es in (ls,rights pfx) : goL es' + + isLeft (Left _) = True + isLeft (Right _) = False + + isRight = not . isLeft