module Network.FTP.Client.Parser(parseReply, parseGoodReply,
toPortString, fromPortString,
debugParseGoodReply,
respToSockAddr,
FTPResult,
unexpectedresp, isxresp,
forcexresp,
forceioresp,
parseDirName)
where
import Text.ParserCombinators.Parsec
import Text.ParserCombinators.Parsec.Utils
import Data.List.Utils
import Data.Bits.Utils
import Data.String.Utils
import System.Log.Logger
import Network.Socket(SockAddr(..), PortNumber(..), inet_addr, inet_ntoa)
import System.IO(Handle, hGetContents)
import System.IO.Unsafe
import Text.Regex
import Data.Word
type FTPResult = (Int, [String])
logit :: String -> IO ()
logit m = debugM "Network.FTP.Client.Parser" ("FTP received: " ++ m)
unexpectedresp m r = "FTP: Expected " ++ m ++ ", got " ++ (show r)
isxresp desired (r, _) = r >= desired && r < (desired + 100)
forcexresp desired r = if isxresp desired r
then r
else error ((unexpectedresp (show desired)) r)
forceioresp :: Int -> FTPResult -> IO ()
forceioresp desired r = if isxresp desired r
then return ()
else fail (unexpectedresp (show desired) r)
crlf :: Parser String
crlf = string "\r\n" <?> "CRLF"
sp :: Parser Char
sp = char ' '
code :: Parser Int
code = do
s <- codeString
return (read s)
codeString :: Parser String
codeString = do
first <- oneOf "123456789" <?> "3-digit reply code"
remaining <- count 2 digit <?> "3-digit reply code"
return (first : remaining)
specificCode :: Int -> Parser Int
specificCode exp = do
s <- string (show exp) <?> ("Code " ++ (show exp))
return (read s)
line :: Parser String
line = do
x <- many (noneOf "\r\n")
crlf
return x
singleReplyLine :: Parser (Int, String)
singleReplyLine = do
x <- code
sp
text <- line
return (x, text)
expectedReplyLine :: Int -> Parser (Int, String)
expectedReplyLine expectedcode = do
x <- specificCode expectedcode
sp
text <- line
return (x, text)
startOfMultiReply :: Parser (Int, String)
startOfMultiReply = do
x <- code
char '-'
text <- line
return (x, text)
multiReplyComponent :: Parser [String]
multiReplyComponent = (try (do
notMatching (do
codeString
sp
) "found unexpected code"
thisLine <- line
remainder <- multiReplyComponent
return (thisLine : remainder)
)
) <|> return []
multiReply :: Parser FTPResult
multiReply = try (do
x <- singleReplyLine
return (fst x, [snd x])
)
<|> (do
start <- startOfMultiReply
component <- multiReplyComponent
end <- expectedReplyLine (fst start)
return (fst start, snd start : (component ++ [snd end]))
)
parseReply :: String -> FTPResult
parseReply input =
case parse multiReply "(unknown)" input of
Left err -> error ("FTP: " ++ (show err))
Right reply -> reply
parseGoodReply :: String -> IO FTPResult
parseGoodReply input =
let reply = parseReply input
in
if (fst reply) >= 400
then fail ("FTP:" ++ (show (fst reply)) ++ ": " ++ (join "\n" (snd reply)))
else return reply
debugParseGoodReply :: String -> IO FTPResult
debugParseGoodReply contents =
let logPlugin :: String -> String -> IO String
logPlugin [] [] = return []
logPlugin [] accum = do
logit accum
return []
logPlugin (x:xs) accum =
case x of
'\n' -> do logit (strip (accum))
next <- unsafeInterleaveIO $ logPlugin xs []
return (x : next)
y -> do
next <- unsafeInterleaveIO $ logPlugin xs (accum ++ [x])
return (x : next)
in
do
loggedStr <- logPlugin contents []
parseGoodReply loggedStr
toPortString :: SockAddr -> IO String
toPortString (SockAddrInet port hostaddr) =
let wport = (fromIntegral (port))::Word16
in do
hn <- inet_ntoa hostaddr
return ((replace "." "," hn) ++ "," ++
(genericJoin "," . getBytes $ wport))
toPortString _ =
error "toPortString only works on AF_INET addresses"
fromPortString :: String -> IO SockAddr
fromPortString instr =
let inbytes = split "," instr
hostname = join "." (take 4 inbytes)
portbytes = map read (drop 4 inbytes)
in
do
addr <- inet_addr hostname
return $ SockAddrInet (fromInteger $ fromBytes portbytes) addr
respToSockAddrRe = mkRegex("([0-9]+,){5}[0-9]+")
respToSockAddr :: FTPResult -> IO SockAddr
respToSockAddr f =
do
forceioresp 200 f
if (fst f) /= 227 then
fail ("Not a 227 response: " ++ show f)
else case matchRegexAll respToSockAddrRe (head (snd f)) of
Nothing -> fail ("Could not find remote endpoint in " ++ (show f))
Just (_, x, _, _) -> fromPortString x
parseDirName :: FTPResult -> Maybe String
parseDirName (257, name:_) =
let procq [] = []
procq ['"'] = []
procq ('"' : '"' : xs) = '"' : procq xs
procq (x:xs) = x : procq xs
in
if head name /= '"'
then Nothing
else Just (procq (tail name))