1 {-# LANGUAGE OverloadedStrings, TemplateHaskell, QuasiQuotes, DataKinds #-} 2 module Databrary.Model.Token 3 ( module Databrary.Model.Token.Types 4 , loginTokenId 5 , lookupLoginToken 6 , createLoginToken 7 , removeLoginToken 8 , lookupSession 9 , createSession 10 , removeSession 11 , lookupUpload 12 , createUpload 13 , removeUpload 14 , cleanTokens 15 ) where 16 17 import Control.Monad (when, void, (<=<)) 18 import Control.Monad.IO.Class (MonadIO, liftIO) 19 import Data.ByteArray (Bytes) 20 import Data.ByteArray.Encoding (convertToBase, Base(Base64URLUnpadded)) 21 import qualified Data.ByteString as BS 22 import Data.Int (Int64) 23 import qualified Data.String 24 import Database.PostgreSQL.Typed.Types 25 -- import Database.PostgreSQL.Typed (pgSQL) 26 -- import Database.PostgreSQL.Typed.Query (simpleQueryFlags) 27 28 import Databrary.Ops 29 import Databrary.Has 30 import Databrary.Files (removeFile) 31 import Databrary.Service.Types 32 import Databrary.Service.Entropy 33 import Databrary.Service.Crypto 34 import Databrary.Service.DB 35 import Databrary.Store.Types 36 import Databrary.Store.Upload 37 -- import Databrary.Model.SQL (selectQuery) 38 -- import Databrary.Model.SQL.Select (makeQuery, selectOutput) 39 import Databrary.Model.Offset 40 import Databrary.Model.Id.Types 41 import Databrary.Model.Identity.Types 42 import Databrary.Model.Volume.Types 43 import Databrary.Model.Party 44 import Databrary.Model.Party.SQL 45 import Databrary.Model.Permission.Types 46 import Databrary.Model.Token.Types 47 48 loginTokenId :: (MonadHas Entropy c m, MonadHas Secret c m, MonadIO m) => LoginToken -> m (Id LoginToken) 49 loginTokenId tok = Id <$> sign (unId (view tok :: Id Token)) 50 51 -- | Attempt to find the matching one time login token for newly registered accounts, 52 -- so that the user can view the password entry form as well as perform the password update. 53 -- Retrieve the site auth with access deduced from inherited authorizations. 54 -- Wrap the site auth in an AccountToken with the corresponding public token value and expiration. 55 -- Wrap the AccountToken in a LoginToken with a boolean indicating ???? . Seems to be always true. 56 lookupLoginToken :: (MonadDB c m, MonadHas Secret c m) => Id LoginToken -> m (Maybe LoginToken) 57 lookupLoginToken = 58 flatMapM (\t -> getToken t) -- dbQuery1 $(selectQuery selectLoginToken "$!WHERE login_token.token = ${t} AND expires > CURRENT_TIMESTAMP")) 59 <=< unSign . unId 60 61 getToken :: (MonadDB c m) => BS.ByteString -> m (Maybe LoginToken) 62 getToken t = do 63 let _tenv_aar3U = unknownPGTypeEnv 64 mRow <- mapRunPrepQuery1 65 ((\ _p_aar3V -> 66 (Data.String.fromString 67 "SELECT login_token.token,login_token.expires,party.id,party.name,party.prename,party.orcid,party.affiliation,party.url,account.email,account.password,authorize_view.site,authorize_view.member,login_token.password FROM login_token JOIN party JOIN account USING (id) LEFT JOIN authorize_view ON account.id = authorize_view.child AND authorize_view.parent = 0 ON login_token.account = account.id WHERE login_token.token = $1 AND expires > CURRENT_TIMESTAMP", 68 [pgEncodeParameter 69 _tenv_aar3U (PGTypeProxy :: PGTypeName "bpchar") _p_aar3V], 70 [pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "bpchar"), 71 pgBinaryColumn 72 _tenv_aar3U (PGTypeProxy :: PGTypeName "timestamp with time zone"), 73 pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "integer"), 74 pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "text"), 75 pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "text"), 76 pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "bpchar"), 77 pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "text"), 78 pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "text"), 79 pgBinaryColumn 80 _tenv_aar3U (PGTypeProxy :: PGTypeName "character varying"), 81 pgBinaryColumn 82 _tenv_aar3U (PGTypeProxy :: PGTypeName "character varying"), 83 pgBinaryColumn 84 _tenv_aar3U (PGTypeProxy :: PGTypeName "permission"), 85 pgBinaryColumn 86 _tenv_aar3U (PGTypeProxy :: PGTypeName "permission"), 87 pgBinaryColumn _tenv_aar3U (PGTypeProxy :: PGTypeName "boolean")])) 88 t) 89 (\ 90 [_ctoken_aar3W, 91 _cexpires_aar3X, 92 _cid_aar3Y, 93 _cname_aar3Z, 94 _cprename_aar40, 95 _corcid_aar41, 96 _caffiliation_aar42, 97 _curl_aar43, 98 _cemail_aar44, 99 _cpassword_aar45, 100 _csite_aar46, 101 _cmember_aar47, 102 _cpassword_aar48] 103 -> (pgDecodeColumnNotNull 104 _tenv_aar3U (PGTypeProxy :: PGTypeName "bpchar") _ctoken_aar3W, 105 pgDecodeColumnNotNull 106 _tenv_aar3U 107 (PGTypeProxy :: PGTypeName "timestamp with time zone") 108 _cexpires_aar3X, 109 pgDecodeColumnNotNull 110 _tenv_aar3U (PGTypeProxy :: PGTypeName "integer") _cid_aar3Y, 111 pgDecodeColumnNotNull 112 _tenv_aar3U (PGTypeProxy :: PGTypeName "text") _cname_aar3Z, 113 pgDecodeColumnNotNull 114 _tenv_aar3U (PGTypeProxy :: PGTypeName "text") _cprename_aar40, 115 pgDecodeColumnNotNull 116 _tenv_aar3U (PGTypeProxy :: PGTypeName "bpchar") _corcid_aar41, 117 pgDecodeColumnNotNull 118 _tenv_aar3U 119 (PGTypeProxy :: PGTypeName "text") 120 _caffiliation_aar42, 121 pgDecodeColumnNotNull 122 _tenv_aar3U (PGTypeProxy :: PGTypeName "text") _curl_aar43, 123 pgDecodeColumnNotNull 124 _tenv_aar3U 125 (PGTypeProxy :: PGTypeName "character varying") 126 _cemail_aar44, 127 pgDecodeColumnNotNull 128 _tenv_aar3U 129 (PGTypeProxy :: PGTypeName "character varying") 130 _cpassword_aar45, 131 pgDecodeColumnNotNull 132 _tenv_aar3U (PGTypeProxy :: PGTypeName "permission") _csite_aar46, 133 pgDecodeColumnNotNull 134 _tenv_aar3U 135 (PGTypeProxy :: PGTypeName "permission") 136 _cmember_aar47, 137 pgDecodeColumnNotNull 138 _tenv_aar3U 139 (PGTypeProxy :: PGTypeName "boolean") 140 _cpassword_aar48)) 141 pure 142 (fmap 143 (\ (vtoken_aar3F, vexpires_aar3G, vid_aar3H, vname_aar3I, 144 vprename_aar3J, vorcid_aar3K, vaffiliation_aar3L, vurl_aar3M, 145 vemail_aar3N, vpassword_aar3O, vsite_aar3P, vmember_aar3Q, 146 vpassword_aar3R) 147 -> LoginToken 148 (AccountToken 149 (Token vtoken_aar3F vexpires_aar3G) 150 (makeSiteAuth 151 (makeUserAccount 152 (makeAccount 153 (PartyRow 154 vid_aar3H 155 vname_aar3I 156 vprename_aar3J 157 vorcid_aar3K 158 vaffiliation_aar3L 159 vurl_aar3M) 160 (Account vemail_aar3N))) 161 vpassword_aar3O 162 (do { cm_aar3S <- vsite_aar3P; 163 cm_aar3T <- vmember_aar3Q; 164 Just (Access cm_aar3S cm_aar3T) }))) 165 vpassword_aar3R) 166 mRow) 167 168 -- | Guts of loading a user and its authorizations during each request, when receiving a logged in session token. 169 -- Find the active session in the sessions table. 170 -- Join the session account with its party and account information. 171 -- Join the party with the authorization it has been granted on the databrary site (party 0), if any. 172 -- Ultimately, a Session object will be created with an access object built up from the user's 173 -- effective, inherited permissions on the databrary site (party 0). 174 -- Note that whenever lookupSession is called, we will be in a bootstrap phase of request handling, where 175 -- the application hasn't attach an identity (MonadHasIdentity) to the context of actions yet. 176 lookupSession :: MonadDB c m => BS.ByteString -> m (Maybe Session) 177 lookupSession tok = do 178 let _tenv_a7Etn = unknownPGTypeEnv 179 mRow <- 180 dbQuery1 181 (mapPrepQuery 182 ((\ _p_a7Eto -> 183 ((Data.String.fromString 184 " SELECT \ 185 \ session.token,session.expires \ 186 \ ,party.id,party.name,party.prename,party.orcid,party.affiliation,party.url\ 187 \ ,account.email,account.password\ 188 \ ,authorize_view.site,authorize_view.member\ 189 \ ,session.verf,session.superuser\ 190 \ FROM session\ 191 \ JOIN party\ 192 \ JOIN account USING (id)\ 193 \ LEFT JOIN authorize_view ON account.id = authorize_view.child AND authorize_view.parent = 0\ 194 \ ON session.account = account.id\ 195 \ WHERE session.token = $1\ 196 \ AND expires > CURRENT_TIMESTAMP"), 197 [Database.PostgreSQL.Typed.Types.pgEncodeParameter 198 _tenv_a7Etn 199 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 200 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 201 _p_a7Eto])) 202 tok) 203 (\ 204 [_ctoken_a7Etp, 205 _cexpires_a7Etq, 206 _cid_a7Etr, 207 _cname_a7Ets, 208 _cprename_a7Ett, 209 _corcid_a7Etu, 210 _caffiliation_a7Etv, 211 _curl_a7Etw, 212 _cemail_a7Etx, 213 _cpassword_a7Ety, 214 _csite_a7Etz, 215 _cmember_a7EtA, 216 _cverf_a7EtB, 217 _csuperuser_a7EtC] 218 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 219 _tenv_a7Etn 220 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 221 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 222 _ctoken_a7Etp, 223 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 224 _tenv_a7Etn 225 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 226 Database.PostgreSQL.Typed.Types.PGTypeName "timestamp with time zone") 227 _cexpires_a7Etq, 228 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 229 _tenv_a7Etn 230 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 231 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 232 _cid_a7Etr, 233 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 234 _tenv_a7Etn 235 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 236 Database.PostgreSQL.Typed.Types.PGTypeName "text") 237 _cname_a7Ets, 238 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 239 _tenv_a7Etn 240 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 241 Database.PostgreSQL.Typed.Types.PGTypeName "text") 242 _cprename_a7Ett, 243 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 244 _tenv_a7Etn 245 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 246 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 247 _corcid_a7Etu, 248 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 249 _tenv_a7Etn 250 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 251 Database.PostgreSQL.Typed.Types.PGTypeName "text") 252 _caffiliation_a7Etv, 253 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 254 _tenv_a7Etn 255 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 256 Database.PostgreSQL.Typed.Types.PGTypeName "text") 257 _curl_a7Etw, 258 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 259 _tenv_a7Etn 260 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 261 Database.PostgreSQL.Typed.Types.PGTypeName "character varying") 262 _cemail_a7Etx, 263 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 264 _tenv_a7Etn 265 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 266 Database.PostgreSQL.Typed.Types.PGTypeName "character varying") 267 _cpassword_a7Ety, 268 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 269 _tenv_a7Etn 270 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 271 Database.PostgreSQL.Typed.Types.PGTypeName "permission") 272 _csite_a7Etz, 273 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 274 _tenv_a7Etn 275 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 276 Database.PostgreSQL.Typed.Types.PGTypeName "permission") 277 _cmember_a7EtA, 278 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 279 _tenv_a7Etn 280 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 281 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 282 _cverf_a7EtB, 283 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 284 _tenv_a7Etn 285 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 286 Database.PostgreSQL.Typed.Types.PGTypeName "boolean") 287 _csuperuser_a7EtC))) 288 pure 289 (fmap 290 (\ (vtoken_a7Esb, vexpires_a7Esc, vid_a7Esd, vname_a7Ese, 291 vprename_a7Esf, vorcid_a7Esg, vaffiliation_a7Esh, vurl_a7Esi, 292 vemail_a7Esj, vpassword_a7Esk, vsite_a7Esl, vmember_a7Esm, 293 vverf_a7Esn, vsuperuser_a7Eso) 294 -> Session 295 (AccountToken 296 (Token vtoken_a7Esb vexpires_a7Esc) 297 (Databrary.Model.Party.SQL.makeSiteAuth 298 (Databrary.Model.Party.SQL.makeUserAccount 299 -- partially apply makeAccount with party row and account, then feed into makeUserAccount 300 (Databrary.Model.Party.SQL.makeAccount 301 (PartyRow 302 vid_a7Esd 303 vname_a7Ese 304 vprename_a7Esf 305 vorcid_a7Esg 306 vaffiliation_a7Esh 307 vurl_a7Esi) 308 (Account vemail_a7Esj))) 309 vpassword_a7Esk 310 -- most likely there will be some authorization inherited from a parent user/group to this user 311 -- leading to the databrary site (party 0), use that inherited authorization's access values 312 (do { cm_a7EsD <- vsite_a7Esl; 313 cm_a7EsE <- vmember_a7Esm; 314 Just 315 (Databrary.Model.Permission.Types.Access cm_a7EsD cm_a7EsE) }))) 316 vverf_a7Esn 317 vsuperuser_a7Eso) 318 mRow) 319 320 lookupUpload :: (MonadDB c m, MonadHasIdentity c m) => BS.ByteString -> m (Maybe Upload) 321 lookupUpload tok = do 322 let _tenv_aar6E = unknownPGTypeEnv 323 auth <- peek 324 -- dbQuery1 $ fmap ($ auth) $(selectQuery selectUpload "$!WHERE upload.token = ${tok} AND expires > CURRENT_TIMESTAMP AND upload.account = ${view auth :: Id Party}") 325 mRow <- mapRunPrepQuery1 326 ((\ _p_aar6F _p_aar6G -> 327 (Data.String.fromString 328 "SELECT upload.token,upload.expires,upload.filename,upload.size FROM upload WHERE upload.token = $1 AND expires > CURRENT_TIMESTAMP AND upload.account = $2", 329 [pgEncodeParameter 330 _tenv_aar6E (PGTypeProxy :: PGTypeName "bpchar") _p_aar6F, 331 pgEncodeParameter 332 _tenv_aar6E (PGTypeProxy :: PGTypeName "integer") _p_aar6G], 333 [pgBinaryColumn _tenv_aar6E (PGTypeProxy :: PGTypeName "bpchar"), 334 pgBinaryColumn 335 _tenv_aar6E (PGTypeProxy :: PGTypeName "timestamp with time zone"), 336 pgBinaryColumn _tenv_aar6E (PGTypeProxy :: PGTypeName "text"), 337 pgBinaryColumn _tenv_aar6E (PGTypeProxy :: PGTypeName "bigint")])) 338 tok (view auth :: Id Party)) 339 (\ 340 [_ctoken_aar6H, _cexpires_aar6I, _cfilename_aar6J, _csize_aar6K] 341 -> (pgDecodeColumnNotNull 342 _tenv_aar6E (PGTypeProxy :: PGTypeName "bpchar") _ctoken_aar6H, 343 pgDecodeColumnNotNull 344 _tenv_aar6E 345 (PGTypeProxy :: PGTypeName "timestamp with time zone") 346 _cexpires_aar6I, 347 pgDecodeColumnNotNull 348 _tenv_aar6E (PGTypeProxy :: PGTypeName "text") _cfilename_aar6J, 349 pgDecodeColumnNotNull 350 _tenv_aar6E (PGTypeProxy :: PGTypeName "bigint") _csize_aar6K)) 351 pure 352 (fmap 353 (\ (vtoken_aar5q, vexpires_aar5r, vfilename_aar5s, vsize_aar5t) 354 -> makeUpload 355 (Token vtoken_aar5q vexpires_aar5r) vfilename_aar5s vsize_aar5t 356 auth) 357 mRow) 358 359 entropyBase64 :: Int -> Entropy -> IO BS.ByteString 360 entropyBase64 n e = (convertToBase Base64URLUnpadded :: Bytes -> BS.ByteString) <$> entropyBytes n e 361 362 createToken :: (MonadHas Entropy c m, MonadDB c m) => (Id Token -> DBM a) -> m a 363 createToken insert = do 364 e <- peek 365 let loop = do 366 tok <- liftIO $ Id <$> entropyBase64 24 e 367 let _tenv_a7EwN = unknownPGTypeEnv 368 r <- dbQuery1 -- [pgSQL|SELECT token FROM token WHERE token = ${tok}|] 369 (mapQuery2 370 ((\ _p_a7EwO -> 371 (BS.concat 372 [Data.String.fromString "SELECT token FROM token WHERE token = ", 373 Database.PostgreSQL.Typed.Types.pgEscapeParameter 374 _tenv_a7EwN 375 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 376 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 377 _p_a7EwO])) 378 tok) 379 (\ [_ctoken_a7EwP] 380 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 381 _tenv_a7EwN 382 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 383 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 384 _ctoken_a7EwP))) 385 case r `asTypeOf` Just tok of 386 Nothing -> insert tok 387 Just _ -> loop 388 dbTransaction $ do 389 _ <- dbExecuteSimple "LOCK TABLE token IN SHARE ROW EXCLUSIVE MODE" 390 loop 391 392 -- | Delete any prior login token that was generated for this account, then generate a new login token. 393 -- Used when generating the login token for reset password email. paswd will always be True. 394 createLoginToken :: (MonadHas Entropy c m, MonadDB c m) => SiteAuth -> Bool -> m LoginToken 395 createLoginToken auth passwd = do 396 let (_tenv_a7Ey3, _tenv_a7Ez6) = (unknownPGTypeEnv, unknownPGTypeEnv) 397 when passwd $ void $ dbExecute -- [pgSQL|DELETE FROM login_token WHERE account = ${view auth :: Id Party} AND password|] 398 (mapQuery2 399 ((\ _p_a7Ey4 -> 400 (BS.concat 401 [Data.String.fromString "DELETE FROM login_token WHERE account = ", 402 Database.PostgreSQL.Typed.Types.pgEscapeParameter 403 _tenv_a7Ey3 404 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 405 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 406 _p_a7Ey4, 407 Data.String.fromString " AND password"])) 408 (view auth :: Id Party)) 409 (\[] -> ())) 410 (tok, ex) <- createToken $ \tok -> 411 dbQuery1' -- [pgSQL|INSERT INTO login_token (token, account, password) VALUES (${tok}, ${view auth :: Id Party}, ${passwd}) RETURNING token, expires|] 412 (mapQuery2 413 ((\ _p_a7Ez7 _p_a7Ez8 _p_a7Ez9 -> 414 (BS.concat 415 [Data.String.fromString 416 "INSERT INTO login_token (token, account, password) VALUES (", 417 Database.PostgreSQL.Typed.Types.pgEscapeParameter 418 _tenv_a7Ez6 419 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 420 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 421 _p_a7Ez7, 422 Data.String.fromString ", ", 423 Database.PostgreSQL.Typed.Types.pgEscapeParameter 424 _tenv_a7Ez6 425 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 426 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 427 _p_a7Ez8, 428 Data.String.fromString ", ", 429 Database.PostgreSQL.Typed.Types.pgEscapeParameter 430 _tenv_a7Ez6 431 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 432 Database.PostgreSQL.Typed.Types.PGTypeName "boolean") 433 _p_a7Ez9, 434 Data.String.fromString ") RETURNING token, expires"])) 435 tok (view auth :: Id Party) passwd) 436 (\[_ctoken_a7Eza, _cexpires_a7Ezb] 437 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 438 _tenv_a7Ez6 439 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 440 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 441 _ctoken_a7Eza, 442 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 443 _tenv_a7Ez6 444 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 445 Database.PostgreSQL.Typed.Types.PGTypeName "timestamp with time zone") 446 _cexpires_a7Ezb))) 447 return $ LoginToken 448 { loginAccountToken = AccountToken 449 { accountToken = Token tok ex 450 , tokenAccount = auth 451 } 452 , loginPasswordToken = passwd 453 } 454 455 sessionDuration :: Bool -> Offset 456 sessionDuration False = 7*24*60*60 457 sessionDuration True = 30*60 458 459 createSession :: (MonadHas Entropy c m, MonadDB c m) => SiteAuth -> Bool -> m Session 460 createSession auth su = do 461 e <- peek 462 (tok, ex, verf) <- createToken $ \tok -> do 463 let _tenv_a7EzQ = unknownPGTypeEnv 464 verf <- liftIO $ entropyBase64 12 e 465 dbQuery1' -- [pgSQL|INSERT INTO session (token, expires, account, superuser, verf) VALUES (${tok}, CURRENT_TIMESTAMP + ${sessionDuration su}::interval, ${view auth :: Id Party}, ${su}, ${verf}) RETURNING token, expires, verf|] 466 (mapQuery2 467 ((\ _p_a7EzR _p_a7EzS _p_a7EzT _p_a7EzU _p_a7EzV -> 468 (BS.concat 469 [Data.String.fromString 470 "INSERT INTO session (token, expires, account, superuser, verf) VALUES (", 471 Database.PostgreSQL.Typed.Types.pgEscapeParameter 472 _tenv_a7EzQ 473 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 474 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 475 _p_a7EzR, 476 Data.String.fromString ", CURRENT_TIMESTAMP + ", 477 Database.PostgreSQL.Typed.Types.pgEscapeParameter 478 _tenv_a7EzQ 479 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 480 Database.PostgreSQL.Typed.Types.PGTypeName "interval") 481 _p_a7EzS, 482 Data.String.fromString "::interval, ", 483 Database.PostgreSQL.Typed.Types.pgEscapeParameter 484 _tenv_a7EzQ 485 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 486 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 487 _p_a7EzT, 488 Data.String.fromString ", ", 489 Database.PostgreSQL.Typed.Types.pgEscapeParameter 490 _tenv_a7EzQ 491 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 492 Database.PostgreSQL.Typed.Types.PGTypeName "boolean") 493 _p_a7EzU, 494 Data.String.fromString ", ", 495 Database.PostgreSQL.Typed.Types.pgEscapeParameter 496 _tenv_a7EzQ 497 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 498 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 499 _p_a7EzV, 500 Data.String.fromString ") RETURNING token, expires, verf"])) 501 tok 502 (sessionDuration su) 503 (view auth :: Id Party) 504 su 505 verf) 506 (\ [_ctoken_a7EzW, _cexpires_a7EzX, _cverf_a7EzY] 507 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 508 _tenv_a7EzQ 509 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 510 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 511 _ctoken_a7EzW, 512 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 513 _tenv_a7EzQ 514 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 515 Database.PostgreSQL.Typed.Types.PGTypeName "timestamp with time zone") 516 _cexpires_a7EzX, 517 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 518 _tenv_a7EzQ 519 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 520 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 521 _cverf_a7EzY))) 522 return $ Session 523 { sessionAccountToken = AccountToken 524 { accountToken = Token tok ex 525 , tokenAccount = auth 526 } 527 , sessionSuperuser = su 528 , sessionVerf = verf 529 } 530 531 createUpload :: (MonadHas Entropy c m, MonadDB c m, MonadHasIdentity c m) => Volume -> BS.ByteString -> Int64 -> m Upload 532 createUpload vol name size = do 533 auth <- peek 534 let _tenv_a7EBb = unknownPGTypeEnv 535 (tok, ex) <- createToken $ \tok -> 536 dbQuery1' -- [pgSQL|INSERT INTO upload (token, account, volume, filename, size) VALUES (${tok}, ${view auth :: Id Party}, ${volumeId $ volumeRow vol}, ${name}, ${size}) RETURNING token, expires|] 537 (mapQuery2 538 ((\ _p_a7EBc _p_a7EBd _p_a7EBe _p_a7EBf _p_a7EBg -> 539 (BS.concat 540 [Data.String.fromString 541 "INSERT INTO upload (token, account, volume, filename, size) VALUES (", 542 Database.PostgreSQL.Typed.Types.pgEscapeParameter 543 _tenv_a7EBb 544 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 545 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 546 _p_a7EBc, 547 Data.String.fromString ", ", 548 Database.PostgreSQL.Typed.Types.pgEscapeParameter 549 _tenv_a7EBb 550 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 551 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 552 _p_a7EBd, 553 Data.String.fromString ", ", 554 Database.PostgreSQL.Typed.Types.pgEscapeParameter 555 _tenv_a7EBb 556 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 557 Database.PostgreSQL.Typed.Types.PGTypeName "integer") 558 _p_a7EBe, 559 Data.String.fromString ", ", 560 Database.PostgreSQL.Typed.Types.pgEscapeParameter 561 _tenv_a7EBb 562 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 563 Database.PostgreSQL.Typed.Types.PGTypeName "text") 564 _p_a7EBf, 565 Data.String.fromString ", ", 566 Database.PostgreSQL.Typed.Types.pgEscapeParameter 567 _tenv_a7EBb 568 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 569 Database.PostgreSQL.Typed.Types.PGTypeName "bigint") 570 _p_a7EBg, 571 Data.String.fromString ") RETURNING token, expires"])) 572 tok (view auth :: Id Party) (volumeId $ volumeRow vol) name size) 573 (\ [_ctoken_a7EBh, _cexpires_a7EBi] 574 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 575 _tenv_a7EBb 576 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 577 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 578 _ctoken_a7EBh, 579 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 580 _tenv_a7EBb 581 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 582 Database.PostgreSQL.Typed.Types.PGTypeName "timestamp with time zone") 583 _cexpires_a7EBi))) 584 return $ Upload 585 { uploadAccountToken = AccountToken 586 { accountToken = Token tok ex 587 , tokenAccount = auth 588 } 589 , uploadFilename = name 590 , uploadSize = size 591 } 592 593 removeLoginToken :: MonadDB c m => LoginToken -> m Bool 594 removeLoginToken tok = do 595 let _tenv_a7EBQ = unknownPGTypeEnv 596 dbExecute1 -- [pgSQL|DELETE FROM login_token WHERE token = ${view tok :: Id Token}|] 597 (mapQuery2 598 ((\ _p_a7EBR -> 599 (BS.concat 600 [Data.String.fromString "DELETE FROM login_token WHERE token = ", 601 Database.PostgreSQL.Typed.Types.pgEscapeParameter 602 _tenv_a7EBQ 603 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 604 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 605 _p_a7EBR])) 606 (view tok :: Id Token)) 607 (\[] -> ())) 608 609 removeSession :: (MonadDB c m) => Session -> m Bool 610 removeSession tok = do 611 let _tenv_a7EDh = unknownPGTypeEnv 612 dbExecute1 -- [pgSQL|DELETE FROM session WHERE token = ${view tok :: Id Token}|] 613 (mapQuery2 614 ((\ _p_a7EDi -> 615 (BS.concat 616 [Data.String.fromString "DELETE FROM session WHERE token = ", 617 Database.PostgreSQL.Typed.Types.pgEscapeParameter 618 _tenv_a7EDh 619 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 620 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 621 _p_a7EDi])) 622 (view tok :: Id Token)) 623 (\ [] -> ())) 624 625 removeUploadFile :: (MonadStorage c m) => Upload -> m Bool 626 removeUploadFile tok = liftIO . removeFile =<< peeks (uploadFile tok) 627 628 removeUpload :: (MonadDB c m, MonadStorage c m) => Upload -> m Bool 629 removeUpload tok = do 630 let _tenv_a7ER0 = unknownPGTypeEnv 631 r <- dbExecute1 --[pgSQL|DELETE FROM upload WHERE token = ${view tok :: Id Token}|] 632 (mapQuery2 633 ((\ _p_a7ER1 -> 634 (BS.concat 635 [Data.String.fromString "DELETE FROM upload WHERE token = ", 636 Database.PostgreSQL.Typed.Types.pgEscapeParameter 637 _tenv_a7ER0 638 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 639 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 640 _p_a7ER1])) 641 (view tok :: Id Token)) 642 (\[] -> ())) 643 when r $ void $ removeUploadFile tok 644 return r 645 646 cleanTokens :: (MonadDB c m, MonadStorage c m) => m () 647 cleanTokens = do 648 -- toks <- dbQuery $ ($ nobodySiteAuth) <$> $(makeQuery simpleQueryFlags ("DELETE FROM upload WHERE expires < CURRENT_TIMESTAMP RETURNING " ++) (selectOutput selectUpload)) 649 let _tenv_a7EWZ = unknownPGTypeEnv 650 rows <- dbQuery 651 (mapQuery2 652 (BS.concat 653 [Data.String.fromString 654 "DELETE FROM upload WHERE expires < CURRENT_TIMESTAMP RETURNING upload.token,upload.expires,upload.filename,upload.size"]) 655 (\ 656 [_ctoken_a7EX0, _cexpires_a7EX1, _cfilename_a7EX2, _csize_a7EX3] 657 -> (Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 658 _tenv_a7EWZ 659 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 660 Database.PostgreSQL.Typed.Types.PGTypeName "bpchar") 661 _ctoken_a7EX0, 662 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 663 _tenv_a7EWZ 664 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 665 Database.PostgreSQL.Typed.Types.PGTypeName "timestamp with time zone") 666 _cexpires_a7EX1, 667 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 668 _tenv_a7EWZ 669 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 670 Database.PostgreSQL.Typed.Types.PGTypeName "text") 671 _cfilename_a7EX2, 672 Database.PostgreSQL.Typed.Types.pgDecodeColumnNotNull 673 _tenv_a7EWZ 674 (Database.PostgreSQL.Typed.Types.PGTypeProxy :: 675 Database.PostgreSQL.Typed.Types.PGTypeName "bigint") 676 _csize_a7EX3))) 677 let toks = 678 fmap (\mkTok -> mkTok nobodySiteAuth) 679 (fmap 680 (\ (vtoken_a7EVR, vexpires_a7EVS, vfilename_a7EVT, vsize_a7EVU) 681 -> makeUpload 682 (Token vtoken_a7EVR vexpires_a7EVS) vfilename_a7EVT vsize_a7EVU) 683 rows) 684 mapM_ removeUploadFile toks 685 dbExecute_ "DELETE FROM token WHERE expires < CURRENT_TIMESTAMP"