/
JsonFile.hs
316 lines (257 loc) · 10.7 KB
/
JsonFile.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
module Snap.Snaplet.Auth.Backends.JsonFile
( initJsonFileAuthManager
, mkJsonAuthMgr
) where
import Control.Applicative
import Control.Monad.State
import Control.Concurrent.STM
import Data.Aeson
import qualified Data.Attoparsec as Atto
import qualified Data.ByteString.Lazy as LB
import qualified Data.ByteString as B
import qualified Data.Map as HM
import Data.Map (Map)
import Data.Maybe (fromJust, isJust)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time
import Web.ClientSession
import System.Directory
import Snap.Snaplet
import Snap.Snaplet.Auth.Types
import Snap.Snaplet.Auth.AuthManager
import Snap.Snaplet.Session
------------------------------------------------------------------------------
-- | Initialize a JSON file backed 'AuthManager'
initJsonFileAuthManager :: AuthSettings
-- ^ Authentication settings for your app
-> SnapletLens b SessionManager
-- ^ Lens into a 'SessionManager' auth snaplet will
-- use
-> FilePath
-- ^ Where to store user data as JSON
-> SnapletInit b (AuthManager b)
initJsonFileAuthManager s l db = do
makeSnaplet
"JsonFileAuthManager"
"A snaplet providing user authentication using a JSON-file backend"
Nothing $ liftIO $ do
rng <- liftIO mkRNG
key <- getKey (asSiteKey s)
jsonMgr <- mkJsonAuthMgr db
return $! AuthManager {
backend = jsonMgr
, session = l
, activeUser = Nothing
, minPasswdLen = asMinPasswdLen s
, rememberCookieName = asRememberCookieName s
, rememberPeriod = asRememberPeriod s
, siteKey = key
, lockout = asLockout s
, randomNumberGenerator = rng
}
------------------------------------------------------------------------------
-- | Load/create a datafile into memory cache and return the manager.
--
-- This data type can be used by itself for batch/non-handler processing.
mkJsonAuthMgr :: FilePath -> IO JsonFileAuthManager
mkJsonAuthMgr fp = do
db <- loadUserCache fp
let db' = case db of
Left e -> error e
Right x -> x
cache <- newTVarIO db'
return $! JsonFileAuthManager {
memcache = cache
, dbfile = fp
}
------------------------------------------------------------------------------
type UserIdCache = Map UserId AuthUser
instance ToJSON UserIdCache where
toJSON m = toJSON $ HM.toList m
instance FromJSON UserIdCache where
parseJSON = fmap HM.fromList . parseJSON
------------------------------------------------------------------------------
type LoginUserCache = Map Text UserId
------------------------------------------------------------------------------
type RemTokenUserCache = Map Text UserId
------------------------------------------------------------------------------
-- | JSON user back-end stores the user data and indexes for login and token
-- based logins.
data UserCache = UserCache {
uidCache :: UserIdCache -- ^ the actual datastore
, loginCache :: LoginUserCache -- ^ fast lookup for login field
, tokenCache :: RemTokenUserCache -- ^ fast lookup for remember tokens
, uidCounter :: Int -- ^ user id counter
}
------------------------------------------------------------------------------
defUserCache :: UserCache
defUserCache = UserCache {
uidCache = HM.empty
, loginCache = HM.empty
, tokenCache = HM.empty
, uidCounter = 0
}
------------------------------------------------------------------------------
loadUserCache :: FilePath -> IO (Either String UserCache)
loadUserCache fp = do
chk <- doesFileExist fp
case chk of
True -> do
d <- B.readFile fp
case Atto.parseOnly json d of
Left e -> return $! Left $
"Can't open JSON auth backend. Error: " ++ e
Right v -> case fromJSON v of
Error e -> return $! Left $
"Malformed JSON auth data store. Error: " ++ e
Success db -> return $! Right db
False -> do
putStrLn "User JSON datafile not found. Creating a new one."
return $ Right defUserCache
------------------------------------------------------------------------------
data JsonFileAuthManager = JsonFileAuthManager {
memcache :: TVar UserCache
, dbfile :: FilePath
}
------------------------------------------------------------------------------
jsonFileSave :: JsonFileAuthManager
-> AuthUser
-> IO (Either AuthFailure AuthUser)
jsonFileSave mgr u = do
now <- getCurrentTime
oldByLogin <- lookupByLogin mgr (userLogin u)
oldById <- case userId u of
Nothing -> return Nothing
Just x -> lookupByUserId mgr x
res <- atomically $ do
cache <- readTVar (memcache mgr)
res <- case userId u of
Nothing -> create cache now oldByLogin
Just _ -> update cache now oldById
case res of
Left e -> return $! Left e
Right (cache', u') -> do
writeTVar (memcache mgr) cache'
return $! Right $! (cache', u')
case res of
Left _ -> return $! Left BackendError
Right (cache', u') -> do
dumpToDisk cache'
return $! Right u'
where
--------------------------------------------------------------------------
create :: UserCache
-> UTCTime
-> (Maybe AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
create cache now old = do
case old of
Just _ -> return $! Left DuplicateLogin
Nothing -> do
new <- do
let uid' = UserId . showT $ uidCounter cache + 1
let u' = u { userUpdatedAt = Just now, userId = Just uid' }
return $! cache {
uidCache = HM.insert uid' u' $ uidCache cache
, loginCache = HM.insert (userLogin u') uid' $ loginCache cache
, tokenCache = case userRememberToken u' of
Nothing -> tokenCache cache
Just x -> HM.insert x uid' $ tokenCache cache
, uidCounter = uidCounter cache + 1
}
return $! Right (new, getLastUser new)
--------------------------------------------------------------------------
-- lookup old record, see what's changed and update indexes accordingly
update :: UserCache
-> UTCTime
-> (Maybe AuthUser)
-> STM (Either AuthFailure (UserCache, AuthUser))
update cache now old =
case old of
Nothing -> return $! Left UserNotFound
Just x -> do
let oldLogin = userLogin x
let oldToken = userRememberToken x
let uid = fromJust $ userId u
let newLogin = userLogin u
let newToken = userRememberToken u
let lc = if oldLogin /= userLogin u
then HM.insert newLogin uid $
HM.delete oldLogin $
loginCache cache
else loginCache cache
let tc = if oldToken /= newToken && isJust oldToken
then HM.delete (fromJust oldToken) $ loginCache cache
else tokenCache cache
let tc' = case newToken of
Just t -> HM.insert t uid tc
Nothing -> tc
let u' = u { userUpdatedAt = Just now }
let new = cache {
uidCache = HM.insert uid u' $ uidCache cache
, loginCache = lc
, tokenCache = tc'
}
return $! Right (new, u')
--------------------------------------------------------------------------
-- Sync user database to disk
-- Need to implement a mutex here; simult syncs could screw things up
dumpToDisk c = LB.writeFile (dbfile mgr) (encode c)
--------------------------------------------------------------------------
-- Gets the last added user
getLastUser cache = maybe e id $ getUser cache uid
where
uid = UserId . showT $ uidCounter cache
e = error "getLastUser failed. This should not happen."
------------------------------------------------------------------------------
instance IAuthBackend JsonFileAuthManager where
save = jsonFileSave
destroy = error "JsonFile: destroy is not yet implemented"
lookupByUserId mgr uid = withCache mgr f
where
f cache = getUser cache uid
lookupByLogin mgr login = withCache mgr f
where
f cache = getUid >>= getUser cache
where getUid = HM.lookup login (loginCache cache)
lookupByRememberToken mgr token = withCache mgr f
where
f cache = getUid >>= getUser cache
where
getUid = HM.lookup token (tokenCache cache)
------------------------------------------------------------------------------
withCache :: JsonFileAuthManager -> (UserCache -> a) -> IO a
withCache mgr f = atomically $ do
cache <- readTVar $ memcache mgr
return $! f cache
------------------------------------------------------------------------------
getUser :: UserCache -> UserId -> Maybe AuthUser
getUser cache uid = HM.lookup uid (uidCache cache)
------------------------------------------------------------------------------
showT :: Int -> Text
showT = T.pack . show
--------------------
-- JSON Instances --
--------------------
------------------------------------------------------------------------------
instance ToJSON UserCache where
toJSON uc = object
[ "uidCache" .= uidCache uc
, "loginCache" .= loginCache uc
, "tokenCache" .= tokenCache uc
, "uidCounter" .= uidCounter uc
]
------------------------------------------------------------------------------
instance FromJSON UserCache where
parseJSON (Object v) =
UserCache
<$> v .: "uidCache"
<*> v .: "loginCache"
<*> v .: "tokenCache"
<*> v .: "uidCounter"
parseJSON _ = error "Unexpected JSON input"