[Pkg] The Trunk: SMServer-gk.33.mcz

commits at source.squeak.org commits at source.squeak.org
Thu Jan 20 21:24:11 UTC 2011


Chris Muller uploaded a new version of SMServer to project The Trunk:
http://source.squeak.org/trunk/SMServer-gk.33.mcz

==================== Summary ====================

Name: SMServer-gk.33
Author: gk
Time: 12 April 2010, 12:58:19 am
UUID: 771b1c33-1bfa-4164-9506-4746629a06a8
Ancestors: SMServer-gk.32

Small fixes to front page.

==================== Snapshot ====================

SystemOrganization addCategory: #'SMServer-remote'!
SystemOrganization addCategory: #'SMServer-web'!

HVTransientView subclass: #SMBaseView
	instanceVariableNames: 'formatter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMServer-web'!

!SMBaseView commentStamp: '<historical>' prior: 0!
A base view class mostly used for utility methods.!

SMBaseView subclass: #SMAccountView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMServer-web'!

!SMAccountView commentStamp: 'gk 11/13/2003 23:38' prior: 0!
The HTTP view of an SMAccount when logged in.!

----- Method: SMAccountView>>admin (in category 'urls') -----
admin
	"This is the entry for all administration pages.
	We verify that we are logged in."

	model isAdmin ifFalse: [^self serverError: 'You are not a SqueakMap administrator.'].
	^(SMSqueakMapAdminView on: model map parent: self) dispatch!

----- Method: SMAccountView>>copackage (in category 'urls') -----
copackage
	"Request for a specific co-package in the account.
	Pick out the UUID, look it up and delegate to a view."

	| uuid package |
	uuid _ self nextMethod.
	package _ model coPackageWithId: uuid.
	package ifNil: [^self serverError: 'This account has no package with id ', uuid].
	^(package viewFor: self) dispatch!

----- Method: SMAccountView>>default (in category 'urls') -----
default
	"Default page for a package."

	| b |
	b _ self builder.
	b start; h1: model name, ' at SqueakMap'.
	b ul: {
		(b getLinkLocal: 'logout' text: 'Logout'), ' - Logout from SqueakMap.'.
		(b getLinkLocal: 'settings' text: 'Settings'), ' - Account settings.'.
		(b getLinkLocal: 'seppuku' text: 'Delete my acount'), ' - Just what it says. Scary stuff.'.
		(b getLinkLocal: 'files' text: 'Uploaded files'), ' - Upload or delete files in account.'.
		(b getLinkLocal: 'newpackage' text: 'Add package'), ' - Create a new package.'
	}.
	model isAdmin ifTrue: [
		b ul: {
			(b getLinkLocal: 'admin' text: 'Administrate the map'), ' - Modify the categories tree etc.'
		}].
	b h2: 'Packages'.
	model packages isEmpty ifTrue: [b html: self none] ifFalse: [
		self listPackages: model packages on: b.
	].
	b h2: 'Co-maintained packages'.
	model coPackages isEmpty ifTrue: [b html: self none] ifFalse: [
		self listCoPackages: model coPackages on: b.
	].
	b hr; linkBackParent: 'Back'; end.
	^b!

----- Method: SMAccountView>>files (in category 'urls') -----
files
	"Upload and remove files. Can also access file by name,
	but the url prompts for login first."

	| b checkBoxes toRemove fileName |
	fileName _ self nextMethod.
	fileName isEmptyOrNil ifFalse:[^model streamForFile: fileName].
	b _ self builder.
	checkBoxes _ Dictionary new.
	b h1: 'Files'.
	b p: 'Upload files to your account.'.
	b postFormMultiPartLocal: 'upload'.
	b inputFile; submit: 'Upload'; br;br.
	b endForm; postFormLocal: 'files'.
	b columnsHeads: #('Select' 'Filename' 'Created' 'Modified' 'Size') do: [
		model entries do: [:entry |
			(entry at: 4) ifFalse:[ | fn |"Not a dir"
				fn _ entry first.
				checkBoxes at: fn put: b inputCheckbox.
				b colTab; link: 'files/', fn text: fn.
				b colTab; html: (Time fromSeconds: entry second) printString.
				b colTab; html: (Time fromSeconds: entry third) printString.
				b colTab; html: ((entry fifth) / 1024) truncated printString, ' kb'; colTab]]].
	b br; submit: 'Delete selected files'.
	b endForm; end.
	(b submitted: 'Delete selected files') ifTrue:[
		toRemove _ Set new.
		checkBoxes keysAndValuesDo: [:fn :box |
			box value ifTrue:[toRemove add: fn]].
		model deleteFiles: toRemove.
		^self redirectToLocal: 'files'].
	b hr; linkDefault; end.
	^b!

----- Method: SMAccountView>>initialize (in category 'initialize-release') -----
initialize

	title _ model name, ' at SqueakMap'.
	prefix _ '/account'!

----- Method: SMAccountView>>listCoPackages:on: (in category 'private') -----
listCoPackages: aColl on: aBuilder
	"List the co packages."

	aBuilder ul: aColl do: [:p |
		aBuilder html: (p getCoLink: aBuilder); html: ' (', (p getCoEditLink: aBuilder), ' ',
			(p getCoEditReleasesLink: aBuilder), ') - ', p summary].!

----- Method: SMAccountView>>listPackages:on: (in category 'private') -----
listPackages: aColl on: aBuilder
	"List the packages."

	aBuilder ul: aColl do: [:p |
		aBuilder html: (p getLink: aBuilder); html: ' (', (p getEditLink: aBuilder), ' ',
			(p getEditReleasesLink: aBuilder), ') - ', p summary].!

----- Method: SMAccountView>>logout (in category 'urls') -----
logout
	"Handle logout."

	^parent logout!

----- Method: SMAccountView>>newpackage (in category 'urls') -----
newpackage
	"Register a new package."

	| msg b name summary description author  url lookup error mandatories select categories pi rss save package |
	b _ self builder.
	error _ false.
	b start; h1: 'New package'; postForm.
	b p: 'Fields in <b>bold</b> are mandatory. For all emails given you can use the Spam blockers "no_spam", "no_canned_ham", "spam_block" (case insensitive). The server knows how to filter those.'.
	msg _ b p; var.
	b endP.
	name _ b html: '<b>Name (a cool name of course):</b> '; br; inputTextSize: 40.
	summary _ b br; html: '<b>Summary (1 line):</b> '; br; inputTextSize: 80.
	author _ b br; html: '<b>Author (The original author, ex: "Joe Schmoe" or "Joe Schmoe &lt;joe at schmoe.com&gt;"):</b> '; br; inputTextSize: 40.
	b p: '<b>In each of the following mandatory categories a subcategory must be chosen:</b>'.
	mandatories _ OrderedCollection new.
	(model map mandatoryCategoriesFor: SMPackage) do: [:cat |
		select _ b html: (self topView categoryLink: cat), ': '; selectObjectsNilFirst: cat subCategories.
		(b submitted: 'Save new package') ifTrue: [select value ifNil: [select error: cat name, ' is mandatory!!'. error _ true]].
		mandatories add: select.
		b br ].
	b p: 'Select additional categories in list (use ctrl or similar key for multiselect):'.
	categories _ b selectMultiObjects: model map categories values.
	categories size: 10.
	url _ b br; html: 'Homepage (url ex: "http://www.here.com/killerapp/index.html"): '; br; inputTextSize: 60.
	pi _ b br; html: 'PackageInfo (simply the name): '; br; inputTextSize: 30.
	rss _ b br; html: 'RSS feed (url ex: "http://www.here.com/killerapp/rss.xml"): '; br; inputTextSize: 60.
	description _ b br; html: 'Description (5-10 lines, enter for line break): ';br; textAreaRows: 10 cols: 80.
	save _ b br; br; submit: 'Save new package'.
	b reset: 'Reset'; endForm.
	b hr; linkBackParent: 'Back'; end.
	save ifPressed: [
		name value isEmpty ifTrue: [name error: 'Name is mandatory'. error _ true].
		lookup _ model map packageWithName: name value.
		(lookup notNil and: [lookup ~= model]) ifTrue:[name error: 'Name is not unique'. error _ true].
		summary value isEmpty ifTrue: [summary error: 'Summary is mandatory'. error _ true].
		author value isEmpty ifTrue: [author error: 'Author is mandatory'. error _ true].
		(model map packageWithPI: pi value)
			ifNotNil: [pi error: 'This package name already taken!!'. error _ true].
		error
			ifTrue: [msg error: 'One or more fields failed validation']
			ifFalse: [
					[
					model map transaction: [
						package _ (SMPackage newIn: model map)
							name: name value;
							summary: summary value;
							description: description value;
							url: url value;
							author: author value.
						package rss: rss value; packageInfoName: pi value.
						mandatories do: [:cat | package addCategory: cat value].
						categories value ifNotNilDo: [:cs | cs do: [:cat | package addCategory: cat]].
						model addObject: package.
						model stampAsUpdated]
					] ifError: [msg error: 'Something went wrong when creating package'. ^b].
					msg success: 'Package created successfully']].
	^b!

----- Method: SMAccountView>>package (in category 'urls') -----
package
	"Request for a specific package owned by the account.
	Pick out the UUID, look it up and delegate to a view."

	| uuid package |
	uuid _ self nextMethod.
	[package _ model packageWithId: uuid] on: Exception do:
		[:ex | ^ self serverError: 'Error when resolving package id: ', ex description].
	package ifNil: [^self serverError: 'This account has no package with id ', uuid].
	^(package viewFor: self) dispatch!

----- Method: SMAccountView>>packageViewOn: (in category 'views') -----
packageViewOn: aPackage
	"Wrap the package in a view."

	^SMAccountPackageView on: aPackage parent: self!

----- Method: SMAccountView>>seppuku (in category 'urls') -----
seppuku
	"Delete this account if it can be done. First confirm it. Finish by performing logout."

	| b confirm |
	b _ self builder.
	b start; h1: 'Delete account'.
	b p: 'Note that deleting your account also deletes all packages, packagereleases and other SM objects owned by your account!!'.
	b  postForm; b: 'Are you sure you want to delete the account? '.
	confirm _ b html: 'If so, confirm it just to be sure:'; inputCheckbox.
	b br; br; submit: '...and press this button. Point of no return.'; endForm.
	b ifPost: [
		"Ok, then, have it your way..."
		(b submitted: '...and press this button. Point of no return.')
			ifTrue: [
				confirm value
					ifFalse: [confirm error: '<- need confirmation!!']
					ifTrue: [
						[super logout.
	
					Transcript cr; show: 'Deleting account ', model nameWithInitials ;cr.
		
				model delete.
		
				^self message: 'Account deleted.']
		
					ifError: [^self message: 'Deletion of account failed. Consult the squeak-dev mailinglist for help.']]]
	].
	b hr; linkDefault: 'No, for Squeak''s sake get me out of here!!'; end.
	^b!

----- Method: SMAccountView>>settings (in category 'urls') -----
settings
	"This is where we change settings in the account."

	| b password email msg verify name initials summary url signature advogato |
	b _ self builder.
	b h1: 'Account settings'; postForm; columns: 2.
	name _ b html: 'Full name: '; colTab; inputTextSize: 40 value: model name.
	email _ b colTab; html: 'Email: '; colTab; inputTextSize: 40 value: model email.
	initials _ b colTab; html: 'Developer initials: '; colTab; inputTextSize: 10 value: model initials.
	b nbsp; html: ' Note: Your developer initials doubles as username.'.
	advogato _ b colTab; html: 'Advogato id: '; colTab; inputTextSize: 10 value: model advogatoId.
	b nbsp; html: ' Note: This is your account name on '; link: 'http://people.squeakfoundation.org/' text: 'Squeak People'; html: '.'.
	summary _ b colTab; html: 'Summary (oneliner): '; colTab; inputTextSize: 50 value: model summary.
	url _ b colTab; html: 'Homepage: '; colTab; inputTextSize: 50 value: model url.
	password _ b br; colTab; html: 'New password: '; colTab; inputPassword.
	verify _ b colTab; html: 'Verify password: '; colTab; inputPassword.
	b endColumns.
	signature _ b html: 'Signature: '; br; textAreaRows: 5 cols: 60 value: model signature. 
	b br; br; submit: 'Save'; reset; endForm.
	b h2: [msg _ b var].
	b hr; linkDefault; end.
	b ifPost: [	
		(password value = verify value)
			ifFalse: [ password error: 'Password not verified correctly!!']
			ifTrue: [| acc |
				acc _ model map accountForUsername: initials value.
				(acc notNil and: [acc ~= model])
						ifTrue: [initials error: 'Those initials are already taken!!'. ^b].
				model map transaction: [
					password value isEmpty ifFalse: [model setPassword: password value].
					model name: name value; email: email value; initials: initials value;
						summary: summary value; url: url value; signature: signature value;
						advogatoId: advogato value;
						stampAsUpdated].
				msg value: '<b>Settings saved.</b>']
	].
	^b!

