module Database.HandlerSocket.HSClient (
HandSock (..),
connectTo,
closeHS,
runReqNoRespData,
runReqGeneric,
runReqOpen,
runReqFind,
runReqInsert,
runReqUpdate,
runReqDelete
) where
import Data.Word
import Data.Char
import Data.List
import Network.Socket hiding (send,sendTo,recv,recvFrom)
import Network.Socket.ByteString
import System.IO
import qualified Data.ByteString as B
data HandSock = HandSock {getSocket :: Socket, getHandle :: Int}
escapeW :: [Word8] -> [Word8]
escapeW [] = []
escapeW (x:xs) = if x < 16 then 1:(0x40+x):(escapeW xs) else x:(escapeW xs)
escape :: String -> [Word8]
escape str = escapeW $ map (fromIntegral . ord) str
unescapeW :: [Word8] -> [Word8]
unescapeW [] = []
unescapeW (x:xs) =
if x == 1
then case xs of
(y:ys) -> (y0x40):(unescapeW ys)
_ -> []
else x:(unescapeW xs)
unescape :: [Word8] -> String
unescape xs = map (chr . fromIntegral) $ unescapeW xs
decodeResp :: B.ByteString -> [String]
decodeResp = map unescape . mysplit . B.unpack
where
isspace' = (\x -> (x == 9) || (x == 10))
mysplit s = case dropWhile isspace' s of
[] -> []
(10:_) -> []
s1 -> w : (mysplit s2)
where
(w,s2) = break isspace' s1
makeReq :: [String] -> B.ByteString
makeReq = B.pack . (++ [10]) . intercalate [9] . map escape
makeReqOpen :: (Integral a) => a -> String -> String -> String -> String -> B.ByteString
makeReqOpen hand db tb ind cs = makeReq ["P",show hand,db,tb,ind,cs]
makeReqFind :: (Integral a, Integral b) => a -> String -> String -> b -> B.ByteString
makeReqFind hand op v lim = makeReq [show hand,op,"1",v,show lim,"0"]
makeReqInsert :: (Integral a) => a -> [String] -> B.ByteString
makeReqInsert hand vs = makeReq $ [show hand,"+",show (length vs)] ++ vs
makeReqUpdate :: (Integral a) => a -> String -> [String] -> B.ByteString
makeReqUpdate hand key newvs = makeReq $ [show hand,"=","1",key,"1","0","U"] ++ newvs
makeReqDelete :: (Integral a) => a -> String -> B.ByteString
makeReqDelete hand key = makeReq [show hand,"=","1",key,"1","0","D"]
connectTo :: String -> String -> Int -> IO HandSock
connectTo host port hand = do
addrinfos <- getAddrInfo Nothing (Just host) (Just port)
let addr = head addrinfos
let addr' = addr {addrFamily = AF_INET, addrSocketType = Stream, addrProtocol = 6}
sock <- socket AF_INET Stream 6
connect sock (addrAddress addr')
return $ HandSock sock hand
runReqBool :: HandSock -> B.ByteString -> IO Bool
runReqBool (HandSock s h) req = do
sendAll s req
resp <- recv s 1024
if B.null resp
then return False
else return $ 48 == (B.head resp)
runReqNoRespData :: HandSock -> [String] -> IO Bool
runReqNoRespData hs vs = runReqBool hs $ makeReq vs
runReqGeneric :: HandSock -> [String] -> IO [String]
runReqGeneric (HandSock s h) vs = do
let req = makeReq vs
sendAll s req
fmap decodeResp $ recv s 4096
runReqOpen :: HandSock -> String -> String -> String -> String -> IO Bool
runReqOpen hs db tb ind cs = runReqBool hs $ makeReqOpen (getHandle hs) db tb ind cs
runReqFind :: (Integral a) => HandSock -> String -> String -> a -> IO [[String]]
runReqFind (HandSock s h) op v lim = do
let req = makeReqFind h op v lim
sendAll s req
resp <- fmap decodeResp $ recv s 4096
case resp of
(o:i:xs) -> return $ mygroup (read i :: Int) xs
_ -> return []
where
mygroup _ [] = []
mygroup i xs = l:(mygroup i r)
where (l,r) = splitAt i xs
runReqInsert :: HandSock -> [String] -> IO Bool
runReqInsert hs vs = runReqBool hs $ makeReqInsert (getHandle hs) vs
runReqUpdate :: HandSock -> String -> [String] -> IO Bool
runReqUpdate hs v0 vs = runReqBool hs $ makeReqUpdate (getHandle hs) v0 vs
runReqDelete :: HandSock -> String -> IO Bool
runReqDelete hs key = runReqBool hs $ makeReqDelete (getHandle hs) key
closeHS :: HandSock -> IO ()
closeHS hs = sClose (getSocket hs)