hsrelp 0.1.0.0 → 0.1.0.1

raw patch · 2 files changed

+54/−53 lines, 2 files

Files

• hsrelp.cabal +5/−5
• src/Network/RELP/Server.hs +49/−48

@@ -1,5 +1,5 @@ name:                hsrelp-version:             0.1.0.0+version:             0.1.0.1 synopsis:            RELP (Reliable Event Logging Protocol) server implementation description:            The specification of the RELP protocol:@@ -9,9 +9,9 @@ bug-reports:         https://github.com/verrens/hsrelp/issues license:             BSD3 license-file:        LICENSE-author:              Denis Afonin-maintainer:          verrens@yandex.ru--- copyright:           +author:              Denis Afonin <verrens@yandex.ru>+maintainer:          Denis Afonin <verrens@yandex.ru>+copyright:           (c) 2016 Denis Afonin category:            Network build-type:          Simple -- extra-source-files:  @@ -20,7 +20,7 @@ library   -- other-modules:          -- other-extensions:    -  build-depends:    base >=4.8 && <4.9,+  build-depends:    base >= 4 && < 5,                     network,                     bytestring,                     utf8-string,

@@ -43,6 +43,7 @@  type RelpOffers = [(ByteString, ByteString)] + -- | Provides a simple RELP server. runRelpServer :: PortNumber -- ^ Port to listen on   -> RelpMessageHandler -- ^ Message handler@@ -56,54 +57,6 @@   sClose sock   where -  relpRsp :: Socket -> RelpMessage -> String -> IO ()-  relpRsp sock msg reply = sendAll sock mkReply-    -- putStrLn $ prettyHex $ B8.toStrict mkReply-    where-    mkReply = B8.pack $ (show $ relpTxnr msg) ++ " rsp "-      ++ (show $ length reply) ++ " " ++ reply ++ "\n"--  relpAck :: Socket -> RelpMessage -> IO ()-  relpAck sock msg = relpRsp sock msg "200 OK"--  relpNAck :: Socket -> RelpMessage -> String -> IO ()-  relpNAck sock msg err = relpRsp sock msg $ "500 " ++ err--  relpParser :: Parser RelpMessage-  relpParser = do-    txnr <- decimal <* space-    command <- parseCommand <* space-    datalen <- decimal <* space-    content <- take (datalen + 1) -- <* trailer-    return $ RelpMessage txnr command content-    where-    decimal :: Integral a => Parser a-    decimal = B.foldl' step 0 `fmap` takeWhile1 isDecimal where-      step a c = a * 10 + fromIntegral (c - 48)-      isDecimal c = c >= 48 && c <= 57-    space = word8 32-    trailer = word8 10-    parseCommand =-      string "syslog" *> return RelpSYSLOG-      <|> string "close" *> return RelpCLOSE-      <|> string "open" *> return RelpOPEN-      <|> string "rsp" *> return RelpRSP-      <|> RelpCommand <$> takeWhile1 (/= 32)--  relpOffersParser :: Parser RelpOffers -  relpOffersParser = many' $ pair <* word8 sep-    where-    sep = 10 -- \n-    der = 61 -- '='-    pair = liftA2 (,)-      (takeWhile1 (\c-> c /= der && c /= sep))-      (word8 der *> takeWhile1 (/= sep) <|> return "")--  -- just shortcuts-  parse_ err ok p = either err ok . parseOnly p-  parseLazy_ err ok p = either err ok . LBP.eitherResult . LBP.parse p--   handleConnection sock = do     accept sock >>= forkIO . handleMessage     handleConnection sock@@ -138,3 +91,51 @@       putStrLn ("ERROR: strange message command: " ++ show msg)       relpNAck sock msg "unexpected message command"       return False+++relpParser :: Parser RelpMessage+relpParser = do+  txnr <- decimal <* space+  command <- parseCommand <* space+  datalen <- decimal <* space+  content <- take (datalen + 1) -- <* trailer+  return $ RelpMessage txnr command content+  where+  decimal :: Integral a => Parser a+  decimal = B.foldl' step 0 `fmap` takeWhile1 isDecimal where+    step a c = a * 10 + fromIntegral (c - 48)+    isDecimal c = c >= 48 && c <= 57+  space = word8 32+  trailer = word8 10+  parseCommand =+    string "syslog" *> return RelpSYSLOG+    <|> string "close" *> return RelpCLOSE+    <|> string "open" *> return RelpOPEN+    <|> string "rsp" *> return RelpRSP+    <|> RelpCommand <$> takeWhile1 (/= 32)++relpOffersParser :: Parser RelpOffers +relpOffersParser = many' $ pair <* word8 sep+  where+  sep = 10 -- \n+  der = 61 -- '='+  pair = liftA2 (,)+    (takeWhile1 (\c-> c /= der && c /= sep))+    (word8 der *> takeWhile1 (/= sep) <|> return "")++relpRsp :: Socket -> RelpMessage -> String -> IO ()+relpRsp sock msg reply = sendAll sock mkReply+  -- putStrLn $ prettyHex $ B8.toStrict mkReply+  where+  mkReply = B8.pack $ (show $ relpTxnr msg) ++ " rsp "+    ++ (show $ length reply) ++ " " ++ reply ++ "\n"++relpAck :: Socket -> RelpMessage -> IO ()+relpAck sock msg = relpRsp sock msg "200 OK"++relpNAck :: Socket -> RelpMessage -> String -> IO ()+relpNAck sock msg err = relpRsp sock msg $ "500 " ++ err++-- just shortcuts+parse_ err ok p = either err ok . parseOnly p+parseLazy_ err ok p = either err ok . LBP.eitherResult . LBP.parse p