1: <%@ WebHandler Language="VB" Class="MetaWeblogAPI" %>
2:
3: Imports System.IO
4: Imports System.Data
5: Imports CookComputing.XmlRpc
6: Imports System.Data.SqlClient
7: Public Class MetaWeblogAPI
8: Inherits XmlRpcService : Implements IHttpHandler
9:
10: Private Shared Sub Authenticate(ByVal username As String, ByVal password As String)
11: ' Check the login and password in the database.
12: Dim iResult As Integer
13: Dim sqlConn As ConnectionStringSettings
14: sqlConn = ConfigurationManager.ConnectionStrings("SQLServer")
15: Dim objConn As New SqlConnection(sqlConn.ConnectionString)
16: Dim objCommand As SqlCommand
17: Dim objParam As SqlParameter
18: Try
19: objConn.Open()
20: objCommand = New SqlCommand("DBAuthenticate", objConn)
21: objCommand.CommandType = Data.CommandType.StoredProcedure
22: objParam = objCommand.Parameters.AddWithValue("RETURN_VALUE", 8)
23: objParam.Direction = Data.ParameterDirection.ReturnValue
24: objCommand.Parameters.AddWithValue("@username", username)
25: objCommand.Parameters.AddWithValue("@password", password)
26: objCommand.ExecuteNonQuery()
27: iResult = objCommand.Parameters("RETURN_VALUE").Value
28: ' The return value is going to be either -2 for an incorrect password,
29: ' -1 for an incorrect username or the UserID if it validates.
30: If (iResult < 0) Then
31: If (iResult = -1) Then
32: Throw New System.Security.Authentication.InvalidCredentialException("Incorrect UserName, please try again.")
33: Else
34: Throw New System.Security.Authentication.InvalidCredentialException("Incorrect Password, please try again.")
35: End If
36: End If
37: Catch ex As Exception
38: Throw New System.Security.Authentication.AuthenticationException("Authentication Error : " & ex.Message)
39: Finally
40: objConn.Close()
41: End Try
42: End Sub
43:
44: <XmlRpcMethod("blogger.getUsersBlogs")> _
45: Public Function getUsersBlogs(ByVal appKey As String, ByVal username As String, ByVal password As String) As XmlRpcStruct()
46: ' This is hardcoded to return only the ID of LPC. As its the only blog on this server,
47: ' it makes sense to do it this way instead of accessing the database.
48: Authenticate(username, password)
49: Dim rpcstruct As XmlRpcStruct = New XmlRpcStruct
50: rpcstruct.Add("blogid", "2")
51: rpcstruct.Add("blogName", "LPC")
52: rpcstruct.Add("url", "http://davewhite.net")
53: Dim datarpcstruct As XmlRpcStruct() = New XmlRpcStruct() {rpcstruct}
54: Return datarpcstruct
55: End Function
56:
57: <XmlRpcMethod("metaWeblog.setTemplate")> _
58: Public Function setTemplate(ByVal appKey As String, ByVal blogid As String, ByVal username As String, ByVal password As String, ByVal template As String, ByVal templateType As String) As Boolean
59: ' Unused - there's only one template
60: Authenticate(username, password)
61: Throw New System.NotImplementedException("SetTemplate is not implemented")
62: End Function
63:
64:
65: <XmlRpcMethod("metaWeblog.getCategories")> _
66: Public Function getCategories(ByVal blogid As String, ByVal username As String, ByVal password As String) As XmlRpcStruct()
67: ' This returns a list of categories. Although you don't see them on the front page, they are
68: ' actually there. They're fairly limited and I don't have any real use for them, but I may one day
69: ' expand their use. In looking through this I just found a huge error caused by writing this and then
70: ' re-using some of it without re-writing. Bad Dave, BAD. To be fixed.
71: Authenticate(username, password)
72: Dim sqlConn As ConnectionStringSettings
73: sqlConn = ConfigurationManager.ConnectionStrings("SQLServer")
74: Dim objConnection As SqlConnection
75: Dim objRecords As SqlDataReader
76: Dim strSQL2 As String = "select count(iID) from Categories"
77: objConnection = New SqlConnection(sqlConn.ConnectionString)
78: objConnection.Open()
79: Dim strSQL As String = "select * from Categories"
80: Dim i As Integer = 0
81: Dim iRecCount As Integer
82: Dim objcommand2 As New SqlCommand(strSQL2, objConnection)
83: iRecCount = objcommand2.ExecuteScalar
84: Dim categories(iRecCount - 1) As XmlRpcStruct
85: Dim objCommand As SqlCommand
86: objCommand = New SqlCommand(strSQL, objConnection)
87: objRecords = objCommand.ExecuteReader()
88: Try
89: If Not objRecords.HasRows Then
90: Throw New Exception("Oh oh... no categories!")
91: Exit Try
92: End If
93: While objRecords.HasRows AndAlso i < iRecCount
94: objRecords.Read()
95: Dim rpcstruct As New XmlRpcStruct
96: rpcstruct.Add("categoryid", objRecords("iID"))
97: rpcstruct.Add("title", objRecords("strCategory"))
98: rpcstruct.Add("description", objRecords("strDescription"))
99: categories(i) = rpcstruct
100: System.Math.Min(System.Threading.Interlocked.Increment(i), i - 1)
101: End While
102: Catch ex As Exception
103: If Not ex.Message = "Invalid attempt to read when no data is present." Then
104: Throw New Exception("Error : " & ex.Message)
105: End If
106: Finally
107: objRecords.Close()
108: objConnection.Close()
109: End Try
110: Return categories
111: End Function
112:
113: <XmlRpcMethod("metaWeblog.getRecentPosts")> _
114: Public Function getRecentPosts(ByVal blogid As String, ByVal username As String, ByVal password As String, ByVal numberOfPosts As Integer) As XmlRpcStruct()
115: ' This is the routine that is called when WLW opens the Recent Posts from the blog. Firstly we need
116: ' to authenticate that the username and password are indeed authorised...
117: Authenticate(username, password)
118: ' Then open the database and get the last numberOfPosts entries from the table.
119: Dim sqlConn As ConnectionStringSettings
120: sqlConn = ConfigurationManager.ConnectionStrings("SQLServer")
121: Dim objConn As New SqlConnection(sqlConn.ConnectionString)
122: objConn.Open()
123: Dim objRecords As SqlDataReader
124: ' Here we need posts of type 0 and 1, which are Drafts and Published Posts. There's a type 2 which
125: ' is deleted posts, but you never get to see that.
126: Dim objCommand As New SqlCommand("select top " & numberOfPosts & " * from Blog where PostType in (0,1) order by ID desc")
127: objCommand.Connection = objConn
128: objRecords = objCommand.ExecuteReader()
129: Dim posts(numberOfPosts - 1) As XmlRpcStruct
130: Dim i As Integer = 0
131: Try
132: While objRecords.Read AndAlso i < numberOfPosts
133: ' Loop and build out the XML structure
134: Dim rpcstruct As XmlRpcStruct = New XmlRpcStruct
135: rpcstruct.Add("title", objRecords("Title"))
136: rpcstruct.Add("link", "http://davewhite.net/default.aspx?id=" & objRecords("ID"))
137: rpcstruct.Add("description", LPC.Functions.TextFromDBToLiveWriter(objRecords("Text")))
138: rpcstruct.Add("dateCreated", LPC.Functions.GetDateTimeforBlogs(objRecords("DateAdded")))
139: If objRecords("Guid") Is DBNull.Value Then
140: rpcstruct.Add("guid", Guid.NewGuid.ToString)
141: Else
142: rpcstruct.Add("guid", objRecords("Guid").ToString)
143: End If
144: rpcstruct.Add("postid", objRecords("ID"))
145: rpcstruct.Add("author", "Dave White")
146: posts(i) = rpcstruct
147: System.Math.Min(System.Threading.Interlocked.Increment(i), i - 1)
148: End While
149: Catch ex As Exception
150: Throw New Exception("oh oh..." & ex.Message)
151: Finally
152: objRecords.Close()
153: objConn.Close()
154: End Try
155: Return posts
156: End Function
157:
158: <XmlRpcMethod("metaWeblog.getTemplate")> _
159: Public Function getTemplate(ByVal appKey As String, ByVal blogid As String, ByVal username As String, ByVal password As String, ByVal templateType As String) As String
160: ' Returns the template to whatever needs it. You know, I actually have no idea what purpose this
161: ' routine server for a WLW implementation. I have to check that.
162: Authenticate(username, password)
163: Dim template As String = "<HTML>" & Microsoft.VisualBasic.Chr(13) & "" & Microsoft.Visual... and lots more...
164: Return template
165: End Function
166:
167: <XmlRpcMethod("metaWeblog.newPost")> _
168: Public Function newPost(ByVal blogid As String, ByVal username As String, ByVal password As String, ByVal rpcstruct As XmlRpcStruct, ByVal publish As Boolean) As String
169: ' Publishing a new post with this one, and I've found something else I need to improve. I think
170: ' that I'm going to re-write this entire class after I post this entry.
171: Authenticate(username, password)
172: Dim iResult As Integer
173: Dim sqlConn As ConnectionStringSettings
174: sqlConn = ConfigurationManager.ConnectionStrings("SQLServer")
175: Dim objConn As New SqlConnection(sqlConn.ConnectionString)
176: Dim objCommand As SqlCommand
177: Dim objParam As SqlParameter
178: Try
179: objConn.Open()
180: objCommand = New SqlCommand("AddEntryFromService", objConn)
181: objCommand.CommandType = Data.CommandType.StoredProcedure
182: objCommand.Parameters.Add("@Title", SqlDbType.NVarChar)
183: objCommand.Parameters.Add("@Guid", SqlDbType.UniqueIdentifier)
184: objCommand.Parameters.Add("@Text", SqlDbType.NText)
185: objCommand.Parameters.Add("@PostType", SqlDbType.Int)
186: objCommand.Parameters.Add("@PostTime", SqlDbType.SmallDateTime)
187: ' Values
188: objCommand.Parameters("@Title").Value = rpcstruct("title").ToString
189: objCommand.Parameters("@Guid").Value = System.Guid.NewGuid
190: ' The line below used to munch through the post text and format it in such a way that it worked
191: ' properly in the blog, and was also valid HTML / XHTML. The new version of WLW actually posts
192: ' valid XHTML now, so it just isn't needed anymore.
193: 'objCommand.Parameters("@Text").Value = LPC.Functions.TextToDBFromLiveWriter(rpcstruct("description"))
194: objCommand.Parameters("@Text").Value = rpcstruct("description")
195: ' Check if this is a draft, or a post for publishing.
196: If publish = True Then
197: objCommand.Parameters("@PostType").Value = 1
198: Else
199: objCommand.Parameters("@PostType").Value = 0
200: End If
201: ' Check if the date has been specified. If not then set to UTC.
202: If Not rpcstruct("dateCreated") Is Nothing Then
203: objCommand.Parameters("@PostTime").Value = rpcstruct("dateCreated")
204: Else
205: objCommand.Parameters("@PostTime").Value = Now.ToUniversalTime
206: End If
207: objParam = objCommand.Parameters.AddWithValue("RETURN_VALUE", 8)
208: objParam.Direction = Data.ParameterDirection.ReturnValue
209: objCommand.ExecuteNonQuery()
210: iResult = objCommand.Parameters("RETURN_VALUE").Value
211: Catch ex As Exception
212: Throw New System.Security.Authentication.InvalidCredentialException("Error adding post : " & ex.Message)
213: Finally
214: objConn.Close()
215: End Try
216: Return iResult
217: End Function
218:
219: <XmlRpcMethod("metaWeblog.editPost")> _
220: Public Function editPost(ByVal postid As String, ByVal username As String, ByVal password As String, ByVal rpcstruct As XmlRpcStruct, ByVal publish As Boolean) As Boolean
221: ' This is the same as posting a new blog, except it takes the blog ID as a parameter.
222: Authenticate(username, password)
223: Dim Title, Blog As String
224: Dim sqlConn As ConnectionStringSettings
225: sqlConn = ConfigurationManager.ConnectionStrings("SQLServer")
226: Dim objConn As New SqlConnection(sqlConn.ConnectionString)
227: objConn.Open()
228: Dim objCommand As New SqlCommand("Update Blog set Title=@Title, Text=@Text, PostType=@PostType where ID=@iID", objConn)
229: Title = LPC.Functions.TextToDBFromLiveWriter(rpcstruct("title"))
230: Blog = LPC.Functions.TextToDBFromLiveWriter(rpcstruct("description"))
231: objCommand.Parameters.AddWithValue("@Title", Title)
232: objCommand.Parameters.AddWithValue("@Text", Blog)
233: objCommand.Parameters.AddWithValue("@iID", postid)
234: objCommand.Parameters.Add("@PostType", SqlDbType.Int)
235: If publish = True Then
236: objCommand.Parameters("@PostType").Value = 1
237: Else
238: objCommand.Parameters("@PostType").Value = 0
239: End If
240: Try
241: objCommand.ExecuteNonQuery()
242: Return True
243: Catch ex As Exception
244: Throw New Exception("There was a problem editing your post. (PostID : " & postid & ") Message (" & ex.Message & ")")
245: Return ex.Message
246: Finally
247: objConn.Close()
248: End Try
249: Return True
250: End Function
251:
252: <XmlRpcMethod("metaWeblog.getPost")> _
253: Public Function getPost(ByVal postid As String, ByVal username As String, ByVal password As String) As XmlRpcStruct
254: ' Reads a specific post from the database.
255: Authenticate(username, password)
256: Dim sqlConn As ConnectionStringSettings
257: sqlConn = ConfigurationManager.ConnectionStrings("SQLServer")
258: Dim objConn As New SqlConnection(sqlConn.ConnectionString)
259: objConn.Open()
260: Dim objRecords As SqlDataReader
261: Dim objCommand As New SqlCommand("select * from Blog where ID=@ID", objConn)
262: objCommand.Parameters.Add("@ID", SqlDbType.Int)
263: objCommand.Parameters("@ID").Value = CInt(postid)
264: Dim rpcstruct As XmlRpcStruct = New XmlRpcStruct
265: Try
266: objRecords = objCommand.ExecuteReader()
267: objRecords.Read()
268: rpcstruct.Add("title", objRecords("Title"))
269: rpcstruct.Add("link", "http://davewhite.net/default.aspx?id=" & objRecords("ID"))
270: rpcstruct.Add("description", LPC.Functions.TextFromDBToLiveWriter(objRecords("Text")))
271: rpcstruct.Add("dateCreated", LPC.Functions.GetDateTimeforBlogs(objRecords("DateAdded")))
272: If objRecords("Guid") Is DBNull.Value Then
273: rpcstruct.Add("guid", Guid.NewGuid.ToString)
274: Else
275: rpcstruct.Add("guid", objRecords("Guid").ToString)
276: End If
277: rpcstruct.Add("postid", objRecords("ID"))
278: rpcstruct.Add("author", "Dave White")
279: objRecords.Close()
280: Catch ex As Exception
281: Throw New Exception("What happened?")
282: Finally
283: objConn.Close()
284: End Try
285: Return rpcstruct
286: End Function
287:
288: <XmlRpcMethod("blogger.deletePost")> _
289: Public Function deletePost(ByVal appKey As String, ByVal postid As String, ByVal username As String, ByVal password As String, ByVal publish As Boolean) As Boolean
290: ' Kills a post
291: Authenticate(username, password)
292: Dim sqlConn As ConnectionStringSettings
293: sqlConn = ConfigurationManager.ConnectionStrings("SQLServer")
294: Dim objConn As New SqlConnection(sqlConn.ConnectionString)
295: objConn.Open()
296: Dim objCommand As New SqlCommand("update Blog set PostType=2 where ID=@iID", objConn)
297: objCommand.Parameters.AddWithValue("@iID", postid)
298: Try
299: objCommand.ExecuteNonQuery()
300: Catch ex As Exception
301: Throw New Exception("There was a problem deleting your post. (PostID : " & postid & ") Message (" & ex.Message & ")")
302: objConn.Close()
303: Return False
304: Finally
305: objConn.Close()
306: End Try
307: Return True
308: End Function
309:
310: <XmlRpcMethod("metaWeblog.newMediaObject")> _
311: Public Function newMediaObject(ByVal blogid As String, ByVal username As String, ByVal password As String, ByVal rpcstruct As XmlRpcStruct) As XmlRpcStruct
312: Authenticate(username, password)
313: ' Some programs specify a directory AND filename. We don't want that - all we want is the filename, so that we control where it goes.
314: ' This truncates that down and checks for redundancy. If a file is there already, we'll use a GUID for the name instead.
315: Dim name As String = rpcstruct("name").ToString
316: Dim type As String = rpcstruct("type").ToString
317: Dim media As Byte() = CType(rpcstruct("bits"), Byte())
318: Dim index As Integer = name.LastIndexOf("/") + 1
319: Dim strFileName As String = name.Substring(index)
320: ' Check for the file existing.
321: If File.Exists(HttpContext.Current.Server.MapPath("/photos/posted/") & strFileName) Then
322: ' File Exists, so lets use a GUID as the filename.
323: Dim strFileNameOnServer As String = HttpContext.Current.Server.MapPath("/photos/posted") & strFileName
324: Dim iIndex As Integer = strFileNameOnServer.LastIndexOf(".")
325: Dim sExt As String = strFileNameOnServer.Substring(iIndex)
326: strFileName = Guid.NewGuid.ToString & sExt
327: End If
328: ' Write the file and return the URL.
329: Dim stream As FileStream = File.Create(HttpContext.Current.Server.MapPath("/photos/posted/") & strFileName)
330: stream.Write(media, 0, media.Length)
331: stream.Flush()
332: stream.Close()
333: stream.Dispose()
334: Dim rstruct As XmlRpcStruct = New XmlRpcStruct
335: rstruct.Add("url", "http://davewhite.net/photos/posted/" & strFileName)
336: Return rstruct
337: End Function
338:
339: End Class
Dave and Annabarbara's fun on planet Earth
Subscribe