-- This is written in Haskell.
{--
HBase -- general-purpose libraries for Haskell
Copyright (C) 2002 Ashley Yakeley <ashley@semantic.org>

This library is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public
License as published by the Free Software Foundation; either
version 2.1 of the License, or (at your option) any later version.

This library is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
Lesser General Public License for more details.

You should have received a copy of the GNU Lesser General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
--}

module Foreign.MySQL.Session
	(
	MySQLSession,MySQLError(..),MySQLMonad,MySQLDatabase(..)
	) where
	{
	import Foreign.MySQL.Raw;
	import Foreign.MySQL.RawField;
	import Foreign.MySQL.FieldType;
	import HBase.Encoding.SQL;
	import HBase.Encoding.URI;
	import HBase.Protocol.Internet;
	import HBase;
	import Foreign.C;
	import Foreign;

	data MySQLError = MkMySQLError Word32 String;

	instance Show MySQLError where
		{
		show (MkMySQLError code text) = text ++ " (MySQL error #" ++ (show code) ++ ")";
		};

	instance MaybeA ShowException MySQLError where
		{
		maybeConvert = Just . convert;
		};

	instance IsA ShowException MySQLError where
		{
		convert = MkShowException . show;
		};

	type MySQLMonad = ExceptionMonad IO MySQLError;

	checkError :: MySQLSession -> IO a -> MySQLMonad a;
	checkError session foo = MkExceptionMonad (do
		{
		a <- foo;
		errno <- rawErrno session;
		if errno == 0
		 then return (SuccessResult a)
		 else do
			{
			sptr <- rawError session;
			text <- peekCString sptr;
			return (ExceptionResult (MkMySQLError errno text));
			};
		});

	withSP :: [Word8] -> (CStringPtr -> ExceptionMonad IO ex r) -> ExceptionMonad IO ex r;
	withSP bytes foo = MkExceptionMonad (withCStringPtr bytes (\sptr -> unExceptionMonad (foo sptr)));

	withArr :: (Storable a) =>
	 [a] -> (Ptr a -> ExceptionMonad IO ex r) -> ExceptionMonad IO ex r;
	withArr list foo = MkExceptionMonad (withArray list (\sptr -> unExceptionMonad (foo sptr)));

	getPtrOffset :: (Storable a) =>
	 Word32 -> Ptr a -> ExceptionMonad IO ex a;
	getPtrOffset i ptr = lift (getRef (offsetPtrToRef (convert i) ptr));

	data MySQLDatabase =MkMySQLDatabase
		{
		dbAccess :: TCPAccess,
		dbName :: [Word8]
		};

	instance CloseSession (ExceptionMonad IO ex) MySQLSession where
		{
		closeSession session = lift (rawClose session);
		};

	instance Session MySQLMonad MySQLDatabase MySQLSession where
		{
		openSession
		 (MkMySQLDatabase (MkTCPAccess (MkTCPPortSpec (MkDNSHostName hostname) mportnum) mUserIdent) dbname) =
		 withSP hostname (\hostnamePtr ->
		  withSP username (\usernamePtr ->
		   withSP pass (\passPtr ->
			withSP dbname (\dbnamePtr -> do
			{
			session <- lift (rawInit nothing);
			session' <- lift (rawRealConnect session hostnamePtr usernamePtr passPtr dbnamePtr (convert portNumber) nothing 0);
			checkError session' (return session');
			})))) where
			{
			(username,pass) = case mUserIdent of
				{
				Nothing -> ([],[]);
				Just (MkUserIdent un Nothing) -> (un,[]);
				Just (MkUserIdent un (Just ps)) -> (un,ps);
				};
			
			portNumber = case mportnum of
				{
				Nothing -> 0;
				Just (MkTCPPortNumber n) -> n;
				};
			};
		};

	instance SQLSession MySQLFieldType MySQLMonad MySQLDatabase MySQLSession where
		{
		sqlExec session sql = withArr query (\queryPtr -> do
			{
--lift (hPutStrLn stderr sql);
			checkError session (rawRealQuery session queryPtr (convertFromInt (length query)));
			result <- checkError session (rawStoreResult session); -- need to do this
			lift (rawFreeResult result);
			return ();
			}) where
			{
			query :: [Word8];
			query = encodeUTF8 sql;
			};

		sqlExecResult session sql foo = withArr query (\queryPtr -> do
			{
--lift (hPutStrLn stderr sql);
			checkError session (rawRealQuery session queryPtr (convertFromInt (length query)));
			result <- checkError session (rawUseResult session);
			nCols <- checkError session (rawFieldCount session);
			ftypes <- getFieldTypes result;
			list <- doRows result nCols ftypes;
			lift (rawFreeResult result);
			return list;
			}) where
			{
			query :: [Word8];
			query = encodeUTF8 sql;

			getFieldTypes :: MySQLResult -> MySQLMonad [MySQLFieldType];
			getFieldTypes result = do
				{
				rfptr <- checkError session (rawFetchField result);
				if isNothing rfptr
				 then return []
				 else do
					{
					rawfield <- lift (peek rfptr);
					ftypes <- getFieldTypes result;
					return ((fieldType rawfield):ftypes);
					};
				};
	
			toTextRow :: Word32 -> [MySQLFieldType] -> Word32 -> RawRow -> Ptr Word32 -> MySQLMonad [SQLItem MySQLFieldType];
			toTextRow nCols ftypes i row lengths = if (i >= nCols)
			 then return []
			 else do
				{
				ln <- getPtrOffset i lengths;
				sptr <- getPtrOffset i row;
				nthBytes <- lift (peekArray (convertToInt ln) sptr);
				case ftypes of
					{
					(ft:fts) -> do
						{
						items <- toTextRow nCols fts (i+1) row lengths;
						return ((MkSQLItem ft nthBytes):items);
						};
					[] -> fail "MySQL fieldtype/column mismatch";
					};
				};
	
			doRows result nCols ftypes = do
				{
				row <- checkError session (rawFetchRow result);
				if (isNothing row)
				 then return []
				 else do
					{
					lengths <- checkError session (rawFetchLengths result);
					textRow <- toTextRow nCols ftypes 0 row lengths;
					resFirst <- foo textRow;
					results <- doRows result nCols ftypes;
					return (resFirst:results);
					};
				};
			};
		};
	}