fixes

2 files changed, 21 insertions, 15 deletions

diff --git a/PEM.hs b/PEM.hs
index 7b27e04..f969484 100644
--- a/PEM.hs
+++ b/PEM.hs
@@ -24,7 +24,7 @@ pemParser mtyp = ScanningParser (maybe fndany fndtyp mtyp) pbdy
         let typ = L.take (L.length x0 - 5) x0
         return typ
 
-    pbdy typ xs = (mblob, rs)
+    pbdy typ xs = (mblob, drop 1 rs)
      where
         (ys,rs) = span (/="-----END " <> typ <> "-----") xs
         mblob = PEMBlob typ <$> LW.pack <$> Base64.decode (L.unpack dta)
diff --git a/validatecert.hs b/validatecert.hs
index b082419..a318275 100644
--- a/validatecert.hs
+++ b/validatecert.hs
@@ -10,9 +10,10 @@ import Data.Maybe
 import qualified Data.Map as Map
 import qualified Data.ByteString.Char8 as S
 import qualified Data.ByteString.Lazy.Char8 as L
-import qualified Data.ByteString.Lazy as L.Word8
-import qualified Codec.Binary.Base64 as Base64
+-- import qualified Data.ByteString.Lazy as L.Word8
+-- import qualified Codec.Binary.Base64 as Base64
 import Control.Monad
+import Control.Monad.Fix
 import System.IO.Error
 import System.IO
 import Data.Map             ( Map )
@@ -28,8 +29,6 @@ import PEM
 
 continue e body = either (const $ return ()) body e
 
-while f = fixIO (\v -> f (return v))
-
 digits s = S.all isDigit s
 
 bshow :: Show x => x -> S.ByteString
@@ -55,7 +54,7 @@ parseHeader first_line = parseHeaderWords $ S.words first_line
     parseHeaderWords (channelId:_)
         = Left $ channelId <> " BH message=\"Insufficient words in message.\"\1"
     parseHeaderWords []
-        = Left ""
+        = Left $ "what: " <> bshow first_line <> "\n"
 
 data ValidationError = ValidationError
     { veName :: S.ByteString
@@ -68,6 +67,7 @@ type Cert = PEMBlob
 certSubject :: Cert -> S.ByteString
 certSubject cert = "TODO:certSubject" -- TODO
 
+{-
 certFormatPEM :: Cert -> S.ByteString
 certFormatPEM cert = S.unlines
     [ "-----BEGIN " <> toS (pemType cert) <> "-----"
@@ -78,6 +78,7 @@ certFormatPEM cert = S.unlines
     base64 = Base64.encode $ L.Word8.unpack $ pemBlob cert
     split64s "" = []
     split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta
+-}
 
 data ValidationRequest = ValidationRequest
     { vrHostname :: S.ByteString
@@ -98,14 +99,17 @@ main = do
             exitSuccess
         return $ not $ null $ ["-d","--debug"] `intersect` args
 
-    while $ \next -> do
+    fix $ \next -> do
         e <- tryIOError S.getLine
         continue e $ \first_line -> do
         when (S.all isSpace first_line)
              next
-        flip (either wlog) (parseHeader first_line) $ \(channelId,code,bodylen,body0) -> do
-        body1 <- L.hGet stdin (bodylen - S.length body0)
+        let wlog' s | debug     = wlog s
+                    | otherwise = return ()
+        flip (either wlog') (parseHeader first_line) $ \(channelId,code,bodylen,body0) -> do
         when debug $ wlog $ "GOT " <> "Code=" <> code <> " " <> bshow bodylen <> "\n"
+        body1 <- L.hGet stdin (bodylen - S.length body0)
+                 `catchIOError` (const $ return "")
         let body = L.fromChunks $ body0 : L.toChunks body1
             req = parseRequest body
         when debug $ forM_ (vrSyntaxErrors req) $ \request -> do
@@ -122,19 +126,20 @@ main = do
             response0 = createResponse req responseErrors
             len = bshow $ S.length response0
             response = if Map.null responseErrors
-                        then channelId <> " OK "  <> len <> " " <> response <> "\1"
-                        else channelId <> " ERR " <> len <> " " <> response <> "\1"
+                        then channelId <> " OK "  <> len <> " " <> response0 <> "\1"
+                        else channelId <> " ERR " <> len <> " " <> response0 <> "\1"
         S.putStr response
         hFlush stdout
-        when debug $ wlog $ ">> " <> response <> "\n"
+        when debug $ wlog $ ">> " <> S.init response <> "\n"
+        next
 
 createResponse :: ValidationRequest -> Map S.ByteString ValidationError -> S.ByteString
 createResponse vr responseErrors = S.concat $ zipWith mkresp [0..] $ Map.elems responseErrors
  where
     mkresp i err = "error_name_" <> bshow i <> "=" <> veName err <> "\n"
                  <>"error_reason_" <> bshow i <> "=" <> veReason err <> "\n"
-                 <>"error_cert_" <> bshow i <> "=" <> certFormatPEM (vrCertFromErr err) <> "\n"
-    vrCertFromErr err = vrCerts vr Map.! veCert err
+                 <>"error_cert_" <> bshow i <> "=" <> veCert err <> "\n"
+    -- vrCertFromErr err = vrCerts vr Map.! veCert err
 
 parseRequest body = parseRequest0 vr0 body
  where
@@ -155,7 +160,7 @@ parseRequest body = parseRequest0 vr0 body
      where vr' = vr { vrHostname = toS hostname }
 
     parseRequest0 vr (splitEq -> Just (var,cert)) | "cert_" `L.isPrefixOf` var
-        = parseRequest0 vr' (L.concat rs)
+        = parseRequest0 vr' $ L.unlines rs
      where vr' = maybe vr upd mb
            upd blob = vr { vrCerts = Map.insert (toS var) blob $ vrCerts vr
                          , vrPeerCertId = Just $ fromMaybe (toS var) $ vrPeerCertId vr }
@@ -206,6 +211,7 @@ wlog msg = do
              <> " " <> self
              <> " " <> show pid
              <> " | " <> S.unpack msg
+    hFlush stderr
 
 usage :: String -> [([String],String)] -> String
 usage cmdname argspec = unlines $ intercalate [""] $