Commits

Stefan Saasen  committed aa2c5ca

Add a Tcp client implementation and a pack file parser

  • Participants
  • Parent commits 81e89e9

Comments (0)

Files changed (5)

+module Client where
+
+
+import Data.Bits
+import Network.Socket hiding (recv)
+import Network.Socket.ByteString (recv, sendAll)
+import qualified Data.ByteString.Char8 as C
+import Network.BSD
+import Data.List
+import System.IO
+
+type Request = String
+type Response = C.ByteString
+type Host = String
+type Port = Int
+{-client host port = -}
+
+{-client :: Host -> Port -> Request -> (Response -> ()) -}
+
+sendViaSocket host port payload = withSocketsDo $
+     do addrinfos <- getAddrInfo Nothing (Just host) (Just port)
+        let serveraddr = head addrinfos
+        sock <- socket (addrFamily serveraddr) Stream defaultProtocol
+        connect sock (addrAddress serveraddr)
+        sendAll sock $ C.pack payload
+        msg <- receive sock C.empty
+        sClose sock
+        return msg
+    where receive s acc = do
+            msg <- recv s 4096
+            if C.null msg then return acc else receive s $ C.append acc msg
+        

File PackProtocol.hs

+{-# LANGUAGE OverloadedStrings #-}
+
+
+module PackProtocol where
+
+
+import qualified Data.Attoparsec.Lazy as AL
+import qualified Data.Attoparsec.Char8 as AC
+import qualified Data.ByteString.Char8 as S
+import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.Text as T
+import Data.Attoparsec.Combinator
+import Data.Attoparsec.Char8 hiding (char, space, take)
+
+data PacketLine = FirstLine {
+    objId           :: S.ByteString
+   ,ref             :: S.ByteString
+   ,capabilities    :: [S.ByteString]
+} | RefLine {
+    objId           :: S.ByteString
+   ,ref             :: S.ByteString
+} | NullLine {
+    zeroId          :: S.ByteString
+} deriving (Show, Eq)
+
+parsePacketLine :: L.ByteString -> Maybe PacketLine
+parsePacketLine line = AL.maybeResult $ AL.parse parseLine line
+
+
+parseLine :: Parser PacketLine
+parseLine = choice [parseFirstLine, parseRef]
+
+
+parseFirstLine :: Parser PacketLine
+parseFirstLine = do
+    _ <- parseLength
+    objId' <- AC.take 40
+    space
+    ref' <- takeTill (== '\0')
+    nul
+    capabilities' <- takeTill (== '\n')
+    return $ FirstLine objId' ref' (S.split ' ' capabilities')
+
+parseRef :: Parser PacketLine
+parseRef = do
+    _ <- parseLength
+    objId' <- AC.take 40
+    space
+    ref' <- takeTill (== '\n')
+    return $ RefLine objId' ref'
+
+flushPacket :: Parser S.ByteString
+flushPacket = do
+    packet <- takeTill (== '\n') -- TODO must be "0000" or "0000\n"
+    return packet
+
+pipe, space, dash, colon, comma, quote, single, nul :: Parser Char
+pipe        = satisfy (== '|')
+space       = satisfy (== ' ')
+dash        = satisfy (== '-')
+colon       = satisfy (== ':')
+comma       = satisfy (== ',')
+quote       = satisfy (== '"')
+single      = satisfy (== '\'')
+nul         = satisfy (== '\0')
+
+
+parseLength :: Parser S.ByteString
+parseLength = do
+    hex <- AC.take 4
+    return $ hex
+
+logEntry :: Parser S.ByteString
+logEntry = do
+   entry <- takeTill (== '|')
+   pipe
+   space
+   return $ S.init entry

File TcpClient.hs

+import Network.Socket hiding (send, sendTo, recv, recvFrom)
+import Network.Socket.ByteString (send, recv)
+import qualified Data.ByteString.Char8 as B8
+ 
+client' :: Int -> IO ()
+client' = client "localhost"
+ 
+client :: String -> Int -> IO ()
+client host port = withSocketsDo $ do
+                addrInfo <- getAddrInfo Nothing (Just host) (Just $ show port)
+                let serverAddr = head addrInfo
+                sock <- socket (addrFamily serverAddr) Stream defaultProtocol
+                connect sock (addrAddress serverAddr)
+                msgSender sock
+                sClose sock
+ 
+msgSender :: Socket -> IO ()
+msgSender sock = do
+  msg <- B8.getLine
+  send sock msg
+  rMsg <- recv sock 10
+  B8.putStrLn rMsg
+  if msg == B8.pack "q" then putStrLn "Disconnected!" else msgSender sock
+module Main where
+
+import Data.Char
+import Text.Printf (printf)
+import Numeric
+
+-- The git repository is made available via:
+--  git daemon --reuseaddr --verbose  --base-path=. --export-all
+-- in the parent directory of the git repository 'stash-scm-cache'
+
+-- Run via: runhaskell clone.hs | nc -v localhost 9418
+
+toHex x = showIntAtBase 16 intToDigit x ""
+
+main = do
+    let cmd = "git-upload-pack /stash-scm-cache\0host=localhost\0"
+    printf "%04s%s" (toHex $ (length cmd) + 4) cmd
+    putStrLn "0000" -- Tell the server to disconnect

File ls-remote-tcp.hs

+module Main where
+
+import Data.Char
+import Text.Printf (printf)
+import Numeric
+import Client
+import qualified Data.ByteString.Char8 as C
+
+-- The git repository is made available via:
+--  git daemon --reuseaddr --verbose  --base-path=. --export-all
+-- in the parent directory of the git repository 'stash-scm-cache'
+
+-- Run via: runhaskell ls-remote.hs | nc -v localhost 9418
+
+
+lsRemote :: String -> String
+lsRemote repo = (pktLine $ "git-upload-pack /stash-scm-cache\0host=localhost\0") ++ 
+                flush -- Tell the server to disconnect
+        where flush = "0000\n"
+              toHex x = showIntAtBase 16 intToDigit x ""
+              pktLine msg = (printf "%04s%s" (toHex $ (length msg) + 4) msg)::String
+
+main = do
+    {-conn <- openConnection "localhost" "9418"-}
+    {-sendPayload conn $ lsRemote "stash-scm-cache"-}
+    let payload = lsRemote "stash-scm-cache"
+    putStrLn payload
+    response <- sendViaSocket "localhost" "9418" $ payload
+    C.putStrLn response
+    {-closeConnection conn-}
+