----- Method: SMAccountView>>upload (in category 'urls') -----
upload
	"Upload files. For each chunk let the model create a document."

	| fileName |
	req multipartFormFieldsDo: [:chunk |
		chunk fileName isEmptyOrNil ifFalse: [
			fileName _ (chunk fileName findTokens: ':/\') last.
			model newFile: fileName block: [:stream | chunk saveToStream: stream]
		]
	].
	^self redirectToLocal: 'files'!

----- Method: SMBaseView classSide>>autoVersionAtEnd: (in category 'as yet unclassified') -----
autoVersionAtEnd: aString
	"If <aString> ends with an autoversion it is returned:
		self autoVersionAtEnd: 'Blabla 1.2' -> '1.2'	
		self autoVersionAtEnd: 'Blabla1.2'   -> nil
		self autoVersionAtEnd: 'Blabla 1.a2' -> nil
	"
	| s c |
	s _ aString size.
	s to: 1 by: -1 do: [:i |
		c _ aString at: i.
		(c = Character space) ifTrue: [
			i = s ifTrue: [^nil] ifFalse: [^aString copyFrom: i+1 to: s]].
		(c isDigit or: [c = $.]) ifFalse: [^nil]]!

----- Method: SMBaseView classSide>>squeakMapServer (in category 'as yet unclassified') -----
squeakMapServer
	^'http://marvin.bluefish.se:8000'!

----- Method: SMBaseView>>accountLink: (in category 'private') -----
accountLink: anAccount
	"Return a link to given account."

	^self topView linklocal: 'accountbyid/', anAccount id asString text: anAccount nameWithInitials!

----- Method: SMBaseView>>before:in: (in category 'private') -----
before: obj in: coll
	"Return the object before <obj> in <coll>. I noone is found
	(obj is first or not in coll) return nil."

	coll first = obj ifTrue:[^nil].
	^coll before: obj ifAbsent: [nil]!

----- Method: SMBaseView>>categoryViewOn: (in category 'views') -----
categoryViewOn: aCat
	"Wrap the category in a view."

	^SMCategoryView on: aCat parent: self!

----- Method: SMBaseView>>coPackageLink: (in category 'links') -----
coPackageLink: aPackage

	^self linklocal: '/copackage/', aPackage id asString text: aPackage name!

----- Method: SMBaseView>>editCoPackageLink: (in category 'links') -----
editCoPackageLink: aPackage

	^self linklocal: '/copackage/', aPackage id asString, '/edit' text: 'edit'!

----- Method: SMBaseView>>editCoPackageReleasesLink: (in category 'links') -----
editCoPackageReleasesLink: aPackage

	^self linklocal: '/copackage/', aPackage id asString, '/editreleases' text: 'edit releases'!

----- Method: SMBaseView>>editOrPassword: (in category 'private') -----
editOrPassword: builder
	"Factored out."

	builder br; linkLocal: '/edit' text: 'Edit registration'; html: ' (requires password) or '.
	builder linkLocal: '/mailpassword' text: 'mail a new password to the registrant'; html: ' because he has forgotten it.'; br.!

----- Method: SMBaseView>>editPackageLink: (in category 'links') -----
editPackageLink: aPackage

	^self linklocal: '/package/', aPackage id asString, '/edit' text: 'edit'!

----- Method: SMBaseView>>editPackageReleasesLink: (in category 'links') -----
editPackageReleasesLink: aPackage

	^self linklocal: '/package/', aPackage id asString, '/editreleases' text: 'edit releases'!

----- Method: SMBaseView>>fileLink: (in category 'private') -----
fileLink: aFileName
	"Return a link to given filename in the current logged in account."

	^self link: (self fileUrl: aFileName) text: aFileName!

----- Method: SMBaseView>>fileUrl: (in category 'private') -----
fileUrl: aFileName
	"Return an absolute URL to given filename in the current logged in account."

	| account |
	account _ self currentAccount.
	^SMUtilities masterServer, '/accountbyid/',  account id asString, '/files/', aFileName!

----- Method: SMBaseView>>format: (in category 'private') -----
format: aString
	"Format the string according to swikification."

	^self formatter swikify: aString!

----- Method: SMBaseView>>formatter (in category 'private') -----
formatter
	"Returns a swiki formatter."

	| topView |
	formatter ifNotNil: [^formatter].
	topView _ self topView.
	formatter _ SMHtmlFormatter base: topView baseUrl model: topView.
	^formatter!

----- Method: SMBaseView>>linkEntered:text: (in category 'private') -----
linkEntered: url text: label
	"Returns a default empty value for presentation."

	self deprecated: 'Deprecated, use link:text:alt: in HVHtmlBuilder instead.'!

----- Method: SMBaseView>>linklocal:text: (in category 'private') -----
linklocal: url text: label
	"Hack."

	^'<a href="', (self originalUrlFor: url), '">', label, '</a>'!

----- Method: SMBaseView>>mailpassword (in category 'email') -----
mailpassword
	"Offer to mail a new random password to the user because it has been forgotten."

	| b msg |
	b _ self builder.
	b h1: 'Mail extra random password'.
	b postForm.
	msg _ b var.
	msg value: 'Would you like a new extra random password for the account held by <b>', model name, '</b>?<br />', 'It will be sent to ', (self personLink: model email), '.'.
	b br; br; submit: 'Send extra random password by email'; endForm.
	b ifPost: [
		[model mailRandomPasswordToRegistratorWithLink: (self linkBase: SMBaseView squeakMapServer local: '/login' text: 'to login').
		parent model logUpdate: model "since the password has been changed we need to log".
		msg value: 'Email has been sent.']
			ifError: [msg value: 'Something went wrong when mailing the new random password to ', (self personLink: model email), '.<br />Contact SqueakMap administrator.'].
		].
	b hr; linkBackParent: 'Back'; end.
	^b!

----- Method: SMBaseView>>mailto:name: (in category 'private') -----
mailto: email name: aName
	"Produces:
		'<a href='mailto:rob at here.com'>Robert Robertson</a>'
	"

	^self link: 'mailto:', email text: aName!

----- Method: SMBaseView>>modulePathFor: (in category 'private') -----
modulePathFor: aCard
	"Show the module path or a text indicating no module path available."

	^aCard modulePath isEmpty ifTrue: ['<i>not a module</i>'] ifFalse: [aCard modulePath]!

----- Method: SMBaseView>>nonEntered (in category 'private') -----
nonEntered
	"Returns a default empty value for presentation."

	^'<i>&lt;Not entered&gt;</i>'!

----- Method: SMBaseView>>nonEntered: (in category 'private') -----
nonEntered: aString
	"Returns a default empty value for presentation."

	^(aString isNil or: [aString isEmpty]) ifTrue:['<i>&lt;Not entered&gt;</i>'] ifFalse: [aString]!

----- Method: SMBaseView>>none (in category 'private') -----
none
	"Returns a default empty value for presentation."

	^'<i>&lt;None&gt;</i>'!

----- Method: SMBaseView>>notEntered (in category 'private') -----
notEntered
	"Return a default empty value for presentation."

	^'<i>&lt;Not entered&gt;</i>'!

----- Method: SMBaseView>>packageReleaseViewOn: (in category 'views') -----
packageReleaseViewOn: aPackageRelease
	"Wrap the package release in a view."

	^SMPackageReleaseView on: aPackageRelease parent: self!

----- Method: SMBaseView>>packageViewOn: (in category 'views') -----
packageViewOn: aPackage
	"Wrap the package in a view."

	^SMPackageView on: aPackage parent: self!

----- Method: SMBaseView>>personLink: (in category 'private') -----
personLink: aString
	"Converts <aString> to an HTML mailto: link as this:
		'Robert Robertson <rob at here.com>' ->
		'<a href='mailto:rob at here.com'>Robert Robertson</a>'
	If <aString> does not conform it will be returned unchanged."

	| lessThan moreThan |
	lessThan _ aString indexOf: $<.
	moreThan _ aString indexOf: $>.
	(lessThan * moreThan = 0) ifTrue:[^aString].
	^self link: 'mailto:', (aString copyFrom: lessThan + 1 to: moreThan - 1) text: (aString copyFrom: 1 to: lessThan - 2)!

----- Method: SMBaseView>>urlAndString:forLink: (in category 'private') -----
urlAndString: aBlock forLink: aString
	"Resolve aString into a relative url. Case insensitive.
	We check for developer initials, account names case insensitive,
	package names (case insensitive, beginning), package releases
	(if an autoversion is tacked on), resource names and category
	names in that order. If nothing matches the string is returned as it is."

	| hit string map autoVersion release |
	map _ self topView model.
	string _ aString asLowercase.

	"This one is exact since the developer initials are unique including case."
	hit _ map accountForUsername: aString.
	hit ifNotNil: [^aBlock value: 'accountbyid/', hit id asString value: hit name ].

	"This one is case insensitive but exact otherwise"
	hit _ map accounts detect: [:a | a name asLowercase = string] ifNone: [nil].
	hit ifNotNil: [^aBlock value: 'accountbyid/', hit id asString value: aString].

	"Next is packages. First we check if the search string ends with a space
	followed by an automaticVersion and then we try
	to find that specific release. If no automaticVersion is found we link to package."
	autoVersion _ self class autoVersionAtEnd: string.
	autoVersion ifNotNil: [string _ string copyFrom: 1 to: string size - autoVersion size].
	"This is one is fuzzy... removes whitespace and is case insensitive. Also matches beginning."
	hit _ map packageWithNameBeginning: string.
	hit ifNotNil: [
		autoVersion ifNil: [^aBlock value: 'package/', hit id asString value: hit name]
			ifNotNil: [
				release _ hit releaseWithAutomaticVersionString: autoVersion.
				release
					ifNil: [^aBlock value: 'package/', hit id asString value: hit name]
					ifNotNil: [^aBlock value: 'package/', hit id asString, '/autoversion/',
						release automaticVersion versionString value: release packageNameWithVersion]]].
	"resource names here"

	hit _ map categoryWithNameBeginning: string.
	hit ifNotNil: [^aBlock value: 'category/', hit id asString value: hit name].

	^aBlock value: aString value: aString
!

----- Method: SMBaseView>>validateEmail: (in category 'private') -----
validateEmail: aString
	"Validate that <aString> conforms to at least this syntax:
		'something @ something . something'
	"

	| s at dot |
	s _ aString withBlanksTrimmed.
	at _ aString indexOf: $@.
	dot _ s indexOf: $. startingAt: at.
	((dot * at) = 0) ifTrue:[^false].
	(at > 1) & (at < dot) & (dot < s size) ifFalse:[^false].
	^true!

----- Method: SMBaseView>>validatePersonLink: (in category 'private') -----
validatePersonLink: aString
	"Validate that <aString> conforms to at least this syntax:
		'something < something @ something >'
	This implementation is twice as fast as:
		^'*<*@*>' match: aString withBlanksTrimmed
	...and verifies that <something> is not the empty String."

	| lessThan moreThan s at |
	s _ aString withBlanksTrimmed.
	lessThan _ s indexOf: $<.
	moreThan _ s indexOf: $>.
	at _ aString indexOf: $@.
	((lessThan * moreThan * at) = 0) ifTrue:[^false].
	(lessThan > 1) & (moreThan = s size) & (lessThan < at) & (at < moreThan) ifFalse:[^false].
	^true!

SMBaseView subclass: #SMCategoryView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMServer-web'!

!SMCategoryView commentStamp: '<historical>' prior: 0!
A HTTP view for an SMCategory.!

----- Method: SMCategoryView>>default (in category 'urls') -----
default
	"Default page for a category."

	| b cats path |
	b _ self builder.
	cats _ model subCategories.
	model parent ifNil: [path _ ''] ifNotNil: [path _ self linkedPathTo: model ].
	b start; b: path; h1: model name.
	b p: model summary.
	model url isEmpty ifFalse:[b p: ('More info: ', (b getLink: model url))].
	b ul: cats do: [:cat | b html: (parent categoryLink: cat) , ' - ', cat summary].
	model objects isEmpty ifFalse:[
		b h2: 'Packages'.
		b p: 'Specific releases are shown with auto version number within parenthesis.'.
		self listPackagesByName: model packages in: b].
	b hr; html: (parent linklocal: 'categories' text: 'Back to top categories'); end.
	^b!

----- Method: SMCategoryView>>initialize (in category 'initialize-release') -----
initialize

	title _ 'SqueakMap category'.
	prefix _ '/category/', model id asString!

----- Method: SMCategoryView>>linkedPathTo: (in category 'urls') -----
linkedPathTo: aCategory
	"Return a linked path to <aCategory>."

	^String streamContents: [:stream |
		aCategory parentsDo: [:par |
			stream nextPutAll: (parent categoryLink: par); nextPutAll: ' / ' ]]!

----- Method: SMCategoryView>>listPackagesByName:in: (in category 'private') -----
listPackagesByName: packages in: aBuilder
	"List packages sorted by their given name as an unordered list.
	All releases matching the category is listed within parentheses."

	| packagesByName releases |
	packagesByName _ packages asSortedCollection:
		[:x :y | x name caseInsensitiveLessOrEqual: y name].
	aBuilder ul: packagesByName do:
		[:package | | first |
			package isPackage ifTrue: [
				first _ true.
				releases _ String streamContents: [:str |
					package releases do: [:rel |
						(model includes: rel)
							ifTrue: [first ifFalse: [str nextPutAll: ', '].
								first _ false.
								str nextPutAll: (aBuilder
									getLinkParent: rel relativeUrl
									text: rel listName)]]].
				aBuilder html: (package getLink: parent builder) ,
					' (', releases, ') - ', package summary]]!

SMBaseView subclass: #SMPackageReleaseView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMServer-web'!

!SMPackageReleaseView commentStamp: 'gk 11/13/2003 23:38' prior: 0!
The public HTTP view for an SMPackageRelease.!

----- Method: SMPackageReleaseView>>cache (in category 'urls') -----
cache
	"Request for the server side cached file."

	model isDownloadable ifFalse: [^'SMRELEASENOTDOWNLOADABLE'].
	model isCached
		ifTrue: [^(model cacheDirectory readOnlyFileNamed: model downloadFileName) binary; yourself]
		ifFalse: [^'FILEMISSINGONSMSERVER']!

----- Method: SMPackageReleaseView>>default (in category 'urls') -----
default
	"Default page for a package release."

	| b |
	b _ self builder.
	b start; h1: model package name.
	b html: '<b>Release name:</b> ', (self nonEntered: model name); br.
	b html: '<b>Release summary:</b> ', (self nonEntered: model summary); br.
	b html: '<b>Automatic version:</b> ', model automaticVersion versionString; br.
	b html: '<b>Manual version:</b> ', (self nonEntered: model smartVersion); br.
	b html: '<b>Published by:</b> ', ((model isPublished)
		ifTrue: [self accountLink: model publisher]
		ifFalse: ['<i>&lt;Not published yet&gt;</i>']); br.
	b html: '<b>Created:</b> ' , (self nonEntered: model created printString); br.
	b html: '<b>Last updated:</b> ' , (self nonEntered: model updated printString); br.
	b html: '<b>Categories:</b>'.
	b ul: model categories do: [:cat | b html: (self topView categoryLink: cat), ' - ', cat summary].

	b br; html: '<b>Release note:</b> '.
	model note isEmpty
		ifTrue:[b html: self nonEntered]
		ifFalse: [b br; html: (self format: model note)].
	b br; html: '<b>Release homepage:</b> '; link: model url text: model url alt: self notEntered; br.
	b html: '<b>Download:</b> '; link: model downloadUrl text: model downloadUrl alt: self notEntered; br.
	b html: '<b>SHA checksum:</b> ', model sha1sum printString; br.
	b hr; linkBackParent: 'Back'; end.
	^b
!

----- Method: SMPackageReleaseView>>downloadurl (in category 'urls') -----
downloadurl
	"Just return the download url for this release."

	^model downloadUrl!

----- Method: SMPackageReleaseView>>initialize (in category 'initialize-release') -----
initialize

	title _ model name!

----- Method: SMPackageReleaseView>>newhint (in category 'urls') -----
newhint
	"Instantiate a hint action, execute it and return the response."

	^ (SMUploadHintAction fromRequest: req)
		release: model;
		response!

SMBaseView subclass: #SMPackageView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMServer-web'!

!SMPackageView commentStamp: 'gk 8/7/2003 18:13' prior: 0!
The public HTTP view for an SMPackage.!

SMPackageView subclass: #SMAccountPackageView
	instanceVariableNames: 'isOwner'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMServer-web'!

!SMAccountPackageView commentStamp: 'gk 8/7/2003 18:13' prior: 0!
The private HTTP view for an SMPackage.!

----- Method: SMAccountPackageView>>edit (in category 'urls') -----
edit
	"Edit the properties of a package except for releases
	that are edited in #editreleases."

	| msg b name summary description author  url lookup error mandatories select delete categories cats pi rss deleteMaintainer addMaintainer maintainerToAdd maintainerToDelete packageWithPi newOwner transfer deletePackage transferPackage feedbackEmail |
	b _ self builder.
	error _ false.
	b start; h1: model name; postForm.
	b p: 'Fields in <b>bold</b> are mandatory. For all emails given you can use the Spam blockers "no_spam", "no_canned_ham", "spam_block" (case insensitive). The server knows how to filter those.'.
	b p: [msg _ b var].
	name _ b html: '<b>Name (a cool name of course):</b> '; br; inputTextSize: 40 value: model name.
	summary _ b br; html: '<b>Summary (1 line):</b> '; br; inputTextSize: 80 value: model summary.
	author _ b br; html: '<b>Author (The original author, ex: "Joe Schmoe" or "Joe Schmoe &lt;joe at schmoe.com&gt;"):</b> '; br; inputTextSize: 40 value: model author.
	b p: '<b>In each of the following mandatory categories a subcategory must be chosen:</b>'.
	mandatories _ OrderedCollection new.
	(model map mandatoryCategoriesFor: SMPackage) do: [:cat |
		select _ b html: (self topView categoryLink: cat), ': '; selectObjectsNilFirst: cat subCategories value: (model categoryForParent: cat).
		(b submitted: 'Save') ifTrue: [select value ifNil: [select error: cat name, ' is mandatory!!'. error _ true]].
		mandatories add: select.
		b br ].
	isOwner ifTrue: [
		b br; html: 'Co-maintainers: '; br.
		maintainerToAdd _ b br; selectObjects: ((model map accountsByName) removeAll: model maintainers asArray; yourself).
		addMaintainer _ b submit: 'Add selected'.
		maintainerToDelete _ b br; selectObjects: model maintainers asOrderedCollection size: 10.
		deleteMaintainer _ b br; submit: 'Delete selected maintainer'].
	b p: 'Select additional categories in list (use ctrl or similar key for multiselect):'.
	categories _ b selectMultiObjects: model map categories values value: model categories.
	categories size: 10.
	url _ b br; html: 'Homepage (url ex: "http://www.here.com/killerapp/index.html"): '; br; inputTextSize: 60 value: model url.
	pi _ b br; html: 'PackageInfo (simply the name): '; br; inputTextSize: 30 value: model packageInfoName.
	feedbackEmail _ b br; html: 'Feedback email (for fixes, changesets, error reports etc): '; br; inputTextSize: 30 value: model feedbackEmail.
	rss _ b br; html: 'RSS feed (url ex: "http://www.here.com/killerapp/rss.xml"): '; br; inputTextSize: 60 value: model rss.
	
	description _ b br; html: 'Description (5-10 lines, enter for line break): ';br; textAreaRows: 10 cols: 80 value: model description.
	isOwner ifTrue: [
		b br; html: 'Maintainer to transfer package to: '; br.
		newOwner _ b br; selectObjects: ((model map accountsByName) remove: model owner; yourself).
		transfer _ b br; br; html: 'Confirm transfer of this package: '; inputCheckbox.
		delete _ b br; br; html: 'Confirm deletion of this package: '; inputCheckbox].
	b br; br; submit: 'Save'.
	(self currentAccount owns: model) ifTrue: [deletePackage _ b submit: 'Delete package'].
	(self currentAccount owns: model) ifTrue: [transferPackage _ b submit: 'Transfer package'].	

	b reset: 'Reset'; endForm.
	b hr; h2: 'Releases'.
	b ul: model releases do: [:rel |
		b html: (self releaseLink: rel), ' - ', rel summary].
	b linkLocal: 'editreleases' text: 'Edit releases'.
	b hr; linkBackParent: 'Back'; end.
	isOwner ifTrue: [
		addMaintainer ifPressed: [
			maintainerToAdd
				ifNil: [maintainerToAdd error: 'Need to select maintainer to add!!'. error _ true]
				ifNotNil: [model map transaction: [model addMaintainer: maintainerToAdd value; stampAsUpdated]].
					maintainerToDelete addObject: maintainerToAdd value.
					maintainerToAdd removeSelected; value: nil ].
		deleteMaintainer ifPressed: [
			maintainerToDelete
				ifNil: [maintainerToDelete error: 'Need to select maintainer to delete!!'. error _ true]
				ifNotNil: [model map transaction: [model removeMaintainer: maintainerToDelete value; stampAsUpdated]].
					maintainerToAdd addObject: maintainerToDelete value.
					maintainerToDelete removeSelected; value: nil ]].
	b ifPost: [
		(isOwner and: [transferPackage isPressed]) ifTrue: [
			transfer value
				ifFalse: [transfer error: 'Need to check for confirmation'.
					msg error: 'You need to confirm transfer by checking the checkbox too.'. ^b]
				ifTrue: [
					[model map transaction: [
						model owner moveObject: model toAccount: newOwner value]]
						ifError: [msg error: 'Something went wrong when transferring package'. ^b].
					 ^parent message: 'Package transferred successfully to ', newOwner value name]].
		(isOwner and: [deletePackage isPressed]) ifTrue: [
			delete value
				ifFalse: [delete error: 'Need to check for confirmation'.
					msg error: 'You need to confirm deletion by checking the checkbox too.'. ^b]
				ifTrue: [
					[model map transaction: [model delete]]
						ifError: [msg error: 'Something went wrong when deleting package'. ^b].
					 ^parent message: 'Package deleted successfully']].
		(b submitted: 'Save') ifTrue:[
			name value isEmpty ifTrue: [name error: 'Name is mandatory'. error _ true].
			lookup _ model map packageWithName: name value.
			(lookup notNil and: [lookup ~= model]) ifTrue:[name error: 'Name is not unique'. error _ true].
			summary value isEmpty ifTrue: [summary error: 'Summary is mandatory'. error _ true].
			author value isEmpty ifTrue: [author error: 'Author is mandatory'. error _ true].
			pi value isEmpty ifFalse: [
				packageWithPi _ model map packageWithPI: pi value.
				(packageWithPi notNil and: [packageWithPi ~= model])
					ifTrue: [pi error: 'This package name already taken by another package!!'. error _ true]].
			feedbackEmail value isEmpty ifFalse: [
				(self validateEmail: feedbackEmail value)
					ifFalse: [feedbackEmail error: 'Email syntax not correct'. error _ true]].
			error
				ifTrue: [msg error: 'One or more fields failed validation']
				ifFalse: [
					[
					model map transaction: [
						model name: name value;
							summary: summary value;
							description: description value;
							url: url value;
							author: author value;
							rss: rss value;
							packageInfoName: pi value;
							feedbackEmail: feedbackEmail value.
						cats _ (mandatories collect: [:sel | sel value]) asSet.
						cats addAll: categories value.
						model map changeCategoriesTo: cats inObject: model.
					model stampAsUpdated]
					] ifError: [msg error: 'Something went wrong when updating package'. ^b].
					msg success: 'Package updated successfully']]].
	^b!

----- Method: SMAccountPackageView>>editreleases (in category 'urls') -----
editreleases
	"Edit the releases of a package. When a new release is created
	or when a download URL is modified, a Process is forked to
	download the file into the cache."

	| msg b name  error mandatories select selectRelease delete categories cats release version downloadUrl note defaultValues newRelease published selectedFile summary publisher oldFileName parentRelease |
	b _ self builder.
	error _ false.
	b start; h1: 'Releases of ', model name; postForm.
	b p: 'Fields in <b>bold</b> are mandatory.'.
	b p: [msg _ b var].
	selectRelease _ b html: 'Select release: '; selectObjects: model releases selector: #listName.
	"Makes the last release autoselected on GET"
	b isPost ifFalse: [
		model releases isEmpty ifFalse: [
			selectRelease value: model releases last]].
	release _ selectRelease value.
	b nbsp; submit: 'Select';br; hr.
	version _ b br; br; html: '<b>Version (ex: "1.22.99-beta-prepatch7"):</b> ';br; inputTextValue: (release ifNotNil: [release version] ifNil: ['']).
	b p: '<b>In each of the following mandatory categories a subcategory must be chosen:</b>'.
	mandatories _ OrderedCollection new.
	(model map mandatoryCategoriesFor: SMPackageRelease) do: [:cat |
		select _ b html: (self topView categoryLink: cat), ': '; selectObjectsNilFirst: cat subCategories value: (release ifNotNil: [release categoryForParent: cat]).
		((b submitted: 'Save changes') or: [b submitted: 'Save as new release'])
			ifTrue: [select value ifNil: [select error: cat name, ' is mandatory!!'. error _ true]].
		mandatories add: select.
		b br ].
	downloadUrl _ b br; br; html: 'Download (url ex: "http://www.here.com/killerapp.cs.gz"): '; br; inputTextSize: 60 value: (release ifNotNil: [release downloadUrl] ifNil: ['']).
	selectedFile _ b nbsp; html: 'or insert url for ', (b getLinkParent: 'files' text: 'uploaded'), ' file: '; selectObjectsNilFirst: self currentAccount files.
	selectedFile value ifNotNil: [downloadUrl value: (self fileUrl: selectedFile value)].
	release ifNotNil: [
		release downloadUrl ifNotNil: [
			b br; link: release downloadUrl text: 'Click to test url']].
	selectedFile value ifNotNil: [downloadUrl value: (self fileUrl: selectedFile value)]. 
	name _ b br; br; html: 'Name (a cool name if you want one): '; br; inputTextSize: 40 value: (release ifNotNil: [release name] ifNil: ['']).
	summary _ b br; br; html: 'Summary (1 line): '; br; inputTextSize: 80 value: (release ifNotNil: [release summary] ifNil: ['']).
	b p: 'Select additional categories in list (use ctrl or similar key for multiselect):'.
	categories _ b selectMultiObjects: model map categories values value: (release ifNotNil: [release categories] ifNil: [#()]).
	categories size: 10; multiple: true.
	note _ b br; html: 'Release note (5-10 lines, enter for line break): ';br; textAreaRows: 10 cols: 80 value: (release ifNotNil: [release note] ifNil: ['']).
	published _ b br; html: 'Published: ';
					inputCheckboxValue: (release isNil or: [release isPublished not]) not.
	publisher _ b var.
	b br; html: '<b>Note: This marks the package as an official release that others can rely on. A published release should be immutable and not be deleted!!</b>'.
	b br; br; submit: 'Delete release'.
	delete _ b nbsp; html: 'Confirm deletion of this release: '; inputCheckboxValue: false.
	b br; br; submit: 'Save changes'; reset: 'Reset'.
	b br; br; submit: 'Save as new release'.
	parentRelease _ b nbsp; html: 'Parent release (change to branch): '; selectObjects: model releases selector: #listName value: model lastRelease.
	b endForm.
	b p: '<b>Note:</b> You can only branch once from an old release, trying to branch again, will create a branch from the previous branch instead!! This is a limitation in the current VersionNumber package that needs to be fixed of course. :)'.
	defaultValues _ ["maintainer value: model lastRelease maintainer"].
	b hr; linkBackParent: 'Back'; end.
	b isPost ifFalse: [defaultValues value].
	(b submitted: 'Select') ifTrue:[
		delete value: false.
		release ifNil: [defaultValues value] ifNotNil: [
			version value: release version.
			downloadUrl value: release downloadUrl.
			name value: release name.
			summary value: release summary.
			categories value: release categories.
			published value: release isPublished.
			mandatories do: [:sel | sel value: (sel objects detect: [:cat | release hasCategory: cat] ifNone: [nil])]. 
			note value: release note]
	].
	(b submitted: 'Delete release') ifTrue: [
		release ifNil: [msg error: 'No release selected to delete!!'. ^b].
		delete value
			ifFalse: [delete error: 'Need to check for confirmation'.
				msg error: 'You need to confirm deletion by checking the checkbox too.'. ^b]
			ifTrue: [
				[model map transaction: [release delete]]
					ifError: [msg error: 'Something went wrong when deleting release'. ^b].
				msg success: 'Package release deleted successfully'].
		self redirectToLocal: #editreleases
	].
	newRelease _ b submitted: 'Save as new release'.
	(newRelease or: [b submitted: 'Save changes']) ifTrue:[
		version value isEmpty ifTrue: [version error: 'Version is mandatory'. error _ true].
		"downloadUrl value isEmpty ifTrue: [downloadUrl error: 'Download url is mandatory'. error _ true]."
	
		error
			ifTrue: [msg error: 'One or more fields failed validation']
			ifFalse: [
				newRelease ifTrue: [
					"["model map transaction: [release _ model newChildReleaseFrom: parentRelease value]"]
						ifError: [msg error: 'Something went wrong when adding a release'. ^b]".
					selectRelease value: release.
				].
				oldFileName _ release downloadFileName.
				[model map transaction: [
					release
						version: version value;
						note: note value;
						downloadUrl: downloadUrl value;
						name: name value;
						summary: summary value.

					(published value not and:  [release isPublished])
						ifTrue: [release publisher: nil].
					(published value and: [release isPublished not])
						ifTrue: [release publisher: self currentAccount].
	
					cats _ (mandatories collect: [:sel | sel value]) asSet.
	
					cats addAll: categories value.
					model map changeCategoriesTo: cats inObject: release.
					release stampAsUpdated]]
						ifError: [msg error: 'Something went wrong when updating release'. ^b].
				newRelease
					ifTrue: [msg success: 'Release added successfully']
					ifFalse: [msg success: 'Release updated successfully'].
				oldFileName = release downloadFileName
					ifFalse: [self updateServerCache: release]].
		"self redirectToLocal: #editreleases"].
	(release notNil and: [release isPublished])
		ifTrue: [publisher value: ' Publisher: ', (self accountLink: release publisher)].

	^b!

----- Method: SMAccountPackageView>>initialize (in category 'initialize-release') -----
initialize

	title _ model name.
	isOwner _ self currentAccount owns: model!

----- Method: SMAccountPackageView>>updateServerCache: (in category 'urls') -----
updateServerCache: aRelease
	"Update the server cache. This is done whenever
	the downloadUrl is changed or a new release is added.
	We fork it so that we can return asynchronously.
	If the release was downloaded we assume it went ok
	and we set the sha1sum. The user has to verify that
	the file was downloaded to the server cache correctly."

	aRelease isCached ifFalse: [
		[aRelease sha1sum: nil; ensureInCache.
		model map transaction: [aRelease sha1sum: aRelease calculateSha1sum]]
			fork]!

----- Method: SMPackageView>>autoversion (in category 'urls') -----
autoversion
	"Request for a specific release. Pick out the automaticVersion,
	look it up and delegate to a view."

	| release v |
	v _ self nextMethod.
	[release _ model releaseWithAutomaticVersionString: v] ifError: [].
	release ifNil: [^self serverError: 'No package release found with automatic version ', v].
	^(release viewFor: self) dispatch!

----- Method: SMPackageView>>default (in category 'urls') -----
default
	"Default page for a package."

	| b |
	b _ self builder.
	b start; h1: model name; postForm.
	b html: '<b>Summary:</b> ', model summary; br.
	b html: '<b>Author:</b> '; mailto: model author; br.
	b html: '<b>Owner:</b> ', (self accountLink: model owner); br.
	b html: '<b>Co-maintainers:</b> '.
	model maintainers isEmpty
		ifTrue: [b html: self none; br]
		ifFalse: [b br; ul: model maintainers do: [:com | b html: (self accountLink: com)]].
	b html: '<b>Categories:</b>'.
	b ul: model categories do: [:cat | b html: (self topView categoryLink: cat), ' - ', cat summary].
	b br; html: '<b>Homepage:</b> '; link: model url text: model url alt: self notEntered; br.
	b html: '<b>PackageInfo name:</b> ', (self nonEntered: model packageInfoName); br.
	b html: '<b>RSS feed:</b> '; link: model rss text: model rss alt: self notEntered; br.

	b br; html: '<b>Description:</b>'.
	model description isEmpty
		ifTrue:[b html: self nonEntered]
		ifFalse: [b br; html: (self format: model description) ]. "(self fixForHtml: model description)]."
	b h2: 'Releases'.
	b ul: model releases do: [:rel |
		b html: (self releaseLink: rel), ' - ', rel summary].
	b hr; linkBackParent: 'Back'; end.
	^b!

----- Method: SMPackageView>>downloadurl (in category 'urls') -----
downloadurl
	"We return the download url for the last published release,
	no more information to go on."

	^model lastPublishedRelease downloadUrl!

----- Method: SMPackageView>>initialize (in category 'initialize-release') -----
initialize

	title _ model name!

----- Method: SMPackageView>>newrelease (in category 'urls') -----
newrelease
	^ (SMNewReleaseAction fromRequest: req)
		package: model;
		response!

----- Method: SMPackageView>>releaseLink: (in category 'initialize-release') -----
releaseLink: aRelease

	^self linklocal: 'autoversion/', aRelease automaticVersion versionString
		text: aRelease listName!

----- Method: SMPackageView>>version (in category 'urls') -----
version
	"Request for a specific release. Pick out the smartVersion,
	look it up and delegate to a view."

	| release v |
	v _ self nextMethod.
	[release _ model releaseWithSmartVersion: v] ifError: [].
	release ifNil: [^self serverError: 'No package release found with smart version ', v].
	^(release viewFor: self) dispatch!

SMBaseView subclass: #SMPublicAccountView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMServer-web'!

!SMPublicAccountView commentStamp: 'gk 11/13/2003 23:37' prior: 0!
The view on an account which is given to everyone else using the public url.!

----- Method: SMPublicAccountView>>copackage (in category 'urls') -----
copackage
	"Request for a specific co-package in the account.
	Pick out the UUID, look it up and delegate to a view."

	| uuid package |
	uuid _ self nextMethod.
	package _ model coPackageWithId: uuid.
	package ifNil: [^self serverError: 'This account has no comaintainer package with id ', uuid].
	^(package viewFor: self) dispatch!

----- Method: SMPublicAccountView>>default (in category 'urls') -----
default
	"Default page for a package."

	| b sqpUrl |
	b _ self builder.
	b start; h1: model name, ' at SqueakMap'.
	b html: '<b>Email:</b> '; mailto: model email text: model name; br.
	b html: '<b>Developer initials:</b> ', model initials; br.
	b html: '<b>Summary:</b> ', model summary; br.
	b html: '<b>Homepage:</b> '; link: model url text: model url; br.
	b html: '<b>Page on Squeak People:</b> '.
	model advogatoId isEmptyOrNil ifFalse: [
		sqpUrl _ 'http://people.squeakfoundation.org/person/', model advogatoId.
		b link: sqpUrl text: sqpUrl].
	b br; html: '<b>Signature:</b>';br; html: model signature.
	b h2: 'Packages'.
	b ul: model packages do: [:p | b html: (p getLink: b), ' - ', p summary].
	model coPackages isEmpty ifFalse: [
		b h2: 'Co-maintained packages'.
		b ul: model coPackages do: [:p | b html: (p getCoLink: b), ' - ', p summary]].
	b hr; linkBackParent: 'Back'; end.
	^b!

----- Method: SMPublicAccountView>>files (in category 'urls') -----
files
	"Download file publicly, no login."

	| fileName |
	fileName _ self nextMethod unescapePercents.
	fileName isEmpty ifFalse:[^model streamForFile: fileName].
	^self serverError: 'No file with given name found.'!

----- Method: SMPublicAccountView>>initialize (in category 'initialize-release') -----
initialize

	title _ model name, ' at SqueakMap'!

----- Method: SMPublicAccountView>>package (in category 'urls') -----
package
	"Request for a specific package owned by the account.
	Pick out the UUID, look it up and delegate to a view."

	| uuid package |
	uuid _ self nextMethod.
	[package _ model packageWithId: uuid] on: Exception do: [:ex | ^ self serverError: 'Error when resolving package id: ', ex description].
	package ifNil: [^self serverError: 'This account has no package with id ', uuid].
	^(package viewFor: self) dispatch!

----- Method: SMPublicAccountView>>packageViewOn: (in category 'views') -----
packageViewOn: aPackage
	"Wrap the package in a view."

	^SMPackageView on: aPackage parent: self!

SMBaseView subclass: #SMSqueakMapAdminView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMServer-web'!

!SMSqueakMapAdminView commentStamp: '<historical>' prior: 0!
A special view for a SMSqueakMap when logging in as admin.!

----- Method: SMSqueakMapAdminView>>categories (in category 'urls') -----
categories
	"This is the page for administrating categories."

	| b category name summary url cat par changed mandatory siblings before place |
	b _ self builder.
	b start; h1: 'Categories'.
	b postForm.
	category _ (b html: 'Category: '; selectObjectsNilFirst: model categories values asOrderedCollection nilLabel: 'New category') value.
	b nbsp; submit: 'Select'; submit: 'Delete'; br.
	name _ b postForm; br; br; html: 'Name: '; inputText.
	summary _ b br; html: 'Summary: '; inputText.
	url _ b br; html: 'Url: '; inputText.
	mandatory _ b br; html: 'Mandatory: '; selectMultiObjects:
					{SMPackage. SMPackageRelease. SMAccount. SMResource} .
	par _ b br; html: 'Parent category: ';
			selectObjectsNilFirst: model categories values
			nilLabel: 'None'
			value: (category ifNil: [nil] ifNotNil: [category parent]).
	b nbsp; submit: 'Select parent'.
	(b submitted: 'Select') ifTrue:[par value: (category ifNil: [nil] ifNotNil: [category parent])].
	par value
		ifNil: [siblings _ model topCategories asOrderedCollection]
		ifNotNil: [siblings _ par value subCategories copy].
	(siblings includes: category) ifTrue:[
		(category = siblings first)
			ifTrue:[before _ nil]
			ifFalse: [before _ siblings before: category].
		siblings remove: category].
	place _ b nbsp; html: 'Place after: '; selectObjectsNilFirst: siblings nilLabel: 'Place first' value: before.
	category ifNotNil: [
		category subCategories isEmpty
			ifFalse:[b ul: category subCategories do: [:c | b html: (c getLink: b) ]]
			ifTrue:[b br]].
	b br; submit: 'Save'; nbsp; reset: 'Restore'; endForm.
	(b submitted: 'Select') ifTrue:[
		name value: (category ifNil: [''] ifNotNil: [category name]).
		summary value: (category ifNil: [''] ifNotNil: [category summary]).
		url value: (category ifNil: [''] ifNotNil: [category url]).
		mandatory value: (category ifNil: [nil] ifNotNil: [category mandatory asOrderedCollection]).
		place value: (category ifNil: [nil] ifNotNil: [before])
	].	
	(b submitted: 'Delete') ifTrue:[
		category delete.
		self redirectToLocal: #categories
	].
	(b submitted: 'Save') ifTrue:[
		category ifNil: [
			cat _ (SMCategory newIn: model)
					name: name value;
					summary: summary value;
					url: url value;
					mandatory: (mandatory value ifNil: [nil] ifNotNil: [mandatory value asSet]).
			par value ifNotNil: [par value addCategory: cat].
			model addObject: cat. "This method will also log the category as a new category"
			self redirectToLocal: #categories
		] ifNotNil: [
				"If name, summary, mandatory or url has changed then we log the whole category
				using SqueakMap>>addCategory:. A parent change is done separately.
				An ordering change is done separately."
			changed _ false.
			(category name ~= name value) ifTrue:[category name: name value. changed _ true].
			(category summary ~= summary value) ifTrue:[category summary: summary value. changed _ true].
			(category url ~= url value) ifTrue:[category url: url value. changed _ true].
			(category mandatory ~= mandatory value) ifTrue:[category mandatory: mandatory value. changed _ true].
			(par value ~= category parent) ifTrue:[
				model moveCategory: category toParent: par value. changed _ true].
			((place value ~= (category categoryBefore)) and: [category parent notNil])
				 ifTrue: [
					model moveCategory: category toAfter: place value inParent: category parent. changed _ true].
			changed ifTrue: [model setDirty]
		]
	].
	b br; linkDefault; end.
	^b!

----- Method: SMSqueakMapAdminView>>code (in category 'urls') -----
code
	"This is the page for doits."

	| b code result button codeResult |
	b _ self builder.
	b start; h1: 'Code'.
	b postForm.
	code _ b br; html: 'Enter some code:';br; textArea.

	b p: 'Result of code:'.
	result _ b var.
	button _ b br; br; submit: 'Hit me'.
	b endForm.

	button ifPressed: [
		"Compile and execute the code. Note that I cobbled this together - I tried adding a bit
		of error handling etc. Not sure how to do this properly."
		code value isEmpty ifFalse: [
			codeResult _ Compiler evaluate: code value logged: true].
	].
	result value: codeResult printString.

	b br; linkDefault; end.
	^b!

----- Method: SMSqueakMapAdminView>>default (in category 'urls') -----
default
	"Request for the top admin view."

	| b |
	b _ self builder.
	b start; h1: 'Aministrate SqueakMap'.
	b ul: {
		(b getLinkLocal: 'categories' text: 'Categories'), ' - Add/edit/remove categories.'.
		(b getLinkLocal: 'code' text: 'Doit'), ' - Execute doits on server. Careful now....'.
	}.
	b linkBackParent.
	b end.
	^b!

----- Method: SMSqueakMapAdminView>>initialize (in category 'initialize-release') -----
initialize
	title _ 'Administrate SqueakMap'.
	prefix _ '/admin'.
!

----- Method: SMSqueakMapAdminView>>packageViewOn: (in category 'views') -----
packageViewOn: aPackage
	"Wrap the package in a view."

	^SMPackageView on: aPackage parent: self!

SMBaseView subclass: #SMSqueakMapView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMServer-web'!

!SMSqueakMapView commentStamp: 'gk 11/13/2003 23:37' prior: 0!
A HTTP top view for the SqueakMap.!

----- Method: SMSqueakMapView>>account (in category 'urls') -----
account
	"This is the users account page.
	We verify that we are logged in and delegate the rest
	onto the correct view for an account based on the rest of the urlpath."

	| account |
	(account _ self currentAccount) ifNil: [
		"if this is a request for css then we use the local css"
		(req url endsWith: 'css') ifTrue:[^self css].
		^self notloggedin ].
	^(account viewFor: self) dispatch!

----- Method: SMSqueakMapView>>accountViewOn: (in category 'views') -----
accountViewOn: anAccount
	"Wrap the account in a view."

	^SMAccountView on: anAccount parent: self!

----- Method: SMSqueakMapView>>accountbyid (in category 'urls') -----
accountbyid
	"Request for a specific account. Pick out the UUID, look it up
	and delegate to a view."

	| uuid acc |
	uuid _ self nextMethod.
	[acc _ model accountWithId: uuid] ifError: [].
	acc ifNil: [^self serverError: 'No account found with id ', uuid].
	^(acc publicViewFor: self) dispatch!

----- Method: SMSqueakMapView>>accountsbyinitials (in category 'urls') -----
accountsbyinitials
	"List all accounts sorted by initials."

	| b |
	b _ self builder.
	b start; h1: 'All accounts sorted by initials'.
	b ul: model accountsByInitials do:
		[:acc | b html: (self accountLink: acc) , ' - ', acc summary].
	b hr; linkDefault: 'Back'; end.
	^b!

----- Method: SMSqueakMapView>>accountsbyname (in category 'urls') -----
accountsbyname
	"List all accounts sorted by name."

	| b |
	b _ self builder.
	b start; h1: 'All accounts sorted by name'.
	b ul: model accountsByName do:
		[:acc | b html: (self accountLink: acc) , ' - ', acc summary].
	b hr; linkDefault: 'Back'; end.
	^b!

----- Method: SMSqueakMapView>>autologin (in category 'urls') -----
autologin
	"Handle a first login to a new account."

	| username account b msg pwd newPassword verifyPassword label password uname |
	b _ self builder.
	b h1: 'Welcome to SqueakMap!!'.
	b p: 'Since email is not a safe transport you can now type in a personal password.'.
	b postForm; columns: 2.
	b html: 'Developer initials: '; colTab.
	label _ b var.
	b colTab.
	username _ b inputHidden: #username.
	password _ b inputHidden: #password.
	b isPost
		ifTrue: [
			uname _ username value.
			pwd _ password value]
		ifFalse: [
			uname _ b at: #u ifAbsent:[^self message: 'No account with those initials!!'].
			pwd _ b at: #p ifAbsent:[^self message: 'Wrong password!!'].
			username value: uname.
			password value: pwd].
	account _ model accountForUsername: uname.
	account ifNil: [^self message: 'No account with those initials!!'].
	label value: '<b>', account initials, '</b>'.
	(account correctPassword: pwd) ifFalse:[^self message: 'Wrong password!!'].
	newPassword _ b html: 'New password: '; colTab; inputPasswordSize: 15.
	verifyPassword _ b colTab; html: 'Confirm password: '; colTab; inputPasswordSize: 15.
	b endColumns; br; submit: 'Save and continue'.
	b h2: [ msg _ b var ].
	b endForm; end.
	b ifPost: [
		(newPassword value = verifyPassword value)
			ifFalse:[msg value: 'Confirm failed, enter passwords again']
			ifTrue: [
				account setPassword: newPassword value.
				account newPassword: nil.
				KomSession current attributes at: #account put: account.
				^self redirectTo: #account]
	].
	^b
!

----- Method: SMSqueakMapView>>categories (in category 'urls') -----
categories
	"Browse top categories."

	| b |
	b _ self builder.
	b start; h1: 'Top categories'; postForm.
	b ul: model topCategories do: [:cat | b html: (self categoryLink: cat) , ' - ', cat summary].
	b endForm.
	b hr; linkDefault: 'Back'; end.
	^b!

----- Method: SMSqueakMapView>>categoriestree (in category 'urls') -----
categoriestree
	"Show all categories in a tree."

	| b |
	b _ self builder.
	b start; h1: 'Category tree'.
	self listCategoriesRecursively: model topCategories on: b.
	b hr; linkDefault: 'Back'; end.
	^b!

----- Method: SMSqueakMapView>>category (in category 'urls') -----
category
	"Request for a specific category. Pick out the UUID, look it up
	and delegate to a view."

	| uuid cat |
	uuid _ self nextMethod.
	cat _ [model categoryWithId: uuid] ifError: [nil].
	cat ifNil: [^self serverError: 'No category found with id ', uuid].
	^(cat viewFor: self) dispatch!

----- Method: SMSqueakMapView>>categoryLink: (in category 'links') -----
categoryLink: aCategory

	^self linklocal: 'category/', aCategory id asString text: aCategory name!

----- Method: SMSqueakMapView>>compress: (in category 'private') -----
compress: aString
	"Compress the given String."

	| buffer |
	buffer _ RWBinaryOrTextStream on: String new.
	(GZipWriteStream on: buffer) nextPutAll: aString; close.
	^buffer contents!

----- Method: SMSqueakMapView>>default (in category 'urls') -----
default
	"Default request for the top view. Show the first page."

	| b loggedIn |
	b _ self builder.
	b start; h1: 'SqueakMap';
		p: 'Welcome to <b>SqueakMap</b>!!';
		p; html: (b getLinkLocal: 'help' text: 'SqueakMap'), ' is a catalog over <b>installable code packages</b> for ';
		link: 'http://www.squeak.org' text: 'Squeak'; html: '. Read more on the '; link: 'http://wiki.squeak.org/squeak/2726' text: 'Squeak Swiki pages'; html: ' about SqueakMap.';
		p: 'So far <b>', model packages size fullPrintString, '</b> ',
			(b getLinkLocal: 'packagesbyname' text: 'Squeak packages'), ' and <b>',
			model accounts size fullPrintString, '</b> ',
			(b getLinkLocal: 'accountsbyname' text: 'SqueakMap accounts'), ' have been registered.'.
	b h2: 'Navigation'.
	b ul: {
		(b getLinkLocal: 'recentnew' text: 'New objects'), ' - See all new objects added in the last 30 days.'.
		(b getLinkLocal: 'packagesbyname' text: 'All packages sorted by name'), ' - See all registered packages.'.
		(b getLinkLocal: 'packagesbyregistration' text: 'All packages sorted by registration'), ' - See all registered packages.'.
		(b getLinkLocal: 'categories' text: 'Browse packages'), ' - Browse packages in the category hierarchy.'.
		(b getLinkLocal: 'categoriestree' text: 'Category tree'), ' - View the full category hierarchy.'.
	}.
	b h2: 'Accounts'.
	b ul: {
		(b getLinkLocal: 'accountsbyname' text: 'All accounts sorted by name'), ' - See all registered accounts.'.
		(b getLinkLocal: 'accountsbyinitials' text: 'All accounts sorted by developer initials'), ' - See all registered accounts.'.
		(b getLinkLocal: 'newaccount' text: 'Get account'), ' - Get a personal account on SqueakMap. Needed to publish packages.'.
		(b getLinkLocal: 'account' text: 'My SqueakMap account'), ' - Your account homepage.'}.
	loggedIn _ self accountsLoggedIn.
	loggedIn isEmpty ifFalse: [
		b h2: 'Logged in now'.
		b ol: self accountsLoggedIn do: [:acc |
			b html: (self accountLink: acc) , ' - ', acc summary ]].

"	b h2: 'Categories and more'.
	b ul: {
		(b getLinkLocal: 'admin' text: 'Administer'), ' - Administer the SqueakMap. <b>Requires password</b>.'.
		(self getLinkLocal: 'analyzeupdate' text: 'Analyze update'), ' - Show some numbers about the current largest slave map update possible.'
	}."
	^b	
!

----- Method: SMSqueakMapView>>help (in category 'urls') -----
help
	"Display general help information."

	| b |
	b _ self builder.
	b start; h1: 'SqueakMap'.
	b p: 'SqueakMap is a Squeak package meta catalog - a catalog of all available Squeak packages.'.
	b p: 'One master instance of the SqueakMap lives on this server. Then each Squeak connected to the Internet has a slave instance of the map that is synchronized against the master. This way every user can have an updated catalog of all available Squeak software on the planet. :-)'.
	b p: 'A SqueakMap contains:'.
	b ul: {
		'User accounts/maintainers that own the other objects on SqueakMap.'.
		'Descriptions of Squeak packages and their releases.'.
		'Descriptions of categories structured in a strict hierarchy used to categorize other objects.'
	}.
	b p: 'The packages and package releases are owned by the accounts. The categories are maintained by a selected few SqueakMap administrators.'.
	b p: 'The central master SqueakMap has a web UI but activities like searching and installing packages are typically done by using a synchronized slave master map living as an object model inside your own local Squeak image. The slave map always keeps the state in a single file on disk and can synchronize itself with the master map by using a single gzipped HTTP request.'.
	b p: 'Read more about SqueakMap on ', (b getLink: '/sm/packagebyname/squeakmap' text: 'its package entry'), ' in SqueakMap.'.
	b hr; linkDefault: 'Back'; end.
	^b	
!

----- Method: SMSqueakMapView>>helpcategories (in category 'urls') -----
helpcategories
	"Display help information about categories."

	| b |
	b _ self builder.
	b start; h1: 'SqueakMap cateogories'.
	b p: 'A SqueakMap category is a "tag" that can be attached to Squeak packages in order to categorize them. The categories are arranged in a strict hierarchy and a Squeak package can "belong" to as many categories as it wishes with one restriction: Some categories are marked as "mandatory" which means that all Squeak packages must belong to <b>one and only one</b> of that categories'' subcategories. This mechanism is used for certain attributes of Squeak packages that we want to make sure are entered for <b>all</b> packages like for example what license a Squeak package has.'.
	b p: 'The use of categories instead of simple Strings for these attributes ensures that such attributes are entered in an orderly fashion and remains unique. An example: If people were to enter the license for a package as a String people would surely end up typing slightly differently like ''Squeak license'', ''SqueakL'', ''Apple license'' etc. when they all mean the same license. This would make it much harder to easily find all packages under the Squeak license.'.
	b p: 'In SqueakMap only SqueakMap administrators can add and edit categories. This is to ensure that the category hierarchy remains sound and to avoid duplications. If you think some categories are missing - send email to any of the administrators or to the Squeak developers'' mailinglist.'.
	b p: 'The fields for a category are described in detail here (bold means that the field is mandatory):'.
	b
		table: {
			'<b>name</b>'->'A String with a name for the package. The card has an id (UUID) too so the name can subsequently be changed but it needs to be unique to avoid confusion.'.
			'<b>summary</b>'->'A one line String describing shortly what the package is in one sentence. This is shown in lists and so on.'.
			'<b>mandatory</b>'->'A boolean value to indicate that all Squeak packages must belong to one and only one subcategory of this category.'.
			'homepage'->'An optional String with the url to a webpage describing the category in more detail. This would typically be a Swiki page on the Squeak swiki.'.
		}
		heads: #('Field' 'Description')
		block: [:a | {a key. a value}].
	b hr; linkDefault: 'Back'; end.
	^b	
!

----- Method: SMSqueakMapView>>helppackage (in category 'urls') -----
helppackage
	"Display help information about a package."

	| b |
	b _ self builder.
	b start; h1: 'Squeak packages'.
	b p: 'A Squeak package is a published piece of code written for/in Squeak. It does not have to be published as a module (as in the new Squeak modules system).'; p: 'In SqueakMap a package is registered with a "library card" describing it. Anyone can register a Squeak package and when doing so the user enters a password which must subsequently be used to update the registration.'.
	b p: 'Basically the "library card"/registration is a bunch of strings describing the Squeak package and a collection of categories it belongs to.'.
	b p: 'The fields are described in detail here, <b>read this before registering a package</b> (bold means that the field is mandatory):'.
	b
		table: {
			'<b>name</b>'->'A String with a name for the package. The card has an id (UUID) too so the name can subsequently be changed but it needs to be unique to avoid confusion.'.
			'<b>summary</b>'->'A one line String describing shortly what the package is in one sentence. This is shown in lists and so on.'.
			'<b>author</b>'->'A String with the original author in format ''Joe Schmoe &lt;joe at schmoe.com&gt;'' or simply the name as ''Joe Schmoe''. For questions, contact the maintainer first since the author may not want to be bothered anymore.'.
			'<b>maintainer</b>'->'A String with the current package maintainer in format ''Joe Schmoe &lt;joe at schmoe.com&gt;''. Often this is the same as the author above but may have changed during the years. This is the person to contact with any questions, not the author.'.
			'current version'->'An optional String with the readable version of the package. This can follow whatever style the author wants.'.
			'version comment'->'An optional String describing the current version of the package in more detail.'.
			'homepage'->'An optional String with the url to the homepage of the package if it has one.'.
			'download'->'An optional String with the url to the current download of the package. Note that if it is packaged as a Squeak Module this is not needed, see "module path" below.'.
			'description'->'An optional 5-10 lines String describing the package in more detail. Remember to use relevant search keywords in the text.'.
			'module path'->'An optional String with the module path as used in the new modules system in Squeak version 3.3 and beyond. A path is expressed like a number of words separated with spaces like ''People gh KillerApp''.'.  
			'module version'->'An optional String with the specific module version. <i>This is not yet finalized in the modules system</i>'.
			'module tag'->'An optional String with the specific module tag (as an alternative to module version). <i>This is not yet finalized in the modules system</i>'.
			'categories'->'An collection with the categories that this card belongs to. Some category choices are mandatory like for example ''license''.'.
			'<b>registrant</b>'->'A String with the person registering the card in format ''Joe Schmoe &lt;joe at schmoe.com&gt;''. You may change this later if someone else takes over responsibility of the registration. This is the person contacted with any questions or reminders about the registration.'.
			'<b>password	</b>'->'A String with the password used by the registrar to be able to update the registration later. If this is forgotten the registrar will have to contact any of the administrators or have SqueakMap send the password in an email to the registrar.'.
		}
		heads: #('Field' 'Description')
		block: [:a | {a key. a value}].
	b p: 'Of all these fields only the last one - categories is not a simple String. When a "library card" (instance of SMCard) describing a Squeak package is being stored or transmitted we use the UUIDs of the categories (instances of SMCategory) instead and then "reconnect" them using real references.'.
	b hr; linkDefault: 'Back'; end.
	^b
!

----- Method: SMSqueakMapView>>helprepository (in category 'urls') -----
helprepository
	"Display help information about a repository."

	| b |
	b _ self builder.
	b start; h1: 'Squeak repositories'.
	b p: 'A Squeak repository is basically a mapping from a <b>module path</b> to a <b>repository url</b> - typically an HTTP or FTP url. This means that everyone intending to host Squeak modules (as in the new modules system available in Squeak 3.3 and beyond) on an FTP or HTTP server should register it in the SqueakMap together with the root module path that corresponds to the top level of the repository.'.
	b p: 'In SqueakMap a repository is registered (much like Squeak packages) with a "library card" describing it. Anyone can register a Squeak repository and when doing so the user enters a password which must subsequently be used to update the registration.'.
	b p: 'The "library card"/registration is a bunch of strings describing the Squeak repository and the fields are described in detail here, <b>read this before registering a repository</b> (bold means that the field is mandatory):'.
	b
		table: {
			'<b>name</b>'->'A String with a name for the repository. The card has an id (UUID) too so the name can subsequently be changed but it needs to be unique to avoid confusion.'.
			'<b>summary</b>'->'A one line String describing shortly the repository in one sentence. This is shown in lists and so on.'.
			'<b>root module path</b>'->'A String with the module path corresponding to the top level of the repository. This can also be described as the "mount point" of the repository in the virtual repository hierarchy. It must of course be unique. Typically a personal repository would have a root path like ''People js''.'.
			'<b>url</b>'->'A String with the url of the repository, typically an ftp or http url.'.
			'<b>registrant</b>'->'A String with the person registering the repository in format ''Joe Schmoe &lt;joe at schmoe.com&gt;''. You may change this later if someone else takes over responsibility of the registration. This is the person contacted with any questions or reminders about the registration.'.
			'<b>password	</b>'->'A String with the password used by the registrar to be able to update the registration later. If this is forgotten the registrar will have to contact any of the administrators or have SqueakMap send the password in an email to the registrar.'.
		}
		heads: #('Field' 'Description')
		block: [:a | {a key. a value}].
	b hr; linkDefault: 'Back'; end.
	^b
!

----- Method: SMSqueakMapView>>initialize (in category 'initialize-release') -----
initialize
	title _ 'SqueakMap'.
	prefix _ ''.
!

----- Method: SMSqueakMapView>>isLoggedIn (in category 'private') -----
isLoggedIn
	"Is the user logged in?"

	^KomSession current attributes at: #admin ifAbsent: [false]!

----- Method: SMSqueakMapView>>isTopView (in category 'testing') -----
isTopView
	^true!

----- Method: SMSqueakMapView>>listCategoriesRecursively:on: (in category 'private') -----
listCategoriesRecursively: cats on: builder.
	"List categories recursively."

	builder ul: cats do: [:cat |
		builder html: (self categoryLink: cat) , ' - ', cat summary.
		cat subCategories isEmpty ifFalse: [
			self listCategoriesRecursively: cat subCategories on: builder]
	]!

----- Method: SMSqueakMapView>>listPackagesByName:in: (in category 'private') -----
listPackagesByName: packages in: aBuilder
	"List packages sorted by their given name as an unordered list."


	aBuilder ul: (packages asSortedCollection: [:x :y | x name caseInsensitiveLessOrEqual: y name]) do: [:p | aBuilder html: (p getLink: aBuilder) , ' - ', p summary]!

----- Method: SMSqueakMapView>>loadgz (in category 'urls') -----
loadgz
	"The user requests a compressed snapshot of the current full map.
	To begin with we use an ImageSegment in SM2."

	((req getFields at: #mapversion
		ifAbsent: [^self compress: 'No mapversion specified'])
			= SMSqueakMap version)
		ifTrue:[
			(((req getFields at: #checkpoint ifAbsent: [^self compress: 'No checkpoint specified!!'])
				asNumber < model checkpointNumber) or: [model isDirty])
					ifTrue: [^model getLastCheckpointWithFilename]
					ifFalse: [^'UPTODATE']]
		ifFalse:[^'Server version:', SMSqueakMap version]!

----- Method: SMSqueakMapView>>login (in category 'urls') -----
login
	"Handle a login."

	^self login: 'Log in to SqueakMap'!

----- Method: SMSqueakMapView>>login: (in category 'private') -----
login: heading
	"Handle a login."

	^self login: heading url: nil!

----- Method: SMSqueakMapView>>login:url: (in category 'private') -----
login: aHeading url: url
	"Handle a login."

	| username password account requestedUrl b msg |
	b _ self builder.
	b title: 'Login to SqueakMap'; h1: aHeading; postForm; columns: 2.
	username _ (b html: 'Username: '; colTab; inputText: #uusername size: 15) value.
	password _ (b colTab; html: 'Password: '; colTab; inputPassword: #ppassword size: 15) value.
	requestedUrl _ b endColumns; inputHidden: #requestedUrl.
	b html: ' Note: Your developer initials doubles as username. You can also use your email address.'.
	b br; br; submit: 'Log in'.
	b h3: [ msg _ b var ].
	msg value: 'In case you have forgotten your password you can ', (b getLinkLocal: 'mailnewpassword' text: 'get a new one'), '.'.
	b html: 'If you haven''t gotten an account yet, ', (b getLinkLocal: 'newaccount' text: 'get one'), '!! It''s quick and painless.'.
	b endForm; end.
	b ifPost: [
		(requestedUrl value = (self originalUrlFor: 'login')) ifTrue:[requestedUrl value: self prefix].
		account _ model accountForUsername: username.
		account ifNil: [account _ model accountForEmail: username].
		account ifNil: [msg value: 'No account with that username or email!!']
			ifNotNil: [
				account password isNil
					ifTrue: [msg value: 'First login should be done using the link provided in the confirmation email!!']
					ifFalse: [
						(account correctPassword: password)
							ifTrue:[
								KomSession current attributes at: #account put: account.
								^self redirectTo: requestedUrl value ]
							ifFalse:[
								KomSession current attributes at: #failedAccount put: account.
								msg value: 'Wrong password - ', (b getLinkLocal: 'mailnewpassword' text: 'would you like a new one?') ]]]
	].
	requestedUrl value: (url ifNil: [req url] ifNotNil: [url]).
	b hr; linkDefault: 'Back'; end.
	^b!

----- Method: SMSqueakMapView>>logout (in category 'urls') -----
logout
	"Handle a logout. If it fails we are probably not logged in.
	This version goes to the top page. A variant would be to go to the login page:
	^self login: request heading: 'Logged out' url: self prefix, '/account'"

	super logout ifFalse: [^self notloggedin].
	^self redirectToDefault!

----- Method: SMSqueakMapView>>mailnewpassword (in category 'urls') -----
mailnewpassword

	| b msg username account randomPassword |
	b _ self builder.
	b h1: 'Mail new password'.
	b p: 'In case you forgot your password you can get a new random one sent through email.'.
	b p: 'Just enter your <b>username or email</b> and click the <b>Send</b> button'.
	b postForm; columns: 2.
	username _ b html: 'Username (your developer initials) or email: '; colTab; inputTextSize: 15.

	b endColumns; br; submit: 'Send'; endForm.
	b h2: [ msg _ b var ].
	b hr; linkDefault: 'Back'; end.
	b ifPost: [
		username value isEmptyOrNil
			ifFalse: [
				account _ model accountForUsername: username value.
				account ifNil: [account _ model accountForEmail: username value]].
		account
			ifNil: [msg value: 'No user found with that email or those developer initials!!']
			ifNotNil: [
				randomPassword _ account createRandomPassword.
				SMUtilities mailPassword: randomPassword for: account.
				msg value: 'A oneshot random password has been sent to <b>', account email, '</b>.']].
	^b!

----- Method: SMSqueakMapView>>newaccount (in category 'urls') -----
newaccount
	"Handle a newaccount request."

	| username msg b msg2 email account name randomPass |
	b _ self builder.
	b h1: 'Register account'.
	b p: 'Before you can publish packages on SqueakMap you need to register an account, it''s real easy.'.
	b ol: {'Enter your name, developer initials (doubles as username) and your email address, then click ''Register'''.
		'A confirmation email is sent immediately - so the email address must be correct!!'.
		'In the confirmation there is a link. Follow it to login to your new account and change to a personal password.'.
		'<b>Done!!</b>'}.
	b postForm; columns: 2.
	name _ b html: 'Name: '; colTab; inputText.
	username _ b colTab; html: 'Developer initials (username): '; colTab; inputText.
	email _ b colTab; html: 'Email address: ';colTab; inputText.
	b endColumns.
	b br; submit: 'Register'; reset: 'Reset'; endForm.
	b html: '<p class="error">'.
	msg _ b var.
	b html: '</p>'.
	b h2: [ msg2 _ b var ].
	b end.
	b ifPost: [
			(self validateUltraSafeString: username value)
				ifFalse:[msg value: 'The initials contains an invalid character!!']
				ifTrue:[
					(model usernameOccupied: username value)
						ifTrue: [username error: 'Those initials are already taken!!'. ^b].
					(model emailOccupied: email value)
						ifTrue: [email error: 'That email address is already taken!!'. ^b].
					(self validateEmail: email value)
						ifFalse: [email error: 'Non valid email address'. ^b].
					[account _ model newAccount: name value username: username value email: email value.
					randomPass _ account createRandomPassword.
					model addObject: account.
					SMUtilities mailPassword: randomPass forNew: account] on: Exception do: [:ex | 
						msg value: 'Something went wrong when creating the account'. ^b].
					msg2 value: 'The account has been created. A confirmation email has been sent to <b>', email value, '</b>.']].
	b hr; linkDefault: 'Back'; end.
	^b!

----- Method: SMSqueakMapView>>notloggedin (in category 'urls') -----
notloggedin
	"Not logged in."

	^self login: 'Not logged in'!

----- Method: SMSqueakMapView>>object (in category 'urls') -----
object
	"Request for a specific object. Pick out the UUID, look it up
	and delegate to a view."

	| uuid obj |
	uuid _ self nextMethod.
	[obj _ model objectWithId: uuid] ifError: [].
	obj ifNil: [^self serverError: 'No object found with id ', uuid].
	^(obj viewFor: self) dispatch!

----- Method: SMSqueakMapView>>package (in category 'urls') -----
package
	"Request for a specific package. Pick out the UUID, look it up
	and delegate to a view."

	| uuid package |
	uuid _ self nextMethod.
	[package _ model packageWithId: uuid] on: Exception do:
		[:ex | ^ self serverError: 'Error when resolving package id: ', ex description].
	package ifNil: [^self serverError: 'No package found with id ', uuid].
	^(package viewFor: self) dispatch!

----- Method: SMSqueakMapView>>packagebyname (in category 'urls') -----
packagebyname
	"Request for a specific package by name. Pick out the name,
	look it up (first found) and delegate to a view. "

	| package name |
	name _ self nextMethod asLowercase.
	package _ model packageWithNameBeginning: name.
	package ifNil: [^self serverError: 'No package found beginning with name ', name].
	^(package viewFor: self) dispatch!

----- Method: SMSqueakMapView>>packagesbyname (in category 'urls') -----
packagesbyname
	"List all packages sorted by their given name."

	| b |
	b _ self builder.
	b start; h1: 'All packages sorted by name'.
	b ul: model packagesByName do:
		[:p | b html: (p getLink: b) , ' - ', p summary].
	b hr; linkDefault: 'Back'; end.
	^b!

----- Method: SMSqueakMapView>>packagesbyregistration (in category 'urls') -----
packagesbyregistration
	"List all packages sorted by their registration timestamp."

	| b |
	b _ self builder.
	b start; h1: 'All packages sorted by registration'.
	b ul: (model packages asSortedCollection: [:x :y | x createdAsSeconds <= y createdAsSeconds]) do:
		[:package | b html: (package created asString) , ': ', (package getLink: b) , ' - ', package summary].
	b hr; linkDefault: 'Back'; end.
	^b!

----- Method: SMSqueakMapView>>ping (in category 'urls') -----
ping
	"The user requests a simple ping to ensure we are responding."

	^'pong'!

----- Method: SMSqueakMapView>>publicAccountViewOn: (in category 'views') -----
publicAccountViewOn: anAccount
	"Wrap the account in a view."

	^SMPublicAccountView on: anAccount parent: self!

----- Method: SMSqueakMapView>>recentnew (in category 'urls') -----
recentnew
	"List last months new objects by creation timestamp."

	| b all limit recent |
	b _ self builder.
	b start; h1: 'Last month'.
	all _ model objects values asSortedCollection: [:o1 :o2 | o1 created > o2 created].
	limit _ TimeStamp current minusDays: 30.
	recent _ all copyUpTo: (all detect: [:o | o created < limit]).
	b columns: 2.
	recent do: [:obj |
		b b: obj created date yyyymmdd,', ', obj type, ':';colTab;
			html: (obj getLink: b) , ' - ', obj summary; colTab].
	b endColumns; hr; linkDefault: 'Back'; end.
	^b!

----- Method: SMSqueakMapView>>sm (in category 'urls') -----
sm
	"This is a hack to make sure older clients
	with the 'sm'-prefix still work, we just strip it."

	^self dispatch!

----- Method: SMSqueakMapView>>updatesgz (in category 'urls') -----
updatesgz
	"The user requests a compressed logfile for all transactions since
	the given transaction number. If no mapversion is sent (an old client) the client
	will have to deal with it..."

	((req getFields at: #mapversion
		ifAbsent: [^self compress: self updates])
			= SMSqueakMap version)
		ifTrue:[^self compress: self updates]
		ifFalse:[^self compress: 'Server version:', SMSqueakMap version]!

----- Method: SMSqueakMapView>>upload (in category 'urls') -----
upload
	^ (SMUploadFileAction fromRequest: req) response!

HVRootView subclass: #SMRootView
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMServer-web'!

!SMRootView commentStamp: '<historical>' prior: 0!
This is the Comanche module for the HttpView framework.
It holds onto the top domain object for the webapplication in the instvar 'model'.
!

----- Method: SMRootView classSide>>createModel (in category 'defaults') -----
createModel
	^SMSqueakMap default!

----- Method: SMRootView classSide>>defaultAlias (in category 'defaults') -----
defaultAlias

	^'/sm'!

----- Method: SMRootView classSide>>defaultViewClass (in category 'defaults') -----
defaultViewClass
	"We are our own view class."
	^nil!

----- Method: SMRootView classSide>>rootView (in category 'defaults') -----
rootView
	"Return class to use as root view. Override to provide your own."

	^self!

----- Method: SMRootView>>packageViewOn: (in category 'views') -----
packageViewOn: aPackage
	"Wrap the package in a view."

	^SMPackageView on: aPackage parent: self!

----- Method: SMRootView>>serverViewOn: (in category 'views') -----
serverViewOn: aServer
	"Wrap the server in a view.
	NOTE: We have no request to set here - it will be inserted
	in #process:. Since we are being called in multiple Processes we can't hold onto
	th request in an instvar."

	^SMServerView on: aServer parent: self!

----- Method: SMRootView>>squeakMapViewOn: (in category 'views') -----
squeakMapViewOn: aSqueakMap
	"Wrap the map in a view.
	NOTE: We have no request to set here - it will be inserted
	in #process:. Since we are being called in multiple Processes we can't hold onto
	th request in an instvar."

	^SMSqueakMapView on: aSqueakMap parent: self!

----- Method: SMRootView>>useSessions (in category 'defaults') -----
useSessions
	"By default we don't."

	^true!

Object subclass: #SMHtmlFormatter
	instanceVariableNames: 'model base inParagraph targetStream lastWasCR consumeCR ulLevel olLevel renderParagraphs'
	classVariableNames: 'SpecialCharacterString AngleBrackets EmCharacter SpecialCharacter EmCharacterString'
	poolDictionaries: ''
	category: 'SMServer-web'!

!SMHtmlFormatter commentStamp: 'gh 10/28/2002 08:47' prior: 0!
A reimplementation of the swikification parser/HTML generator. It is highly direct and usable standalone.
The model is used for resolving links and must implement #urlForLink:.
All swikification can be seen in method #swikifyPiece:.!

----- Method: SMHtmlFormatter classSide>>base:model: (in category 'instance creation') -----
base: anUrl model: aModel

	| formatter |
	formatter _ self new.
	formatter base: anUrl model: aModel.
	^formatter!

----- Method: SMHtmlFormatter classSide>>initialize (in category 'initialize-release') -----
initialize
	"self initialize"

	AngleBrackets _ CharacterSet newFrom: #($< $>).
	SpecialCharacter _ $*.
	SpecialCharacterString _ SpecialCharacter asString.
	EmCharacter _ $_.
	EmCharacterString _ EmCharacter asString.
!

----- Method: SMHtmlFormatter classSide>>test1 (in category 'tests') -----
test1
	"self test1"

	| text |
	text _ '!!Heading3
A line after that with cr.
A <b>bold</b> word.
Another _bold_ word.

!!!!Heading2
A paragraph.

!!!!!!Heading1
Another paragraph. <html><pre>Don''t touch this.No line breaking.</pre></html> End of paragraph.
!!Hello
'.
	^(SMHtmlFormatter base: 'http://www.garble.com/') swikify: text
		!

----- Method: SMHtmlFormatter classSide>>test2 (in category 'tests') -----
test2
	"self test2"

	| text |
	text _
'A paragraph
That has a <b>bold</b> word and
two linebreaks in it.


!!Before this heading 3 there should be one extra break
A paragraph after heading 1 an & (ampersand).

Another paragraph after heading 1'.
	^(SMHtmlFormatter base: 'http://www.garble.com/') swikify: text
		!

----- Method: SMHtmlFormatter classSide>>test3 (in category 'tests') -----
test3
	"self test3"

	| text |
	text _
'A *link* and an aliased *This is the shown text|link*'.
	^(SMHtmlFormatter base: 'http://www.garble.com' model: self) swikify: text
		!

----- Method: SMHtmlFormatter classSide>>test4 (in category 'tests') -----
test4
	"self test4"

	| text |
	text _
'A *link* and an aliased *alias|link*

!!Heading
A *link* and an aliased *alias|link*
'.
	^(SMHtmlFormatter base: 'http://www.garble.com' model: self) swikify: text
		!

----- Method: SMHtmlFormatter classSide>>test5 (in category 'tests') -----
test5
	"self test5"

	| text |
	text _
'-One
-Two
--Nested one with a *link* and an & and a ** (star)
--Nested two
---Deep down one
-Three

#Uno
#Dos
#Tres
'.
	^(SMHtmlFormatter base: 'http://www.garble.com/' model: self) swikify: text
		!

----- Method: SMHtmlFormatter classSide>>test6 (in category 'tests') -----
test6
	"self test6"

	| text |
	text _
'-One <b>bold</b> line
-New line'.
	^(SMHtmlFormatter base: 'http://www.garble.com' model: self) swikify: text
		!

----- Method: SMHtmlFormatter classSide>>urlAndString:forLink: (in category 'tests') -----
urlAndString: aBlock forLink: aString
	"This is only for tests. We just return the string."

	aBlock value: aString value: aString!

----- Method: SMHtmlFormatter classSide>>urlForLink: (in category 'tests') -----
urlForLink: aString
	"This is only for tests. We just return the string."

	^aString!

----- Method: SMHtmlFormatter>>base:model: (in category 'accessing') -----
base: anUrl model: aModel

	renderParagraphs _ true.
	base _ anUrl.
	model _ aModel!

----- Method: SMHtmlFormatter>>break (in category 'private') -----
break
	"Add a linebreak."

	targetStream nextPutAll: '<br />'; cr.!

----- Method: SMHtmlFormatter>>countLevel:in: (in category 'private') -----
countLevel: char in: aLine
	"Start the paragraph."

	| count |
	count _ 0.
	aLine do: [:c | c = char ifTrue:[count _ count + 1] ifFalse: [^count]].
	^count!

----- Method: SMHtmlFormatter>>endParagraph (in category 'private') -----
endParagraph
	"End the paragraph."

	targetStream cr; nextPutAll: '</p>';cr!

----- Method: SMHtmlFormatter>>endPossibleOl (in category 'private') -----
endPossibleOl
	"Ok, close the uls."

	olLevel > 0 ifTrue:[
		targetStream nextPutAll: '</li>'; cr.
		olLevel timesRepeat: [targetStream nextPutAll: '</ol>';cr].
		olLevel _ 0.
		^true].
	^false!

----- Method: SMHtmlFormatter>>endPossibleParagraph (in category 'private') -----
endPossibleParagraph
	"End the paragraph if we are in it."

	inParagraph ifTrue: [targetStream cr; nextPutAll: '</p>';cr. inParagraph _ false]!

----- Method: SMHtmlFormatter>>endPossibleUl (in category 'private') -----
endPossibleUl
	"Ok, close the uls."

	ulLevel > 0 ifTrue:[
		targetStream nextPutAll: '</li>'; cr.
		ulLevel timesRepeat: [targetStream nextPutAll: '</ul>';cr].
		ulLevel _ 0.
		^true].
	^false!

----- Method: SMHtmlFormatter>>externalURL:string: (in category 'private') -----
externalURL: url string: string
	"Make a non-local link."

	^'<a href="', url, '">', string,'</a>'!

----- Method: SMHtmlFormatter>>fixEms: (in category 'private') -----
fixEms: aString
	"Resolve all the emphasizes."

	| start aLine end |
	start _ 1.
	aLine _ aString.
	[(start _ aLine indexOfSubCollection: '_' startingAt: start ifAbsent: [0]) ~= 0
		and: [start < aLine size]]
	whileTrue:
		[(aLine at: start+1) = $_
			ifTrue: [aLine _ aLine copyReplaceFrom: start 
								to: start+1 with: '_'.
					start_start + 1]
			ifFalse: [
				(end _ aLine indexOfSubCollection: '_'
						startingAt: (start+1) ifAbsent: [0]) ~= 0
					ifTrue: [aLine _ aLine copyReplaceFrom: start to: end
							with: ('<b>', (aLine copyFrom: start+1 to: end-1), '</b>')]
					ifFalse: [start _ start + 1]]].
	^aLine!

----- Method: SMHtmlFormatter>>fixLinks: (in category 'private') -----
fixLinks: aString
	"Resolve all the links."

	| start aLine end |
	start _ 1.
	aLine _ aString.
	[(start _ aLine indexOfSubCollection: SpecialCharacterString startingAt: start ifAbsent: [0]) ~= 0
		and: [start < aLine size]]
	whileTrue:
		[(aLine at: start+1) = SpecialCharacter
			ifTrue: [aLine _ aLine copyReplaceFrom: start 
								to: start+1 with: SpecialCharacterString.
					start_start + 1]
			ifFalse: [
				(end _ aLine indexOfSubCollection: SpecialCharacterString
						startingAt: (start+1) ifAbsent: [0]) ~= 0
					ifTrue: [aLine _ aLine copyReplaceFrom: start to: end
							with: (self resolveLink: (aLine copyFrom: start+1 to: end-1))]
					ifFalse: [start _ start + 1]]].
	^aLine!

----- Method: SMHtmlFormatter>>imageURL:string: (in category 'private') -----
imageURL: url string: string
	"Make a non-local image link."

	^'<img src="', url,'" alt="', string, '">'!

----- Method: SMHtmlFormatter>>isStringAnImage: (in category 'private') -----
isStringAnImage: anUpperCasedString
	"check the string to see if it end with something that makes it likely to be an image URL"
	^(anUpperCasedString endsWith: '.GIF') or:
		[(anUpperCasedString endsWith: '.JPEG') or:
		[anUpperCasedString endsWith: '.JPG']]!

----- Method: SMHtmlFormatter>>isStringRooted: (in category 'private') -----
isStringRooted: anUpperCasedString
	"check the string to see if it starts with something that makes it
lkely to be a rooted URL"
	^(anUpperCasedString indexOfSubCollection: 'HTTP' startingAt: 1) =
1 or:
	[(anUpperCasedString indexOfSubCollection: 'FTP' startingAt: 1) = 1 or:
	[(anUpperCasedString indexOfSubCollection: 'MAILTO' startingAt: 1)
= 1]]!

----- Method: SMHtmlFormatter>>localImageURL:string: (in category 'private') -----
localImageURL: url string: string
	"Make a local image link."

	string ifNil: [^'<img src="', base, '/', url, '">']
		ifNotNil: [^'<a href="', string, '"><img src="', base, '/', url, '"></a>']!

----- Method: SMHtmlFormatter>>localURL:string: (in category 'private') -----
localURL: url string: string
	"Make a local URL."

	^'<a href="', base, '/', url, '">', string, '</a>'!

----- Method: SMHtmlFormatter>>renderParagraphs: (in category 'accessing') -----
renderParagraphs: aBoolean

	renderParagraphs _ aBoolean!

----- Method: SMHtmlFormatter>>resolveLink: (in category 'private') -----
resolveLink: aString
	"Resolve the link. Text before an optional '|' is used as the visible string.
	If it is an image url which is then embedded the text before '|' is
	resolved to a link for the image."

	|  parts url string uurl |
	parts _ aString findTokens: '|'.
	parts size = 1
		ifTrue:[url _ string _ aString]
		ifFalse: [url _ parts at: 2. string _ parts at: 1].
	model urlAndString: [:u :s | url _ u. string _ s] forLink: url.
	uurl _ url asUppercase.
	(self isStringRooted: uurl)
		ifTrue: ["an external URL"
			(self isStringAnImage: uurl)
				ifTrue: ["Looks like an image URL"
						(parts size = 1)
							ifFalse:[model urlAndString: [:u :s | ^self imageURL: url string: s] forLink: string]
							ifTrue: [^self imageURL: url string: nil]]
				ifFalse: [^self externalURL: url string: string]]
		ifFalse: ["an internal URL"
			(self isStringAnImage: uurl)
					ifTrue: [(parts size = 1)
							ifFalse:[model urlAndString: [:u :s | ^self localImageURL: url string: s] forLink: string]
							ifTrue: [^self localImageURL: url string: nil]]
					ifFalse: [^self localURL: url string: string]]!

----- Method: SMHtmlFormatter>>startParagraph (in category 'private') -----
startParagraph
	"Start the paragraph."

	renderParagraphs ifTrue: [
		inParagraph _ true.
		targetStream nextPutAll: '<p>';cr]!

----- Method: SMHtmlFormatter>>swikify: (in category 'accessing') -----
swikify: aString
	"Swikify the String. This code only handles cutting up
	the String into pieces based on angle brackets and calling
	#swikifyPiece: for each piece outside of a tag.
	The tag <html></html> is also handled as a way of
	disabling swikification."

	| pos index piece tagLevel finished size ignore |
	aString isEmptyOrNil ifTrue:[^''].
	inParagraph _ finished _ ignore _ false.
	lastWasCR _ true.
	consumeCR _ false.
	ulLevel _ olLevel _ tagLevel _ index _ 0.
	pos _ 1.
	size _ aString size.
	targetStream := WriteStream on: (String new: 300).
	[finished ifFalse: [index _ aString indexOfAnyOf: AngleBrackets startingAt: pos].
	finished]
		whileFalse: [
			index = 0
				ifTrue:[index _ size. piece _ aString copyFrom: pos to: index]
				ifFalse:[	piece _ aString copyFrom: pos to: index - 1].
			pos _ index + 1.
			(ignore or: [tagLevel > 0])
				ifTrue:["Check special tags"
					(piece = 'nopara') ifTrue:[renderParagraphs _ false] ifFalse:[
					(piece = '/nopara') ifTrue:[renderParagraphs _ true] ifFalse:[
					(piece = 'html') ifTrue:[ignore _ true] ifFalse:[
					(piece = '/html') ifTrue:[ignore _ false] ifFalse:[
						tagLevel = 0
							ifTrue:[targetStream nextPutAll: piece]
							ifFalse: [targetStream nextPutAll: '<', piece, '>'].
						]]]]]
				ifFalse:[self swikifyPiece: piece].
			((aString at: index) = $<)
				ifTrue: [tagLevel _ tagLevel + 1]
				ifFalse: [tagLevel _ tagLevel - 1].
			finished _ index = size.
		].
	"End any lists"
	self endPossibleUl; endPossibleOl.

	"If we are still in a paragraph we end it."
	self endPossibleParagraph.

	"If we have a hanging CR we add a break."
	consumeCR ifFalse: [lastWasCR ifTrue:[self break. lastWasCR _ false]].
	^targetStream contents!

----- Method: SMHtmlFormatter>>swikifyPiece: (in category 'private') -----
swikifyPiece: aString
	"Swikify the String. The string contains CRs as lineendings but may
	end in a middle of a line, that is why we keep state in instance variables.
	An empty line ends current paragraph if
	a paragraph is in progress, otherwise it generates a <br />.
	Transformations done are:
		CR -> <br />, !! -> h1, !!!! -> h2, !!!!!! -> h3, # -> <ol> , ## -> nested <ol>
		- -> <ul>, -- -> nested <ul>, _something_ -> <b>something</b>
		| -> <hr>
		*something* -> Link to something,
		*textOrImage|something* -> Link to something but showing text or image for link. 

		And then finally also map '&' -> '&amp;' and '**'-> '*'"

	"Map the tricky characters." 
	| string newLevel |
	string _ aString copyReplaceAll: '&' with: '&amp;'.
	(string findTokens: (String with: Character cr with: Character lf) keep: (String with: Character cr)) do: [:aLine |
		(aLine = (String with: Character cr))
			ifFalse: [ "Not a CR"
				"Convert any links in the line"
				aLine _ self fixEms: aLine.
				aLine _ self fixLinks: aLine.

				"Check for special line beginnings"
				consumeCR _ true.
				lastWasCR ifTrue:[
					(aLine beginsWith: '-')
						ifTrue: [self endPossibleParagraph.
								newLevel _ self countLevel: $- in: aLine.
								newLevel > ulLevel
									ifTrue:[(newLevel - ulLevel) timesRepeat: [targetStream nextPutAll: '<ul>';cr]]
									ifFalse: [(ulLevel - newLevel) timesRepeat: [targetStream nextPutAll: '</ul>';cr]].
								ulLevel > 0 ifTrue:[targetStream nextPutAll: '</li>';cr].
								targetStream nextPutAll: '<li>', (aLine copyFrom: newLevel + 1 to: aLine size).
								ulLevel _ newLevel] ifFalse: [
					self endPossibleUl.
					(aLine beginsWith: '#')
						ifTrue: [self endPossibleParagraph.
								newLevel _ self countLevel: $# in: aLine.
								newLevel > olLevel
									ifTrue:[(newLevel - olLevel) timesRepeat: [targetStream nextPutAll: '<ol>';cr]]
									ifFalse: [(olLevel - newLevel) timesRepeat: [targetStream nextPutAll: '</ol>';cr]].
								olLevel > 0 ifTrue:[targetStream nextPutAll: '</li>';cr].
								targetStream nextPutAll: '<li>', (aLine copyFrom: newLevel + 1 to: aLine size).
								olLevel _ newLevel.] ifFalse: [
					self endPossibleOl.
					(aLine beginsWith: '|')
						ifTrue: [self endPossibleParagraph.
								targetStream nextPutAll: '<hr>' ; cr.] ifFalse: [
					(aLine beginsWith: '!!!!!!')
						ifTrue: [self endPossibleParagraph.
								targetStream nextPutAll: '<h3>',
								(aLine copyFrom: 4 to: aLine size),'</h3>';cr.] ifFalse: [
					(aLine beginsWith: '!!!!')
						ifTrue: [self endPossibleParagraph.
								targetStream nextPutAll: '<h2>',
								(aLine copyFrom: 3 to: aLine size),'</h2>';cr.] ifFalse: [
					(aLine beginsWith: '!!')
						ifTrue: [self endPossibleParagraph.
								targetStream nextPutAll: '<h1>',
								(aLine copyFrom: 2 to: aLine size),'</h1>';cr.]
						ifFalse: [
							consumeCR _ false.
							"Ok, then this is text. If we are not in a paragraph we start one."
							inParagraph
								ifTrue: ["If last was CR we add a break for that until we continue."
										lastWasCR ifTrue:[self break]]
								ifFalse: [(ulLevel + olLevel = 0) ifTrue:[self startParagraph]].
							targetStream nextPutAll: aLine]]]]]]]
				ifFalse: [
					consumeCR _ false.
					"Ok, then this is text. If we are not in a paragraph we start one."
					inParagraph
						ifTrue: ["If last was CR we add a break for that until we continue."
								lastWasCR ifTrue:[self break]]
						ifFalse: [(ulLevel + olLevel = 0) ifTrue:[self startParagraph]].
					targetStream nextPutAll: aLine].
				lastWasCR _ false]

			 ifTrue: ["A CR"
				"If we are in a paragraph and last was a CR we end it, otherwise we remember this CR."
				consumeCR
					ifTrue: [consumeCR _ false. lastWasCR _ true]
					ifFalse: [
							lastWasCR
								ifTrue:[(self endPossibleUl | self endPossibleOl)
											ifFalse:[
												inParagraph
													ifTrue:[self endPossibleParagraph]
													ifFalse: [self break]]]
								ifFalse:[lastWasCR _ true]]]]!

Object subclass: #SMRemoteAction
	instanceVariableNames: 'request fields account'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMServer-remote'!

SMRemoteAction subclass: #SMNewReleaseAction
	instanceVariableNames: 'package release'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMServer-remote'!

----- Method: SMNewReleaseAction>>go (in category 'as yet unclassified') -----
go
	(package isOwnerOrMaintainer: self account) ifFalse: [self invalidAccountError].
	self map transaction:
		[release _ package newRelease.
		release
			version: (self fieldAt: 'version');
			note: (self fieldAt: 'note');
			downloadUrl: (self fieldAt: 'downloadURL');
			name: (self fieldAt: 'name');
			summary: (self fieldAt: 'summary');
			stampAsUpdated].
	^ release smartVersion!

----- Method: SMNewReleaseAction>>map (in category 'accessing') -----
map
	^ package map!

----- Method: SMNewReleaseAction>>package: (in category 'accessing') -----
package: aPackage
	package _ aPackage!

----- Method: SMRemoteAction classSide>>fromRequest: (in category 'as yet unclassified') -----
fromRequest: aRequest
	^ self basicNew initializeWithRequest: aRequest!

----- Method: SMRemoteAction>>account (in category 'as yet unclassified') -----
account
	^ account ifNil: [account _ self getAccount]!

----- Method: SMRemoteAction>>fieldAt: (in category 'accessing') -----
fieldAt: aString
	^ self fields at: aString ifAbsent: ['']!

----- Method: SMRemoteAction>>fields (in category 'accessing') -----
fields
	^ fields ifNil: [fields _ HttpRequest decodeUrlEncodedForm: request rawPostFields]!

----- Method: SMRemoteAction>>getAccount (in category 'as yet unclassified') -----
getAccount
	| credentials user password |
	credentials _ (Base64MimeConverter mimeDecodeToChars:  request user readStream) contents.
	user _ credentials upTo: $:.
	password _ credentials copyAfter: $:.
	^ (self getAccount: user password: password) ifNil: [self invalidAccountError]!

----- Method: SMRemoteAction>>getAccount:password: (in category 'as yet unclassified') -----
getAccount: userString password: passwordString
	^ (self map accountForUsername: userString) ifNotNilDo:
		[:acct |
		(acct correctPassword: passwordString)
			ifTrue: [acct]]!

----- Method: SMRemoteAction>>go (in category 'as yet unclassified') -----
go
	self subclassResponsibility!

----- Method: SMRemoteAction>>initializeWithRequest: (in category 'initialization') -----
initializeWithRequest: aRequest
	request _ aRequest!

----- Method: SMRemoteAction>>invalidAccountError (in category 'as yet unclassified') -----
invalidAccountError
	self error: 'Invalid account'!

----- Method: SMRemoteAction>>isPut (in category 'testing') -----
isPut
	^ self method = 'PUT'!

----- Method: SMRemoteAction>>map (in category 'accessing') -----
map
	^ SMSqueakMap default!

----- Method: SMRemoteAction>>method (in category 'accessing') -----
method
	^ request method asUppercase!

----- Method: SMRemoteAction>>putData (in category 'as yet unclassified') -----
putData
	^ request stream next: request contentLength!

----- Method: SMRemoteAction>>response (in category 'accessing') -----
response
	^ self go!

----- Method: SMRemoteAction>>writePutDataOn: (in category 'as yet unclassified') -----
writePutDataOn: aStream
	request multipartFormFieldsDo:
		[:chunk |
		chunk fileName isEmptyOrNil ifFalse:
			[chunk saveToStream: aStream.
			^ chunk fileName]].
	^ nil!

SMRemoteAction subclass: #SMUploadFileAction
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMServer-remote'!

----- Method: SMUploadFileAction>>fileName (in category 'accessing') -----
fileName
	| tokens |
	tokens _ request url findTokens: '/'.
	^ tokens last!

----- Method: SMUploadFileAction>>go (in category 'as yet unclassified') -----
go
	self isPut ifFalse: [self error: 'You must upload a file with PUT'].
	self account newFile: self fileName block: [:s | s nextPutAll: self putData].
	^ SMUtilities masterServer, '/accountbyid/',  self account id asString, '/files/', self fileName!

SMRemoteAction subclass: #SMUploadHintAction
	instanceVariableNames: 'release'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'SMServer-remote'!

----- Method: SMUploadHintAction>>addHint: (in category 'as yet unclassified') -----
addHint: aHint
	"The incoming request is a request to add a hint.
	We both add it to the owner account and to the release."

	self map transaction: [
		self account addObject: aHint.
		release addResource: aHint]
	!

----- Method: SMUploadHintAction>>go (in category 'as yet unclassified') -----
go
	"Execute the action. Depending on the type given
	we remove the hint with the given UUID
	or we extract the hint from the request and add it."
	
	| hint type |
	type _ (self fieldAt: 'type') asNumber.
	((self fieldAt: 'type') asNumber isZero)
		ifTrue: [self removeHintWithUUID: (UUID fromString: (self fieldAt: 'contents'))]
		ifFalse: [
			hint _ SMKabunguHint newIn: release map.
			hint type: type; contents: (self fieldAt: 'contents').
			self addHint: hint]!

----- Method: SMUploadHintAction>>release: (in category 'accessing') -----
release: aRelease

	release _ aRelease!

----- Method: SMUploadHintAction>>removeHintWithId: (in category 'as yet unclassified') -----
removeHintWithId: aUUID
	"The incoming request is a request to remove
	an existing hint. Do that if authorized."

	| target |
	target _ release resources detect: [:r | r id = aUUID] 
				ifNone: [^self error: 'Could not remove hint ', aUUID printString, ', there is no such hint'].

	"only the author of the hint, or the maintainer/owner of the package can remove a hint"
	(self account = target account or: [release package isOwnerOrMaintainer: self account])
		ifFalse: [^self invalidAccountError].
	self map transaction: [
		release removeResource: target.
		target delete]!



More information about the Packages mailing list