Authentication.icl 7.88 KB
Newer Older
1
implementation module iTasks.Extensions.Distributed.Authentication
2 3

import iTasks
4
import iTasks.Extensions.Admin.UserAdmin
5 6 7 8
from Text import class Text, instance Text String
import qualified Data.Map as DM
import qualified Text as T
import Text.Encodings.Base64
Mart Lubbers's avatar
Mart Lubbers committed
9
from iTasks.Internal.Distributed.Domain import :: Domain(..)
10
from iTasks.Extensions.Distributed._Util import repeatClient
11
from Data.Maybe import fromMaybe, isNothing, fromJust, maybe, instance Functor Maybe
12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27

:: Communication =
	{ id :: Int
	, requests :: [String]
	, responses :: [String]
	}

:: AuthShare =
	{ lastId :: Int
	, clients :: [Communication]
	}

:: AuthServerState =
	{ id :: Int
	, buffer :: String
	}
28

29 30 31 32 33 34 35 36 37
derive class iTask Communication
derive class iTask AuthShare
derive class iTask AuthServerState

authServerShare = sharedStore "authServerShare" {AuthShare| lastId = 0, clients = [] }

authServer :: Int -> Task ()
authServer port = tcplisten port True authServerShare {ConnectionHandlers
	| onConnect 		= onConnect
38 39
	, onData		= onData
	, onShareChange		= onShareChange
40
	, onDisconnect 		= onDisconnect
Mart Lubbers's avatar
Mart Lubbers committed
41
	, onDestroy         = \s->(Ok s, [])
42 43
	} -|| (process authServerShare) @! ()
where
44 45
	onConnect :: ConnectionId String AuthShare -> (MaybeErrorString AuthServerState, Maybe AuthShare, [String], Bool)
	onConnect connId host share
46 47 48 49 50 51 52
		# clientId = share.lastId + 1
		= ( Ok {AuthServerState| id = clientId, buffer = "" }
		  , Just { share & lastId = clientId, clients = share.clients ++ [{Communication| id = clientId, requests = [], responses = []}] }
		  , []
		  , False
		  )

53 54
	onData :: String AuthServerState AuthShare -> (MaybeErrorString AuthServerState, Maybe AuthShare, [String], Bool)
	onData newData st=:{id,buffer} share
55 56
		= let (requests, newBuffer) = getRequests (buffer +++ newData) in
			(Ok {AuthServerState| st & buffer = newBuffer}, Just { share & clients = [ if (clientid == id) ({Communication| c & requests = c.requests ++ requests}) c \\ c=:{Communication|id=clientid} <- share.clients] }, [], False)
57

58
	onShareChange state=:{AuthServerState|id} share
59 60 61 62
		# responses = flatten [ c.responses \\ c=:{Communication|id=clientid} <- share.clients | clientid == id ]
		| isEmpty responses = (Ok state, Just share, responses, False)
		# share = {share & clients = [ if (clientid == id) {Communication| c & responses = []} c \\ c=:{Communication|id=clientid} <- share.clients ] }
		= (Ok state, Just share, [ r +++ "\n" \\ r <- responses ], False) // Only replay on requests.
63

64 65 66
	onDisconnect :: AuthServerState AuthShare -> (MaybeErrorString AuthServerState, Maybe AuthShare)
	onDisconnect state share
		= (Ok state, Just share)
67

68
	process :: (Shared sds AuthShare) -> Task () | RWShared sds
69 70 71 72 73
	process share
		= forever (watch share >>* [OnValue (ifValue hasRequests \_ -> changed)] @! ())
	where
		hasRequests :: AuthShare -> Bool
		hasRequests {AuthShare|clients} = not (isEmpty (flatten [requests \\ c=:{Communication|requests}<-clients | not (isEmpty requests)]))
74

75 76 77 78 79 80
		changed :: Task Bool
		changed
			= get share
			>>= \{AuthShare|clients} -> processClients clients
			>>= \newClients -> upd (\s -> {AuthShare| s & clients = newClients}) share
			>>| return True
81

82 83 84 85 86 87
		processClients :: [Communication] -> Task [Communication]
		processClients [] = return []
		processClients [c=:{Communication|id, requests}:rest]
			= case requests of
				[]		= processClients rest >>= \rest -> return [c:rest]
				data	= processClients rest >>= \rest -> appendTopLevelTask ('DM'.fromList []) True (handleClient id data) >>| return [{Communication| c & requests = []}:rest]
88

89 90 91
		handleClient :: Int [String] -> Task ()
		handleClient id requests
			= handleClientRequests id requests
92 93
			>>= \responses -> upd (\s -> {AuthShare| s & clients = [if (clientid == id) ({Communication| c & responses=responses}) c \\ c=:{Communication|id=clientid} <- s.clients]}) share @! ()

94
		handleClientRequests :: Int [String] -> Task [String]
95
		handleClientRequests id []
96 97 98
			= return []
		handleClientRequests id [request:rest]
			= handleClientRequest id ('T'.split " " request)
99
			>>= \responses -> handleClientRequests id rest
100
			>>= \other -> return (responses ++ other)
