diff --git a/LysKom.hs b/LysKom.hs
index 7c6abf2f1e5358eef287079bd87efa154a873cdf..255d661728632d6a5ae6246f766c75259bcacf59 100644
--- a/LysKom.hs
+++ b/LysKom.hs
@@ -48,7 +48,6 @@ data KomType = KomType
-- deriving ({-Functor, {-Applicative,-} Monad, MonadIO, MonadState KomType-})
type LysKom a = StateT KomType IO a
-
-- instance Applicative LysKom where
-- pure = return
-- (<*>) = ap
@@ -60,6 +59,11 @@ type LysKom a = StateT KomType IO a
-- mempty = return mempty
-- mappend = liftM2 mappend
+data KomError = KomError Int Int
+ | ParseError String
+ | ProtocolError String
+ deriving (Show)
+
getRefNo :: LysKom Int
getRefNo = do
ref <- get
@@ -113,13 +117,21 @@ parsePacketError = do
errorCode <- decimal
char ' '
errorStatus <- decimal
+ char '\n'
return $ PacketError refNo errorCode errorStatus
-parseInput :: Parser PacketHeader
-parseInput = choice [ parseSuccess
- , parseAsync
- , parseProtocolError
- , parsePacketError ]
+ffff :: PacketHeader -> Either KomError a
+ffff p = case p of
+ (PacketProtocolError msg) -> Left $ ProtocolError msg
+ -- Done bs (PacketAsync t) -> (bs, Right True)
+ -- Done bs (PacketSuccess ref) -> (bs, Right False)
+ (PacketError ref code status) -> Left $ KomError code status
+
+parseInput :: LineFormat a => Parser a -> Parser (Either KomError a)
+parseInput p = choice [ (parseSuccess *> p) <&> Right
+ , (parseAsync *> p) <&> Right
+ , parseProtocolError <&> ffff
+ , parsePacketError <&> ffff ]
getSocket :: HostName -> ServiceName -> IO (Socket, SockAddr)
getSocket addr port = do
@@ -148,17 +160,17 @@ runKom sock kom = do
-- tid <- liftIO (forkIO $ inputLoop sock mv)
runStateT kom (KomType 0 sock)
-inp :: Socket -> IO B.ByteString
-inp sock = do
- resp <- parseWith (recv sock 1) parseInput ""
- case resp of
- Fail bs ctxs err -> (putStrLn $ "ParseError: " ++ show err ++ ", " ++ show bs ++ ", " ++ show ctxs) >> return ""
- Done bs (PacketProtocolError msg) -> (putStrLn $ "ProtocollError: " ++ show msg) >> return ""
- Done bs (PacketAsync t) -> (putStrLn $ "recieved async" ++ show bs) >> return ""
- Done bs (PacketSuccess ref) -> putStrLn "Got something" >> return bs
- Done bs (PacketError ref code status) -> (putStrLn $ "error" ++ show code) >> return ""
-
-request :: LineFormat a => Builder -> LysKom a
+{-
+fff resp = case resp of
+ Fail bs ctxs err -> (bs, Left $ ParseError err)
+ Done bs (PacketProtocolError msg) -> (bs, Left $ ProtocolError msg)
+ Done bs (PacketAsync t) -> (bs, Right True)
+ Done bs (PacketSuccess ref) -> (bs, Right False)
+ Done bs (PacketError ref code status) -> (bs, Left $ KomError code status)
+-}
+
+
+request :: LineFormat a => Builder -> LysKom (Either KomError a)
request builder = do
refNo <- getRefNo
let msg = intDec refNo <> char7 ' ' <> builder <> char7 '\n'
@@ -171,12 +183,26 @@ request builder = do
liftIO $ send sock $ bs
liftIO $ putStrLn "sent"
- bs <- (liftIO $ inp sock)
- liftIO (putStrLn $ "got something back " ++ show bs)
- resp <- liftIO $ parseWith (recv sock 1) ((many' (ATTO.char8 ' ')) *> decoder <* char '\n') bs
- case resp of
- -- Fail _ _ _ -> return ()
- Done bs b -> return b
+ -- bs <- (liftIO $ inp sock)
+
+ res <- liftIO $ parseWith (recv sock 1) (parseInput (many' (ATTO.char8 ' ') *> decoder <* char '\n')) ""
+ case res of
+ Fail bs ctxs err -> return . Left . ParseError $ err
+ Done bs b -> return b
+
+ -- let (bs, eth) = fff resp
+
+ -- return . Left . ParseError $ ""
+
+ -- case eth of
+ -- Left e -> return e
+ -- Right False ->
+ -- -- resp <- liftIO $ parseWith (recv sock 1) ((many' (ATTO.char8 ' ')) *> decoder <* char '\n') bs
+ -- case resp of
+ -- Fail bs ctxs err -> Left $ ParseError err
+ -- Done bs b -> return $ Right b
+
+ -- liftIO (putStrLn $ "got something back " ++ show bs)
-- liftIO $ async (readMVar mv)
diff --git a/LysKom/Internal/CodeGen.hs b/LysKom/Internal/CodeGen.hs
index d0b9f19f8857fdd0f1fafdc90775bd1f57af354d..9c3006e0206b2f60726c1fdb6b423131c420b362 100644
--- a/LysKom/Internal/CodeGen.hs
+++ b/LysKom/Internal/CodeGen.hs
@@ -16,6 +16,7 @@ import Data.Maybe (maybe)
import Control.Concurrent.Async (Async)
import LysKom.LineFormat
+import LysKom
import Data.Int
import qualified Data.List as L
@@ -207,7 +208,9 @@ f (Request name n args ret) = do
[ SigD nn $
arrow $ [ lystype t | (_,t) <- args ]
++ [ AppT (ConT . mkName $ "LysKom")
- $ maybe (TupleT 0) lystype ret ]
+ $ AppT (AppT (ConT ''Either)
+ (ConT ''KomError))
+ $ maybe (TupleT 0) lystype ret ]
, FunD nn [Clause (map VarP syms) (NormalB body) []]
]
diff --git a/test.hs b/test.hs
index 2654b4d3554f763b6618115b1bff78c968eb2ff2..3828d025e97a2d6ca3cc506de1153f50cc7491dc 100644
--- a/test.hs
+++ b/test.hs
@@ -5,6 +5,8 @@ import Control.Concurrent.Async
import Control.Monad.IO.Class
import Data.Attoparsec.ByteString
+import Control.Monad
+
import Output
req76 :: String -> Builder
@@ -19,28 +21,22 @@ main :: IO ()
main = do
sock <- lyskomConnect "kom.lysator.liu.se" "lyskom" "hugo%gandalf.adrift.space"
runKom sock $ do
- s1 <- lookupZName7 "Hugo Hörnquist" True False
- let pn = confNo . head $ s1
- liftIO (putStrLn $ "Response: " ++ show pn)
-
- login4 pn "INSERT PASSWORD HERE" True
- -- liftIO (putStrLn $ "Response: " ++ show s2)
-
- time <- getTime1
- liftIO (putStrLn . show $ time)
-
- s1 <- lookupZName7 "Root (@) Lysator" False True
- let cn = confNo . head $ s1
- --liftIO (putStrLn $ "Response: " ++ show s1)
-
- s1 <- queryReadTexts11 pn cn False 0
- liftIO (putStrLn $ "Response: " ++ show s1)
-
- {-
- bs <- request $ req76 "Alexander Rehnman"
- s2 <- liftIO (wait bs)
- liftIO (putStrLn $ "Response: " ++ show s2)
- -}
- return ()
+ s <- lookupZName7 "Hugo Hörnquist" True False
+ case s of
+ Left err -> return ()
+ Right (x:xs) -> do
+ let pn = confNo x
+
+ login4 pn "PASSWORD GOES HERE" True
+
+ s <- lookupZName7 "Root (@) Lysator" False True
+ case s of
+ Left _ -> return ()
+ Right (x:xn) -> do
+ let cn = confNo x
+ s <- queryReadTexts11 pn cn False 0
+ case s of
+ Left _ -> return ()
+ Right resp -> liftIO (putStrLn . show $ resp)
putStrLn "bye"