module Network.NetRc
(
NetRc(..)
, NetRcHost(..)
, NetRcMacDef(..)
, netRcToBuilder
, netRcToByteString
, netRcParsec
, parseNetRc
, readUserNetRc
) where
import Control.Applicative
import Control.DeepSeq
import Control.Monad
import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Char8 as BC
import qualified Data.ByteString.Lazy as LB
import Data.Data
import Data.Either (rights, lefts)
import Data.List (intersperse, foldl')
import Data.Monoid
import GHC.Generics
import System.Environment
import System.IO.Error
import qualified Text.Parsec as P
import qualified Text.Parsec.ByteString as P
data NetRcHost = NetRcHost
{ nrhName :: !ByteString
, nrhLogin :: !ByteString
, nrhPassword :: !ByteString
, nrhAccount :: !ByteString
, nrhMacros :: [NetRcMacDef]
} deriving (Eq,Ord,Show,Typeable,Data,Generic)
instance NFData NetRcHost where rnf !_ = ()
data NetRcMacDef = NetRcMacDef
{ nrmName :: !ByteString
, nrmBody :: !ByteString
} deriving (Eq,Ord,Show,Typeable,Data,Generic)
instance NFData NetRcMacDef where rnf !_ = ()
data NetRc = NetRc
{ nrHosts :: [NetRcHost]
, nrMacros :: [NetRcMacDef]
} deriving (Eq,Ord,Show,Typeable,Data,Generic)
instance NFData NetRc where
rnf (NetRc ms ds) = ms `deepseq` ds `deepseq` ()
netRcToBuilder :: NetRc -> BB.Builder
netRcToBuilder (NetRc ms ds) =
mconcat . intersperse nl $ map netRcMacDefToBuilder ds <> map netRcHostToBuilder ms
where
netRcHostToBuilder (NetRcHost {..})
= 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
prop lab val | B.null val = mempty
| otherwise = spc <> BB.byteString lab <> spc <> BB.byteString val
netRcMacDefToBuilder (NetRcMacDef {..})
= BB.byteString "macdef" <> spc <> BB.byteString nrmName <>
(if B.null nrmBody then mempty else nl <> BB.byteString nrmBody) <>
nl
spc = BB.charUtf8 ' '
nl = BB.charUtf8 '\n'
netRcToByteString :: NetRc -> ByteString
#if MIN_VERSION_bytestring(0,10,0)
netRcToByteString = LB.toStrict . BB.toLazyByteString . netRcToBuilder
#else
netRcToByteString = B.concat . LB.toChunks . BB.toLazyByteString . netRcToBuilder
#endif
parseNetRc :: P.SourceName -> ByteString -> Either P.ParseError NetRc
parseNetRc = P.parse (netRcParsec <* P.eof)
readUserNetRc :: IO (Maybe (Either P.ParseError NetRc))
readUserNetRc = do
mhome <- lookupEnv "HOME"
case mhome of
Nothing -> return Nothing
Just "" -> return Nothing
Just ho -> do
let fn = ho ++ "/.netrc"
ret <- tryIOError (B.readFile fn)
case ret of
Left e | isDoesNotExistError e -> return Nothing
| otherwise -> ioError e
Right b -> return $! Just $! parseNetRc fn b
#if !(MIN_VERSION_base(4,6,0))
where
lookupEnv k = lookup k <$> getEnvironment
#endif
netRcParsec :: P.Parser NetRc
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")
wsChars1
n <- tok P.<?> "macdef-name"
P.skipMany (P.oneOf "\t ")
lf
bodyLines <- P.sepEndBy neline lf
return $! NetRcMacDef n (BC.pack $ unlines bodyLines)
where
neline = P.many1 (P.noneOf "\n")
hostEnt :: P.Parser NetRcHost
hostEnt = do
nam <- mac <|> def
ps <- P.many (P.try (wsChars1 *> pval))
return $! foldl' setFld (NetRcHost nam "" "" "" []) ps
where
def = P.try (P.string "default") *> pure ""
mac = do
P.try (void $ P.string "machine")
wsChars1
tok P.<?> "hostname"
pval = hlp "login" PValLogin <|>
hlp "account" PValAccount <|>
hlp "password" PValPassword
where
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 }
setFld n (PValPassword v) = n { nrhPassword = v }
tok :: P.Parser ByteString
tok = BC.pack <$> P.many1 notWsChar P.<?> "token"
data PVal = PValLogin !ByteString
| PValAccount !ByteString
| PValPassword !ByteString
deriving Show
lf, wsChar, wsChars1 :: P.Parser ()
lf = void (P.char '\n') P.<?> "line-feed"
wsChar = void (P.oneOf "\t \n")
wsChars1 = P.skipMany1 wsChar
notWsChar :: P.Parser Char
notWsChar = P.noneOf "\t \n"
comment :: P.Parser ()
comment = (P.char '#' *> skipToEol) P.<?> "comment"
skipToEol :: P.Parser ()
skipToEol = P.skipMany notlf <* (lf <|> P.eof)
where
notlf = P.noneOf "\n"
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