101

102
		handleClientRequest :: Int [String] -> Task [String]
103
		handleClientRequest id ["auth", username, password]
104 105 106 107
			# username = base64Decode username
			# password = base64Decode password
			= authenticateUser (Username username) (Password password)
			>>= \user -> return [(base64Encode (toString (toJSON user)))]
108
		handleClientRequest id ["users"]
109 110 111 112 113 114 115 116 117 118 119 120 121
			= get users
			>>= \users -> return [(base64Encode (toString (toJSON users)))]
		handleClientRequest _ _ = return []

remoteAuthenticateUser	:: !Username !Password	-> Task (Maybe User)
remoteAuthenticateUser (Username username) (Password password)
	# user = (toString (base64Encode username))
	# pass = (toString (base64Encode password))
	= get authServerInfoShare
	>>- \domain -> request domain DEFAULT_AUTH_PORT ("auth " +++ user +++ " " +++ pass)
	>>- \user -> return (fromMaybe Nothing user)

getUsers :: String Int -> Task [User]
122
getUsers host port
123 124 125 126 127 128 129 130 131
	= request host port "users"
	>>= \users -> return (fromMaybe [] users)

request	:: String Int String -> Task (Maybe a) | iTask a
request host port request
	= repeatClient client
where
	client :: Task (Maybe a) | iTask a
	client
132
		= ((tcpconnect host port (constShare ())
133 134
                        { ConnectionHandlers
                        | onConnect      = onConnect
135 136
                        , onData	 = onData
			, onShareChange  = onShareChange
137
                        , onDisconnect   = onDisconnect
Mart Lubbers's avatar
Mart Lubbers committed
138
                        , onDestroy      = \s->(Ok s, [])
139
                        }) @? taskResult)
140 141 142 143
		>>- \(resps,_) -> case resps of
					[resp:_]  -> return (fromJSON (fromString (base64Decode resp)))
					_         -> return Nothing

144 145
	onConnect :: ConnectionId String () -> (MaybeErrorString ([String], String, Bool), Maybe (), [String], Bool)
	onConnect connId host store
146
		= (Ok ([], "", False), Just store, [request +++ "\n"], False)
147

148 149
	onData :: String ([String], String,Bool) () -> (MaybeErrorString ([String], String, Bool), Maybe (), [String], Bool)
	onData received state=:(response,data,_) store
150 151
		# received_data = data +++ received
		# (new_requests,other) = getRequests received_data
152 153 154
		= (Ok (response ++ new_requests,data, not (isEmpty new_requests)), Just store, [], False)

	onShareChange state ()
155 156
		= (Ok state, Nothing, [], False)

157
	onDisconnect :: ([String], String, Bool) () -> (MaybeErrorString ([String], String, Bool), Maybe ())
158 159 160
	onDisconnect state share
                = (Ok state, Just share)

161
	taskResult (Value (r1,r2,True) _) = Value (r1,r2) True
162
	taskResult _                      = NoValue
163

164 165 166 167 168 169 170 171 172 173 174 175 176 177
getRequests :: String -> ([String], String)
getRequests input
	| 'T'.indexOf "\n" input <> -1
		# splitpoint = 'T'.indexOf "\n" input
		# request = 'T'.subString 0 splitpoint input
		# rest = 'T'.dropChars (splitpoint + 1) input
		= let (req,data) = getRequests rest in ([request : req], data)
	= ([], input)

DEFAULT_AUTH_PORT :: Int
DEFAULT_AUTH_PORT = 2018

domainAuthServer :: Task ()
domainAuthServer
178
	= authServer DEFAULT_AUTH_PORT
179 180 181 182 183 184 185 186 187 188

usersOf :: Domain -> Task [User]
usersOf (Domain domain)
	= request domain DEFAULT_AUTH_PORT "users"
	>>- \users -> return (fromMaybe [] users)

startAuthEngine :: Domain -> Task ()
startAuthEngine (Domain domain)
	= set domain authServerInfoShare @! ()

189
authServerInfoShare :: SimpleSDSLens String
190 191
authServerInfoShare = sharedStore "authServer" ""

192
currentDistributedUser :: SimpleSDSParallel (User,Domain)
Haye Böhm's avatar
Haye Böhm committed
193
currentDistributedUser = sdsParallel "communicationDetailsByNo" param read (SDSWriteConst writel) (SDSWriteConst writer) currentUser authServerInfoShare
194 195 196
where
	param p = (p,p)
	read (user,domain) = (user,Domain domain)
Haye Böhm's avatar
Haye Böhm committed
197 198
	writel _ (x,_) = Ok (Just x)
	writer _ (_, Domain y) = Ok (Just y)
199

200
currentDomain :: SDSLens () Domain ()
Haye Böhm's avatar
Haye Böhm committed
201
currentDomain = toReadOnly (mapRead (\domain -> Domain domain) authServerInfoShare)
202 203 204 205

enterDomain :: Task Domain
enterDomain
	= get authServerInfoShare
206
	>>- \domain -> Hint "Enter domain" @>> updateInformation  [] (Domain domain)