tds (empty) → 0.1.0.0
raw patch · 12 files changed
+2577/−0 lines, 12 filesdep +attoparsecdep +attoparsec-binarydep +basesetup-changed
Dependencies added: attoparsec, attoparsec-binary, base, bytestring, hostname, mtl, network, stm, streaming, streaming-attoparsec, streaming-bytestring, tardis, tds, text, transformers, unix, vector
Files
- Database/TDS.hs +8/−0
- Database/TDS/Connection.hs +589/−0
- Database/TDS/Login.hs +76/−0
- Database/TDS/Proto.hs +1285/−0
- Database/TDS/Proto/Errors.hs +23/−0
- Database/TDS/Query.hs +179/−0
- Database/TDS/Types.hs +312/−0
- LICENSE +8/−0
- README.md +8/−0
- Setup.hs +2/−0
- src/Test.hs +22/−0
- tds.cabal +65/−0
+ Database/TDS.hs view
@@ -0,0 +1,8 @@+module Database.TDS+ ( module Database.TDS.Types+ , module Database.TDS.Login+ , module Database.TDS.Query ) where++import Database.TDS.Types+import Database.TDS.Login+import Database.TDS.Query
+ Database/TDS/Connection.hs view
@@ -0,0 +1,589 @@+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}++module Database.TDS.Connection+ ( newConnection+ ) where++import Database.TDS.Types+import Database.TDS.Proto++import Control.Concurrent+import Control.Concurrent.STM+import Control.Exception ( SomeException, IOException+ , Exception, throwIO, bracket+ , catch, finally, onException )+import Control.Exception (mask)+import Control.Monad.IO.Class+import Control.Monad.Identity+import Control.Monad.Trans++import Data.Bits+import qualified Data.ByteString as BS+import qualified Data.ByteString.Internal as IBS+import qualified Data.ByteString.Streaming as SBS+import Data.Char+import Data.Maybe (fromMaybe)+import Data.Monoid ((<>))+import Data.Proxy+import Data.Text (Text)+import Data.Word++import Foreign.C.Types+import Foreign.ForeignPtr+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable++import qualified Network.Socket as BSD++import qualified Streaming as S+import qualified Streaming.Prelude as S++type family IsCancelable (resp :: ResponseInfo a) :: Bool where+ IsCancelable ('ExpectsResponse ('ResponseType r a)) = r+ IsCancelable _ = 'False++data SomeSentPacket where+ SomeSentPacket :: Show d+ => Packet sender resp d Identity+ -> CancelInfo (IsCancelable resp)+ -> SomeSentPacket++data TDSCanceledException+ = TDSCanceled+ deriving Show+instance Exception TDSCanceledException++data TDSWasCanceledException+ = TDSWasCanceled+ deriving Show+instance Exception TDSWasCanceledException++data WriteEnd+ = WriteEnd !BSD.Socket++ -- Output buffer+ !(Maybe (ForeignPtr (), CSize))++data ReadEnd = ReadEnd !BSD.Socket++data ConnectionState+ = ConnectionQuit+ | ConnectionState+ { connectionWriteSock :: TVar (Either ThreadId WriteEnd)+ , connectionReadSock :: TVar (Either ThreadId ReadEnd)++ , connectionCurReq :: TVar (Maybe SomeSentPacket)++ , connectionCurState :: TVar ClientState++ -- Information on current database, locale, etc+ , connectionEnvironment :: !ClientEnv+ }++closeWriteEnd :: WriteEnd -> IO ()+closeWriteEnd (WriteEnd _ _) = pure ()++closeReadEnd :: ReadEnd -> IO ()+closeReadEnd (ReadEnd s) = BSD.close s++-- | Start a new connection to a TDS server+newConnection :: Options -> IO Connection+newConnection opts = do+ -- TODO UNIX, pipe, or other transport possibilities+ let opts' = defaultOptions <> opts+ connInfo = _tdsConnInfo opts'++ addrInfo = BSD.defaultHints+ { BSD.addrSocketType = BSD.Stream }++ addrs <- BSD.getAddrInfo (Just addrInfo) (_tdsConnHost connInfo)+ (show <$> _tdsConnPort connInfo)+ `catch` \(e :: IOException) ->+ throwIO (tdsErrorNoReq+ TDSNoSuchHost Connecting+ (show e))++ case addrs of+ [] -> throwIO (tdsErrorNoReq+ TDSNoSuchHost Connecting+ "No addresses returned by getAddrInfo")+ addr:_ ->+ do sock <- BSD.socket (BSD.addrFamily addr)+ (BSD.addrSocketType addr)+ (BSD.addrProtocol addr)+ `catch` \(e :: IOException) ->+ throwIO (tdsErrorNoReq+ TDSSocketError Connecting+ (show e))++ BSD.connect sock (BSD.addrAddress addr)+ `catch` (\(e :: IOException) ->+ throwIO (tdsErrorNoReq TDSSocketError Connecting+ (show e)))+ `onException` BSD.close sock++ writeV <- newTVarIO (Right (WriteEnd sock Nothing))+ readV <- newTVarIO (Right (ReadEnd sock))++ reqV <- newTVarIO Nothing++ stV <- newTVarIO Connecting++ let connSt = ConnectionState writeV readV reqV stV+ (clientEnvFromOptions opts)+ connStV <- newTVarIO connSt++ pure (Connection (sendPacket opts connStV)+ (cancel connStV)+ (quit connStV)+ stV opts)++debugPtr :: Ptr a -> CSize -> IO ()+debugPtr _ _ = pure ()+-- debugPtr ptr' sz+-- | sz > width =+-- do putStrLn . foldMap formatHex =<< forM [0..width - 1] (peek . plusPtr ptr)+-- debugPtr (ptr' `plusPtr` width) (sz - width)+-- | otherwise =+-- putStrLn . foldMap formatHex =<< forM [0..fromIntegral sz - 1] (peek . plusPtr ptr)+-- +-- where+-- width :: Num a => a+-- width = 8+-- +-- ptr = castPtr ptr'+-- +-- formatHex :: Word8 -> String+-- formatHex b =+-- let hi = fromIntegral ((b `shiftR` 4) .&. 0xF)+-- lo = fromIntegral (b .&. 0xF)+-- in intToDigit hi : intToDigit lo : ' ' : []++sendPackets :: BSD.Socket -> ForeignPtr () -> CSize+ -> SplitPacket 'Client resp d -> IO ()+sendPackets sock fPtr bufSz =+ withForeignPtr fPtr . go+ where+ go pkt ptr =+ case pktData pkt of+ LastPacket writePkt ->+ do pktSz <- writePkt (ptr `plusPtr` fromIntegral pktHdrSz)+ let totalSz = fromIntegral (pktSz + pktHdrSz)++ let hdr = pktHdr pkt+ writeHdr ptr (hdr { pktHdrStatus = pktHdrStatus hdr <>+ pktStatusEndOfMessage+ , pktHdrLength = fromIntegral totalSz })++ debugPtr ptr totalSz++ BSD.sendBuf sock (castPtr ptr) (fromIntegral totalSz)+ `catch` \(e :: SomeException) -> do+ putStrLn ("Exception " ++ show e)+ error "Bad"++ pure ()+ OnePacket writePkt ->+ do pkt' <- writePkt (ptr `plusPtr` fromIntegral pktHdrSz)++ let hdr = pktHdr pkt+ writeHdr ptr (hdr { pktHdrLength = fromIntegral bufSz })++ debugPtr ptr bufSz+ BSD.sendBuf sock (castPtr ptr) (fromIntegral bufSz)++ go pkt' ptr++recvExactly :: BSD.Socket -> Ptr a -> Word16 -> IO ()+recvExactly sock p sz = do+ recvd <- fromIntegral <$> BSD.recvBuf sock (castPtr p) (fromIntegral sz)+ if recvd == sz+ then pure ()+ else recvExactly sock (p `plusPtr` fromIntegral recvd) (sz - recvd)++dataStream :: ReadEnd -> CancelInfo resp -> SBS.ByteString IO ()+dataStream (ReadEnd sock) cancel = do+ hdr <-+ liftIO . alloca $ \hdrP ->+ recvExactly sock (hdrP :: Ptr Word64) 8 >>+ readHdr (TabularResult :: PacketType 'Server 'NoResponse ()) hdrP++ case hdr of+ Nothing -> fail "Invalid header"+ Just hdr' -> do+ let pktLength = pktHdrLength hdr' - 8++ bufSz = 65536 - 8++ getChunk :: Word16 -> SBS.ByteString IO ()+ getChunk 0 = pure ()+ getChunk len = do+ case cancel of+ Cancelable isCanceled sync -> do+ cancelSt <- lift (atomically (readTVar isCanceled))+ when cancelSt (liftIO (throwIO TDSWasCanceled))+ _ -> pure ()++ chunk <-+ liftIO $ bracket startRead (\_ -> endRead) $ \_ -> do+ fPtr <- mallocForeignPtrBytes (fromIntegral len)+ actuallyRead <-+ withForeignPtr fPtr $ \ptr -> do+ bytesRead <- BSD.recvBuf sock ptr (fromIntegral len)+ debugPtr ptr (fromIntegral bytesRead)+ pure bytesRead+ pure (IBS.fromForeignPtr fPtr 0 actuallyRead)++ SBS.chunk chunk++ getChunk (len - fromIntegral (BS.length chunk))++ (startRead, endRead) =+ case cancel of+ Cancelable _ sync ->+ (atomically $ takeTMVar sync,+ atomically $ putTMVar sync ())+ _ -> (pure (), pure ())++ liftIO endRead+ getChunk pktLength++ if pktHdrStatus hdr' `hasStatus` pktStatusEndOfMessage+ then pure ()+ else dataStream (ReadEnd sock) cancel++withConnectionState :: TVar ConnectionState -> STM a+ -> (ConnectionState -> STM a)+ -> STM a+withConnectionState stV onQuit onState = do+ connSt <- readTVar stV+ case connSt of+ ConnectionQuit -> onQuit+ ConnectionState {} -> onState connSt++waitUntilSendable :: ThreadId -> ConnectionState+ -> (ClientState -> Bool)+ -> STM (Either TDSError (WriteEnd, ReadEnd))+waitUntilSendable _ ConnectionQuit _ = retry+waitUntilSendable threadId+ (ConnectionState { connectionWriteSock = writeEndV+ , connectionReadSock = readEndV+ , connectionCurState = stateV+ , connectionCurReq = reqV })+ canSendInState =+ do state <- readTVar stateV+ case state of+ _ | canSendInState state ->+ do writeSock <- either (\_ -> retry) pure =<<+ readTVar writeEndV+ readSock <- either (\_ -> retry) pure =<<+ readTVar readEndV+ maybe (pure ()) (\_ -> retry) =<<+ readTVar reqV++ writeTVar writeEndV (Left threadId)+ writeTVar readEndV (Left threadId)++ pure (Right (writeSock, readSock))+ SentClientRequest ->+ tdsError TDSServerBusy SentClientRequest+ "Can't send request while server is still processing"+ SentAttention -> retry+ Final ->+ tdsError TDSServerQuit Final "Connection is closing"+ _ -> tdsError TDSServerUninitialized Final "The connection is not yet ready"++ where+ tdsError ty st msg = pure (Left (tdsErrorNoReq ty st msg))++surrenderWrite :: TVar ConnectionState -> WriteEnd -> STM ()+surrenderWrite stV we = do+ st <- readTVar stV+ case st of+ ConnectionQuit -> pure ()+ ConnectionState { connectionWriteSock = writeEndV } ->+ do we' <- readTVar writeEndV+ case we' of+ Left {} -> writeTVar writeEndV (Right we)++ -- TODO output warning or something+ _ -> pure ()+++sendPacket :: forall cancelable r d+ . ( Payload d, Response r, MkCancelable cancelable+ , KnownBool cancelable )+ => Options -> TVar ConnectionState+ -> Packet 'Client ('ExpectsResponse ('ResponseType cancelable r)) d Identity+ -> IO (IO (ResponseResult ('ResponseType cancelable r)))+sendPacket options stV pkt =+ myThreadId >>= go+ where+ go threadId =+ mask $ \unmask ->+ join . atomically .+ withConnectionState stV+ (pure (throwIO (tdsErrorNoReq TDSServerQuit Final+ "Can't send request to closed connection"))) $ \st ->+ do sock <- waitUntilSendable threadId st (sendableInState (pktHdrType (pktHdr pkt)))+ case sock of+ Left err -> pure (throwIO err)+ Right (writeEnd, readEnd) -> do+ cancel <- mkCancelable+ writeTVar (connectionCurReq st) (Just (SomeSentPacket pkt cancel))++ pure (unmask $+ let go = doSend writeEnd readEnd cancel++ go' = if boolVal (Proxy :: Proxy cancelable)+ then go `catch`+ \(e :: TDSCanceledException) ->+ cancelRequest st writeEnd >>+ throwIO e+ else go++ internalError =+ join . atomically $ quitSTM' stV writeEnd readEnd++ in go' `onException` internalError)++ encoding = packetEncoding pkt++ doSend we@(WriteEnd sock buf) readEnd cancel = do+ let (maxSz, splitEncoding) =+ splitPacket (maybe maximumPayloadPacketSize snd buf - pktHdrSz) encoding++ (buf', sz') <-+ case buf of+ Nothing ->+ case maxSz of+ Nothing -> fail "Don't know what size of buffer"+ Just maxSz' ->+ (, maxSz') <$> mallocForeignPtrBytes (fromIntegral (maxSz' + pktHdrSz))+ Just (buf, sz) -> pure (buf, sz)++ sendPackets sock buf' sz' splitEncoding++ join . atomically . withConnectionState stV+ (pure (throwIO (TDSError TDSInvalidStateTransition Final (Just pkt)+ "Server quit before response received"))) $ \st ->+ do surrenderWrite stV we++ oldSt <- readTVar (connectionCurState st)+ let st' = stateTransition (pktHdrType (pktHdr pkt)) oldSt+ writeTVar (connectionCurState st) st'++ disconnectOnFinal st' we readEnd+ (throwIO (TDSError TDSInvalidStateTransition st' (Just pkt)+ "The state transitioned to Final before a response could be received"))+ (pure (getResult readEnd cancel))++ getResult readEnd@(ReadEnd sock) cancel =+ case responseDecoder :: ResponseDecoder (ResponseStreaming r) r of+ DecodeBatchResponse decode -> do+ hdr <- alloca $ \hdrP ->+ do recvExactly sock (hdrP :: Ptr Word64) 8+ readHdr (TabularResult :: PacketType 'Server 'NoResponse r) hdrP++ case hdr of+ Nothing -> invalidResponse readEnd+ Just hdr'+ | not (pktHdrStatus hdr' `hasStatus` pktStatusEndOfMessage) ->+ fail "Cannot decode batch message split over multiple packets"+ | otherwise ->+ allocaBytes (fromIntegral $ pktHdrLength hdr') $ \pktBuf ->+ do recvExactly sock pktBuf (pktHdrLength hdr' - 8)++ debugPtr pktBuf (fromIntegral $ pktHdrLength hdr' - 8)++ resp <- decode pktBuf (pktHdrLength hdr')+ case resp of+ Nothing -> fail "Invalid response"+ Just resp' -> do+ atomically . withConnectionState stV (pure ()) $ \st -> do+ writeTVar (connectionReadSock st) (Right readEnd)+ writeTVar (connectionCurReq st) Nothing+ pure (ResponseResultReceived resp')++ DecodeTokenStream streamDecoder ->+ do let tokenStream = parseTokenStream (dataStream readEnd cancel)+ validTokens s = do+ res <- S.lift (S.inspect s)+ case res of+ Left a -> pure a+ Right (OneToken tok next) ->+ do includeToken <- S.lift (handleToken pkt options stV tok)+ if includeToken+ then S.wrap (OneToken tok (validTokens next))+ else validTokens next+ Right (ContParse tok next) ->+ S.wrap (ContParse tok (validTokens . next))++ finishUp = atomically . withConnectionState stV (pure ()) $+ \st -> do+ writeTVar (connectionCurState st) LoggedIn+ writeTVar (connectionReadSock st) (Right readEnd)+ writeTVar (connectionCurReq st) Nothing++ -- TODO statically determine the kind of DONE message to+ -- expect as the end of this stream+ --+ -- TODO if this throws an exception, we should close the connection+ res <- streamDecoder finishUp (validTokens tokenStream)++ pure (ResponseResultReceived res)++ invalidResponse :: ReadEnd -> IO (ResponseResult ('ResponseType cancelable r))+ invalidResponse readEnd =+ join . atomically . withConnectionState stV+ (pure $ throwIO (TDSError TDSInvalidResponse Final+ (Just pkt)+ "Invalid response received, but we've already quit")) $+ \st -> do+ clientSt <- readTVar (connectionCurState st)++ writeTVar (connectionCurState st) Final+ writeTVar (connectionReadSock st) (Right readEnd)+ quitSTM stV++ pure (throwIO (TDSError TDSInvalidResponse clientSt+ (Just pkt)+ "Invalid response received"))++ disconnectOnFinal :: ClientState -> WriteEnd -> ReadEnd+ -> IO a -> IO a+ -> STM (IO a)+ disconnectOnFinal Final we re failer _ = quitSTM' stV we re >> pure failer+ disconnectOnFinal _ _ _ _ action = pure action++ cancelRequest st writeEnd@(WriteEnd sock buf) = do+ curReq <- atomically (readTVar (connectionCurReq st))++ case curReq of+ Just (SomeSentPacket (Packet (PacketHeader { pktHdrType = SQLBatch }) _)+ (Cancelable signal sync)) -> do+ let bufSz = cancelPacketSize+ buf <- mallocForeignPtrBytes (fromIntegral bufSz)++ atomically (writeTVar signal True)+ atomically (takeTMVar sync)++ let (_, splitEncoding) = splitPacket bufSz+ (Packet (mkPacketHeader Attention pktStatusEndOfMessage)+ (PacketEncoding (encodePayload ())))+ sendPackets sock buf bufSz splitEncoding++ -- TODO create read end, and read until done token+ let tokenStream = parseTokenStream (dataStream (ReadEnd sock) NonCancelable)+ readUntilDoneToken tokenStream++ -- Cancel all+ atomically $ do+ writeTVar (connectionCurState st) LoggedIn+ writeTVar (connectionReadSock st) (Right (ReadEnd sock))+ writeTVar (connectionCurReq st) Nothing++ _ -> pure ()++ -- Spawn a new thread to handle the shutdown+-- void . forkIO $ do+-- -- Sending a cancel request in the middle of a send operation+-- -- This just means sending the packet header with the EOM bit set+--+-- -- TODO sendPackets sock _ (pkt { pktData = LastPacket (\_ -> pure 0) })+--+-- atomically $ do+-- writeTVar sockV (Just writeEnd)+-- writeTVar sentV Nothing+--+-- -- We should be back in the old state+--+-- fail "TODO figure out cancel while sending request"++handleToken :: Packet clientServer respType d f+ -> Options -> TVar ConnectionState+ -> Token -> IO Bool+handleToken _ options stV (Info msg) = False <$ _tdsOnMessage options msg+handleToken _ options stV (Error msg) = False <$ _tdsOnMessage options msg+handleToken _ options stV (EnvChange chg) =+ join . atomically $ do+ st <- readTVar stV+ case st of+ ConnectionQuit -> pure (pure False)+ ConnectionState {} ->+ do let st' = st { connectionEnvironment = updateEnv chg (connectionEnvironment st) }+ writeTVar stV st'+ pure (False <$ _tdsOnEnvChange options chg)++handleToken pkt options stV (LoginAck {})+ | Login7 <- pktHdrType (pktHdr pkt) =+ atomically $ do+ st <- readTVar stV+ case st of+ ConnectionQuit -> pure True+ ConnectionState { connectionCurState = protoStV } ->+ do protoSt <- readTVar protoStV+ let setLoggedIn = writeTVar protoStV LoggedIn+ case protoSt of+ SentLogin7WithCompleteAuthenticationToken -> setLoggedIn+ SentLogin7WithSPNEGO -> setLoggedIn+ SentLogin7WithFAIR -> setLoggedIn+ _ -> pure ()+ pure True+handleToken _ _ _ _ = pure True++cancel :: TVar ConnectionState -> IO ()+cancel _ = fail "Cancel"++quitSTM :: TVar ConnectionState -> STM (IO ())+quitSTM stV = do+ withConnectionState stV (pure (pure ())) $ \st -> do+ we <- either (\_ -> retry) pure =<<+ readTVar (connectionWriteSock st)+ re <- either (\_ -> retry) pure =<<+ readTVar (connectionReadSock st)++ quitSTM' stV we re++quitSTM' :: TVar ConnectionState -> WriteEnd -> ReadEnd -> STM (IO ())+quitSTM' stV we re = do+ withConnectionState stV (pure (pure ())) $ \st -> do+ writeTVar stV ConnectionQuit++ pure (closeWriteEnd we >> closeReadEnd re)++quit :: TVar ConnectionState -> IO ()+quit = join . atomically . quitSTM++-- * Client environment++data ClientEnv+ = ClientEnv+ { clientEnvDatabase :: Text+ , clientEnvLanguage :: Text+ } deriving Show++-- TODO This should work+clientEnvFromOptions :: Options -> ClientEnv+clientEnvFromOptions _ = ClientEnv "master" "us_english"++updateEnv :: EnvChange -> ClientEnv -> ClientEnv+updateEnv (EnvChangeDatabase _ new) env = env { clientEnvDatabase = new }+updateEnv _ env = env++readUntilDoneToken :: S.Stream TokenStream IO () -> IO ()+readUntilDoneToken s = do+ res <- S.inspect s+ case res of+ Left {} -> pure ()+ Right (OneToken Done {} s') -> readUntilDoneToken s'+ Right (ContParse Done {} cont) -> pure ()+ Right (ContParse _ f) -> fail "Can't read (TODO)"
+ Database/TDS/Login.hs view
@@ -0,0 +1,76 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-}++module Database.TDS.Login where++import Database.TDS.Connection (newConnection)+import qualified Database.TDS.Proto as Proto+import qualified Database.TDS.Proto.Errors as Proto+import Database.TDS.Types++import Control.Exception+import Control.Monad++import Data.Monoid ((<>))+import qualified Data.Text as T++import Network.HostName++import System.Posix.Process++login :: Options -> IO Connection+login options = do+ c <- newConnection (options { _tdsOnMessage =+ \m -> case Proto.clsSeverity (Proto.messageClass m) of+ Proto.Information -> pure ()+ Proto.Fatal -> throwIO m })++ let prelogin = Proto.mkPacket+ (Proto.mkPacketHeader Proto.PreLogin mempty)+ (Proto.PreLoginP (Proto.versionOption 0 1 0 0 <>+ Proto.encryptionOff))++ getPreLoginResp <- tdsSendPacket c prelogin++ ResponseResultReceived preloginResp <- getPreLoginResp++ pid <- getProcessID+ hostname <- T.pack <$> getHostName++ let login7 = Proto.Login7P Proto.tdsVersion71+ 16384+ (Proto.ClientProgVersion 0x00010000)+ (Proto.ClientPID (fromIntegral pid))+ (Proto.ConnectionID 0)+ Proto.defaultLoginOptions+ 0+ (Proto.Collation (Proto.LCID 0x0409) -- English US+ (Proto.CollationFlags 0)+ (Proto.CollationVersion 0))+ hostname+ (_tdsUser options)+ (_tdsPassword options)+ (_tdsAppName options)+ "localhost"+ ""+ (_tdsClientName options)+ "us_english"+ (_tdsDatabase options)++ -- TODO send MAC address+ (Proto.ClientID 0 0)++ "" "" "" 0+ []+ getLogin7Resp <- tdsSendPacket c (Proto.mkPacket (Proto.mkPacketHeader Proto.Login7 mempty)+ login7)+ ResponseResultReceived login7Resp <- getLogin7Resp++ pure c++-- login :: Options -> IO Connection+-- login options = do+-- conn <- asyncLogin options+-- waitUntilReady conn++
+ Database/TDS/Proto.hs view
@@ -0,0 +1,1285 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}++{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TupleSections #-}++module Database.TDS.Proto where++import Database.TDS.Proto.Errors++import Control.Exception (Exception)+import Control.Monad.Identity+import Control.Monad.Reader+import Control.Monad.State+import Control.Monad.Tardis+import Control.Monad.Trans.Maybe++import Data.Attoparsec.Binary+import qualified Data.Attoparsec.ByteString as A hiding (Done)+import qualified Data.Attoparsec.ByteString.Streaming as S+import Data.Bits ( bit, (.|.), (.&.), xor+ , shiftL, shiftR )+import qualified Data.ByteString as BS+import Data.ByteString.Builder+import Data.ByteString.Builder.Extra hiding (Done)+import qualified Data.ByteString.Internal as IBS+import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Streaming as SBS+import Data.Int+import Data.Maybe+import Data.Monoid+import Data.Text (Text)+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.Foreign as T+import Data.Word+import qualified Data.Vector as V++import Debug.Trace++import Foreign.C.Types+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Marshal.Utils (copyBytes)+import Foreign.Ptr+import Foreign.Storable++import Streaming (Compose(..))+import qualified Streaming as S+import qualified Streaming.Prelude as S+import qualified Streaming.Internal as S (inspect)++cancelPacketSize, maximumPayloadPacketSize :: CSize+cancelPacketSize = 1024+maximumPayloadPacketSize = 65536++pktHdrSz :: CSize+pktHdrSz = 8++data Sender+ = Client+ | Server+ deriving Show++data ResponseInfo a+ = ExpectsResponse (ResponseType a)+ | NoResponse+ deriving Show++data ResponseType a+ = ResponseType Bool {-^ Cancelable -} a+ deriving Show++data StreamType+ = TokenlessStream+ | TokenStream+ deriving Show++data Unimplemented++instance Show Unimplemented where+ show = error "Unimplemented"++-- * Misc data types++newtype SPID = SPID Word16+ deriving (Show, Eq)++-- * Packets++-- ** Packet header++-- | Data type representing valid packet types+data PacketType (sender :: Sender) (resp :: ResponseInfo *) (d :: *) where+ PreLogin :: PacketType 'Client+ ('ExpectsResponse ('ResponseType 'False PreLogin))+ PreLogin++ Login7 :: PacketType 'Client ('ExpectsResponse ('ResponseType 'False Login7Ack)) Login7++ SQLBatch :: PacketType 'Client ('ExpectsResponse ('ResponseType 'True RowResults)) T.Text+ BulkLoad :: PacketType 'Client 'NoResponse Unimplemented+ RPC :: PacketType 'Client 'NoResponse Unimplemented++ -- TODO response or something+ Attention :: PacketType 'Client ('ExpectsResponse ('ResponseType 'False ())) ()++ TrMgrRequest :: PacketType 'Client 'NoResponse Unimplemented++ -- Server requests+ TabularResult :: PacketType 'Server 'NoResponse a++deriving instance Show (PacketType sender resp d)++packetType :: PacketType sender resp d -> Word8+packetType PreLogin = 0x12+packetType Login7 = 0x10+packetType SQLBatch = 0x01+packetType BulkLoad = 0x07+packetType RPC = 0x03+packetType Attention = 0x06+packetType TrMgrRequest = 0x0E+packetType TabularResult = 0x04++newtype PacketStatus (s :: Sender) = PacketStatus Word8+ deriving Show++instance Semigroup (PacketStatus s) where+ (<>) = mappend++instance Monoid (PacketStatus s) where+ mempty = PacketStatus 0+ mappend (PacketStatus a) (PacketStatus b) =+ PacketStatus (a .|. b)++hasStatus :: PacketStatus s -> PacketStatus s -> Bool+hasStatus (PacketStatus sts) (PacketStatus lookup) =+ sts .&. lookup > 0++pktStatusEndOfMessage :: PacketStatus s+pktStatusEndOfMessage = PacketStatus (bit 0)++pktStatusIgnore, pktStatusResetConn, pktStatusResetConnSkipTran+ :: PacketStatus 'Client+pktStatusIgnore = PacketStatus (bit 1)+pktStatusResetConn = PacketStatus (bit 2)+pktStatusResetConnSkipTran = PacketStatus (bit 3)++newtype PacketSequenceID = PacketSequenceID Word8+ deriving (Show, Eq)++type family Packed (packed :: Bool) (a :: *) (b :: *) where+ Packed 'True a b = a+ Packed 'False a b = b++data PacketHeader (sender :: Sender) (resp :: ResponseInfo *) (d :: *) where+ PacketHeader ::+ { pktHdrType :: !(PacketType sender resp d)+ , pktHdrStatus :: !(PacketStatus sender)+ , pktHdrLength :: !Word16 {- Filled in automatically on send -}+ , pktHdrSPID :: !SPID+ , pktHdrSeqID :: !PacketSequenceID {- Filled in automatically on send -}+ , pktHdrWindow :: !Word8 -- == 0+ } -> PacketHeader sender resp d+deriving instance Show (PacketHeader sender resp d)++mkPacketHeader :: PacketType sender resp d -> PacketStatus sender+ -> PacketHeader sender resp d+mkPacketHeader ty flags = PacketHeader ty flags 0 (SPID 0)+ (PacketSequenceID 0) 0++writeHdr :: Ptr a -> PacketHeader 'Client resp d -> IO ()+writeHdr ptr (PacketHeader pktType (PacketStatus pktSts) len+ (SPID spid16) (PacketSequenceID seqId)+ window) =+ do poke (castPtr ptr) (packetType pktType)+ poke (castPtr ptr `plusPtr` 1) pktSts+ be16 (castPtr ptr `plusPtr` 2) len+ be16 (castPtr ptr `plusPtr` 4) spid16+ poke (castPtr ptr `plusPtr` 6) seqId+ poke (castPtr ptr `plusPtr` 7) window++ where+ be16 :: Ptr Word8 -> Word16 -> IO ()+ be16 ptr x =+ let lo, hi :: Word8+ lo = fromIntegral (x .&. 0xFF)+ hi = fromIntegral ((x `shiftR` 8) .&. 0xFF)+ in poke (castPtr ptr) hi >>+ poke (castPtr ptr `plusPtr` 1) lo++readHdr :: PacketType sender resp d+ -> Ptr a -> IO (Maybe (PacketHeader sender resp d))+readHdr pktTy ptr =+ do tag <- peek (castPtr ptr)+ if tag /= packetType pktTy+ then pure Nothing+ else Just <$>+ (PacketHeader pktTy+ <$> (PacketStatus <$> peek (castPtr ptr `plusPtr` 1))+ <*> be16 (ptr `plusPtr` 2)+ <*> (SPID <$> be16 (ptr `plusPtr` 4))+ <*> (PacketSequenceID <$> peek (castPtr ptr `plusPtr` 6))+ <*> peek (castPtr ptr `plusPtr` 7))+ where+ be16 ptr = do+ hi <- peek (castPtr ptr :: Ptr Word8)+ lo <- peek (castPtr ptr `plusPtr` 1 :: Ptr Word8)+ pure ((fromIntegral hi `shiftL` 8) .|. fromIntegral lo)+++data Packet (sender :: Sender) (resp :: ResponseInfo *) (d :: *) (f :: * -> *) where+ Packet ::+ { pktHdr :: !(PacketHeader sender resp d)+ , pktData :: !(f d)+ } -> Packet sender resp d f++mkPacket :: PacketHeader sender resp d -> d+ -> Packet sender resp d Identity+mkPacket hdr d = Packet hdr (Identity d)++packetEncoding :: Payload d+ => Packet sender resp d Identity+ -> Packet sender resp d PacketEncoding+packetEncoding (Packet hdr (Identity x)) =+ Packet hdr (PacketEncoding (encodePayload x))++deriving instance Show d => Show (Packet sender resp d Identity)+--deriving instance Show d => Show (Packet sender resp d Encoded)++displayRequest :: Show d => Packet sender resp d Identity -> String+displayRequest = show++-- * Packet payloads++data PayloadEncoder (streaming :: StreamType) where+ PayloadStreamEncoder :: Builder -> PayloadEncoder 'TokenStream+ PayloadBatchEncoder :: Word -> Builder -> PayloadEncoder 'TokenlessStream++newtype PacketEncoding pld+ = PacketEncoding (PayloadEncoder (PayloadStreaming pld))++class Show pld => Payload pld where+ type PayloadStreaming pld :: StreamType++ encodePayload :: pld -> PayloadEncoder (PayloadStreaming pld)++instance Payload () where+ type PayloadStreaming () = 'TokenlessStream++ encodePayload _ = PayloadBatchEncoder 0 mempty++instance Payload Text where+ type PayloadStreaming Text = 'TokenlessStream++ encodePayload t = PayloadBatchEncoder (fromIntegral $ T.length t * 2)+ (byteString (TE.encodeUtf16LE t))++runBatchEncoder :: Monoid fixup+ => Tardis fixup (Builder, Word) ()+ -> PayloadEncoder 'TokenlessStream+runBatchEncoder action =+ let (_, (_, (builder, len))) = runTardis action (mempty, (mempty, 0))+ in PayloadBatchEncoder len builder++getFixups :: Tardis fixup (Builder, Word) fixup+getFixups = getFuture++getPosition :: Tardis fixup (Builder, Word) Word+getPosition = snd <$> getPast++fixup :: Monoid fixup+ => fixup -> Tardis fixup (Builder, Word) ()+fixup f = modifyBackwards (mappend f)++emit :: Word -> Builder -> Tardis fixup (Builder, Word) ()+emit len b = modifyForwards (\(before, p) -> (before <> b, len + p))++-- ** PRELOGIN Payload++newtype MajorVersion = MajorVersion Word8 deriving (Show, Num)+newtype MinorVersion = MinorVersion Word8 deriving (Show, Num)+newtype BuildNumber = BuildNumber Word16 deriving (Show, Num)+newtype SubBuildNumber = SubBuildNumber Word16 deriving (Show, Num)++data Encryption+ = EncryptionOff | EncryptionOn+ | EncryptionNotSupported+ | EncryptionRequired+ deriving Show++data Nonce+ = Nonce !Word64 !Word64 !Word64 !Word64+ deriving Show++data PreLoginOption+ = VersionOption !MajorVersion !MinorVersion !BuildNumber !SubBuildNumber+ | EncryptionOption !Encryption+ | InstanceNameOption !Text+ | ThreadIdOption !Word32+ | MarsOption !Bool+-- TODO+-- | TraceIdOption !UUID !UUID+ | FedAuthRequiredOption !Word8+ | NonceOption !Nonce+ deriving Show++type PreLoginOptions = [ PreLoginOption ]++versionOption :: MajorVersion -> MinorVersion -> BuildNumber -> SubBuildNumber+ -> PreLoginOptions+versionOption maj min b sb =+ [ VersionOption maj min b sb ]++encryptionOff :: PreLoginOptions+encryptionOff = [ EncryptionOption EncryptionNotSupported ]++newtype PreLogin+ = PreLoginP+ { preLoginOptions :: PreLoginOptions+ } deriving Show++instance Payload PreLogin where+ type PayloadStreaming PreLogin = 'TokenlessStream++ encodePayload (PreLoginP options) =+ runBatchEncoder $+ do fixups <- getFixups++ emitFixups options fixups++ emit 1 (word8 0xFF) -- Termination token++ forM_ options $ \option ->+ do o <- getPosition+ buildOption option+ o' <- getPosition+ fixup ([( fromIntegral o+ , fromIntegral $ o' - o)])++ where+ emitFixups [] _ = pure ()+ emitFixups (option:options) ~(~(offset, len):fixups) =+ do emit 1 (word8 (optionToken option))+ emit 2 (word16BE offset)+ emit 2 (word16BE len)+ emitFixups options fixups++ optionToken :: PreLoginOption -> Word8+ optionToken VersionOption {} = 0x00+ optionToken EncryptionOption {} = 0x01+ optionToken InstanceNameOption {} = 0x02+ optionToken ThreadIdOption {} = 0x03+ optionToken MarsOption {} = 0x04+-- optionToken TraceIdOption {} = 0x05+ optionToken FedAuthRequiredOption {} = 0x06+ optionToken NonceOption {} = 0x07++ buildOption (VersionOption (MajorVersion major)+ (MinorVersion minor)+ (BuildNumber build)+ (SubBuildNumber subBuild)) =+ emit 1 (word8 major) >> emit 1 (word8 minor) >>+ emit 2 (word16BE build) >> emit 2 (word16BE subBuild)+ buildOption (EncryptionOption enc) =+ buildEncryption enc+ buildOption (InstanceNameOption nm) =+ let nmBs = TE.encodeUtf8 nm+ in emit (fromIntegral $ BS.length nmBs)+ (byteString nmBs) >>+ emit 0 (word8 0)+ buildOption (ThreadIdOption w) =+ emit 4 (word32BE w)+ buildOption (MarsOption False) = emit 1 (word8 0x00)+ buildOption (MarsOption True) = emit 1 (word8 0x01)+ buildOption (FedAuthRequiredOption a) =+ emit 1 (word8 a)+ buildOption (NonceOption (Nonce a3 a2 a1 a0)) =+ emit 32 (word64LE a0 <> word64LE a1 <>+ word64LE a2 <> word64LE a3)++ buildEncryption e =+ emit 1 . word8 $+ case e of+ EncryptionOff -> 0x00+ EncryptionOn -> 0x01+ EncryptionNotSupported -> 0x02+ EncryptionRequired -> 0x03++-- ** LOGIN7 Payload++newtype TDSVersion+ = TDSVersion { fromTDSVersion :: Word32 }+ deriving Show+newtype ClientProgVersion+ = ClientProgVersion { fromClientProgVersion :: Word32 }+ deriving Show+newtype ClientPID+ = ClientPID { fromClientPID :: Word32 }+ deriving Show+newtype ConnectionID+ = ConnectionID { fromConnectionID :: Word32 }+ deriving Show+newtype Login7Options+ = Login7Options { fromLogin7Options :: Word32 }+ deriving Show++instance Monoid Login7Options where+ mempty = Login7Options 0+ mappend (Login7Options a) (Login7Options b) =+ Login7Options (a .|. b)++instance Semigroup Login7Options where+ (<>) = mappend++defaultLoginOptions :: Login7Options+defaultLoginOptions = Login7Options 0x000003e0++data Login7Feature = Login7Feature deriving Show++-- | 12-bit Windows language code identifier+newtype LCID = LCID Word16 deriving Show+newtype CollationFlags = CollationFlags Word8 deriving Show+-- | 4-bit collation version+newtype CollationVersion = CollationVersion Word8 deriving Show++data Collation+ = Collation+ { collationLCID :: !LCID+ , collationFlags :: !CollationFlags+ , collationVersion :: !CollationVersion+ } deriving Show++data ClientID+ = ClientID !Word16 !Word32+ deriving (Show, Eq)++tdsVersion71 :: TDSVersion+tdsVersion71 = TDSVersion 0x00000071++data Login7+ = Login7P+ { login7_tdsVersion :: !TDSVersion+ , login7_packetSize :: !Word32+ , login7_clientProgVer :: !ClientProgVersion+ , login7_clientPID :: !ClientPID+ , login7_connectionID :: !ConnectionID+ , login7_flags :: !Login7Options+ , login7_clientTmZone :: !Word32+ , login7_collation :: !Collation++ , login7_hostName :: !Text+ , login7_userName :: !Text+ , login7_password :: !Text+ , login7_appName :: !Text+ , login7_serverName :: !Text+ , login7_extension :: !Text+ , login7_cltIntName :: !Text+ , login7_language :: !Text+ , login7_database :: !Text+ , login7_clientID :: !ClientID+ , login7_SSPI :: !Text+ , login7_atchDbFile :: !Text+ , login7_changePasswd :: !Text+ , login7_SSPILong :: !Word32++ , login7_extraFeatures :: [Login7Feature]+ } deriving Show++data Login7Fixups+ = Login7Fixups+ { login7_totalLen :: !(Sum Word32)+ , login7_hostNameOfs :: !Word16+ , login7_userNameOfs :: !Word16+ , login7_passwordOfs :: !Word16+ , login7_appNameOfs :: !Word16+ , login7_serverNameOfs :: !Word16+ , login7_extensionOfs :: !Word16+ , login7_cltIntNameOfs :: !Word16+ , login7_languageOfs :: !Word16+ , login7_databaseOfs :: !Word16+ , login7_SSPIOfs :: !Word16+ , login7_atchDbFileOfs :: !Word16+ , login7_changePasswdOfs :: !Word16+ } deriving Show++instance Monoid Login7Fixups where+ mempty = Login7Fixups mempty 0 0 0 0 0 0 0 0 0 0 0 0+ mappend a b =+ Login7Fixups (login7_totalLen a <> login7_totalLen b)+ (go login7_hostNameOfs) (go login7_userNameOfs)+ (go login7_passwordOfs) (go login7_appNameOfs)+ (go login7_serverNameOfs) (go login7_extensionOfs)+ (go login7_cltIntNameOfs) (go login7_languageOfs)+ (go login7_databaseOfs) (go login7_SSPIOfs)+ (go login7_atchDbFileOfs) (go login7_changePasswdOfs)+ where+ go f = if f b == 0 then f a else f b++instance Semigroup Login7Fixups where+ (<>) = mappend++instance Payload Login7 where+ type PayloadStreaming Login7 = 'TokenlessStream++ encodePayload d =+ runBatchEncoder $+ do ~(Sum totalLen) <- login7_totalLen <$> getFixups++ emit 4 (word32LE (fromIntegral totalLen))++ emit 4 (word32BE (fromTDSVersion (login7_tdsVersion d)))+ emit 4 (word32LE (login7_packetSize d))+ emit 4 (word32LE (fromClientProgVersion (login7_clientProgVer d)))+ emit 4 (word32LE (fromClientPID (login7_clientPID d)))+ emit 4 (word32LE (fromConnectionID (login7_connectionID d)))+ emit 4 (word32LE (fromLogin7Options (login7_flags d)))+ emit 4 (word32LE (login7_clientTmZone d))++ emitCollation (login7_collation d)++ emitOffset login7_hostName login7_hostNameOfs+ emitOffset login7_userName login7_userNameOfs+ emitOffset login7_password login7_passwordOfs+ emitOffset login7_appName login7_appNameOfs+ emitOffset login7_serverName login7_serverNameOfs+ emitOffset login7_extension login7_extensionOfs+ emitOffset login7_cltIntName login7_cltIntNameOfs+ emitOffset login7_language login7_languageOfs+ emitOffset login7_database login7_databaseOfs++ let ClientID hi lo = login7_clientID d+ emit 4 (word32LE lo)+ emit 2 (word16LE hi)++ emitOffset login7_SSPI login7_SSPIOfs+ emitOffset login7_atchDbFile login7_atchDbFileOfs+-- emitOffset login7_changePasswd login7_changePasswdOfs++-- emit 4 (word32LE (login7_SSPILong d))++ curPos <- fromIntegral <$> getPosition+ fixup (mempty { login7_hostNameOfs = curPos })++ emitData id login7_hostName (\x -> mempty { login7_hostNameOfs = x })+ emitData id login7_userName (\x -> mempty { login7_userNameOfs = x })+ emitData enc login7_password (\x -> mempty { login7_passwordOfs = x })+ emitData id login7_appName (\x -> mempty { login7_appNameOfs = x })+ emitData id login7_serverName (\x -> mempty { login7_serverNameOfs = x })+ emitData id login7_extension (\x -> mempty { login7_extensionOfs = x })+ emitData id login7_cltIntName (\x -> mempty { login7_cltIntNameOfs = x })+ emitData id login7_language (\x -> mempty { login7_languageOfs = x })+ emitData id login7_database (\x -> mempty { login7_databaseOfs = x })++-- TODO TDS7.4 only+-- TODO forM_ (login7_extraFeatures d) emitFeature++ --emit 1 (word8 0xFF)++ pos <- fromIntegral <$> getPosition+ fixup (mempty { login7_totalLen = Sum pos })+ where+ emitOffset getBs getOfs = do+ let bs = getBs d+ ofs <- getOfs <$> getFixups+ emit 2 (word16LE ofs)+ emit 2 (word16LE (fromIntegral (T.length bs)))++ -- | Password encryption algorithm as described on pg 64+ enc b = let swapped = ((b `shiftR` 4) .&. 0xF) .|.+ ((b .&. 0xF) `shiftL` 4)+ in swapped `xor` 0xA5++ emitData f getBs setOfs = do+ let bs = getBs d+ if T.length bs > 0+ then do+ ofs <- fromIntegral <$> getPosition+ fixup (setOfs ofs)+ emit (2 * fromIntegral (T.length bs))+ (byteString (BS.map f $ TE.encodeUtf16LE bs))+ else pure ()++ emitCollation (Collation (LCID lcid)+ (CollationFlags flags)+ (CollationVersion vers)) = do+ emit 4 (word32LE (((fromIntegral vers .&. 0xF) `shiftR` 28) .|.+ (fromIntegral flags `shiftR` 20) .|.+ fromIntegral lcid))+++-- * Packet decoders++data ResponseDecoder (streaming :: StreamType) (res :: *) where+ DecodeBatchResponse :: (Ptr Word8 -> Word16 -> IO (Maybe res))+ -> ResponseDecoder 'TokenlessStream res+ DecodeTokenStream :: (forall r. IO () -> S.Stream TokenStream IO r -> IO res)+ -> ResponseDecoder 'TokenStream res++class Show res => Response res where+ type ResponseStreaming res :: StreamType++ responseDecoder :: ResponseDecoder (ResponseStreaming res) res++instance Response Unimplemented where+ type ResponseStreaming Unimplemented = 'TokenlessStream++ responseDecoder = error "responseDecoder{Unimplemented}"++type BatchDecoder = StateT (Ptr Word8, Word16) (ReaderT Word16 (MaybeT IO))++decodeBatch :: BatchDecoder a -> ResponseDecoder 'TokenlessStream a+decodeBatch decoder =+ DecodeBatchResponse $ \ptr sz ->+ runMaybeT (runReaderT (evalStateT decoder (ptr, 0)) sz)++read8 :: BatchDecoder Word8+read8 = do+ sz <- ask+ (res, ofs) <- get+ if ofs > sz+ then lift (lift (MaybeT (pure Nothing)))+ else do+ put (res, ofs + 1)++ liftIO (peek (res `plusPtr` fromIntegral ofs))++read16BE :: BatchDecoder Word16+read16BE = do+ hi <- fromIntegral <$> read8+ lo <- fromIntegral <$> read8+ pure ((hi `shiftL` 8) .|. lo)++read32BE :: BatchDecoder Word32+read32BE = do+ hi <- fromIntegral <$> read16BE+ lo <- fromIntegral <$> read16BE+ pure ((hi `shiftL` 16) .|. lo)++read64BE :: BatchDecoder Word64+read64BE = do+ hi <- fromIntegral <$> read32BE+ lo <- fromIntegral <$> read32BE+ pure ((hi `shiftL` 32) .|. lo)++read16LE :: BatchDecoder Word16+read16LE = do+ lo <- fromIntegral <$> read8+ hi <- fromIntegral <$> read8+ pure ((hi `shiftL` 8) .|. lo)++read32LE :: BatchDecoder Word32+read32LE = do+ lo <- fromIntegral <$> read16LE+ hi <- fromIntegral <$> read16LE+ pure ((hi `shiftL` 16) .|. lo)++read64LE :: BatchDecoder Word64+read64LE = do+ lo <- fromIntegral <$> read32LE+ hi <- fromIntegral <$> read32LE+ pure ((hi `shiftL` 32) .|. lo)++ztText :: Word16 -> BatchDecoder Text+ztText len = tell >>= go 0+ where+ go ofs start+ | ofs >= len = lift (lift (MaybeT (pure Nothing)))+ | otherwise = do+ c <- read8+ if c == 0+ then finish start ofs+ else go (ofs + 1) start++ finish start finalLen = do+ (ptr, _) <- get+ liftIO (T.peekCStringLen (castPtr ptr `plusPtr` fromIntegral start,+ fromIntegral finalLen))++tell :: BatchDecoder Word16+tell = snd <$> get++seek :: Word16 -> BatchDecoder ()+seek ofs = do+ sz <- ask+ if ofs < sz+ then modify (\(ptr, _) -> (ptr, ofs))+ else lift (lift (MaybeT (pure Nothing)))++-- ** PRELOGIN response++instance Response PreLogin where+ type ResponseStreaming PreLogin = 'TokenlessStream++ responseDecoder =+ decodeBatch $ do+ options <- readOptions id++ fmap (PreLoginP . catMaybes)+ (sequence options)++ where+ readOptions a = do+ tag <- read8+ if tag == (0xFF :: Word8)+ then pure (a [])+ else do+ ofs <- read16BE+ len <- read16BE+ readOptions (a . ((seek ofs >> readOption tag len):))++ readOption 0x00 len+ | len >= 6 =+ Just <$> (VersionOption+ <$> (MajorVersion <$> read8)+ <*> (MinorVersion <$> read8)+ <*> (BuildNumber <$> read16BE)+ <*> (SubBuildNumber <$> read16BE))+ readOption 0x01 len+ | len >= 1 =+ fmap (Just . EncryptionOption) $ do+ tag <- read8+ case tag of+ 0x00 -> pure EncryptionOff+ 0x01 -> pure EncryptionOn+ 0x02 -> pure EncryptionNotSupported+ 0x03 -> pure EncryptionRequired+ _ -> lift (lift (MaybeT (pure Nothing)))+ readOption 0x02 len+ | len >= 1 =+ Just . InstanceNameOption <$> ztText len+ readOption 0x03 len+ | len >= 4 =+ Just . ThreadIdOption <$> read32BE+ readOption 0x04 len+ | len >= 1 =+ Just . MarsOption <$> ((/=0) <$> read8)+ readOption 0x06 len+ | len >= 1 =+ Just . FedAuthRequiredOption <$> read8+ readOption 0x07 len+ | len == 32 =+ Just <$> (NonceOption <$>+ (Nonce <$> read64LE <*> read64LE+ <*> read64LE <*> read64LE))+ readOption _ _ = lift (lift (MaybeT (pure Nothing)))++data Login7Ack = Login7Ack !Word8 !TDSVersion !T.Text !ProgVersion+ deriving Show++instance Response Login7Ack where+ type ResponseStreaming Login7Ack = 'TokenStream++ responseDecoder = DecodeTokenStream $ \finish s ->+ S.streamFold (\_ ack -> do+ S.liftIO finish+ case ack of+ Just ack' -> pure ack'+ _ -> fail "Token stream incomplete")+ (\x ack -> x >>= ($ ack))+ (\x ack ->+ case x of+ OneToken (LoginAck i v progNm progVers) next ->+ next (Just (Login7Ack i v progNm progVers))+ OneToken Done {} _+ | Just ack' <- ack ->+ S.liftIO finish >> pure ack'+ | otherwise -> fail "Premature DONE"+ OneToken token next -> do liftIO (putStrLn ("Unhandled token during LOGIN : " ++ show (() <$ token)))+ next ack+ ContParse {} -> fail "Can't parse unhandled token in LOGIN")+ s Nothing++-- * Tokens++newtype DoneSts = DoneSts Word16 deriving Show+newtype ProgVersion = ProgVersion Word32 deriving Show++data Message+ = Message+ { messageCode :: !SQLError+ , messageSt :: !Word8+ , messageClass :: !ErrorClass+ , messageText :: !Text+ , messageServerName :: !Text+ , messageProcName :: !Text+ , messageLineNum :: Word16+ } deriving Show+instance Exception Message++data EnvChange+ = EnvChangeDatabase !T.Text !T.Text+ | EnvChangeLanguage !T.Text !T.Text+ | EnvChangeCollation !BS.ByteString !BS.ByteString+ | EnvChangeUnknown+ deriving Show++data Token' f+ = TvpRow+ | Offset+ | ReturnStatus+ | ColMetadata !ColumnMetadata+ | AltMetadata+ | TableName+ | ColumnInfo+ | Order (V.Vector Word8)++ | Error !Message+ | Info !Message++ | ReturnValue+ | LoginAck !Word8 !TDSVersion !T.Text !ProgVersion+ | FeatureExtAck+ | Row !f+ | NbcRow+ | AltRow+ | EnvChange !EnvChange+ | SessionState+ | SSPI+ | FedAuthInfo+ | Done !DoneSts !Word16 !Word64 -- status, token, rowcount, where rowcount is 32-bit pre 7.2+ | DoneProc+ | DoneInProc+ deriving (Functor, Show)++type Token = Token' (SBS.ByteString IO ())++data TokenStream f+ = OneToken !Token f+ | ContParse !Token (SBS.ByteString IO () -> f)+ deriving Functor++doneHasMore :: DoneSts -> Bool+doneHasMore (DoneSts sts) =+ (sts .&. 1) /= 0++doneHasError :: DoneSts -> Bool+doneHasError (DoneSts sts) =+ (sts .&. 2) /= 0++parseTokenStream :: SBS.ByteString IO () -> S.Stream TokenStream IO ()+parseTokenStream bs =+ do (res, bs') <- liftIO (S.parse parseToken bs)+ case res of+ Left e ->+ fail ("Stream decode error: " ++ show e)+ Right (Right r) ->+ S.wrap (OneToken r (parseTokenStream bs'))+ Right (Left contParse) -> do+ S.wrap (ContParse (contParse bs') parseTokenStream)++usVarChar, bVarChar :: A.Parser (Int, Text)+bVarChar = do+ len <- fromIntegral <$> A.anyWord8+ (1 + len * 2,) <$> (TE.decodeUtf16LE <$> A.take (len * 2))++usVarChar = do+ len <- fromIntegral <$> anyWord16le+ (2 + len * 2,) <$> (TE.decodeUtf16LE <$> A.take (len * 2))++bVarByte :: A.Parser (Int, BS.ByteString)+bVarByte = do+ len <- fromIntegral <$> A.anyWord8+ (1 + len,) . BS.copy <$> A.take len++parseToken :: A.Parser (Either (SBS.ByteString IO () -> Token) Token)+parseToken =+ do tag <- A.anyWord8++ case tag of+ 0x01 -> fail "TVPROW"+ 0x78 -> fail "OFFSET"+ 0x79 -> fail "RETURNSTATUS"+ 0x81 -> Right . ColMetadata <$> colMetadataP+ 0x88 -> fail "ALTMETADATA"+ 0xA4 -> fail "TABNAME"+ 0xA5 -> fail "COLINFO"+ 0xA9 -> Right . Order <$> orderP+ 0xAA -> Right . Error <$> messageP+ 0xAB -> Right . Info <$> messageP+ 0xAC -> fail "RETURNVALUE"+ 0xAD -> Right <$> loginAckP+ 0xAE -> fail "FEATUREEXTACK"+ 0xD1 -> pure (Left Row)+ 0xD2 -> fail "NBCROW"+ 0xD3 -> fail "ALTROW"+ 0xE3 -> Right <$> envChangeP+ 0xE4 -> fail "SESSIONSTATE"+ 0xED -> fail "SSPI"+ 0xEE -> fail "FEDAUTHINFO"++ -- Using TDS 7.1 for now+ 0xFD -> fmap Right (Done <$> (DoneSts <$> anyWord16le) <*> anyWord16le+ <*> (fromIntegral <$> anyWord32le))+ 0xFE -> fail "DONEPROC"+ 0xFF -> fail "DONEINPROC"+ _ -> do+ d <- BS.pack <$> replicateM 16 A.anyWord8+ fail ("Unknown token in TDS stream: " ++ show tag ++ " " ++ show d)++ where+ nextPacket totalLen actualLength =+ if totalLen - fromIntegral actualLength < 0 then fail "len - actualLength < 0"+ else replicateM_ (fromIntegral $ totalLen - fromIntegral actualLength) A.anyWord8++ loginAckP = do+ len <- anyWord16le+ iface <- A.anyWord8+ tdsVersion <- TDSVersion <$> anyWord32le++ (progByteLen, progName) <- bVarChar++ progVersion <- ProgVersion <$> anyWord32le++ let actualLength = 1 {- iface -} + 4 {- tdsVersion -} ++ progByteLen {- progName -} ++ 4 {- progVersion -}++ nextPacket len actualLength++ pure (LoginAck iface tdsVersion progName progVersion)++ envChangeP = do+ len <- anyWord16le++ tag <- A.anyWord8+ (actualLen, chg) <-+ case tag of+ 1 -> do+ (newDbLen, newDb) <- bVarChar+ (oldDbLen, oldDb) <- bVarChar+ pure (oldDbLen + newDbLen, EnvChangeDatabase oldDb newDb)+ 2 -> do+ (newLangLen, newLang) <- bVarChar+ (oldLangLen, oldLang) <- bVarChar+ pure (oldLangLen + newLangLen, EnvChangeLanguage oldLang newLang)+ 7 -> do+ (newCollLen, newColl) <- bVarByte+ (oldCollLen, oldColl) <- bVarByte+ pure (oldCollLen + newCollLen, EnvChangeCollation oldColl newColl)+ _ -> pure (0, EnvChangeUnknown)++ nextPacket len (1 + actualLen)++ pure (EnvChange chg)++ orderP = do+ len <- anyWord16le+ V.fromList <$> replicateM (fromIntegral len) A.anyWord8++ messageP = do+ len <- anyWord16le++ msgCode <- SQLError <$> anyWord32le+ st <- A.anyWord8+ cls <- ErrorClass <$> A.anyWord8++ (msgByteLen, msgText) <- usVarChar++ (serverNameByteLen, serverName) <- bVarChar+ (procNameByteLen, procName) <- bVarChar+ lnNum <- anyWord16le++ let actualLength = 4 {- errNum -} + 1 {- st -} + 1 {- cls -} ++ msgByteLen {- msgText -} ++ serverNameByteLen {- serverName -} ++ procNameByteLen {- procName -} ++ 2 {- lnNum -}++ nextPacket len actualLength++ pure (Message msgCode st cls msgText serverName procName lnNum)++-- * Tabular results++data EncryptionAlgorithm = EncryptionAlgorithm deriving Show+data EncryptionAlgorithmType = EncryptionAlgorithmType deriving Show++data CharKind = NormalChar | NationalChar deriving Show++data PrecScale = PrecScale !Word8 !Word8 deriving Show++data TypeLen = ByteLen | ShortLen deriving Show++data TypeInfo+ = NullType+ | IntNType !Bool !Word8+ | GuidType !Word8+ | DecimalType !Bool !Word8 !PrecScale+ | NumericType !Bool !Word8 !PrecScale+ | BitNType !Bool !Word8+ | DecimalNType !Bool !Word8 !PrecScale+ | NumericNType !Bool !Word8 !PrecScale+ | FloatNType !Bool !Word8+ | MoneyNType !Bool !Word8+ | DtTmNType !Bool !Word8+ | DateNType !Bool !Word8+ | TimeNType !Bool !Word8+ | DtTm2NType !Word8+ | DtTmOfsType !Word8+ | CharType !TypeLen !CharKind !Word16 !(Maybe Collation)+ | VarcharType !TypeLen !CharKind !Word16 !(Maybe Collation)+ | BinaryType !Word16+ | VarBinType !Word16+ | ImageType !Word32+ | NTextType !Word32 !Collation+ | SSVarType !Word32+ | TextType !Word32 !Collation+ | XMLType !Word32+ deriving Show++data CryptoMetadata+ = CryptoMetadata+ { cryptoOrdinal :: !Word16+ , cryptoUserType :: !Word32+ , cryptoBaseType :: !TypeInfo+ , cryptoEncAlgo :: !EncryptionAlgorithm+ , cryptoAlgName :: !T.Text+ , cryptoAlgType :: !EncryptionAlgorithmType+ , cryptoNormVers :: !Word8+ } deriving Show++data ColumnData+ = ColumnData+ { cdUserType :: !Word32 -- Usually just 16-bits, but upgraded to 32 in TDS 7.4+ , cdFlags :: !Word16 -- TODO interpret this field+ , cdBaseTypeInfo :: !TypeInfo+ , cdTableName :: !(Maybe T.Text)+ , cdCrypto :: !(Maybe CryptoMetadata)+ , cdColName :: !T.Text+ } deriving Show++data ColumnMetadata+ = ColumnMetadata+ { cmCekTbl :: BS.ByteString+ , cmColData :: [ ColumnData ]+ } deriving Show++-- Defer data parsing to the end user. We only know enough about types to supply a proper length.+data RawColumn f where+ RawColumn :: ColumnData -> SBS.ByteString IO () -> (SBS.ByteString IO () -> f) -> RawColumn f+deriving instance Functor RawColumn++typeInfoParser :: A.Parser TypeInfo+typeInfoParser = do+ tag <- A.anyWord8+ case tag of+ 0x1F -> pure $ NullType+ 0x22 -> lLen $ ImageType+ 0x23 -> collation $ lLen $ TextType+ 0x24 -> bLen $ GuidType -- GUID+ 0x25 -> bLen $ VarBinType+ 0x26 -> bLen $ IntNType True -- INT(n)+ 0x27 -> noColl $ bLen $ VarcharType ByteLen NormalChar+ 0x28 -> bLen $ DateNType True+ 0x29 -> bLen $ TimeNType True+ 0x2A -> bLen $ DtTm2NType+ 0x2B -> bLen $ DtTmOfsType+ 0x2D -> bLen $ BinaryType+ 0x2F -> noColl $ bLen $ CharType ByteLen NormalChar+ 0x37 -> precScale $ bLen $ DecimalNType True -- DECIMAL (legacy) is this 4?+ 0x3F -> precScale $ bLen $ NumericType True -- NUMERIC (legacy)+ 0x30 -> pure $ IntNType False 1 -- TINYINT+ 0x32 -> pure $ BitNType False 1 -- BIT+ 0x34 -> pure $ IntNType False 2 -- SMALLINT+ 0x38 -> pure $ IntNType False 4 -- INT+ 0x3A -> pure $ DtTmNType False 4 -- SMALLDATETIME+ 0x3B -> pure $ FloatNType False 4 -- REAL+ 0x3C -> pure $ MoneyNType False 8 -- MONEY+ 0x3D -> pure $ DtTmNType True 8 -- DATETIME+ 0x3E -> pure $ FloatNType False 8 -- FLOAT8+ 0x62 -> lLen $ SSVarType+ 0x63 -> collation $ lLen $ NTextType+ 0x68 -> bLen $ BitNType True+ 0x6A -> precScale $ bLen $ DecimalNType True+ 0x6C -> precScale $ bLen $ NumericNType True+ 0x6D -> bLen $ FloatNType True+ 0x6E -> bLen $ MoneyNType True+ 0x6F -> bLen $ DtTmNType True+ 0x7A -> pure $ MoneyNType False 4 -- SMALLMONEY+ 0x7F -> pure $ IntNType False 8 -- BIGINT+ 0xA5 -> usLen $ VarBinType+ 0xA7 -> optColl $ usLen $ VarcharType ShortLen NormalChar+ 0xAD -> usLen $ BinaryType+ 0xAF -> optColl $ usLen $ CharType ShortLen NormalChar+ 0xE7 -> optColl $ usLen $ VarcharType ShortLen NationalChar+ 0xEF -> optColl $ usLen $ CharType ShortLen NationalChar+ 0xF1 -> usLen $ XMLType+ 0xF0 -> fail "CLR UDT not supported"+ _ -> fail ("Unknown TypeInfo tag " ++ show tag)++ where+ bLen, usLen, lLen :: Num a => (a -> b) -> A.Parser b+ bLen mk = mk . fromIntegral <$> A.anyWord8+ usLen mk = mk . fromIntegral <$> anyWord16le+ lLen mk = mk . fromIntegral <$> anyWord32le++ precScale mk = do+ prec <- A.anyWord8+ scale <- A.anyWord8+ mk <*> pure (PrecScale prec scale)++ collation mk =+ mk <*> collationP+ optColl mk =+ mk <*> (fmap Just collationP)+ noColl mk = mk <*> pure Nothing++ collationP = do+ lcidData <- anyWord32le++ let lcid = LCID (fromIntegral (lcidData .&. 0xFFFFF))+ colFlags = CollationFlags (fromIntegral ((lcidData `shiftR` 20) .&. 0xFF))+ version = CollationVersion (fromIntegral ((lcidData `shiftR` 28) .&. 0xF))++ sortId <- A.anyWord8 -- TODO unused ?++ pure (Collation lcid colFlags version)++colDataParser :: A.Parser ColumnData+colDataParser = do+ userType <- fromIntegral <$> anyWord16le+ flags <- anyWord16le+ typeInfo <- typeInfoParser++ let hasTableName =+ case typeInfo of+ NTextType {} -> True+ TextType {} -> True+ ImageType {} -> True+ _ -> False++ tblName <- if hasTableName+ then fail "TODO table name parsing"+ else pure Nothing++ -- TODO Column encryption data++ (_, colNm) <- bVarChar++ pure (ColumnData userType flags typeInfo tblName Nothing colNm)++colMetadataP :: A.Parser ColumnMetadata+colMetadataP = do+ colCnt <- fromIntegral <$> anyWord16le++ -- Cek table not present until TDS 7.4++ let columnsPresent = if colCnt == 0xFFFF then 0 else colCnt++ colsData <- replicateM columnsPresent colDataParser++ if columnsPresent == 0+ then do -- No columns means we should have the informational 0xFFFF marker present+ metadata <- anyWord16le+ when (metadata /= 0xFFFF) (fail "TDS COLMETADATA decode error: Columns present")+ pure (ColumnMetadata mempty [])+ else+ pure (ColumnMetadata mempty colsData)++newtype RowResults+ = RowResults+ { getRowResults :: S.Stream (Compose (S.Of ColumnMetadata)+ (S.Stream (S.Stream RawColumn IO) IO))+ IO ()+ }++instance Show RowResults where+ show _ = "RowResults <stream>"++instance Response RowResults where+ type ResponseStreaming RowResults = 'TokenStream++ responseDecoder = DecodeTokenStream (\finish s ->+ pure (RowResults (resultsDecoder s >>+ liftIO finish)))+ where+ resultsDecoder :: S.Stream TokenStream IO a+ -> S.Stream (Compose (S.Of ColumnMetadata)+ (S.Stream (S.Stream RawColumn IO) IO))+ IO ()+ resultsDecoder tokens =+ do res <- liftIO $ S.inspect tokens+ case res of+ Left a -> pure () -- fail "Tokens ended prematurely"+ Right (OneToken (ColMetadata mt) next) ->+ S.wrap (Compose (mt S.:> parseRowData mt next))+ Right (OneToken Done {} next) ->+ pure () -- fail "Tokens ended before getting result"+ Right (OneToken _ next) -> resultsDecoder next+ Right (ContParse tok _) -> fail ("Can't parse " ++ show (() <$ tok))++ parseRowData :: ColumnMetadata+ -> S.Stream TokenStream IO a+ -> S.Stream (S.Stream RawColumn IO)+ IO+ (S.Stream+ (Compose+ (S.Of ColumnMetadata) (S.Stream (S.Stream RawColumn IO) IO))+ IO ())+ parseRowData cols tokens =+ do res <- liftIO $ S.inspect tokens+ case res of+ Left a -> fail "Tokens ended while parsing row results"+ Right (OneToken (Done sts _ _) next)+ | doneHasMore sts -> pure (resultsDecoder next)+ | otherwise -> pure (pure ())+ Right (OneToken _ next) -> parseRowData cols next+ Right (ContParse (Row rowData) next) ->+ S.wrap (parseColumns cols (cmColData cols) rowData next)+ Right (ContParse tok _) -> fail ("Unknown token while parsing row result: " ++ show (() <$ tok))++ parseColumns :: ColumnMetadata -> [ColumnData]+ -> SBS.ByteString IO ()+ -> (SBS.ByteString IO () -> S.Stream TokenStream IO a)+ -> S.Stream RawColumn IO+ (S.Stream (S.Stream RawColumn IO) IO+ (S.Stream (Compose+ (S.Of ColumnMetadata)+ (S.Stream (S.Stream RawColumn IO) IO))+ IO ()))+ -- Done parsing row data+ parseColumns mt [] rowData next =+ pure (parseRowData mt (next rowData))+ parseColumns mt (col:cols) rowData next =+ S.wrap (RawColumn col rowData (\row -> parseColumns mt cols row next))+++-- * Splitting packets++data SplitEncoding sender resp pld+ = LastPacket (Ptr () -> IO CSize)+ | OnePacket (Ptr () -> IO (Packet sender resp pld (SplitEncoding sender resp)))++type SplitPacket sender resp pld =+ Packet sender resp pld (SplitEncoding sender resp)++splitPacket :: CSize -> Packet 'Client resp d PacketEncoding+ -> (Maybe CSize, SplitPacket 'Client resp d)+splitPacket bufSz (Packet pktHdr (PacketEncoding encoder)) =+ case encoder of+ PayloadBatchEncoder len builder ->+ let chunkSz = min bufSz (fromIntegral len)+ chunks = toLazyByteStringWith (untrimmedStrategy (fromIntegral chunkSz)+ (fromIntegral chunkSz))+ mempty+ builder++ unfoldSplit _ _ [] = error "No data in packet"+ unfoldSplit i lenLeft (a:as) =+ let (ptr, ofs, len) = IBS.toForeignPtr a+ in Packet (pktHdr { pktHdrSeqID = PacketSequenceID (i + 1) }) $+ if null as || len == lenLeft+ then LastPacket $ \dst ->+ withForeignPtr ptr $ \ptrRaw ->+ copyBytes dst (castPtr ptrRaw `plusPtr` ofs) lenLeft >>+ pure (fromIntegral lenLeft)+ else OnePacket $ \dst ->+ withForeignPtr ptr $ \ptrRaw ->+ copyBytes dst (castPtr ptrRaw `plusPtr` ofs) (fromIntegral chunkSz) >>+ pure (unfoldSplit (i + 1) (lenLeft - BS.length a)+ as)++ in ( Just chunkSz+ , unfoldSplit 0 (fromIntegral len) (BL.toChunks chunks) )+ PayloadStreamEncoder builder ->+ error "PayloadStreamEncoder TODO"++-- * KnownBool type class++class KnownBool (b :: Bool) where+ boolVal :: p b -> Bool++instance KnownBool 'True where+ boolVal _ = True+instance KnownBool 'False where+ boolVal _ = False
+ Database/TDS/Proto/Errors.hs view
@@ -0,0 +1,23 @@+module Database.TDS.Proto.Errors where++import Data.Word++-- | Error code in @ERROR@ token+newtype SQLError = SQLError Word32 deriving Show++-- * Error classes++-- | ERROR @cls@ field+newtype ErrorClass = ErrorClass Word8 deriving Show++data Severity+ = Information+ | Fatal+ deriving Show++clsSeverity :: ErrorClass -> Severity+clsSeverity (ErrorClass cls)+ | cls <= 10 = Information+ | cls > 10 = Fatal++
+ Database/TDS/Query.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Database.TDS.Query where++import qualified Database.TDS.Proto as Proto+import Database.TDS.Types++import Control.Exception ( Exception, SomeException(..)+ , bracket, onException+ , throwIO, catch, mask )++import Data.Bifunctor+import Data.Bits+import qualified Data.ByteString.Streaming as SBS+import qualified Data.ByteString.Internal as IBS+import Data.Foldable+import Data.Maybe+import Data.Ratio+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import qualified Data.Text.IO as T+import Data.Word++import Debug.Trace++import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable++import Numeric++import System.IO+import qualified Streaming as S+import qualified Streaming.Prelude as S++newtype MsSQLRuntimeError = MsSQLRuntimeError T.Text+ deriving Show+instance Exception MsSQLRuntimeError++withTransaction :: Connection -> IO a -> IO a+withTransaction conn go =+ mask $ \unmask -> do+ beginTransaction conn+ res <- (unmask (fmap Right go <*+ commitTransaction conn)+ `catch` (\e@(MsSQLRuntimeError {}) -> pure (Left e)))+ `catch` (\e@(SomeException {}) -> hPutStrLn stderr ("Caught exception " ++ show e) >> rollbackTransaction conn >> throwIO e)+ case res of+ Right x -> pure x+ Left err -> throwIO err++execNoRows :: Connection -> T.Text -> IO ()+execNoRows tds q = do+ let sql = Proto.mkPacket (Proto.mkPacketHeader Proto.SQLBatch mempty) q+ getRes <- tdsSendPacket tds sql+ ResponseResultReceived (Proto.RowResults rows) <- getRes+ res <- S.inspect rows+ case res of+ Left () -> pure ()+ Right {} -> throwIO (MsSQLRuntimeError (T.pack ("Expected no rows for statement: " ++ T.unpack q)))++beginTransaction, commitTransaction, rollbackTransaction :: Connection -> IO ()+beginTransaction tds = execNoRows tds "BEGIN TRANSACTION"+commitTransaction tds = execNoRows tds "COMMIT TRANSACTION"+rollbackTransaction tds = execNoRows tds "ROLLBACK TRANSACTION"++query :: Connection -> T.Text -> IO ()+query conn sqlTxt = do+ let sqlBatch = Proto.mkPacket (Proto.mkPacketHeader Proto.SQLBatch mempty)+ sqlTxt++ getRes <- tdsSendPacket conn sqlBatch++ ResponseResultReceived (Proto.RowResults rows) <- getRes++ S.mapsM_ (\(S.Compose (cols S.:> rows')) -> do+ S.mapsM_ (\row -> S.mapsM_ (\(Proto.RawColumn columnType columnData next) -> do+ bs' <- S.liftIO (printColumn columnType columnData)+ pure (next bs')) row) rows')+ rows++ pure ()++take8 :: Monad m => SBS.ByteString m () -> m (Word8, SBS.ByteString m ())+take8 bs = do+ r <- SBS.uncons bs+ case r of+ Nothing -> fail "take8: no more bytes"+ Just (r, bs') -> pure (r, bs')++take16LE :: S.MonadIO m => SBS.ByteString m () -> m (Word16, SBS.ByteString m ())+take16LE bs = do+ a S.:> bs' <- SBS.toStrict (SBS.splitAt 2 bs)+ let (fPtr, ofs, _) = IBS.toForeignPtr a+ x <- S.liftIO . withForeignPtr fPtr $ \ptr ->+ peek (ptr `plusPtr` ofs)+ pure (x, bs')+-- (lo, bs') <- first fromIntegral <$> take8 bs+-- (hi, bs'') <- first fromIntegral <$> take8 bs'+-- pure ((hi `shiftL` 8) .|. lo, bs'')++takeLength :: S.MonadIO m => Proto.TypeLen -> SBS.ByteString m () -> m (Word16, SBS.ByteString m ())+takeLength Proto.ShortLen = take16LE+takeLength Proto.ByteLen = fmap (first fromIntegral) . take16LE++takeLE :: Monad m => Int -> SBS.ByteString m () -> m (Integer, SBS.ByteString m ())+takeLE n bs = foldlM (\(!a, bs') shift -> do+ (x, bs'') <- take8 bs'+ pure (a .|. (fromIntegral x `shiftL` shift), bs''))+ (0, bs) (fmap (*8) [0..n-1])++printNumeric :: String -> Bool -> Word8 -> Proto.PrecScale -> SBS.ByteString IO ()+ -> IO (SBS.ByteString IO ())+printNumeric s True sz precScale d = do+ (realSz, d') <- take8 d+ if realSz == 0+ then do+ putStrLn (s ++ "(" ++ show sz ++ ", " ++ show precScale ++ "): (NULL)")+ pure d'+ else printNumeric s False realSz precScale d'+printNumeric s False sz precScale@(Proto.PrecScale p scale) d = do+ putStr (s ++ "(" ++ show sz ++ ", " ++ show precScale ++ "):")+ (sign, d') <- take8 d+ let intSz | p <= 9 = 4+ | p <= 19 = 8+ | p <= 28 = 12+ | otherwise = 16+ (num, d'') <- takeLE (fromIntegral sz - 1) d'+ let res = num % (10 ^ fromIntegral scale)++ res' :: Rational+ res' = if sign == 0 then negate res else res++ putStrLn (show res')++ pure d''++printColumn :: Proto.ColumnData -> SBS.ByteString IO () -> IO (SBS.ByteString IO ())+printColumn ty d =+ case Proto.cdBaseTypeInfo ty of+ Proto.VarcharType typeLen Proto.NationalChar len coll -> do+-- putStr ("NVARCHAR(" ++ show len ++ ") COLLATION " ++ show coll ++ ": ")+ (len, d') <- takeLength typeLen d++ if len == 0xFFFF+ then do+ putStrLn "(NULL)"+ pure d'+ else do+ let d'' = SBS.splitAt (fromIntegral len) d'+ byteData S.:> d''' <- SBS.toStrict d''+ T.putStrLn (TE.decodeUtf16LE byteData)++ pure d'''+ Proto.IntNType False 4 -> do+ (n, d') <-takeLE 4 d+-- putStrLn ("INT: " ++ show n)+ pure d'+ Proto.IntNType False bytes -> do+ (n, d') <- takeLE (fromIntegral bytes) d+-- putStrLn ("INT(" ++ show bytes ++ "): " ++ show n)+ pure d'+ Proto.IntNType True bytes -> do+ (realWidth, d') <- take8 d+ if realWidth == 0+ then do+ putStrLn ("INT(" ++ show bytes ++ "): (NULL)")+ pure d'+ else do+ (n, d'') <- takeLE (fromIntegral bytes) d'+ putStrLn ("INT(" ++ show bytes ++ "): " ++ show n)+ pure d''+ Proto.DecimalNType nullable sz precScale ->+ printNumeric "DECIMAL" nullable sz precScale d+ Proto.NumericNType nullable sz precScale ->+ printNumeric "NUMERIC" nullable sz precScale d+ _ -> fail ("Can't print data of type " ++ show ty)
+ Database/TDS/Types.hs view
@@ -0,0 +1,312 @@+{-# OPTIONS_GHC -funbox-strict-fields #-}+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE StandaloneDeriving #-}++module Database.TDS.Types where++import Control.Applicative+import Control.Concurrent.STM+import Control.Exception+import Control.Monad.Identity++import Data.Monoid ((<>))+import qualified Data.Text as T+import Data.Word++import qualified Database.TDS.Proto as Proto+import qualified Database.TDS.Proto.Errors as Proto++import System.IO++-- From MS-TDS reference:+--+-- https://msdn.microsoft.com/en-us/library/dd304523.aspx+-- Version 12/1/2017++-- | Client state type based on recommendation on page 120+data ClientState+ = Connecting+ | SentPreLogin+ | SentTLSSSLNegotiation+ | SentLogin7WithCompleteAuthenticationToken+ | SentLogin7WithSPNEGO+ | SentLogin7WithFAIR+ | LoggedIn+ | SentClientRequest+ | SentAttention+ | RoutingCompleted+ | Final+ deriving (Show, Enum, Eq, Ord, Bounded)++sendableInState :: Proto.PacketType sender resp d -> ClientState -> Bool+sendableInState Proto.PreLogin Connecting = True+sendableInState Proto.Login7 SentPreLogin = True+sendableInState Proto.TrMgrRequest LoggedIn = True+sendableInState Proto.SQLBatch LoggedIn = True+sendableInState Proto.Attention _ = True+sendableInState _ _ = False++stateTransition :: Proto.PacketType sender resp d -> ClientState -> ClientState+stateTransition Proto.PreLogin Connecting = SentPreLogin+stateTransition Proto.Login7 SentPreLogin = SentLogin7WithCompleteAuthenticationToken+stateTransition Proto.SQLBatch LoggedIn = SentClientRequest+stateTransition _ _ = Final++newtype ConnectionTimeout = ConnectionTimeout Int+ deriving (Show, Eq, Ord)++-- | Connection timeout in seconds+connectionTimeout :: ConnectionTimeout+connectionTimeout = ConnectionTimeout 15++-- * Protocol Errors++data TDSErrorType+ = TDSNoSuchHost | TDSSocketError+ | TDSServerUninitialized+ | TDSServerBusy | TDSServerQuit+ | TDSInvalidStateTransition+ | TDSInvalidResponse+ deriving Show++data TDSError where+ TDSError ::+ Show d =>+ { tdsErrorType :: !TDSErrorType+ , tdsErrorState :: !ClientState+ , tdsErrorRequest :: !(Maybe (Proto.Packet sender resp d Identity))+ , tdsErrorMessage :: !String+ } -> TDSError+deriving instance Show TDSError++tdsErrorNoReq :: TDSErrorType -> ClientState -> String -> TDSError+tdsErrorNoReq ty st =+ TDSError ty st+ (Nothing :: Maybe (Proto.Packet 'Proto.Client 'Proto.NoResponse () Identity))++instance Exception TDSError where+ displayException e =+ unlines ([ "TDS Error\n"+ , " " <> tdsErrorMessage e <> "\n"+ , " Type: " <> show (tdsErrorType e)+ , " State: " <> show (tdsErrorState e) ] +++ case e of+ TDSError { tdsErrorRequest = Nothing } -> []+ TDSError { tdsErrorRequest = Just req } ->+ [ " Request: ", Proto.displayRequest req ])++-- * Options++data ConnectionInfo+ = ConnectionInfo+ { _tdsConnHost :: Maybe String+ , _tdsConnPort :: Maybe Word16+ } deriving (Show, Eq, Ord)++instance Monoid ConnectionInfo where+ mempty = ConnectionInfo Nothing Nothing+ mappend a b =+ ConnectionInfo+ { _tdsConnHost = _tdsConnHost b <|> _tdsConnHost a+ , _tdsConnPort = _tdsConnPort b <|> _tdsConnPort a+ }++instance Semigroup ConnectionInfo where+ (<>) = mappend++data TdsAuth = TdsAuth deriving (Show, Eq, Ord)++data Options+ = Options+ { _tdsOptionsSecure :: Bool++ , _tdsAuth :: Maybe TdsAuth++ , _tdsConnInfo :: ConnectionInfo++ , _tdsOnMessage :: Proto.Message -> IO ()+ , _tdsOnEnvChange :: Proto.EnvChange -> IO ()++ , _tdsUser :: T.Text+ , _tdsPassword :: T.Text+ , _tdsDatabase :: T.Text+ , _tdsAppName :: T.Text+ , _tdsClientName :: T.Text+ }++instance Monoid Options where+ mempty =+ Options+ { _tdsOptionsSecure = False+ , _tdsAuth = Nothing+ , _tdsConnInfo = mempty+ , _tdsOnMessage = \_ -> pure ()+ , _tdsOnEnvChange = \_ -> pure ()++ , _tdsUser = ""+ , _tdsPassword = ""+ , _tdsDatabase = ""+ , _tdsAppName = ""+ , _tdsClientName = ""+ }++ mappend a b =+ Options+ { _tdsOptionsSecure =+ _tdsOptionsSecure a || _tdsOptionsSecure b+ , _tdsAuth = _tdsAuth b <|> _tdsAuth a+ , _tdsConnInfo = _tdsConnInfo a <> _tdsConnInfo b+ , _tdsOnMessage = _tdsOnMessage a >> _tdsOnMessage b+ , _tdsOnEnvChange = _tdsOnEnvChange a >> _tdsOnEnvChange b++ , _tdsUser = altText (_tdsUser a) (_tdsUser b)+ , _tdsPassword = altText (_tdsPassword a) (_tdsPassword b)+ , _tdsDatabase = altText (_tdsDatabase a) (_tdsDatabase b)+ , _tdsAppName = altText (_tdsAppName a) (_tdsAppName b)+ , _tdsClientName = altText (_tdsClientName a) (_tdsClientName b)+ }+ where+ altText a b+ | T.null a = b+ | otherwise = a++instance Semigroup Options where+ (<>) = mappend++defaultOptions :: Options+defaultOptions =+ mempty+ { _tdsConnInfo = ConnectionInfo+ { _tdsConnHost = Just "localhost"+ , _tdsConnPort = Just 1433+ }+ , _tdsClientName = "haskell-tds"+ }++tdsOptionSecure :: Options+tdsOptionSecure =+ mempty { _tdsOptionsSecure = True }++tdsOptionHost :: String -> Options+tdsOptionHost h = mempty { _tdsConnInfo = mempty { _tdsConnHost = Just h } }++tdsOptionPort :: Word16 -> Options+tdsOptionPort p = mempty { _tdsConnInfo = mempty { _tdsConnPort = Just p } }++tdsOptionUserAndPassword :: T.Text -> T.Text -> Options+tdsOptionUserAndPassword user pw = mempty { _tdsUser = user+ , _tdsPassword = pw }++tdsOptionDatabase :: T.Text -> Options+tdsOptionDatabase db = mempty { _tdsDatabase = db }++tdsDebugLogging :: Options+tdsDebugLogging = mempty { _tdsOnMessage = debugMsg+ , _tdsOnEnvChange = debugEnvChange }+ where+ debugEnvChange c = hPutStrLn stderr ("[ENVCHANGE] " ++ show c)+ debugMsg msg =+ do let level = case Proto.clsSeverity (Proto.messageClass msg) of+ Proto.Information -> "[INFO ] "+ Proto.Fatal -> "[FATAL ] "++ Proto.SQLError msgCode = Proto.messageCode msg+ Proto.ErrorClass cls = Proto.messageClass msg++ hPutStr stderr . unlines . map (level <>) $+ [ "Message Code: " ++ show msg+ , "Message Status: " ++ show (Proto.messageSt msg)+ , "Message Class: " ++ show cls+ , ""+ , " " ++ T.unpack (Proto.messageText msg)+ , ""+ , "Server name: " ++ T.unpack (Proto.messageServerName msg)+ , "Process name: " ++ T.unpack (Proto.messageProcName msg)+ , "Line Number: " ++ show (Proto.messageLineNum msg)+ ]++-- * Connection object++data ResponseResult (ty :: Proto.ResponseType *) where+ ResponseResultCancelled :: ResponseResult ('Proto.ResponseType 'True a)+ ResponseResultReceived :: Show a => a -> ResponseResult ('Proto.ResponseType cancelable a)+deriving instance Show (ResponseResult ty)++data CancelInfo (canCancel :: Bool) where+ NonCancelable :: CancelInfo 'False+ Cancelable :: TVar Bool -> TMVar () -> CancelInfo 'True++class MkCancelable (canCancel :: Bool) where+ mkCancelable :: STM (CancelInfo canCancel)++instance MkCancelable 'False where+ mkCancelable = pure NonCancelable+instance MkCancelable 'True where+ mkCancelable = Cancelable <$> newTVar False <*> newEmptyTMVar++data Connection+ = Connection+ { tdsSendPacket :: forall (sender :: Proto.Sender) (d :: *)+ (cancelable :: Bool) (res :: *)+ . ( Proto.Payload d, Proto.Response res+ , Proto.KnownBool cancelable+ , MkCancelable cancelable )+ => Proto.Packet 'Proto.Client+ ('Proto.ExpectsResponse ('Proto.ResponseType cancelable res))+ d Identity+ -> IO (IO (ResponseResult ('Proto.ResponseType cancelable res)))+ , tdsCancel :: IO ()+ , tdsQuit :: IO ()++ , tdsConnectionState :: !(TVar ClientState)++ , tdsConnectionOptions :: !Options+ }++getReadyState :: Connection -> IO ClientState+getReadyState c =+ atomically $+ readTVar (tdsConnectionState c)++-- | Returns 'True' if the client is connected to the server. 'False'+-- otherwise+isConnected :: Connection -> IO Bool+isConnected c =+ getReadyState c >>=+ \case+ Final -> pure False+ _ -> pure True++-- | Returns 'True' if the client is ready to send commands to the+-- server. 'False' otherwise+isReady :: Connection -> IO Bool+isReady c =+ getReadyState c >>=+ \case+ LoggedIn -> pure True+ _ -> pure False++-- | Returns 'True' if the server is busy processing a+-- request. 'False' otherwise+isBusy :: Connection -> IO Bool+isBusy c =+ getReadyState c >>=+ \case+ SentClientRequest -> pure True+ SentAttention -> pure True+ _ -> pure False++-- | Returns 'True' if the server is processing a request that can be+-- canceled. 'False' otherwise+isCancelable :: Connection -> IO Bool+isCancelable c =+ getReadyState c >>=+ \case+ SentClientRequest -> pure True+ _ -> pure False
+ LICENSE view
@@ -0,0 +1,8 @@+The MIT License (MIT)+Copyright (c) 2018 Travis Athougies++Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,8 @@+# tds: Low-level Haskell TDS interface++This is a low-level client library for databases that support the TDS wire protocol (SQL Server and Sybase for example).++This library does not provide high-level primitives to parse row results. Rather, it works on converting the underlying token streams into something off of which higher-level parsers can be +efficiently developed.++This library is used in `beam-mssql` to provide wire-protocol support.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Test.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-}++import Database.TDS++import GHC.IO.Encoding++main :: IO ()+main = do+ setLocaleEncoding utf8 -- Needed for stack exec on nix++ let o = tdsOptionHost "172.17.0.1" <> tdsOptionPort 1401 <> tdsDebugLogging <>+ tdsOptionSecure <> tdsOptionUserAndPassword "SA" "beamTest!"+ conn <- login o++ connSt <- getReadyState conn+ putStrLn ("Connection is now in state " ++ show connSt)++ query conn "SELECT * FROM [Track]"++ pure ()+
+ tds.cabal view
@@ -0,0 +1,65 @@+name: tds+version: 0.1.0.0+synopsis: Pure Haskell TDS protocol implementation. Mainly for beam-mssql and beam-sybase+description:+ This is a work in progress! Please report bugs on github++ Low-level Haskell TDS implementation+homepage: https://github.com/tathougies/beam-tds#readme+license: MIT+license-file: LICENSE+author: Travis Athougies+maintainer: travis@athougies.net+copyright: Copyright (C) 2018 Travis Athougies+category: Database+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ exposed-modules: Database.TDS+ Database.TDS.Types+ Database.TDS.Connection+ Database.TDS.Login+ Database.TDS.Query++ Database.TDS.Proto+ Database.TDS.Proto.Errors++ build-depends: base >=4.7 && < 5,+ bytestring >=0.10 && <0.11,+ mtl >=2.2 && <2.3,+ text >=1.2 && <1.3,+ stm >=2.0 && <2.6,+ transformers >=0.5 && <0.6,+ network >=2.8 && <2.9,+ tardis >=0.4 && <0.5,+ unix >=2.7 && <2.8,+ streaming >=0.2 && <0.3,+ streaming-attoparsec >=1.0 && <1.1,+ streaming-bytestring >=0.1 && <0.2,+ attoparsec >=0.13 && <0.14,+ attoparsec-binary >=0.2 && <0.3,+ hostname >=1.0 && <1.1,+ vector >=0.11 && <0.13+ default-language: Haskell2010+ ghc-options: -O2++executable test+ build-depends: base >=4.7 && <5,+ tds+ hs-source-dirs: src+ main-is: Test.hs+ default-language: Haskell2010+ ghc-options: -O2 -Wall+ if flag(werror)+ ghc-options: -Werror++source-repository head+ type: git+ location: https://github.com/tathougies/tds++flag werror+ description: Enable -Werror during development+ default: False+ manual: True